gcl/0000755000175000017500000000000012241155623010240 5ustar cammcammgcl/dos/0000755000175000017500000000000012240167764011035 5ustar cammcammgcl/dos/read.s0000755000175000017500000000202012240167764012131 0ustar cammcamm/* This is file READ.S */ /* ** Copyright (C) 1991 DJ Delorie, 24 Kirsten Ave, Rochester NH 03867-2954 ** ** This file is distributed under the terms listed in the document ** "copying.dj", available from DJ Delorie at the address above. ** A copy of "copying.dj" should accompany this file; if not, a copy ** should be available from where this file was obtained. This file ** may not be distributed without a verbatim copy of "copying.dj". ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ .text .globl _read _read: pushl %eax movl $0,%eax cmp 8(%esp),%eax /* Is it stdin */ jne NotStdin cmp _interrupt_flag,%eax /* Any SIGINT Interrupt pending ? */ je NoInterrupt call _sigalrm NoInterrupt: NotStdin: popl %eax pushl %ebx pushl %esi pushl %edi movl 16(%esp),%ebx movl 20(%esp),%edx movl 24(%esp),%ecx movb $0x3f,%ah int $0x21 popl %edi popl %esi popl %ebx jb syscall_error ret gcl/dos/signal.h0000755000175000017500000001137612240167764012476 0ustar cammcamm/* This is file signal.h */ /* This file may have been modified by DJ Delorie (Jan 1991). If so, ** these modifications are Coyright (C) 1991 DJ Delorie, 24 Kirsten Ave, ** Rochester NH, 03867-2954, USA. */ /* This may look like C code, but it is really -*- C++ -*- */ /* Copyright (C) 1989 Free Software Foundation written by Doug Lea (dl@rocky.oswego.edu) This file is part of GNU CC. GNU CC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the GNU CC General Public License for full details. Everyone is granted permission to copy, modify and redistribute GNU CC, but only under the conditions described in the GNU CC General Public License. A copy of this license is supposed to have been given to you along with GNU CC so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. */ #ifndef _signal_h #pragma once #ifdef __cplusplus extern "C" { #endif /* This #define KERNEL hack gets around bad function prototypes on most */ /* systems. If not, you need to do some real work... */ /******************* * #define KERNEL * #include * #undef KERNEL ********************/ #ifndef _signal_h #define _signal_h 1 #endif /* The Interviews folks call this SignalHandler. Might as well conform. */ /* Beware: some systems think that SignalHandler returns int. */ typedef void (*SignalHandler) (); extern SignalHandler signal(int sig, SignalHandler action); extern SignalHandler sigset(int sig, SignalHandler action); extern SignalHandler ssignal(int sig, SignalHandler action); extern int gsignal (int sig); extern int kill (int pid, int sig); #ifndef hpux /* Interviews folks claim that hpux doesn't like these */ struct sigvec; extern int sigsetmask(int mask); extern int sigblock(int mask); extern int sigpause(int mask); extern int sigvec(int sig, struct sigvec* v, struct sigvec* prev); #endif /* The Interviews version also has these ... */ #define SignalBad ((SignalHandler)-1) #define SignalDefault ((SignalHandler)0) #define SignalIgnore ((SignalHandler)1) #ifdef __cplusplus } #endif #define _SIGNAL_H /** #include **/ #ifdef _SIGNAL_H /* This file defines the fake signal functions and signal number constants for 4.2 or 4.3 BSD-derived Unix system. */ #define SIG_DFL 0 #if 0 /*#ifndef SIG_DFL*/ /* Fake signal functions. These lines MUST be split! m4 will not change them otherwise. */ #define SIG_ERR /* Error return. */ \ ((void EXFUN((*), (int sig))) -1) #define SIG_DFL /* Default action. */ \ ((void EXFUN((*), (int sig))) 0) #define SIG_IGN /* Ignore signal. */ \ ((void EXFUN((*), (int sig))) 1) #endif /* Signals. */ #define SIGHUP 1 /* Hangup (POSIX). */ #define SIGINT 2 /* Interrupt (ANSI). */ #define SIGQUIT 3 /* Quit (POSIX). */ #define SIGILL 4 /* Illegal instruction (ANSI). */ #define SIGABRT SIGIOT /* Abort (ANSI). */ #define SIGTRAP 5 /* Trace trap (POSIX). */ #define SIGIOT 6 /* IOT trap (4.2 BSD). */ #define SIGEMT 7 /* EMT trap (4.2 BSD). */ #define SIGFPE 8 /* Floating-point exception (ANSI). */ #define SIGKILL 9 /* Kill, unblockable (POSIX). */ #define SIGBUS 10 /* Bus error (4.2 BSD). */ #define SIGSEGV 11 /* Segmentation violation (ANSI). */ #define SIGSYS 12 /* Bad argument to system call (4.2 BSD)*/ #define SIGPIPE 13 /* Broken pipe (POSIX). */ #define SIGALRM 14 /* Alarm clock (POSIX). */ #define SIGTERM 15 /* Termination (ANSI). */ #define SIGURG 16 /* Urgent condition on socket (4.2 BSD).*/ #define SIGSTOP 17 /* Stop, unblockable (POSIX). */ #define SIGTSTP 18 /* Keyboard stop (POSIX). */ #define SIGCONT 19 /* Continue (POSIX). */ #define SIGCHLD 20 /* Child status has changed (POSIX). */ #define SIGCLD SIGCHLD /* Same as SIGCHLD (System V). */ #define SIGTTIN 21 /* Background read from tty (POSIX). */ #define SIGTTOU 22 /* Background write to tty (POSIX). */ #define SIGIO 23 /* I/O now possible (4.2 BSD). */ #define SIGPOLL SIGIO /* Same as SIGIO? (SVID). */ #define SIGXCPU 24 /* CPU limit exceeded (4.2 BSD). */ #define SIGXFSZ 25 /* File size limit exceeded (4.2 BSD). */ #define SIGVTALRM 26 /* Virtual alarm clock (4.2 BSD). */ #define SIGPROF 27 /* Profiling alarm clock (4.2 BSD). */ #define SIGWINCH 28 /* Window size change (4.3 BSD, Sun). */ #define SIGUSR1 30 /* User-defined signal 1 (POSIX). */ #define SIGUSR2 31 /* User-defined signal 2 (POSIX). */ #endif /* included. */ #define _NSIG 32 /* Biggest signal number + 1. */ #endif gcl/dos/sigman.s0000755000175000017500000000241712240167764012506 0ustar cammcamm .globl _SignalManager _SignalManager: pushl %ebp movl %esp,%ebp /*------------------------------------------------------------------- ** Save all registers **-----------------------------------------------------------------*/ pushl %eax pushl %ebx pushl %ecx pushl %edx pushl %esi pushl %edi pushf pushl %es pushl %ds /* pushl %ss*/ pushl %fs pushl %gs /*-----------------------------------------------------------------*/ movl 4(%ebp), %eax shl $2, %eax movl _SignalTable(%eax), %ebx call %ebx /*------------------------------------------------------------------- ** Restore registers **-----------------------------------------------------------------*/ popl %gs popl %fs /* popl %ss*/ popl %ds popl %es popf popl %edi popl %esi popl %edx popl %ecx popl %ebx popl %eax /*------------------------------------------------------------------*/ popl %ebp add $4, %esp ret /* resume program */ gcl/dos/signal.c0000755000175000017500000000607012240167764012464 0ustar cammcamm/* This is file signal.c ** ** Copyright (C) 1992 Rami EL CHARIF and William SCHELTER ** rcharif@ma.utexas.edu wfs@cs.utexas.edu ** ** Signal package for djgpp versions 1.05, 1.06 ** version 0.0 alpha 03/30/1992 ** ** Send your comments or bugs report to ** rcharif@ma.utexas.edu or wfs@cs.utexas.edu ** ** This file is distributed WITHOUT ANY WARRANTY; without even the implied ** warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ #include #include #include unsigned long SignalTable[_NSIG + 1] = { (unsigned long)SIG_DFL, /* SIGHUP */ (unsigned long)SIG_DFL, /* SIGINT +*/ (unsigned long)SIG_DFL, /* SIGQUIT */ (unsigned long)SIG_DFL, /* SIGILL */ (unsigned long)SIG_DFL, /* SIGABRT */ (unsigned long)SIG_DFL, /* SIGTRAP */ (unsigned long)SIG_DFL, /* SIGIOT */ (unsigned long)SIG_DFL, /* SIGEMT */ (unsigned long)SIG_DFL, /* SIGFPE */ (unsigned long)SIG_DFL, /* SIGKILL */ (unsigned long)SIG_DFL, /* SIGBUS */ (unsigned long)SIG_DFL, /* SIGSEGV +*/ (unsigned long)SIG_DFL, /* SIGSYS */ (unsigned long)SIG_DFL, /* SIGPIPE */ (unsigned long)SIG_DFL, /* SIGALRM */ (unsigned long)SIG_DFL, /* SIGTERM */ (unsigned long)SIG_DFL, /* SIGURG */ (unsigned long)SIG_DFL, /* SIGSTOP */ (unsigned long)SIG_DFL, /* SIGTSTP */ (unsigned long)SIG_DFL, /* SIGCONT */ (unsigned long)SIG_DFL, /* SIGCHLD */ (unsigned long)SIG_DFL, /* SIGCLD */ (unsigned long)SIG_DFL, /* SIGTTIN */ (unsigned long)SIG_DFL, /* SIGTTOU */ (unsigned long)SIG_DFL, /* SIGIO */ (unsigned long)SIG_DFL, /* SIGPOLL */ (unsigned long)SIG_DFL, /* SIGXCPU */ (unsigned long)SIG_DFL, /* SIGXFSZ */ (unsigned long)SIG_DFL, /* SIGVTALRM */ (unsigned long)SIG_DFL, /* SIGPROF */ (unsigned long)SIG_DFL, /* SIGWINCH */ (unsigned long)SIG_DFL, /* SIGUSR1 */ (unsigned long)SIG_DFL /* SIGUSR2 */ }; SignalHandler signal(int sig, SignalHandler action) { extern void SignalManager(); union REGS in, out; SignalHandler hsigOld; in.h.ah = 1; in.h.al = sig; SignalTable[sig] = in.x.dx = (long)action; in.x.cx = (long)SignalManager; int86(0xfa, &in, &out); hsigOld = (SignalHandler)out.x.dx; return hsigOld; } void SigInst() { union REGS in, out; extern void SignalManager(); in.h.ah = 0; in.h.al = 0; in.x.dx = (long)SignalManager; #ifdef DEBUG_SIG printf("\nSignal Manager = %ld, %lx", in.x.dx, in.x.dx); #endif int86(0xfa, &in, &out); } #ifndef NO_SIG_ALARM unsigned int alarm(int culSeconds) { union REGS in, out; if (!culSeconds) { in.h.ah = 3; /* Reset alarm */ int86(0xfa, &in, &out); } else { in.h.ah = 2; in.x.dx = culSeconds; int86(0xfa, &in, &out); } return in.x.cx; } #else unsigned int alarm(int n) { return 0; } #endif gcl/dos/makefile0000644000175000017500000000040712240167764012536 0ustar cammcamm.SUFFIXES: .o .c HDIR = ../h OFLAG = -O ODIR = . -include ../makedefs DOS_ODIR=. CFLAGS = -I. -I$(HDIR) $(ODIR_DEBUG) .s.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c .c.o: $(CC) -c $(OFLAG) $(CFLAGS) $*.c OBJS = $(EXX_DOS) all: $(OBJS) clean: rm -f $(OBJS) gcl/dos/readme0000755000175000017500000000033612240167764012222 0ustar cammcamm This is the remnants of the port of akcl to dos under djgpp (version 1.06) Unfortunately djgpp has changed and so it is not so straightforward to make gcl work .. I would be happy if someone else does it! Bill Schelter gcl/dos/dostimes.c0000755000175000017500000000044512240167764013036 0ustar cammcamm#include #include #ifdef __ZTC__ #define HZ 100 #endif times(x) struct tms *x; { int hz; struct rusage ru; getrusage(RUSAGE_SELF,&ru); hz = ru.ru_utime.tv_sec * HZ + (ru.ru_utime.tv_usec *HZ)/1000000; x->tms_utime = hz; x->tms_stime = hz; return 0; } gcl/dos/dum_dos.c0000755000175000017500000000026512240167764012641 0ustar cammcamm#define DUM(a) int a(int n) { printf("dummy " #a " call %d\n",n); return 0;} DUM(profil) /* DUM(alarm) */ DUM(getpid) DUM(getuid) DUM(popen) DUM(pclose) DUM(getpwuid) DUM(getpwnam) gcl/config.guess0000755000175000017500000012763712240167764012610 0ustar cammcamm#! /bin/sh # Attempt to guess a canonical system name. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 # Free Software Foundation, Inc. timestamp='2009-12-30' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Per Bothner. Please send patches (context # diff format) to and include a ChangeLog # entry. # # This script attempts to guess a canonical system name similar to # config.sub. If it succeeds, it prints the system name on stdout, and # exits with 0. Otherwise, it exits with 1. # # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] Output the configuration name of the system \`$me' is run on. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" >&2 exit 1 ;; * ) break ;; esac done if test $# != 0; then echo "$me: too many arguments$help" >&2 exit 1 fi trap 'exit 1' 1 2 15 # CC_FOR_BUILD -- compiler used by this script. Note that the use of a # compiler to aid in system detection is discouraged as it requires # temporary files to be created and, as you can see below, it is a # headache to deal with in a portable fashion. # Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still # use `HOST_CC' if defined, but it is deprecated. # Portable tmp directory creation inspired by the Autoconf team. set_cc_for_build=' trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; : ${TMPDIR=/tmp} ; { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; dummy=$tmp/dummy ; tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; case $CC_FOR_BUILD,$HOST_CC,$CC in ,,) echo "int x;" > $dummy.c ; for c in cc gcc c89 c99 ; do if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then CC_FOR_BUILD="$c"; break ; fi ; done ; if test x"$CC_FOR_BUILD" = x ; then CC_FOR_BUILD=no_compiler_found ; fi ;; ,,*) CC_FOR_BUILD=$CC ;; ,*,*) CC_FOR_BUILD=$HOST_CC ;; esac ; set_cc_for_build= ;' # This is needed to find uname on a Pyramid OSx when run in the BSD universe. # (ghazi@noc.rutgers.edu 1994-08-24) if (test -f /.attbin/uname) >/dev/null 2>&1 ; then PATH=$PATH:/.attbin ; export PATH fi UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown # Note: order is significant - the case branches are not exclusive. case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in *:NetBSD:*:*) # NetBSD (nbsd) targets should (where applicable) match one or # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently # switched to ELF, *-*-netbsd* would select the old # object file format. This provides both forward # compatibility and a consistent mechanism for selecting the # object file format. # # Note: NetBSD doesn't particularly care about the vendor # portion of the name. We always set it to "unknown". sysctl="sysctl -n hw.machine_arch" UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ /usr/sbin/$sysctl 2>/dev/null || echo unknown)` case "${UNAME_MACHINE_ARCH}" in armeb) machine=armeb-unknown ;; arm*) machine=arm-unknown ;; sh3el) machine=shl-unknown ;; sh3eb) machine=sh-unknown ;; sh5el) machine=sh5le-unknown ;; *) machine=${UNAME_MACHINE_ARCH}-unknown ;; esac # The Operating System including object format, if it has switched # to ELF recently, or will in the future. case "${UNAME_MACHINE_ARCH}" in arm*|i386|m68k|ns32k|sh3*|sparc|vax) eval $set_cc_for_build if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ELF__ then # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). # Return netbsd for either. FIX? os=netbsd else os=netbsdelf fi ;; *) os=netbsd ;; esac # The OS release # Debian GNU/NetBSD machines have a different userland, and # thus, need a distinct triplet. However, they do not need # kernel version information, so it can be replaced with a # suitable tag, in the style of linux-gnu. case "${UNAME_VERSION}" in Debian*) release='-gnu' ;; *) release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` ;; esac # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: # contains redundant information, the shorter form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. echo "${machine}-${os}${release}" exit ;; *:OpenBSD:*:*) UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} exit ;; *:ekkoBSD:*:*) echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} exit ;; *:SolidBSD:*:*) echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} exit ;; macppc:MirBSD:*:*) echo powerpc-unknown-mirbsd${UNAME_RELEASE} exit ;; *:MirBSD:*:*) echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} exit ;; alpha:OSF1:*:*) case $UNAME_RELEASE in *4.0) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` ;; *5.*) UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` ;; esac # According to Compaq, /usr/sbin/psrinfo has been available on # OSF/1 and Tru64 systems produced since 1995. I hope that # covers most systems running today. This code pipes the CPU # types through head -n 1, so we only detect the type of CPU 0. ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` case "$ALPHA_CPU_TYPE" in "EV4 (21064)") UNAME_MACHINE="alpha" ;; "EV4.5 (21064)") UNAME_MACHINE="alpha" ;; "LCA4 (21066/21068)") UNAME_MACHINE="alpha" ;; "EV5 (21164)") UNAME_MACHINE="alphaev5" ;; "EV5.6 (21164A)") UNAME_MACHINE="alphaev56" ;; "EV5.6 (21164PC)") UNAME_MACHINE="alphapca56" ;; "EV5.7 (21164PC)") UNAME_MACHINE="alphapca57" ;; "EV6 (21264)") UNAME_MACHINE="alphaev6" ;; "EV6.7 (21264A)") UNAME_MACHINE="alphaev67" ;; "EV6.8CB (21264C)") UNAME_MACHINE="alphaev68" ;; "EV6.8AL (21264B)") UNAME_MACHINE="alphaev68" ;; "EV6.8CX (21264D)") UNAME_MACHINE="alphaev68" ;; "EV6.9A (21264/EV69A)") UNAME_MACHINE="alphaev69" ;; "EV7 (21364)") UNAME_MACHINE="alphaev7" ;; "EV7.9 (21364A)") UNAME_MACHINE="alphaev79" ;; esac # A Pn.n version is a patched version. # A Vn.n version is a released version. # A Tn.n version is a released field test version. # A Xn.n version is an unreleased experimental baselevel. # 1.2 uses "1.2" for uname -r. echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` exit ;; Alpha\ *:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # Should we change UNAME_MACHINE based on the output of uname instead # of the specific Alpha model? echo alpha-pc-interix exit ;; 21064:Windows_NT:50:3) echo alpha-dec-winnt3.5 exit ;; Amiga*:UNIX_System_V:4.0:*) echo m68k-unknown-sysv4 exit ;; *:[Aa]miga[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-amigaos exit ;; *:[Mm]orph[Oo][Ss]:*:*) echo ${UNAME_MACHINE}-unknown-morphos exit ;; *:OS/390:*:*) echo i370-ibm-openedition exit ;; *:z/VM:*:*) echo s390-ibm-zvmoe exit ;; *:OS400:*:*) echo powerpc-ibm-os400 exit ;; arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) echo arm-acorn-riscix${UNAME_RELEASE} exit ;; arm:riscos:*:*|arm:RISCOS:*:*) echo arm-unknown-riscos exit ;; SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit ;; Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 else echo pyramid-pyramid-bsd fi exit ;; NILE*:*:*:dcosx) echo pyramid-pyramid-svr4 exit ;; DRS?6000:unix:4.0:6*) echo sparc-icl-nx6 exit ;; DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) case `/usr/bin/uname -p` in sparc) echo sparc-icl-nx7; exit ;; esac ;; s390x:SunOS:*:*) echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4H:SunOS:5.*:*) echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*) echo i386-pc-auroraux${UNAME_RELEASE} exit ;; i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*) eval $set_cc_for_build SUN_ARCH="i386" # If there is a compiler, see if it is configured for 64-bit objects. # Note that the Sun cc does not turn __LP64__ into 1 like gcc does. # This test works for both compilers. if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then SUN_ARCH="x86_64" fi fi echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:6*:*) # According to config.sub, this is the proper way to canonicalize # SunOS6. Hard to guess exactly what SunOS6 will be like, but # it's likely to be more like Solaris than SunOS4. echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; sun4*:SunOS:*:*) case "`/usr/bin/arch -k`" in Series*|S4*) UNAME_RELEASE=`uname -v` ;; esac # Japanese Language versions have a version number like `4.1.3-JL'. echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` exit ;; sun3*:SunOS:*:*) echo m68k-sun-sunos${UNAME_RELEASE} exit ;; sun*:*:4.2BSD:*) UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 case "`/bin/arch`" in sun3) echo m68k-sun-sunos${UNAME_RELEASE} ;; sun4) echo sparc-sun-sunos${UNAME_RELEASE} ;; esac exit ;; aushp:SunOS:*:*) echo sparc-auspex-sunos${UNAME_RELEASE} exit ;; # The situation for MiNT is a little confusing. The machine name # can be virtually everything (everything which is not # "atarist" or "atariste" at least should have a processor # > m68000). The system name ranges from "MiNT" over "FreeMiNT" # to the lowercase version "mint" (or "freemint"). Finally # the system name "TOS" denotes a system which is actually not # MiNT. But MiNT is downward compatible to TOS, so this should # be no problem. atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) echo m68k-atari-mint${UNAME_RELEASE} exit ;; milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) echo m68k-milan-mint${UNAME_RELEASE} exit ;; hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) echo m68k-hades-mint${UNAME_RELEASE} exit ;; *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) echo m68k-unknown-mint${UNAME_RELEASE} exit ;; m68k:machten:*:*) echo m68k-apple-machten${UNAME_RELEASE} exit ;; powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit ;; RISC*:ULTRIX:*:*) echo mips-dec-ultrix${UNAME_RELEASE} exit ;; VAX*:ULTRIX*:*:*) echo vax-dec-ultrix${UNAME_RELEASE} exit ;; 2020:CLIX:*:* | 2430:CLIX:*:*) echo clipper-intergraph-clix${UNAME_RELEASE} exit ;; mips:*:*:UMIPS | mips:*:*:RISCos) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __cplusplus #include /* for printf() prototype */ int main (int argc, char *argv[]) { #else int main (argc, argv) int argc; char *argv[]; { #endif #if defined (host_mips) && defined (MIPSEB) #if defined (SYSTYPE_SYSV) printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_SVR4) printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); #endif #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); #endif #endif exit (-1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && SYSTEM_NAME=`$dummy $dummyarg` && { echo "$SYSTEM_NAME"; exit; } echo mips-mips-riscos${UNAME_RELEASE} exit ;; Motorola:PowerMAX_OS:*:*) echo powerpc-motorola-powermax exit ;; Motorola:*:4.3:PL8-*) echo powerpc-harris-powermax exit ;; Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) echo powerpc-harris-powermax exit ;; Night_Hawk:Power_UNIX:*:*) echo powerpc-harris-powerunix exit ;; m88k:CX/UX:7*:*) echo m88k-harris-cxux7 exit ;; m88k:*:4*:R4*) echo m88k-motorola-sysv4 exit ;; m88k:*:3*:R3*) echo m88k-motorola-sysv3 exit ;; AViiON:dgux:*:*) # DG/UX returns AViiON for all architectures UNAME_PROCESSOR=`/usr/bin/uname -p` if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] then if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ [ ${TARGET_BINARY_INTERFACE}x = x ] then echo m88k-dg-dgux${UNAME_RELEASE} else echo m88k-dg-dguxbcs${UNAME_RELEASE} fi else echo i586-dg-dgux${UNAME_RELEASE} fi exit ;; M88*:DolphinOS:*:*) # DolphinOS (SVR3) echo m88k-dolphin-sysv3 exit ;; M88*:*:R3*:*) # Delta 88k system running SVR3 echo m88k-motorola-sysv3 exit ;; XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) echo m88k-tektronix-sysv3 exit ;; Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) echo m68k-tektronix-bsd exit ;; *:IRIX*:*:*) echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` exit ;; ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' i*86:AIX:*:*) echo i386-ibm-aix exit ;; ia64:AIX:*:*) if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} exit ;; *:AIX:2:3) if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include main() { if (!__power_pc()) exit(1); puts("powerpc-ibm-aix3.2.5"); exit(0); } EOF if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` then echo "$SYSTEM_NAME" else echo rs6000-ibm-aix3.2.5 fi elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then echo rs6000-ibm-aix3.2.4 else echo rs6000-ibm-aix3.2 fi exit ;; *:AIX:*:[456]) IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc fi if [ -x /usr/bin/oslevel ] ; then IBM_REV=`/usr/bin/oslevel` else IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} fi echo ${IBM_ARCH}-ibm-aix${IBM_REV} exit ;; *:AIX:*:*) echo rs6000-ibm-aix exit ;; ibmrt:4.4BSD:*|romp-ibm:BSD:*) echo romp-ibm-bsd4.4 exit ;; ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to exit ;; # report: romp-ibm BSD 4.3 *:BOSX:*:*) echo rs6000-bull-bosx exit ;; DPX/2?00:B.O.S.:*:*) echo m68k-bull-sysv3 exit ;; 9000/[34]??:4.3bsd:1.*:*) echo m68k-hp-bsd exit ;; hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit ;; 9000/[34678]??:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; 9000/[678][0-9][0-9]) if [ -x /usr/bin/getconf ]; then sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` case "${sc_cpu_version}" in 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 532) # CPU_PA_RISC2_0 case "${sc_kernel_bits}" in 32) HP_ARCH="hppa2.0n" ;; 64) HP_ARCH="hppa2.0w" ;; '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 esac ;; esac fi if [ "${HP_ARCH}" = "" ]; then eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #define _HPUX_SOURCE #include #include int main () { #if defined(_SC_KERNEL_BITS) long bits = sysconf(_SC_KERNEL_BITS); #endif long cpu = sysconf (_SC_CPU_VERSION); switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0"); break; case CPU_PA_RISC1_1: puts ("hppa1.1"); break; case CPU_PA_RISC2_0: #if defined(_SC_KERNEL_BITS) switch (bits) { case 64: puts ("hppa2.0w"); break; case 32: puts ("hppa2.0n"); break; default: puts ("hppa2.0"); break; } break; #else /* !defined(_SC_KERNEL_BITS) */ puts ("hppa2.0"); break; #endif default: puts ("hppa1.0"); break; } exit (0); } EOF (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` test -z "$HP_ARCH" && HP_ARCH=hppa fi ;; esac if [ ${HP_ARCH} = "hppa2.0w" ] then eval $set_cc_for_build # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler # generating 64-bit code. GNU and HP use different nomenclature: # # $ CC_FOR_BUILD=cc ./config.guess # => hppa2.0w-hp-hpux11.23 # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess # => hppa64-hp-hpux11.23 if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | grep -q __LP64__ then HP_ARCH="hppa2.0w" else HP_ARCH="hppa64" fi fi echo ${HP_ARCH}-hp-hpux${HPUX_REV} exit ;; ia64:HP-UX:*:*) HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ia64-hp-hpux${HPUX_REV} exit ;; 3050*:HI-UX:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #include int main () { long cpu = sysconf (_SC_CPU_VERSION); /* The order matters, because CPU_IS_HP_MC68K erroneously returns true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct results, however. */ if (CPU_IS_PA_RISC (cpu)) { switch (cpu) { case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; default: puts ("hppa-hitachi-hiuxwe2"); break; } } else if (CPU_IS_HP_MC68K (cpu)) puts ("m68k-hitachi-hiuxwe2"); else puts ("unknown-hitachi-hiuxwe2"); exit (0); } EOF $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } echo unknown-hitachi-hiuxwe2 exit ;; 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) echo hppa1.1-hp-bsd exit ;; 9000/8??:4.3bsd:*:*) echo hppa1.0-hp-bsd exit ;; *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) echo hppa1.0-hp-mpeix exit ;; hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) echo hppa1.1-hp-osf exit ;; hp8??:OSF1:*:*) echo hppa1.0-hp-osf exit ;; i*86:OSF1:*:*) if [ -x /usr/sbin/sysversion ] ; then echo ${UNAME_MACHINE}-unknown-osf1mk else echo ${UNAME_MACHINE}-unknown-osf1 fi exit ;; parisc*:Lites*:*:*) echo hppa1.1-hp-lites exit ;; C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) echo c1-convex-bsd exit ;; C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) echo c34-convex-bsd exit ;; C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) echo c38-convex-bsd exit ;; C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) echo c4-convex-bsd exit ;; CRAY*Y-MP:*:*:*) echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*[A-Z]90:*:*:*) echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ -e 's/\.[^.]*$/.X/' exit ;; CRAY*TS:*:*:*) echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*T3E:*:*:*) echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; CRAY*SV1:*:*:*) echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; *:UNICOS/mp:*:*) echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' exit ;; F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; 5000:UNIX_System_V:4.*:*) FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" exit ;; i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit ;; sparc*:BSD/OS:*:*) echo sparc-unknown-bsdi${UNAME_RELEASE} exit ;; *:BSD/OS:*:*) echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} exit ;; *:FreeBSD:*:*) case ${UNAME_MACHINE} in pc98) echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; amd64) echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; *) echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; esac exit ;; i*:CYGWIN*:*) echo ${UNAME_MACHINE}-pc-cygwin exit ;; *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;; i*:windows32*:*) # uname -m includes "-pc" on this system. echo ${UNAME_MACHINE}-mingw32 exit ;; i*:PW*:*) echo ${UNAME_MACHINE}-pc-pw32 exit ;; *:Interix*:*) case ${UNAME_MACHINE} in x86) echo i586-pc-interix${UNAME_RELEASE} exit ;; authenticamd | genuineintel | EM64T) echo x86_64-unknown-interix${UNAME_RELEASE} exit ;; IA64) echo ia64-unknown-interix${UNAME_RELEASE} exit ;; esac ;; [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) echo i${UNAME_MACHINE}-pc-mks exit ;; 8664:Windows_NT:*) echo x86_64-pc-mks exit ;; i*:Windows_NT*:* | Pentium*:Windows_NT*:*) # How do we know it's Interix rather than the generic POSIX subsystem? # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we # UNAME_MACHINE based on the output of uname instead of i386? echo i586-pc-interix exit ;; i*:UWIN*:*) echo ${UNAME_MACHINE}-pc-uwin exit ;; amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) echo x86_64-unknown-cygwin exit ;; p*:CYGWIN*:*) echo powerpcle-unknown-cygwin exit ;; prep*:SunOS:5.*:*) echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` exit ;; *:GNU:*:*) # the GNU system echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` exit ;; *:GNU/*:*:*) # other systems with GNU libc and userland echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu exit ;; i*86:Minix:*:*) echo ${UNAME_MACHINE}-pc-minix exit ;; alpha:Linux:*:*) case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; PCA57) UNAME_MACHINE=alphapca56 ;; EV6) UNAME_MACHINE=alphaev6 ;; EV67) UNAME_MACHINE=alphaev67 ;; EV68*) UNAME_MACHINE=alphaev68 ;; esac objdump --private-headers /bin/sh | grep -q ld.so.1 if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} exit ;; arm*:Linux:*:*) eval $set_cc_for_build if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \ | grep -q __ARM_EABI__ then echo ${UNAME_MACHINE}-unknown-linux-gnu else echo ${UNAME_MACHINE}-unknown-linux-gnueabi fi exit ;; avr32*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; cris:Linux:*:*) echo cris-axis-linux-gnu exit ;; crisv32:Linux:*:*) echo crisv32-axis-linux-gnu exit ;; frv:Linux:*:*) echo frv-unknown-linux-gnu exit ;; i*86:Linux:*:*) LIBC=gnu eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #ifdef __dietlibc__ LIBC=dietlibc #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'` echo "${UNAME_MACHINE}-pc-linux-${LIBC}" exit ;; ia64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m32r*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; m68*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; mips:Linux:*:* | mips64:Linux:*:*) eval $set_cc_for_build sed 's/^ //' << EOF >$dummy.c #undef CPU #undef ${UNAME_MACHINE} #undef ${UNAME_MACHINE}el #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) CPU=${UNAME_MACHINE}el #else #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) CPU=${UNAME_MACHINE} #else CPU= #endif #endif EOF eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } ;; or32:Linux:*:*) echo or32-unknown-linux-gnu exit ;; padre:Linux:*:*) echo sparc-unknown-linux-gnu exit ;; parisc64:Linux:*:* | hppa64:Linux:*:*) echo hppa64-unknown-linux-gnu exit ;; parisc:Linux:*:* | hppa:Linux:*:*) # Look for CPU level case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in PA7*) echo hppa1.1-unknown-linux-gnu ;; PA8*) echo hppa2.0-unknown-linux-gnu ;; *) echo hppa-unknown-linux-gnu ;; esac exit ;; ppc64:Linux:*:*) echo powerpc64-unknown-linux-gnu exit ;; ppc:Linux:*:*) echo powerpc-unknown-linux-gnu exit ;; s390:Linux:*:* | s390x:Linux:*:*) echo ${UNAME_MACHINE}-ibm-linux exit ;; sh64*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sh*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; sparc:Linux:*:* | sparc64:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; vax:Linux:*:*) echo ${UNAME_MACHINE}-dec-linux-gnu exit ;; x86_64:Linux:*:*) echo x86_64-unknown-linux-gnu exit ;; xtensa*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-gnu exit ;; i*86:DYNIX/ptx:4*:*) # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. # earlier versions are messed up and put the nodename in both # sysname and nodename. echo i386-sequent-sysv4 exit ;; i*86:UNIX_SV:4.2MP:2.*) # Unixware is an offshoot of SVR4, but it has its own version # number series starting with 2... # I am not positive that other SVR4 systems won't match this, # I just have to hope. -- rms. # Use sysv4.2uw... so that sysv4* matches it. echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} exit ;; i*86:OS/2:*:*) # If we were able to find `uname', then EMX Unix compatibility # is probably installed. echo ${UNAME_MACHINE}-pc-os2-emx exit ;; i*86:XTS-300:*:STOP) echo ${UNAME_MACHINE}-unknown-stop exit ;; i*86:atheos:*:*) echo ${UNAME_MACHINE}-unknown-atheos exit ;; i*86:syllable:*:*) echo ${UNAME_MACHINE}-pc-syllable exit ;; i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*) echo i386-unknown-lynxos${UNAME_RELEASE} exit ;; i*86:*DOS:*:*) echo ${UNAME_MACHINE}-pc-msdosdjgpp exit ;; i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} else echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} fi exit ;; i*86:*:5:[678]*) # UnixWare 7.x, OpenUNIX and OpenServer 6. case `/bin/uname -X | grep "^Machine"` in *486*) UNAME_MACHINE=i486 ;; *Pentium) UNAME_MACHINE=i586 ;; *Pent*|*Celeron) UNAME_MACHINE=i686 ;; esac echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} exit ;; i*86:*:3.2:*) if test -f /usr/options/cb.name; then UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ && UNAME_MACHINE=i586 (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ && UNAME_MACHINE=i686 (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ && UNAME_MACHINE=i686 echo ${UNAME_MACHINE}-pc-sco$UNAME_REL else echo ${UNAME_MACHINE}-pc-sysv32 fi exit ;; pc:*:*:*) # Left here for compatibility: # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i586. # Note: whatever this is, it MUST be the same as what config.sub # prints for the "djgpp" host, or else GDB configury will decide that # this is a cross-build. echo i586-pc-msdosdjgpp exit ;; Intel:Mach:3*:*) echo i386-pc-mach3 exit ;; paragon:*:*:*) echo i860-intel-osf1 exit ;; i860:*:4.*:*) # i860-SVR4 if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 else # Add other i860-SVR4 vendors below as they are discovered. echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 fi exit ;; mini*:CTIX:SYS*5:*) # "miniframe" echo m68010-convergent-sysv exit ;; mc68k:UNIX:SYSTEM5:3.51m) echo m68k-convergent-sysv exit ;; M680?0:D-NIX:5.3:*) echo m68k-diab-dnix exit ;; M68*:*:R3V[5678]*:*) test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) OS_REL='' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4; exit; } ;; NCR*:*:4.2:* | MPRAS*:*:4.2:*) OS_REL='.3' test -r /etc/.relid \ && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ && { echo i486-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \ && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) echo m68k-unknown-lynxos${UNAME_RELEASE} exit ;; mc68030:UNIX_System_V:4.*:*) echo m68k-atari-sysv4 exit ;; TSUNAMI:LynxOS:2.*:*) echo sparc-unknown-lynxos${UNAME_RELEASE} exit ;; rs6000:LynxOS:2.*:*) echo rs6000-unknown-lynxos${UNAME_RELEASE} exit ;; PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*) echo powerpc-unknown-lynxos${UNAME_RELEASE} exit ;; SM[BE]S:UNIX_SV:*:*) echo mips-dde-sysv${UNAME_RELEASE} exit ;; RM*:ReliantUNIX-*:*:*) echo mips-sni-sysv4 exit ;; RM*:SINIX-*:*:*) echo mips-sni-sysv4 exit ;; *:SINIX-*:*:*) if uname -p 2>/dev/null >/dev/null ; then UNAME_MACHINE=`(uname -p) 2>/dev/null` echo ${UNAME_MACHINE}-sni-sysv4 else echo ns32k-sni-sysv fi exit ;; PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort # says echo i586-unisys-sysv4 exit ;; *:UNIX_System_V:4*:FTX*) # From Gerald Hewes . # How about differentiating between stratus architectures? -djm echo hppa1.1-stratus-sysv4 exit ;; *:*:*:FTX*) # From seanf@swdc.stratus.com. echo i860-stratus-sysv4 exit ;; i*86:VOS:*:*) # From Paul.Green@stratus.com. echo ${UNAME_MACHINE}-stratus-vos exit ;; *:VOS:*:*) # From Paul.Green@stratus.com. echo hppa1.1-stratus-vos exit ;; mc68*:A/UX:*:*) echo m68k-apple-aux${UNAME_RELEASE} exit ;; news*:NEWS-OS:6*:*) echo mips-sony-newsos6 exit ;; R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit ;; BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. echo powerpc-be-beos exit ;; BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. echo powerpc-apple-beos exit ;; BePC:BeOS:*:*) # BeOS running on Intel PC compatible. echo i586-pc-beos exit ;; BePC:Haiku:*:*) # Haiku running on Intel PC compatible. echo i586-pc-haiku exit ;; SX-4:SUPER-UX:*:*) echo sx4-nec-superux${UNAME_RELEASE} exit ;; SX-5:SUPER-UX:*:*) echo sx5-nec-superux${UNAME_RELEASE} exit ;; SX-6:SUPER-UX:*:*) echo sx6-nec-superux${UNAME_RELEASE} exit ;; SX-7:SUPER-UX:*:*) echo sx7-nec-superux${UNAME_RELEASE} exit ;; SX-8:SUPER-UX:*:*) echo sx8-nec-superux${UNAME_RELEASE} exit ;; SX-8R:SUPER-UX:*:*) echo sx8r-nec-superux${UNAME_RELEASE} exit ;; Power*:Rhapsody:*:*) echo powerpc-apple-rhapsody${UNAME_RELEASE} exit ;; *:Rhapsody:*:*) echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} exit ;; *:Darwin:*:*) UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown case $UNAME_PROCESSOR in i386) eval $set_cc_for_build if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \ grep IS_64BIT_ARCH >/dev/null then UNAME_PROCESSOR="x86_64" fi fi ;; unknown) UNAME_PROCESSOR=powerpc ;; esac echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;; *:procnto*:*:* | *:QNX:[0123456789]*:*) UNAME_PROCESSOR=`uname -p` if test "$UNAME_PROCESSOR" = "x86"; then UNAME_PROCESSOR=i386 UNAME_MACHINE=pc fi echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} exit ;; *:QNX:*:4*) echo i386-pc-qnx exit ;; NSE-?:NONSTOP_KERNEL:*:*) echo nse-tandem-nsk${UNAME_RELEASE} exit ;; NSR-?:NONSTOP_KERNEL:*:*) echo nsr-tandem-nsk${UNAME_RELEASE} exit ;; *:NonStop-UX:*:*) echo mips-compaq-nonstopux exit ;; BS2000:POSIX*:*:*) echo bs2000-siemens-sysv exit ;; DS/*:UNIX_System_V:*:*) echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} exit ;; *:Plan9:*:*) # "uname -m" is not consistent, so use $cputype instead. 386 # is converted to i386 for consistency with other x86 # operating systems. if test "$cputype" = "386"; then UNAME_MACHINE=i386 else UNAME_MACHINE="$cputype" fi echo ${UNAME_MACHINE}-unknown-plan9 exit ;; *:TOPS-10:*:*) echo pdp10-unknown-tops10 exit ;; *:TENEX:*:*) echo pdp10-unknown-tenex exit ;; KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) echo pdp10-dec-tops20 exit ;; XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) echo pdp10-xkl-tops20 exit ;; *:TOPS-20:*:*) echo pdp10-unknown-tops20 exit ;; *:ITS:*:*) echo pdp10-unknown-its exit ;; SEI:*:*:SEIUX) echo mips-sei-seiux${UNAME_RELEASE} exit ;; *:DragonFly:*:*) echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` exit ;; *:*VMS:*:*) UNAME_MACHINE=`(uname -p) 2>/dev/null` case "${UNAME_MACHINE}" in A*) echo alpha-dec-vms ; exit ;; I*) echo ia64-dec-vms ; exit ;; V*) echo vax-dec-vms ; exit ;; esac ;; *:XENIX:*:SysV) echo i386-pc-xenix exit ;; i*86:skyos:*:*) echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' exit ;; i*86:rdos:*:*) echo ${UNAME_MACHINE}-pc-rdos exit ;; i*86:AROS:*:*) echo ${UNAME_MACHINE}-pc-aros exit ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 #echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 eval $set_cc_for_build cat >$dummy.c < # include #endif main () { #if defined (sony) #if defined (MIPSEB) /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, I don't know.... */ printf ("mips-sony-bsd\n"); exit (0); #else #include printf ("m68k-sony-newsos%s\n", #ifdef NEWSOS4 "4" #else "" #endif ); exit (0); #endif #endif #if defined (__arm) && defined (__acorn) && defined (__unix) printf ("arm-acorn-riscix\n"); exit (0); #endif #if defined (hp300) && !defined (hpux) printf ("m68k-hp-bsd\n"); exit (0); #endif #if defined (NeXT) #if !defined (__ARCHITECTURE__) #define __ARCHITECTURE__ "m68k" #endif int version; version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; if (version < 4) printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); else printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); exit (0); #endif #if defined (MULTIMAX) || defined (n16) #if defined (UMAXV) printf ("ns32k-encore-sysv\n"); exit (0); #else #if defined (CMU) printf ("ns32k-encore-mach\n"); exit (0); #else printf ("ns32k-encore-bsd\n"); exit (0); #endif #endif #endif #if defined (__386BSD__) printf ("i386-pc-bsd\n"); exit (0); #endif #if defined (sequent) #if defined (i386) printf ("i386-sequent-dynix\n"); exit (0); #endif #if defined (ns32000) printf ("ns32k-sequent-dynix\n"); exit (0); #endif #endif #if defined (_SEQUENT_) struct utsname un; uname(&un); if (strncmp(un.version, "V2", 2) == 0) { printf ("i386-sequent-ptx2\n"); exit (0); } if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ printf ("i386-sequent-ptx1\n"); exit (0); } printf ("i386-sequent-ptx\n"); exit (0); #endif #if defined (vax) # if !defined (ultrix) # include # if defined (BSD) # if BSD == 43 printf ("vax-dec-bsd4.3\n"); exit (0); # else # if BSD == 199006 printf ("vax-dec-bsd4.3reno\n"); exit (0); # else printf ("vax-dec-bsd\n"); exit (0); # endif # endif # else printf ("vax-dec-bsd\n"); exit (0); # endif # else printf ("vax-dec-ultrix\n"); exit (0); # endif #endif #if defined (alliant) && defined (i860) printf ("i860-alliant-bsd\n"); exit (0); #endif exit (1); } EOF $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && { echo "$SYSTEM_NAME"; exit; } # Apollos put the system type in the environment. test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } # Convex versions that predate uname can use getsysinfo(1) if [ -x /usr/convex/getsysinfo ] then case `getsysinfo -f cpu_type` in c1*) echo c1-convex-bsd exit ;; c2*) if getsysinfo -f scalar_acc then echo c32-convex-bsd else echo c2-convex-bsd fi exit ;; c34*) echo c34-convex-bsd exit ;; c38*) echo c38-convex-bsd exit ;; c4*) echo c4-convex-bsd exit ;; esac fi cat >&2 < in order to provide the needed information to handle your system. config.guess timestamp = $timestamp uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` /bin/uname -X = `(/bin/uname -X) 2>/dev/null` hostinfo = `(hostinfo) 2>/dev/null` /bin/universe = `(/bin/universe) 2>/dev/null` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` /bin/arch = `(/bin/arch) 2>/dev/null` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` UNAME_MACHINE = ${UNAME_MACHINE} UNAME_RELEASE = ${UNAME_RELEASE} UNAME_SYSTEM = ${UNAME_SYSTEM} UNAME_VERSION = ${UNAME_VERSION} EOF exit 1 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl/RELEASE-2.6.2.html0000644000175000017500000016325512240167764012675 0ustar cammcamm GCL 2.6.2 tests

GCL 2.6.2 RELEASE NOTES

The GCL team is happy to announce the release of version 2.6.2, the latest achievement in the 'stable' series.  While strictly speaking a bug-fix only release, 2.6.2 incorporates several major improvements over the last stable release, 2.5.3.  Some highlights:

  • The development of a 'lisp compiler torture tester' by GCL developer Paul Dietz which repeatedly compiles randomly generated forms of specifiable length to test the compiler for correctness.
  • The application of several significant corrections to the GCL lisp compiler to remove every known instance of miscompilation uncovered by this tester.  To our knowledge, GCL is alone with CLISP in passing this torture test for runs of effectively indefinite length.
  • Major performance improvements were applied to the lisp compiler to enable it to complete random tests of great length in a reasonable amount of time. 
  • Corrections to the GCL core files to enable very large image sizes in 64 bits, in which more than a billion cons cells can be allocated.  Current 64bit options include amd64, ia64, and alpha running most flavors of GNU/Linux.
  • Corrections to the heap scaling behavior of the garbage collector, resulting in significant performance gains in many instances.
  • Support for the latest gcc and binutils versions on all platforms but mingw
  • The elimination of many instances of unnecessary internal garbage generation bringing the associated performance gains
  • Native support for execstack protected linux kernels, such as on Fedora core systems
  • Native support for FreeBSD, OpenBSD, and MacOSX
  • Static function pointer support to stabilize dynamic library usage on Itanium systems
  • Transparent readline initialization when compiled in
  • Support for profiling via gprof
  • Automatic disabling of SGC (stratified garbage collection) if the image is executed on a kernel not supporting fault address recovery
  • Remove a memory leak associated with heavy bignum usage via the introduction of SGC contiguous pages
  • Several significant internal bug fixes, epecially in the mingw port.
  • Alter the build process to perform a full self compile with full function proclamation at build time.
  • GCL now compiles Axiom from scratch and carries it to all supported platforms with the current exception of mingw
  • GCL's ANSI build now in use for its first end-user application -- maxima (current cvs)
  • New 64bit platform support -- amd64, with full native object relocation
The full changelog can be found in the source tree in the file 'debian/changelog'.

 
The GCL team has subjected this release to a wide variety of tests and benchmarks.  While all such results are necessarily incomplete, one can nevertheless usefully summarize the approximate state of affairs as follows:
  • GCL is about as portable as CLISP
  • The GCL lisp compiler is about as robust/correct as that of CLISP, at least as measured by the random tester, which at present only covers a mostly integer subset of lisp.
  • GCL is about as fast as CMUCL
  • GCL plays a major role in carrying the primary large open source lisp end user applications to a wide variety of systems
  • GCL is still the least ANSI compliant of the freely available lisp systems,  though a modest level of compliance has been achieved in this release.  Much greater compliance has been achieved in the 2.7.x (cvs unstable) series yet to be officially released.

The specific test results are arranged in the following table.  Some terms need defining:

BFD
 the method of relocating compiled lisp object modules into the running executable using the BFD library
custreloc
 the method of relocating compiled lisp object modules into the running executable using the native GCL code.  This method as well as the BFD method preserve the module loading across image saving and re-execution
dlopen
 the method of dynamically linking in compiled lisp object modules into the existing session only via the system dynamic linker loader, ld.so.
SGC
 Stratified Garbage Collection -- an optional accelerated generational garbage collection algorithm employing read-only memory
CLtL1
 Common Lisp, the Language vol I, referring to the book of the same name by Steele defining a widely used lisp language standard prior to the ANSI standardization process in 1994.
ANSI
 the work in progress image build attempting to eventually extend traditional GCL into full ANSI complaince
Ansi tests
 the results of the work in progress ansi compliance test suite written by GCL developer Paul Dietz presented as the number of failures divided by the total number of tests run
Random tests
 the results of the random 'compiler torture tester' presented as the number of tests/the size of the random forms/the number of variables passed to the random function


In the table below, green denotes a pass, yellow denotes an as yet unimplemented option, and red indicates failure.  Blank cells indicate tests that have not been run.

System
 CPU
 Self Build
 BFD
 dlopen
 custreloc
 Preferred
Linking
 SGC
 CLtL1
 ANSI
 ANSI tests
 Random tests
 Maxima 5.9.0/CLtL1
(4)
 Maxima CVS/ANSI
(4)
 ACL2 2.8/CLtL1
(5)
 Axiom CVS/CLtL1
(6)
 nqthm
CLtL1
 pc-nqthm
CLtL1
Debian GNU/Linux (sid)
 i386



bfd
or
custreloc


303/
10697
 50000/10000/8
500000/1000/8




(setq si::*multiply-stacks* 16)
Debian GNU/Linux (sid)
 sparc



bfd
or
custreloc


303/
10697






Debian GNU/Linux (sid)
 powerpc



bfd


303/
10697






Debian GNU/Linux (sid)
 amd64



bfd


303/
10697






Debian GNU/Linux (sid)
 arm



bfd


303/
10697






Debian GNU/Linux (sid)
 m68k



bfd


303/
10697






Debian GNU/Linux (sid)
 s390



bfd


303/
10697






Debian GNU/Linux (sid)
 ia64



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 hppa
 -O0


dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 mips



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 mipsel



dlopen


303/
10697



(1)

Debian GNU/Linux (sid)
 alpha



dlopen


303/
10697



(1)

Fedora FC1
 i386



bfd or
custreloc


303/
10697
 12000/1000/8





Solaris
 sparc



bfd or
custreloc


303/
10697
 4000/1000/8
(4)





Windows MINGW(a)
 i386



custreloc



303/
10697
 57000/1000/8


(2)

MacOSX
 powerpc



bfd
 (3)

303/
10697






OpenBSD
 i386



bfd


303/
10697






FreeBSD
 i386



custreloc


303/
10697

























Notes:

(1) dlopen builds use file descriptors for each object load.  The step in the Axiom build process which regenerates its databases consumes more than the conventional maximum of 1024 file descriptors available by default on most UNIX systems.
(2) An AXIOMsys executable can be produced, and is basically functional, but experiences sporadic errors of a type as yet unknown.
(3) This is known to work on at least some versions of the OS, but others report a hang (infinite loop) when enabling SGC.  It is possible that this is due to a mprotect bug in older versions of the Darwin system shared libraries.  'compatibility version of user 6.0.0' appears to work.
(4) On this machine, the underlying gcc was old (3.0) and segfaulted outside of GCL when attempting to compile its produced C code after a few thousand        iterations.

(a) The preferred build environment for Mingw/Windows is gcc 3.3.1, binutils 2.14.90, and the latest msys release.



The following table presents the results of the popular gabriel benchmarks of three freely available lisp systems, GCL, CLISP and CMUCL.  Times are presented as multiples of the time GCL took in completing the tests.  Green  indicates tests on which GCL is the fastest, while red indicates tests on which GCLwas not the fastest.   The benchmark code can be found in ftp://ftp.ma.utexas.edu/gcl/gabriel.tgz.  The number of test iterations has been increased by a factor of 400 to overcome granularity issues on modern machines.  The '(print (time ...))' statements around each test iteration were removed, again due to granularity and relative i/o load.  Likewise the special init.lsp file conventionally used to preallocate GCL memory in such cases was removed as it is now mostly obsolete.  Finally the tests were modified slightly to place the optimization declamations at the top of each file being compiled as suggested by a CMUCL expert.

As with any benchmark, results can vary somewhat with the details of the executing machine.  With lisp in particular, the ratios of the cache sizes, cpu speed, and memory bandwidths can impact such tests significantly.  We present the results for two popular configurations below.  While the precise details of the differences are as yet known, it is speculated that the first result is more dominated by in-cache cpu performance, while the latter is more dominated by memory access efficiency.

Dual Intel Xeon 2.4Ghz, 512 Mb, Linux 2.4.20
 Athlon XP 3000+ (2.1Ghz), 512 Mb, Linux 2.4.26
Benchmark
 GCL
2.6.2
 CMUCL 18e-9
 CLISP
2.33-2

BOYER
1.000
2.200
9.869

BROWSE
1.000
2.240
NA

CTAK
1.000
0.230
1.890

DDERIV
1.000
2.148
2.909

DERIV
1.000
2.083
3.640

DESTRU-MOD
1.000
2.043
9.880

DESTRU
1.000
1.168
5.743

DIV2
1.000
2.222
3.911

FFT-MOD
1.000
1.585
206.057

FFT
1.000
1.544
176.088

FPRINT
1.000
2.136
3.742

FREAD
1.000
1.746
2.111

FRPOLY
1.000
1.524
5.112

PUZZLE-MOD
1.000
10.824
41.618

PUZZLE
1.000
11.324
37.671

STAK
1.000
1.536
9.836

TAK-MOD
1.000
1.465
15.053

TAK
1.000
1.486
14.629

TAKL
1.000
1.419
14.965

TAKR
1.000
1.933
12.327

TPRINT
1.000
0.937
1.263

TRAVERSE
1.000
0.875
8.378

TRIANG-MOD
1.000
7.067
26.814

TRIANG
1.000
1.281
18.565
GEOMETRIC
AVERAGE
1.00
1.86
10.33
MEDIAN
 1.00
 1.67
 9.87
Benchmark
 GCL
2.6.2
 CMUCL 18e
 CLISP
2.33

BOYER
1.000
0.892
6.316

BROWSE
1.000
0.965
NA

CTAK
1.000
0.435
3.489

DDERIV
1.000
0.822
1.579

DERIV
1.000
0.651
1.639

DESTRU-MOD
1.000
0.812
4.779

DESTRU
1.000
0.550
3.239

DIV2
1.000
0.599
1.525

FFT-MOD
1.000
2.655
337.207

FFT
1.000
1.923
251.026

FPRINT
1.000
2.322
3.508

FREAD
1.000
1.890
1.900

FRPOLY
1.000
1.013
3.606

PUZZLE-MOD
1.000
5.976
20.350

PUZZLE
1.000
5.472
19.387

STAK
1.000
1.655
8.064

TAK-MOD
1.000
1.382
14.775

TAK
1.000
1.399
14.514

TAKL
1.000
1.281
12.877

TAKR
1.000
1.735
15.500

TPRINT
1.000
2.008
1.674

TRAVERSE
1.000
0.770
8.013

TRIANG-MOD
1.000
6.639
25.182

TRIANG
1.000
1.186
16.948
GEOMETRIC
AVERAGE
1.00
1.40
8.46
MEDIAN
 1.00
 1.33
 8.01


Many improvements are planned for the 2.7.x development series time permitting, the most important of which is to complete the task of building an ANSI compliant GCL image. 







gcl/readme.xgcl0000644000175000017500000000574612240167764012400 0ustar cammcammxgcl is an interface from Gnu Common Lisp to the X library, Xlib. This software provides a lightweight and fairy easy-to-use way to: * Draw diagrams from Lisp * Create interactive graphical interfaces * Make the interactive Lisp interfaces available via the Web Beginning with release 2.6.8, xgcl is built into the make of GCL. There is a "raw" interface to the Xlib, and an "easy-to-use" interface built on top of it; we will only discuss the "easy-to-use" version. To use xgcl, start GCL and enter: (xgcl) This will load xgcl and print a message inviting you to try (xgcl-demo). (xgcl-demo) will create a small window and draw some examples in it. You can try (wtestc), (wtestd), ... (wtestk) to try some other things. The xgcl files are located in the directory xgcl-2/ relative to the GCL directory. The file gcl_dwtest.lsp contains the test examples; one way to get started quickly is by using this file for examples. There is also documentation: dwdoc.tex dwdoc.dvi dwdoc.html http://www.cs.utexas.edu/users/novak/dwdoc.html dwdoc.pdf dwdoc.ps To use the basic xgcl, you only need to invoke (xgcl). To use some of the more advanced features such as menu-set, described below, also load the file gcl_dwimportsb.lsp immediately after invoking (xgcl), to import symbols. Additional files that may be useful: gcl_menu-set.lsp Source and some comments for menu-set gcl_menu-settrans.lsp menu-set translated to Common Lisp gcl_pcalc.lsp Pocket calculator example gcl_draw-gates.lsp Draw boolean gate symbols gcl_draw.lsp Interactive drawing program source gcl_drawtrans.lsp Drawing program translated to Common Lisp gcl_dwindow.lsp Easy-to-use interface source with comments gcl_dwtrans.lsp Easy-to-use interface translated to Common Lisp gcl_editors.lsp Editors for colors etc. gcl_editorstrans.lsp Editors translated to Common Lisp gcl_ice-cream.lsp Example created using Draw lispserver.lsp Example web demo: a Lisp server lispservertrans.lsp Lisp server translated to Common Lisp Xakcl.paper Documentation on the "raw" Xlib interface Xakcl.example.lsp some PRIMITIVE examples This software provides a way to interface Lisp programs to the Web; see: http://www.cs.utexas.edu/users/novak/dwindow.html There are two ways to accomplish a Web interface. The first uses X directly, and requires that the user have an X server; this is reliable and fast, but it only works for the Linux/Mac/Cygwin subset of the world. There can also be firewall issues. The other option uses WeirdX, an X server written in Java. The WeirdX interface is often slow, and sometimes doesn't work at all, but when it works, it works with any web browser, even on Windows. The WeirdX interface tends to leave "mouse droppings" on interactive drawings. There are numerous examples of these web interfaces at: http://www.cs.utexas.edu/users/novak/ The Draw demo is a good one to try. gcl/readme-bin.mingw0000644000175000017500000000141212240167764013314 0ustar cammcammHi there! WHAT NOW: You are installing GNU Common Lisp for Windows, 2.6.8 This compiler uses the Minimalist GNU Windows 32 compiler tools (MinGW32, see below). IF YOU INSTALL INTO A DIRECTORY WITH SPACES IN THE NAME, MAKE SURE you use the DOSified form eg: c:/Progra~1/somewhere. MINGW32 GCC: The MinGW compiler is provided subject to the terms of the files: "COPYING" and "COPYING.LIB" located in the mingw sub-directory. The source code and updated binary packages can be obtained via the official MinGW web site: http://sourceforge.net/projects/mingw/ We recommend that you use the compiler provided when working with this GCL package for compatibility. Clean and rebuild pre-existing projects whenever you upgrade the GCL binary package for this reason. gcl/clcs/0000755000175000017500000000000012240167764011174 5ustar cammcammgcl/clcs/package.lisp0000755000175000017500000000432512240167764013467 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: ("CONDITIONS" :USE "LISP" :SHADOW ("BREAK" "ERROR" "CERROR" "WARN" "CHECK-TYPE" "ASSERT" "ETYPECASE" "CTYPECASE" "ECASE" "CCASE")); Base: 10 -*- ; From arisia.xerox.com:/cl/conditions/cond18.lisp ;;; ;;; CONDITIONS ;;; ;;; This is a sample implementation. It is not in any way intended as the definition ;;; of any aspect of the condition system. It is simply an existence proof that the ;;; condition system can be implemented. ;;; ;;; While this written to be "portable", this is not a portable condition system ;;; in that loading this file will not redefine your condition system. Loading this ;;; file will define a bunch of functions which work like a condition system. Redefining ;;; existing condition systems is beyond the goal of this implementation attempt. (MAKE-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP")) (IN-PACKAGE "CONDITIONS" :USE '("LISP" #+lucid "LUCID-COMMON-LISP")) #-(or lucid excl genera cmu ) (SHADOW '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE)) #+gcl (EXPORT '(;; Shadowed symbols BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE)) (EXPORT '(;; New symbols *BREAK-ON-SIGNALS* *DEBUGGER-HOOK* SIGNAL HANDLER-CASE HANDLER-BIND IGNORE-ERRORS DEFINE-CONDITION MAKE-CONDITION WITH-SIMPLE-RESTART 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 SERIOUS-CONDITION SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-ERROR SIMPLE-CONDITION-FORMAT-STRING SIMPLE-CONDITION-FORMAT-ARGUMENTS STORAGE-CONDITION STACK-OVERFLOW STORAGE-EXHAUSTED TYPE-ERROR TYPE-ERROR-DATUM TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR PROGRAM-ERROR CONTROL-ERROR STREAM-ERROR STREAM-ERROR-STREAM END-OF-FILE FILE-ERROR FILE-ERROR-PATHNAME CELL-ERROR 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)) (DEFVAR *THIS-PACKAGE* (FIND-PACKAGE "CONDITIONS")) gcl/clcs/sys-proclaim.lisp0000644000175000017500000000552712240167764014520 0ustar cammcamm (IN-PACKAGE "CONDITIONS") (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) |(PCL::FAST-METHOD PRINT-OBJECT (CASE-FAILURE T))| |(PCL::FAST-METHOD PRINT-OBJECT (END-OF-FILE T))| |(PCL::FAST-METHOD PRINT-OBJECT (PACKAGE-ERROR T))| |(PCL::FAST-METHOD PRINT-OBJECT (UNBOUND-VARIABLE T))| |(PCL::FAST-METHOD PRINT-OBJECT (UNDEFINED-FUNCTION T))| |(PCL::FAST-METHOD PRINT-OBJECT (ABORT-FAILURE T))| |(PCL::FAST-METHOD PRINT-OBJECT (INTERNAL-ERROR T))| |(PCL::FAST-METHOD PRINT-OBJECT (INTERNAL-SIMPLE-ERROR T))| COERCE-TO-CONDITION |(PCL::FAST-METHOD PRINT-OBJECT (SIMPLE-CONDITION T))| |(PCL::FAST-METHOD PRINT-OBJECT (TYPE-ERROR T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) RESTART-PRINT EXECUTE-DEBUGGER-COMMAND)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) *) CLCS-UNIVERSAL-ERROR-HANDLER)) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) CERROR)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) ACCUMULATE-CASES)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) SET-INTERNAL-ERROR)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) |(PCL::FAST-METHOD PRINT-OBJECT (CONDITION T))|)) (PROCLAIM '(FTYPE (FUNCTION NIL *) ABORT CONTINUE MUFFLE-WARNING SYSTEM::BREAK-RESUME SYSTEM::BREAK-HELP)) (PROCLAIM '(FTYPE (FUNCTION NIL T) KCL-TOP-RESTARTS INSTALL-CLCS-SYMBOLS REVERT-CLCS-SYMBOLS READ-EVALUATED-FORM INITIALIZE-INTERNAL-ERROR-TABLE READ-DEBUG-COMMAND)) (PROCLAIM '(FTYPE (FUNCTION (*) *) INVOKE-DEBUGGER CLCS-COMPILE)) (PROCLAIM '(FTYPE (FUNCTION (*) T) COMPUTE-RESTARTS SYSTEM::CLCS-BREAK-QUIT BREAK SHOW-RESTARTS MAKE-RESTART)) (PROCLAIM '(FTYPE (FUNCTION (T) *) INVOKE-RESTART-INTERACTIVELY STORE-VALUE USE-VALUE COMPILER::CMP-TOPLEVEL-EVAL CLCS-ERROR-SET SIMPLE-ASSERTION-FAILURE SYSTEM::CLCS-BREAK-LEVEL-INVOKE-RESTART)) (PROCLAIM '(FTYPE (FUNCTION (T) T) RESTART-NAME UNIQUE-ID REVERT-SYMBOL MAKE-KCL-TOP-RESTART FIND-KCL-TOP-RESTART RESTART-REPORT-FUNCTION SYSTEM::CLCS-TERMINAL-INTERRUPT RESTART-FUNCTION RESTART-INTERACTIVE-FUNCTION CONDITIONP CONDITION-CLASS-P RESET-FUNCTION CONDITION-BACKTRACE ESCAPE-SPECIAL-CASES-REPLACE STANDARD-DEBUGGER SIMPLE-CONDITION-CLASS-P RESTART-P)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) MAKE-CONDITION INVOKE-RESTART CLCS-COMPILE-FILE CLCS-LOAD CLCS-OPEN ERROR)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) FIND-RESTART SYSTEM::CLCS-BREAK-LEVEL WARN SIGNAL)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) RESTART-REPORT ASSERT-PROMPT PARSE-KEYWORD-PAIRS)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) INSTALL-SYMBOL INTERNAL-SIMPLE-ERROR-PRINTER ASSERT-REPORT SIMPLE-CONDITION-PRINTER)) gcl/clcs/gcl_clcs_condition_definitions.lisp0000755000175000017500000003311212240167764020302 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (eval-when (compile load eval) (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions *features*) ) (eval-when (compile load eval) (when (and (member :clos-conditions *features*) (member :defstruct-conditions *features*)) (dolist (sym '(simple-condition-format-string simple-condition-format-arguments type-error-datum type-error-expected-type case-failure-name case-failure-possibilities stream-error-stream file-error-pathname package-error-package cell-error-name arithmetic-error-operation internal-error-function-name)) (when (fboundp sym) (fmakunbound sym))) (setq *features* (remove :defstruct-conditions *features*))) ) (DEFINE-CONDITION WARNING (CONDITION) ()) (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) ()) (DEFINE-CONDITION ERROR (SERIOUS-CONDITION) ()) (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) ((FORMAT-STRING :type string :initarg :FORMAT-STRING :reader SIMPLE-CONDITION-FORMAT-STRING) (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS :initform '())) #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) (DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) (DEFINE-CONDITION TYPE-ERROR (ERROR) #-(or clos pcl) (DATUM EXPECTED-TYPE) #+(or clos pcl) ((DATUM :initarg :DATUM :reader TYPE-ERROR-DATUM) (EXPECTED-TYPE :initarg :EXPECTED-TYPE :reader TYPE-ERROR-EXPECTED-TYPE)) (:report (lambda (condition stream) (format stream "~S is not of type ~S." (TYPE-ERROR-DATUM CONDITION) (TYPE-ERROR-EXPECTED-TYPE CONDITION))))) (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) #-(or clos pcl) (NAME POSSIBILITIES) #+(or clos pcl) ((NAME :initarg :NAME :reader CASE-FAILURE-NAME) (POSSIBILITIES :initarg :POSSIBILITIES :reader CASE-FAILURE-POSSIBILITIES)) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "~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 CONTROL-ERROR (ERROR) ()) (DEFINE-CONDITION STREAM-ERROR (ERROR) #-(or clos pcl) (STREAM) #+(or clos pcl) ((STREAM :initarg :STREAM :reader STREAM-ERROR-STREAM))) (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (DEFINE-CONDITION FILE-ERROR (ERROR) #-(or clos pcl) (PATHNAME) #+(or clos pcl) ((PATHNAME :initarg :PATHNAME :reader FILE-ERROR-PATHNAME))) (DEFINE-CONDITION PACKAGE-ERROR (ERROR) #-(or clos pcl) (PACKAGE) #+(or clos pcl) ((PACKAGE :initarg :PACKAGE :reader PACKAGE-ERROR-PACKAGE) (MESSAGE :initarg :MESSAGE :reader PACKAGE-ERROR-MESSAGE)) (:report (lambda (condition stream) (format stream "A package error occurred on ~S: ~S." (PACKAGE-ERROR-PACKAGE CONDITION) (PACKAGE-ERROR-MESSAGE CONDITION))))) (DEFINE-CONDITION CELL-ERROR (ERROR) #-(or clos pcl) (NAME) #+(or clos pcl) ((NAME :initarg :NAME :reader CELL-ERROR-NAME))) (DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION ARITHMETIC-ERROR (ERROR) #-(or clos pcl) (OPERATION OPERANDS) #+(or clos pcl) ((OPERATION :initarg :OPERATION :reader ARITHMETIC-ERROR-OPERATION))) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () (:REPORT "Abort failed.")) #+kcl (progn (define-condition internal-error ( error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) ((function-name :initarg :function-name :reader internal-error-function-name :initform 'nil)) (:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) #+(or clos pcl)(call-next-method)))) (defun internal-simple-error-printer (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (apply #'format stream (simple-condition-format-string condition) (simple-condition-format-arguments condition))) (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-package-error (#+(or clos pcl) internal-error package-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-package-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "A package error occurred on ~S: ~S." (package-error-package condition) (package-error-message condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-undefined-function (#+(or clos pcl) internal-error undefined-function) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-undefined-function-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-end-of-file (#+(or clos pcl) internal-error end-of-file) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-end-of-file-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (define-condition internal-simple-file-error (#+(or clos pcl) internal-simple-error file-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-file-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-stream-error (#+(or clos pcl) internal-simple-error stream-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-stream-error-) #-(or clos pcl)(:report internal-simple-error-printer)) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) ) #-(or clos pcl) (progn (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-string condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-string condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-string condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-string condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-string condition)))) (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-arguments condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-arguments condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-arguments condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-arguments condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-arguments condition)))) (defun simple-condition-class-p (type) (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR #+kcl internal-simple-error #+kcl internal-simple-program-error #+kcl internal-simple-control-error #+kcl internal-simple-file-error #+kcl internal-simple-stream-error))) ) #+(or clos pcl) (progn (defvar *simple-condition-class* (find-class 'simple-condition)) (defun simple-condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *simple-condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) ) gcl/clcs/gcl_clcs_top_patches.lisp0000755000175000017500000001472212240167764016240 0ustar cammcamm (in-package "CONDITIONS") (import '(with-simple-restart abort continue compute-restarts *debug-level* *debug-restarts* *number-of-debug-restarts* *debug-abort* *debug-continue* *debug-condition* *debug-eval* find-restart invoke-restart invoke-restart-interactively restart-name ignore-errors show-restarts conditionp) "SYSTEM") (in-package "SYSTEM") (defvar *abort-restarts* nil) (defmacro with-clcs-break-level-bindings (&body forms) `(let* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) (debug-level *DEBUG-LEVEL*) (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) (IF (OR (NOT *DEBUG-CONTINUE*) (NOT (EQ *DEBUG-CONTINUE* C))) C NIL)) (LET ((C (IF *DEBUG-RESTARTS* (FIRST *DEBUG-RESTARTS*) NIL))) (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) (*DEBUG-CONDITION* (if (conditionp at) at *DEBUG-CONDITION*)) (*abort-restarts* (let ((abort-list nil)) (dolist (restart *DEBUG-RESTARTS*) (when (eq 'abort (restart-name restart)) (push restart abort-list))) (nreverse abort-list)))) ,@forms)) (defun clcs-break-level-invoke-restart (-) (COND ((AND (PLUSP -) (< - (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) (LET ((RESTART (NTH (- - 1) *DEBUG-RESTARTS*))) (INVOKE-RESTART-INTERACTIVELY RESTART))) (T (FORMAT T "~&No such restart.")))) ;; From akcl-1-530, changes marked with ;*** (defun clcs-break-level (at &optional env) (let* ((*break-message* (if (or (stringp at) (conditionp at)) ;*** at *break-message*)) ;*** (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*)) ;*** (*quit-tag* nil) ;*** (*break-level* (if (conditionp at) (cons t *break-level*) *break-level*)) (*ihs-base* (1+ *ihs-top*)) (*ihs-top* (1- (ihs-top))) (*current-ihs* *ihs-top*) (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top)))) (*frs-top* (frs-top)) (*break-env* nil) ;;(be *break-enable*) ;*** ;;(*break-enable* ;*** ;;(progn ;*** ;;(if (stringp at) nil be))) ;*** ;;(*standard-input* *terminal-io*) (*readtable* (or *break-readtable* *readtable*)) (*read-suppress* nil) (+ +) (++ ++) (+++ +++) (- -) (* *) (** **) (*** ***) (/ /) (// //) (/// ///) ) ;;(terpri *error-output*) (with-clcs-break-level-bindings ;*** (if (consp at) (set-back at env) (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** (format *debug-io* "~&~A~2%" *break-message*) ;*** (when (> (length *link-array*) 0) (format *debug-io* "Fast links are on: do (use-fast-links nil) for debugging~%")) (set-current) ;*** (setq *no-prompt* nil) (show-restarts))) ;*** (catch-fatal 1) (setq *interrupt-enable* t) (loop (setq +++ ++ ++ + + -) (cond (*no-prompt* (setq *no-prompt* nil)) (t (format *debug-io* "~&~a~a>~{~*>~}" (if (stringp at) "" "dbl:") (if (eq *package* (find-package 'user)) "" (package-name *package*)) *break-level*))) (unless ;*** (with-simple-restart (abort "Return to debug level ~D." DEBUG-LEVEL) ;*** (not (catch 'step-continue (setq - (locally (declare (notinline read)) (dbl-read *debug-io* nil *top-eof*))) (when (eq - *top-eof*) (bye)) (let* ( break-command (values (multiple-value-list (LOCALLY (declare (notinline break-call evalhook)) (if (or (keywordp -) (integerp -)) ;*** (setq - (cons - nil))) (cond ((and (consp -) (keywordp (car -))) (setq break-command t) (break-call (car -) (cdr -))) ((and (consp -) (integerp (car -))) ;*** (setq break-command t) ;*** (clcs-break-level-invoke-restart (car -))) ;*** (t (evalhook - nil nil *break-env*))))))) ;*** (setq /// // // / / values *** ** ** * * (car /)) (fresh-line *debug-io*) (dolist (val /) (locally (declare (notinline prin1)) (prin1 val *debug-io*)) (terpri *debug-io*))) nil))) ;*** (terpri *debug-io*) (break-current)))))) (defun clcs-terminal-interrupt (correctablep) (if correctablep (cerror "Continues execution." "Console interrupt.") (error "Console interrupt -- cannot continue."))) (defun clcs-break-quit (&optional (level 0)) (let ((abort (nth level (reverse *abort-restarts*)))) (when abort (invoke-restart-interactively abort))) (break-current)) (setq conditions::*debugger-function* 'break-level) (setq conditions::*debug-command-prefix* "") (defun break-resume () (and *debug-continue* (invoke-restart *debug-continue*))) (putprop :r 'break-resume 'break-command) (putprop :s 'show-restarts 'break-command) (defun break-help () (format *debug-io* " Break-loop Command Summary ([] indicates optional arg) -------------------------- :bl [j] show local variables and their values, or segment of vs if compiled in j stack frames starting at the current one. :bt [n] BACKTRACE [n steps] :down [i] DOWN i frames (one if no i) :env describe ENVIRONMENT of this stack frame (for interpreted). :fr [n] show frame n :loc [i] return i'th local of this frame if its function is compiled (si::loc i) :r RESUME (return from the current break loop). :up [i] UP i frames (one if no i) Example: print a bactrace of the last 4 frames >>:bt 4 Note: (use-fast-links nil) makes all non system function calls be recorded in the stack. (use-fast-links t) is the default Low level commands: ------------------ :p [i] make current the i'th PREVIOUS frame (in list show by :b) :n [i] make current the i'th NEXT frame (in list show by :b) :go [ihs-index] make current the frame corresponding ihs-index :m print the last break message. :s show restarts. :c show function of the current ihs frame. :q [i] quit to top level :r resume from this break loop. :b full backtrace of all functions and special forms. :bs [name] backward search for frame named 'name' :fs [name] search for frame named 'name' :vs [from] [to] Show value stack between FROM and TO :ihs [from] [to] Show Invocation History Stack :bds ['v1 'v2 ..]Show previous special bindings of v1, v2,.. or all if no v1 ") (values) ) gcl/clcs/gcl_clcs_debugger.lisp0000755000175000017500000001161412240167764015510 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS") (DEFVAR *DEBUG-LEVEL* 0) (DEFVAR *DEBUG-ABORT* NIL) (DEFVAR *DEBUG-CONTINUE* NIL) (DEFVAR *DEBUG-CONDITION* NIL) (DEFVAR *DEBUG-RESTARTS* NIL) (DEFVAR *NUMBER-OF-DEBUG-RESTARTS* 0) (DEFVAR *DEBUG-EVAL* 'EVAL) (DEFVAR *DEBUG-PRINT* #'(LAMBDA (VALUES) (FORMAT T "~&~{~S~^,~%~}" VALUES))) (DEFMACRO DEBUG-COMMAND (X) `(GET ,X 'DEBUG-COMMAND)) (DEFMACRO DEBUG-COMMAND-ARGUMENT-COUNT (X) `(GET ,X 'DEBUG-COMMAND-ARGUMENT-COUNT)) (DEFMACRO DEFINE-DEBUG-COMMAND (NAME BVL &REST BODY) `(PROGN (SETF (DEBUG-COMMAND ',NAME) #'(LAMBDA ,BVL ,@BODY)) (SETF (DEBUG-COMMAND-ARGUMENT-COUNT ',NAME) ,(LENGTH BVL)) ',NAME)) (DEFUN READ-DEBUG-COMMAND () (FORMAT T "~&Debug ~D> " *DEBUG-LEVEL*) (COND ((CHAR= (PEEK-CHAR T) #\:) (READ-CHAR) ;Eat the ":" so that ":1" reliably reads a number. (WITH-INPUT-FROM-STRING (STREAM (READ-LINE)) (LET ((EOF (LIST NIL))) (DO ((FORM (LET ((*PACKAGE* (FIND-PACKAGE "KEYWORD"))) (READ STREAM NIL EOF)) (READ STREAM NIL EOF)) (L '() (CONS FORM L))) ((EQ FORM EOF) (NREVERSE L)))))) (T (LIST :EVAL (READ))))) (DEFINE-DEBUG-COMMAND :EVAL (FORM) (FUNCALL *DEBUG-PRINT* (MULTIPLE-VALUE-LIST (FUNCALL *DEBUG-EVAL* FORM)))) (DEFINE-DEBUG-COMMAND :ABORT () (IF *DEBUG-ABORT* (INVOKE-RESTART-INTERACTIVELY *DEBUG-ABORT*) (FORMAT T "~&There is no way to abort.~%"))) (DEFINE-DEBUG-COMMAND :CONTINUE () (IF *DEBUG-CONTINUE* (INVOKE-RESTART-INTERACTIVELY *DEBUG-CONTINUE*) (FORMAT T "~&There is no way to continue.~%"))) (DEFINE-DEBUG-COMMAND :ERROR () (FORMAT T "~&~A~%" *DEBUG-CONDITION*)) (DEFINE-DEBUG-COMMAND :HELP () (FORMAT T "~&You are in a portable debugger.~ ~%Type a debugger command or a form to evaluate.~ ~%Commands are:~%") (SHOW-RESTARTS *DEBUG-RESTARTS* *NUMBER-OF-DEBUG-RESTARTS* 16) (FORMAT T "~& :EVAL form Evaluate a form.~ ~% :HELP Show this text.~%") (IF *DEBUG-ABORT* (FORMAT T "~& :ABORT Exit by ABORT.~%")) (IF *DEBUG-CONTINUE* (FORMAT T "~& :CONTINUE Exit by CONTINUE.~%")) (FORMAT T "~& :ERROR Reprint error message.~%")) (defvar *debug-command-prefix* ":") (DEFUN SHOW-RESTARTS (&OPTIONAL (RESTARTS *DEBUG-RESTARTS*) (MAX *NUMBER-OF-DEBUG-RESTARTS*) TARGET-COLUMN) (UNLESS MAX (SETQ MAX (LENGTH RESTARTS))) (WHEN RESTARTS (DO ((W (IF TARGET-COLUMN (- TARGET-COLUMN 3) (CEILING (LOG MAX 10)))) (P RESTARTS (CDR P)) (I 0 (1+ I))) ((OR (NOT P) (= I MAX))) (FORMAT T "~& ~A~A " *debug-command-prefix* (LET ((S (FORMAT NIL "~D" (+ I 1)))) (WITH-OUTPUT-TO-STRING (STR) (FORMAT STR "~A" S) (DOTIMES (I (- W (LENGTH S))) (WRITE-CHAR #\Space STR))))) (IF (EQ (CAR P) *DEBUG-ABORT*) (FORMAT T "(Abort) ")) (IF (EQ (CAR P) *DEBUG-CONTINUE*) (FORMAT T "(Continue) ")) (FORMAT T "~A" (CAR P)) (FORMAT T "~%")))) (defvar *DEBUGGER-HOOK* nil) (defvar *debugger-function* 'STANDARD-DEBUGGER) (DEFUN INVOKE-DEBUGGER (&OPTIONAL (DATUM "Debug") &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'DEBUG))) (WHEN *DEBUGGER-HOOK* (LET ((HOOK *DEBUGGER-HOOK*) (*DEBUGGER-HOOK* NIL)) (FUNCALL HOOK CONDITION HOOK))) (funcall *debugger-function* CONDITION))) (DEFUN STANDARD-DEBUGGER (CONDITION) (LET* ((*DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)) (*DEBUG-RESTARTS* (COMPUTE-RESTARTS)) (*NUMBER-OF-DEBUG-RESTARTS* (LENGTH *DEBUG-RESTARTS*)) (*DEBUG-ABORT* (FIND-RESTART 'ABORT)) (*DEBUG-CONTINUE* (OR (LET ((C (FIND-RESTART 'CONTINUE))) (IF (OR (NOT *DEBUG-CONTINUE*) (NOT (EQ *DEBUG-CONTINUE* C))) C NIL)) (LET ((C (IF *DEBUG-RESTARTS* (FIRST *DEBUG-RESTARTS*) NIL))) (IF (NOT (EQ C *DEBUG-ABORT*)) C NIL)))) (*DEBUG-CONDITION* CONDITION)) (FORMAT T "~&~A~%" CONDITION) (SHOW-RESTARTS) (DO ((COMMAND (READ-DEBUG-COMMAND) (READ-DEBUG-COMMAND))) (NIL) (EXECUTE-DEBUGGER-COMMAND (CAR COMMAND) (CDR COMMAND) *DEBUG-LEVEL*)))) (DEFUN EXECUTE-DEBUGGER-COMMAND (CMD ARGS LEVEL) (WITH-SIMPLE-RESTART (ABORT "Return to debug level ~D." LEVEL) (COND ((NOT CMD)) ((INTEGERP CMD) (COND ((AND (PLUSP CMD) (< CMD (+ *NUMBER-OF-DEBUG-RESTARTS* 1))) (LET ((RESTART (NTH (- CMD 1) *DEBUG-RESTARTS*))) (IF ARGS (APPLY #'INVOKE-RESTART RESTART (MAPCAR *DEBUG-EVAL* ARGS)) (INVOKE-RESTART-INTERACTIVELY RESTART)))) (T (FORMAT T "~&No such restart.")))) (T (LET ((FN (DEBUG-COMMAND CMD))) (IF FN (COND ((NOT (= (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD))) (FORMAT T "~&Too ~:[few~;many~] arguments to ~A." (> (LENGTH ARGS) (DEBUG-COMMAND-ARGUMENT-COUNT CMD)) CMD)) (T (APPLY FN ARGS))) (FORMAT T "~&~S is not a debugger command.~%" CMD))))))) gcl/clcs/makefile0000644000175000017500000000234512240167764012700 0ustar cammcamm-include ../makedefs COMPILE_FILE=./saved_clcs_gcl$(EXE) ./ -system-p -c-file -data-file \ -o-file nil -h-file -compile FILES:=$(shell ls -1 gcl_clcs_*.lisp | sed 's,\.lisp,,1') all: $(addsuffix .c,$(FILES)) $(addsuffix .o,$(FILES)) saved_clcs_gcl: ../unixport/saved_pcl_gcl$(EXE) echo '(load "package.lisp")(load "myload.lisp")(si::save-system "$@")' | $< $(" (TYPE-OF CONDITION) (UNIQUE-ID CONDITION))) (T (CONDITION-REPORT CONDITION STREAM)))) (DEFSTRUCT (CONDITION :CONC-NAME (:CONSTRUCTOR |Constructor for CONDITION|) (:PREDICATE NIL) (:PRINT-FUNCTION CONDITION-PRINT)) (-DUMMY-SLOT- NIL)) (EVAL-WHEN (EVAL COMPILE LOAD) (DEFMACRO PARENT-TYPE (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'PARENT-TYPE)) (DEFMACRO SLOTS (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'SLOTS)) (DEFMACRO CONC-NAME (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'CONC-NAME)) (DEFMACRO REPORT-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'REPORT-FUNCTION)) (DEFMACRO MAKE-FUNCTION (CONDITION-TYPE) `(GET ,CONDITION-TYPE 'MAKE-FUNCTION)) );NEHW-LAVE (DEFUN CONDITION-REPORT (CONDITION STREAM) (DO ((TYPE (TYPE-OF CONDITION) (PARENT-TYPE TYPE))) ((NOT TYPE) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF CONDITION))) (LET ((REPORTER (REPORT-FUNCTION TYPE))) (WHEN REPORTER (FUNCALL REPORTER CONDITION STREAM) (RETURN NIL))))) (SETF (MAKE-FUNCTION 'CONDITION) '|Constructor for CONDITION|) (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) (LET ((FN (MAKE-FUNCTION TYPE))) (COND ((NOT FN) (ERROR 'SIMPLE-TYPE-ERROR :DATUM TYPE :EXPECTED-TYPE '(SATISFIES MAKE-FUNCTION) :FORMAT-STRING "Not a condition type: ~S" :FORMAT-ARGUMENTS (LIST TYPE))) (T (APPLY FN SLOT-INITIALIZATIONS))))) (EVAL-WHEN (EVAL COMPILE LOAD) ;Some utilities that are used at macro expansion time (DEFUN PARSE-NEW-AND-USED-SLOTS (SLOTS PARENT-TYPE) (LET ((NEW '()) (USED '())) (DOLIST (SLOT SLOTS) (IF (SLOT-USED-P (CAR SLOT) PARENT-TYPE) (PUSH SLOT USED) (PUSH SLOT NEW))) (VALUES NEW USED))) (DEFUN SLOT-USED-P (SLOT-NAME TYPE) (COND ((EQ TYPE 'CONDITION) NIL) ((NOT TYPE) (ERROR "The type ~S does not inherit from CONDITION." TYPE)) ((ASSOC SLOT-NAME (SLOTS TYPE))) (T (SLOT-USED-P SLOT-NAME (PARENT-TYPE TYPE))))) );NEHW-LAVE (DEFMACRO DEFINE-CONDITION (NAME (PARENT-TYPE) SLOT-SPECS &REST OPTIONS) (LET ((CONSTRUCTOR (LET ((*PACKAGE* *THIS-PACKAGE*)) ;Bind for the INTERN -and- the FORMAT (INTERN (FORMAT NIL "Constructor for ~S" NAME))))) (LET ((SLOTS (MAPCAR #'(LAMBDA (SLOT-SPEC) (IF (ATOM SLOT-SPEC) (LIST SLOT-SPEC) SLOT-SPEC)) SLOT-SPECS))) (MULTIPLE-VALUE-BIND (NEW-SLOTS USED-SLOTS) (PARSE-NEW-AND-USED-SLOTS SLOTS PARENT-TYPE) (LET ((CONC-NAME-P NIL) (CONC-NAME NIL) (REPORT-FUNCTION NIL) (DOCUMENTATION NIL)) (DO ((O OPTIONS (CDR O))) ((NULL O)) (LET ((OPTION (CAR O))) (CASE (CAR OPTION) ;Should be ECASE (:CONC-NAME (SETQ CONC-NAME-P T) (SETQ CONC-NAME (CADR OPTION))) (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) `(LAMBDA (CONDITION STREAM) (DECLARE (IGNORE CONDITION)) (WRITE-STRING ,(CADR OPTION) STREAM)) (CADR OPTION)))) (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION))) (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option." "Invalid DEFINE-CONDITION option: ~S" OPTION))))) (IF (NOT CONC-NAME-P) (SETQ CONC-NAME (INTERN (FORMAT NIL "~A-" NAME) *PACKAGE*))) ;; The following three forms are compile-time side-effects. For now, they affect ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, ;; and CONC-NAME, the compiler could easily make them local. (SETF (PARENT-TYPE NAME) PARENT-TYPE) (SETF (SLOTS NAME) SLOTS) (SETF (CONC-NAME NAME) CONC-NAME) ;; Finally, the expansion ... `(PROGN (DEFSTRUCT (,NAME (:CONSTRUCTOR ,CONSTRUCTOR) (:PREDICATE NIL) (:COPIER NIL) (:PRINT-FUNCTION CONDITION-PRINT) (:INCLUDE ,PARENT-TYPE ,@USED-SLOTS) (:CONC-NAME ,CONC-NAME)) ,@NEW-SLOTS) (SETF (DOCUMENTATION ',NAME 'TYPE) ',DOCUMENTATION) (SETF (PARENT-TYPE ',NAME) ',PARENT-TYPE) (SETF (SLOTS ',NAME) ',SLOTS) (SETF (CONC-NAME ',NAME) ',CONC-NAME) (SETF (REPORT-FUNCTION ',NAME) ,(IF REPORT-FUNCTION `#',REPORT-FUNCTION)) (SETF (MAKE-FUNCTION ',NAME) ',CONSTRUCTOR) ',NAME)))))) (defun conditionp (object) (typep object 'condition)) (defun condition-class-p (object) (and (symbolp object) (MAKE-FUNCTION object))) ) #+(or clos pcl) (progn (eval-when (compile load eval) (defvar *condition-class-list* nil) ; list of (class-name initarg1 type1...) ) (DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS) (unless (or parent-list (eq name 'condition)) (setq parent-list (list 'condition))) (let* ((REPORT-FUNCTION nil) (DOCUMENTATION nil)) (DO ((O OPTIONS (CDR O))) ((NULL O)) (LET ((OPTION (CAR O))) (CASE (CAR OPTION) (:REPORT (SETQ REPORT-FUNCTION (IF (STRINGP (CADR OPTION)) `(LAMBDA (CONDITION STREAM) (DECLARE (IGNORE CONDITION)) (WRITE-STRING ,(CADR OPTION) STREAM)) (CADR OPTION)))) (:DOCUMENTATION (SETQ DOCUMENTATION (CADR OPTION))) (OTHERWISE (CERROR "Ignore this DEFINE-CONDITION option." "Invalid DEFINE-CONDITION option: ~S" OPTION))))) `(progn (eval-when (compile) #+pcl (setq pcl::*defclass-times* '(compile load eval))) (defclass ,name ,parent-list ,slot-specs) (eval-when (compile load eval) (pushnew '(,name ,parent-list ,@(mapcan #'(lambda (slot-spec) (let* ((ia (getf (cdr slot-spec) ':initarg))) (when ia (list (cons ia (or (getf (cdr slot-spec) ':type) t)))))) SLOT-SPECS)) *condition-class-list*) #+kcl (setf (get ',name #+akcl 'si::s-data #-akcl 'si::is-a-structure) nil) ; (setf (get ',name 'documentation) ',documentation) ) ,@(when REPORT-FUNCTION `((DEFMETHOD PRINT-OBJECT ((X ,NAME) STREAM) (IF *PRINT-ESCAPE* (CALL-NEXT-METHOD) (,REPORT-FUNCTION X STREAM))))) ',NAME))) (eval-when (compile load eval) (define-condition condition () ()) #+pcl (when (fboundp 'pcl::proclaim-incompatible-superclasses) (mapc #'pcl::proclaim-incompatible-superclasses '((condition pcl::metaobject)))) ) (defun conditionp (object) (typep object 'condition)) (DEFMETHOD PRINT-OBJECT ((X condition) STREAM) (IF *PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (class-name (class-of x)) (UNIQUE-ID x)) (FORMAT STREAM "The condition ~A occurred." (TYPE-OF x)))) (defvar *condition-class* (find-class 'condition)) (defun condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) (DEFUN MAKE-CONDITION (TYPE &REST SLOT-INITIALIZATIONS) (unless (condition-class-p TYPE) (ERROR 'SIMPLE-TYPE-ERROR :DATUM TYPE :EXPECTED-TYPE '(SATISFIES condition-class-p) :FORMAT-STRING "Not a condition type: ~S" :FORMAT-ARGUMENTS (LIST TYPE))) (apply #'make-instance TYPE SLOT-INITIALIZATIONS)) ) gcl/clcs/readme0000755000175000017500000000035112240167764012356 0ustar cammcamm =====Compile the system========= (si::chdir "clcs") (load "loading.lisp") (jamie-load-clcs :compile) ======== load the system ======== (si::chdir "clcs") (load "package.lisp") (load "loading.lisp") (jamie-load-clcs :compiled) gcl/clcs/gcl_clcs_restart.lisp0000755000175000017500000001535712240167764015420 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") ;;; Unique Ids (DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE)) (DEFVAR *UNIQUE-ID-COUNT* -1) (DEFUN UNIQUE-ID (OBJ) "Generates a unique integer ID for its argument." (OR (GETHASH OBJ *UNIQUE-ID-TABLE*) (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*)))) ;;; Miscellaneous 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) (ERROR "&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) (FIND-PACKAGE "KEYWORD"))) 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)))))) );NEHW-LAVE ;;; Restarts (DEFVAR *RESTART-CLUSTERS* '()) ; FIXME add condition support (DEFUN COMPUTE-RESTARTS (&optional condition) #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts)) #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*)) (DEFUN RESTART-PRINT (RESTART STREAM DEPTH) (DECLARE (IGNORE DEPTH)) (IF *PRINT-ESCAPE* (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART)) (RESTART-REPORT RESTART STREAM))) (DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT)) NAME FUNCTION REPORT-FUNCTION INTERACTIVE-FUNCTION) #+kcl (progn (defvar *kcl-top-restarts* nil) (defun make-kcl-top-restart (quit-tag) (make-restart :name 'abort :function #'(lambda () (throw (car (list quit-tag)) quit-tag)) :report-function #'(lambda (stream) (let ((b-l (if (eq quit-tag si::*quit-tag*) si::*break-level* (car (or (find quit-tag si::*quit-tags* :key #'cdr) '(:not-found)))))) (cond ((eq b-l :not-found) (format stream "Return to ? level.")) ((null b-l) (format stream "Return to top level.")) (t (format stream "Return to break level ~D." (length b-l)))))) :interactive-function nil)) (defun find-kcl-top-restart (quit-tag) (cdr (or (assoc quit-tag *kcl-top-restarts*) (car (push (cons quit-tag (make-kcl-top-restart quit-tag)) *kcl-top-restarts*))))) (defun kcl-top-restarts () (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e)))) si::*quit-tags*)) (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags)) (restarts (mapcar #'find-kcl-top-restart tags))) (setq *kcl-top-restarts* (mapcar #'cons tags restarts)) restarts)) ) (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 RESTART-BIND (BINDINGS &BODY FORMS) `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING) `(MAKE-RESTART :NAME ',(CAR BINDING) :FUNCTION ,(CADR BINDING) ,@(CDDR BINDING))) BINDINGS)) *RESTART-CLUSTERS*))) ,@FORMS)) (DEFUN FIND-RESTART (NAME &optional condition) ;FIXME add condition support (declare (ignore condition)) (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*) (DOLIST (RESTART RESTART-CLUSTER) (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) (RETURN-FROM FIND-RESTART RESTART)))) #+kcl (let ((RESTART-CLUSTER (kcl-top-restarts))) (DOLIST (RESTART RESTART-CLUSTER) (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME)) (RETURN-FROM FIND-RESTART RESTART))))) (DEFUN INVOKE-RESTART (RESTART &REST VALUES) (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) (ERROR "Restart ~S is not active." RESTART)))) (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES))) (DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART) (LET ((REAL-RESTART (OR (FIND-RESTART RESTART) (ERROR "Restart ~S is not active." RESTART)))) (APPLY (RESTART-FUNCTION REAL-RESTART) (LET ((INTERACTIVE-FUNCTION (RESTART-INTERACTIVE-FUNCTION REAL-RESTART))) (IF INTERACTIVE-FUNCTION (FUNCALL INTERACTIVE-FUNCTION) '()))))) (DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES) (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE) (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))) (NREVERSE RESULT)))) (LET ((BLOCK-TAG (GENSYM)) (TEMP-VAR (GENSYM)) (DATA (MAPCAR #'(LAMBDA (CLAUSE) (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS) (CDDR CLAUSE)) (LIST (CAR CLAUSE) ;Name=0 (GENSYM) ;Tag=1 (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2 :INTERACTIVE INTERACTIVE) (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) #+LISPM (SETQ TEMP (COPY-LIST TEMP)) (SETQ ,TEMP-VAR TEMP) (GO ,TAG)) ,@KEYS))) DATA) (RETURN-FROM ,BLOCK-TAG ,EXPRESSION)) ,@(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))))))) (DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING &REST FORMAT-ARGUMENTS) &BODY FORMS) `(RESTART-CASE (PROGN ,@FORMS) (,RESTART-NAME () :REPORT (LAMBDA (STREAM) (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS)) (VALUES NIL T)))) (DEFUN ABORT () (INVOKE-RESTART 'ABORT) (ERROR 'ABORT-FAILURE)) (DEFUN CONTINUE () (INVOKE-RESTART 'CONTINUE)) (DEFUN MUFFLE-WARNING () (INVOKE-RESTART 'MUFFLE-WARNING)) (DEFUN STORE-VALUE (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE)) (DEFUN USE-VALUE (VALUE) (INVOKE-RESTART 'USE-VALUE VALUE)) gcl/clcs/myload.lisp0000644000175000017500000000051312240167764013351 0ustar cammcamm(load "gcl_clcs_precom.lisp") (load "gcl_clcs_macros.lisp") (load "gcl_clcs_restart.lisp") (load "gcl_clcs_handler.lisp") (load "gcl_clcs_debugger.lisp") (load "gcl_clcs_conditions.lisp") (load "gcl_clcs_condition_definitions.lisp") (load "gcl_clcs_kcl_cond.lisp") (load "gcl_clcs_top_patches.lisp") (load "gcl_clcs_install.lisp") gcl/clcs/loading.lisp0000755000175000017500000000124012240167764013502 0ustar cammcamm(defun jamie-load-clcs (&optional (mode :compiled)) (let ((files (list ;"package" "clcs_precom" "clcs_macros" "clcs_restart" "clcs_handler" "clcs_debugger" "clcs_conditions" "clcs_condition_definitions" "clcs_kcl_cond" "clcs_top_patches" "clcs_install"))) ; (load "package.lisp") (when (eql :compile mode) ; (load "package.lisp") (load "clcs_precom.lisp")) (mapc #'(lambda (file) (ecase mode (:interpreted (load (format nil "~A.lisp" file))) (:compiled (load (format nil "~A.o" file))) (:compile (compile-file (format nil "~A.lisp" file) :c-file t :h-file t :data-file t :system-p t)))) files))) gcl/clcs/gcl_clcs_kcl_cond.lisp0000755000175000017500000002226312240167764015502 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS") (defvar *internal-error-table* (make-hash-table :test 'equal)) ;(defmacro find-internal-error-data (error-name error-format-string) ; `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) (defmacro find-internal-error-data (error-name) `(gethash (list ,error-name) *internal-error-table*)) ;(defun clcs-universal-error-handler (error-name correctable function-name ; continue-format-string error-format-string ; &rest args) ; (if correctable ; (with-simple-restart ; (continue "~a" (apply #'format nil continue-format-string args)) ; (error 'internal-simple-error ; :function-name function-name ; :format-string error-format-string ; :format-arguments args)) ; (let ((e-d (find-internal-error-data error-name error-format-string))) ; (if e-d ; (let ((condition-name (car e-d))) ; (apply #'error condition-name ; :function-name function-name ; (let ((k-a (mapcan #'list (cdr e-d) args))) ; (if (simple-condition-class-p condition-name) ; (list* :format-string error-format-string ; :format-arguments args ; k-a) ; k-a)))) ; (error 'internal-simple-error :function-name function-name ; :format-string error-format-string :format-arguments args))))) (defvar *internal-error-parms* nil) (defun clcs-universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args &aux (internal-error-parms (list error-name correctable function-name continue-format-string error-format-string))) (when (equal internal-error-parms *internal-error-parms*) (format t "Universal error handler called recursively ~S~%" internal-error-parms) (return-from clcs-universal-error-handler)) (let* ((*internal-error-parms* (list error-name correctable function-name continue-format-string error-format-string)) (e-d (find-internal-error-data error-name))) (if e-d (let ((condition-name (car e-d))) (if correctable (with-simple-restart (continue "~a" (apply #'format nil continue-format-string args)) (apply #'error condition-name :function-name function-name (let ((k-a (mapcan #'list (cdr e-d) args))) (if (simple-condition-class-p condition-name) (list* :format-string error-format-string :format-arguments args k-a) k-a)))) (apply #'error condition-name :function-name function-name (let ((k-a (mapcan #'list (cdr e-d) args))) (if (simple-condition-class-p condition-name) (list* :format-string error-format-string :format-arguments args k-a) k-a))))) (error 'internal-simple-error :function-name function-name :format-string error-format-string :format-arguments args)))) (defun set-internal-error (error-keyword error-format condition-name &rest keyword-list) (declare (ignore error-format)) ; (setf (find-internal-error-data error-keyword error-format) (setf (find-internal-error-data error-keyword) (cons condition-name keyword-list))) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) (clrhash *internal-error-table*) (dolist (error-data *internal-error-list*) (apply #'set-internal-error (cdr error-data)))) (defparameter *internal-error-list* '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." internal-type-error :datum :expected-type) ("FEpackage_error" :package-error "A package error occurred on ~S: ~S." internal-package-error :package :message) ; || |top - base| ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." internal-simple-program-error) ; || |top - base| ; ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." ; internal-simple-control-error) ; || |args| ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-program-error) ; || |top - base| ; ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." ; internal-simple-control-error) ; || |args| ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; || ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." internal-simple-program-error) ; || |key| ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| ("FEundefined_function" :undefined-function "The function ~S is undefined." internal-undefined-function :name) ("FEinvalid_function" :invalid-function "~S is invalid as a function." internal-undefined-function :name) ; |obj| ("FEinvalid_variable" :invalid-variable "~S is an invalid variable." internal-program-error) ; |obj| ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-program-error) ; || |n| |top - base| ; ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ ;but ~R ~:*~[were~;was~:;were~] supplied." ; internal-simple-program-error) ; || |n| |top - base| ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("keyword_value_mismatch" :error "Keywords and values do not match." internal-simple-program-error) ;?? ("not_a_keyword" :error "~S is not a keyword." internal-simple-program-error) ;?? ("illegal_declare" :invalid-form "~S is an illegal declaration form." internal-simple-program-error) ; ("not_a_symbol" :invalid-variable "~S is not a symbol." ; internal-simple-error) ;?? ; ("not_a_variable" :invalid-variable "~S is not a variable." ; internal-simple-program-error) ("illegal_index" :error "~S is an illegal index to ~S." internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ("end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ("open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ("open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ("open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ("close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ("close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ("too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ("cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ("cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ("cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ("cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) )) (initialize-internal-error-table) (defun condition-backtrace (condition) (let* ((*debug-io* *error-output*) (si::*ihs-base* (1+ si::*ihs-top*)) (si::*ihs-top* (1- (si::ihs-top))) (si::*current-ihs* si::*ihs-top*) (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) (1+ (si::frs-top)))) (si::*frs-top* (si::frs-top)) (si::*break-env* nil)) (format *error-output* "~%~A~%" condition) (si::simple-backtrace))) (defvar *error-set-break-p* nil) (defun clcs-error-set (form) (let ((cond nil)) (restart-case (handler-bind ((error #'(lambda (condition) (unless (or si::*break-enable* *error-set-break-p*) (condition-backtrace condition) (return-from clcs-error-set condition)) (setq cond condition) nil))) (values-list (cons nil (multiple-value-list (eval form))))) (si::error-set () :report (lambda (stream) (format stream "~S" `(si::error-set ',form))) cond)))) (eval-when (compile load eval) (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties (setf (symbol-function symbol) (symbol-function symbol))) (reset-function 'si::error-set) (reset-function 'load) (reset-function 'open) ) (setq compiler::*compiler-break-enable* t) (defun compiler::cmp-toplevel-eval (form) (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* compiler::*compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) gcl/clcs/gcl_clcs_macros.lisp0000755000175000017500000001223312240167764015206 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P) (DO ((L '()) (C CASES (CDR C))) ((NULL C) (NREVERSE L)) (LET ((KEYS (CAAR C))) (COND ((ATOM KEYS) (COND ((NULL KEYS)) ((MEMBER KEYS '(OTHERWISE T)) (IF (NOT (MEMBER MACRO-NAME '( ECASE CCASE ETYPECASE CTYPECASE))) (ERROR "OTHERWISE is not allowed in ~S expressions." MACRO-NAME)) (PUSH (LIST KEYS) L)) (T (PUSH KEYS L)))) (LIST-IS-ATOM-P (PUSH KEYS L)) (T (DOLIST (KEY KEYS) (PUSH KEY L))))))) );NEHW-LAVE ;(DEFUN ESCAPE-SPECIAL-CASES (CASES) ; (DO ((L '()) ; (C CASES (CDR C))) ; ((NULL C) (NREVERSE L)) ; (LET ((KEYS (CAAR C))) ; (COND ((ATOM KEYS) ; (COND ((NULL KEYS)) ; ((MEMBER KEYS '(OTHERWISE T)) ; (PUSH (CONS (LIST KEYS) (CDR (CAR C))) L)) ; (T (PUSH (CONS KEYS (CDR (CAR C))) L)))) ; (T ; (PUSH (CONS KEYS (CDR (CAR C))) L)))))) (DEFUN ESCAPE-SPECIAL-CASES-REPLACE (CASES) (DO ((C CASES (CDR C))) ((NULL C) CASES) (LET ((KEYS (CAAR C))) (IF (MEMBER KEYS '(OTHERWISE T)) (RPLACA (CAR C) (LIST KEYS)))))) (DEFMACRO ECASE (KEYFORM &REST CASES) (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL)) (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES)) (VAR (GENSYM))) `(LET ((,VAR ,KEYFORM)) (CASE ,VAR ,@NCASES (OTHERWISE (ERROR 'CASE-FAILURE :NAME 'ECASE :DATUM ,VAR :EXPECTED-TYPE '(MEMBER ,@KEYS) :POSSIBILITIES ',KEYS)))))) (DEFMACRO CCASE (KEYPLACE &REST CASES) (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL)) (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES)) (TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (RETURN-FROM ,TAG1 (CASE ,KEYPLACE ,@NCASES (OTHERWISE (RESTART-CASE (ERROR 'CASE-FAILURE :NAME 'CCASE :DATUM ,KEYPLACE :EXPECTED-TYPE '(MEMBER ,@KEYS) :POSSIBILITIES ',KEYS) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',KEYPLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,KEYPLACE VALUE) (GO ,TAG2)))))))))) (DEFMACRO ETYPECASE (KEYFORM &REST CASES) (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T)) (VAR (GENSYM))) `(LET ((,VAR ,KEYFORM)) (TYPECASE ,VAR ,@CASES (OTHERWISE (ERROR 'CASE-FAILURE :NAME 'ETYPECASE :DATUM ,VAR :EXPECTED-TYPE '(OR ,@TYPES) :POSSIBILITIES ',TYPES)))))) (DEFMACRO CTYPECASE (KEYPLACE &REST CASES) (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T)) (TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (RETURN-FROM ,TAG1 (TYPECASE ,KEYPLACE ,@CASES (OTHERWISE (RESTART-CASE (ERROR 'CASE-FAILURE :NAME 'CTYPECASE :DATUM ,KEYPLACE :EXPECTED-TYPE '(OR ,@TYPES) :POSSIBILITIES ',TYPES) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',KEYPLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,KEYPLACE VALUE) (GO ,TAG2)))))))))) (DEFUN ASSERT-REPORT (NAMES STREAM) (FORMAT STREAM "Retry assertion") (IF NAMES (FORMAT STREAM " with new value~P for ~{~S~^, ~}." (LENGTH NAMES) NAMES) (FORMAT STREAM "."))) (DEFUN ASSERT-PROMPT (NAME VALUE) (COND ((Y-OR-N-P "The old value of ~S is ~S.~ ~%Do you want to supply a new value? " NAME VALUE) (FORMAT *QUERY-IO* "~&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))) (DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION) (ERROR 'SIMPLE-TYPE-ERROR :DATUM ASSERTION :EXPECTED-TYPE NIL ; This needs some work in next revision. -kmp :FORMAT-STRING "The assertion ~S failed." :FORMAT-ARGUMENTS (LIST ASSERTION))) (DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS) (LET ((TAG (GENSYM))) `(TAGBODY ,TAG (UNLESS ,TEST-FORM (RESTART-CASE ,(IF DATUM `(ERROR ,DATUM ,@ARGUMENTS) `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM)) (CONTINUE () :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM)) ,@(MAPCAR #'(LAMBDA (PLACE) `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE))) PLACES) (GO ,TAG))))))) (DEFUN READ-EVALUATED-FORM () (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%") (LIST (EVAL (READ *QUERY-IO*)))) (DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING) (LET ((TAG1 (GENSYM)) (TAG2 (GENSYM))) `(BLOCK ,TAG1 (TAGBODY ,TAG2 (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL)) (RESTART-CASE ,(IF TYPE-STRING `(ERROR "The value of ~S is ~S, ~ which is not ~A." ',PLACE ,PLACE ,TYPE-STRING) `(ERROR "The value of ~S is ~S, ~ which is not of type ~S." ',PLACE ,PLACE ',TYPE)) (STORE-VALUE (VALUE) :REPORT (LAMBDA (STREAM) (FORMAT STREAM "Supply a new value of ~S." ',PLACE)) :INTERACTIVE READ-EVALUATED-FORM (SETF ,PLACE VALUE) (GO ,TAG2))))))) gcl/clcs/unused/0000755000175000017500000000000012240167764012477 5ustar cammcammgcl/clcs/unused/reload.lisp0000755000175000017500000000044412240167764014643 0ustar cammcamm(load "package.lisp") (load "precom.lisp") (load "macros.lisp") (load "restart.lisp") (load "handler.lisp") (load "debugger.lisp") (load "conditions.lisp") (load "condition-definitions.lisp") (compile-file "precom.lisp") (load "kcl-cond.lisp") (load "top-patches.lisp") (load "install.lisp") gcl/clcs/unused/test5.lisp0000755000175000017500000002616512240167764014451 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (eval-when (compile load eval) (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions *features*) ) (eval-when (compile load eval) (when (and (member :clos-conditions *features*) (member :defstruct-conditions *features*)) (dolist (sym '(simple-condition-format-string simple-condition-format-arguments type-error-datum type-error-expected-type case-failure-name case-failure-possibilities stream-error-stream file-error-pathname package-error-package cell-error-name arithmetic-error-operation internal-error-function-name)) (when (fboundp sym) (fmakunbound sym))) (setq *features* (remove :defstruct-conditions *features*))) ) ;;; Start (DEFINE-CONDITION WARNING (CONDITION) ()) (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) ()) (DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION) ()) (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM) (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING CONDITION) (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION))) (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) ((FORMAT-STRING :type string :initarg :FORMAT-STRING :reader SIMPLE-CONDITION-FORMAT-STRING) (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS :initform '())) #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-) (:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ()) (DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) ()) (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ()) (DEFINE-CONDITION TYPE-ERROR (lisp:ERROR) #-(or clos pcl) (DATUM EXPECTED-TYPE) #+(or clos pcl) ((DATUM :initarg :DATUM :reader TYPE-ERROR-DATUM) (EXPECTED-TYPE :initarg :EXPECTED-TYPE :reader TYPE-ERROR-EXPECTED-TYPE)) (:report (lambda (condition stream) (format stream "~S is not of type ~S." (TYPE-ERROR-DATUM CONDITION) (TYPE-ERROR-EXPECTED-TYPE CONDITION))))) (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR) #-(or clos pcl) (FORMAT-STRING (FORMAT-ARGUMENTS '())) #+(or clos pcl) () #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-) #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER)) (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR) #-(or clos pcl) (NAME POSSIBILITIES) #+(or clos pcl) ((NAME :initarg :NAME :reader CASE-FAILURE-NAME) (POSSIBILITIES :initarg :POSSIBILITIES :reader CASE-FAILURE-POSSIBILITIES)) (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "~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 (lisp:ERROR) ()) (DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR) ()) (DEFINE-CONDITION STREAM-ERROR (lisp:ERROR) #-(or clos pcl) (STREAM) #+(or clos pcl) ((STREAM :initarg :STREAM :reader STREAM-ERROR-STREAM))) (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (DEFINE-CONDITION FILE-ERROR (lisp:ERROR) #-(or clos pcl) (PATHNAME) #+(or clos pcl) ((PATHNAME :initarg :PATHNAME :reader FILE-ERROR-PATHNAME))) (DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR) #-(or clos pcl) (PACKAGE) #+(or clos pcl) ((PACKAGE :initarg :PACKAGE :reader PACKAGE-ERROR-PACKAGE))) (DEFINE-CONDITION CELL-ERROR (lisp:ERROR) #-(or clos pcl) (NAME) #+(or clos pcl) ((NAME :initarg :NAME :reader CELL-ERROR-NAME))) (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) () (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR) #-(or clos pcl) (OPERATION OPERANDS) #+(or clos pcl) ((OPERATION :initarg :OPERATION :reader ARITHMETIC-ERROR-OPERATION))) (DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) ()) (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) () (:REPORT "Abort failed.")) #+kcl (progn ;;; When this form is present, the compiled behavior disagrees with ;;; the interpreted behavior. The interpreted behavior is correct. (define-condition internal-error (lisp:error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) ((function-name :initarg :function-name :reader internal-error-function-name :initform 'nil)) (:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) #+(or clos pcl)(call-next-method)))) (defun internal-simple-error-printer (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (apply #'format stream (simple-condition-format-string condition) (simple-condition-format-arguments condition))) (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) ) #-(or clos pcl) (progn (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-STRING CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-string condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-string condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-string condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-string condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-string condition)))) (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-CONDITION (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-ERROR (%%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) #+kcl(internal-simple-error (%%internal-simple-error-format-arguments condition)) #+kcl(internal-simple-program-error (%%internal-simple-program-error-format-arguments condition)) #+kcl(internal-simple-control-error (%%internal-simple-control-error-format-arguments condition)) #+kcl(internal-simple-file-error (%%internal-simple-file-error-format-arguments condition)) #+kcl(internal-simple-stream-error (%%internal-simple-stream-error-format-arguments condition)))) (defun simple-condition-class-p (type) (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR #+kcl internal-simple-error #+kcl internal-simple-program-error #+kcl internal-simple-control-error #+kcl internal-simple-file-error #+kcl internal-simple-stream-error))) ) #+(or clos pcl) (progn (defvar *simple-condition-class* (find-class 'simple-condition)) (defun simple-condition-class-p (TYPE) (when (symbolp TYPE) (setq TYPE (find-class TYPE))) (and (typep TYPE 'standard-class) (member *simple-condition-class* (#+pcl pcl::class-precedence-list #-pcl clos::class-precedence-list type)))) ) gcl/clcs/unused/test.lisp0000755000175000017500000001625612240167764014364 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS") (defvar *internal-error-table* (make-hash-table :test 'equal)) (defmacro find-internal-error-data (error-name error-format-string) `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) (defun clcs-universal-error-handler (error-name correctable function-name continue-format-string error-format-string &rest args) (if correctable (with-simple-restart (continue "~a" (apply #'format nil continue-format-string args)) (error 'internal-simple-error :function-name function-name :format-string error-format-string :format-arguments args)) (let ((e-d (find-internal-error-data error-name error-format-string))) (print e-d) (if e-d (let ((condition-name (car e-d))) (apply #'error condition-name :function-name function-name (let ((k-a (mapcan #'list (cdr e-d) args))) (if (simple-condition-class-p condition-name) (list* :format-string error-format-string :format-arguments args k-a) k-a)))) (error 'internal-simple-error :function-name function-name :format-string error-format-string :format-arguments args))))) (defun set-internal-error (error-keyword error-format condition-name &rest keyword-list) (setf (find-internal-error-data error-keyword error-format) (cons condition-name keyword-list))) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) (clrhash *internal-error-table*) (dolist (error-data *internal-error-list*) (apply #'set-internal-error (cdr error-data)))) (defparameter *internal-error-list* '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S." internal-type-error :datum :expected-type) ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments." internal-simple-control-error) ; || |args| ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p." internal-simple-control-error) ; || |top - base| ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments." internal-simple-control-error) ; || |args| ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S." internal-simple-program-error) ; || ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S." internal-simple-control-error) ; || |key| ("FEunbound_variable" :unbound-variable "The variable ~S is unbound." internal-unbound-variable :name) ; |sym| ("FEundefined_function" :undefined-function "The function ~S is undefined." internal-undefined-function :name) ("FEinvalid_function" :invalid-function "~S is invalid as a function." internal-simple-program-error) ; |obj| ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\ but only ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\ but ~R ~:*~[were~;was~:;were~] supplied." internal-simple-control-error) ; || |n| |top - base| ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA." internal-simple-control-error) ("keyword_value_mismatch" :error "Keywords and values do not match." internal-simple-error) ;?? ("not_a_keyword" :error "~S is not a keyword." internal-simple-error) ;?? ("illegal_declare" :invalid-form "~S is an illegal declaration form." internal-simple-program-error) ("not_a_symbol" :invalid-variable "~S is not a symbol." internal-simple-error) ;?? ("not_a_variable" :invalid-variable "~S is not a variable." internal-simple-program-error) ("illegal_index" :error "~S is an illegal index to ~S." internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ("end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ("open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ("open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ("open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ("close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ("close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ("too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ("cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ("cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ("cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ("cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) )) (initialize-internal-error-table) (defun condition-backtrace (condition) (let* ((*debug-io* *error-output*) (si::*ihs-base* (1+ si::*ihs-top*)) (si::*ihs-top* (1- (si::ihs-top))) (si::*current-ihs* si::*ihs-top*) (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*) (1+ (si::frs-top)))) (si::*frs-top* (si::frs-top)) (si::*break-env* nil)) (format *error-output* "~%~A~%" condition) (si::simple-backtrace))) (defvar *error-set-break-p* nil) (defun clcs-error-set (form) (let ((cond nil)) (restart-case (handler-bind ((error #'(lambda (condition) (unless (or si::*break-enable* *error-set-break-p*) (condition-backtrace condition) (return-from clcs-error-set condition)) (setq cond condition) nil))) (values-list (cons nil (multiple-value-list (eval form))))) (si::error-set () :report (lambda (stream) (format stream "~S" `(si::error-set ',form))) cond)))) (eval-when (compile load eval) (defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties (setf (symbol-function symbol) (symbol-function symbol))) (reset-function 'si::error-set) (reset-function 'load) (reset-function 'open) ) (setq compiler::*compiler-break-enable* t) (defun compiler::cmp-toplevel-eval (form) (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack (si::*ihs-top* (1- (si::ihs-top))) (*break-enable* compiler::*compiler-break-enable*) (si::*break-hidden-packages* (cons (find-package 'compiler) si::*break-hidden-packages*))) (si:error-set form))) gcl/clcs/unused/tester.lisp0000755000175000017500000000056612240167764014710 0ustar cammcamm(in-package "conditions") (defun compare-semantics (file condition) (let ((results)) (load (format nil "~A.lisp" file)) (push (with-output-to-string (s) (princ condition s)) results) (compile-file (format nil "~A.lisp" file)) (load (format nil "~A.o" file)) (push (with-output-to-string (s) (princ condition s)) results) (print (reverse results)) (values)))gcl/clcs/unused/test2.lisp0000755000175000017500000000305512240167764014437 0ustar cammcamm(in-package "conditions") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) #-(or pcl clos) (defun internal-error-function-name (condition) (etypecase condition (internal-error (%%internal-simple-error-function-name condition)) (internal-simple-error (%%internal-simple-error-function-name condition)) (internal-type-error (%%internal-type-error-function-name condition)) (internal-simple-program-error (%%internal-simple-program-error-function-name condition)) (internal-simple-control-error (%%internal-simple-control-error-function-name condition)) (internal-unbound-variable (%%internal-unbound-variable-function-name condition)) (internal-undefined-function (%%internal-undefined-function-function-name condition)) (internal-end-of-file (%%internal-end-of-file-function-name condition)) (internal-simple-file-error (%%internal-simple-file-error-function-name condition)) (internal-simple-stream-error (%%internal-simple-stream-error-function-name condition)))) gcl/clcs/unused/doload.lisp0000755000175000017500000000071212240167764014635 0ustar cammcamm (defun file-name-directory (path) (let ((pa (pathname path))) (namestring (make-pathname :directory (pathname-directory path) )))) (let ((pa (file-name-directory si::*LOAD-PATHNAME*)) (files '("package" "precom" "macros" "restart" "handler" "debugger" "conditions" "condition-definitions" "kcl-cond" "top-patches" "install"))) (dolist (v files) (setq v (si::file-search v (list pa) '(".o" ".lisp"))) (load v))) gcl/clcs/unused/sysdef.lisp0000755000175000017500000000771712240167764014704 0ustar cammcamm;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*- (in-package "DSYS") (defparameter *clcs-system-date* "CLCS 2/1/90") ; (For akcl-1-530) (defsystem clcs (:pretty-name "Common Lisp Condition System") #+kcl (:module clos pcl (:type :system)) (:parallel #+kcl clos (:forms :compile (proclaim *fast-declaration*) :load (proclaim *fast-declaration*)) (:serial "package" #-(or lucid excl genera cmu) (:serial (:load "precom") "macros" "restart" "handler" "debugger" #+kcl "kcl-cond" #+kcl "top-patches" "conditions" "condition-definitions" (:compile "precom")) "install"))) (defparameter *clcs-files* '((("systems") "lisp" "clcs") (("clcs") "lisp" "sysdef" "package" "macros" "restart" "handler" "debugger" "kcl-cond" "top-patches" "conditions" "condition-definitions" "precom" "install") (("clcs") nil "clcs-readme") (("clcs") "text" "installing-mailed-clcs") (("clcs" "doc") "text" ;;"cond18" "status" ) (("clcs" "doc") nil ;;"clos-conditions" ))) (defvar *clcs-dist-name* "clcs") (defun clcs-distribution-header () (let* ((*subfile-default-root-pathname* (make-pathname :directory '(:absolute "mydirectory" "lisp"))) (dist-dir (namestring (subfile '()))) (dist-file (namestring (subfile '() :name *clcs-dist-name* :type "lisp"))) (sys-file (namestring (subfile '() :name *this-file*)))) (format nil ";;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*- ;;; Common Lisp Condition System Distribution File ;;; Suppose the directory that is to contain the clcs system ;;; is ~S. ;;; To install CLCS: ;;; ~A ;;; (1) Put this file in ~S. ;;; (2) Run lisp, and type: ;;; (load ~S) ;;; To use CLCS: ;;; (1) Run lisp, and type: ;;; (load ~S) " dist-dir #-akcl "" #+akcl ";;; The CLCS system redefines the functions LOAD and OPEN (adding ;;; restart handlers), and the function SYSTEM:ERROR-SET. But AKCL is ;;; set up to compile calls to these functions into direct calls to ;;; C functions. You can fix this by: ;;; A. Edit the file cmpnew/lfun_list.lsp, commenting out every line ;;; that begins with #-clcs. ;;; B. Remake AKCL. ;;; C. Delete the files cmpnew/cmputil.o and lsp/debug.o ;;; (these files call SYSTEM:ERROR-SET). ;;; D. Remake AKCL. ;;; " dist-file dist-file sys-file))) (defun write-clcs-distribution (&key output-file) (dolist (sys '(clcs pcl)) (find-system sys nil)) (unless output-file (setq output-file (subfile '() :name *clcs-dist-name* :type "lisp"))) (write-distribution :files (append *basic-files* *clcs-files* *pcl-files*) :output-file output-file :header (clcs-distribution-header) #+unix :compress-uu-split-p #+unix t)) (defun read-clcs-distribution (&key input-file) (unless input-file (setq input-file (subfile '() :name *clcs-dist-name* :type "lisp"))) (read-distribution :input-file input-file)) (defun clcs-users () (let ((users-file (subfile '("clcs") :name "users" :type "text")) (users nil)) (when (probe-file users-file) (with-open-file (in users-file :direction :input) (loop (push (or (read in nil) (return nil)) users)))) (nreverse users))) #+unix (defun mail-clcs (&key output-file (new-p :ask) (query-users-p t)) (unless output-file (setq output-file (subfile '() :name *clcs-dist-name* :type "lisp"))) (let ((users (clcs-users)) (mail-users nil)) (if query-users-p (dolist (user users) (when (y-or-n-p "Mail CLCS to ~A? " user) (push user mail-users))) (setq mail-users users)) (when (if (eq new-p :ask) (y-or-n-p "~%Make a new distribution first? ") new-p) (write-clcs-distribution :output-file output-file)) (mail-compressed-uu-files :users mail-users :file output-file :intro-subject "How to install CLCS" :intro-file (subfile '("clcs") :name "installing-mailed-clcs" :type "text")))) gcl/clcs/unused/test4.lisp0000755000175000017500000000105212240167764014434 0ustar cammcamm(IN-PACKAGE "CONDITIONS") (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) gcl/clcs/unused/test3.lisp0000755000175000017500000000727612240167764014451 0ustar cammcamm(IN-PACKAGE "CONDITIONS") (define-condition internal-simple-error (internal-error #+(or clos pcl) simple-condition) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-error-) (:report internal-simple-error-printer)) (define-condition internal-type-error (#+(or clos pcl) internal-error type-error) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-type-error-) #-(or clos pcl)(:report (lambda (condition stream) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (format stream "~S is not of type ~S." (type-error-datum condition) (type-error-expected-type condition))))) (define-condition internal-simple-program-error (#+(or clos pcl) internal-simple-error program-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-program-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-control-error (#+(or clos pcl) internal-simple-error control-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-control-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-unbound-variable (#+(or clos pcl) internal-error unbound-variable) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-unbound-variable-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The variable ~S is unbound." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-undefined-function (#+(or clos pcl) internal-error undefined-function) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-undefined-function-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "The function ~S is undefined." (CELL-ERROR-NAME CONDITION))))) (define-condition internal-end-of-file (#+(or clos pcl) internal-error end-of-file) #-(or clos pcl) ((function-name nil)) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-end-of-file-) #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM) (when (internal-error-function-name condition) (format stream "Error in ~S [or a callee]: " (internal-error-function-name condition))) (FORMAT STREAM "Unexpected end of file on ~S." (STREAM-ERROR-STREAM CONDITION))))) (define-condition internal-simple-file-error (#+(or clos pcl) internal-simple-error file-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-file-error-) #-(or clos pcl)(:report internal-simple-error-printer)) (define-condition internal-simple-stream-error (#+(or clos pcl) internal-simple-error stream-error) #-(or clos pcl) ((function-name nil) format-string (format-arguments '())) #+(or clos pcl) () #-(or clos pcl)(:conc-name %%internal-simple-stream-error-) #-(or clos pcl)(:report internal-simple-error-printer)) gcl/clcs/unused/condition_precom.lisp0000755000175000017500000000331612240167764016731 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL")) #-(or lucid excl genera) (progn #+pcl (eval-when (compile load eval) (defun exercise-condition-classes () (let ((gfuns nil)) (dolist (name '(make-instance initialize-instance shared-initialize print-object)) (push (pcl::gdefinition name) gfuns)) (labels ((do-class (class) (dolist (gfun (pcl::specializer-generic-functions class)) (pushnew gfun gfuns)) (dolist (dsub (pcl::class-direct-subclasses class)) (do-class dsub)))) (do-class (find-class 'condition))) (mapc #'pcl::exercise-generic-function gfuns)) nil) ) #+pcl (progn (eval-when (compile) (exercise-condition-classes) ) (pcl::precompile-random-code-segments clcs) (eval-when (load eval) (exercise-condition-classes) ) ) #+kcl (install-clcs-symbols) ) (defun dsys::retry-operation (function retry-string) (loop (with-simple-restart (retry retry-string) (return-from dsys::retry-operation (funcall function))))) (defun dsys::operate-on-module (module initial-state system-operation) (if (null dsys::*retry-operation-list*) (dsys::operate-on-module1 module initial-state system-operation) (let ((retry-operation (car (last dsys::*retry-operation-list*))) (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*))) (restart-bind ((retry #'(lambda (&rest ignore) (declare (ignore ignore)) (funcall (car retry-operation))) :report-function #'(lambda (stream) (write-string (cdr retry-operation) stream)))) (dsys::operate-on-module module initial-state system-operation))))) gcl/clcs/gcl_clcs_handler.lisp0000755000175000017500000001123412240167764015337 0ustar cammcamm;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*- (IN-PACKAGE "CONDITIONS") (DEFVAR *HANDLER-CLUSTERS* NIL) (DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS) (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS) (ERROR "Ill-formed handler bindings.")) `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X))) BINDINGS)) *HANDLER-CLUSTERS*))) ,@FORMS)) (DEFVAR *BREAK-ON-SIGNALS* NIL) (DEFUN SIGNAL (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL)) (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*)) (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*) (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*." CONDITION)) (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN)) (LET ((CLUSTER (POP *HANDLER-CLUSTERS*))) (DOLIST (HANDLER CLUSTER) (WHEN (TYPEP CONDITION (CAR HANDLER)) (FUNCALL (CDR HANDLER) CONDITION) (RETURN NIL) ;? )))) NIL)) ;;; COERCE-TO-CONDITION ;;; Internal routine used in ERROR, CERROR, BREAK, and WARN 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) #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS)) (COND ((CONDITIONP DATUM) (IF ARGUMENTS (CERROR "Ignore the additional arguments." 'SIMPLE-TYPE-ERROR :DATUM ARGUMENTS :EXPECTED-TYPE 'NULL :FORMAT-STRING "You may not supply additional arguments ~ when giving ~S to ~S." :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME))) DATUM) ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM)) (APPLY #'MAKE-CONDITION DATUM ARGUMENTS)) ((STRINGP DATUM) (MAKE-CONDITION DEFAULT-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGUMENTS)) (T (ERROR 'SIMPLE-TYPE-ERROR :DATUM DATUM :EXPECTED-TYPE '(OR SYMBOL STRING) :FORMAT-STRING "Bad argument to ~S: ~S" :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM))))) (DEFUN ERROR (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR))) (SIGNAL CONDITION) (INVOKE-DEBUGGER CONDITION))) (DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS) (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS)) (APPLY #'ERROR DATUM ARGUMENTS)) NIL) (DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS) (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.") (INVOKE-DEBUGGER (MAKE-CONDITION 'SIMPLE-CONDITION :FORMAT-STRING FORMAT-STRING :FORMAT-ARGUMENTS FORMAT-ARGUMENTS))) NIL) (DEFUN WARN (DATUM &REST ARGUMENTS) (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN))) (CHECK-TYPE CONDITION WARNING "a warning condition") (IF *BREAK-ON-WARNINGS* (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*." CONDITION)) (RESTART-CASE (SIGNAL CONDITION) (MUFFLE-WARNING () :REPORT "Skip warning." (RETURN-FROM WARN NIL))) (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION) NIL)) (DEFMACRO HANDLER-CASE (FORM &REST CASES) (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)) ,VAR ;ignorable (TAGBODY (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE) (LIST (CADR ANNOTATED-CASE) `#'(LAMBDA (TEMP) ,@(IF (CADDR ANNOTATED-CASE) `((SETQ ,VAR TEMP))) (GO ,(CAR ANNOTATED-CASE))))) ANNOTATED-CASES) (RETURN-FROM ,TAG ,FORM)) ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE) (LIST (CAR ANNOTATED-CASE) (LET ((BODY (CDDDR ANNOTATED-CASE))) `(RETURN-FROM ,TAG ,(COND ((CADDR ANNOTATED-CASE) `(LET ((,(CAADDR ANNOTATED-CASE) ,VAR)) ,@BODY)) ((NOT (CDR BODY)) (CAR BODY)) (T `(PROGN ,@BODY))))))) ANNOTATED-CASES)))))))) (DEFMACRO IGNORE-ERRORS (&REST FORMS) `(HANDLER-CASE (PROGN ,@FORMS) (ERROR (CONDITION) (VALUES NIL CONDITION)))) gcl/japitest.lsp0000644000175000017500000003025112240167764012614 0ustar cammcamm;;; ;;; Japi is a cross-platform, easy to use (rough and ready) Java based GUI library ;;; Download a library and headers for your platform, and get the C examples ;;; and documentation from: ;;; ;;; http://www.japi.de/ ;;; ;;; This file shows how to use some of the available functions. You may assume ;;; that the only functions tested so far in the binding are those which appear ;;; below, as this file doubles as the test program. The binding is so simple ;;; however that so far no binding (APART FROM J_PRINT) has gone wrong of those ;;; tested so far! ;;; ;;; ;;; HOW TO USE THIS FILE ;;; ;;; (compile-file "c:/cvs/gcl/japitest.lsp") (load "c:/cvs/gcl/japitest.o") ;;; ;;; Requires either "java" or "jre" in the path to work. ;;; (in-package :japi-primitives) ;; Start up the Japi server (needs to find either "java" or "jre" in your path (defmacro with-server ((app-name debug-level) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(if (= 0 (jpr::j_start)) (format t (format nil "~S can't connect to the Japi GUI server." ,app-name)) (progn (j_setdebug ,debug-level) ,@ds (unwind-protect (progn ,@b) (j_quit)))))) ;; Use a frame and clean up afterwards even if trouble ensues (defmacro with-frame ((frame-var-name title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,frame-var-name (j_frame ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,frame-var-name))))) ;; Use a canvas and clean up afterwards even if trouble ensues (defmacro with-canvas ((canvas-var-name frame-obj x-size y-size) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,canvas-var-name (j_canvas ,frame-obj ,x-size ,y-size))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,canvas-var-name))))) ;; Use a text area and clean up afterwards even if trouble ensues (defmacro with-text-area ((text-area-var-name panel-obj x-size y-size) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,text-area-var-name (j_textarea ,panel-obj ,x-size ,y-size))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,text-area-var-name))))) ;; Use a pulldown menu bar and clean up afterwards even if trouble ensues (defmacro with-menu-bar ((bar-var-name frame-obj) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,bar-var-name (j_menubar ,frame-obj))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,bar-var-name))))) ;; Add a pulldown menu and clean up afterwards even if trouble ensues (defmacro with-menu ((menu-var-name bar-obj title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,menu-var-name (j_menu ,bar-obj ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,menu-var-name))))) ;; Add a pulldown menu item and clean up afterwards even if trouble ensues (defmacro with-menu-item ((item-var-name menu-obj title) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,item-var-name (j_menuitem ,menu-obj ,title))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,item-var-name))))) ;; Add a mouse listener and clean up afterwards even if trouble ensues (defmacro with-mouse-listener ((var-name obj type) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,var-name (j_mouselistener ,obj ,type))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,var-name))))) ;; Use a panel and clean up afterwards even if trouble ensues (defmacro with-panel ((panel-var-name frame-obj) . body) (multiple-value-bind (ds b) (si::find-declarations body) `(let ((,panel-var-name (j_panel ,frame-obj))) ,@ds (unwind-protect (progn ,@b) (j_dispose ,panel-var-name))))) ;; Run a five second frame in a Japi server (with-server ("GCL Japi library test GUI 1" 0) (with-frame (frame "Five Second Blank Test Frame") (j_show frame) (j_sleep 5000))) ;; Get a pointer to an array of ints (defCfun "static void* inta_ptr(object s)" 0 " return(s->fixa.fixa_self);") (defentry inta-ptr (object) (int "inta_ptr")) ;; Draw function (defun drawgraphics (drawable xmin ymin xmax ymax) (let* ((fntsize 10) (tmpstrx (format nil "XMax = ~D" xmax)) (tmpstry (format nil "YMax = ~D" ymax)) (tmpstrwidx (j_getstringwidth drawable tmpstrx))) (j_setfontsize drawable fntsize) (j_setnamedcolor drawable J_RED) (j_drawline drawable xmin ymin (- xmax 1) (- ymax 1)) (j_drawline drawable xmin (- ymax 1) (- xmax 1) ymin) (j_drawrect drawable xmin ymin (- xmax xmin 1) (- ymax xmin 1)) (j_setnamedcolor drawable J_BLACK) (j_drawline drawable xmin (- ymax 30) (- xmax 1) (- ymax 30)) (j_drawstring drawable (- (/ xmax 2) (/ tmpstrwidx 2)) (- ymax 40) tmpstrx) (j_drawline drawable (+ xmin 30) ymin (+ xmin 30) (- ymax 1)) (j_drawstring drawable (+ xmin 50) 40 tmpstry) (j_setnamedcolor drawable J_MAGENTA) (loop for i from 1 to 10 do (j_drawoval drawable (+ xmin (/ (- xmax xmin) 2)) (+ ymin (/ (- ymax ymin) 2)) (* (/ (- xmax xmin) 20) i) (* (/ (- ymax ymin) 20) i))) (j_setnamedcolor drawable J_BLUE) (let ((y ymin) (teststr "JAPI Test Text")) (loop for i from 5 to 21 do (j_setfontsize drawable i) (let ((x (- xmax (j_getstringwidth drawable teststr)))) (setf y (+ y (j_getfontheight drawable))) (j_drawstring drawable x y teststr)))))) ;; Run some more extensive tests (with-server ("GCL Japi library test GUI 2" 0) (with-frame (frame "Draw") (j_show frame) (let ((alert (j_messagebox frame "Two second alert box" "label"))) (j_sleep 2000) (j_dispose alert)) (let ((result1 (j_alertbox frame "label1" "label2" "OK")) (result2 (j_choicebox2 frame "label1" "label2" "Yes" "No")) (result3 (j_choicebox3 frame "label1" "label2" "Yes" "No" "Cancel"))) (format t "Requestor results were: ~D, ~D, ~D~%" result1 result2 result3)) (j_setborderlayout frame) (with-menu-bar (menubar frame) (with-menu (file menubar "File") (with-menu-item (print file "Print") (with-menu-item (save file "Save BMP") (with-menu-item (quit file "Quit") (with-canvas (canvas frame 400 600) (j_pack frame) (drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas)) (j_show frame) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit)) t) (when (= obj canvas) (j_setnamedcolorbg canvas J_WHITE) (drawgraphics canvas 10 10 (- (j_getwidth canvas) 10) (- (j_getheight canvas) 10))) (when (= obj print) (let ((printer (j_printer frame))) (when (> 0 printer) (drawgraphics printer 40 40 (- (j_getwidth printer) 80) (- (j_getheight printer) 80)) (j_print printer)))) (when (= obj save) (let ((image (j_image 600 800))) (drawgraphics image 0 0 600 800) (when (= 0 (j_saveimage image "test.bmp" J_BMP)) (j_alertbox frame "Problems" "Can't save the image" "OK"))))))))))))) ;; Try some mouse handling (with-server ("GCL Japi library test GUI 3" 0) (with-frame (frame "Move and drag the mouse") (j_setsize frame 430 240) (j_setnamedcolorbg frame J_LIGHT_GRAY) (with-canvas (canvas1 frame 200 200) (with-canvas (canvas2 frame 200 200) (j_setpos canvas1 10 30) (j_setpos canvas2 220 30) (with-mouse-listener (pressed canvas1 J_PRESSED) (with-mouse-listener (dragged canvas1 J_DRAGGED) (with-mouse-listener (released canvas1 J_RELEASED) (with-mouse-listener (entered canvas2 J_ENTERERD) (with-mouse-listener (moved canvas2 J_MOVED) (with-mouse-listener (exited canvas2 J_EXITED) (j_show frame) ;; Allocate immovable storage for passing data back from C land. ;; Uses the GCL only make-array keyword :static (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (pxa (inta-ptr xa)) (pya (inta-ptr ya)) (x 0) (y 0) (get-mouse-xy (lambda (obj) (progn (j_getmousepos obj pxa pya) (setf x (aref xa 0)) (setf y (aref ya 0))))) (startx 0) (starty 0)) (do ((obj (j_nextaction) (j_nextaction))) ((= obj frame) t) (when (= obj pressed) (funcall get-mouse-xy pressed) (setf startx x) (setf starty y)) (when (= obj dragged) (funcall get-mouse-xy dragged) (j_drawrect canvas1 startx starty (- x startx) (- y starty))) (when (= obj released) (funcall get-mouse-xy released) (j_drawrect canvas1 startx starty (- x startx) (- y starty))) (when (= obj entered) (funcall get-mouse-xy entered) (setf startx x) (setf starty y)) (when (= obj moved) (funcall get-mouse-xy moved) (j_drawline canvas2 startx starty x y)) (setf startx x) (setf starty y) (when (= obj exited) (funcall get-mouse-xy exited) (j_drawline canvas2 startx starty x y)))))))))))))) ;; Text editor demo (with-server ("GCL Japi library test text editor" 0) (with-frame (frame "A simple editor") (j_setgridlayout frame 1 1) (with-panel (panel frame) (j_setgridlayout panel 1 1) (with-menu-bar (menubar frame) (with-menu (file-mi menubar "File") (with-menu-item (new-mi file-mi "New") (with-menu-item (save-mi file-mi "Save") (j_seperator file-mi) (with-menu-item (quit-mi file-mi "Quit") (with-menu (edit-mi menubar "Edit") (with-menu-item (select-all-mi edit-mi "Select All") (j_seperator edit-mi) (with-menu-item (cut-mi edit-mi "Cut") (with-menu-item (copy-mi edit-mi "Copy") (with-menu-item (paste-mi edit-mi "Paste") (with-text-area (text panel 15 4) (j_setfont text J_DIALOGIN J_BOLD 18) (let ((new-text (format nil "JAPI (Java Application~%Programming Interface)~%a platform and language~%independent API"))) (j_settext text new-text) (j_show frame) (j_pack frame) (j_setrows text 4) (j_setcolumns text 15) (j_pack frame) ;; Allocate immovable storage for passing data back from C land. ;; Uses the GCL only make-array keyword :static (let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) (pxa (inta-ptr xa)) (pya (inta-ptr ya)) (x 0) (y 0) (get-mouse-xy (lambda (obj) (progn (j_getmousepos obj pxa pya) (setf x (aref xa 0)) (setf y (aref ya 0))))) (startx 0) (starty 0) (selstart 0) (selend 0) (text-buffer (make-array 64000 :initial-element 0 :element-type 'character :static t)) ; (text-buffer (make-string 64000 :initial-element #\0)) (p-text-buffer (inta-ptr text-buffer))) (do ((obj (j_nextaction) (j_nextaction))) ((or (= obj frame) (= obj quit-mi))t) (when (= obj panel) (format t "Size changed to ~D rows ~D columns~%" (j_getrows text) (j_getcolumns text)) (format t "Size changed to ~D x ~D pixels~%" (j_getwidth text) (j_getheight text))) (when (= obj text) (format t "Text changed (len=~D)~%" (j_getlength text) )) (when (= obj new-mi) (j_settext new-text)) (when (= obj save-mi) (j_gettext text text-buffer)) (when (= obj select-all-mi) (j_selectall text)) (when (or (= obj cut-mi) (= obj copy-mi) (= obj paste-mi)) (setf selstart (1- (j_getselstart text))) (setf selend (1- (j_getselend text)))) (when (= obj cut-mi) (j_getseltext text p-text-buffer) (j_delete text (1- (j_getselstart text)) (1- (j_getselend text))) (setf selend selstart)) (when (= obj copy-mi) (j_getseltext text p-text-buffer)) (when (= obj paste-mi) (if (= selstart selend) (j_inserttext text p-text-buffer (1- (j_getcurpos text))) (j_replacetext text p-text-buffer (1- (j_getselstart text)) (1- (j_getselend text)))) )))))))))))))))))) gcl/readme.mingw0000755000175000017500000000660012240167764012555 0ustar cammcamm=============================================== BUILDING NATIVE WIN32 GNU COMMON LISP FROM CVS =============================================== The preferred build host system for the Mingw32 compiler is MSYS. I use gcc version 3.3.1 and binutils 2.14.90, but earlier versions of gcc back to 2.95 are OK provided that you remove the "-fno-zero-initialized-in-bss" flag in "h/mingw.defs" before running "configure". Note that gcc 3.3.3 and gcc 3.4.0 do NOT work; likewise binutils 2.13.90 and 2.15.90. The working binutils version can be found at: ftp://ftp.sf.net/m/mi/mingw/binutils-2.14.90-20030807-1.tar.gz =============================================== BUILDING GCL USING MSYS AS THE HOST =============================================== BUILD TOOLS - Mingw32 Version 2 Windows native gcc: http://www.mingw.org/ - MSYS Mingw build environment, including the MSYS DTK http://www.mingw.org/ - Source code for GCL. http://savannah.gnu.org/projects/gcl/ Subject to the above warnings, it is usually a good idea to keep up to date with Mingw32 and MSYS. Updates for various parts of these packages are available on the web site. SHORT SETUP NOTES - Install Mingw32 and MSYS using the instructions at those sites. DETAILED SETUP NOTES - Start by installing the latest version of MinGW2.exe. - By looking at the dates and version numbers appended to the other packages on the download page, get any versions of gcc 3.2, binutils, mingw-runtime, and w32api that are later than the Mingw2 package. - Go to the top level Mingw32 installation directory - the one in which you can see "bin", "lib" etc - Extract those other packages in that directory eg: tar xzf rumpty-dumpty.tar.gz - Remove the Mingw version of "make" from the bin directory - it has serious bugs and will not work properly for most tasks including building GCL and Maxima. We will be using the MSYS version. - Get MSYS and install it - follow the instructions - subscribe to the mailing list and read the archives. - In the MSYS directory install the "msysDTK-1.0.0-alpha-1.tar.gz" package which gives you cvs, ssh, rlogin, etc. BUILDING - Change to your GCL source directory eg: cd /c/cvs/gcl - You are now ready to configure GCL: ./configure --prefix="c:/gcl" > configure.log 2>&1 Change the prefix directory as required for your final installation path. I find it helpful to redirect output from "configure" and "make" into log files for debugging and checking. - Check the log. - Type: make >& make.log - The "saved_gcl.exe" should turn up eventually in the unixport directory. You can try it out directly by typing: ./unixport/saved_gcl.exe at the command prompt. - To install: make install >& install.log It is necessary to install GCL before building Maxima. - The batch file "gclm.bat" can be used to make a Windows desktop shortcut. - BFD fasloading, Stratified Garbage Collection (SGC) readline and GCL-TK don't work under Windows. The configuration options above provide a "traditional" GCL executable which will build the current CVS version of Maxima. The BFD option will depend on someone with knowledge of BFD and PE-COFF linking fixing some problems with the BFD library - I am slowly absorbing the info needed, but we really need input from an expert. My inclination is to stick with custom relocation as BFD is less efficient. Mike Thomas 15 June 2004 gcl/makdefs0000755000175000017500000000423412240167764011613 0ustar cammcamm# constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: add-defs 386-linux /usr/local/lib # constructed by wfs using: add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs 386-linux /usr/local # constructed by wfs using: add-defs 386-linux /usr/local # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by wfs using: ./add-defs cygwin # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: ./add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: add-defs cygwinb # constructed by using: ./add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by using: add-defs gnuwin95 # constructed by using: ./add-defs gnuwin95 # constructed by wfs using: ./add-defs 386-linux # constructed by wfs using: ./add-defs 386-linux gcl/minvers0000755000175000017500000000000512240167764011654 0ustar cammcamm6.10 gcl/COPYING.LIB-2.00000755000175000017500000006126112240167764012216 0ustar cammcamm GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! gcl/config.sub0000755000175000017500000010344512240167764012242 0ustar cammcamm#! /bin/sh # Configuration validation subroutine script. # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, # 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 # Free Software Foundation, Inc. timestamp='2010-01-22' # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA # 02110-1301, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Please send patches to . Submit a context # diff and a properly formatted GNU ChangeLog entry. # # Configuration subroutine to validate and canonicalize a configuration type. # Supply the specified configuration type as an argument. # If it is invalid, we print an error message on stderr and exit with code 1. # Otherwise, we print the canonical config type on stdout and succeed. # You can get the latest version of this script from: # http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD # This file is supposed to be the same for all GNU packages # and recognize all the CPU types, system types and aliases # that are meaningful with *any* GNU software. # Each package is responsible for reporting which valid configurations # it does not support. The user should be able to distinguish # a failure to support a valid configuration from a meaningless # configuration. # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM # or in some cases, the newer four-part form: # CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. me=`echo "$0" | sed -e 's,.*/,,'` usage="\ Usage: $0 [OPTION] CPU-MFR-OPSYS $0 [OPTION] ALIAS Canonicalize a configuration name. Operation modes: -h, --help print this help, then exit -t, --time-stamp print date of last modification, then exit -v, --version print version number, then exit Report bugs and patches to ." version="\ GNU config.sub ($timestamp) Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." help=" Try \`$me --help' for more information." # Parse command line while test $# -gt 0 ; do case $1 in --time-stamp | --time* | -t ) echo "$timestamp" ; exit ;; --version | -v ) echo "$version" ; exit ;; --help | --h* | -h ) echo "$usage"; exit ;; -- ) # Stop option processing shift; break ;; - ) # Use stdin as input. break ;; -* ) echo "$me: invalid option $1$help" exit 1 ;; *local*) # First pass through any local machine types. echo $1 exit ;; * ) break ;; esac done case $# in 0) echo "$me: missing argument$help" >&2 exit 1;; 1) ;; *) echo "$me: too many arguments$help" >&2 exit 1;; esac # Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). # Here we must recognize all the valid KERNEL-OS combinations. maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` case $maybe_os in nto-qnx* | linux-gnu* | linux-dietlibc | linux-newlib* | linux-uclibc* | \ uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | \ kopensolaris*-gnu* | \ storm-chaos* | os2-emx* | rtmk-nova*) os=-$maybe_os basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` ;; *) basic_machine=`echo $1 | sed 's/-[^-]*$//'` if [ $basic_machine != $1 ] then os=`echo $1 | sed 's/.*-/-/'` else os=; fi ;; esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also ### recognize some manufacturers as not being operating systems, so we ### can provide default operating systems below. case $os in -sun*os*) # Prevent following clause from handling this invalid input. ;; -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ -apple | -axis | -knuth | -cray | -microblaze) os= basic_machine=$1 ;; -bluegene*) os=-cnk ;; -sim | -cisco | -oki | -wec | -winbond) os= basic_machine=$1 ;; -scout) ;; -wrs) os=-vxworks basic_machine=$1 ;; -chorusos*) os=-chorusos basic_machine=$1 ;; -chorusrdb) os=-chorusrdb basic_machine=$1 ;; -hiux*) os=-hiuxwe2 ;; -sco6) os=-sco5v6 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5) os=-sco3.2v5 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco5v6*) # Don't forget version if it is 3.2v4 or newer. basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -udk*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos ;; -ptx*) basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` ;; -windowsnt*) os=`echo $os | sed -e 's/windowsnt/winnt/'` ;; -psos*) os=-psos ;; -mint | -mint[0-9]*) basic_machine=m68k-atari os=-mint ;; esac # Decode aliases for certain CPU-COMPANY combinations. case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. 1750a | 580 \ | a29k \ | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ | am33_2.0 \ | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \ | bfin \ | c4x | clipper \ | d10v | d30v | dlx | dsp16xx \ | fido | fr30 | frv \ | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \ | maxq | mb | microblaze | mcore | mep | metag \ | mips | mipsbe | mipseb | mipsel | mipsle \ | mips16 \ | mips64 | mips64el \ | mips64octeon | mips64octeonel \ | mips64orion | mips64orionel \ | mips64r5900 | mips64r5900el \ | mips64vr | mips64vrel \ | mips64vr4100 | mips64vr4100el \ | mips64vr4300 | mips64vr4300el \ | mips64vr5000 | mips64vr5000el \ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipstx39 | mipstx39el \ | mn10200 | mn10300 \ | moxie \ | mt \ | msp430 \ | nios | nios2 \ | ns16k | ns32k \ | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ | pyramid \ | rx \ | score \ | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \ | sh64 | sh64le \ | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \ | sparcv8 | sparcv9 | sparcv9b | sparcv9v \ | spu | strongarm \ | tahoe | thumb | tic4x | tic80 | tron \ | ubicom32 \ | v850 | v850e \ | we32k \ | x86 | xc16x | xscale | xscalee[bl] | xstormy16 | xtensa \ | z8k | z80) basic_machine=$basic_machine-unknown ;; m6811 | m68hc11 | m6812 | m68hc12 | picochip) # Motorola 68HC11/12. basic_machine=$basic_machine-unknown os=-none ;; m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) ;; ms1) basic_machine=mt-unknown ;; # We use `pc' rather than `unknown' # because (1) that's what they normally are, and # (2) the word "unknown" tends to confuse beginning users. i*86 | x86_64) basic_machine=$basic_machine-pc ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. 580-* \ | a29k-* \ | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ | avr-* | avr32-* \ | bfin-* | bs2000-* \ | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \ | clipper-* | craynv-* | cydra-* \ | d10v-* | d30v-* | dlx-* \ | elxsi-* \ | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \ | h8300-* | h8500-* \ | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \ | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \ | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ | mips16-* \ | mips64-* | mips64el-* \ | mips64octeon-* | mips64octeonel-* \ | mips64orion-* | mips64orionel-* \ | mips64r5900-* | mips64r5900el-* \ | mips64vr-* | mips64vrel-* \ | mips64vr4100-* | mips64vr4100el-* \ | mips64vr4300-* | mips64vr4300el-* \ | mips64vr5000-* | mips64vr5000el-* \ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipstx39-* | mipstx39el-* \ | mmix-* \ | mt-* \ | msp430-* \ | nios-* | nios2-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ | pyramid-* \ | romp-* | rs6000-* | rx-* \ | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \ | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \ | sparclite-* \ | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | strongarm-* | sv1-* | sx?-* \ | tahoe-* | thumb-* \ | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \ | tile-* | tilegx-* \ | tron-* \ | ubicom32-* \ | v850-* | v850e-* | vax-* \ | we32k-* \ | x86-* | x86_64-* | xc16x-* | xps100-* | xscale-* | xscalee[bl]-* \ | xstormy16-* | xtensa*-* \ | ymp-* \ | z8k-* | z80-*) ;; # Recognize the basic CPU types without company name, with glob match. xtensa*) basic_machine=$basic_machine-unknown ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. 386bsd) basic_machine=i386-unknown os=-bsd ;; 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) basic_machine=m68000-att ;; 3b*) basic_machine=we32k-att ;; a29khif) basic_machine=a29k-amd os=-udi ;; abacus) basic_machine=abacus-unknown ;; adobe68k) basic_machine=m68010-adobe os=-scout ;; alliant | fx80) basic_machine=fx80-alliant ;; altos | altos3068) basic_machine=m68k-altos ;; am29k) basic_machine=a29k-none os=-bsd ;; amd64) basic_machine=x86_64-pc ;; amd64-*) basic_machine=x86_64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; amdahl) basic_machine=580-amdahl os=-sysv ;; amiga | amiga-*) basic_machine=m68k-unknown ;; amigaos | amigados) basic_machine=m68k-unknown os=-amigaos ;; amigaunix | amix) basic_machine=m68k-unknown os=-sysv4 ;; apollo68) basic_machine=m68k-apollo os=-sysv ;; apollo68bsd) basic_machine=m68k-apollo os=-bsd ;; aros) basic_machine=i386-pc os=-aros ;; aux) basic_machine=m68k-apple os=-aux ;; balance) basic_machine=ns32k-sequent os=-dynix ;; blackfin) basic_machine=bfin-unknown os=-linux ;; blackfin-*) basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; bluegene*) basic_machine=powerpc-ibm os=-cnk ;; c90) basic_machine=c90-cray os=-unicos ;; cegcc) basic_machine=arm-unknown os=-cegcc ;; convex-c1) basic_machine=c1-convex os=-bsd ;; convex-c2) basic_machine=c2-convex os=-bsd ;; convex-c32) basic_machine=c32-convex os=-bsd ;; convex-c34) basic_machine=c34-convex os=-bsd ;; convex-c38) basic_machine=c38-convex os=-bsd ;; cray | j90) basic_machine=j90-cray os=-unicos ;; craynv) basic_machine=craynv-cray os=-unicosmp ;; cr16) basic_machine=cr16-unknown os=-elf ;; crds | unos) basic_machine=m68k-crds ;; crisv32 | crisv32-* | etraxfs*) basic_machine=crisv32-axis ;; cris | cris-* | etrax*) basic_machine=cris-axis ;; crx) basic_machine=crx-unknown os=-elf ;; da30 | da30-*) basic_machine=m68k-da30 ;; decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) basic_machine=mips-dec ;; decsystem10* | dec10*) basic_machine=pdp10-dec os=-tops10 ;; decsystem20* | dec20*) basic_machine=pdp10-dec os=-tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) basic_machine=m68k-motorola ;; delta88) basic_machine=m88k-motorola os=-sysv3 ;; dicos) basic_machine=i686-pc os=-dicos ;; djgpp) basic_machine=i586-pc os=-msdosdjgpp ;; dpx20 | dpx20-*) basic_machine=rs6000-bull os=-bosx ;; dpx2* | dpx2*-bull) basic_machine=m68k-bull os=-sysv3 ;; ebmon29k) basic_machine=a29k-amd os=-ebmon ;; elxsi) basic_machine=elxsi-elxsi os=-bsd ;; encore | umax | mmax) basic_machine=ns32k-encore ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson os=-ose ;; fx2800) basic_machine=i860-alliant ;; genix) basic_machine=ns32k-ns ;; gmicro) basic_machine=tron-gmicro os=-sysv ;; go32) basic_machine=i386-pc os=-go32 ;; h3050r* | hiux*) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; h8300hms) basic_machine=h8300-hitachi os=-hms ;; h8300xray) basic_machine=h8300-hitachi os=-xray ;; h8500hms) basic_machine=h8500-hitachi os=-hms ;; harris) basic_machine=m88k-harris os=-sysv3 ;; hp300-*) basic_machine=m68k-hp ;; hp300bsd) basic_machine=m68k-hp os=-bsd ;; hp300hpux) basic_machine=m68k-hp os=-hpux ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k2[0-9][0-9] | hp9k31[0-9]) basic_machine=m68000-hp ;; hp9k3[2-9][0-9]) basic_machine=m68k-hp ;; hp9k6[0-9][0-9] | hp6[0-9][0-9]) basic_machine=hppa1.0-hp ;; hp9k7[0-79][0-9] | hp7[0-79][0-9]) basic_machine=hppa1.1-hp ;; hp9k78[0-9] | hp78[0-9]) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) # FIXME: really hppa2.0-hp basic_machine=hppa1.1-hp ;; hp9k8[0-9][13679] | hp8[0-9][13679]) basic_machine=hppa1.1-hp ;; hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; hppa-next) os=-nextstep3 ;; hppaosf) basic_machine=hppa1.1-hp os=-osf ;; hppro) basic_machine=hppa1.1-hp os=-proelf ;; i370-ibm* | ibm*) basic_machine=i370-ibm ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? i*86v32) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; i*86v4*) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; i*86v) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; i*86sol2) basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; i386mach) basic_machine=i386-mach os=-mach ;; i386-vsta | vsta) basic_machine=i386-unknown os=-vsta ;; iris | iris4d) basic_machine=mips-sgi case $os in -irix*) ;; *) os=-irix4 ;; esac ;; isi68 | isi) basic_machine=m68k-isi os=-sysv ;; m68knommu) basic_machine=m68k-unknown os=-linux ;; m68knommu-*) basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; m88k-omron*) basic_machine=m88k-omron ;; magnum | m3230) basic_machine=mips-mips os=-sysv ;; merlin) basic_machine=ns32k-utek os=-sysv ;; microblaze) basic_machine=microblaze-xilinx ;; mingw32) basic_machine=i386-pc os=-mingw32 ;; mingw32ce) basic_machine=arm-unknown os=-mingw32ce ;; miniframe) basic_machine=m68000-convergent ;; *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) basic_machine=m68k-atari os=-mint ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; mips3*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown ;; monitor) basic_machine=m68k-rom68k os=-coff ;; morphos) basic_machine=powerpc-unknown os=-morphos ;; msdos) basic_machine=i386-pc os=-msdos ;; ms1-*) basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'` ;; mvs) basic_machine=i370-ibm os=-mvs ;; ncr3000) basic_machine=i486-ncr os=-sysv4 ;; netbsd386) basic_machine=i386-unknown os=-netbsd ;; netwinder) basic_machine=armv4l-rebel os=-linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony os=-newsos ;; news1000) basic_machine=m68030-sony os=-newsos ;; news-3600 | risc-news) basic_machine=mips-sony os=-newsos ;; necv70) basic_machine=v70-nec os=-sysv ;; next | m*-next ) basic_machine=m68k-next case $os in -nextstep* ) ;; -ns2*) os=-nextstep2 ;; *) os=-nextstep3 ;; esac ;; nh3000) basic_machine=m68k-harris os=-cxux ;; nh[45]000) basic_machine=m88k-harris os=-cxux ;; nindy960) basic_machine=i960-intel os=-nindy ;; mon960) basic_machine=i960-intel os=-mon960 ;; nonstopux) basic_machine=mips-compaq os=-nonstopux ;; np1) basic_machine=np1-gould ;; nsr-tandem) basic_machine=nsr-tandem ;; op50n-* | op60c-*) basic_machine=hppa1.1-oki os=-proelf ;; openrisc | openrisc-*) basic_machine=or32-unknown ;; os400) basic_machine=powerpc-ibm os=-os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson os=-ose ;; os68k) basic_machine=m68k-none os=-os68k ;; pa-hitachi) basic_machine=hppa1.1-hitachi os=-hiuxwe2 ;; paragon) basic_machine=i860-intel os=-osf ;; parisc) basic_machine=hppa-unknown os=-linux ;; parisc-*) basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'` os=-linux ;; pbd) basic_machine=sparc-tti ;; pbb) basic_machine=m68k-tti ;; pc532 | pc532-*) basic_machine=ns32k-pc532 ;; pc98) basic_machine=i386-pc ;; pc98-*) basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium | p5 | k5 | k6 | nexgen | viac3) basic_machine=i586-pc ;; pentiumpro | p6 | 6x86 | athlon | athlon_*) basic_machine=i686-pc ;; pentiumii | pentium2 | pentiumiii | pentium3) basic_machine=i686-pc ;; pentium4) basic_machine=i786-pc ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumpro-* | p6-* | 6x86-* | athlon-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pentium4-*) basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould ;; power) basic_machine=power-ibm ;; ppc) basic_machine=powerpc-unknown ;; ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppcle | powerpclittle | ppc-le | powerpc-little) basic_machine=powerpcle-unknown ;; ppcle-* | powerpclittle-*) basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64) basic_machine=powerpc64-unknown ;; ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ppc64le | powerpc64little | ppc64-le | powerpc64-little) basic_machine=powerpc64le-unknown ;; ppc64le-* | powerpc64little-*) basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` ;; ps2) basic_machine=i386-ibm ;; pw32) basic_machine=i586-unknown os=-pw32 ;; rdos) basic_machine=i386-pc os=-rdos ;; rom68k) basic_machine=m68k-rom68k os=-coff ;; rm[46]00) basic_machine=mips-siemens ;; rtpc | rtpc-*) basic_machine=romp-ibm ;; s390 | s390-*) basic_machine=s390-ibm ;; s390x | s390x-*) basic_machine=s390x-ibm ;; sa29200) basic_machine=a29k-amd os=-udi ;; sb1) basic_machine=mipsisa64sb1-unknown ;; sb1el) basic_machine=mipsisa64sb1el-unknown ;; sde) basic_machine=mipsisa32-sde os=-elf ;; sei) basic_machine=mips-sei os=-seiux ;; sequent) basic_machine=i386-sequent ;; sh) basic_machine=sh-hitachi os=-hms ;; sh5el) basic_machine=sh5le-unknown ;; sh64) basic_machine=sh64-unknown ;; sparclite-wrs | simso-wrs) basic_machine=sparclite-wrs os=-vxworks ;; sps7) basic_machine=m68k-bull os=-sysv2 ;; spur) basic_machine=spur-unknown ;; st2000) basic_machine=m68k-tandem ;; stratus) basic_machine=i860-stratus os=-sysv4 ;; sun2) basic_machine=m68000-sun ;; sun2os3) basic_machine=m68000-sun os=-sunos3 ;; sun2os4) basic_machine=m68000-sun os=-sunos4 ;; sun3os3) basic_machine=m68k-sun os=-sunos3 ;; sun3os4) basic_machine=m68k-sun os=-sunos4 ;; sun4os3) basic_machine=sparc-sun os=-sunos3 ;; sun4os4) basic_machine=sparc-sun os=-sunos4 ;; sun4sol2) basic_machine=sparc-sun os=-solaris2 ;; sun3 | sun3-*) basic_machine=m68k-sun ;; sun4) basic_machine=sparc-sun ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun ;; sv1) basic_machine=sv1-cray os=-unicos ;; symmetry) basic_machine=i386-sequent os=-dynix ;; t3e) basic_machine=alphaev5-cray os=-unicos ;; t90) basic_machine=t90-cray os=-unicos ;; tic54x | c54x*) basic_machine=tic54x-unknown os=-coff ;; tic55x | c55x*) basic_machine=tic55x-unknown os=-coff ;; tic6x | c6x*) basic_machine=tic6x-unknown os=-coff ;; # This must be matched before tile*. tilegx*) basic_machine=tilegx-unknown os=-linux-gnu ;; tile*) basic_machine=tile-unknown os=-linux-gnu ;; tx39) basic_machine=mipstx39-unknown ;; tx39el) basic_machine=mipstx39el-unknown ;; toad1) basic_machine=pdp10-xkl os=-tops20 ;; tower | tower-32) basic_machine=m68k-ncr ;; tpf) basic_machine=s390x-ibm os=-tpf ;; udi29k) basic_machine=a29k-amd os=-udi ;; ultra3) basic_machine=a29k-nyu os=-sym1 ;; v810 | necv810) basic_machine=v810-nec os=-none ;; vaxv) basic_machine=vax-dec os=-sysv ;; vms) basic_machine=vax-dec os=-vms ;; vpp*|vx|vx-*) basic_machine=f301-fujitsu ;; vxworks960) basic_machine=i960-wrs os=-vxworks ;; vxworks68) basic_machine=m68k-wrs os=-vxworks ;; vxworks29k) basic_machine=a29k-wrs os=-vxworks ;; w65*) basic_machine=w65-wdc os=-none ;; w89k-*) basic_machine=hppa1.1-winbond os=-proelf ;; xbox) basic_machine=i686-pc os=-mingw32 ;; xps | xps100) basic_machine=xps100-honeywell ;; ymp) basic_machine=ymp-cray os=-unicos ;; z8k-*-coff) basic_machine=z8k-unknown os=-sim ;; z80-*-coff) basic_machine=z80-unknown os=-sim ;; none) basic_machine=none-none os=-none ;; # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. w89k) basic_machine=hppa1.1-winbond ;; op50n) basic_machine=hppa1.1-oki ;; op60c) basic_machine=hppa1.1-oki ;; romp) basic_machine=romp-ibm ;; mmix) basic_machine=mmix-knuth ;; rs6000) basic_machine=rs6000-ibm ;; vax) basic_machine=vax-dec ;; pdp10) # there are many clones, so DEC is not a safe bet basic_machine=pdp10-unknown ;; pdp11) basic_machine=pdp11-dec ;; we32k) basic_machine=we32k-att ;; sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele) basic_machine=sh-unknown ;; sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v) basic_machine=sparc-sun ;; cydra) basic_machine=cydra-cydrome ;; orion) basic_machine=orion-highlevel ;; orion105) basic_machine=clipper-highlevel ;; mac | mpw | mac-mpw) basic_machine=m68k-apple ;; pmac | pmac-mpw) basic_machine=powerpc-apple ;; *-unknown) # Make sure to match an already-canonicalized machine name. ;; *) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; esac # Here we canonicalize certain aliases for manufacturers. case $basic_machine in *-digital*) basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` ;; *-commodore*) basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` ;; *) ;; esac # Decode manufacturer-specific aliases for certain operating systems. if [ x"$os" != x"" ] then case $os in # First match some system type aliases # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -auroraux) os=-auroraux ;; -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` ;; -solaris) os=-solaris2 ;; -svr4*) os=-sysv4 ;; -unixware*) os=-sysv4.2uw ;; -gnu/linux*) os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \ | -sym* | -kopensolaris* \ | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ | -aos* | -aros* \ | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \ | -openbsd* | -solidbsd* \ | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \ | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ | -chorusos* | -chorusrdb* | -cegcc* \ | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -linux-gnu* | -linux-newlib* | -linux-uclibc* \ | -uxpv* | -beos* | -mpeix* | -udk* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*) case $basic_machine in x86-* | i*86-*) ;; *) os=-nto$os ;; esac ;; -nto-qnx*) ;; -nto*) os=`echo $os | sed -e 's|nto|nto-qnx|'` ;; -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \ | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) ;; -mac*) os=`echo $os | sed -e 's|mac|macos|'` ;; -linux-dietlibc) os=-linux-dietlibc ;; -linux*) os=`echo $os | sed -e 's|linux|linux-gnu|'` ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; -sunos6*) os=`echo $os | sed -e 's|sunos6|solaris3|'` ;; -opened*) os=-openedition ;; -os400*) os=-os400 ;; -wince*) os=-wince ;; -osfrose*) os=-osfrose ;; -osf*) os=-osf ;; -utek*) os=-bsd ;; -dynix*) os=-bsd ;; -acis*) os=-aos ;; -atheos*) os=-atheos ;; -syllable*) os=-syllable ;; -386bsd) os=-bsd ;; -ctix* | -uts*) os=-sysv ;; -nova*) os=-rtmk-nova ;; -ns2 ) os=-nextstep2 ;; -nsk*) os=-nsk ;; # Preserve the version number of sinix5. -sinix5.*) os=`echo $os | sed -e 's|sinix|sysv|'` ;; -sinix*) os=-sysv4 ;; -tpf*) os=-tpf ;; -triton*) os=-sysv3 ;; -oss*) os=-sysv3 ;; -svr4) os=-sysv4 ;; -svr3) os=-sysv3 ;; -sysvr4) os=-sysv4 ;; # This must come after -sysvr4. -sysv*) ;; -ose*) os=-ose ;; -es1800*) os=-ose ;; -xenix) os=-xenix ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) os=-mint ;; -aros*) os=-aros ;; -kaos*) os=-kaos ;; -zvmoe) os=-zvmoe ;; -dicos*) os=-dicos ;; -nacl*) ;; -none) ;; *) # Get rid of the `-' at the beginning of $os. os=`echo $os | sed 's/[^-]*-//'` echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 exit 1 ;; esac else # Here we handle the default operating systems that come with various machines. # The value should be what the vendor currently ships out the door with their # machine or put another way, the most popular os provided with the machine. # Note that if you're going to try to match "-MANUFACTURER" here (say, # "-sun"), then you have to tell the case statement up towards the top # that MANUFACTURER isn't an operating system. Otherwise, code above # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. case $basic_machine in score-*) os=-elf ;; spu-*) os=-elf ;; *-acorn) os=-riscix1.2 ;; arm*-rebel) os=-linux ;; arm*-semi) os=-aout ;; c4x-* | tic4x-*) os=-coff ;; # This must come before the *-dec entry. pdp10-*) os=-tops20 ;; pdp11-*) os=-none ;; *-dec | vax-*) os=-ultrix4.2 ;; m68*-apollo) os=-domain ;; i386-sun) os=-sunos4.0.2 ;; m68000-sun) os=-sunos3 # This also exists in the configure program, but was not the # default. # os=-sunos4 ;; m68*-cisco) os=-aout ;; mep-*) os=-elf ;; mips*-cisco) os=-elf ;; mips*-*) os=-elf ;; or32-*) os=-coff ;; *-tti) # must be before sparc entry or we get the wrong os. os=-sysv3 ;; sparc-* | *-sun) os=-sunos4.1.1 ;; *-be) os=-beos ;; *-haiku) os=-haiku ;; *-ibm) os=-aix ;; *-knuth) os=-mmixware ;; *-wec) os=-proelf ;; *-winbond) os=-proelf ;; *-oki) os=-proelf ;; *-hp) os=-hpux ;; *-hitachi) os=-hiux ;; i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) os=-sysv ;; *-cbm) os=-amigaos ;; *-dg) os=-dgux ;; *-dolphin) os=-sysv3 ;; m68k-ccur) os=-rtu ;; m88k-omron*) os=-luna ;; *-next ) os=-nextstep ;; *-sequent) os=-ptx ;; *-crds) os=-unos ;; *-ns) os=-genix ;; i370-*) os=-mvs ;; *-next) os=-nextstep3 ;; *-gould) os=-sysv ;; *-highlevel) os=-bsd ;; *-encore) os=-bsd ;; *-sgi) os=-irix ;; *-siemens) os=-sysv4 ;; *-masscomp) os=-rtu ;; f30[01]-fujitsu | f700-fujitsu) os=-uxpv ;; *-rom68k) os=-coff ;; *-*bug) os=-coff ;; *-apple) os=-macos ;; *-atari*) os=-mint ;; *) os=-none ;; esac fi # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. vendor=unknown case $basic_machine in *-unknown) case $os in -riscix*) vendor=acorn ;; -sunos*) vendor=sun ;; -cnk*|-aix*) vendor=ibm ;; -beos*) vendor=be ;; -hpux*) vendor=hp ;; -mpeix*) vendor=hp ;; -hiux*) vendor=hitachi ;; -unos*) vendor=crds ;; -dgux*) vendor=dg ;; -luna*) vendor=omron ;; -genix*) vendor=ns ;; -mvs* | -opened*) vendor=ibm ;; -os400*) vendor=ibm ;; -ptx*) vendor=sequent ;; -tpf*) vendor=ibm ;; -vxsim* | -vxworks* | -windiss*) vendor=wrs ;; -aux*) vendor=apple ;; -hms*) vendor=hitachi ;; -mpw* | -macos*) vendor=apple ;; -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) vendor=atari ;; -vos*) vendor=stratus ;; esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; esac echo $basic_machine$os exit # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "timestamp='" # time-stamp-format: "%:y-%02m-%02d" # time-stamp-end: "'" # End: gcl/gcl.jpg0000755000175000017500000006010012240167764011517 0ustar cammcammÿØÿàJFIFHHÿí ðPhotoshop 3.08BIMíHH8BIMó8BIM 8BIM' 8BIMõH/fflff/ff¡™š2Z5-8BIMøpÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿèÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿè8BIM@@8BIM €4€N cÿØÿàJFIFHHÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed€ÿÛ„            ÿÀ4€"ÿÝÿÄ?   3!1AQa"q2‘¡±B#$RÁb34r‚ÑC%’Sðáñcs5¢²ƒ&D“TdE£t6ÒUâeò³„ÃÓuãóF'”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷5!1AQaq"2‘¡±B#ÁRÑð3$bár‚’CScs4ñ%¢²ƒ&5ÂÒD“T£dEU6teâò³„ÃÓuãóF”¤…´•ÄÔäô¥µÅÕåõVfv†–¦¶ÆÖæö'7GWgw‡—§·ÇÿÚ ?õT’^õ÷묹ý¥ÚXY¦vC 8'ìµYù®Ûý"ÆÄÿ¥Sò¼®Ng(Ç9Hü°ïJ@ .×]úÿÑ:Eƨ»?1„µôÑXá¦Ëòú:Ý»é1ž­ÌÿD¹|ñ¥×òq°ñigaa²Ó÷°â®BŒ{.{h¡£qàpÐÒs¿u«gêÛml±îñ` oËp{–ܹo†r`G7ë2~®)KûÞÜ=÷˜¸§-´t›þ4>±ƒ/ÇÂx𠵇üï^ßú•Óý[úû‰Öl8™}44¹µîÞË>™¦Èc·³é>«ÿn/;Îè=K(ÐÊ-ÈnÐöØÆ ϵî£kÛµK¦ôþ¥F~>G¤jôl$¸Lj×{Z]ù®K™å¾>\Î9qâ"\&¸£n_½ýÅDÎõ²ûS,kÄ‚©õ~¹Òú.8¿¨Þ)k¤VÍ\÷‘ùµTÍÖYô¿±ùëϬlèýùù-6ÕñOÓÃýoÖq¯„‰úuiõŸñ•‘…Õrð±0«¾œ[ >«ìsKœÀÞÖÖÿ¡vúÿ°¬ýZú÷Özƒñ¯Ã«Š«6YklsŒÈeL sôÝÿP¼Ìo:½Åïq%î:’âw=ßÚr辫Wc{t7¸’Ïk?éoW9þK”å¹BF0rúqÆw?TÿJ7îqÍle#-ô}f››hŠ¨ô¶9´7r¼¹æWÿÐô?¬]Tt~‰—Ôcsè¯ôM:ƒcˆª†Ÿäºç±x‘/q/±æËK¬±ÆKœã¹ïq?¾ó¹zoøÓ±íèÌi!¶fVðk.µ ÿn¶/1<.—àx„yydý,“:ÿV/ýÛS­vw¾¯á°:=×™'ù#FûúÖêŸY]Ð3ÿgâbS’êêc¯}®x-{Ç©é·ÓýÚ}'×>©W]­¥í÷7kGÌsÎVþ±}N蜞±Ÿ›“Sïs®³}µ4}*êw»NªÖv<¸rs¹eÍFSâ2Œq)K‹†ôÿ›‡¡yDp¸ÖÿŒ>£cv»§bGõíW¾¬uWõœ«ÆN-ôÐÆõ—’^óì¯ôžß Ëÿì.¤ N±á亯ªTØÑ[[§¬ñc¾pÖàmW~)Êòœ¿-)Cc’DBå§éHüß¹°”‰Ôµþ¼ç·#­}†£ú¿Mo¦àÜðÛ2_ýŸÑQÿZX¸4 ò˜Ç `÷¼x†þoöœ£•cíÌɵÿNËís§Ä½ê÷@ v[Ø~›šÝ£ÄwÇýs(<¯Ãä1ïÞŸ¦y?ÆŸº´z§¯Rö¥zÎÖãPÁ«ß¤ŸÝc~–;ók¯Þ¸\¯ñ‡õýRÜÌ+E8Žpa\ƽ¡ú¦Ý¶¶×ý;};ÿàÿÁ®{”äss\GF0ý)i/Üõ™e!Þß'êë-³q ˜úþkéØ*­—a¾èÿGDzm?ñ—Ø×ÖWEõWëVWYÄõ³1™Žòí•Ü\-§ck{wTÆ¿ôÎY½p\zŸí?¬¹—4Í4‹Oõi–ÙþvK¯rµð¾RC1Èôk”€Xz£ýo_øœ½:uqƒ\âߤâ߉Ð.ïêÖÞÆ´{XGÀh¸î˜Æ;-®{ƒ[XÝ. {µ¼¯Eú»wM¢°ërñØ•kÿ«S|o$¥’¢ R¡úy?ïaÿ¥â[ÖPÍ•€ˆªSÕ:eÖ6šrè²ÇèÊÙcãwµ­vç{Z­ Ä1#pG›+ÿÑï>¶t?ÛÜ&–²ð[n3Ý;E¬Õ›£ó,÷RÿøÅã™xùYÅÍ©ØÙ 0ê¬~-?FÆ~í•û½‘!fu>Fk6ØƼvk€pÿ¤´y‰Ë•‰Æaîc'Š¯†P—õO«üU“‡»>-NNF;‹ñﲇMOs'ã±ÍLç[•v÷ºÌ«øqu¯ë;{פ[õ3:YEcàÆÿr%_U¶èÖøðW¥ñÜbÌ0#ÖRÿ£¾Ñîð8Ý*ïç¿BÓù£Üóÿ|bî~®ôǵíyn؈ò…¯‰õršÈ. cº@ ²ù¾{/2AÈEFøaQëãŸ)úéõs'¤õ;ók­Îé¹o72Ñ«k{Î먺?šý!ßSìÙýEÎ5ÐA5ïy XZ{ˆ\ÆwÔü+^^1ê$÷ØßîZ·Ç 1Æq™˜Ž8Ëæ÷£ûßá-8¬Ø/–9ÛÞ ÜlxÑ¥î/pònòç+ø]"ûÜ{Mu~çwþ“gý5Ý×õIµŸÑ±¬þ«@ü‹GêÝu\%cã“”LpÃÚ½8ÉâŸø¸¡ˆuÕÁ­Ïé''©¾ÜJ¢Þóú,jÛÿ]sŸ²ÊàP8ŽL‚Iîïí/y¯–W°±®4ø¬®¥Ñ’í+`Mhþ CâQåc0q’É+2ãáôÇåÉ?ë¦pâ­v|t¹‡’Ü¢[Aä0ü@^§ÿ4Ùûû‚_óMŸº>à®ÿÊÿ˜?øgþ»[íx¼WÔÏGª?=¬nêXk¨€4}º=ßÙ§Ûÿ^^­Ó/}Õ9aãýXmo4†‹£ÄÇV;,ž{š<Öc”ŽcâጭýïRøÇ„SÿÒõT—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ê¤—Ê©$§ÿÙ8BIMÿþ'File written by Adobe Photoshop¨ 4.0ÿîAdobed@ÿÛ„      ÿÀ¶ºÿÝ8ÿÄ¢  s!1AQa"q2‘¡±B#ÁRÑá3bð$r‚ñ%C4S’¢²csÂ5D'“£³6TdtÃÒâ&ƒ „”EF¤´VÓU(òãóÄÔäôeu…•¥µÅÕåõfv†–¦¶ÆÖæö7GWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø)9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúm!1AQa"q‘2¡±ðÁÑá#BRbrñ3$4C‚’S%¢c²ÂsÒ5âDƒT“ &6E'dtU7ò£³Ã()Óã󄔤´ÄÔäôeu…•¥µÅÕåõFVfv†–¦¶ÆÖæöGWgw‡—§·Ç×ç÷8HXhxˆ˜¨¸ÈØèø9IYiy‰™©¹ÉÙéù*:JZjzŠšªºÊÚêúÿÚ ?ûùŠ»v*ìUØ«±Wb®Å]Š»j b­Xd8ªÃ0ñU¦uñÅVúë㊻×_UÞºøâ•âa㊉Ž*¼88ªàAÅ[Å]Š»v*ìUØ«±Vª1U¥ÀÅVGŽ*°ÌùËô‡ÿ¡Úÿœˆÿ©¶Ïþáv?õGåýgó‡È3ÿ“EìïúŒ¿ådÿZ>×þs—óúÜGëjÚEÿ«ô؇1Zѽ#ß*d£í¬uàÑ—þ¾ÏÎê#î™ý6Í´Ÿùø?楻 Ö|©å­R%§#n—v’°ïV7-~IôfD=¦Î>¨ÄüÇé.ŸUÿîÊŸ÷9ó@ùðȹ‰û^ãåùø?’õŠ8ùGSòÿÂ×–R¦¥n§ùŸá‚P?ÕF?¯68=¦Å-²DÇݸýã{Wþý¡„i3Ã/”Ç/‡Õœ¢û#É¿šžMóîœ5_(yŽÏ^²µ³þò"z,±7#ogPs}ƒS‹÷oÙ]ƒ¯íIpé0Ï!þˆ4=òä>%ñÿ›ÿçá”z;É•´}oÎR¥x]$K§Ú7Éî¬>˜sK›ÚM<6€2ûÛ¿ØúofÀOµõDñá×Ç/”}?ìߨ䗾gýèŠRç6ÿç"ý5¶÷ ±ÿª9åýgó‡È9?òh½ÿQ—ü¬ŸëLìç:?- }cQÑuN5¨ºÓQyWÇêíOlœ}¢ÕŽd‡ê§7üýŸÉôÇ$=Ó?ï„ž ÏÄ<ã óOåþ‘ª!4‘ô«™ì!gúÝiáQ_™x½§È>¸î$}öóšïøhä?ÁµS‡õãÿ¹ðßPy þsWòƒÎrÁc}¨Üù/S˜„K}m(òÝÆÏòÍΛ·´ÙÂ|ÿ_/>oÛŸð&í¾Í‰œ 3ÀuÆn_éÿJ$ú¦Û]·¸Ž9¡%†e¨Á••…C6 Ž™¹ß4” IQ ´:’µ>,,i3ŽéZ›â„jH|U\â­â¯?:ÿç3|Ÿù3ç«Ÿ!Ýù_Qó¡aimq¨ÜÚO I —+ê¬$=I>™G¯ùY£×öæ=&_ Ä’Þú—²Ÿð,Övþ„k#–8ã)$ˆìNßÒ±ðyÏÇü–z~[ëô—mý3ýcþaù‡¤ÿ“­ÿ”¬éd¢ßóñ¿'Ÿ—:Ðÿ£»éú(ÇüÃó ÿ&+[ÿ)XÿÒÉHÿÏÆ<¡ÿ–ïZÿ¤»éú'ÇüÃó ÿ&+[ÿ)XÿÒɯú(¿”òÝë_ô•oý1ÿDøÿ˜~aäÅkå+úY>²üœüäƒówɱyÎÛBºòõ•ÕäöÖ6×r$2[0)°§$§ŠœÝè5ƒW‹Ä _WËý¬ön^Ï뎎Yc’B “@[ˆïÖ¨ü^½¢­ûYšóI„W!»â¨ôzâ…`kŠ·Š»v*ìUÿÑûùŠ»v*ìUØ«±Wb©^±¬éZ›y¬kz•¶‘¤éÑ™¯õ;ÉR!Œui$rG¹9Î0R4RߦÓeÔäŽ,13œÄIòrüàüåÿŸé:k\蟓Zbk·hLry¿TÒÉOsmmT–_f“€¨û,3˜×{Iúp =ç—À>éì·üsf7jÏÃúœ3ÿ:[Æ>èñ8—æ·Ÿ?40?3µ©yëÍwþa˜9x-ç“´×û‹høÅ_ØQœ¶£W—Po$‰û¾\Ÿyìog»?±ñøz<1Æ:=GúÒ7)|I`9Œî]Š»v*ìUØ«±Wb¬—Ê~qó/‘µ›}ÊšÅƪ[ì'¨+S¨j®†›«2쌘'ÇŒÑu½­ØúNÕÀtú¬c$CÐ÷ƒÎ'ÌnýjüŒÿœ‡´üÐЋ^¬Zoš4°©­é‘“ÀòÙgƒ‘'Ór:J‰;ßö_iÇY ö˜æ?Hò~DöóØŒ¾Íꀉ3Á’ø&yùÂU·ø ÇP=9§y$ãûÊæÕàˆg:¢ÈÅ…2X' øª=Z¸¡~*êÓyæ¿çåÏäÖ–º‡õÔµ¹¸BúfƒlÚå*?sn4¨¡v*€ìXf³_‡KÈ}éø~Ò{9ìŸhöþ^ &;ê™Úþ´¿Þ‹‘è•?›_óÿ™Þu’ëMò/å×—¤åOnÂmVT¯Ú{¢) 4­!PËÓ›g!¬ö‡6]±ú#öüú|>oÑ~ÍÀw³;< šÏðŒ½ÇlcÝâÿ<šjŽ¡«^O¨j—וýÓs¹¾º•æšF?´ò9,ÇÜœÐÊFFɲúÎð@CDb9ÜÈ<‹k±Wb®Å]Š»v*÷ßÉŸùÈ?9~Rß[Ú%ÜÚÇ“d~òÜÏÉcV?–ŒÇ÷N:Ð|-ûB´aµìîÖˤáÔ~®çöÏþÚhqÐÇ©Ó~Y+êŸÕ‡˜?[ü›ù›£y·FÓõíýo4ÝF1%¼£b;2ºÕ”‚=wø3Ã4àläNÕì­Gfjg¦ÔLJ$ ÷ÞÜ¡êšv¼’qøúåκ™•¥úÉMð±O"”0â…·×öºm•Þ£}:ÛYXA%ÍåÃý˜â‰K»·²¨$à”„A'lÅŠYg@\¤@¼€5?™>rºüÂó÷›üíwÉeó.«s{MÖ(]Ï£}£Œ*až[ªÎså–CüFß¼û²ãÙz :HòÅyÔ~2³ña9ŽíŠ»V··šîâ [hÌ×2,PD½YÜ…U2pÆ&D̵åËP”æj1“Üä¿n?.$³òG“<±åIÓЬ!¶‘Óa$ÀršJÅ’o§=CI€`Åc þ×á?h;R]«Úµrÿ)2G”„›¬éþcYJüy’éˆgºv¤$òß,ºÚn`{áBh†¸¡Sv*ìUØ«ÿÒûùŠ»v*ìUØ«±W‡þvþ}ùò7A—™®¾·¬^£þ€òµ³/Öï]v¨¾œ`ý©PväÔS¯íZ8\ùžC©üw½g²~Çk½£ÏáéÅB?^CôÃõ˺#sä7~"~sÿÎ@~a~wêÆë͇Õ4+iKèþS³fKQ¸V*Me’‡y§¯+ðç®í,º¹\ÎÝä?ïÖžÊûÙþÎâáÓÆòêÉ/®_ñ1þˆÛ¾ÎïÌ­v*ìUØ«±Wb®Å]Š»v*ìUœþ[ùÆëȾpÒuûyZ8#A©¢“I-e J¤w¦Ì󙽫:lñŸNGÜyþ·˜öÇ°#Û}——JEθ¡å’;ÇçôŸè’ýWò÷œÄž&¨4 ×=,âFžé yˆJãëï’k§­é—âUSË%–Á' 0±EòÛøâ¯ÏïùÉùÍ=3òúMCÈÿ•ò[ë¾v‹¾«¯°Ylt©*È«¸žu ÕOÀ‡ír<“9ÎÕíØà¼x·—SÐ~³ö>Ñìü rö Ž¯´/¼aÊyô`{þ©T*OÈ/0ù^óf±{¯ù—Wº×5­EÌ—º•ä­,®{LvlØ €8¼¹e–FS6O{ôÞ‹CƒE†8tðÇQˆ ?O3Õ&Êܧb®Å]Š»v*ìUØ«±Wb¯¥?ç¿2nü¯¯Ëå{›†ý®’ö¨ÇáŠñµ¢Ž'ą΋ÙíiÇ—Â?L¹{ÿoê|gþ ^ÌGY¡¡Œ~÷Òþ–2Þ~Q2~‘y{ÍâBŸ½üs·~^!íÚº²„øúá`CÓ,/DŠ»ábù›þsKóù'ò+^³µŸÑÕ<ï4~_±¡<½+ŠÉvh7¡·ÐžÅ‡Ë4Ý»©ðt¤rÛõý¥À£±”{w¤.È}ñÚìÈ?ü(Ï=~Âv*ìUØ«Ñ*ìãŸÎš]äê ¾ŒÆýê6ç=/¤HTý·ì=?©‰<£¿Ë—Úùßü»cù;°òÆ&§š±t¾¿öCâyé¾ri{øç Ûò ×ü¹æ&”ÇñÖ´ï…~òíù”'Å× õ½6Bʧ IlP­Š»v*ìUÿÓûùŠ»v*ìUØ«æŸùÉùÈÍòËHá#Õüï®G ò¿—‹?Ân®¸V'عøWö™u}©ÚqÑC¾gý'Ëï{Ïa=‡Ïí.¦·†žx“ÿyù”Fç ?üççO3þ`ùQóg›õiµ­wT~WW’ÐËh *" •TAž}Ÿ<óÌÎfÉ~Áì®ÊÓv^š:m,1Çy<É=Iܱ|¥Ø;v*ìUr#»E.Ç¢¨©û†J124–¼Ù¡†&y$#Ôš2Ž]'RqQe0å)_×LÌfêe˾U÷¼Þm»©jñ_”„¿ÜÚœºuô ™-%U[‰#ï š F1r„€÷7èý¬ì\„qj±HžCŒò$b= ±Wb®Å]Š»}­ùwæÉdÑôfyIqkÈkÕ‘B“÷Œô¾ÏÉâiá/è‡âkôCIÛ¬C`2νĒ>ÂúËÉþb2z_‡|Íy’LùoSõ?‹Ã$ÖCÕìg䫾ÍÏùËïùˉ,Uü¥ü®ÔLwËÎÓÎ~m·jOÙ’ÊÍ×£ö–Aö~ÊüU+Éö×lðÞ'â? ~’ýÿø ¢¥Ú1ôóÇŒõîœÇwXǯÔv ~Ug ýìUØ«±Wb®Å]Š»v*ìUØ«±TUäÚ}í¥ý»p¸²™'…¼6 ?–bÈqÌHsþN.»G fŸ& ›Ç$LOºB‹ôÊoõÒÚd–©*«©¯fê0˜”D‡"üªÓËYbŸÕA÷ƒEõ”|Åê¾? ±Å!ôF…©zˆŸpµ—åÇüç×æøƒó@ò=¥Ç©eä;Õ¾[a¨ñ‘Ãü°$DW§#ôñÒjxó c”GÚe?QÀO±-Ù™5’¬ò¡ýLvÎf ø39ÇÚŠ»v*ô%Mú> îÒ]°PÈJÿs´ösOÁ„ä<ä~Áûmù›þ ݳùžÐÇ£‰ôàŸëä£öDGæ^á j²;§ÄzçDøÉ¥<™pîbßÃ$äú¿Ê|ŠG_…¨½ËK‚á`YD]*Ø«±Wb®Å_ÿÔûùŠ»v*ìUä›þ^ü•ò&¥çt‹‰ÓýAÑ•‚Ë|à˜¡CØlYÚŸ ‚hMÃ×ka¤Äg/€ï/I짳:h5ÑÒáØsœºBœÜY6æþ|<ùç¯2~dù¯Wó—›/ÛPÖµ‰yÌý#‰ÑÃtXãZ*zœó}F¢zŒ†s6Kö·cv>›²t°Òé£Ã‰=dORNä± ¡Ù»v*à $“@Rp{JBÊF€æYvå±ÅgÔØ ;­¢š1ÿXöù ó¦ìÿgÌ€ž}‡ózü{½Üýφû]ÿè`”´ý–ä69NñÔÅýcé#†ôí HÁ ùž§éΣŸPˆÉðŽÓíoiäñ5Ye’_Ò;på€ „6’ÌFÇ.u‰Ä$¯O€á[I|Åäg¸²žöÒ—–èd*£ûТ¤ãN‡4]¯ÙPÍ’¦7þ·í}Wþ^ßj;3UI©™–šdGÔº'`bzFþ¨òq¿>3œ3õC±Wb®ÅW¤RÊio!ðPOêË1ážO¦$û…¸z¾ÒÒéçË cúRûÈ{÷‘åžÚÆÆ'V‘(v#|ôNÍ„¡¦„d(€ükí¶§«¶u9pÈN™ ƒ`Š‹êÿ$_IXªOlÏ%'×^P»b‘Tødš‹Æ¿ç,ç#%üµòÚùÊÞ—ž|ÍnMÝôMñévU2†fi·Xû¨«ìxWAÛ©ùxxp>¹}ƒõžŸØúßü =„±¨üîª?àøŽÀòÉ1Óú±ç.óQßÕ_‰$’MIÜ“œ+õk±Wb®ÅWÇ“:Ç$sEE''²HF"Éqõz¼:LRÍšBˆ²I *³òôHßÉÍÿåž3@?ÖnÿGßV‹ÙÐ=YÏÀ~“ú¾o‚{MÿIÈœ]— ê“ŸêÀì=ó¿8„ú Kxö‚Ö8ýŠýýs‹G‡ô@‡é|‡´=¥í=|‰Ôj2Nú„ED|i„“Š2r¨"£2 D…Ý><ÓÅ.(Þ 5ç’Òò6kxŽÅ*Œ¢ŠOƒúÆiõ݉‡qB`J'¼Æ㢎Vå;v*ìUô—õi†˜ îÆ„ÿªþé].-63ý÷?{g€aí­d@¡ãLÿ¦‘—éÛÉõ×’5f>ˆåá™Áå$ShÚõ®›¦]j—óˆ,tëy.¯'n‰(]Øûã)ˆDÈò Á§ž|±ÅŒ\¦D@ï$Ð7á¯üÑyço7ù—Í×ü…Ϙµ‹ç}5šBÉ>´Qì3ËuŽl’™þ"K÷cvl;7E‡KX¡ûèn~'sïbùK²v*ìUÀ@“°ÉF&D̵æÍ 0–IšŒA$÷¹gšePEý”g¦é°Œ8ãÐSðßmv”ûK[›U>y&eîì>‡Áì¾U…ãùŒ½ÔÖÞE²cèíá’ R}såKR*ŽÃ$Ô^ͧGÅW @ƒlP©Š»v*ìUÿÕûùŠ»v*†¼»¶±µ¸¼¼ž;[KHž{«©X$qÇ,îìhP $ôÀHÏ&xñË$„ ‘4æIäùûÿœœüó¼üðüúÔm¦‘<›åö’ÇÉ– UCÔºe4¤—Cî*þÎyÏjöÖf±ô‡ëø¿hÀÿÙ{;ÙâÇÉRÈ|úCÝ ¯3rêùË5otìUØ«±Vg£ééf‹w:ÖíÅcSþëøœí;²†2ä³È7öýÏÌ¿ðKÿ‚»G$´9Vž&§!þVC¥ÿ0tþqßqL‚%yØu9о:Ë´½ç+ðÖ¸X’ôýÊO'ÝõöÂÆÞ•§y°_Ý~±%‘/‘>î 4Ž'ÉòÿÎ7yÑ®®¥šãOÓìÌÒtç$’ù? ƧùYÅÿ¡Ìò‘7/Ïõ?Mø4öf0ˆÇ—$ÄEšŒcu¾æWÏú*rþD=€­æ¯-Éia„Eø³?ê̼~ÌÀ}s'Ü+õ¼î³þ:‰_åô°œägöDCïø¤w?—Vd ³ûR9ÿxŒÎÇØ:Xs‰>òE<®³þ =¿¨úrÇþ„#÷ÏŒý©wø^(Õøï÷æv= L">åužÕv¶³ûíVYî9WúPkìL­tû³( tR‘‘³Íè:‰(tø¾Šò~›"4_†I¬—ºk~tÓ,ü“¬yÇW£A¤ÛÖÚÓ—¹¹†®îä ÓaVècêõQÓb–ItûO@í½ì<Ý·¯Ç£ÅÎgsüØå#î3C™~:y³Í:Ï|Ç«ù§ÌFóWÖ®âîSÐWeD²ˆ *ŽÀžiŸ4³LÎfÉ~Ýì®ÌÁÙš\z\áÇŒPý$÷’w'©,{*vÅ]Š®Ž7•Ö8Ô³¹¢¨îNO9dŒE’ãë5x´˜g›4„aL‰è7°³‹OŽ‹G¹qûÙãUöÎÿ³;2HwÌó? y}ïÈÞÛûo¨ö‡P@&xŸD;ÿ§>ù”Fé'6Öï3 «\Ù¼#5Òô˜¯ÀMp±%éZ_“Ú@¿ºü0±%›[yŠÜþÒ8Ÿ/þxyq|¿æ{XÌcR±YdÚž7d&¿ê…Î#Ú½=GÍîšE°kÑ“ãº4ð1)Cþ°Í?oj|1œ¶ýgÞú?ü ûùC·!’BဇúÃh|xˆ—ù¥ùuœõÛ±Wb®ÅQvQóOdøðÍÇaéü]H'”wý_kçðSíŸäþÅœ"}yφ=Çyÿ±œî“ynùÞ¿%Ð~LÓË<_†²ûȺe_†H5Iõ7—-8F›xdš‹Óm#⣠ÍFØ¡v*ìUØ«±WÿÖûùŠ»v*üøÿœøüå>RòU§åv‹uéëÞ|ÖÖÙÅŽŒU—Ûë/uYëœç´Zï Ãrçý_Ûúßiÿ€×²ßžÖË´r‹Ç€Ô|ò‘þò&ÿ¬b_™Ã¿R;v*ìU7Ò-D³zò Ũ¡nÃèë›ÞÂÐxù|IL~ÓøßäùWü}«=•¡L2¬ÙÁsŽ?â>F_Hÿ8Ã0…ZgÜ?,3ÝGi™>× ^óå*™=2cðí…/ <½äÑÅ+á…¬—­i¾P@«XÇÝ…‰,„yV0¿Ý»[Ô¼«VýØû±M¼£^ò’žtðÀÈj¾N«7î¿ ÁbäÏ‹û¯ÃÚ6×É{Ý~­³'ɼYO¥øabKÙ<½åŸH§îéÓ¶¾ ÿœºüÃý/æ‹?ËÍ2ඓå%Õ‚]JUèi±ô#Ôö—eaž&cŽ37.²FßUq &ÿò×GÒ"x´ÓMŒ pµ"ÿ`Y<{B {…8:ÎÕÕëO£,òéHËï%ãž`òéá–8€¼ÂóÊOÌþëðÀÊÔmü¢ü‡îÝŠÛ=Ñ<©"²~ëðÂÄ—½ùWËïàéNØXùþrÏÌÿ¤|ó¦ùR 9ZùBÅDéØ]Þ…šNŸñPˆ{çí£8Æ9@}§ºŸ¨ÿà1Øß•ì©êä=Z‰íýLwþËì|­œóì.Å]Š»NôȾ}ÜíòÚû;§àÂrr?`ý¶üÇÿNØüÏiÃIéÁÿ¯’¤Øð}¯Nòõ§9nã:Ç‹ê/#i•h¾ !ªEöG’ôÞ)Ãá’ R/¢4[`‘¦Ý°µ–i Ð ,Qx«±Wb®Å]Š¿ÿ×ûùŠ»CÝ\Ck×72¤öñ´³Ï! ˆˆ*ÌÄì§ ,¡ NB1NÀy¿œoÏÌ«¯Í¯Í5ùÚi¬oîÚ ¨ôtëÝÚ SN$  Û}¢Ç¾yhjŽ§<²t'owGîd{=‡Ùxt€z£™ïÉ-æ~{ ɳ 銻w\ Z%!g`}”>”QÂ:Üÿ”zç£ö~”i°FzûÏ7â¿l;z]µÚ™µ7é'†PŽÑùýGÌ–s¢éægO‡3ž\¾ƒò—½Cáá…¬—¬y¿ÌŸ•žI¹ó\ö+SsœŒ‰ï$Ùz/—ô³+§Ã]òǾò‡—9úDÇáÛ Y/¨ü«åp:ÇáÛ$ÔKÝ´.¢*|†²Y¤:2(µ­ Ÿƒ·Ÿk^\Wû¿Ã@¼{Zò€·îºû`f Ïî|ŒÏî{ø`emÛùâ¹ü1¤q33É! þëðÆdοFXù{JÔ5­E…¾£ÚM{=6Hmã2HßB©8'1™@[v—O“Ušq‹œä#Þdh}¥ø‡æ¯0]y¯Ìº÷™ovþ{Ù#­BzÎX öPBaž]Ÿ1Í’S<äI~ðìžÎ‡ghñiaôâ„b<øE_Ç™H2—`ìUØ«€$€:“A’„ ä"9šu:ˆiñK.CQ€2'¸DYûŽ=4ì€3Ó°aqÆü5ÚÝ£>ÑÕåÕdú²HËÝgað²ùRÛǷq—:Â_]yKþçáðÉ4’úïÊvR/‡Ã$Ô^Õ§CÅl, ŒP P«Š»v*ìUØ«ÿÐûùŠ»|™ÿ9¡ù„ÞCüŠó6³ú:·]<¹§ÐŽ\.Ã5Ù§Z}Y$Zö,3OÛšŸK*ç/OÏŸÙo£ÿÀ¯±?”ûw¸a¼§ß£ý™‰÷üÏ<~Æv*ìUت*Ê?Rá**â?GOÇ6½§ñµ1¾QÜü9}´ð_ðJíäÞÄÊbjywóþ¯ö_o§ÂduÏ@~@{O•4¯Qãø|0°%õ’´H¾Ù Õ"ùÓþs ÌÃô·•¼‡k'ît›Sªê‘¯CqsXáV÷HÔ‘ìùÇûK©¹Çè,ûÏ/³ï~ÿ€bøzlúù òK‚?ÕŽò¯#"ù‹ó—}ÕØ«±Wb®Å]Š»~­~LéÐù7òÿËZ(ŽóêâëSQ¾±r}Y½Ó—’ç¥vfŸòúx@ó«>ó¿ì~&ö綕ûgQ¨áÅÃêCÒþµq|_@izœnV„f{Èù+þsoϦ-ùSÈ6sRMfáõm]ïõ{_ÝÀ¬<FfùÇœ¿´Úš„q»Ÿ‡/Ç“îßðìOSŸ_1¶0!ëKyxˆÝ7æÖqÏÒNÅ]Š»LôÈë#ÈGÙ_™Î—ÙÍ?Ie?Â({ÏìûßÿƒGlø:<:òËŠ_Õ‡ }ò7þc:ÒmL’.Ýs°~o/|ò~ê4_†I¬—ÖÞJÐ"<<0†©Óþ\ÑÕ?ƒÃ$ÔKÕ,l•vÂÅ:H1U)mö*ÞiË%~Vؕ怒V¨02´ü¯úCîÅ6«•ãSýØû±E§Vþ^)û±ŠÛåÏùÍ4ÇäŸÉ‹½"ÚA§ç›È´ˆ}±l¿¿ºqìR1ÿ_4žÐj<-1ˆç3_gõ|_Qÿc~¶ã–Cѧ‰™þ·Óó&²ûÈÚe?†Õ'Ô¾\³à‰·A’j/LµŠŒ,S%¡v*ìUØ«±Wb¯ÿÑûùŠ´zb¯È/ùøÇœšûÎÞGò4VßËúTº­ìjvúÆ¡)ŽÜìþùÅûOžòCp¿Ÿö?LÿÀ7²ü=£XFù& ?«gægþÅùÇœÃîŽÅ]Š»N4¸ëÍéöˆQôg]ìÖ„òwšùoú_¿àÙÚ|z>Œ¡3ï‘áÈDÿ¦z>ƒkêH›wÎð²ú_É:W&‹áðÉ5—×¾PÓc‚–R±Eó’F *¨$“Ð <šèÈÐÜ—ä?æw›[Ï^ó_š‹3A«j5€jÕm"¤VÊkü±"Œón£ó哼ý>Çîeû vGf`Òu„õϪgã"X&b»çb®Å]Š»v*ɼa£æ]" Ô5´s¬÷JEAŽ”û58ý9ŸÙšQô»>á¿ìy?n;cù+±µÁ©pðÇúÓô‚?«|_ÞZo›K²þóñÏH~)§®ùw_iJ|~Xüúÿœ‰óKù«ó[Ìú…í´1f ¯h)(ÿ‘Í!Ï=í¼þ.ª]ÑÛåÏí·ì_øvWä;V[ÈÏúؼ?5/ ;v*ìU‘é‘R$ñsÈý?Ùÿb`ð´±ï–ÿ>_e?#ÁCµ?=Û¹@7@cæï/öfORòå‘‘ã۸ͻçeõ7‘ôŠ˜~ -D¾Àòv’"ø|2M$¾ÑìÂ"í…f0ÆX¢v¦*¤ì1T#…8¥ Ð#vÅV}QlUUlÓÃD e¦*ü]ÿœöóðó/æ姓­%ç§~_X-¼ª Tß߸¸aÛhý>OÈpžÑê|M@€åöÏè~­ÿ€Çb~O²%ªõj%æBã·Œûˆ|7œûëîÅ]Š»O4¸~TÞCø í½žÓøx Ï9°múß—ÿàÃÛ?›íXéb}8#_çÎ¥/ö<Þ Óü½iÎHöî3 |ˆ¾£ò.™Sãá„5ȾÇò^Å"ø|2A¦EôFmÂ4Û YfP­ÂÅŠ»v*ìUØ«±WÿÒûùŠ¬s¶*þ}ÿç.5÷óüä7æMË?(´ëè´»t¢-…¼Vì|]ŸsžqÛ98õs=ƾBŸ´¿ài¢_g´±ë(™Ÿóäe÷8f­îÝŠ»v*É4”¬qû’OßÿaÇI;?i~Eÿ‚–¤æöƒ8é„"OÚKؼ¯iÎHöðÍ»çeõ§‘4áûŸ‡Ã$¤^Áù“iæ‘ùQæ›/%iZÇ™5‹OѶ6¶c÷Š—DE<•¨ãÂ"äfixŸ—Æ ‘·Ÿ?±é½‰1Û'­œa‡¸É—+†ñw*ø[óHÿÎ7þySùg¬ãÁ?æ¼á’uêeú¯þN³ÿò™æR]qù ùÃh ¹ü¿Õa¯$Où«ä_ú™OüœÀÿ”¼3ú˜íçå—Ÿtõw½ò½í²Æ vp :“ñ`=•ªœeœ=¾ì)‘êàI÷þ¦ š÷®v*ìUØ«4ò{ýR[‹ÎŽÀCöûMü3¬öoOõe>á÷ŸÐüÿÿÎÙ³ƒ³ây^I}±‡ûÿ˜{v…©ÈîŸëSà>†ò½ð†¹™¸Åm,¬{* “¿°ÄÈDYè¸ñK,Ä#ÎDï;?8õÙµ=BûR¸5¸Ô.%¹œÖµy\»oó9å™&g##Ì›~÷Òi£¦Ã 0úaƒÈ9Å]Š»³Éšé°üQ­6PÝž£‹‡àÉøC´5GW©ÉœóÉ9Ký1'ô½»Ê6\ž-»ŒµÀ/°<‰¦Üü> Õ"úßÊÖ!R=¼2M%ì…EÛ /4yŸDòW–õŸ5yŽõ4ýAµ’óQ»oÙŽ1Z(êÌÆŠª7f ÎW›,q@ÎF€s;;³óö†¢lâɈÄyŸ¸dô—á6»ÿ9mùÕwù‡æ<ùwΚ——íu{²ö>X2‹­>ÞÕ(CõYÄr¨äáfäÛW<û'lêNidŒˆ³Ë˜¯qÙûGÿ^ŇgâÑçÁ†ÞuÃ9Hï#Ç•_!dC£èï"ÿÏÄõÛFÓó#É6ú¤b‚MgAÛLîÖ³³£±ö‘¶m4ÞÓÈm–æ?Qýaàûgþ¸'rÐj ór!þž4@ÿ6Eö’ç*¿&<ýèÅ¥ùÊßKÔ¦â¬ÿ¸ûŽMÑÍH¤ohݳ}¦í}6¦t{Žßƒäݳÿ¾Üì«9tæpÅ÷‘÷ú}QÖˆ{ªjñ8 ®X¬ AÃ6OE#á¿Fý¡… ”w ÝñT¿¯éþ\ÐuŸ1j’ˆ4Í ÆãPÔ&Ûá‚Ú6–C½:*œ†LƒL /ääè´™5yჹäˆ÷ÈÐûKù©óg™/üáæ1y¯TnZ‡˜õJðT°W¹•¤*¤ö^T<³6S–r™æI?7ïnÍÐcÐiqi±ý8ãtE}½XþTæ»v*Ú‚Ä(êƃéÉÂrɦV¦l3ÍÔa"|¢,ýŒËOƒxÐ –€g¦àÄ1B0€§áŽÓ×Ï_ªË©Éõd‘‘ÿ8Ý|9=›Ê–Þ?‡Ã.uåõב4¿î~ j‘}wåK)݆I¤—´iñEÂÁ?ŒP P«Š»v*ìUØ«±WÿÓûùŠ©HvÅ_ÍçÔ—¿›_š“%ºónµ,k@^úb@©&‚»ož]­7¨È¤~òýãì¾1²t‘†cý„^u˜®ñØ«±Wb¬³C£‹Ø~üôÅ–’ÒþòüƒÿìÅí£‹ø¸d=Æý6>zò„¼[xfÙóâûÈv¢íá’ R}aå¸@‰(; “QfW H<1bò_4ÂÌ’mÖ¸‡Ã_óz‘òÿ“õ)Cúw:£®ŸiØ“5KÓå±ÍOmj<4«œ¶e¾‡ÿÆþSíÌ"BáŠòKüϧý™ÂßžYçØ®Å]Š»eúR˜Ò$»|Îç=#³´þC­oï;—â¯l»cù[µµn&UêGÓ˜ï/bòÄ,òGóœòÅïÓÅ%Ÿ‘¼ÛxƒãµÐµ “¶ém# þŒÇÖžtOÜ]dz8Æ^ÖÒ@ò–|cç8¿<3Ì_¹Š»v*áÔd h‚Õ¨ž9Ds ±èšBr‘>yêaø&@ƒEô?’­x¶î0µÙ~E´aÛÃ&dúŸË°…Ž?ÂÖ^ $Q‚")gv4 É$øab&ƒñ§þs'þrY?3õsùyä«âþBòõÉmGQ…MZú"@u*~("?c³7ÇÓ†p½¹Ú¿˜—…Œúû#úƒõ_ü =‚=‡óÚ¸ÿ„dyâéå9pôÿ9ð–sÏ°»v*õ"þoþhù[{o'y³Qµ€È«ˆ[ëV®ÌiÅmf -ÓáP}ó7K¯Ô`5ŽGÝÌ|žc·}’ì~Õ‰ž³ ­çôHó8Ñ¡æiû3ä5yŽ_,èMç)m™äµGÖ–É p¬Í¹ERﺂˆ4$(Ñ´ç'‡¸«z~0í˜èƳ(ÑqxDCˆÜŒG^CŸ0*À lîõÝ?ZY@øë—º¢.În~d7–?&eòåœá5/?ÞǦ YCIîÜ{){Iš/hu>›„s™¯‡3ú¾/«À{±?=ÛC<…ÃO?óϦí2Õ~.gýjìUØ«±TeŒ|çôA_§¶nûOâj8(‹øò¯àù‡ü»cò]ŒpÄú³ÈCüÑêŸÜ"¬Ïtˆ9È»wÎéùH¾…òe‡'‹áðÉ5—ؾFÓÀž>CTŸRyvÜ$qíá’j/Jµ¢¨ÂÅ2W¡¨1Wzƒo˜ÅWTb­â®Å_ÿÔûùŠ¨ËÐâ¯æëó·N}'óóSOeey³Xô¹XÄ÷’¼liAº09åúøðê2é½û³Ùã?chæ:áÇóàý¯0ÌG¡v*ìUتw¢_%µÀŽf †¡ÏE>ÿ<è;´£§‘Ç3Q—^ãû_!ÿ‚Ÿ±y{[uºXñfÄ(Äsœ9íß(’HA=h>”òs¯(ˆ ƒJí·åùÄÄÑ؇ؾD•@‡ h“ê¯.̾”{öÉ5–i#+ÇôbÅòæ¿üäåG‘¾³kyæ(µÍj*©Ðôr·s‡ìÈê}(ˆwØæ¯WÚúm>ÆV{†ÿ°=ß³ÿð:ížØ©CÇŒÿODkÈ}Rÿ6$y¿0¿7ÿ8µÍ[Û*éQèš>–Ò=•ŠHÓHÍ'^iU$Ø©ëœwiö¤µ¤ áˆä?[ô—°þÁ`öfÈråÈ”ˆ Ú#r9ïdÝOÍSß;v*¯m«2/jÔü†l;/Oãê#—gÜ?òÝöÏòWcg̬ǂ?ÖŸ¦ÿÍ/ƒ:Òà,ë·|ôWã'½y?Oäñ|>XÑWº$—^@ó•¬KûÛRŠ=«ñ=¬Š6ùœ£Y,|OÜ]·³y†ÖÒd<£›ùN%ùuž`ýÒìUØ«±Wb¬ßË7ð»Ço+„™H܇j{çoØý© ¸Æ9š˜ÛÞ?[òçü}„Ôv~¯&·O->BdkGy æÞñ—!ôžBýEä–PÑ}Ð>D_eyU ã¶H4ÉízŸæ/’ü¤WÎ>d±Ð,–ŒÝJ’•+ B²HÞȤå9õ8°G‹$€Dz»]Ú¹|-&)d—ØXòˆó$æ¿üägüæF³ù™kyä¯Ëô¹òß‘ç婨Hx_j±ô(ÁIôanè&l€JgÚ¹-@8ñza×¼þ¡øò~”öþx{QÕëˆÉ¨Ä áŒ÷ÿJcùÜ£ü;ÔŸ ç<û ±Wb®Å^÷ù'åÛxõh|ÝªÆ Z{×E…ÆÍ8Û֡쟳þVÿ³?`vw¼y‡Óïïø}þçÃ?à¹í˜ÁˆöVš^¹Þ‘ü0þg¾_Åý¿‰÷~‡æövOÞþ9ØÛóq‹Ü<½¯™B|}i…ÍÿùÌÏ>7š¿4-ü¿ÆM?É h¯Ö¸aþÄƇÝ3…ö‹Sâj8( øÏèù?VÿÀs±¿%ØçQ!êÔHËüÈúb>|RR|‹šÖŠ»v*˜YÜC<ÉäÇzÙÑö?hiô˜Ï8P¹Q⑹øD|†—æ*Ñ”ÎÒ:Ñ ÍÇú Ò÷Ÿ“ç'þ=½üÜéÃÙüµù¯ä½,Ænæºzñ€·ñÃþˆ4½çäÀÿÀƒ·¿›ý8ýO¡<¹ÿ9AùO¥¬bæëRi^6LŽôC¥ï?&³ÿîßþn?ôãõ={NÿœÖü‘µU^ëxiîãl?è‡IÞ~Lü= þn?ôãõ2Hÿç;?"Poµ¯û‡?üÕú"ÒwŸ’?äÎ{AüÜéÇêWóž‘þ?õ¯û†¿üÕú"ÒwŸ’ÿÉ›öƒù¸ÿÓÔ©üçoädÒ$Q]ë’K+Ž4Ó$ffc@ RIÂ=¡Òž§äÆ_ðíè‚Lq€?¦]Eª+ª6èXUºŠö9»|¸ŠFÇx­ß Ñ̾(E+W_Š¿ÿÕûùŠ¨ËÐâ¯ÂùÍÿ'ÉåÏgSH½;9ØÚk¥GÃÌGõYŘÉsþ°ñÏ?öƒ‡ª'¤€? ýÏ×ßð!íA¬ìc'Õ‚R÷_~2{Ÿ!f‘ô÷b®Å]Š»d:7šµÍ”é×¥cSQ€HŸ@jÓè¦gé»OQ§ mÜwsÉöç°ý‘Û23Ôagøãp—ÄƸ¿ÎìÚü䟜ôUUN‘tRœY’u&ž4›õfÎ>Òê8Äüÿ[Ãfÿ€—dÈÜ3fˆ÷Àÿ¼¥–Íÿ9™ù´"0é–º’BM¤²Ê:R¦yäCOõr3ö“S.B#àIr4ßðìLFç,Ù<Œ¢ûÄý¯óçoæ¿Ÿc’ßÍ>yÔïìe¯©¦E µ´jíF·¶FÔ*sY¨íF}§2Gw!òoÙÆö?e-6šþ"8§þš|RòÌÂzgb®Å]Š»N´˜9s”Ž§Šþ³o³zzÊzì>óúžÿà×ÛY0h"~rKÞn0ù?ôÁé™ylê_/¥ü‘¥òh !®Eõו4”hrFxºPA á«kâ1 Žaøïç¯,\ù/Î>fò­Ð"M QžÑ¿n$séH=ž2¬=Žyv«Á–XÏBC÷‡av¤{SA‡WY!{‰¡ð•ƒÊ«±Wb®Å]Š² ;Í~dÒB?Zº¶Uû*° Õ3qöŽ£¨ÎUïy­o±½¬‘ž].3#Ìðˆ“ï1«dù·ù–ñ´Iç]RÕ•ú¬ÆØì)³CÀ äçÚº©sÈ~}Î6ŸØ.ÁÀAŽ“¯ç?÷|LöþûS¹’óR½ŸP»—yn®dido›¹$ýùƒ)ÊFäl½N ><ÅŽB ò!2-®Å]Š»NôM'ôÀyª–P°õß¡oòWÜþ¶ì®Í–®vv€æ@ülðÞûo‹Ùí7 *ZœƒÑæÿN^C þ#·!";¶—©úK 0€‘F»Q°g}ˆŠùQŸ&£$²å‘”äI$ó$ó/dòÆ¡+´í“q‹è}7_ƒAÑu-výŠÙhös^Ýþœd`=È]²9r p3<€¿“~ƒE“[©Ç§Çõdˆ÷ÈÐ~KëšÅç˜u­[^Ô_Ô¿Öo'½¼~ÆIÜÈÔö©Û<».C’fræMüß»ô,z->=>1PÇ•ån[±Wb®Å]Š»v*ìUØ«±Wb¯lÿœxòÔ^eüÚòª]F$Óô9ÿLêî8Yñ‚;†›ÓRc›NÆÓøú¨ƒÈn~¶žþ =³ü™ØYçSÈ<8ûç±ùCˆü³öÞjG#÷•úsÑŸŒi–éúà–Ÿ\PC5²½æõÂĆA œ€Å¿éŠ¿ÿÖûùŠ¨ËÐ⯇?ç5¿(n?1ÿ.ã×ô[cqæo!4×Ö° «ÜXÈ£ë¨îÀ"È£¿ U³GÛÚ¨ÃŪü:þ·Õ?àOíL{´ü Æ°ê*$ôŒÇÑ/væ'úÖvÄìà®]Š»v*ìUØ«±Wb®Å]Š»v*ìU4¶Òn§£:˜#?´Ãsò¹Ñv&}FòôǼóøͽ¦ÿ‚fvEãÄ||Ãø`} ÿJ{îï–éÚxŒ$H Üõ9ÚitÑÓããÈ?2vÿmçínM^zl9 ¾ƒç»Ö¼±¤³IÃÜfK¥%õg‘ôcû¯ƒÃ$¤_WygMá|=†¢_ÿÎp~SÜYj:_涕l^ËPH´¿5_îî#mgz’ ô‰;¨:¶rÒhˆÏGcúèù?FÀWÚxÏ û+)õD™ãó‰úâ=ÇÕ]x¤z?>3•}ñØ«±Wb®Å]Š»v*ìUØ«±TßLÒe½a,•ŠÑOÅ'vö_ë›~Ìì™êÏÚýþïÖùç¶ÿð@Óv3‹dÔ‘´zBùK'pê#õKÈz™Ì¬h@"eAÖ0à ùO´{GQÚ:‰j53É3dŸÆÀrlÁ™è¶2Hé±Ë\_@ùGH˜¾ , _ÿ9®Ÿ,þXÇ¢Äþï›n’Ô/Fúµ½&‡ÒO³fÚG‡§àækà7?¡õOøö?ç{cóCÚ|¹®´Ü>>´ÂÀ‡¹h—†EC^¸ZËÐí²Œ(LÿæŒPÿÿ×ûùŠ©È6ÅXö£%lRüŽÿœžÿœY¼Óu=OÏ¿–ºq¸Ó.Ý®5Ï)Ú¡2[Èw’{DäŒwhÔUOÙvN;¶;‚rá:Ç»Ì~¯ÀúCþ?ðPÇÉÁ¦Ü —yülø_´ðAí^Û¸dŸ‡ˆÿ.1?Ö?T¾&»€MbÓ¤•‡Âsdñ ÇHòó»¯Àp±%îÞTòÃrŠ±øvÂÀ—ÔÞOÐ=1ÁáÛ$ÔKèNôãO‡¶²U<Ùå]#Í>_Õ<»®Ø¦¡¤jöïmi'FFPTЩ‚Œ¯.(å„…‚åö~¿>ƒQ F 丑ßúºÈ‹ðÿóÃò#ÌŸ“ºäâH¥Ôü¡y3 ÌJµ^'u†çŽÑÊÛìÔª÷Ï{K²òhåßÈþƒç÷¿bûíÖ“Ú<!¨ˆõãÿ}çGí)t'ƒæ­îŠ»v*ìUØ«±Wb«âŠIœGm#·EQS–cÅ<’á€$ù8ºÝvŸEˆæÔN8à9™Û׸s,¦Ã@T+-ñ ÝVÙNßìˆëòÔh=Ÿªžô¿¬þ§Á½®ÿ‚ùÈ%ƒ²‘ÊFÿòN'—õ¥¿tG6S 'Eâª(ªÃ:ˆÄDPØ>—,òÌÎdÊDÙ$Ù$õ$ó,§KÑ^W_‚µÉ5ö,ù]™£>™íÛ Y/¥<§årž‘ôü;ak%ð×üå?™†±ù—&m/;'ZÇ`ª§áúÌ€MpÃÜXÏú™ÁûA©ñu<#”|yŸÕð~±ÿc~G±Fy ž¢F~|#ÓîØÈYóVhßTv*ìUØ«±Wb®Å]Š»v*ìUÀ@¤ì/dJB Èšô–aeaQmã iüÇv?KsÓ4x< 1ÇÜ>Þ¿kðï´ª{W´³êÏ,“$TmðˆíYÔå‘ãølÊtD>¡òdîþ—^ØZ‹éÿ-Ô¤!’j/U²û+…‚mÿ4b¯ÿÐûùŠ­aQŠ¥·QòR)Š^w¯iþ¢?ÃZŒ ƒâÍßùÇï$ùÆâçR—M:Nµ!-&¯§Ò)$o’…$÷$rÿ+5ZÞÇÓêw"¥Þ?O{ß{5ÿnÖì01㟉ˆî@Tß}Àðù>óGüã×™´I$:f¡m«Û©³ò첪»[;Ò¼ îV±uöÂÄ—­h>J5Cé~Ó'»yoÊ"?O÷}=²Md½ã@ЄA> a`KÔll‚*í…‚.æÚ¨E1W“ùÇËÖZ½ÞŸ¨ÙC¨XÝ¡ŽæÎâ5–)þË#ùä'ÌT…‚äiµ9tùLR0œM‰DAò#püçüÊÿœTòÜ“Ü^ùJîo.Jì\éî Å¥zÑ0t©ÿ(Øg;ªösMñžÝÌ~·Ù;þ ý¡¤¶ã8Äü¤AKšÒé m*‘Ôaü2“§Ê9Äü‹²lhd.9ñ‘ýxþµ¿Wž´ô$©íÄÿLFŸ!þò+.ØÑDYÏŒëÇõª­…ëý›IO¿ÞF]ÏÔK–9|‹®Ô{]ØØ>½^åÇ~@’‹CÔd¥bÝØ~¡S™¸»U>`GÞU¼Æ¿þ ƒ¦ƒ$²‘Ò?|ø#ò)Í·–Tn$i?ÈAÄ}ûœÛéý›„wË"|†ß±ó¾ØÿƒV«(1ÐàŽ1üéž9|"*#ãÆÉmtÅ…x[Â"^üFçæzœßàÓcÀ+@’v¯më{S'‰«Ë,’ó;êÇéÀîÛG–B>¾^ê­ši^Y’F_Ýý±A/`ò÷“É)X¿ , }å'…Ö/ØZÉ{¾åç‚h`̨LQ1à€Ø¡¥Oza,cD‹4œ:×üáWçÆ»«jºî£{å¹oµ‹¹ï¯dúüÿ·ïmâÇ8ŒžÏêòHȘÙ7Ìõø?Qh¿à¿ìö“0cŽa qˆòˆ¡ü]ÁŠÞÿÎ~oØ‚ÓÜùzƒ¯Ùý‹Œ‡úÕwÇçû¯ù==…üÜßéüSÔ¿ç0t®_Y›I\Ô‡ì§üþ˜?Ðî§ú??Ø¿òy;»/úAÿ×øsRþXÿàôÇýê£óý‹ÿ'“±;²ÿ¤ñNÿj_ÊŸðGúcþ‡u?ÑùþÄÿÉäìNì¿éüSá½Kùcÿ‚?Óô;©þÏö#þO'bweÿJ?â›ÿ êËüþ˜ÿ¡ÝOô~±äòv'v_ôƒþ)ßá­OÂ?ø#ý1ÿCºžøüÿbäñö'órÿ¥ñNÿ j~ÿÁéúÔÿGçûþObweÿJ?â‘–>[¾Žê'Tô£nG‰$Ôn;xæ^‡°scÍä®ocÝ˧{ÏûQÿŽÎÖöf}>drG„qDRÚ[‰áºózn—c)uøO\럞 ܼ¥§IÎ*¯†¾µòNžÀDiÒ™ Ó'Ó¾^¶+m…¬½*Ñ(£ Ëúb‡ÿÑûùŠ»CÈ•c÷ö‚E;b——kÚ•^©^¸ð_2ùKÔõ¥Ö½°S`“Áõï%_÷_†E°•ê^Kp[÷_†,bW>Oû¯Ãm,)È÷†)µ£ÊÒÿ¾ÏÝŠÚ!<­/ûìýØ­¦0yNRGîÏÝŠ-=´òtŒGîÝ…Ëôÿ$9+ûŸÃGÐ4¯"š¯î 4ÄÉéú?‘ÀãûŸÃbdõM#Ê œuO£ ^›¥ùyb ðtöÂÄ–yc§,a~acl†8@lPéb¨;b¬[S±+ uÀÈù‹ËâPÿŽ,|ûæ_'ó2R/ÙÀ^­ù)¹?î¿ Áy½ÿ“û¯Ã;c“yF@OîÝŠm|© ?ÝŸ»¶×ʲ×û³÷b¶‡Êr?v~ìQiýŸ“¤b?t~ìQlãKòKµ‹ðÃH2z–‰ä}Ó÷_†bdö]ÉÁ8~맶`döMˉOƒðÂÀ—¢Ùi‹‡6‰¹·â„Š¼ËÌV¬Èà YÍþlÒ^_Sá¯\‹`|ý®yfIÿw×Û0X Ç“äf?º?v,­|˜çýÕø`¥âküÿï¯ÃO¿Áoþúü1¤q7þ ÷Ñû±¥âoüÿï£÷cIâwø1ÿßGîÆ—‰ßàÇÿ}»G´~Lzÿt~ìVÙF—ä翺ü0 —µy_ÊÌîü;a`Kéo*è¾’Çðt¦²^ë¤Zzh»tÂÀ²øV€abŠ§ê¦*ÿÿÒûùŠ»hŠâ¨Ib±V?}`$q­qM°=SËë(o‚¸ó=WÊ '/ÝuöÀÈžj>FV-ûŸÃd$Ä®¼„ ?¹ü0S.$šO ïýÏá/—øþ)ü1¥âWÈ[ÜþÒñ&ÖþB~çðÆ‘ÄȬüˆ?søa¤q2û$ªÓ÷_†(%›iþQD§î¿ ,m›XùmŸ»{b‹e–š: (´þ 5@(¸P™GZmŠ!iŠ´ËQŠ '€0;b–+¨i‹ o†µÀ—jÞZYy~ïðÅ•¼ÏUòb¹oÝ~)“¾ò %¿sø`¦\LfãÈB§÷?†4¼Isyî i?»ü0±¶§èI_ƒ6ËítõŒ .Zn€:b„-Ì5lRÂum?ÔðõÀògËž±ƒ0^s}äÁ#1ô¿ YZC'‘'÷?† O—ø¾ ixþïŸÃ^'€‡ûçðÆ—‰ßà!þùü1¥âwø¾ ixþïŸÃ^'€‡ûçðÆ—‰Q<†û§ðÆ—‰<²òB¡_Ý~iOBѼª±ýßá‹^¯¤i" ¿ )…,òÒ 0¡7E¦(TÅ_ÿÓûùŠ»v*ÑÅPÒDlU-žÍ^¿)Hît„züi Ç—ãjþìb¶“MåˆÚ¿»v)´yR2»ü1M¬ÿ Çþúü1¥µEò¤cýÖ>ìVѱyb1OÝ»Zk—cR?v>ìVÓˆ4TZ|îÅœC¦"Óá„Î+5^ت5!¶(WT^1VñWb«kŠ å€7lU)¸ÓÕÁøqJCs¢Fõø+6Üyr6¯îñM¥2ùZ3þëv+hSå8Ïû«ðÅ6áå8ÿßCîÅm•£~ì}Ø¢Óh<¹Ó÷cîÅm;·Ñ#Z|b‹NàÓQøp¢ÓX­•i¶*XÀíŠxâª2GQÓJ.m×lRÜi õø0&Òy|¾û­¡Ï–ãÿ}»Û_á¸ÿ߆+nÿ Çþûü1[wøn?÷ßáŠÛ¿Ãqÿ¾ÿ VÝþý÷øb¶ïðÜï¿Ã·†ãÿ}þ­¶<·ûì}Ø­¢¢òú)þìb‹Nm´„JQiŠÚ}oh›aBkS"¦*ìUÿÔûùŠ»v*ìUØ«\WÀb«}4=QOÐ1V½OXÿ±ªß«Ûž°Gÿ?¦*×Õ­¿åž?øý1W}VÛþYâÿ€ÓwÕ­¿åž?øý1Vþ¯oþøþLUw£ûé?àF*ߧé b­ñ_åv*Ý€Å[Å]Š»v*ìUØ«T«\TõQ÷b­zqž±©ú*·Ð„õ…ûŠµõk÷Äð#úb­}VÛþYâÿ€ÓwÕm¿åž/øý1Vþ­oþøþLU¿BÒìF*»ÓŒtGÐ1Vø¯ò»nƒÃov*êb«x©ê ý«^œg¬k÷ U¯F/÷ÒÀŒUÞŒ?ï¤ÿ«½ßIÿ1Wz0ÿ¾“þb®ôaÿ}'üÅ]èÃþúOøŠ»Ñ‡ýôŸð#w£ûé?àF*ïF÷ÒÀŒUÞŒ?ï¤ÿ«½¿ßIÿ1Vý8ÇDQô Uw²>ìU¼UØ«±WÿÕûùŠ»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å]Š»v*ìUØ«±Wb®Å_ÿÙgcl/ltmain.sh0000644000175000017500000046147712240167764012113 0ustar cammcamm# ltmain.sh - Provide generalized library-building support services. # NOTE: Changing this file will not affect anything until you rerun ltconfig. # # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 # Free Software Foundation, Inc. # Originally by Gordon Matzigkeit , 1996 # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Check that we have a working $echo. if test "X$1" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test "X$1" = X--fallback-echo; then # Avoid inline document here, it may be left over : elif test "X`($echo '\t') 2>/dev/null`" = 'X\t'; then # Yippee, $echo works! : else # Restart under the correct shell, and then maybe $echo will work. exec $SHELL "$0" --no-reexec ${1+"$@"} fi if test "X$1" = X--fallback-echo; then # used as fallback echo shift cat <&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 fi if test "$build_libtool_libs" != yes && test "$build_old_libs" != yes; then echo "$modename: not configured to build any kind of library" 1>&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 fi # Global variables. mode=$default_mode nonopt= prev= prevopt= run= show="$echo" show_help= execute_dlfiles= lo2o="s/\\.lo\$/.${objext}/" o2lo="s/\\.${objext}\$/.lo/" taglist= # Parse our command line options once, thoroughly. while test $# -gt 0 do arg="$1" shift case $arg in -*=*) optarg=`$echo "X$arg" | $Xsed -e 's/[-_a-zA-Z0-9]*=//'` ;; *) optarg= ;; esac # If the previous option needs an argument, assign it. if test -n "$prev"; then case $prev in execute_dlfiles) execute_dlfiles="$execute_dlfiles $arg" ;; tag) tagname="$arg" # Check whether tagname contains only valid characters case $tagname in *[!-_A-Za-z0-9,/]*) echo "$progname: invalid tag name: $tagname" 1>&2 exit 1 ;; esac case $tagname in CC) # Don't test for the "default" C tag, as we know, it's there, but # not specially marked. taglist="$taglist $tagname" ;; *) if grep "^### BEGIN LIBTOOL TAG CONFIG: $tagname$" < "$0" > /dev/null; then taglist="$taglist $tagname" # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$tagname'$/,/^### END LIBTOOL TAG CONFIG: '$tagname'$/p' < $0`" else echo "$progname: ignoring unknown tag $tagname" 1>&2 fi ;; esac ;; *) eval "$prev=\$arg" ;; esac prev= prevopt= continue fi # Have we seen a non-optional argument yet? case $arg in --help) show_help=yes ;; --version) echo "$PROGRAM (GNU $PACKAGE) $VERSION$TIMESTAMP" exit 0 ;; --config) sed -n -e '/^### BEGIN LIBTOOL CONFIG/,/^### END LIBTOOL CONFIG/p' < "$0" # Now print the configurations for the tags. for tagname in $taglist; do sed -n -e "/^### BEGIN LIBTOOL TAG CONFIG: $tagname$/,/^### END LIBTOOL TAG CONFIG: $tagname$/p" < "$0" done exit 0 ;; --debug) echo "$progname: enabling shell trace mode" set -x ;; --dry-run | -n) run=: ;; --features) echo "host: $host" if test "$build_libtool_libs" = yes; then echo "enable shared libraries" else echo "disable shared libraries" fi if test "$build_old_libs" = yes; then echo "enable static libraries" else echo "disable static libraries" fi exit 0 ;; --finish) mode="finish" ;; --mode) prevopt="--mode" prev=mode ;; --mode=*) mode="$optarg" ;; --quiet | --silent) show=: ;; --tag) prevopt="--tag" prev=tag ;; --tag=*) set tag "$optarg" ${1+"$@"} shift prev=tag ;; -dlopen) prevopt="-dlopen" prev=execute_dlfiles ;; -*) $echo "$modename: unrecognized option \`$arg'" 1>&2 $echo "$help" 1>&2 exit 1 ;; *) nonopt="$arg" break ;; esac done if test -n "$prevopt"; then $echo "$modename: option \`$prevopt' requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi # If this variable is set in any of the actions, the command in it # will be execed at the end. This prevents here-documents from being # left over by shells. exec_cmd= if test -z "$show_help"; then # Infer the operation mode. if test -z "$mode"; then case $nonopt in *cc | *++ | gcc* | *-gcc*) mode=link for arg do case $arg in -c) mode=compile break ;; esac done ;; *db | *dbx | *strace | *truss) mode=execute ;; *install*|cp|mv) mode=install ;; *rm) mode=uninstall ;; *) # If we have no mode, but dlfiles were specified, then do execute mode. test -n "$execute_dlfiles" && mode=execute # Just use the default operation mode. if test -z "$mode"; then if test -n "$nonopt"; then $echo "$modename: warning: cannot infer operation mode from \`$nonopt'" 1>&2 else $echo "$modename: warning: cannot infer operation mode without MODE-ARGS" 1>&2 fi fi ;; esac fi # Only execute mode is allowed to have -dlopen flags. if test -n "$execute_dlfiles" && test "$mode" != execute; then $echo "$modename: unrecognized option \`-dlopen'" 1>&2 $echo "$help" 1>&2 exit 1 fi # Change the help message to a mode-specific one. generic_help="$help" help="Try \`$modename --help --mode=$mode' for more information." # These modes are in order of execution frequency so that they run quickly. case $mode in # libtool compile mode compile) modename="$modename: compile" # Get the compilation command and the source file. base_compile= prev= lastarg= srcfile="$nonopt" suppress_output= user_target=no for arg do case $prev in "") ;; xcompiler) # Aesthetically quote the previous argument. prev= lastarg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac # Add the previous argument to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi continue ;; esac # Accept any command-line options. case $arg in -o) if test "$user_target" != "no"; then $echo "$modename: you cannot specify \`-o' more than once" 1>&2 exit 1 fi user_target=next ;; -static) build_old_libs=yes continue ;; -prefer-pic) pic_mode=yes continue ;; -prefer-non-pic) pic_mode=no continue ;; -Xcompiler) prev=xcompiler continue ;; -Wc,*) args=`$echo "X$arg" | $Xsed -e "s/^-Wc,//"` lastarg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for arg in $args; do IFS="$save_ifs" # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac lastarg="$lastarg $arg" done IFS="$save_ifs" lastarg=`$echo "X$lastarg" | $Xsed -e "s/^ //"` # Add the arguments to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi continue ;; esac case $user_target in next) # The next one is the -o target name user_target=yes continue ;; yes) # We got the output file user_target=set libobj="$arg" continue ;; esac # Accept the current argument as the source file. lastarg="$srcfile" srcfile="$arg" # Aesthetically quote the previous argument. # Backslashify any backslashes, double quotes, and dollar signs. # These are the only characters that are still specially # interpreted inside of double-quoted scrings. lastarg=`$echo "X$lastarg" | $Xsed -e "$sed_quote_subst"` # Double-quote args containing other shell metacharacters. # Many Bourne shells cannot handle close brackets correctly # in scan sets, so we specify it separately. case $lastarg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") lastarg="\"$lastarg\"" ;; esac # Add the previous argument to base_compile. if test -z "$base_compile"; then base_compile="$lastarg" else base_compile="$base_compile $lastarg" fi done case $user_target in set) ;; no) # Get the name of the library object. libobj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%'` ;; *) $echo "$modename: you must specify a target with \`-o'" 1>&2 exit 1 ;; esac # Recognize several different file suffixes. # If the user specifies -o file.o, it is replaced with file.lo xform='[cCFSfmso]' case $libobj in *.ada) xform=ada ;; *.adb) xform=adb ;; *.ads) xform=ads ;; *.asm) xform=asm ;; *.c++) xform=c++ ;; *.cc) xform=cc ;; *.class) xform=class ;; *.cpp) xform=cpp ;; *.cxx) xform=cxx ;; *.f90) xform=f90 ;; *.for) xform=for ;; *.java) xform=java ;; esac libobj=`$echo "X$libobj" | $Xsed -e "s/\.$xform$/.lo/"` case $libobj in *.lo) obj=`$echo "X$libobj" | $Xsed -e "$lo2o"` ;; *) $echo "$modename: cannot determine name of library object from \`$libobj'" 1>&2 exit 1 ;; esac # Infer tagged configuration to use if any are available and # if one wasn't chosen via the "--tag" command line option. # Only attempt this if the compiler in the base compile # command doesn't match the default compiler. if test -n "$available_tags" && test -z "$tagname"; then case $base_compile in "$CC "*) ;; # Blanks in the command may have been stripped by the calling shell, # but not from the CC environment variable when ltconfig was run. "`$echo $CC` "*) ;; *) for z in $available_tags; do if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" case $base_compile in "$CC "*) # The compiler in the base compile command matches # the one in the tagged configuration. # Assume this is the tagged configuration we want. tagname=$z break ;; "`$echo $CC` "*) tagname=$z break ;; esac fi done # If $tagname still isn't set, then no tagged configuration # was found and let the user know that the "--tag" command # line option must be used. if test -z "$tagname"; then echo "$modename: unable to infer tagged configuration" echo "$modename: specify a tag with \`--tag'" 1>&2 exit 1 # else # echo "$modename: using $tagname tagged configuration" fi ;; esac fi objname=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$obj"; then xdir= else xdir=$xdir/ fi lobj=${xdir}$objdir/$objname if test -z "$base_compile"; then $echo "$modename: you must specify a compilation command" 1>&2 $echo "$help" 1>&2 exit 1 fi # Delete any leftover library objects. if test "$build_old_libs" = yes; then removelist="$obj $lobj $libobj ${libobj}T" else removelist="$lobj $libobj ${libobj}T" fi $run $rm $removelist trap "$run $rm $removelist; exit 1" 1 2 15 # On Cygwin there's no "real" PIC flag so we must build both object types case $host_os in cygwin* | mingw* | pw32* | os2*) pic_mode=default ;; esac if test $pic_mode = no && test "$deplibs_check_method" != pass_all; then # non-PIC code in shared libraries is not supported pic_mode=default fi # Calculate the filename of the output object if compiler does # not support -o with -c if test "$compiler_c_o" = no; then output_obj=`$echo "X$srcfile" | $Xsed -e 's%^.*/%%' -e 's%\.[^.]*$%%'`.${objext} lockfile="$output_obj.lock" removelist="$removelist $output_obj $lockfile" trap "$run $rm $removelist; exit 1" 1 2 15 else output_obj= need_locks=no lockfile= fi # Lock this critical section if it is needed # We use this script file to make the link, it avoids creating a new file if test "$need_locks" = yes; then until $run ln "$0" "$lockfile" 2>/dev/null; do $show "Waiting for $lockfile to be removed" sleep 2 done elif test "$need_locks" = warn; then if test -f "$lockfile"; then echo "\ *** ERROR, $lockfile exists and contains: `cat $lockfile 2>/dev/null` This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi echo $srcfile > "$lockfile" fi if test -n "$fix_srcfile_path"; then eval srcfile=\"$fix_srcfile_path\" fi $run $rm "$libobj" "${libobj}T" # Create a libtool object file (analogous to a ".la" file), # but don't create it if we're doing a dry run. test -z "$run" && cat > ${libobj}T </dev/null`" != x"$srcfile"; then echo "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi # Just move the object if needed, then go on to compile the next one if test -n "$output_obj" && test "x$output_obj" != "x$lobj"; then $show "$mv $output_obj $lobj" if $run $mv $output_obj $lobj; then : else error=$? $run $rm $removelist exit $error fi fi # Append the name of the PIC object to the libtool object file. test -z "$run" && cat >> ${libobj}T <> ${libobj}T </dev/null`" != x"$srcfile"; then echo "\ *** ERROR, $lockfile contains: `cat $lockfile 2>/dev/null` but it should contain: $srcfile This indicates that another process is trying to use the same temporary object file, and libtool could not work around it because your compiler does not support \`-c' and \`-o' together. If you repeat this compilation, it may succeed, by chance, but you had better avoid parallel builds (make -j) in this platform, or get a better compiler." $run $rm $removelist exit 1 fi # Just move the object if needed if test -n "$output_obj" && test "x$output_obj" != "x$obj"; then $show "$mv $output_obj $obj" if $run $mv $output_obj $obj; then : else error=$? $run $rm $removelist exit $error fi fi # Append the name of the non-PIC object the libtool object file. # Only append if the libtool object file exists. test -z "$run" && cat >> ${libobj}T <> ${libobj}T <&2 fi if test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi else if test -z "$pic_flag" && test -n "$link_static_flag"; then dlopen_self=$dlopen_self_static fi fi build_libtool_libs=no build_old_libs=yes prefer_static_libs=yes break ;; esac done # See if our shared archives depend on static archives. test -n "$old_archive_from_new_cmds" && build_old_libs=yes # Go through the arguments, transforming them on the way. while test $# -gt 0; do arg="$1" base_compile="$base_compile $arg" shift case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") qarg=\"`$echo "X$arg" | $Xsed -e "$sed_quote_subst"`\" ### testsuite: skip nested quoting test ;; *) qarg=$arg ;; esac libtool_args="$libtool_args $qarg" # If the previous option needs an argument, assign it. if test -n "$prev"; then case $prev in output) compile_command="$compile_command @OUTPUT@" finalize_command="$finalize_command @OUTPUT@" ;; esac case $prev in dlfiles|dlprefiles) if test "$preload" = no; then # Add the symbol object into the linking commands. compile_command="$compile_command @SYMFILE@" finalize_command="$finalize_command @SYMFILE@" preload=yes fi case $arg in *.la | *.lo) ;; # We handle these cases below. force) if test "$dlself" = no; then dlself=needless export_dynamic=yes fi prev= continue ;; self) if test "$prev" = dlprefiles; then dlself=yes elif test "$prev" = dlfiles && test "$dlopen_self" != yes; then dlself=yes else dlself=needless export_dynamic=yes fi prev= continue ;; *) if test "$prev" = dlfiles; then dlfiles="$dlfiles $arg" else dlprefiles="$dlprefiles $arg" fi prev= continue ;; esac ;; expsyms) export_symbols="$arg" if test ! -f "$arg"; then $echo "$modename: symbol file \`$arg' does not exist" exit 1 fi prev= continue ;; expsyms_regex) export_symbols_regex="$arg" prev= continue ;; release) release="-$arg" prev= continue ;; objectlist) if test -f "$arg"; then save_arg=$arg moreargs= for fil in `cat $save_arg` do # moreargs="$moreargs $fil" arg=$fil # A libtool-controlled object. # Check to see that this really is a libtool object. if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then pic_object= non_pic_object= # Read the .lo file # If there is no directory component, then add one. case $arg in */* | *\\*) . $arg ;; *) . ./$arg ;; esac if test -z "$pic_object" || \ test -z "$non_pic_object" || test "$pic_object" = none && \ test "$non_pic_object" = none; then $echo "$modename: cannot find name of object for \`$arg'" 1>&2 exit 1 fi # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. libobjs="$libobjs $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object non_pic_objects="$non_pic_objects $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi fi else # Only an error if not doing a dry-run. if test -z "$run"; then $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 exit 1 else # Dry-run case. # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` libobjs="$libobjs $pic_object" non_pic_objects="$non_pic_objects $non_pic_object" fi fi done else $echo "$modename: link input file \`$save_arg' does not exist" exit 1 fi arg=$save_arg prev= continue ;; rpath | xrpath) # We need an absolute path. case $arg in [\\/]* | [A-Za-z]:[\\/]*) ;; *) $echo "$modename: only absolute run-paths are allowed" 1>&2 exit 1 ;; esac if test "$prev" = rpath; then case "$rpath " in *" $arg "*) ;; *) rpath="$rpath $arg" ;; esac else case "$xrpath " in *" $arg "*) ;; *) xrpath="$xrpath $arg" ;; esac fi prev= continue ;; xcompiler) compiler_flags="$compiler_flags $qarg" prev= compile_command="$compile_command $qarg" finalize_command="$finalize_command $qarg" continue ;; xlinker) linker_flags="$linker_flags $qarg" compiler_flags="$compiler_flags $wl$qarg" prev= compile_command="$compile_command $wl$qarg" finalize_command="$finalize_command $wl$qarg" continue ;; *) eval "$prev=\"\$arg\"" prev= continue ;; esac fi # test -n $prev prevarg="$arg" case $arg in -all-static) if test -n "$link_static_flag"; then compile_command="$compile_command $link_static_flag" finalize_command="$finalize_command $link_static_flag" fi continue ;; -allow-undefined) # FIXME: remove this flag sometime in the future. $echo "$modename: \`-allow-undefined' is deprecated because it is the default" 1>&2 continue ;; -avoid-version) avoid_version=yes continue ;; -dlopen) prev=dlfiles continue ;; -dlpreopen) prev=dlprefiles continue ;; -export-dynamic) export_dynamic=yes continue ;; -export-symbols | -export-symbols-regex) if test -n "$export_symbols" || test -n "$export_symbols_regex"; then $echo "$modename: more than one -exported-symbols argument is not allowed" exit 1 fi if test "X$arg" = "X-export-symbols"; then prev=expsyms else prev=expsyms_regex fi continue ;; # The native IRIX linker understands -LANG:*, -LIST:* and -LNO:* # so, if we see these flags be careful not to treat them like -L -L[A-Z][A-Z]*:*) case $with_gcc/$host in no/*-*-irix*) compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" ;; esac continue ;; -L*) dir=`$echo "X$arg" | $Xsed -e 's/^-L//'` # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) absdir=`cd "$dir" && pwd` if test -z "$absdir"; then $echo "$modename: cannot determine absolute directory name of \`$dir'" 1>&2 exit 1 fi dir="$absdir" ;; esac case "$deplibs " in *" -L$dir "*) ;; *) deplibs="$deplibs -L$dir" lib_search_path="$lib_search_path $dir" ;; esac case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) case :$dllsearchpath: in *":$dir:"*) ;; *) dllsearchpath="$dllsearchpath:$dir";; esac ;; esac continue ;; -l*) if test "X$arg" = "X-lc" || test "X$arg" = "X-lm"; then case $host in *-*-cygwin* | *-*-pw32* | *-*-beos*) # These systems don't actually have a C or math library (as such) continue ;; *-*-mingw* | *-*-os2*) # These systems don't actually have a C library (as such) test "X$arg" = "X-lc" && continue ;; esac fi deplibs="$deplibs $arg" continue ;; -module) module=yes continue ;; -no-fast-install) fast_install=no continue ;; -no-install) case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) # The PATH hackery in wrapper scripts is required on Windows # in order for the loader to find any dlls it needs. $echo "$modename: warning: \`-no-install' is ignored for $host" 1>&2 $echo "$modename: warning: assuming \`-no-fast-install' instead" 1>&2 fast_install=no ;; *) no_install=yes ;; esac continue ;; -no-undefined) allow_undefined=no continue ;; -objectlist) prev=objectlist continue ;; -o) prev=output ;; -release) prev=release continue ;; -rpath) prev=rpath continue ;; -R) prev=xrpath continue ;; -R*) dir=`$echo "X$arg" | $Xsed -e 's/^-R//'` # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) $echo "$modename: only absolute run-paths are allowed" 1>&2 exit 1 ;; esac case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac continue ;; -static) # The effects of -static are defined in a previous loop. # We used to do the same as -all-static on platforms that # didn't have a PIC flag, but the assumption that the effects # would be equivalent was wrong. It would break on at least # Digital Unix and AIX. continue ;; -thread-safe) thread_safe=yes continue ;; -version-info) prev=vinfo continue ;; -Wc,*) args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wc,//'` arg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" case $flag in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") flag="\"$flag\"" ;; esac arg="$arg $wl$flag" compiler_flags="$compiler_flags $flag" done IFS="$save_ifs" arg=`$echo "X$arg" | $Xsed -e "s/^ //"` ;; -Wl,*) args=`$echo "X$arg" | $Xsed -e "$sed_quote_subst" -e 's/^-Wl,//'` arg= IFS="${IFS= }"; save_ifs="$IFS"; IFS=',' for flag in $args; do IFS="$save_ifs" case $flag in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") flag="\"$flag\"" ;; esac arg="$arg $wl$flag" compiler_flags="$compiler_flags $wl$flag" linker_flags="$linker_flags $flag" done IFS="$save_ifs" arg=`$echo "X$arg" | $Xsed -e "s/^ //"` ;; -Xcompiler) prev=xcompiler continue ;; -Xlinker) prev=xlinker continue ;; # Some other compiler flag. -* | +*) # Unknown arguments in both finalize_command and compile_command need # to be aesthetically quoted because they are evaled later. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac ;; *.$objext) # A standard object. objs="$objs $arg" ;; *.lo) # A libtool-controlled object. # Check to see that this really is a libtool object. if (sed -e '2q' $arg | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then pic_object= non_pic_object= # Read the .lo file # If there is no directory component, then add one. case $arg in */* | *\\*) . $arg ;; *) . ./$arg ;; esac if test -z "$pic_object" || \ test -z "$non_pic_object" || test "$pic_object" = none && \ test "$non_pic_object" = none; then $echo "$modename: cannot find name of object for \`$arg'" 1>&2 exit 1 fi # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi if test "$pic_object" != none; then # Prepend the subdirectory the object is found in. pic_object="$xdir$pic_object" if test "$prev" = dlfiles; then if test "$build_libtool_libs" = yes && test "$dlopen_support" = yes; then dlfiles="$dlfiles $pic_object" prev= continue else # If libtool objects are unsupported, then we need to preload. prev=dlprefiles fi fi # CHECK ME: I think I busted this. -Ossama if test "$prev" = dlprefiles; then # Preload the old-style object. dlprefiles="$dlprefiles $pic_object" prev= fi # A PIC object. libobjs="$libobjs $pic_object" arg="$pic_object" fi # Non-PIC object. if test "$non_pic_object" != none; then # Prepend the subdirectory the object is found in. non_pic_object="$xdir$non_pic_object" # A standard non-PIC object non_pic_objects="$non_pic_objects $non_pic_object" if test -z "$pic_object" || test "$pic_object" = none ; then arg="$non_pic_object" fi fi else # Only an error if not doing a dry-run. if test -z "$run"; then $echo "$modename: \`$arg' is not a valid libtool object" 1>&2 exit 1 else # Dry-run case. # Extract subdirectory from the argument. xdir=`$echo "X$arg" | $Xsed -e 's%/[^/]*$%%'` if test "X$xdir" = "X$arg"; then xdir= else xdir="$xdir/" fi pic_object=`$echo "X${xdir}${objdir}/${arg}" | $Xsed -e "$lo2o"` non_pic_object=`$echo "X${xdir}${arg}" | $Xsed -e "$lo2o"` libobjs="$libobjs $pic_object" non_pic_objects="$non_pic_objects $non_pic_object" fi fi ;; *.$libext) # An archive. deplibs="$deplibs $arg" old_deplibs="$old_deplibs $arg" continue ;; *.la) # A libtool-controlled library. if test "$prev" = dlfiles; then # This library was specified with -dlopen. dlfiles="$dlfiles $arg" prev= elif test "$prev" = dlprefiles; then # The library was specified with -dlpreopen. dlprefiles="$dlprefiles $arg" prev= else deplibs="$deplibs $arg" fi continue ;; # Some other compiler argument. *) # Unknown arguments in both finalize_command and compile_command need # to be aesthetically quoted because they are evaled later. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*|"") arg="\"$arg\"" ;; esac ;; esac # arg # Now actually substitute the argument into the commands. if test -n "$arg"; then compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" fi done # argument parsing loop if test -n "$prev"; then $echo "$modename: the \`$prevarg' option requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi # Infer tagged configuration to use if any are available and # if one wasn't chosen via the "--tag" command line option. # Only attempt this if the compiler in the base link # command doesn't match the default compiler. if test -n "$available_tags" && test -z "$tagname"; then case $base_compile in "$CC "*) ;; # Blanks in the command may have been stripped by the calling shell, # but not from the CC environment variable when ltconfig was run. "`$echo $CC` "*) ;; *) for z in $available_tags; do if grep "^### BEGIN LIBTOOL TAG CONFIG: $z$" < "$0" > /dev/null; then # Evaluate the configuration. eval "`sed -n -e '/^### BEGIN LIBTOOL TAG CONFIG: '$z'$/,/^### END LIBTOOL TAG CONFIG: '$z'$/p' < $0`" case $base_compile in "$CC "*) # The compiler in $compile_command matches # the one in the tagged configuration. # Assume this is the tagged configuration we want. tagname=$z break ;; "`$echo $CC` "*) tagname=$z break ;; esac fi done # If $tagname still isn't set, then no tagged configuration # was found and let the user know that the "--tag" command # line option must be used. if test -z "$tagname"; then echo "$modename: unable to infer tagged configuration" echo "$modename: specify a tag with \`--tag'" 1>&2 exit 1 # else # echo "$modename: using $tagname tagged configuration" fi ;; esac fi if test "$export_dynamic" = yes && test -n "$export_dynamic_flag_spec"; then eval arg=\"$export_dynamic_flag_spec\" compile_command="$compile_command $arg" finalize_command="$finalize_command $arg" fi # calculate the name of the file, without its directory outputname=`$echo "X$output" | $Xsed -e 's%^.*/%%'` libobjs_save="$libobjs" if test -n "$shlibpath_var"; then # get the directories listed in $shlibpath_var eval shlib_search_path=\`\$echo \"X\${$shlibpath_var}\" \| \$Xsed -e \'s/:/ /g\'\` else shlib_search_path= fi eval sys_lib_search_path=\"$sys_lib_search_path_spec\" eval sys_lib_dlsearch_path=\"$sys_lib_dlsearch_path_spec\" output_objdir=`$echo "X$output" | $Xsed -e 's%/[^/]*$%%'` if test "X$output_objdir" = "X$output"; then output_objdir="$objdir" else output_objdir="$output_objdir/$objdir" fi # Create the object directory. if test ! -d $output_objdir; then $show "$mkdir $output_objdir" $run $mkdir $output_objdir status=$? if test $status -ne 0 && test ! -d $output_objdir; then exit $status fi fi # Determine the type of output case $output in "") $echo "$modename: you must specify an output file" 1>&2 $echo "$help" 1>&2 exit 1 ;; *.$libext) linkmode=oldlib ;; *.lo | *.$objext) linkmode=obj ;; *.la) linkmode=lib ;; *) linkmode=prog ;; # Anything else should be a program. esac specialdeplibs= libs= # Find all interdependent deplibs by searching for libraries # that are linked more than once (e.g. -la -lb -la) for deplib in $deplibs; do case "$libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac libs="$libs $deplib" done if test $linkmode = lib; then libs="$predeps $libs $compiler_lib_search_path $postdeps" # Compute libraries that are listed more than once in $predeps # $postdeps and mark them as special (i.e., whose duplicates are # not to be eliminated). pre_post_deps= for pre_post_dep in $predeps $postdeps; do case "$pre_post_deps " in *" $pre_post_dep "*) specialdeplibs="$specialdeplibs $pre_post_deps" ;; esac pre_post_deps="$pre_post_deps $pre_post_dep" done pre_post_deps= fi deplibs= newdependency_libs= newlib_search_path= need_relink=no # whether we're linking any uninstalled libtool libraries notinst_deplibs= # not-installed libtool libraries notinst_path= # paths that contain not-installed libtool libraries case $linkmode in lib) passes="conv link" for file in $dlfiles $dlprefiles; do case $file in *.la) ;; *) $echo "$modename: libraries can \`-dlopen' only libtool libraries: $file" 1>&2 exit 1 ;; esac done ;; prog) compile_deplibs= finalize_deplibs= alldeplibs=no newdlfiles= newdlprefiles= passes="conv scan dlopen dlpreopen link" ;; *) passes="conv" ;; esac for pass in $passes; do if test $linkmode = prog; then # Determine which files to process case $pass in dlopen) libs="$dlfiles" save_deplibs="$deplibs" # Collect dlpreopened libraries deplibs= ;; dlpreopen) libs="$dlprefiles" ;; link) libs="$deplibs %DEPLIBS% $dependency_libs" ;; esac fi for deplib in $libs; do lib= found=no case $deplib in -l*) if test $linkmode = oldlib && test $linkmode = obj; then $echo "$modename: warning: \`-l' is ignored for archives/objects: $deplib" 1>&2 continue fi if test $pass = conv; then deplibs="$deplib $deplibs" continue fi name=`$echo "X$deplib" | $Xsed -e 's/^-l//'` for searchdir in $newlib_search_path $lib_search_path $sys_lib_search_path $shlib_search_path; do # Search the libtool library lib="$searchdir/lib${name}.la" if test -f "$lib"; then found=yes break fi done if test "$found" != yes; then # deplib doesn't seem to be a libtool library if test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else deplibs="$deplib $deplibs" test $linkmode = lib && newdependency_libs="$deplib $newdependency_libs" fi continue fi ;; # -l -L*) case $linkmode in lib) deplibs="$deplib $deplibs" test $pass = conv && continue newdependency_libs="$deplib $newdependency_libs" newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` ;; prog) if test $pass = conv; then deplibs="$deplib $deplibs" continue fi if test $pass = scan; then deplibs="$deplib $deplibs" newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'` else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi ;; *) $echo "$modename: warning: \`-L' is ignored for archives/objects: $deplib" 1>&2 ;; esac # linkmode continue ;; # -L -R*) if test $pass = link; then dir=`$echo "X$deplib" | $Xsed -e 's/^-R//'` # Make sure the xrpath contains only unique directories. case "$xrpath " in *" $dir "*) ;; *) xrpath="$xrpath $dir" ;; esac fi deplibs="$deplib $deplibs" continue ;; *.la) lib="$deplib" ;; *.$libext) if test $pass = conv; then deplibs="$deplib $deplibs" continue fi case $linkmode in lib) if test "$deplibs_check_method" != pass_all; then echo echo "*** Warning: This library needs some functionality provided by $deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." else echo echo "*** Warning: Linking the shared library $output against the" echo "*** static library $deplib is not portable!" deplibs="$deplib $deplibs" fi continue ;; prog) if test $pass != link; then deplibs="$deplib $deplibs" else compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" fi continue ;; esac # linkmode ;; # *.$libext *.lo | *.$objext) if test $pass = dlpreopen || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlopen support or we're linking statically, # we need to preload. newdlprefiles="$newdlprefiles $deplib" compile_deplibs="$deplib $compile_deplibs" finalize_deplibs="$deplib $finalize_deplibs" else newdlfiles="$newdlfiles $deplib" fi continue ;; %DEPLIBS%) alldeplibs=yes continue ;; esac # case $deplib if test $found = yes || test -f "$lib"; then : else $echo "$modename: cannot find the library \`$lib'" 1>&2 exit 1 fi # Check to see that this really is a libtool archive. if (sed -e '2q' $lib | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi ladir=`$echo "X$lib" | $Xsed -e 's%/[^/]*$%%'` test "X$ladir" = "X$lib" && ladir="." dlname= dlopen= dlpreopen= libdir= library_names= old_library= # If the library was installed with an old release of libtool, # it will not redefine variable installed. installed=yes # Read the .la file case $lib in */* | *\\*) . $lib ;; *) . ./$lib ;; esac if test "$linkmode,$pass" = "lib,link" || test "$linkmode,$pass" = "prog,scan" || { test $linkmode = oldlib && test $linkmode = obj; }; then # Add dl[pre]opened files of deplib test -n "$dlopen" && dlfiles="$dlfiles $dlopen" test -n "$dlpreopen" && dlprefiles="$dlprefiles $dlpreopen" fi if test $pass = conv; then # Only check for convenience libraries deplibs="$lib $deplibs" if test -z "$libdir"; then if test -z "$old_library"; then $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 exit 1 fi # It is a libtool convenience library, so add in its objects. convenience="$convenience $ladir/$objdir/$old_library" old_convenience="$old_convenience $ladir/$objdir/$old_library" tmp_libs= for deplib in $dependency_libs; do deplibs="$deplib $deplibs" case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done elif test $linkmode != prog && test $linkmode != lib; then $echo "$modename: \`$lib' is not a convenience library" 1>&2 exit 1 fi continue fi # $pass = conv # Get the name of the library we link against. linklib= for l in $old_library $library_names; do linklib="$l" done if test -z "$linklib"; then $echo "$modename: cannot find name of link library for \`$lib'" 1>&2 exit 1 fi # This library was specified with -dlopen. if test $pass = dlopen; then if test -z "$libdir"; then $echo "$modename: cannot -dlopen a convenience library: \`$lib'" 1>&2 exit 1 fi if test -z "$dlname" || test "$dlopen_support" != yes || test "$build_libtool_libs" = no; then # If there is no dlname, no dlopen support or we're linking # statically, we need to preload. dlprefiles="$dlprefiles $lib" else newdlfiles="$newdlfiles $lib" fi continue fi # $pass = dlopen # We need an absolute path. case $ladir in [\\/]* | [A-Za-z]:[\\/]*) abs_ladir="$ladir" ;; *) abs_ladir=`cd "$ladir" && pwd` if test -z "$abs_ladir"; then $echo "$modename: warning: cannot determine absolute directory name of \`$ladir'" 1>&2 $echo "$modename: passing it literally to the linker, although it might fail" 1>&2 abs_ladir="$ladir" fi ;; esac laname=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` # Find the relevant object directory and library name. if test "X$installed" = Xyes; then if test ! -f "$libdir/$linklib" && test -f "$abs_ladir/$linklib"; then $echo "$modename: warning: library \`$lib' was moved." 1>&2 dir="$ladir" absdir="$abs_ladir" libdir="$abs_ladir" else dir="$libdir" absdir="$libdir" fi else dir="$ladir/$objdir" absdir="$abs_ladir/$objdir" # Remove this search path later notinst_path="$notinst_path $abs_ladir" fi # $installed = yes name=`$echo "X$laname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` # This library was specified with -dlpreopen. if test $pass = dlpreopen; then if test -z "$libdir"; then $echo "$modename: cannot -dlpreopen a convenience library: \`$lib'" 1>&2 exit 1 fi # Prefer using a static library (so that no silly _DYNAMIC symbols # are required to link). if test -n "$old_library"; then newdlprefiles="$newdlprefiles $dir/$old_library" # Otherwise, use the dlname, so that lt_dlopen finds it. elif test -n "$dlname"; then newdlprefiles="$newdlprefiles $dir/$dlname" else newdlprefiles="$newdlprefiles $dir/$linklib" fi fi # $pass = dlpreopen if test -z "$libdir"; then # Link the convenience library if test $linkmode = lib; then deplibs="$dir/$old_library $deplibs" elif test "$linkmode,$pass" = "prog,link"; then compile_deplibs="$dir/$old_library $compile_deplibs" finalize_deplibs="$dir/$old_library $finalize_deplibs" else deplibs="$lib $deplibs" fi continue fi if test $linkmode = prog && test $pass != link; then newlib_search_path="$newlib_search_path $ladir" deplibs="$lib $deplibs" linkalldeplibs=no if test "$link_all_deplibs" != no || test -z "$library_names" || test "$build_libtool_libs" = no; then linkalldeplibs=yes fi tmp_libs= for deplib in $dependency_libs; do case $deplib in -L*) newlib_search_path="$newlib_search_path "`$echo "X$deplib" | $Xsed -e 's/^-L//'`;; ### testsuite: skip nested quoting test esac # Need to link against all dependency_libs? if test $linkalldeplibs = yes; then deplibs="$deplib $deplibs" else # Need to hardcode shared library paths # or/and link against static libraries newdependency_libs="$deplib $newdependency_libs" fi case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done # for deplib continue fi # $linkmode = prog... link_static=no # Whether the deplib will be linked statically if test -n "$library_names" && { test "$prefer_static_libs" = no || test -z "$old_library"; }; then # Link against this shared library if test "$linkmode,$pass" = "prog,link" || { test $linkmode = lib && test $hardcode_into_libs = yes; }; then # Hardcode the library path. # Skip directories that are in the system default run-time # search path. case " $sys_lib_dlsearch_path " in *" $absdir "*) ;; *) case "$compile_rpath " in *" $absdir "*) ;; *) compile_rpath="$compile_rpath $absdir" esac ;; esac case " $sys_lib_dlsearch_path " in *" $libdir "*) ;; *) case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" esac ;; esac if test $linkmode = prog; then # We need to hardcode the library path if test -n "$shlibpath_var"; then # Make sure the rpath contains only unique directories. case "$temp_rpath " in *" $dir "*) ;; *" $absdir "*) ;; *) temp_rpath="$temp_rpath $dir" ;; esac fi fi fi # $linkmode,$pass = prog,link... if test "$alldeplibs" = yes && { test "$deplibs_check_method" = pass_all || { test "$build_libtool_libs" = yes && test -n "$library_names"; }; }; then # We only need to search for static libraries continue fi if test "$installed" = no; then notinst_deplibs="$notinst_deplibs $lib" need_relink=yes fi if test -n "$old_archive_from_expsyms_cmds"; then # figure out the soname set dummy $library_names realname="$2" shift; shift libname=`eval \\$echo \"$libname_spec\"` # use dlname if we got it. it's perfectly good, no? if test -n "$dlname"; then soname="$dlname" elif test -n "$soname_spec"; then # bleh windows case $host in *cygwin*) major=`expr $current - $age` versuffix="-$major" ;; esac eval soname=\"$soname_spec\" else soname="$realname" fi # Make a new name for the extract_expsyms_cmds to use soroot="$soname" soname=`echo $soroot | sed -e 's/^.*\///'` newlib="libimp-`echo $soname | sed 's/^lib//;s/\.dll$//'`.a" # If the library has no export list, then create one now if test -f "$output_objdir/$soname-def"; then : else $show "extracting exported symbol list from \`$soname'" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' eval cmds=\"$extract_expsyms_cmds\" for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # Create $newlib if test -f "$output_objdir/$newlib"; then :; else $show "generating import library for \`$soname'" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' eval cmds=\"$old_archive_from_expsyms_cmds\" for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # make sure the library variables are pointing to the new library dir=$output_objdir linklib=$newlib fi # test -n $old_archive_from_expsyms_cmds if test $linkmode = prog || test "$mode" != relink; then add_shlibpath= add_dir= add= lib_linked=yes case $hardcode_action in immediate | unsupported) if test "$hardcode_direct" = no; then add="$dir/$linklib" elif test "$hardcode_minus_L" = no; then case $host in *-*-sunos*) add_shlibpath="$dir" ;; esac add_dir="-L$dir" add="-l$name" elif test "$hardcode_shlibpath_var" = no; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; relink) if test "$hardcode_direct" = yes; then add="$dir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$dir" add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then add_shlibpath="$dir" add="-l$name" else lib_linked=no fi ;; *) lib_linked=no ;; esac if test "$lib_linked" != yes; then $echo "$modename: configuration error: unsupported hardcode properties" exit 1 fi if test -n "$add_shlibpath"; then case :$compile_shlibpath: in *":$add_shlibpath:"*) ;; *) compile_shlibpath="$compile_shlibpath$add_shlibpath:" ;; esac fi if test $linkmode = prog; then test -n "$add_dir" && compile_deplibs="$add_dir $compile_deplibs" test -n "$add" && compile_deplibs="$add $compile_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" if test "$hardcode_direct" != yes && \ test "$hardcode_minus_L" != yes && \ test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac fi fi fi if test $linkmode = prog || test "$mode" = relink; then add_shlibpath= add_dir= add= # Finalize command for both is simple: just hardcode it. if test "$hardcode_direct" = yes; then add="$libdir/$linklib" elif test "$hardcode_minus_L" = yes; then add_dir="-L$libdir" add="-l$name" elif test "$hardcode_shlibpath_var" = yes; then case :$finalize_shlibpath: in *":$libdir:"*) ;; *) finalize_shlibpath="$finalize_shlibpath$libdir:" ;; esac add="-l$name" else # We cannot seem to hardcode it, guess we'll fake it. add_dir="-L$libdir" add="-l$name" fi if test $linkmode = prog; then test -n "$add_dir" && finalize_deplibs="$add_dir $finalize_deplibs" test -n "$add" && finalize_deplibs="$add $finalize_deplibs" else test -n "$add_dir" && deplibs="$add_dir $deplibs" test -n "$add" && deplibs="$add $deplibs" fi fi elif test $linkmode = prog; then if test "$alldeplibs" = yes && { test "$deplibs_check_method" = pass_all || { test "$build_libtool_libs" = yes && test -n "$library_names"; }; }; then # We only need to search for static libraries continue fi # Try to link the static library # Here we assume that one of hardcode_direct or hardcode_minus_L # is not unsupported. This is valid on all known static and # shared platforms. if test "$hardcode_direct" != unsupported; then test -n "$old_library" && linklib="$old_library" compile_deplibs="$dir/$linklib $compile_deplibs" finalize_deplibs="$dir/$linklib $finalize_deplibs" else compile_deplibs="-l$name -L$dir $compile_deplibs" finalize_deplibs="-l$name -L$dir $finalize_deplibs" fi elif test "$build_libtool_libs" = yes; then # Not a shared library if test "$deplibs_check_method" != pass_all; then # We're trying link a shared library against a static one # but the system doesn't support it. # Just print a warning and add the library to dependency_libs so # that the program can be linked against the static library. echo echo "*** Warning: This library needs some functionality provided by $lib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." if test "$module" = yes; then echo "*** Therefore, libtool will create a static module, that should work " echo "*** as long as the dlopening application is linked with the -dlopen flag." if test -z "$global_symbol_pipe"; then echo echo "*** However, this would only work if libtool was able to extract symbol" echo "*** lists from a program, using \`nm' or equivalent, but libtool could" echo "*** not find such a program. So, this module is probably useless." echo "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi else convenience="$convenience $dir/$old_library" old_convenience="$old_convenience $dir/$old_library" deplibs="$dir/$old_library $deplibs" link_static=yes fi fi # link shared/static library? if test $linkmode = lib; then if test -n "$dependency_libs" && { test $hardcode_into_libs != yes || test $build_old_libs = yes || test $link_static = yes; }; then # Extract -R from dependency_libs temp_deplibs= for libdir in $dependency_libs; do case $libdir in -R*) temp_xrpath=`$echo "X$libdir" | $Xsed -e 's/^-R//'` case " $xrpath " in *" $temp_xrpath "*) ;; *) xrpath="$xrpath $temp_xrpath";; esac;; *) temp_deplibs="$temp_deplibs $libdir";; esac done dependency_libs="$temp_deplibs" fi newlib_search_path="$newlib_search_path $absdir" # Link against this library test "$link_static" = no && newdependency_libs="$abs_ladir/$laname $newdependency_libs" # ... and its dependency_libs tmp_libs= for deplib in $dependency_libs; do newdependency_libs="$deplib $newdependency_libs" case "$tmp_libs " in *" $deplib "*) specialdeplibs="$specialdeplibs $deplib" ;; esac tmp_libs="$tmp_libs $deplib" done if test $link_all_deplibs != no; then # Add the search paths of all dependency libraries for deplib in $dependency_libs; do case $deplib in -L*) path="$deplib" ;; *.la) dir=`$echo "X$deplib" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$deplib" && dir="." # We need an absolute path. case $dir in [\\/]* | [A-Za-z]:[\\/]*) absdir="$dir" ;; *) absdir=`cd "$dir" && pwd` if test -z "$absdir"; then $echo "$modename: warning: cannot determine absolute directory name of \`$dir'" 1>&2 absdir="$dir" fi ;; esac if grep "^installed=no" $deplib > /dev/null; then path="-L$absdir/$objdir" else eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` if test -z "$libdir"; then $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 exit 1 fi if test "$absdir" != "$libdir"; then $echo "$modename: warning: \`$deplib' seems to be moved" 1>&2 fi path="-L$absdir" fi ;; *) continue ;; esac case " $deplibs " in *" $path "*) ;; *) deplibs="$path $deplibs" ;; esac done fi # link_all_deplibs != no fi # linkmode = lib done # for deplib in $libs if test $pass = dlpreopen; then # Link the dlpreopened libraries before other libraries for deplib in $save_deplibs; do deplibs="$deplib $deplibs" done fi if test $pass != dlopen; then test $pass != scan && dependency_libs="$newdependency_libs" if test $pass != conv; then # Make sure lib_search_path contains only unique directories. lib_search_path= for dir in $newlib_search_path; do case "$lib_search_path " in *" $dir "*) ;; *) lib_search_path="$lib_search_path $dir" ;; esac done newlib_search_path= fi if test "$linkmode,$pass" != "prog,link"; then vars="deplibs" else vars="compile_deplibs finalize_deplibs" fi for var in $vars dependency_libs; do # Add libraries to $var in reverse order eval tmp_libs=\"\$$var\" new_libs= for deplib in $tmp_libs; do case $deplib in -L*) new_libs="$deplib $new_libs" ;; *) case " $specialdeplibs " in *" $deplib "*) new_libs="$deplib $new_libs" ;; *) case " $new_libs " in *" $deplib "*) ;; *) new_libs="$deplib $new_libs" ;; esac ;; esac ;; esac done tmp_libs= for deplib in $new_libs; do case $deplib in -L*) case " $tmp_libs " in *" $deplib "*) ;; *) tmp_libs="$tmp_libs $deplib" ;; esac ;; *) tmp_libs="$tmp_libs $deplib" ;; esac done eval $var=\"$tmp_libs\" done # for var fi if test "$pass" = "conv" && { test "$linkmode" = "lib" || test "$linkmode" = "prog"; }; then libs="$deplibs" # reset libs deplibs= fi done # for pass if test $linkmode = prog; then dlfiles="$newdlfiles" dlprefiles="$newdlprefiles" fi case $linkmode in oldlib) if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then $echo "$modename: warning: \`-dlopen' is ignored for archives" 1>&2 fi if test -n "$rpath"; then $echo "$modename: warning: \`-rpath' is ignored for archives" 1>&2 fi if test -n "$xrpath"; then $echo "$modename: warning: \`-R' is ignored for archives" 1>&2 fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for archives" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for archives" 1>&2 fi if test -n "$export_symbols" || test -n "$export_symbols_regex"; then $echo "$modename: warning: \`-export-symbols' is ignored for archives" 1>&2 fi # Now set the variables for building old libraries. build_libtool_libs=no oldlibs="$output" objs="$objs$old_deplibs" ;; lib) # Make sure we only generate libraries of the form `libNAME.la'. case $outputname in lib*) name=`$echo "X$outputname" | $Xsed -e 's/\.la$//' -e 's/^lib//'` eval libname=\"$libname_spec\" ;; *) if test "$module" = no; then $echo "$modename: libtool library \`$output' must begin with \`lib'" 1>&2 $echo "$help" 1>&2 exit 1 fi if test "$need_lib_prefix" != no; then # Add the "lib" prefix for modules if required name=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` eval libname=\"$libname_spec\" else libname=`$echo "X$outputname" | $Xsed -e 's/\.la$//'` fi ;; esac if test -n "$objs"; then if test "$deplibs_check_method" != pass_all; then $echo "$modename: cannot build libtool library \`$output' from non-libtool objects on this host:$objs" 2>&1 exit 1 else echo echo "*** Warning: Linking the shared library $output against the non-libtool" echo "*** objects $objs is not portable!" libobjs="$libobjs $objs" fi fi if test "$dlself" != no; then $echo "$modename: warning: \`-dlopen self' is ignored for libtool libraries" 1>&2 fi set dummy $rpath if test $# -gt 2; then $echo "$modename: warning: ignoring multiple \`-rpath's for a libtool library" 1>&2 fi install_libdir="$2" oldlibs= if test -z "$rpath"; then if test "$build_libtool_libs" = yes; then # Building a libtool convenience library. # Some compilers have problems with a `.al' extension so # convenience libraries should have the same extension an # archive normally would. oldlibs="$output_objdir/$libname.$libext $oldlibs" build_libtool_libs=convenience build_old_libs=yes fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for convenience libraries" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for convenience libraries" 1>&2 fi else # Parse the version information argument. IFS="${IFS= }"; save_ifs="$IFS"; IFS=':' set dummy $vinfo 0 0 0 IFS="$save_ifs" if test -n "$8"; then $echo "$modename: too many parameters to \`-version-info'" 1>&2 $echo "$help" 1>&2 exit 1 fi current="$2" revision="$3" age="$4" # Check that each of the things are valid numbers. case $current in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: CURRENT \`$current' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac case $revision in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: REVISION \`$revision' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac case $age in 0 | [1-9] | [1-9][0-9] | [1-9][0-9][0-9]) ;; *) $echo "$modename: AGE \`$age' is not a nonnegative integer" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 ;; esac if test $age -gt $current; then $echo "$modename: AGE \`$age' is greater than the current interface number \`$current'" 1>&2 $echo "$modename: \`$vinfo' is not valid version information" 1>&2 exit 1 fi # Calculate the version variables. major= versuffix= verstring= case $version_type in none) ;; darwin) # Like Linux, but with the current version available in # verstring for coding it into the library header major=.`expr $current - $age` versuffix="$major.$age.$revision" # Darwin ld doesn't like 0 for these options... minor_current=`expr $current + 1` verstring="-compatibility_version $minor_current -current_version $minor_current.$revision" ;; freebsd-aout) major=".$current" versuffix=".$current.$revision"; ;; freebsd-elf) major=".$current" versuffix=".$current"; ;; irix) major=`expr $current - $age + 1` verstring="sgi$major.$revision" # Add in all the interfaces that we are compatible with. loop=$revision while test $loop != 0; do iface=`expr $revision - $loop` loop=`expr $loop - 1` verstring="sgi$major.$iface:$verstring" done # Before this point, $major must not contain `.'. major=.$major versuffix="$major.$revision" ;; linux) major=.`expr $current - $age` versuffix="$major.$age.$revision" ;; osf) major=`expr $current - $age` versuffix=".$current.$age.$revision" verstring="$current.$age.$revision" # Add in all the interfaces that we are compatible with. loop=$age while test $loop != 0; do iface=`expr $current - $loop` loop=`expr $loop - 1` verstring="$verstring:${iface}.0" done # Make executables depend on our current version. verstring="$verstring:${current}.0" ;; sunos) major=".$current" versuffix=".$current.$revision" ;; windows) # Use '-' rather than '.', since we only want one # extension on DOS 8.3 filesystems. major=`expr $current - $age` versuffix="-$major" ;; *) $echo "$modename: unknown library version type \`$version_type'" 1>&2 echo "Fatal configuration error. See the $PACKAGE docs for more information." 1>&2 exit 1 ;; esac # Clear the version info if we defaulted, and they specified a release. if test -z "$vinfo" && test -n "$release"; then major= verstring="0.0" if test "$need_version" = no; then versuffix= else versuffix=".0.0" fi fi # Remove version info from name if versioning should be avoided if test "$avoid_version" = yes && test "$need_version" = no; then major= versuffix= verstring="" fi # Check to see if the archive will have undefined symbols. if test "$allow_undefined" = yes; then if test "$allow_undefined_flag" = unsupported; then $echo "$modename: warning: undefined symbols not allowed in $host shared libraries" 1>&2 build_libtool_libs=no build_old_libs=yes fi else # Don't allow undefined symbols. allow_undefined_flag="$no_undefined_flag" fi fi if test "$mode" != relink; then # Remove our outputs, but don't remove object files since they # may have been created when compiling PIC objects. removelist= tempremovelist=`echo "$output_objdir/*"` for p in $tempremovelist; do case $p in *.$objext) ;; $output_objdir/$outputname | $output_objdir/$libname.* | $output_objdir/${libname}${release}.*) removelist="$removelist $p" ;; *) ;; esac done if test -n "$removelist"; then $show "${rm}r $removelist" $run ${rm}r $removelist fi fi # Now set the variables for building old libraries. if test "$build_old_libs" = yes && test "$build_libtool_libs" != convenience ; then oldlibs="$oldlibs $output_objdir/$libname.$libext" # Transform .lo files to .o files. oldobjs="$objs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}'$/d' -e "$lo2o" | $NL2SP` fi # Eliminate all temporary directories. for path in $notinst_path; do lib_search_path=`echo "$lib_search_path " | sed -e 's% $path % %g'` deplibs=`echo "$deplibs " | sed -e 's% -L$path % %g'` dependency_libs=`echo "$dependency_libs " | sed -e 's% -L$path % %g'` done if test -n "$xrpath"; then # If the user specified any rpath flags, then add them. temp_xrpath= for libdir in $xrpath; do temp_xrpath="$temp_xrpath -R$libdir" case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done if test $hardcode_into_libs != yes || test $build_old_libs = yes; then dependency_libs="$temp_xrpath $dependency_libs" fi fi # Make sure dlfiles contains only unique files that won't be dlpreopened old_dlfiles="$dlfiles" dlfiles= for lib in $old_dlfiles; do case " $dlprefiles $dlfiles " in *" $lib "*) ;; *) dlfiles="$dlfiles $lib" ;; esac done # Make sure dlprefiles contains only unique files old_dlprefiles="$dlprefiles" dlprefiles= for lib in $old_dlprefiles; do case "$dlprefiles " in *" $lib "*) ;; *) dlprefiles="$dlprefiles $lib" ;; esac done if test "$build_libtool_libs" = yes; then if test -n "$rpath"; then case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2* | *-*-beos*) # these systems don't actually have a c library (as such)! ;; *-*-rhapsody* | *-*-darwin1.[012]) # Rhapsody C library is in the System framework deplibs="$deplibs -framework System" ;; *-*-netbsd*) # Don't link with libc until the a.out ld.so is fixed. ;; *) # Add libc to deplibs on all other systems if necessary. if test $build_libtool_need_lc = "yes"; then deplibs="$deplibs -lc" fi ;; esac fi # Transform deplibs into only deplibs that can be linked in shared. name_save=$name libname_save=$libname release_save=$release versuffix_save=$versuffix major_save=$major # I'm not sure if I'm treating the release correctly. I think # release should show up in the -l (ie -lgmp5) so we don't want to # add it in twice. Is that correct? release="" versuffix="" major="" newdeplibs= droppeddeps=no case $deplibs_check_method in pass_all) # Don't check for shared/static. Everything works. # This might be a little naive. We might want to check # whether the library exists or not. But this is on # osf3 & osf4 and I'm not really sure... Just # implementing what was already the behaviour. newdeplibs=$deplibs ;; test_compile) # This code stresses the "libraries are programs" paradigm to its # limits. Maybe even breaks it. We compile a program, linking it # against the deplibs as a proxy for the library. Then we can check # whether they linked in statically or dynamically with ldd. $rm conftest.c cat > conftest.c </dev/null` for potent_lib in $potential_libs; do # Follow soft links. if ls -lLd "$potent_lib" 2>/dev/null \ | grep " -> " >/dev/null; then continue fi # The statement above tries to avoid entering an # endless loop below, in case of cyclic links. # We might still enter an endless loop, since a link # loop can be closed while we follow links, # but so what? potlib="$potent_lib" while test -h "$potlib" 2>/dev/null; do potliblink=`ls -ld $potlib | sed 's/.* -> //'` case $potliblink in [\\/]* | [A-Za-z]:[\\/]*) potlib="$potliblink";; *) potlib=`$echo "X$potlib" | $Xsed -e 's,[^/]*$,,'`"$potliblink";; esac done # It is ok to link against an archive when # building a shared library. if $AR -t $potlib > /dev/null 2>&1; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi if eval $file_magic_cmd \"\$potlib\" 2>/dev/null \ | sed 10q \ | egrep "$file_magic_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done if test -n "$a_deplib" ; then droppeddeps=yes echo echo "*** Warning: This library needs some functionality provided by $a_deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." fi else # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" fi done # Gone through all deplibs. ;; match_pattern*) set dummy $deplibs_check_method match_pattern_regex=`expr "$deplibs_check_method" : "$2 \(.*\)"` for a_deplib in $deplibs; do name="`expr $a_deplib : '-l\(.*\)'`" # If $name is empty we are operating on a -L argument. if test -n "$name" && test "$name" != "0"; then libname=`eval \\$echo \"$libname_spec\"` for i in $lib_search_path $sys_lib_search_path $shlib_search_path; do potential_libs=`ls $i/$libname[.-]* 2>/dev/null` for potent_lib in $potential_libs; do if eval echo \"$potent_lib\" 2>/dev/null \ | sed 10q \ | egrep "$match_pattern_regex" > /dev/null; then newdeplibs="$newdeplibs $a_deplib" a_deplib="" break 2 fi done done if test -n "$a_deplib" ; then droppeddeps=yes echo echo "*** Warning: This library needs some functionality provided by $a_deplib." echo "*** I have the capability to make that library automatically link in when" echo "*** you link to this library. But I can only do this if you have a" echo "*** shared version of the library, which you do not appear to have." fi else # Add a -L argument. newdeplibs="$newdeplibs $a_deplib" fi done # Gone through all deplibs. ;; none | unknown | *) newdeplibs="" if $echo "X $deplibs" | $Xsed -e 's/ -lc$//' \ -e 's/ -[LR][^ ]*//g' -e 's/[ ]//g' | grep . >/dev/null; then echo if test "X$deplibs_check_method" = "Xnone"; then echo "*** Warning: inter-library dependencies are not supported in this platform." else echo "*** Warning: inter-library dependencies are not known to be supported." fi echo "*** All declared inter-library dependencies are being dropped." droppeddeps=yes fi ;; esac versuffix=$versuffix_save major=$major_save release=$release_save libname=$libname_save name=$name_save case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library is the System framework newdeplibs=`$echo "X $newdeplibs" | $Xsed -e 's/ -lc / -framework System /'` ;; esac if test "$droppeddeps" = yes; then if test "$module" = yes; then echo echo "*** Warning: libtool could not satisfy all declared inter-library" echo "*** dependencies of module $libname. Therefore, libtool will create" echo "*** a static module, that should work as long as the dlopening" echo "*** application is linked with the -dlopen flag." if test -z "$global_symbol_pipe"; then echo echo "*** However, this would only work if libtool was able to extract symbol" echo "*** lists from a program, using \`nm' or equivalent, but libtool could" echo "*** not find such a program. So, this module is probably useless." echo "*** \`nm' from GNU binutils and a full rebuild may help." fi if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi else echo "*** The inter-library dependencies that have been dropped here will be" echo "*** automatically added whenever a program is linked with this library" echo "*** or is declared to -dlopen it." if test $allow_undefined = no; then echo echo "*** Since this library must not contain undefined symbols," echo "*** because either the platform does not support them or" echo "*** it was explicitly requested with -no-undefined," echo "*** libtool will only create a static version of it." if test "$build_old_libs" = no; then oldlibs="$output_objdir/$libname.$libext" build_libtool_libs=module build_old_libs=yes else build_libtool_libs=no fi fi fi fi # Done checking deplibs! deplibs=$newdeplibs fi # All the library-specific variables (install_libdir is set above). library_names= old_library= dlname= # Test again, we may have decided not to build it any more if test "$build_libtool_libs" = yes; then if test $hardcode_into_libs = yes; then # Hardcode the library paths hardcode_libdirs= dep_rpath= rpath="$finalize_rpath" test "$mode" != relink && rpath="$compile_rpath$rpath" for libdir in $rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" dep_rpath="$dep_rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval dep_rpath=\"$hardcode_libdir_flag_spec\" fi if test -n "$runpath_var" && test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done eval "$runpath_var='$rpath\$$runpath_var'; export $runpath_var" fi test -n "$dep_rpath" && deplibs="$dep_rpath $deplibs" fi shlibpath="$finalize_shlibpath" test "$mode" != relink && shlibpath="$compile_shlibpath$shlibpath" if test -n "$shlibpath"; then eval "$shlibpath_var='$shlibpath\$$shlibpath_var'; export $shlibpath_var" fi # Get the real and link names of the library. eval library_names=\"$library_names_spec\" set dummy $library_names realname="$2" shift; shift if test -n "$soname_spec"; then eval soname=\"$soname_spec\" else soname="$realname" fi test -z "$dlname" && dlname=$soname lib="$output_objdir/$realname" for link do linknames="$linknames $link" done # # Ensure that we have .o objects for linkers which dislike .lo # # (e.g. aix) in case we are running --disable-static # for obj in $libobjs; do # xdir=`$echo "X$obj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$obj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$obj" | $Xsed -e 's%^.*/%%'` # oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` # if test ! -f $xdir/$oldobj && test "$baseobj" != "$oldobj"; then # $show "(cd $xdir && ${LN_S} $baseobj $oldobj)" # $run eval '(cd $xdir && ${LN_S} $baseobj $oldobj)' || exit $? # fi # done # Use standard objects if they are pic test -z "$pic_flag" && libobjs=`$echo "X$libobjs" | $SP2NL | $Xsed -e "$lo2o" | $NL2SP` # Prepare the list of exported symbols if test -z "$export_symbols"; then if test "$always_export_symbols" = yes || test -n "$export_symbols_regex"; then $show "generating symbol list for \`$libname.la'" export_symbols="$output_objdir/$libname.exp" $run $rm $export_symbols eval cmds=\"$export_symbols_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" if test -n "$export_symbols_regex"; then $show "egrep -e \"$export_symbols_regex\" \"$export_symbols\" > \"${export_symbols}T\"" $run eval 'egrep -e "$export_symbols_regex" "$export_symbols" > "${export_symbols}T"' $show "$mv \"${export_symbols}T\" \"$export_symbols\"" $run eval '$mv "${export_symbols}T" "$export_symbols"' fi fi fi if test -n "$export_symbols" && test -n "$include_expsyms"; then $run eval '$echo "X$include_expsyms" | $SP2NL >> "$export_symbols"' fi if test -n "$convenience"; then if test -n "$whole_archive_flag_spec"; then save_libobjs=$libobjs eval libobjs=\"\$libobjs $whole_archive_flag_spec\" else gentop="$output_objdir/${outputname}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" for xlib in $convenience; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? libobjs="$libobjs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` done fi fi if test "$thread_safe" = yes && test -n "$thread_safe_flag_spec"; then eval flag=\"$thread_safe_flag_spec\" linker_flags="$linker_flags $flag" fi # Make a backup of the uninstalled library when relinking if test "$mode" = relink; then $run eval '(cd $output_objdir && $rm ${realname}U && $mv $realname ${realname}U)' || exit $? fi # Do each of the archive commands. if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then eval cmds=\"$archive_expsym_cmds\" else eval cmds=\"$archive_cmds\" fi if len=`expr "X$cmds" : ".*"` && test $len -le $max_cmd_len; then : else # The command line is too long to link in one step, link piecewise. $echo "creating reloadable object files..." # Save the value of $output and $libobjs because we want to # use them later. If we have whole_archive_flag_spec, we # want to use save_libobjs as it was before # whole_archive_flag_spec was expanded, because we can't # assume the linker understands whole_archive_flag_spec. # This may have to be revisited, in case too many # convenience libraries get linked in and end up exceeding # the spec. if test -z "$convenience" || test -z "$whole_archive_flag_spec"; then save_libobjs=$libobjs fi save_output=$output # Clear the reloadable object creation command queue and # initialize k to one. test_cmds= concat_cmds= objlist= delfiles= last_robj= k=1 output=$output_objdir/$save_output-${k}.$objext # Loop over the list of objects to be linked. for obj in $save_libobjs do eval test_cmds=\"$reload_cmds $objlist $last_robj\" if test "X$objlist" = X || { len=`expr "X$test_cmds" : ".*"` && test $len -le $max_cmd_len; }; then objlist="$objlist $obj" else # The command $test_cmds is almost too long, add a # command to the queue. if test $k -eq 1 ; then # The first file doesn't have a previous command to add. eval concat_cmds=\"$reload_cmds $objlist $last_robj\" else # All subsequent reloadable object files will link in # the last one created. eval concat_cmds=\"\$concat_cmds~$reload_cmds $objlist $last_robj\" fi last_robj=$output_objdir/$save_output-${k}.$objext k=`expr $k + 1` output=$output_objdir/$save_output-${k}.$objext objlist=$obj len=1 fi done # Handle the remaining objects by creating one last # reloadable object file. All subsequent reloadable object # files will link in the last one created. test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$reload_cmds $objlist $last_robj\" # Set up a command to remove the reloadale object files # after they are used. i=0 while test $i -lt $k do i=`expr $i + 1` delfiles="$delfiles $output_objdir/$save_output-${i}.$objext" done $echo "creating a temporary reloadable object file: $output" # Loop through the commands generated above and execute them. IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $concat_cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" libobjs=$output # Restore the value of output. output=$save_output if test -n "$convenience" && test -n "$whole_archive_flag_spec"; then eval libobjs=\"\$libobjs $whole_archive_flag_spec\" fi # Expand the library linking commands again to reset the # value of $libobjs for piecewise linking. # Do each of the archive commands. if test -n "$export_symbols" && test -n "$archive_expsym_cmds"; then eval cmds=\"$archive_expsym_cmds\" else eval cmds=\"$archive_cmds\" fi # Append the command to remove the reloadable object files # to the just-reset $cmds. eval cmds=\"\$cmds~$rm $delfiles\" fi IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # Restore the uninstalled library and exit if test "$mode" = relink; then $run eval '(cd $output_objdir && $rm ${realname}T && $mv $realname ${realname}T && $mv "$realname"U $realname)' || exit $? exit 0 fi # Create links to the real library. for linkname in $linknames; do if test "$realname" != "$linkname"; then $show "(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)" $run eval '(cd $output_objdir && $rm $linkname && $LN_S $realname $linkname)' || exit $? fi done # If -module or -export-dynamic was specified, set the dlname. if test "$module" = yes || test "$export_dynamic" = yes; then # On all known operating systems, these are identical. dlname="$soname" fi fi ;; obj) if test -n "$deplibs"; then $echo "$modename: warning: \`-l' and \`-L' are ignored for objects" 1>&2 fi if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then $echo "$modename: warning: \`-dlopen' is ignored for objects" 1>&2 fi if test -n "$rpath"; then $echo "$modename: warning: \`-rpath' is ignored for objects" 1>&2 fi if test -n "$xrpath"; then $echo "$modename: warning: \`-R' is ignored for objects" 1>&2 fi if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for objects" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for objects" 1>&2 fi case $output in *.lo) if test -n "$objs$old_deplibs"; then $echo "$modename: cannot build library object \`$output' from non-libtool objects" 1>&2 exit 1 fi libobj="$output" obj=`$echo "X$output" | $Xsed -e "$lo2o"` ;; *) libobj= obj="$output" ;; esac # Delete the old objects. $run $rm $obj $libobj # Objects from convenience libraries. This assumes # single-version convenience libraries. Whenever we create # different ones for PIC/non-PIC, this we'll have to duplicate # the extraction. reload_conv_objs= gentop= # reload_cmds runs $LD directly, so let us get rid of # -Wl from whole_archive_flag_spec wl= if test -n "$convenience"; then if test -n "$whole_archive_flag_spec"; then eval reload_conv_objs=\"\$reload_objs $whole_archive_flag_spec\" else gentop="$output_objdir/${obj}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" for xlib in $convenience; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? reload_conv_objs="$reload_objs "`find $xdir -name \*.$objext -print -o -name \*.lo -print | $NL2SP` done fi fi # Create the old-style object. reload_objs="$objs$old_deplibs "`$echo "X$libobjs" | $SP2NL | $Xsed -e '/\.'${libext}$'/d' -e '/\.lib$/d' -e "$lo2o" | $NL2SP`" $reload_conv_objs" ### testsuite: skip nested quoting test output="$obj" eval cmds=\"$reload_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # Exit if we aren't doing a library object file. if test -z "$libobj"; then if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi exit 0 fi if test "$build_libtool_libs" != yes; then if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi # Create an invalid libtool object if no PIC, so that we don't # accidentally link it into a program. # $show "echo timestamp > $libobj" # $run eval "echo timestamp > $libobj" || exit $? exit 0 fi if test -n "$pic_flag" || test "$pic_mode" != default; then # Only do commands if we really have different PIC objects. reload_objs="$libobjs $reload_conv_objs" output="$libobj" eval cmds=\"$reload_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" # else # # Just create a symlink. # $show $rm $libobj # $run $rm $libobj # xdir=`$echo "X$libobj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$libobj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$libobj" | $Xsed -e 's%^.*/%%'` # oldobj=`$echo "X$baseobj" | $Xsed -e "$lo2o"` # $show "(cd $xdir && $LN_S $oldobj $baseobj)" # $run eval '(cd $xdir && $LN_S $oldobj $baseobj)' || exit $? fi if test -n "$gentop"; then $show "${rm}r $gentop" $run ${rm}r $gentop fi exit 0 ;; prog) case $host in *cygwin*) output=`echo $output | sed -e 's,.exe$,,;s,$,.exe,'` ;; esac if test -n "$vinfo"; then $echo "$modename: warning: \`-version-info' is ignored for programs" 1>&2 fi if test -n "$release"; then $echo "$modename: warning: \`-release' is ignored for programs" 1>&2 fi if test "$preload" = yes; then if test "$dlopen_support" = unknown && test "$dlopen_self" = unknown && test "$dlopen_self_static" = unknown; then $echo "$modename: warning: \`AC_LIBTOOL_DLOPEN' not used. Assuming no dlopen support." fi fi case $host in *-*-rhapsody* | *-*-darwin1.[012]) # On Rhapsody replace the C library is the System framework compile_deplibs=`$echo "X $compile_deplibs" | $Xsed -e 's/ -lc / -framework System /'` finalize_deplibs=`$echo "X $finalize_deplibs" | $Xsed -e 's/ -lc / -framework System /'` ;; esac compile_command="$compile_command $compile_deplibs" finalize_command="$finalize_command $finalize_deplibs" if test -n "$rpath$xrpath"; then # If the user specified any rpath flags, then add them. for libdir in $rpath $xrpath; do # This is the magic to use -rpath. case "$finalize_rpath " in *" $libdir "*) ;; *) finalize_rpath="$finalize_rpath $libdir" ;; esac done fi # Now hardcode the library paths rpath= hardcode_libdirs= for libdir in $compile_rpath $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$perm_rpath " in *" $libdir "*) ;; *) perm_rpath="$perm_rpath $libdir" ;; esac fi case $host in *-*-cygwin* | *-*-mingw* | *-*-pw32* | *-*-os2*) case :$dllsearchpath: in *":$libdir:"*) ;; *) dllsearchpath="$dllsearchpath:$libdir";; esac ;; esac done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi compile_rpath="$rpath" rpath= hardcode_libdirs= for libdir in $finalize_rpath; do if test -n "$hardcode_libdir_flag_spec"; then if test -n "$hardcode_libdir_separator"; then if test -z "$hardcode_libdirs"; then hardcode_libdirs="$libdir" else # Just accumulate the unique libdirs. case $hardcode_libdir_separator$hardcode_libdirs$hardcode_libdir_separator in *"$hardcode_libdir_separator$libdir$hardcode_libdir_separator"*) ;; *) hardcode_libdirs="$hardcode_libdirs$hardcode_libdir_separator$libdir" ;; esac fi else eval flag=\"$hardcode_libdir_flag_spec\" rpath="$rpath $flag" fi elif test -n "$runpath_var"; then case "$finalize_perm_rpath " in *" $libdir "*) ;; *) finalize_perm_rpath="$finalize_perm_rpath $libdir" ;; esac fi done # Substitute the hardcoded libdirs into the rpath. if test -n "$hardcode_libdir_separator" && test -n "$hardcode_libdirs"; then libdir="$hardcode_libdirs" eval rpath=\" $hardcode_libdir_flag_spec\" fi finalize_rpath="$rpath" dlsyms= if test -n "$dlfiles$dlprefiles" || test "$dlself" != no; then if test -n "$NM" && test -n "$global_symbol_pipe"; then dlsyms="${outputname}S.c" else $echo "$modename: not configured to extract global symbols from dlpreopened files" 1>&2 fi fi if test -n "$dlsyms"; then case $dlsyms in "") ;; *.c) # Discover the nlist of each of the dlfiles. nlist="$output_objdir/${outputname}.nm" $show "$rm $nlist ${nlist}S ${nlist}T" $run $rm "$nlist" "${nlist}S" "${nlist}T" # Parse the name list into a source file. $show "creating $output_objdir/$dlsyms" test -z "$run" && $echo > "$output_objdir/$dlsyms" "\ /* $dlsyms - symbol resolution table for \`$outputname' dlsym emulation. */ /* Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP */ #ifdef __cplusplus extern \"C\" { #endif /* Prevent the only kind of declaration conflicts we can make. */ #define lt_preloaded_symbols some_other_symbol /* External symbol declarations for the compiler. */\ " if test "$dlself" = yes; then $show "generating symbol list for \`$output'" test -z "$run" && $echo ': @PROGRAM@ ' > "$nlist" # Add our own program objects to the symbol list. progfiles="$objs$old_deplibs" for arg in $progfiles; do $show "extracting global C symbols from \`$arg'" $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" done if test -n "$exclude_expsyms"; then $run eval 'egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T' $run eval '$mv "$nlist"T "$nlist"' fi if test -n "$export_symbols_regex"; then $run eval 'egrep -e "$export_symbols_regex" "$nlist" > "$nlist"T' $run eval '$mv "$nlist"T "$nlist"' fi # Prepare the list of exported symbols if test -z "$export_symbols"; then export_symbols="$output_objdir/$output.exp" $run $rm $export_symbols $run eval "sed -n -e '/^: @PROGRAM@$/d' -e 's/^.* \(.*\)$/\1/p' "'< "$nlist" > "$export_symbols"' else $run eval "sed -e 's/\([][.*^$]\)/\\\1/g' -e 's/^/ /' -e 's/$/$/'"' < "$export_symbols" > "$output_objdir/$output.exp"' $run eval 'grep -f "$output_objdir/$output.exp" < "$nlist" > "$nlist"T' $run eval 'mv "$nlist"T "$nlist"' fi fi for arg in $dlprefiles; do $show "extracting global C symbols from \`$arg'" name=`echo "$arg" | sed -e 's%^.*/%%'` $run eval 'echo ": $name " >> "$nlist"' $run eval "$NM $arg | $global_symbol_pipe >> '$nlist'" done if test -z "$run"; then # Make sure we have at least an empty file. test -f "$nlist" || : > "$nlist" if test -n "$exclude_expsyms"; then egrep -v " ($exclude_expsyms)$" "$nlist" > "$nlist"T $mv "$nlist"T "$nlist" fi # Try sorting and uniquifying the output. if grep -v "^: " < "$nlist" | sort +2 | uniq > "$nlist"S; then : else grep -v "^: " < "$nlist" > "$nlist"S fi if test -f "$nlist"S; then eval "$global_symbol_to_cdecl"' < "$nlist"S >> "$output_objdir/$dlsyms"' else echo '/* NONE */' >> "$output_objdir/$dlsyms" fi $echo >> "$output_objdir/$dlsyms" "\ #undef lt_preloaded_symbols #if defined (__STDC__) && __STDC__ # define lt_ptr_t void * #else # define lt_ptr_t char * # define const #endif /* The mapping between symbol names and symbols. */ const struct { const char *name; lt_ptr_t address; } lt_preloaded_symbols[] = {\ " sed -n -e 's/^: \([^ ]*\) $/ {\"\1\", (lt_ptr_t) 0},/p' \ -e 's/^. \([^ ]*\) \([^ ]*\)$/ {"\2", (lt_ptr_t) \&\2},/p' \ < "$nlist" >> "$output_objdir/$dlsyms" $echo >> "$output_objdir/$dlsyms" "\ {0, (lt_ptr_t) 0} }; /* This works around a problem in FreeBSD linker */ #ifdef FREEBSD_WORKAROUND static const void *lt_preloaded_setup() { return lt_preloaded_symbols; } #endif #ifdef __cplusplus } #endif\ " fi pic_flag_for_symtable= case $host in # compiling the symbol table file with pic_flag works around # a FreeBSD bug that causes programs to crash when -lm is # linked before any other PIC object. But we must not use # pic_flag when linking with -static. The problem exists in # FreeBSD 2.2.6 and is fixed in FreeBSD 3.1. *-*-freebsd2*|*-*-freebsd3.0*|*-*-freebsdelf3.0*) case "$compile_command " in *" -static "*) ;; *) pic_flag_for_symtable=" $pic_flag -DFREEBSD_WORKAROUND";; esac;; *-*-hpux*) case "$compile_command " in *" -static "*) ;; *) pic_flag_for_symtable=" $pic_flag";; esac esac # Now compile the dynamic symbol file. $show "(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable \"$dlsyms\")" $run eval '(cd $output_objdir && $LTCC -c$no_builtin_flag$pic_flag_for_symtable "$dlsyms")' || exit $? # Clean up the generated files. $show "$rm $output_objdir/$dlsyms $nlist ${nlist}S ${nlist}T" $run $rm "$output_objdir/$dlsyms" "$nlist" "${nlist}S" "${nlist}T" # Transform the symbol file into the correct name. compile_command=`$echo "X$compile_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` finalize_command=`$echo "X$finalize_command" | $Xsed -e "s%@SYMFILE@%$output_objdir/${outputname}S.${objext}%"` ;; *) $echo "$modename: unknown suffix for \`$dlsyms'" 1>&2 exit 1 ;; esac else # We keep going just in case the user didn't refer to # lt_preloaded_symbols. The linker will fail if global_symbol_pipe # really was required. # Nullify the symbol file. compile_command=`$echo "X$compile_command" | $Xsed -e "s% @SYMFILE@%%"` finalize_command=`$echo "X$finalize_command" | $Xsed -e "s% @SYMFILE@%%"` fi if test $need_relink = no || test "$build_libtool_libs" != yes; then # Replace the output file specification. compile_command=`$echo "X$compile_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` link_command="$compile_command$compile_rpath" # We have no uninstalled library dependencies, so finalize right now. $show "$link_command" $run eval "$link_command" status=$? # Delete the generated files. if test -n "$dlsyms"; then $show "$rm $output_objdir/${outputname}S.${objext}" $run $rm "$output_objdir/${outputname}S.${objext}" fi exit $status fi if test -n "$shlibpath_var"; then # We should set the shlibpath_var rpath= for dir in $temp_rpath; do case $dir in [\\/]* | [A-Za-z]:[\\/]*) # Absolute path. rpath="$rpath$dir:" ;; *) # Relative path: add a thisdir entry. rpath="$rpath\$thisdir/$dir:" ;; esac done temp_rpath="$rpath" fi if test -n "$compile_shlibpath$finalize_shlibpath"; then compile_command="$shlibpath_var=\"$compile_shlibpath$finalize_shlibpath\$$shlibpath_var\" $compile_command" fi if test -n "$finalize_shlibpath"; then finalize_command="$shlibpath_var=\"$finalize_shlibpath\$$shlibpath_var\" $finalize_command" fi compile_var= finalize_var= if test -n "$runpath_var"; then if test -n "$perm_rpath"; then # We should set the runpath_var. rpath= for dir in $perm_rpath; do rpath="$rpath$dir:" done compile_var="$runpath_var=\"$rpath\$$runpath_var\" " fi if test -n "$finalize_perm_rpath"; then # We should set the runpath_var. rpath= for dir in $finalize_perm_rpath; do rpath="$rpath$dir:" done finalize_var="$runpath_var=\"$rpath\$$runpath_var\" " fi fi if test "$no_install" = yes; then # We don't need to create a wrapper script. link_command="$compile_var$compile_command$compile_rpath" # Replace the output file specification. link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output"'%g'` # Delete the old output file. $run $rm $output # Link the executable and exit $show "$link_command" $run eval "$link_command" || exit $? exit 0 fi if test "$hardcode_action" = relink; then # Fast installation is not supported link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" $echo "$modename: warning: this platform does not like uninstalled shared libraries" 1>&2 $echo "$modename: \`$output' will be relinked during installation" 1>&2 else if test "$fast_install" != no; then link_command="$finalize_var$compile_command$finalize_rpath" if test "$fast_install" = yes; then relink_command=`$echo "X$compile_var$compile_command$compile_rpath" | $Xsed -e 's%@OUTPUT@%\$progdir/\$file%g'` else # fast_install is set to needless relink_command= fi else link_command="$compile_var$compile_command$compile_rpath" relink_command="$finalize_var$finalize_command$finalize_rpath" fi fi # Replace the output file specification. link_command=`$echo "X$link_command" | $Xsed -e 's%@OUTPUT@%'"$output_objdir/$outputname"'%g'` # Delete the old output files. $run $rm $output $output_objdir/$outputname $output_objdir/lt-$outputname $show "$link_command" $run eval "$link_command" || exit $? # Now create the wrapper script. $show "creating $output" # Quote the relink command for shipping. if test -n "$relink_command"; then # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` relink_command="$var=\"$var_value\"; export $var; $relink_command" fi done relink_command="cd `pwd`; $relink_command" relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` fi # Quote $echo for shipping. if test "X$echo" = "X$SHELL $0 --fallback-echo"; then case $0 in [\\/]* | [A-Za-z]:[\\/]*) qecho="$SHELL $0 --fallback-echo";; *) qecho="$SHELL `pwd`/$0 --fallback-echo";; esac qecho=`$echo "X$qecho" | $Xsed -e "$sed_quote_subst"` else qecho=`$echo "X$echo" | $Xsed -e "$sed_quote_subst"` fi # Only actually do things if our run command is non-null. if test -z "$run"; then # win32 will think the script is a binary if it has # a .exe suffix, so we strip it off here. case $output in *.exe) output=`echo $output|sed 's,.exe$,,'` ;; esac # test for cygwin because mv fails w/o .exe extensions case $host in *cygwin*) exeext=.exe ;; *) exeext= ;; esac $rm $output trap "$rm $output; exit 1" 1 2 15 $echo > $output "\ #! $SHELL # $output - temporary wrapper script for $objdir/$outputname # Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP # # The $output program cannot be directly executed until all the libtool # libraries that it depends on are installed. # # This wrapper script should never be moved out of the build directory. # If it is, it will not operate correctly. # Sed substitution that helps us do robust quoting. It backslashifies # metacharacters that are still active within double-quoted strings. Xsed='sed -e 1s/^X//' sed_quote_subst='$sed_quote_subst' # The HP-UX ksh and POSIX shell print the target directory to stdout # if CDPATH is set. if test \"\${CDPATH+set}\" = set; then CDPATH=:; export CDPATH; fi relink_command=\"$relink_command > /dev/null 2>&1\" # This environment variable determines our operation mode. if test \"\$libtool_install_magic\" = \"$magic\"; then # install mode needs the following variable: notinst_deplibs='$notinst_deplibs' else # When we are sourced in execute mode, \$file and \$echo are already set. if test \"\$libtool_execute_magic\" != \"$magic\"; then echo=\"$qecho\" file=\"\$0\" # Make sure echo works. if test \"X\$1\" = X--no-reexec; then # Discard the --no-reexec flag, and continue. shift elif test \"X\`(\$echo '\t') 2>/dev/null\`\" = 'X\t'; then # Yippee, \$echo works! : else # Restart under the correct shell, and then maybe \$echo will work. exec $SHELL \"\$0\" --no-reexec \${1+\"\$@\"} fi fi\ " $echo >> $output "\ # Find the directory that this script lives in. thisdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*$%%'\` test \"x\$thisdir\" = \"x\$file\" && thisdir=. # Follow symbolic links until we get to the real thisdir. file=\`ls -ld \"\$file\" | sed -n 's/.*-> //p'\` while test -n \"\$file\"; do destdir=\`\$echo \"X\$file\" | \$Xsed -e 's%/[^/]*\$%%'\` # If there was a directory component, then change thisdir. if test \"x\$destdir\" != \"x\$file\"; then case \"\$destdir\" in [\\\\/]* | [A-Za-z]:[\\\\/]*) thisdir=\"\$destdir\" ;; *) thisdir=\"\$thisdir/\$destdir\" ;; esac fi file=\`\$echo \"X\$file\" | \$Xsed -e 's%^.*/%%'\` file=\`ls -ld \"\$thisdir/\$file\" | sed -n 's/.*-> //p'\` done # Try to get the absolute directory name. absdir=\`cd \"\$thisdir\" && pwd\` test -n \"\$absdir\" && thisdir=\"\$absdir\" " if test "$fast_install" = yes; then echo >> $output "\ program=lt-'$outputname'$exeext progdir=\"\$thisdir/$objdir\" if test ! -f \"\$progdir/\$program\" || \\ { file=\`ls -1dt \"\$progdir/\$program\" \"\$progdir/../\$program\" 2>/dev/null | sed 1q\`; \\ test \"X\$file\" != \"X\$progdir/\$program\"; }; then file=\"\$\$-\$program\" if test ! -d \"\$progdir\"; then $mkdir \"\$progdir\" else $rm \"\$progdir/\$file\" fi" echo >> $output "\ # relink executable if necessary if test -n \"\$relink_command\"; then if relink_command_output=\`eval \$relink_command 2>&1\`; then : else $echo \"\$relink_command_output\" >&2 $rm \"\$progdir/\$file\" exit 1 fi fi $mv \"\$progdir/\$file\" \"\$progdir/\$program\" 2>/dev/null || { $rm \"\$progdir/\$program\"; $mv \"\$progdir/\$file\" \"\$progdir/\$program\"; } $rm \"\$progdir/\$file\" fi" else echo >> $output "\ program='$outputname' progdir=\"\$thisdir/$objdir\" " fi echo >> $output "\ if test -f \"\$progdir/\$program\"; then" # Export our shlibpath_var if we have one. if test "$shlibpath_overrides_runpath" = yes && test -n "$shlibpath_var" && test -n "$temp_rpath"; then $echo >> $output "\ # Add our own library path to $shlibpath_var $shlibpath_var=\"$temp_rpath\$$shlibpath_var\" # Some systems cannot cope with colon-terminated $shlibpath_var # The second colon is a workaround for a bug in BeOS R4 sed $shlibpath_var=\`\$echo \"X\$$shlibpath_var\" | \$Xsed -e 's/::*\$//'\` export $shlibpath_var " fi # fixup the dll searchpath if we need to. if test -n "$dllsearchpath"; then $echo >> $output "\ # Add the dll search path components to the executable PATH PATH=$dllsearchpath:\$PATH " fi $echo >> $output "\ if test \"\$libtool_execute_magic\" != \"$magic\"; then # Run the actual program with our arguments. " case $host in # win32 systems need to use the prog path for dll # lookup to work *-*-cygwin* | *-*-pw32*) $echo >> $output "\ exec \$progdir/\$program \${1+\"\$@\"} " ;; # Backslashes separate directories on plain windows *-*-mingw | *-*-os2*) $echo >> $output "\ exec \$progdir\\\\\$program \${1+\"\$@\"} " ;; *) $echo >> $output "\ # Export the path to the program. PATH=\"\$progdir:\$PATH\" export PATH exec \$program \${1+\"\$@\"} " ;; esac $echo >> $output "\ \$echo \"\$0: cannot exec \$program \${1+\"\$@\"}\" exit 1 fi else # The program doesn't exist. \$echo \"\$0: error: \$progdir/\$program does not exist\" 1>&2 \$echo \"This script is just a wrapper for \$program.\" 1>&2 echo \"See the $PACKAGE documentation for more information.\" 1>&2 exit 1 fi fi\ " chmod +x $output fi exit 0 ;; esac # See if we need to build an old-fashioned archive. for oldlib in $oldlibs; do if test "$build_libtool_libs" = convenience; then oldobjs="$libobjs_save" addlibs="$convenience" build_libtool_libs=no else if test "$build_libtool_libs" = module; then oldobjs="$libobjs_save" build_libtool_libs=no else oldobjs="$objs$old_deplibs $non_pic_objects" fi addlibs="$old_convenience" fi if test -n "$addlibs"; then gentop="$output_objdir/${outputname}x" $show "${rm}r $gentop" $run ${rm}r "$gentop" $show "$mkdir $gentop" $run $mkdir "$gentop" status=$? if test $status -ne 0 && test ! -d "$gentop"; then exit $status fi generated="$generated $gentop" # Add in members from convenience archives. for xlib in $addlibs; do # Extract the objects. case $xlib in [\\/]* | [A-Za-z]:[\\/]*) xabs="$xlib" ;; *) xabs=`pwd`"/$xlib" ;; esac xlib=`$echo "X$xlib" | $Xsed -e 's%^.*/%%'` xdir="$gentop/$xlib" $show "${rm}r $xdir" $run ${rm}r "$xdir" $show "$mkdir $xdir" $run $mkdir "$xdir" status=$? if test $status -ne 0 && test ! -d "$xdir"; then exit $status fi $show "(cd $xdir && $AR x $xabs)" $run eval "(cd \$xdir && $AR x \$xabs)" || exit $? oldobjs="$oldobjs "`find $xdir -name \*.${objext} -print | $NL2SP` done fi # Do each command in the archive commands. if test -n "$old_archive_from_new_cmds" && test "$build_libtool_libs" = yes; then eval cmds=\"$old_archive_from_new_cmds\" else # # Ensure that we have .o objects in place in case we decided # # not to build a shared library, and have fallen back to building # # static libs even though --disable-static was passed! # for oldobj in $oldobjs; do # if test ! -f $oldobj; then # xdir=`$echo "X$oldobj" | $Xsed -e 's%/[^/]*$%%'` # if test "X$xdir" = "X$oldobj"; then # xdir="." # else # xdir="$xdir" # fi # baseobj=`$echo "X$oldobj" | $Xsed -e 's%^.*/%%'` # obj=`$echo "X$baseobj" | $Xsed -e "$o2lo"` # $show "(cd $xdir && ${LN_S} $obj $baseobj)" # $run eval '(cd $xdir && ${LN_S} $obj $baseobj)' || exit $? # fi # done eval cmds=\"$old_archive_cmds\" if len=`expr "X$cmds" : ".*"` && test $len -le $max_cmd_len; then : else # the command line is too long to link in one step, link in parts $echo "using piecewise archive linking..." save_RANLIB=$RANLIB RANLIB=: objlist= concat_cmds= save_oldobjs=$oldobjs for obj in $save_oldobjs do oldobjs="$objlist $obj" objlist="$objlist $obj" eval test_cmds=\"$old_archive_cmds\" if len=`expr "X$test_cmds" : ".*"` && test $len -le $max_cmd_len; then : else # the above command should be used before it gets too long oldobjs=$objlist test -z "$concat_cmds" || concat_cmds=$concat_cmds~ eval concat_cmds=\"\${concat_cmds}$old_archive_cmds\" objlist= fi done RANLIB=$save_RANLIB oldobjs=$objlist eval cmds=\"\$concat_cmds~$old_archive_cmds\" fi fi IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" done if test -n "$generated"; then $show "${rm}r$generated" $run ${rm}r$generated fi # Now create the libtool archive. case $output in *.la) old_library= test "$build_old_libs" = yes && old_library="$libname.$libext" $show "creating $output" # Preserve any variables that may affect compiler behavior for var in $variables_saved_for_relink; do if eval test -z \"\${$var+set}\"; then relink_command="{ test -z \"\${$var+set}\" || unset $var || { $var=; export $var; }; }; $relink_command" elif eval var_value=\$$var; test -z "$var_value"; then relink_command="$var=; export $var; $relink_command" else var_value=`$echo "X$var_value" | $Xsed -e "$sed_quote_subst"` relink_command="$var=\"$var_value\"; export $var; $relink_command" fi done # Quote the link command for shipping. tagopts= for tag in $taglist; do tagopts="$tagopts --tag $tag" done relink_command="(cd `pwd`; $SHELL $0$tagopts --mode=relink $libtool_args)" relink_command=`$echo "X$relink_command" | $Xsed -e "$sed_quote_subst"` # Only create the output if not a dry run. if test -z "$run"; then for installed in no yes; do if test "$installed" = yes; then if test -z "$install_libdir"; then break fi output="$output_objdir/$outputname"i # Replace all uninstalled libtool libraries with the installed ones newdependency_libs= for deplib in $dependency_libs; do case $deplib in *.la) name=`$echo "X$deplib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $deplib` if test -z "$libdir"; then $echo "$modename: \`$deplib' is not a valid libtool archive" 1>&2 exit 1 fi newdependency_libs="$newdependency_libs $libdir/$name" ;; *) newdependency_libs="$newdependency_libs $deplib" ;; esac done dependency_libs="$newdependency_libs" newdlfiles= for lib in $dlfiles; do name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` if test -z "$libdir"; then $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi newdlfiles="$newdlfiles $libdir/$name" done dlfiles="$newdlfiles" newdlprefiles= for lib in $dlprefiles; do name=`$echo "X$lib" | $Xsed -e 's%^.*/%%'` eval libdir=`sed -n -e 's/^libdir=\(.*\)$/\1/p' $lib` if test -z "$libdir"; then $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 exit 1 fi newdlprefiles="$newdlprefiles $libdir/$name" done dlprefiles="$newdlprefiles" fi $rm $output # place dlname in correct position for cygwin tdlname=$dlname case $host,$output,$installed,$module,$dlname in *cygwin*,*lai,yes,no,*.dll) tdlname=../bin/$dlname ;; esac $echo > $output "\ # $outputname - a libtool library file # Generated by $PROGRAM - GNU $PACKAGE $VERSION$TIMESTAMP # # Please DO NOT delete this file! # It is necessary for linking the library. # The name that we can dlopen(3). dlname='$tdlname' # Names of this library. library_names='$library_names' # The name of the static archive. old_library='$old_library' # Libraries that this one depends upon. dependency_libs='$dependency_libs' # Version information for $libname. current=$current age=$age revision=$revision # Is this an already installed library? installed=$installed # Files to dlopen/dlpreopen dlopen='$dlfiles' dlpreopen='$dlprefiles' # Directory that this library needs to be installed in: libdir='$install_libdir'" if test "$installed" = no && test $need_relink = yes; then $echo >> $output "\ relink_command=\"$relink_command\"" fi done fi # Do a symbolic link so that the libtool archive can be found in # LD_LIBRARY_PATH before the program is installed. $show "(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)" $run eval '(cd $output_objdir && $rm $outputname && $LN_S ../$outputname $outputname)' || exit $? ;; esac exit 0 ;; # libtool install mode install) modename="$modename: install" # There may be an optional sh(1) argument at the beginning of # install_prog (especially on Windows NT). if test "$nonopt" = "$SHELL" || test "$nonopt" = /bin/sh || # Allow the use of GNU shtool's install command. $echo "X$nonopt" | $Xsed | grep shtool > /dev/null; then # Aesthetically quote it. arg=`$echo "X$nonopt" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$arg " arg="$1" shift else install_prog= arg="$nonopt" fi # The real first argument should be the name of the installation program. # Aesthetically quote it. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$install_prog$arg" # We need to accept at least all the BSD install flags. dest= files= opts= prev= install_type= isdir=no stripme= for arg do if test -n "$dest"; then files="$files $dest" dest="$arg" continue fi case $arg in -d) isdir=yes ;; -f) prev="-f" ;; -g) prev="-g" ;; -m) prev="-m" ;; -o) prev="-o" ;; -s) stripme=" -s" continue ;; -*) ;; *) # If the previous option needed an argument, then skip it. if test -n "$prev"; then prev= else dest="$arg" continue fi ;; esac # Aesthetically quote the argument. arg=`$echo "X$arg" | $Xsed -e "$sed_quote_subst"` case $arg in *[\[\~\#\^\&\*\(\)\{\}\|\;\<\>\?\'\ \ ]*|*]*) arg="\"$arg\"" ;; esac install_prog="$install_prog $arg" done if test -z "$install_prog"; then $echo "$modename: you must specify an install program" 1>&2 $echo "$help" 1>&2 exit 1 fi if test -n "$prev"; then $echo "$modename: the \`$prev' option requires an argument" 1>&2 $echo "$help" 1>&2 exit 1 fi if test -z "$files"; then if test -z "$dest"; then $echo "$modename: no file or destination specified" 1>&2 else $echo "$modename: you must specify a destination" 1>&2 fi $echo "$help" 1>&2 exit 1 fi # Strip any trailing slash from the destination. dest=`$echo "X$dest" | $Xsed -e 's%/$%%'` # Check to see that the destination is a directory. test -d "$dest" && isdir=yes if test "$isdir" = yes; then destdir="$dest" destname= else destdir=`$echo "X$dest" | $Xsed -e 's%/[^/]*$%%'` test "X$destdir" = "X$dest" && destdir=. destname=`$echo "X$dest" | $Xsed -e 's%^.*/%%'` # Not a directory, so check to see that there is only one file specified. set dummy $files if test $# -gt 2; then $echo "$modename: \`$dest' is not a directory" 1>&2 $echo "$help" 1>&2 exit 1 fi fi case $destdir in [\\/]* | [A-Za-z]:[\\/]*) ;; *) for file in $files; do case $file in *.lo) ;; *) $echo "$modename: \`$destdir' must be an absolute directory name" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac done ;; esac # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" staticlibs= future_libdirs= current_libdirs= for file in $files; do # Do each installation. case $file in *.$libext) # Do the static libraries later. staticlibs="$staticlibs $file" ;; *.la) # Check to see that this really is a libtool archive. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$file' is not a valid libtool archive" 1>&2 $echo "$help" 1>&2 exit 1 fi library_names= old_library= relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Add the libdir to current_libdirs if it is the destination. if test "X$destdir" = "X$libdir"; then case "$current_libdirs " in *" $libdir "*) ;; *) current_libdirs="$current_libdirs $libdir" ;; esac else # Note the libdir as a future libdir. case "$future_libdirs " in *" $libdir "*) ;; *) future_libdirs="$future_libdirs $libdir" ;; esac fi dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'`/ test "X$dir" = "X$file/" && dir= dir="$dir$objdir" if test -n "$relink_command"; then $echo "$modename: warning: relinking \`$file'" 1>&2 $show "$relink_command" if $run eval "$relink_command"; then : else $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 exit 1 fi fi # See the names of the shared library. set dummy $library_names if test -n "$2"; then realname="$2" shift shift srcname="$realname" test -n "$relink_command" && srcname="$realname"T # Install the shared library and build the symlinks. $show "$install_prog $dir/$srcname $destdir/$realname" $run eval "$install_prog $dir/$srcname $destdir/$realname" || exit $? if test -n "$stripme" && test -n "$striplib"; then $show "$striplib $destdir/$realname" $run eval "$striplib $destdir/$realname" || exit $? fi if test $# -gt 0; then # Delete the old symlinks, and create new ones. for linkname do if test "$linkname" != "$realname"; then $show "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" $run eval "(cd $destdir && $rm $linkname && $LN_S $realname $linkname)" fi done fi # Do each command in the postinstall commands. lib="$destdir/$realname" eval cmds=\"$postinstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" fi # Install the pseudo-library for information purposes. name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` instname="$dir/$name"i $show "$install_prog $instname $destdir/$name" $run eval "$install_prog $instname $destdir/$name" || exit $? # Maybe install the static library, too. test -n "$old_library" && staticlibs="$staticlibs $dir/$old_library" ;; *.lo) # Install (i.e. copy) a libtool object. # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` destfile="$destdir/$destfile" fi # Deduce the name of the destination old-style object file. case $destfile in *.lo) staticdest=`$echo "X$destfile" | $Xsed -e "$lo2o"` ;; *.$objext) staticdest="$destfile" destfile= ;; *) $echo "$modename: cannot copy a libtool object to \`$destfile'" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac # Install the libtool object if requested. if test -n "$destfile"; then $show "$install_prog $file $destfile" $run eval "$install_prog $file $destfile" || exit $? fi # Install the old object if enabled. if test "$build_old_libs" = yes; then # Deduce the name of the old-style object file. staticobj=`$echo "X$file" | $Xsed -e "$lo2o"` $show "$install_prog $staticobj $staticdest" $run eval "$install_prog \$staticobj \$staticdest" || exit $? fi exit 0 ;; *) # Figure out destination file name, if it wasn't already specified. if test -n "$destname"; then destfile="$destdir/$destname" else destfile=`$echo "X$file" | $Xsed -e 's%^.*/%%'` destfile="$destdir/$destfile" fi # Do a test to see if this is really a libtool program. if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then notinst_deplibs= relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Check the variables that should have been set. if test -z "$notinst_deplibs"; then $echo "$modename: invalid libtool wrapper script \`$file'" 1>&2 exit 1 fi finalize=yes for lib in $notinst_deplibs; do # Check to see that each library is installed. libdir= if test -f "$lib"; then # If there is no directory component, then add one. case $lib in */* | *\\*) . $lib ;; *) . ./$lib ;; esac fi libfile="$libdir/"`$echo "X$lib" | $Xsed -e 's%^.*/%%g'` ### testsuite: skip nested quoting test if test -n "$libdir" && test ! -f "$libfile"; then $echo "$modename: warning: \`$lib' has not been installed in \`$libdir'" 1>&2 finalize=no fi done relink_command= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac outputname= if test "$fast_install" = no && test -n "$relink_command"; then if test "$finalize" = yes && test -z "$run"; then tmpdir="/tmp" test -n "$TMPDIR" && tmpdir="$TMPDIR" tmpdir="$tmpdir/libtool-$$" if $mkdir -p "$tmpdir" && chmod 700 "$tmpdir"; then : else $echo "$modename: error: cannot create temporary directory \`$tmpdir'" 1>&2 continue fi file=`$echo "X$file" | $Xsed -e 's%^.*/%%'` outputname="$tmpdir/$file" # Replace the output file specification. relink_command=`$echo "X$relink_command" | $Xsed -e 's%@OUTPUT@%'"$outputname"'%g'` $show "$relink_command" if $run eval "$relink_command"; then : else $echo "$modename: error: relink \`$file' with the above command before installing it" 1>&2 ${rm}r "$tmpdir" continue fi file="$outputname" else $echo "$modename: warning: cannot relink \`$file'" 1>&2 fi else # Install the binary that we compiled earlier. file=`$echo "X$file" | $Xsed -e "s%\([^/]*\)$%$objdir/\1%"` fi fi # remove .exe since cygwin /usr/bin/install will append another # one anyways case $install_prog,$host in */usr/bin/install*,*cygwin*) case $file:$destfile in *.exe:*.exe) # this is ok ;; *.exe:*) destfile=$destfile.exe ;; *:*.exe) destfile=`echo $destfile | sed -e 's,.exe$,,'` ;; esac ;; esac $show "$install_prog$stripme $file $destfile" $run eval "$install_prog\$stripme \$file \$destfile" || exit $? test -n "$outputname" && ${rm}r "$tmpdir" ;; esac done for file in $staticlibs; do name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` # Set up the ranlib parameters. oldlib="$destdir/$name" $show "$install_prog $file $oldlib" $run eval "$install_prog \$file \$oldlib" || exit $? if test -n "$stripme" && test -n "$striplib"; then $show "$old_striplib $oldlib" $run eval "$old_striplib $oldlib" || exit $? fi # Do each command in the postinstall commands. eval cmds=\"$old_postinstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || exit $? done IFS="$save_ifs" done if test -n "$future_libdirs"; then $echo "$modename: warning: remember to run \`$progname --finish$future_libdirs'" 1>&2 fi if test -n "$current_libdirs"; then # Maybe just do a dry run. test -n "$run" && current_libdirs=" -n$current_libdirs" exec_cmd='$SHELL $0 --finish$current_libdirs' else exit 0 fi ;; # libtool finish mode finish) modename="$modename: finish" libdirs="$nonopt" admincmds= if test -n "$finish_cmds$finish_eval" && test -n "$libdirs"; then for dir do libdirs="$libdirs $dir" done for libdir in $libdirs; do if test -n "$finish_cmds"; then # Do each command in the finish commands. eval cmds=\"$finish_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" || admincmds="$admincmds $cmd" done IFS="$save_ifs" fi if test -n "$finish_eval"; then # Do the single finish_eval. eval cmds=\"$finish_eval\" $run eval "$cmds" || admincmds="$admincmds $cmds" fi done fi # Exit here if they wanted silent mode. test "$show" = ":" && exit 0 echo "----------------------------------------------------------------------" echo "Libraries have been installed in:" for libdir in $libdirs; do echo " $libdir" done echo echo "If you ever happen to want to link against installed libraries" echo "in a given directory, LIBDIR, you must either use libtool, and" echo "specify the full pathname of the library, or use the \`-LLIBDIR'" echo "flag during linking and do at least one of the following:" if test -n "$shlibpath_var"; then echo " - add LIBDIR to the \`$shlibpath_var' environment variable" echo " during execution" fi if test -n "$runpath_var"; then echo " - add LIBDIR to the \`$runpath_var' environment variable" echo " during linking" fi if test -n "$hardcode_libdir_flag_spec"; then libdir=LIBDIR eval flag=\"$hardcode_libdir_flag_spec\" echo " - use the \`$flag' linker flag" fi if test -n "$admincmds"; then echo " - have your system administrator run these commands:$admincmds" fi if test -f /etc/ld.so.conf; then echo " - have your system administrator add LIBDIR to \`/etc/ld.so.conf'" fi echo echo "See any operating system documentation about shared libraries for" echo "more information, such as the ld(1) and ld.so(8) manual pages." echo "----------------------------------------------------------------------" exit 0 ;; # libtool execute mode execute) modename="$modename: execute" # The first argument is the command name. cmd="$nonopt" if test -z "$cmd"; then $echo "$modename: you must specify a COMMAND" 1>&2 $echo "$help" exit 1 fi # Handle -dlopen flags immediately. for file in $execute_dlfiles; do if test ! -f "$file"; then $echo "$modename: \`$file' is not a file" 1>&2 $echo "$help" 1>&2 exit 1 fi dir= case $file in *.la) # Check to see that this really is a libtool archive. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then : else $echo "$modename: \`$lib' is not a valid libtool archive" 1>&2 $echo "$help" 1>&2 exit 1 fi # Read the libtool library. dlname= library_names= # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Skip this library if it cannot be dlopened. if test -z "$dlname"; then # Warn if it was a shared library. test -n "$library_names" && $echo "$modename: warning: \`$file' was not linked with \`-export-dynamic'" continue fi dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$file" && dir=. if test -f "$dir/$objdir/$dlname"; then dir="$dir/$objdir" else $echo "$modename: cannot find \`$dlname' in \`$dir' or \`$dir/$objdir'" 1>&2 exit 1 fi ;; *.lo) # Just add the directory containing the .lo file. dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` test "X$dir" = "X$file" && dir=. ;; *) $echo "$modename: warning \`-dlopen' is ignored for non-libtool libraries and objects" 1>&2 continue ;; esac # Get the absolute pathname. absdir=`cd "$dir" && pwd` test -n "$absdir" && dir="$absdir" # Now add the directory to shlibpath_var. if eval "test -z \"\$$shlibpath_var\""; then eval "$shlibpath_var=\"\$dir\"" else eval "$shlibpath_var=\"\$dir:\$$shlibpath_var\"" fi done # This variable tells wrapper scripts just to set shlibpath_var # rather than running their programs. libtool_execute_magic="$magic" # Check if any of the arguments is a wrapper script. args= for file do case $file in -*) ;; *) # Do a test to see if this is really a libtool program. if (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then # If there is no directory component, then add one. case $file in */* | *\\*) . $file ;; *) . ./$file ;; esac # Transform arg to wrapped name. file="$progdir/$program" fi ;; esac # Quote arguments (to preserve shell metacharacters). file=`$echo "X$file" | $Xsed -e "$sed_quote_subst"` args="$args \"$file\"" done if test -z "$run"; then if test -n "$shlibpath_var"; then # Export the shlibpath_var. eval "export $shlibpath_var" fi # Restore saved enviroment variables if test "${save_LC_ALL+set}" = set; then LC_ALL="$save_LC_ALL"; export LC_ALL fi if test "${save_LANG+set}" = set; then LANG="$save_LANG"; export LANG fi # Now prepare to actually exec the command. exec_cmd='"$cmd"$args' else # Display what would be done. if test -n "$shlibpath_var"; then eval "\$echo \"\$shlibpath_var=\$$shlibpath_var\"" $echo "export $shlibpath_var" fi $echo "$cmd$args" exit 0 fi ;; # libtool clean and uninstall mode clean | uninstall) modename="$modename: $mode" rm="$nonopt" files= rmforce= exit_status=0 # This variable tells wrapper scripts just to set variables rather # than running their programs. libtool_install_magic="$magic" for arg do case $arg in -f) rm="$rm $arg"; rmforce=yes ;; -*) rm="$rm $arg" ;; *) files="$files $arg" ;; esac done if test -z "$rm"; then $echo "$modename: you must specify an RM program" 1>&2 $echo "$help" 1>&2 exit 1 fi rmdirs= for file in $files; do dir=`$echo "X$file" | $Xsed -e 's%/[^/]*$%%'` if test "X$dir" = "X$file"; then dir=. objdir="$objdir" else objdir="$dir/$objdir" fi name=`$echo "X$file" | $Xsed -e 's%^.*/%%'` test $mode = uninstall && objdir="$dir" # Remember objdir for removal later, being careful to avoid duplicates if test $mode = clean; then case " $rmdirs " in *" $objdir "*) ;; *) rmdirs="$rmdirs $objdir" ;; esac fi # Don't error if the file doesn't exist and rm -f was used. if (test -L "$file") >/dev/null 2>&1 \ || (test -h "$file") >/dev/null 2>&1 \ || test -f "$file"; then : elif test -d "$file"; then exit_status=1 continue elif test "$rmforce" = yes; then continue fi rmfiles="$file" case $name in *.la) # Possibly a libtool archive, so verify it. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then . $dir/$name # Delete the libtool libraries and symlinks. for n in $library_names; do rmfiles="$rmfiles $objdir/$n" done test -n "$old_library" && rmfiles="$rmfiles $objdir/$old_library" test $mode = clean && rmfiles="$rmfiles $objdir/$name $objdir/${name}i" if test $mode = uninstall; then if test -n "$library_names"; then # Do each command in the postuninstall commands. eval cmds=\"$postuninstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" if test $? != 0 && test "$rmforce" != yes; then exit_status=1 fi done IFS="$save_ifs" fi if test -n "$old_library"; then # Do each command in the old_postuninstall commands. eval cmds=\"$old_postuninstall_cmds\" IFS="${IFS= }"; save_ifs="$IFS"; IFS='~' for cmd in $cmds; do IFS="$save_ifs" $show "$cmd" $run eval "$cmd" if test $? != 0 && test "$rmforce" != yes; then exit_status=1 fi done IFS="$save_ifs" fi # FIXME: should reinstall the best remaining shared library. fi fi ;; *.lo) # Possibly a libtool object, so verify it. if (sed -e '2q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then # Read the .lo file . $dir/$name # Add PIC object to the list of files to remove. if test -n "$pic_object" \ && test "$pic_object" != none; then rmfiles="$rmfiles $dir/$pic_object" fi # Add non-PIC object to the list of files to remove. if test -n "$non_pic_object" \ && test "$non_pic_object" != none; then rmfiles="$rmfiles $dir/$non_pic_object" fi fi ;; *) # Do a test to see if this is a libtool program. if test $mode = clean && (sed -e '4q' $file | egrep "^# Generated by .*$PACKAGE") >/dev/null 2>&1; then relink_command= . $dir/$file rmfiles="$rmfiles $objdir/$name $objdir/${name}S.${objext}" if test "$fast_install" = yes && test -n "$relink_command"; then rmfiles="$rmfiles $objdir/lt-$name" fi fi ;; esac $show "$rm $rmfiles" $run $rm $rmfiles || exit_status=1 done # Try to remove the ${objdir}s in the directories where we deleted files for dir in $rmdirs; do if test -d "$dir"; then $show "rmdir $dir" $run rmdir $dir >/dev/null 2>&1 fi done exit $exit_status ;; "") $echo "$modename: you must specify a MODE" 1>&2 $echo "$generic_help" 1>&2 exit 1 ;; esac if test -z "$exec_cmd"; then $echo "$modename: invalid operation mode \`$mode'" 1>&2 $echo "$generic_help" 1>&2 exit 1 fi fi # test -z "$show_help" if test -n "$exec_cmd"; then eval exec $exec_cmd exit 1 fi # We need to display help for each of the modes. case $mode in "") $echo \ "Usage: $modename [OPTION]... [MODE-ARG]... Provide generalized library-building support services. --config show all configuration variables --debug enable verbose shell tracing -n, --dry-run display commands without modifying any files --features display basic configuration information and exit --finish same as \`--mode=finish' --help display this help message and exit --mode=MODE use operation mode MODE [default=inferred from MODE-ARGS] --quiet same as \`--silent' --silent don't print informational messages --tag=TAG use configuration variables from tag TAG --version print version information MODE must be one of the following: clean remove files from the build directory compile compile a source file into a libtool object execute automatically set library path, then run a program finish complete the installation of libtool libraries install install libraries or executables link create a library or an executable uninstall remove libraries from an installed directory MODE-ARGS vary depending on the MODE. Try \`$modename --help --mode=MODE' for a more detailed description of MODE." exit 0 ;; clean) $echo \ "Usage: $modename [OPTION]... --mode=clean RM [RM-OPTION]... FILE... Remove files from the build directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, object or program, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; compile) $echo \ "Usage: $modename [OPTION]... --mode=compile COMPILE-COMMAND... SOURCEFILE Compile a source file into a libtool library object. This mode accepts the following additional options: -o OUTPUT-FILE set the output file name to OUTPUT-FILE -prefer-pic try to building PIC objects only -prefer-non-pic try to building non-PIC objects only -static always build a \`.o' file suitable for static linking COMPILE-COMMAND is a command to be used in creating a \`standard' object file from the given SOURCEFILE. The output file name is determined by removing the directory component from SOURCEFILE, then substituting the C source code suffix \`.c' with the library object suffix, \`.lo'." ;; execute) $echo \ "Usage: $modename [OPTION]... --mode=execute COMMAND [ARGS]... Automatically set library path, then run a program. This mode accepts the following additional options: -dlopen FILE add the directory containing FILE to the library path This mode sets the library path environment variable according to \`-dlopen' flags. If any of the ARGS are libtool executable wrappers, then they are translated into their corresponding uninstalled binary, and any of their required library directories are added to the library path. Then, COMMAND is executed, with ARGS as arguments." ;; finish) $echo \ "Usage: $modename [OPTION]... --mode=finish [LIBDIR]... Complete the installation of libtool libraries. Each LIBDIR is a directory that contains libtool libraries. The commands that this mode executes may require superuser privileges. Use the \`--dry-run' option if you just want to see what would be executed." ;; install) $echo \ "Usage: $modename [OPTION]... --mode=install INSTALL-COMMAND... Install executables or libraries. INSTALL-COMMAND is the installation command. The first component should be either the \`install' or \`cp' program. The rest of the components are interpreted as arguments to that command (only BSD-compatible install options are recognized)." ;; link) $echo \ "Usage: $modename [OPTION]... --mode=link LINK-COMMAND... Link object files or libraries together to form another library, or to create an executable program. LINK-COMMAND is a command using the C compiler that you would use to create a program from several object files. The following components of LINK-COMMAND are treated specially: -all-static do not do any dynamic linking at all -avoid-version do not add a version suffix if possible -dlopen FILE \`-dlpreopen' FILE if it cannot be dlopened at runtime -dlpreopen FILE link in FILE and add its symbols to lt_preloaded_symbols -export-dynamic allow symbols from OUTPUT-FILE to be resolved with dlsym(3) -export-symbols SYMFILE try to export only the symbols listed in SYMFILE -export-symbols-regex REGEX try to export only the symbols matching REGEX -LLIBDIR search LIBDIR for required installed libraries -lNAME OUTPUT-FILE requires the installed library libNAME -module build a library that can dlopened -no-fast-install disable the fast-install mode -no-install link a not-installable executable -no-undefined declare that a library does not refer to external symbols -o OUTPUT-FILE create OUTPUT-FILE from the specified objects -objectlist FILE Use a list of object files found in FILE to specify objects -release RELEASE specify package release information -rpath LIBDIR the created library will eventually be installed in LIBDIR -R[ ]LIBDIR add LIBDIR to the runtime path of programs and libraries -static do not do any dynamic linking of libtool libraries -version-info CURRENT[:REVISION[:AGE]] specify library version info [each variable defaults to 0] All other options (arguments beginning with \`-') are ignored. Every other argument is treated as a filename. Files ending in \`.la' are treated as uninstalled libtool libraries, other files are standard or library object files. If the OUTPUT-FILE ends in \`.la', then a libtool library is created, only library objects (\`.lo' files) may be specified, and \`-rpath' is required, except when creating a convenience library. If OUTPUT-FILE ends in \`.a' or \`.lib', then a standard library is created using \`ar' and \`ranlib', or on Windows using \`lib'. If OUTPUT-FILE ends in \`.lo' or \`.${objext}', then a reloadable object file is created, otherwise an executable program is created." ;; uninstall) $echo \ "Usage: $modename [OPTION]... --mode=uninstall RM [RM-OPTION]... FILE... Remove libraries from an installation directory. RM is the name of the program to use to delete files associated with each FILE (typically \`/bin/rm'). RM-OPTIONS are options (such as \`-f') to be passed to RM. If FILE is a libtool library, all the files associated with it are deleted. Otherwise, only FILE itself is deleted using RM." ;; *) $echo "$modename: invalid operation mode \`$mode'" 1>&2 $echo "$help" 1>&2 exit 1 ;; esac echo $echo "Try \`$modename --help' for more information about other modes." exit 0 # The TAGs below are defined such that we never get into a situation # in which we disable both kinds of libraries. Given conflicting # choices, we go for a static library, that is the most portable, # since we can't tell whether shared libraries were disabled because # the user asked for that or because the platform doesn't support # them. This is particularly important on AIX, because we don't # support having both static and shared libraries enabled at the same # time on that platform, so we default to a shared-only configuration. # If a disable-shared tag is given, we'll fallback to a static-only # configuration. But we'll never go from static-only to shared-only. ### BEGIN LIBTOOL TAG CONFIG: disable-shared build_libtool_libs=no build_old_libs=yes ### END LIBTOOL TAG CONFIG: disable-shared ### BEGIN LIBTOOL TAG CONFIG: disable-static build_old_libs=`case $build_libtool_libs in yes) echo no;; *) echo yes;; esac` ### END LIBTOOL TAG CONFIG: disable-static # Local Variables: # mode:shell-script # sh-indentation:2 # End: gcl/windows/0000755000175000017500000000000012240167764011742 5ustar cammcammgcl/windows/instdos.sh0000755000175000017500000000027012240167764013763 0ustar cammcamm#!/bin/sh -ef # Copy a file so that it ends up with dos line endings so that for example, # batch files will run properly under Windows 98. cat $1 | awk '{sub(/$/,"\r");print}' > $2 gcl/windows/install.lsp.in0000644000175000017500000001314212240167764014536 0ustar cammcamm;;; ;;; Help the Windows installer ;;; ;; In the final destination bin directory, make a Bourne shell script ;; to launch GCL. (defun kill-backs ( s ) (let ((pos (search "\\" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (1+ pos)))) (kill-backs (concatenate 'string start "/" finish))) s))) (defun kill-double-forwards ( s ) (let ((pos (search "//" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (+ pos 2)))) (kill-double-forwards (concatenate 'string start "/" finish))) s))) (defun kill-forwards ( s ) (let ((pos (search "/" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (1+ pos)))) (kill-forwards (concatenate 'string start "\\" finish))) s))) (defun kill-double-backs ( s ) (let ((pos (search "\\\\" s))) (if pos (let ((start (subseq s 0 pos)) (finish (subseq s (+ pos 2)))) (kill-double-backs (concatenate 'string start "\\" finish))) s))) (defun split-by-one-fs (string) (loop for i = 0 then (1+ j) as j = (position #\/ string :start i) collect (subseq string i j) while j)) ; Remove dos colon for MSYS and \\ (defun msysarise (s) (if (equal (char s 1) #\:) (kill-double-forwards (kill-backs (concatenate 'string "/" (subseq s 0 1) (subseq s 2)))) (kill-double-forwards (kill-backs s)))) (setq *msys-system-directory* (msysarise *system-directory*)) ;; The following few lines remove the lib/gcl-???/unixport string. ;; Can't do this by simple string substitution as W98 paths are shortened. ;; All depends on path format including end separator. ; Canonicalise directory separators (setq *root-directory* (kill-double-forwards (kill-backs *system-directory*))) ; Remove end dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove unixport and dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *root-directory* (subseq *root-directory* 0 (search "/" *root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *root-directory* (subseq *root-directory* 0 (1+ (search "/" *root-directory* :from-end t)))) ; Canonicalise directory separators (setq *msys-root-directory* (kill-double-forwards (kill-backs *msys-system-directory*))) ; Remove end dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove unixport and dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (search "/" *msys-root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *msys-root-directory* (subseq *msys-root-directory* 0 (1+ (search "/" *msys-root-directory* :from-end t)))) (setq *lib-directory* (format nil "~a~a" *root-directory* "lib/gcl-@VERSION@/")) (setq *h-directory* (format nil "~a~a" *msys-root-directory* "/lib/gcl-@VERSION@/h")) (setq *bin-directory* (format nil "~a~a" *root-directory* "bin/")) (setq gclscript (format nil "~a~a" *bin-directory* "gcl")) (with-open-file (s gclscript :direction :output :if-exists :supersede) (format s "#!/bin/sh~%") (format s "# export C_INCLUDE_PATH=~a~%" *h-directory* ) (format s "export PATH=~a/mingw/bin:~a/lib/gcl-@VERSION@/unixport:${PATH}~%" *msys-root-directory* *msys-root-directory* ) (format s "exec ~a@FLISP@.exe -dir ~a -libdir ~a -eval \"(setq si::*allow-gzipped-file* t)\" \"$@\"" *msys-system-directory* (kill-double-forwards *system-directory*) *lib-directory* )) ; Now make a batch file to launch GCL (setq *dos-system-directory* (kill-double-backs (kill-forwards *system-directory*))) ; Now make a batch file to launch GCL (setq *dos-root-directory* (kill-double-backs (kill-forwards *dos-system-directory*))) ; Remove end dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove unixport and dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove gcl-?.?.? and dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (search "\\" *dos-root-directory* :from-end t))) ; Remove lib but not the dir separator (setq *dos-root-directory* (subseq *dos-root-directory* 0 (1+ (search "\\" *dos-root-directory* :from-end t)))) (setq *dos-h-directory* (format nil "~a~a" *dos-root-directory* "lib\\gcl-@VERSION@\\h")) (setq *dos-bin-directory* (format nil "~a~a" *dos-root-directory* "bin\\")) (setq gclbatch (format nil "~a~a" *bin-directory* "gcl.bat")) ;; Output CRLF line terminated batch file (setf crstr (make-string 1 :initial-element #\Return)) (setf lfstr (make-string 1 :initial-element #\Linefeed)) (defun crlf (s) (format s "~a~a" crstr lfstr)) (with-open-file (s gclbatch :direction :output :if-exists :supersede) (format s "@echo off") (crlf s) (format s "REM set C_INCLUDE_PATH=~a" *dos-h-directory* ) (crlf s) (format s "path ~amingw\\bin;~alib\\gcl-@VERSION@\\unixport;%PATH%" *dos-root-directory* *dos-root-directory* ) (crlf s) (format s "start ~a@FLISP@.exe -dir ~a -libdir ~a -eval \"(setq si::*allow-gzipped-file* t)\" %1 %2 %3 %4 %5 %6 %7 %8 %9" *dos-system-directory* (kill-double-forwards *system-directory*) *lib-directory* ) (crlf s)) (quit) gcl/windows/gcl.iss.in0000644000175000017500000000410512240167764013634 0ustar cammcamm; -*-mode: text; fill-column: 75; tab-width: 8; coding: iso-latin-1-dos -*- ; Script originally generated by the Inno Setup Script Wizard. ; -- $Id$ -- [Setup] AppName=GNU Common Lisp (@CLSTANDARD@ build) AppVerName=GNU Common Lisp @VERSION@ (@CLSTANDARD@ build) AppPublisher=The GNU Common Lisp Development Team AppPublisherURL=http://savannah.gnu.org/projects/gcl/ AppSupportURL=http://savannah.gnu.org/projects/gcl/ AppUpdatesURL=http://savannah.gnu.org/projects/gcl/ AppVersion=@VERSION@ OutputBaseFilename=gcl-@VERSION@-@CLSTANDARD@ DefaultDirName={sd}\Progra~1\GCL-@VERSION@-@CLSTANDARD@ DefaultGroupName=GCL-@VERSION@-@CLSTANDARD@ AllowNoIcons=yes ; AlwaysCreateUninstallIcon=yes LicenseFile=@prefix@\COPYING.LIB-2.0 InfoBeforeFile=@prefix@\readme-bin.mingw Uninstallable=yes UninstallFilesDir={app}\uninst ; uncomment the following line if you want your installation to run on NT 3.51 too. ; MinVersion=4,3.51 [Tasks] Name: "desktopicon"; Description: "Create a &desktop icon"; GroupDescription: "Additional icons:"; MinVersion: 4,4 [Files] Source: "@prefix@\*.*"; DestDir: "{app}\"; Flags: recursesubdirs Source: "c:\lang\MinGW32-gcl\*.*"; DestDir: "{app}\mingw"; Flags: recursesubdirs [Icons] Name: "{group}\GNU Common Lisp @VERSION@ @CLSTANDARD@"; Filename: "{app}\bin\gcl.bat"; IconFilename: "{app}\bin\gcl.ico" Name: "{group}\GCL System Manual"; Filename: "{app}\lib\gcl-@VERSION@\doc\gcl-si\index.html" Name: "{group}\Common Lisp HyperSpec"; Filename: "{app}\lib\gcl-@VERSION@\doc\gcl\index.html" Name: "{userdesktop}\GNU Common Lisp"; Filename: "{app}\bin\gcl.bat"; MinVersion: 4,4; Tasks: desktopicon; IconFilename: "{app}\bin\gcl.ico" [Run] Filename: "{app}\bin\sysdir.bat"; Parameters: "{app}\lib\gcl-@VERSION@\unixport\" Filename: "{app}\lib\gcl-@VERSION@\unixport\@FLISP@.exe"; Parameters: -load {app}/install/install.lsp Filename: "{app}\bin\gcl.bat"; Description: "Launch GNU Common Lisp"; Flags: postinstall skipifsilent [UninstallDelete] Type: files; Name: "{app}\bin\gcl.bat" Type: files; Name: "{app}\bin\gcl" Type: files; Name: "{app}\lib\gcl-@VERSION@\unixport\@FLISP@_orig.exe" gcl/windows/sysdir.bat.in0000644000175000017500000000033612240167764014356 0ustar cammcammcd %1 echo (setq si::*system-directory* (namestring(truename (make-pathname :name nil :type nil :defaults (si::argv 0))))) (si::save-system "modified.exe") | @FLISP@.exe del @FLISP@.exe ren modified.exe @FLISP@.exe pause gcl/pcl/0000755000175000017500000000000012240167764011026 5ustar cammcammgcl/pcl/gcl_pcl_cache.lisp0000644000175000017500000016430212240167764014453 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; (in-package :pcl) ;;; ;;; The caching algorithm implemented: ;;; ;;; << put a paper here >> ;;; ;;; For now, understand that as far as most of this code goes, a cache has ;;; two important properties. The first is the number of wrappers used as ;;; keys in each cache line. Throughout this code, this value is always ;;; called NKEYS. The second is whether or not the cache lines of a cache ;;; store a value. Throughout this code, this always called VALUEP. ;;; ;;; Depending on these values, there are three kinds of caches. ;;; ;;; NKEYS = 1, VALUEP = NIL ;;; ;;; In this kind of cache, each line is 1 word long. No cache locking is ;;; needed since all read's in the cache are a single value. Nevertheless ;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will ;;; not get a first probe hit. ;;; ;;; To keep the code simpler, a cache lock count does appear in location 0 ;;; of these caches, that count is incremented whenever data is written to ;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to ;;; do locking when reading the cache. ;;; ;;; ;;; NKEYS = 1, VALUEP = T ;;; ;;; In this kind of cache, each line is 2 words long. Cache locking must ;;; be done to ensure the synchronization of cache reads. Line 0 of the ;;; cache (location 0) is reserved for the cache lock count. Location 1 ;;; of the cache is unused (in effect wasted). ;;; ;;; NKEYS > 1 ;;; ;;; In this kind of cache, the 0 word of the cache holds the lock count. ;;; The 1 word of the cache is line 0. Line 0 of these caches is not ;;; reserved. ;;; ;;; This is done because in this sort of cache, the overhead of doing the ;;; cache probe is high enough that the 1+ required to offset the location ;;; is not a significant cost. In addition, because of the larger line ;;; sizes, the space that would be wasted by reserving line 0 to hold the ;;; lock count is more significant. ;;; ;;; ;;; Caches ;;; ;;; A cache is essentially just a vector. The use of the individual `words' ;;; in the vector depends on particular properties of the cache as described ;;; above. ;;; ;;; This defines an abstraction for caches in terms of their most obvious ;;; implementation as simple vectors. But, please notice that part of the ;;; implementation of this abstraction, is the function lap-out-cache-ref. ;;; This means that most port-specific modifications to the implementation ;;; of caches will require corresponding port-specific modifications to the ;;; lap code assembler. ;;; ;; #+gcl(import 'si::non-negative-fixnum) (defmacro cache-vector-ref (cache-vector location) `(svref (the simple-vector ,cache-vector) (#-cmu the #+cmu ext:truly-the non-negative-fixnum ,location))) (defmacro cache-vector-size (cache-vector) `(array-dimension (the simple-vector ,cache-vector) 0)) (defun allocate-cache-vector (size) (make-array size :adjustable nil)) (defmacro cache-vector-lock-count (cache-vector) `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) (without-interrupts (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) ;; FIXME 64 (defconstant rand-base (- (ash 1 31) 1)) (defmacro modify-cache (cache-vector &body body) `(without-interrupts (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) (declare (type non-negative-fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) (if (= old-count rand-base) 1 (the non-negative-fixnum (1+ old-count)))))))) (deftype field-type () '(integer 0 ;#.(position 'number wrapper-layout) 7)) ;#.(position 'number wrapper-layout :from-end t) (eval-when (compile load eval) (defun power-of-two-ceiling (x) (declare (type (and fixnum (integer 1 *)) x)) ;;(expt 2 (ceiling (log x 2))) (the non-negative-fixnum (ash 1 (integer-length (1- x))))) (defconstant *nkeys-limit* 255) ) (defstruct (cache (:print-function print-cache) (:constructor make-cache ()) (:copier copy-cache-internal)) (owner nil) (nkeys 1 :type (integer 1 #.*nkeys-limit*)) (valuep nil :type boolean) (nlines 0 :type non-negative-fixnum) (field 0 :type field-type) (limit-fn #'default-limit-fn :type function) (mask 0 :type non-negative-fixnum) (size 0 :type non-negative-fixnum) (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*)))) (max-location 0 :type non-negative-fixnum) (vector #() :type simple-vector) (overflow nil :type list)) #+cmu (declaim (ext:freeze-type cache)) (defun print-cache (cache stream depth) (declare (ignore depth)) (printing-random-thing (cache stream) (format stream "cache ~D ~S ~D" (cache-nkeys cache) (cache-valuep cache) (cache-nlines cache)))) #+akcl (si::freeze-defstruct 'cache) (defmacro cache-lock-count (cache) `(cache-vector-lock-count (cache-vector ,cache))) ;;; ;;; Some facilities for allocation and freeing caches as they are needed. ;;; This is done on the assumption that a better port of PCL will arrange ;;; to cons these all the same static area. Given that, the fact that ;;; PCL tries to reuse them should be a win. ;;; (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) ;;; ;;; Return a cache that has had flush-cache-vector-internal called on it. This ;;; returns a cache of exactly the size requested, it won't ever return a ;;; larger cache. ;;; (defun get-cache-vector (size) (let ((entry (gethash size *free-cache-vectors*))) (without-interrupts (cond ((null entry) (setf (gethash size *free-cache-vectors*) (cons 0 nil)) (get-cache-vector size)) ((null (cdr entry)) (incf (car entry)) (flush-cache-vector-internal (allocate-cache-vector size))) (t (let ((cache (cdr entry))) (setf (cdr entry) (cache-vector-ref cache 0)) (flush-cache-vector-internal cache))))))) (defun free-cache-vector (cache-vector) (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) (without-interrupts (if (null entry) (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.") (let ((thread (cdr entry))) (loop (unless thread (return)) (when (eq thread cache-vector) (error "Freeing a cache twice.")) (setq thread (cache-vector-ref thread 0))) (flush-cache-vector-internal cache-vector) ;Help the GC (setf (cache-vector-ref cache-vector 0) (cdr entry)) (setf (cdr entry) cache-vector) nil))))) ;;; ;;; This is just for debugging and analysis. It shows the state of the free ;;; cache resource. ;;; (defun show-free-cache-vectors () (let ((elements ())) (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) (setq elements (sort elements #'< :key #'car)) (dolist (e elements) (let* ((size (car e)) (entry (cadr e)) (allocated (car entry)) (head (cdr entry)) (free 0)) (loop (when (null head) (return t)) (setq head (cache-vector-ref head 0)) (incf free)) (format t "~&There ~4D are caches of size ~4D. (~D free ~3D%)" allocated size free (floor (* 100 (/ free (float allocated))))))))) ;;; ;;; Wrapper cache numbers ;;; ;;; ;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero ;;; bits wrapper cache numbers will have. ;;; ;;; The value of this constant is the number of wrapper cache numbers which ;;; can be added and still be certain the result will be a fixnum. This is ;;; used by all the code that computes primary cache locations from multiple ;;; wrappers. ;;; ;;; The value of this constant is used to derive the next two which are the ;;; forms of this constant which it is more convenient for the runtime code ;;; to use. ;;; #-cmu17 (eval-when (compile load eval) (defconstant wrapper-cache-number-adds-ok 4) ;;; Incorrect. This actually allows 15 or 16 adds, depending on whether ;;; most-positive-fixnum is all-ones. -- Ram ;;; (defconstant wrapper-cache-number-length (- (integer-length rand-base) wrapper-cache-number-adds-ok)) (defconstant wrapper-cache-number-mask (1- (expt 2 wrapper-cache-number-length))) (defvar *get-wrapper-cache-number* (make-random-state)) (defun get-wrapper-cache-number () (let ((n 0)) (declare (type non-negative-fixnum n)) (loop (setq n (logand wrapper-cache-number-mask (random rand-base *get-wrapper-cache-number*))) (unless (zerop n) (return n))))) (unless (> wrapper-cache-number-length 8) (error "In this implementation of Common Lisp, fixnums are so small that~@ wrapper cache numbers end up being only ~D bits long. This does~@ not actually keep PCL from running, but it may degrade cache~@ performance.~@ You may want to consider changing the value of the constant~@ WRAPPER-CACHE-NUMBER-ADDS-OK."))) #+cmu17 (progn (defconstant wrapper-cache-number-length (integer-length kernel:layout-hash-max)) (defconstant wrapper-cache-number-mask kernel:layout-hash-max) (defconstant wrapper-cache-number-adds-ok (truncate most-positive-fixnum kernel:layout-hash-max))) ;;; ;;; wrappers themselves ;;; ;;; This caching algorithm requires that wrappers have more than one wrapper ;;; cache number. You should think of these multiple numbers as being in ;;; columns. That is, for a given cache, the same column of wrapper cache ;;; numbers will be used. ;;; ;;; If at some point the cache distribution of a cache gets bad, the cache ;;; can be rehashed by switching to a different column. ;;; ;;; The columns are referred to by field number which is that number which, ;;; when used as a second argument to wrapper-ref, will return that column ;;; of wrapper cache number. ;;; ;;; This code is written to allow flexibility as to how many wrapper cache ;;; numbers will be in each wrapper, and where they will be located. It is ;;; also set up to allow port specific modifications to `pack' the wrapper ;;; cache numbers on machines where the addressing modes make that a good ;;; idea. ;;; #-structure-wrapper (progn (eval-when (compile load eval) (defconstant wrapper-layout '(number number number number number number number number state instance-slots-layout class-slots class no-of-instance-slots)) ) (eval-when (compile load eval) (defun wrapper-field (type) (posq type wrapper-layout)) (defun next-wrapper-field (field-number) (position (nth field-number wrapper-layout) wrapper-layout :start (1+ field-number))) (defmacro first-wrapper-cache-number-index () `(wrapper-field 'number)) (defmacro next-wrapper-cache-number-index (field-number) `(next-wrapper-field ,field-number)) );eval-when (defmacro wrapper-cache-number-vector (wrapper) wrapper) (defmacro cache-number-vector-ref (cnv n) `(svref ,cnv ,n)) (defmacro wrapper-ref (wrapper n) `(svref ,wrapper ,n)) (defmacro wrapper-state (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'state))) (defmacro wrapper-instance-slots-layout (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) (defmacro wrapper-class-slots (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) (defmacro wrapper-class (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'class))) (defmacro wrapper-no-of-instance-slots (wrapper) `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots))) (defmacro make-wrapper-internal () `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) ,@(gathering1 (collecting) (iterate ((i (interval :from 0)) (desc (list-elements wrapper-layout))) (ecase desc (number (gather1 `(setf (wrapper-ref wrapper ,i) (get-wrapper-cache-number)))) ((state instance-slots-layout class-slots class no-of-instance-slots))))) (setf (wrapper-state wrapper) 't) wrapper)) (defun make-wrapper (no-of-instance-slots &optional class) (let ((wrapper (make-wrapper-internal))) (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots) (setf (wrapper-class wrapper) class) wrapper)) ) ; In CMUCL we want to do type checking as early as possible; structures help this. #+structure-wrapper (eval-when (compile load eval) (defconstant wrapper-cache-number-vector-length #+cmu17 kernel:layout-hash-length #-cmu17 8) #-cmu17 (deftype cache-number-vector () `(simple-array fixnum (,wrapper-cache-number-vector-length))) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) ) #+structure-wrapper (progn #-(or new-kcl-wrapper cmu17) (defun make-wrapper-cache-number-vector () (let ((cnv (make-array #.wrapper-cache-number-vector-length :element-type 'fixnum))) (dotimes (i #.wrapper-cache-number-vector-length) (setf (aref cnv i) (get-wrapper-cache-number))) cnv)) #-cmu17 (defstruct (wrapper #+new-kcl-wrapper (:include si::basic-wrapper) (:print-function print-wrapper) #-new-kcl-wrapper (:constructor make-wrapper (no-of-instance-slots &optional class)) #+new-kcl-wrapper (:constructor make-wrapper-internal)) #-new-kcl-wrapper (cache-number-vector (make-wrapper-cache-number-vector) :type cache-number-vector) #-new-kcl-wrapper (state t :type (or (member t) cons)) ;; either t or a list (state-sym new-wrapper) ;; where state-sym is either :flush or :obsolete (instance-slots-layout nil :type list) (class-slots nil :type list) #-new-kcl-wrapper (no-of-instance-slots 0 :type fixnum) #-new-kcl-wrapper (class *the-class-t* :type class)) (unless (boundp '*the-class-t*) (setq *the-class-t* nil)) #+new-kcl-wrapper (defmacro wrapper-no-of-instance-slots (wrapper) `(si::s-data-length ,wrapper)) ;;; Note that for CMU, the WRAPPER of a built-in or structure class will be ;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only ;;; two slots that WRAPPER adds are meaningless in those cases. ;;; #+cmu17 (progn (defstruct (wrapper (:include kernel:layout) (:conc-name %wrapper-) (:print-function print-wrapper) (:constructor make-wrapper-internal)) (instance-slots-layout nil :type list) (class-slots nil :type list)) (declaim (ext:freeze-type wrapper)) (defmacro wrapper-class (wrapper) `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) (defmacro wrapper-no-of-instance-slots (wrapper) `(kernel:layout-length ,wrapper)) (declaim (inline wrapper-state (setf wrapper-state))) (defun wrapper-state (wrapper) (let ((invalid (kernel:layout-invalid wrapper))) (cond ((null invalid) t) ((atom invalid) ;; Some non-pcl object. invalid is probably :INVALID ;; We should compute the new wrapper here instead ;; of returning nil, but why bother, since ;; obsolete-instance-trap can't use it. '(:obsolete nil)) (t invalid)))) (defun (setf wrapper-state) (new-value wrapper) (setf (kernel:layout-invalid wrapper) (if (eq new-value 't) nil new-value))) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) (defmacro wrapper-class-slots (wrapper) `(%wrapper-class-slots ,wrapper)) (defmacro wrapper-cache-number-vector (x) x)) #+new-kcl-wrapper (defun make-wrapper (size &optional class) (multiple-value-bind (raw slot-positions) (if (< size 50) (values si::*all-t-s-type* si::*standard-slot-positions*) (values (make-array size :element-type 'unsigned-char) (let ((array (make-array size :element-type 'unsigned-short))) (dotimes (i size) (declare (fixnum i)) (setf (aref array i) (* #.(si::size-of t) i)))))) (make-wrapper-internal :length size :raw raw :print-function 'print-std-instance :slot-position slot-positions :size (* size #.(si::size-of t)) :class class))) #+cmu17 ;;; BOOT-MAKE-WRAPPER -- Interface ;;; ;;; Called in BRAID when we are making wrappers for classes whose slots are ;;; not initialized yet, and which may be built-in classes. We pass in the ;;; class name in addition to the class. ;;; (defun boot-make-wrapper (length name &optional class) (let ((found (lisp:find-class name nil))) (cond (found (unless (kernel:class-pcl-class found) (setf (kernel:class-pcl-class found) class)) (assert (eq (kernel:class-pcl-class found) class)) (let ((layout (kernel:class-layout found))) (assert layout) layout)) (t (kernel:initialize-layout-hash (make-wrapper-internal :length length :class (kernel:make-standard-class :name name :pcl-class class))))))) #+cmu17 ;;; MAKE-WRAPPER -- Interface ;;; ;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure ;;; classes already exist when PCL is initialized, so we don't necessarily ;;; always make a wrapper. Also, we help maintain the mapping between ;;; lisp:class and pcl::class objects. ;;; (defun make-wrapper (length class) (cond ((typep class 'std-class) (kernel:initialize-layout-hash (make-wrapper-internal :length length :class (let ((owrap (class-wrapper class))) (cond (owrap (kernel:layout-class owrap)) ((*subtypep (class-of class) *the-class-standard-class*) (kernel:make-standard-class :pcl-class class)) (t (kernel:make-random-pcl-class :pcl-class class))))))) (t (let* ((found (lisp:find-class (slot-value class 'name))) (layout (kernel:class-layout found))) (unless (kernel:class-pcl-class found) (setf (kernel:class-pcl-class found) class)) (assert (eq (kernel:class-pcl-class found) class)) (assert layout) layout)))) (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) (printing-random-thing (wrapper stream) (format stream "Wrapper ~S" (wrapper-class wrapper)))) (defmacro first-wrapper-cache-number-index () 0) (defmacro next-wrapper-cache-number-index (field-number) `(and (< (the field-type ,field-number) #.(1- wrapper-cache-number-vector-length)) (the field-type (1+ (the field-type ,field-number))))) #-cmu17 (defmacro cache-number-vector-ref (cnv n) `(#-kcl svref #+kcl aref ,cnv ,n)) #+cmu17 (defmacro cache-number-vector-ref (cnv n) `(wrapper-cache-number-vector-ref ,cnv ,n)) ) #-cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(the fixnum (#-structure-wrapper svref #+structure-wrapper aref (wrapper-cache-number-vector ,wrapper) ,n))) #+cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(kernel:layout-hash ,wrapper ,n)) (defmacro class-no-of-instance-slots (class) `(wrapper-no-of-instance-slots (class-wrapper ,class))) (defmacro wrapper-class* (wrapper) #-(or new-kcl-wrapper cmu17) `(wrapper-class ,wrapper) #+(or new-kcl-wrapper cmu17) `(let ((wrapper ,wrapper)) (or (wrapper-class wrapper) (find-structure-class #+new-kcl-wrapper (si::s-data-name wrapper) #+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on ;;; the next access to any instance of a given class. This mechanism is ;;; used to implement the updating of instances when the class is redefined ;;; (make-instances-obsolete). The same mechanism is also used to update ;;; generic function caches when there is a change to the supers of a class. ;;; ;;; Basically, a given wrapper can be valid or invalid. If it is invalid, ;;; it means that any attempt to do a wrapper cache lookup using the wrapper ;;; should trap. Also, methods on slot-value-using-class check the wrapper ;;; validity as well. This is done by calling check-wrapper-validity. ;;; (defmacro invalid-wrapper-p (wrapper) `(neq (wrapper-state ,wrapper) 't)) (defvar *previous-nwrappers* (make-hash-table)) (defun invalidate-wrapper (owrapper state nwrapper) (ecase state ((:flush :obsolete) (let ((new-previous ())) ;; ;; First off, a previous call to invalidate-wrapper may have recorded ;; owrapper as an nwrapper to update to. Since owrapper is about to ;; be invalid, it no longer makes sense to update to it. ;; ;; We go back and change the previously invalidated wrappers so that ;; they will now update directly to nwrapper. This corresponds to a ;; kind of transitivity of wrapper updates. ;; (dolist (previous (gethash owrapper *previous-nwrappers*)) (when (eq state ':obsolete) (setf (car previous) ':obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) (let ((ocnv (wrapper-cache-number-vector owrapper))) (iterate ((type (list-elements wrapper-layout)) (i (interval :from 0))) (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0)))) (push (setf (wrapper-state owrapper) (list state nwrapper)) new-previous) (setf (gethash owrapper *previous-nwrappers*) () (gethash nwrapper *previous-nwrappers*) new-previous))))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) (state (wrapper-state owrapper))) (if (eq state 't) owrapper (let ((nwrapper (ecase (car state) (:flush (flush-cache-trap owrapper (cadr state) instance)) (:obsolete (obsolete-instance-trap owrapper (cadr state) instance))))) ;; ;; This little bit of error checking is superfluous. It only ;; checks to see whether the person who implemented the trap ;; handling screwed up. Since that person is hacking internal ;; PCL code, and is not a user, this should be needless. Also, ;; since this directly slows down instance update and generic ;; function cache refilling, feel free to take it out sometime ;; soon. ;; (cond ((neq nwrapper (wrapper-of instance)) (error "Wrapper returned from trap not wrapper of instance.")) ((invalid-wrapper-p nwrapper) (error "Wrapper returned from trap invalid."))) nwrapper)))) #-cmu17 (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (cond ((std-instance-p ,object) (std-instance-wrapper ,object)) ((fsc-instance-p ,object) (fsc-instance-wrapper ,object)) #+new-kcl-wrapper (t (built-in-wrapper-of ,object)) #-new-kcl-wrapper (t (wrapper-of ,object))))) (if (eq 't (wrapper-state ,owrapper)) ,owrapper (check-wrapper-validity ,object))))) #+cmu17 ;;; semantically equivalent, but faster. ;;; (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (kernel:layout-of object))) (if (kernel:layout-invalid ,owrapper) (check-wrapper-validity ,object) ,owrapper)))) (defvar *free-caches* nil) (defun get-cache (nkeys valuep limit-fn nlines) (declare (type non-negative-fixnum nlines)) (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (compute-cache-parameters nkeys valuep nlines) (declare (type non-negative-fixnum cache-mask actual-size line-size nlines)) (setf (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) (first-wrapper-cache-number-index) (cache-limit-fn cache) limit-fn (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size (cache-max-location cache) (let ((line (1- nlines))) (declare (type non-negative-fixnum line)) (if (= nkeys 1) (the fixnum (* line line-size)) (the fixnum (1+ (the fixnum (* line line-size)))))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) (defun get-cache-from-cache (old-cache new-nlines &optional (new-field (first-wrapper-cache-number-index))) (declare (type non-negative-fixnum new-nlines)) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (if (= new-nlines (cache-nlines old-cache)) (values (cache-mask old-cache) (cache-size old-cache) (cache-line-size old-cache) (cache-nlines old-cache)) (compute-cache-parameters nkeys valuep new-nlines)) (declare (type non-negative-fixnum cache-mask actual-size line-size nlines)) (setf (cache-owner cache) (cache-owner old-cache) (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines (cache-field cache) new-field (cache-limit-fn cache) (cache-limit-fn old-cache) (cache-mask cache) cache-mask (cache-size cache) actual-size (cache-line-size cache) line-size (cache-max-location cache) (let ((line (1- nlines))) (declare (type non-negative-fixnum line)) (if (= nkeys 1) (the fixnum (* line line-size)) (the fixnum (1+ (the fixnum (* line line-size)))))) (cache-vector cache) (get-cache-vector actual-size) (cache-overflow cache) nil) cache))) (defun copy-cache (old-cache) (let* ((new-cache (copy-cache-internal old-cache)) (size (cache-size old-cache)) (old-vector (cache-vector old-cache)) (new-vector (get-cache-vector size))) (declare (simple-vector old-vector new-vector)) (dotimes (i size) (setf (svref new-vector i) (svref old-vector i))) (setf (cache-vector new-cache) new-vector) new-cache)) (defun free-cache (cache) (free-cache-vector (cache-vector cache)) (setf (cache-vector cache) #()) (setf (cache-owner cache) nil) (push cache *free-caches*) nil) (defun compute-line-size (x) (power-of-two-ceiling x)) (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) ;;(declare (values cache-mask actual-size line-size nlines)) (declare (type non-negative-fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the non-negative-fixnum (* line-size (the non-negative-fixnum (power-of-two-ceiling nlines-or-cache-vector)))) (cache-vector-size nlines-or-cache-vector)))) (declare (type non-negative-fixnum line-size cache-size)) (values (logxor (the non-negative-fixnum (1- cache-size)) (the non-negative-fixnum (1- line-size))) cache-size line-size (the non-negative-fixnum (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the non-negative-fixnum (* line-size (the non-negative-fixnum (power-of-two-ceiling nlines-or-cache-vector)))) (1- (cache-vector-size nlines-or-cache-vector))))) (declare (type non-negative-fixnum line-size cache-size)) (values (logxor (the non-negative-fixnum (1- cache-size)) (the non-negative-fixnum (1- line-size))) (the non-negative-fixnum (1+ cache-size)) line-size (the non-negative-fixnum (floor cache-size line-size)))))) ;;; ;;; The various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are ;;; several implementations of the same algorithm. ;;; ;;; The algorithm is: ;;; ;;; SUM over the wrapper cache numbers, ;;; ENSURING that the result is a fixnum ;;; MASK the result against the mask argument. ;;; ;;; ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION ;;; ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. ;;; (defun compute-primary-cache-location (field mask wrappers) (declare (type field-type field) (type non-negative-fixnum mask)) (if (not (listp wrappers)) (logand mask (the non-negative-fixnum (wrapper-cache-number-vector-ref wrappers field))) (let ((location 0) (i 0)) (declare (type non-negative-fixnum location i)) (dolist (wrapper wrappers) ;; ;; First add the cache number of this wrapper to location. ;; (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field))) (declare (type non-negative-fixnum wrapper-cache-number)) (if (zerop wrapper-cache-number) (return-from compute-primary-cache-location 0) (setq location (the non-negative-fixnum (+ location wrapper-cache-number))))) ;; ;; Then, if we are working with lots of wrappers, deal with ;; the wrapper-cache-number-mask stuff. ;; (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq location (logand location wrapper-cache-number-mask))) (incf i)) (the non-negative-fixnum (1+ (logand mask location)))))) ;;; ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION ;;; ;;; This version is called on a cache line. It fetches the wrappers from ;;; the cache line and determines the primary location. Various parts of ;;; the cache filling code call this to determine whether it is appropriate ;;; to displace a given cache entry. ;;; ;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol ;;; invalid to suggest to its caller that it would be provident to blow away ;;; the cache line in question. ;;; (defun compute-primary-cache-location-from-location (to-cache from-location &optional (from-cache to-cache)) (declare (type cache to-cache from-cache) (type non-negative-fixnum from-location)) (let ((result 0) (cache-vector (cache-vector from-cache)) (field (cache-field to-cache)) (mask (cache-mask to-cache)) (nkeys (cache-nkeys to-cache))) (declare (type field-type field) (type non-negative-fixnum result mask nkeys) (simple-vector cache-vector)) (dotimes (i nkeys) (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) (wcn (wrapper-cache-number-vector-ref wrapper field))) (declare (type non-negative-fixnum wcn)) (setq result (+ result wcn))) (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq result (logand result wrapper-cache-number-mask)))) (if (= nkeys 1) (logand mask result) (the non-negative-fixnum (1+ (logand mask result)))))) ;;; ;;; NIL means nothing so far, no actual arg info has NILs ;;; in the metatype ;;; CLASS seen all sorts of metaclasses ;;; (specifically, more than one of the next 4 values) ;;; T means everything so far is the class T ;;; STANDARD-CLASS seen only standard classes ;;; BUILT-IN-CLASS seen only built in classes ;;; STRUCTURE-CLASS seen only structure classes ;;; (defun raise-metatype (metatype new-specializer) (let ((slot (find-class 'slot-class)) (standard (find-class 'standard-class)) (fsc (find-class 'funcallable-standard-class)) (structure (find-class 'structure-class)) (built-in (find-class 'built-in-class))) (flet ((specializer->metatype (x) (let ((meta-specializer (if (eq *boot-state* 'complete) (class-of (specializer-class x)) (class-of x)))) (cond ((eq x *the-class-t*) t) ((*subtypep meta-specializer standard) 'standard-instance) ((*subtypep meta-specializer fsc) 'standard-instance) ((*subtypep meta-specializer structure) 'structure-instance) ((*subtypep meta-specializer built-in) 'built-in-instance) ((*subtypep meta-specializer slot) 'slot-instance) (t (error "PCL can not handle the specializer ~S (meta-specializer ~S)." new-specializer meta-specializer)))))) ;; ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; ;; NIL ===> ;; X X ===> X ;; X Y ===> CLASS ;; (let ((new-metatype (specializer->metatype new-specializer))) (cond ((eq new-metatype 'slot-instance) 'class) ((null metatype) new-metatype) ((eq metatype new-metatype) new-metatype) (t 'class)))))) (defmacro with-dfun-wrappers ((args metatypes) (dfun-wrappers invalid-wrapper-p &optional wrappers classes types) invalid-arguments-form &body body) `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil) (,dfun-wrappers nil) (dfun-wrappers-tail nil) ,@(when wrappers `((wrappers-rev nil) (types-rev nil) (classes-rev nil)))) (dolist (mt ,metatypes) (unless args-tail (setq invalid-arguments-p t) (return nil)) (let* ((arg (pop args-tail)) (wrapper nil) ,@(when wrappers `((class *the-class-t*) (type 't)))) (unless (eq mt 't) (setq wrapper (wrapper-of arg)) (when (invalid-wrapper-p wrapper) (setq ,invalid-wrapper-p t) (setq wrapper (check-wrapper-validity arg))) (cond ((null ,dfun-wrappers) (setq ,dfun-wrappers wrapper)) ((not (consp ,dfun-wrappers)) (setq dfun-wrappers-tail (list wrapper)) (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail))) (t (let ((new-dfun-wrappers-tail (list wrapper))) (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail) (setf dfun-wrappers-tail new-dfun-wrappers-tail)))) ,@(when wrappers `((setq class (wrapper-class* wrapper)) (setq type `(class-eq ,class))))) ,@(when wrappers `((push wrapper wrappers-rev) (push class classes-rev) (push type types-rev))))) (if invalid-arguments-p ,invalid-arguments-form (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) (,types (mapcar #'(lambda (class) `(class-eq ,class)) ,classes))))) ,@body)))) ;;; ;;; Some support stuff for getting a hold of symbols that we need when ;;; building the discriminator codes. Its ok for these to be interned ;;; symbols because we don't capture any user code in the scope in which ;;; these symbols are bound. ;;; (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) (defun dfun-arg-symbol (arg-number) (or (nth arg-number (the list *dfun-arg-symbols*)) (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) (or (nth arg-number (the list *slot-vector-symbols*)) (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) (defun make-dfun-lambda-list (metatypes applyp) (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '&rest) (gather1 '.dfun-rest-arg.)))) (defun make-dlap-lambda-list (metatypes applyp) (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '&rest)))) (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.))))) (defun make-dfun-call (metatypes applyp fn-variable) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) (if applyp `(function-apply ,fn-variable ,@required .dfun-rest-arg.) `(function-funcall ,fn-variable ,@required)))) (defun make-dfun-arg-list (metatypes applyp) (let ((required (gathering1 (collecting) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i)))))) (if applyp `(list* ,@required .dfun-rest-arg.) `(list ,@required)))) (defun make-fast-method-call-lambda-list (metatypes applyp) (gathering1 (collecting) (gather1 '.pv-cell.) (gather1 '.next-method-call.) (iterate ((i (interval :from 0)) (s (list-elements metatypes))) (progn s) (gather1 (dfun-arg-symbol i))) (when applyp (gather1 '.dfun-rest-arg.)))) (defmacro fin-lambda-fn (arglist &body body) `#'(#+cmu kernel:instance-lambda #-cmu lambda ,arglist ,@body)) (defun make-dispatch-lambda (function-p metatypes applyp body) `(#+cmu ,(if function-p 'kernel:instance-lambda 'lambda) #-cmu lambda ,(if function-p (make-dfun-lambda-list metatypes applyp) (make-fast-method-call-lambda-list metatypes applyp)) ,@(unless function-p `((declare (ignore .pv-cell. .next-method-call.)))) #+cmu (declare (ignorable ,@(cddr (make-fast-method-call-lambda-list metatypes applyp)))) #+copy-&rest-arg ,@(when (and applyp function-p) `((setq .dfun-rest-arg. (copy-list .dfun-rest-arg.)))) ,@body)) ;;; ;;; Its too bad Common Lisp compilers freak out when you have a defun with ;;; a lot of LABELS in it. If I could do that I could make this code much ;;; easier to read and work with. ;;; ;;; Ahh Scheme... ;;; ;;; In the absence of that, the following little macro makes the code that ;;; follows a little bit more reasonable. I would like to add that having ;;; to practically write my own compiler in order to get just this simple ;;; thing is something of a drag. ;;; (eval-when (compile load eval) (defvar *cache* nil) (defconstant *local-cache-functions* '((cache () .cache.) (nkeys () (cache-nkeys .cache.)) (line-size () (cache-line-size .cache.)) (vector () (cache-vector .cache.)) (valuep () (cache-valuep .cache.)) (nlines () (cache-nlines .cache.)) (max-location () (cache-max-location .cache.)) (limit-fn () (cache-limit-fn .cache.)) (size () (cache-size .cache.)) (mask () (cache-mask .cache.)) (field () (cache-field .cache.)) (overflow () (cache-overflow .cache.)) ;; ;; Return T IFF this cache location is reserved. The only time ;; this is true is for line number 0 of an nkeys=1 cache. ;; (line-reserved-p (line) (declare (type non-negative-fixnum line)) (and (= (nkeys) 1) (= line 0))) ;; (location-reserved-p (location) (declare (type non-negative-fixnum location)) (and (= (nkeys) 1) (= location 0))) ;; ;; Given a line number, return the cache location. This is the ;; value that is the second argument to cache-vector-ref. Basically, ;; this deals with the offset of nkeys>1 caches and multiplies ;; by line size. ;; (line-location (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "line is reserved")) (if (= (nkeys) 1) (the non-negative-fixnum (* line (line-size))) (the non-negative-fixnum (1+ (the non-negative-fixnum (* line (line-size))))))) ;; ;; Given a cache location, return the line. This is the inverse ;; of LINE-LOCATION. ;; (location-line (location) (declare (type non-negative-fixnum location)) (if (= (nkeys) 1) (floor location (line-size)) (floor (the non-negative-fixnum (1- location)) (line-size)))) ;; ;; Given a line number, return the wrappers stored at that line. ;; As usual, if nkeys=1, this returns a single value. Only when ;; nkeys>1 does it return a list. An error is signalled if the ;; line is reserved. ;; (line-wrappers (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-wrappers (line-location line))) ;; (location-wrappers (location) ; avoid multiplies caused by line-location (declare (type non-negative-fixnum location)) (if (= (nkeys) 1) (cache-vector-ref (vector) location) (let ((list (make-list (nkeys))) (vector (vector))) (declare (simple-vector vector)) (dotimes (i (nkeys) list) (setf (nth i list) (cache-vector-ref vector (+ location i))))))) ;; ;; Given a line number, return true IFF the line's ;; wrappers are the same as wrappers. ;; (line-matches-wrappers-p (line wrappers) (declare (type non-negative-fixnum line)) (and (not (line-reserved-p line)) (location-matches-wrappers-p (line-location line) wrappers))) ;; (location-matches-wrappers-p (loc wrappers) ; must not be reserved (declare (type non-negative-fixnum loc)) (let ((cache-vector (vector))) (declare (simple-vector cache-vector)) (if (= (nkeys) 1) (eq wrappers (cache-vector-ref cache-vector loc)) (dotimes (i (nkeys) t) (unless (eq (pop wrappers) (cache-vector-ref cache-vector (+ loc i))) (return nil)))))) ;; ;; Given a line number, return the value stored at that line. ;; If valuep is NIL, this returns NIL. As with line-wrappers, ;; an error is signalled if the line is reserved. ;; (line-value (line) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-value (line-location line))) ;; (location-value (loc) (declare (type non-negative-fixnum loc)) (and (valuep) (cache-vector-ref (vector) (+ loc (nkeys))))) ;; ;; Given a line number, return true IFF that line has data in ;; it. The state of the wrappers stored in the line is not ;; checked. An error is signalled if line is reserved. (line-full-p (line) (when (line-reserved-p line) (error "Line is reserved.")) (not (null (cache-vector-ref (vector) (line-location line))))) ;; ;; Given a line number, return true IFF the line is full and ;; there are no invalid wrappers in the line, and the line's ;; wrappers are different from wrappers. ;; An error is signalled if the line is reserved. ;; (line-valid-p (line wrappers) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Line is reserved.")) (location-valid-p (line-location line) wrappers)) ;; (location-valid-p (loc wrappers) (declare (type non-negative-fixnum loc)) (let ((cache-vector (vector)) (wrappers-mismatch-p (null wrappers))) (declare (simple-vector cache-vector)) (dotimes (i (nkeys) wrappers-mismatch-p) (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) (when (or (null wrapper) (invalid-wrapper-p wrapper)) (return nil)) (unless (and wrappers (eq wrapper (if (consp wrappers) (pop wrappers) wrappers))) (setq wrappers-mismatch-p t)))))) ;; ;; How many unreserved lines separate line-1 and line-2. ;; (line-separation (line-1 line-2) (declare (type non-negative-fixnum line-1 line-2)) (let ((diff (the fixnum (- line-2 line-1)))) (declare (fixnum diff)) (when (minusp diff) (setq diff (+ diff (nlines))) (when (line-reserved-p 0) (setq diff (1- diff)))) diff)) ;; ;; Given a cache line, get the next cache line. This will not ;; return a reserved line. ;; (next-line (line) (declare (type non-negative-fixnum line)) (if (= line (the fixnum (1- (nlines)))) (if (line-reserved-p 0) 1 0) (the non-negative-fixnum (1+ line)))) ;; (next-location (loc) (declare (type non-negative-fixnum loc)) (if (= loc (max-location)) (if (= (nkeys) 1) (line-size) 1) (the non-negative-fixnum (+ loc (line-size))))) ;; ;; Given a line which has a valid entry in it, this will return ;; the primary cache line of the wrappers in that line. We just ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an ;; easier packaging up of the call to it. ;; (line-primary (line) (declare (type non-negative-fixnum line)) (location-line (line-primary-location line))) ;; (line-primary-location (line) (declare (type non-negative-fixnum line)) (compute-primary-cache-location-from-location (cache) (line-location line))) )) (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) (declare (type cache .cache.)) (macrolet ,(mapcar #'(lambda (fn) `(,(car fn) ,(cadr fn) `(let (,,@(mapcar #'(lambda (var) ``(,',var ,,var)) (cadr fn))) ,@',(cddr fn)))) *local-cache-functions*) ,@body))) ) ;;; ;;; Here is where we actually fill, recache and expand caches. ;;; ;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external ;;; entrypoints into this code. ;;; ;;; FILL-CACHE returns 1 value: a new cache ;;; ;;; a wrapper field number ;;; a cache ;;; a mask ;;; an absolute cache size (the size of the actual vector) ;;; It tries to re-adjust the cache every time it makes a new fill. The ;;; intuition here is that we want uniformity in the number of probes needed to ;;; find an entry. Furthermore, adjusting has the nice property of throwing out ;;; any entries that are invalid. ;;; (defvar *cache-expand-threshold* 1.25) (defun fill-cache (cache wrappers value &optional free-cache-p) ;;(declare (values cache)) (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. (error "fill-cache: wrappers arg is NIL!")) (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) 1.25)) (if (= (cache-nkeys cache) 1) (1- (cache-nlines cache)) (cache-nlines cache))) (adjust-cache cache wrappers value free-cache-p)) (expand-cache cache wrappers value free-cache-p))) (defvar *check-cache-p* nil) (defmacro maybe-check-cache (cache) `(progn (when *check-cache-p* (check-cache ,cache)) ,cache)) (defun check-cache (cache) (with-local-cache-functions (cache) (let ((location (if (= (nkeys) 1) 0 1)) (limit (funcall (limit-fn) (nlines)))) (dotimes (i (nlines) cache) (when (and (not (location-reserved-p location)) (line-full-p i)) (let* ((home-loc (compute-primary-cache-location-from-location cache location)) (home (location-line (if (location-reserved-p home-loc) (next-location home-loc) home-loc))) (sep (when home (line-separation home i)))) (when (and sep (> sep limit)) (error "bad cache ~S ~@ value at location ~D is ~D lines from its home. limit is ~D." cache location sep limit)))) (setq location (next-location location)))))) (defun probe-cache (cache wrappers &optional default limit-fn) ;;(declare (values value)) (unless wrappers (error "probe-cache: wrappers arg is NIL!")) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (limit (funcall (or limit-fn (limit-fn)) (nlines)))) (declare (type non-negative-fixnum location limit)) (when (location-reserved-p location) (setq location (next-location location))) (dotimes (i (the non-negative-fixnum (1+ limit))) (when (location-matches-wrappers-p location wrappers) (return-from probe-cache (or (not (valuep)) (location-value location)))) (setq location (next-location location))) (dolist (entry (overflow)) (when (equal (car entry) wrappers) (return-from probe-cache (or (not (valuep)) (cdr entry))))) default))) (defun map-cache (function cache &optional set-p) (with-local-cache-functions (cache) (let ((set-p (and set-p (valuep)))) (dotimes (i (nlines) cache) (unless (or (line-reserved-p i) (not (line-valid-p i nil))) (let ((value (funcall function (line-wrappers i) (line-value i)))) (when set-p (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys))) value))))) (dolist (entry (overflow)) (let ((value (funcall function (car entry) (cdr entry)))) (when set-p (setf (cdr entry) value)))))) cache) (defun cache-count (cache) (with-local-cache-functions (cache) (let ((count 0)) (declare (type non-negative-fixnum count)) (dotimes (i (nlines) count) (unless (line-reserved-p i) (when (line-full-p i) (incf count))))))) (defun entry-in-cache-p (cache wrappers value) (declare (ignore value)) (with-local-cache-functions (cache) (dotimes (i (nlines)) (unless (line-reserved-p i) (when (equal (line-wrappers i) wrappers) (return t)))))) ;;; ;;; returns T or NIL ;;; (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (primary (location-line location))) (declare (type non-negative-fixnum location primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache wrappers) (when (or forcep emptyp) (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) ;;(fill-line free wrappers value) (let ((line free)) (declare (type non-negative-fixnum line)) (when (line-reserved-p line) (error "Attempt to fill a reserved line.")) (let ((loc (line-location line)) (cache-vector (vector))) (declare (type non-negative-fixnum loc) (simple-vector cache-vector)) (cond ((= (nkeys) 1) (setf (cache-vector-ref cache-vector loc) wrappers) (when (valuep) (setf (cache-vector-ref cache-vector (1+ loc)) value))) (t (let ((i 0)) (declare (type non-negative-fixnum i)) (dolist (w wrappers) (setf (cache-vector-ref cache-vector (+ loc i)) w) (setq i (the non-negative-fixnum (1+ i))))) (when (valuep) (setf (cache-vector-ref cache-vector (+ loc (nkeys))) value)))) (maybe-check-cache cache)))))))) (defun fill-cache-from-cache-p (forcep cache from-cache from-line) (declare (type non-negative-fixnum from-line)) (with-local-cache-functions (cache) (let ((primary (location-line (compute-primary-cache-location-from-location cache (line-location from-line) from-cache)))) (declare (type non-negative-fixnum primary)) (multiple-value-bind (free emptyp) (find-free-cache-line primary cache) (when (or forcep emptyp) (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) ;;(transfer-line from-cache-vector from-line cache-vector free) (let ((from-cache-vector (cache-vector from-cache)) (to-cache-vector (vector)) (to-line free)) (declare (type non-negative-fixnum to-line)) (if (line-reserved-p to-line) (error "transfering something into a reserved cache line.") (let ((from-loc (line-location from-line)) (to-loc (line-location to-line))) (declare (type non-negative-fixnum from-loc to-loc)) (modify-cache to-cache-vector (dotimes (i (line-size)) (setf (cache-vector-ref to-cache-vector (+ to-loc i)) (cache-vector-ref from-cache-vector (+ from-loc i))))))) (maybe-check-cache cache))))))) ;;; ;;; Returns NIL or (values ) ;;; ;;; This is only called when it isn't possible to put the entry in the cache ;;; the easy way. That is, this function assumes that FILL-CACHE-P has been ;;; called as returned NIL. ;;; ;;; If this returns NIL, it means that it wasn't possible to find a wrapper ;;; field for which all of the entries could be put in the cache (within the ;;; limit). ;;; (defun adjust-cache (cache wrappers value free-old-cache-p) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (nlines) (field)))) (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield))) ((null nfield) (free-cache ncache) nil) (let ((nfield nfield)) (declare (type field-type nfield)) (setf (cache-field ncache) nfield) (labels ((try-one-fill-from-line (line) (fill-cache-from-cache-p nil ncache cache line)) (try-one-fill (wrappers value) (fill-cache-p nil ncache wrappers value))) (if (and (dotimes (i (nlines) t) (when (and (null (line-reserved-p i)) (line-valid-p i wrappers)) (unless (try-one-fill-from-line i) (return nil)))) (dolist (wrappers+value (cache-overflow cache) t) (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) (return nil))) (try-one-fill wrappers value)) (progn (when free-old-cache-p (free-cache cache)) (return (maybe-check-cache ncache))) (flush-cache-vector-internal (cache-vector ncache))))))))) ;;; ;;; returns: (values ) ;;; (defun expand-cache (cache wrappers value free-old-cache-p) ;;(declare (values cache)) (with-local-cache-functions (cache) (let ((ncache (get-cache-from-cache cache (* (nlines) 2)))) (labels ((do-one-fill-from-line (line) (unless (fill-cache-from-cache-p nil ncache cache line) (do-one-fill (line-wrappers line) (line-value line)))) (do-one-fill (wrappers value) (setq ncache (or (adjust-cache ncache wrappers value t) (fill-cache-p t ncache wrappers value)))) (try-one-fill (wrappers value) (fill-cache-p nil ncache wrappers value))) (dotimes (i (nlines)) (when (and (null (line-reserved-p i)) (line-valid-p i wrappers)) (do-one-fill-from-line i))) (dolist (wrappers+value (cache-overflow cache)) (unless (try-one-fill (car wrappers+value) (cdr wrappers+value)) (do-one-fill (car wrappers+value) (cdr wrappers+value)))) (unless (try-one-fill wrappers value) (do-one-fill wrappers value)) (when free-old-cache-p (free-cache cache)) (maybe-check-cache ncache))))) ;;; ;;; This is the heart of the cache filling mechanism. It implements the decisions ;;; about where entries are placed. ;;; ;;; Find a line in the cache at which a new entry can be inserted. ;;; ;;; ;;; is in fact empty? ;;; (defun find-free-cache-line (primary cache &optional wrappers) ;;(declare (values line empty?)) (declare (type non-negative-fixnum primary)) (with-local-cache-functions (cache) (when (line-reserved-p primary) (setq primary (next-line primary))) (let ((limit (funcall (limit-fn) (nlines))) (wrappedp nil) (lines nil) (p primary) (s primary)) (declare (type non-negative-fixnum p s limit)) (block find-free (loop ;; Try to find a free line starting at .

is the ;; primary line of the entry we are finding a free ;; line for, it is used to compute the seperations. (do* ((line s (next-line line)) (nsep (line-separation p s) (1+ nsep))) (()) (declare (type non-negative-fixnum line nsep)) (when (null (line-valid-p line wrappers)) ;If this line is empty or (push line lines) ;invalid, just use it. (return-from find-free)) (when (and wrappedp (>= line primary)) ;; have gone all the way around the cache, time to quit (return-from find-free-cache-line (values primary nil))) (let ((osep (line-separation (line-primary line) line))) (when (>= osep limit) (return-from find-free-cache-line (values primary nil))) (when (cond ((= nsep limit) t) ((= nsep osep) (zerop (random 2))) ((> nsep osep) t) (t nil)) ;; See if we can displace what is in this line so that we ;; can use the line. (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)) (setq p (line-primary line)) (setq s (next-line line)) (push line lines) (return nil))) (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))))) ;; Do all the displacing. (loop (when (null (cdr lines)) (return nil)) (let ((dline (pop lines)) (line (car lines))) (declare (type non-negative-fixnum dline line)) ;;Copy from line to dline (dline is known to be free). (let ((from-loc (line-location line)) (to-loc (line-location dline)) (cache-vector (vector))) (declare (type non-negative-fixnum from-loc to-loc) (simple-vector cache-vector)) (modify-cache cache-vector (dotimes (i (line-size)) (setf (cache-vector-ref cache-vector (+ to-loc i)) (cache-vector-ref cache-vector (+ from-loc i))) (setf (cache-vector-ref cache-vector (+ from-loc i)) nil)))))) (values (car lines) t)))) (defun default-limit-fn (nlines) (case nlines ((1 2 4) 1) ((8 16) 4) (otherwise 6))) (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms ;;; ;;; pre-allocate generic function caches. The hope is that this will put ;;; them nicely together in memory, and that that may be a win. Of course ;;; the first gc copy will probably blow that out, this really wants to be ;;; wrapped in something that declares the area static. ;;; ;;; This preallocation only creates about 25% more caches than PCL itself ;;; uses. Some ports may want to preallocate some more of these. ;;; (eval-when (load) (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32) (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2))) (let ((n (car n-size)) (size (cadr n-size))) (mapcar #'free-cache-vector (mapcar #'get-cache-vector (make-list n :initial-element size)))))) (defun caches-to-allocate () (sort (let ((l nil)) (maphash #'(lambda (size entry) (push (list (car entry) size) l)) pcl::*free-caches*) l) #'> :key #'cadr)) gcl/pcl/gcl_pcl_fngen.lisp0000644000175000017500000001672412240167764014511 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; ;;; GET-FUNCTION is the main user interface to this code. It is like ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by ;;; reducing the number of times that the compiler needs to be called. ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants ;;; can use the same piece of compiled code. (For example, dispatch dfuns and ;;; combined method functions can often be shared, if they differ only ;;; by referring to different methods.) ;;; ;;; If GET-FUNCTION is called with a lambda expression only, it will return ;;; a corresponding function. The optional constant-converter argument ;;; can be a function which will be called to convert each constant appearing ;;; in the lambda to whatever value should appear in the function. ;;; ;;; There are three internal functions which operate on the lambda argument ;;; to GET-FUNCTION: ;;; compute-test converts the lambda into a key to be used for lookup, ;;; compute-code is used by get-new-function-generator-internal to ;;; generate the actual lambda to be compiled, and ;;; compute-constants is used to generate the argument list that is ;;; to be passed to the compiled function. ;;; ;;; Whether the returned function is actually compiled depends on whether ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of ;;; code was precompiled. ;;; (defun get-function (lambda &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) (constant-converter #'default-constant-converter)) (function-apply (get-function-generator lambda test-converter code-converter) (compute-constants lambda constant-converter))) (defun get-function1 (lambda &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) (constant-converter #'default-constant-converter)) (values (the function (get-function-generator lambda test-converter code-converter)) (compute-constants lambda constant-converter))) (defun default-constantp (form) (and (constantp form) (not (typep (eval form) '(or symbol fixnum))))) (defun default-test-converter (form) (if (default-constantp form) '.constant. form)) (defun default-code-converter (form) (if (default-constantp form) (let ((gensym (gensym))) (values gensym (list gensym))) form)) (defun default-constant-converter (form) (if (default-constantp form) (list (eval form)) nil)) ;;; ;;; *fgens* is a list of all the function generators we have so far. Each ;;; element is a FGEN structure as implemented below. Don't ever touch this ;;; list by hand, use STORE-FGEN. ;;; (defvar *fgens* ()) (defun store-fgen (fgen) (let ((old (lookup-fgen (fgen-test fgen)))) (if old (setf (svref old 2) (fgen-generator fgen) (svref old 4) (or (svref old 4) (fgen-system fgen))) (setq *fgens* (nconc *fgens* (list fgen)))))) (defun lookup-fgen (test) (find test (the list *fgens*) :key #'fgen-test :test #'equal)) (defun make-fgen (test gensyms generator generator-lambda system) (let ((new (make-array 6))) (setf (svref new 0) test (svref new 1) gensyms (svref new 2) generator (svref new 3) generator-lambda (svref new 4) system) new)) (defun fgen-test (fgen) (svref fgen 0)) (defun fgen-gensyms (fgen) (svref fgen 1)) (defun fgen-generator (fgen) (svref fgen 2)) (defun fgen-generator-lambda (fgen) (svref fgen 3)) (defun fgen-system (fgen) (svref fgen 4)) (defun get-function-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) (fgen (lookup-fgen test))) (if fgen (fgen-generator fgen) (get-new-function-generator lambda test code-converter)))) (defun get-new-function-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) (get-new-function-generator-internal lambda code-converter) (let* ((generator (compile-lambda generator-lambda)) (fgen (make-fgen test gensyms generator generator-lambda nil))) (store-fgen fgen) generator))) (defun get-new-function-generator-internal (lambda code-converter) (multiple-value-bind (code gensyms) (compute-code lambda code-converter) (values gensyms `(lambda ,gensyms (function ,code))))) (defun compute-test (lambda test-converter) (let ((walk-form-expand-macros-p t)) (walk-form lambda nil #'(lambda (f c e) (declare (ignore e)) (if (neq c :eval) f (let ((converted (funcall test-converter f))) (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((walk-form-expand-macros-p t) (gensyms ())) (values (walk-form lambda nil #'(lambda (f c e) (declare (ignore e)) (if (neq c :eval) f (multiple-value-bind (converted gens) (funcall code-converter f) (when gens (setq gensyms (append gensyms gens))) (values converted (neq converted f)))))) gensyms))) (defun compute-constants (lambda constant-converter) (let ((walk-form-expand-macros-p t)) ; doesn't matter here. (macrolet ((appending () `(let ((result ())) (values #'(lambda (value) (setq result (append result value))) #'(lambda ()result))))) (gathering1 (appending) (walk-form lambda nil #'(lambda (f c e) (declare (ignore e)) (if (neq c :eval) f (let ((consts (funcall constant-converter f))) (if consts (progn (gather1 consts) (values f t)) f))))))))) ;;; ;;; ;;; (defmacro precompile-function-generators (&optional system) (let ((index -1)) `(progn ,@(gathering1 (collecting) (dolist (fgen *fgens*) (when (or (null (fgen-system fgen)) (eq (fgen-system fgen) system)) (when system (setf (svref fgen 4) system)) (gather1 (make-top-level-form `(precompile-function-generators ,system ,(incf index)) '(load) `(load-function-generator ',(fgen-test fgen) ',(fgen-gensyms fgen) (function ,(fgen-generator-lambda fgen)) ',(fgen-generator-lambda fgen) ',system))))))))) (defun load-function-generator (test gensyms generator generator-lambda system) (store-fgen (make-fgen test gensyms generator generator-lambda system))) gcl/pcl/gcl_pcl_pkg.lisp0000644000175000017500000002743612240167764014177 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :user) ;;; From defsys.lisp (eval-when (compile load eval) (if (find-package ':walker) (use-package '(:lisp) ':walker) (make-package ':walker :use '(:lisp))) (if (find-package ':iterate) (use-package '(:lisp :walker) ':iterate) (make-package ':iterate :use '(:lisp :walker))) (if (find-package ':pcl) (use-package '(:walker :iterate :lisp) ':pcl) (make-package ':pcl :use '(:walker :iterate :lisp))) (export (intern (symbol-name :iterate) ;Have to do this here, (find-package :iterate)) ;because in the defsystem (find-package :iterate)) ;(later in this file) ;we use the symbol iterate ;to name the file ) (in-package :walker) (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 )) (in-package :iterate) (export '(iterate iterate* gathering gather with-gathering interval elements list-elements list-tails plist-elements eachtime while until collecting joining maximizing minimizing summing *iterate-warnings*)) (in-package :pcl) ;;; ;;; Some CommonLisps have more symbols in the Lisp package than the ones that ;;; are explicitly specified in CLtL. This causes trouble. Any Lisp that has ;;; extra symbols in the Lisp package should shadow those symbols in the PCL ;;; package. ;;; #+TI (shadow '(string-append once-only destructuring-bind memq assq delq neq true false without-interrupts defmethod) *the-pcl-package*) #+CMU (shadow '(destructuring-bind) *the-pcl-package*) #+cmu17 (shadow '(find-class class-name class-of class built-in-class structure-class standard-class) *the-pcl-package*) #+GCLisp (shadow '(string-append memq assq delq neq make-instance) *the-pcl-package*) (defun use-package-pcl (&optional (*package* *package*)) (shadowing-import (let ((*package* *the-pcl-package*)) (mapcar #'intern #+cmu17 '("FIND-CLASS" "CLASS-NAME" "CLASS-OF" "CLASS" "BUILT-IN-CLASS" "STRUCTURE-CLASS" "STANDARD-CLASS") #+TI '("DEFMETHOD") #+GCLisp '("MAKE-INSTANCE") #-(or cmu17 TI GCLisp) '()))) (use-package *the-pcl-package*)) #+Genera (shadowing-import '(zl:arglist zwei:indentation) *the-pcl-package*) #+Lucid (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist system:structurep system:structure-type system:structure-length) *the-pcl-package*) #+lucid (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind #+LCL3.0 ((lcl:warning #'(lambda (condition) (declare (ignore condition)) (lcl:muffle-warning)))) (let ((importer #+LCL3.0 #'sys:import-from-lucid-pkg #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID"))) (if (and x (fboundp x)) (symbol-function x) ;; Only the #'(lambda (x) ...) below is really needed, ;; but when available, the "internal" function ;; 'import-from-lucid-pkg' provides better checking. #'(lambda (name) (import (intern name "LUCID"))))))) ;; ;; We need the following "internal", undocumented Lucid goodies: (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE" #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE")) ;; ;; For without-interrupts. ;; #+LCL3.0 (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as SYS:, whereas in 3.0 lisps, they are homed in the ;; LUCID-COMMON-LISP package. (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as LUCID::, whereas in 3.0 lisps, they have to be ;; accessed as SYS: (mapc importer '( "NEW-STRUCTURE" "STRUCTURE-REF" "STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH" "PROCEDUREP" "PROCEDURE-SYMBOL" "PROCEDURE-REF" "SET-PROCEDURE-REF" )) ; ;; ; ;; The following is for the "patch" to the general defstruct printer. ; (mapc importer '( ; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO" ; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT" ; "STRUCTURE-TYPE" "*PRINT-OUTPUT*" ; )) ;; ;; The following is for a "patch" affecting compilation of %logand&. ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS ;; on *FEATURES*, so this conditionalizes correctly for APOLLO. #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) (mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC")) nil)) #+kcl (progn (import '(si:structurep si:structure-def si:structure-ref)) (shadow 'lisp:dotimes) ) #+kcl (in-package "SI") #+kcl (export '(%structure-name %compiled-function-name %set-compiled-function-name %instance-ref %set-instance-ref)) #+kcl (in-package 'pcl) #+cmu (shadow 'lisp:dotimes) #+cmu (import '(kernel:funcallable-instance-p) *the-pcl-package*) (shadow 'documentation) ;;; ;;; These come from the index pages of 88-002R. ;;; ;;; (eval-when (compile load eval) (defvar *exports* '(add-method built-in-class call-method call-next-method change-class class-name class-of compute-applicable-methods defclass defgeneric define-method-combination defmethod ensure-generic-function find-class find-method function-keywords generic-flet generic-labels 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-class standard-generic-function standard-method standard-object structure-class #-cmu17 symbol-macrolet update-instance-for-different-class update-instance-for-redefined-class with-accessors with-added-methods with-slots )) );eval-when #-(or KCL IBCL CMU) (export *exports* *the-pcl-package*) #+CMU (export '#.*exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *exports*) (list *the-pcl-package*)) (eval-when (compile load eval) (defvar *class-exports* '(standard-instance funcallable-standard-instance generic-function standard-generic-function method standard-method standard-accessor-method standard-reader-method standard-writer-method method-combination slot-definition direct-slot-definition effective-slot-definition standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition specializer eql-specializer built-in-class forward-referenced-class standard-class funcallable-standard-class)) (defvar *chapter-6-exports* '(add-dependent add-direct-method add-direct-subclass add-method allocate-instance class-default-initargs class-direct-default-initargs class-direct-slots class-direct-subclasses class-direct-superclasses class-finalized-p class-precedence-list class-prototype class-slots compute-applicable-methods compute-applicable-methods-using-classes compute-class-precedence-list compute-discriminating-function compute-effective-method compute-effective-slot-definition compute-slots direct-slot-definition-class effective-slot-definition-class ensure-class ensure-class-using-class ensure-generic-function ensure-generic-function-using-class eql-specializer-instance extract-lambda-list extract-specializer-names finalize-inheritance find-method-combination funcallable-standard-instance-access generic-function-argument-precedence-order generic-function-declarations generic-function-lambda-list generic-function-method-class generic-function-method-combination generic-function-methods generic-function-name intern-eql-specializer make-instance make-method-lambda map-dependents method-function method-generic-function method-lambda-list method-specializers method-qualifiers accessor-method-slot-definition reader-method-class remove-dependent remove-direct-method remove-direct-subclass remove-method set-funcallable-instance-function slot-boundp-using-class slot-definition-allocation slot-definition-initargs slot-definition-initform slot-definition-initfunction slot-definition-location slot-definition-name slot-definition-readers slot-definition-writers slot-definition-type slot-makunbound-using-class slot-value-using-class specializer-direct-generic-function specializer-direct-methods standard-instance-access update-dependent validate-superclass writer-method-class )) );eval-when #-(or KCL IBCL) (export *class-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *class-exports*) (list *the-pcl-package*)) #-(or KCL IBCL) (export *chapter-6-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*)) (defvar *slot-accessor-name-package* (or (find-package :slot-accessor-name) (make-package :slot-accessor-name :use '() :nicknames '(:s-a-n)))) #+kcl (when (get 'si::basic-wrapper 'si::s-data) (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI")) '(:copy-structure-header :swap-structure-contents :set-structure-def :%instance-ref :%set-instance-ref :cache-number-vector :cache-number-vector-length :wrapper-cache-number-adds-ok :wrapper-cache-number-length :wrapper-cache-number-mask :wrapper-cache-number-vector-length :wrapper-layout :wrapper-cache-number-vector :wrapper-state :wrapper-class :wrapper-length)))) gcl/pcl/gcl_pcl_fsc.lisp0000644000175000017500000000667112240167764014167 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS ;;; metaclass. Much of the implementation of this metaclass is actually ;;; defined on the class STD-CLASS. What appears in this file is a modest ;;; number of simple methods related to the low-level differences in the ;;; implementation of standard and funcallable-standard instances. ;;; ;;; As it happens, none of these differences are the ones reflected in ;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS ;;; share all their specified methods at STD-CLASS. ;;; ;;; ;;; workings of this metaclass and the standard-class metaclass. ;;; (in-package :pcl) (defmethod wrapper-fetcher ((class funcallable-standard-class)) 'fsc-instance-wrapper) (defmethod slots-fetcher ((class funcallable-standard-class)) 'fsc-instance-slots) (defmethod raw-instance-allocator ((class funcallable-standard-class)) 'allocate-funcallable-instance) ;;; ;;; ;;; (defmethod validate-superclass ((fsc funcallable-standard-class) (class standard-class)) t) ; was (null (wrapper-instance-slots-layout (class-wrapper class))) (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (allocate-funcallable-instance (class-wrapper class))) (defmethod make-reader-method-function ((class funcallable-standard-class) slot-name) (make-std-reader-method-function (class-name class) slot-name)) (defmethod make-writer-method-function ((class funcallable-standard-class) slot-name) (make-std-writer-method-function (class-name class) slot-name)) ;;;; ;;;; See the comment about reader-function--std and writer-function--sdt. ;;;; ;(define-function-template reader-function--fsc () '(slot-name) ; `(function ; (lambda (instance) ; (slot-value-using-class (wrapper-class (get-wrapper instance)) ; instance ; slot-name)))) ; ;(define-function-template writer-function--fsc () '(slot-name) ; `(function ; (lambda (nv instance) ; (setf ; (slot-value-using-class (wrapper-class (get-wrapper instance)) ; instance ; slot-name) ; nv)))) ; ;(eval-when (load) ; (pre-make-templated-function-constructor reader-function--fsc) ; (pre-make-templated-function-constructor writer-function--fsc)) gcl/pcl/gcl_pcl_cpl.lisp0000644000175000017500000002572212240167764014170 0ustar cammcamm;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; ;;; compute-class-precedence-list ;;; ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. ;;; ;;; The key idea is that we use class-precedence-description (CPD) structures ;;; to store the precedence information as we proceed. The CPD structure for ;;; a class stores two critical pieces of information: ;;; ;;; - a count of the number of "reasons" why the class can't go ;;; into the class precedence list yet. ;;; ;;; - a list of the "reasons" this class prevents others from ;;; going in until after it ;; ;;; A "reason" is essentially a single local precedence constraint. If a ;;; constraint between two classes arises more than once it generates more ;;; than one reason. This makes things simpler, linear, and isn't a problem ;;; as long as we make sure to keep track of each instance of a "reason". ;;; ;;; This code is divided into three phases. ;;; ;;; - the first phase simply generates the CPD's for each of the class ;;; and its superclasses. The remainder of the code will manipulate ;;; these CPDs rather than the class objects themselves. At the end ;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs ;;; of the direct superclasses of the class. ;;; ;;; - the second phase folds all the local constraints into the CPD ;;; structure. The CPD-COUNT of each CPD is built up, and the ;;; CPD-AFTER fields are augmented to include precedence constraints ;;; from the CPD-SUPERS field and from the order of classes in other ;;; CPD-SUPERS fields. ;;; ;;; After this phase, the CPD-AFTER field of a class includes all the ;;; direct superclasses of the class plus any class that immediately ;;; follows the class in the direct superclasses of another. There ;;; can be duplicates in this list. The CPD-COUNT field is equal to ;;; the number of times this class appears in the CPD-AFTER field of ;;; all the other CPDs. ;;; ;;; - In the third phase, classes are put into the precedence list one ;;; at a time, with only those classes with a CPD-COUNT of 0 being ;;; candidates for insertion. When a class is inserted , every CPD ;;; in its CPD-AFTER field has its count decremented. ;;; ;;; In the usual case, there is only one candidate for insertion at ;;; any point. If there is more than one, the specified tiebreaker ;;; rule is used to choose among them. ;;; (defmethod compute-class-precedence-list ((root slot-class)) (compute-std-cpl root (class-direct-superclasses root))) (defstruct (class-precedence-description (:conc-name nil) (:print-function (lambda (obj str depth) (declare (ignore depth)) (format str "#" (class-name (cpd-class obj)) (cpd-count obj)))) (:constructor make-cpd ())) (cpd-class nil) (cpd-supers ()) (cpd-after ()) (cpd-count 0 :type fixnum)) (defun compute-std-cpl (class supers) (cond ((null supers) ;First two branches of COND (list class)) ;are implementing the single ((null (cdr supers)) ;inheritance optimization. (cons class (compute-std-cpl (car supers) (class-direct-superclasses (car supers))))) (t (multiple-value-bind (all-cpds nclasses) (compute-std-cpl-phase-1 class supers) (compute-std-cpl-phase-2 all-cpds) (compute-std-cpl-phase-3 class all-cpds nclasses))))) (defvar *compute-std-cpl-class->entry-table-size* 60) (defun compute-std-cpl-phase-1 (class supers) (let ((nclasses 0) (all-cpds ()) (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test #'eq))) (declare (fixnum nclasses)) (labels ((get-cpd (c) (or (gethash c table) (setf (gethash c table) (make-cpd)))) (walk (c supers) (if (forward-referenced-class-p c) (cpl-forward-referenced-class-error class c) (let ((cpd (get-cpd c))) (unless (cpd-class cpd) ;If we have already done this ;class before, we can quit. (setf (cpd-class cpd) c) (incf nclasses) (push cpd all-cpds) (setf (cpd-supers cpd) (mapcar #'get-cpd supers)) (dolist (super supers) (walk super (class-direct-superclasses super)))))))) (walk class supers) (values all-cpds nclasses)))) (defun compute-std-cpl-phase-2 (all-cpds) (dolist (cpd all-cpds) (let ((supers (cpd-supers cpd))) (when supers (setf (cpd-after cpd) (nconc (cpd-after cpd) supers)) (incf (cpd-count (car supers)) 1) (do* ((t1 supers t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (incf (cpd-count (car t2)) 2) (push (car t2) (cpd-after (car t1)))))))) (defun compute-std-cpl-phase-3 (class all-cpds nclasses) (declare (fixnum nclasses)) (let ((candidates ()) (next-cpd nil) (rcpl ())) ;; ;; We have to bootstrap the collection of those CPD's that ;; have a zero count. Once we get going, we will maintain ;; this list incrementally. ;; (dolist (cpd all-cpds) (when (zerop (cpd-count cpd)) (push cpd candidates))) (loop (when (null candidates) ;; ;; If there are no candidates, and enough classes have been put ;; into the precedence list, then we are all done. Otherwise ;; it means there is a consistency problem. (if (zerop nclasses) (return (reverse rcpl)) (cpl-inconsistent-error class all-cpds))) ;; ;; Try to find the next class to put in from among the candidates. ;; If there is only one, its easy, otherwise we have to use the ;; famous RPG tiebreaker rule. There is some hair here to avoid ;; having to call DELETE on the list of candidates. I dunno if ;; its worth it but what the hell. ;; (setq next-cpd (if (null (cdr candidates)) (prog1 (car candidates) (setq candidates ())) (block tie-breaker (dolist (c rcpl) (let ((supers (class-direct-superclasses c))) (if (memq (cpd-class (car candidates)) supers) (return-from tie-breaker (pop candidates)) (do ((loc candidates (cdr loc))) ((null (cdr loc))) (let ((cpd (cadr loc))) (when (memq (cpd-class cpd) supers) (setf (cdr loc) (cddr loc)) (return-from tie-breaker cpd)))))))))) (decf nclasses) (push (cpd-class next-cpd) rcpl) (dolist (after (cpd-after next-cpd)) (when (zerop (decf (cpd-count after))) (push after candidates)))))) ;;; ;;; Support code for signalling nice error messages. ;;; (defun cpl-error (class format-string &rest format-args) (error "While computing the class precedence list of the class ~A.~%~A" (if (class-name class) (format nil "named ~S" (class-name class)) class) (apply #'format nil format-string format-args))) (defun cpl-forward-referenced-class-error (class forward-class) (flet ((class-or-name (class) (if (class-name class) (format nil "named ~S" (class-name class)) class))) (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))) (cpl-error class "The class ~A is a forward referenced class.~@ The class ~A is ~A." (class-or-name forward-class) (class-or-name forward-class) (if (null (cdr names)) (format nil "a direct superclass of the class ~A" (class-or-name class)) (format nil "reached from the class ~A by following~@ the direct superclass chain through: ~A~ ~% ending at the class ~A" (class-or-name class) (format nil "~{~% the class ~A,~}" (butlast names)) (car (last names)))))))) (defun find-superclass-chain (bottom top) (labels ((walk (c chain) (if (eq c top) (return-from find-superclass-chain (nreverse chain)) (dolist (super (class-direct-superclasses c)) (walk super (cons super chain)))))) (walk bottom (list bottom)))) (defun cpl-inconsistent-error (class all-cpds) (let ((reasons (find-cycle-reasons all-cpds))) (cpl-error class "It is not possible to compute the class precedence list because~@ there ~A in the local precedence relations.~@ ~A because:~{~% ~A~}." (if (cdr reasons) "are circularities" "is a circularity") (if (cdr reasons) "These arise" "This arises") (format-cycle-reasons (apply #'append reasons))))) (defun format-cycle-reasons (reasons) (flet ((class-or-name (cpd) (let ((class (cpd-class cpd))) (if (class-name class) (format nil "named ~S" (class-name class)) class)))) (mapcar #'(lambda (reason) (ecase (caddr reason) (:super (format nil "the class ~A appears in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)))) (:in-supers (format nil "the class ~A follows the class ~A in the supers of the class ~A" (class-or-name (cadr reason)) (class-or-name (car reason)) (class-or-name (cadddr reason)))))) reasons))) (defun find-cycle-reasons (all-cpds) (let ((been-here ()) ;List of classes we have visited. (cycle-reasons ())) (labels ((chase (path) (if (memq (car path) (cdr path)) (record-cycle (memq (car path) (nreverse path))) (unless (memq (car path) been-here) (push (car path) been-here) (dolist (after (cpd-after (car path))) (chase (cons after path)))))) (record-cycle (cycle) (let ((reasons ())) (do* ((t1 cycle t2) (t2 (cdr t1) (cdr t1))) ((null t2)) (let ((c1 (car t1)) (c2 (car t2))) (if (memq c2 (cpd-supers c1)) (push (list c1 c2 :super) reasons) (dolist (cpd all-cpds) (when (memq c2 (memq c1 (cpd-supers cpd))) (return (push (list c1 c2 :in-supers cpd) reasons))))))) (push (nreverse reasons) cycle-reasons)))) (dolist (cpd all-cpds) (unless (zerop (cpd-count cpd)) (chase (list cpd)))) cycle-reasons))) gcl/pcl/sys-proclaim.lisp0000644000175000017500000025751312240167764014356 0ustar cammcamm (IN-PACKAGE "PCL") (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) ONE-INDEX-LIMIT-FN N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN PV-CACHE-LIMIT-FN ARG-INFO-NUMBER-REQUIRED DEFAULT-LIMIT-FN CACHE-COUNT CACHING-LIMIT-FN PV-TABLE-PV-SIZE EARLY-CLASS-SIZE CPD-COUNT FAST-INSTANCE-BOUNDP-INDEX)) (PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) (PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN METHOD-CALL-FUNCTION FAST-METHOD-CALL-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING)) (PROCLAIM '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW PV-TABLE-SLOT-NAME-LISTS PV-TABLE-CALL-LIST)) (PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP)) (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) (PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME MAKE-KEYWORD)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) COMPUTE-PRIMARY-CACHE-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (T) (OR CACHE NULL)) PV-TABLE-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| BOOTSTRAP-ACCESSOR-DEFINITION GET-ACCESSOR-METHOD-FUNCTION EMIT-CHECKING-OR-CACHING EMIT-CHECKING-OR-CACHING-FUNCTION SETF-SLOT-VALUE-USING-CLASS-DFUN LOAD-SHORT-DEFCOMBIN INITIALIZE-INSTANCE-SIMPLE-FUNCTION MAKE-SHARED-INITIALIZE-FORM-LIST MAKE-ONE-CLASS-ACCESSOR-DFUN MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN MAKE-FINAL-CHECKING-DFUN ACCESSOR-VALUES SET-CLASS-SLOT-VALUE-1 GENERATE-DISCRIMINATION-NET REAL-MAKE-METHOD-LAMBDA ORDER-SPECIALIZERS ACCESSOR-MISS |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) LOAD-DEFGENERIC TYPES-FROM-ARGUMENTS MAKE-DEFAULT-INITARGS-FORM-LIST MAKE-FINAL-ACCESSOR-DFUN MAKE-ACCESSOR-TABLE GET-SIMPLE-INITIALIZATION-FUNCTION GET-COMPLEX-INITIALIZATION-FUNCTIONS COMPUTE-SECONDARY-DISPATCH-FUNCTION SLOT-VALUE-OR-DEFAULT MAKE-EFFECTIVE-METHOD-FUNCTION GET-EFFECTIVE-METHOD-FUNCTION MAKE-N-N-ACCESSOR-DFUN MAKE-CHECKING-DFUN NESTED-WALK-FORM)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) *) MEMF-CODE-CONVERTER CACHE-MISS-VALUES-INTERNAL GENERATE-DISCRIMINATION-NET-INTERNAL MAKE-LONG-METHOD-COMBINATION-FUNCTION DO-SHORT-METHOD-COMBINATION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) *) MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS GET-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) EMIT-ONE-OR-N-INDEX-READER/WRITER GENERATING-LISP EMIT-READER/WRITER-FUNCTION EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION WALKER::WALK-LET-IF SET-SLOT-VALUE CONVERT-METHODS |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| CHECK-METHOD-ARG-INFO |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| LOAD-LONG-DEFCOMBIN MAKE-FINAL-N-N-ACCESSOR-DFUN |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| MAKE-FINAL-CACHING-DFUN MAKE-FINAL-CONSTANT-VALUE-DFUN GET-CLASS-SLOT-VALUE-1 ACCESSOR-VALUES-INTERNAL MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES CONSTANT-VALUE-MISS CACHING-MISS |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| CHECKING-MISS GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::WALK-GATHERING-BODY CACHE-MISS-VALUES MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION OPTIMIZE-SLOT-VALUE-BY-CLASS-P ACCESSOR-VALUES1 EMIT-READER/WRITER)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) *) |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL ADD-METHOD-DECLARATIONS WALK-METHOD-LAMBDA MAKE-TWO-CLASS-ACCESSOR-DFUN |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| ITERATE::ITERATE-TRANSFORM-BODY)) (PROCLAIM '(FTYPE (FUNCTION (T) NON-NEGATIVE-FIXNUM) CACHE-NLINES CACHE-MAX-LOCATION CACHE-SIZE CACHE-MASK)) (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| WALKER::WALK-MULTIPLE-VALUE-BIND |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| WALKER::WALK-SETQ |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| STANDARD-COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SYMBOL-MACROLET PRINT-CACHE MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION WALKER::RECONS EMIT-BOUNDP-CHECK ITERATE::OPTIMIZE-GATHERING-FORM WALKER::WALK-DO WALKER::WALK-MULTIPLE-VALUE-SETQ WALKER::WALK-DO* |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| WALKER::WALK-PROG |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| WALKER::WALK-NAMED-LAMBDA |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| WALKER::WALK-PROG* |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| EXPAND-DEFGENERIC COMPUTE-EFFECTIVE-METHOD NOTE-PV-TABLE-REFERENCE |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| WALKER::RELIST-INTERNAL INITIALIZE-INTERNAL-SLOT-GFS* OPTIMIZE-SLOT-VALUE |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P MAKE-DFUN-CALL |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| WALKER::WALK-TAGBODY-1 |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| OPTIMIZE-SET-SLOT-VALUE SORT-APPLICABLE-METHODS WALKER::WALK-LAMBDA SORT-METHODS |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| FIRST-FORM-TO-LISP OPTIMIZE-GF-CALL-INTERNAL ITERATE::OPTIMIZE-ITERATE-FORM DECLARE-STRUCTURE WRAP-METHOD-GROUP-SPECIFIER-BINDINGS WALKER::WALK-COMPILER-LET MAKE-TOP-LEVEL-FORM OPTIMIZE-SLOT-BOUNDP INVALIDATE-WRAPPER |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| EMIT-GREATER-THAN-1-DLAP |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| EMIT-1-T-DLAP ITERATE::SIMPLE-EXPAND-GATHERING-FORM MAKE-METHOD-INITARGS-FORM-INTERNAL ITERATE::RENAME-AND-CAPTURE-VARIABLES ITERATE::VARIABLE-SAME-P ENTRY-IN-CACHE-P CONVERT-TABLE GET-FUNCTION-GENERATOR MAKE-METHOD-SPEC GET-NEW-FUNCTION-GENERATOR TRACE-EMF-CALL-INTERNAL TRACE-METHOD-INTERNAL FLUSH-CACHE-TRAP ONE-INDEX-DFUN-INFO SET-FUNCTION-NAME-1 ONE-CLASS-DFUN-INFO OBSOLETE-INSTANCE-TRAP |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| COMPUTE-PRECEDENCE MAP-ALL-ORDERS PRINT-STD-INSTANCE CAN-OPTIMIZE-ACCESS |SETF PCL METHOD-FUNCTION-GET| SKIP-FAST-SLOT-ACCESS-P |SETF PCL PLIST-VALUE| WALKER::WALK-UNEXPECTED-DECLARE WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| WALKER::WALK-MACROLET |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| VARIABLE-DECLARATION FIX-SLOT-ACCESSORS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) EXPAND-SYMBOL-MACROLET-INTERNAL |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| BOOTSTRAP-SET-SLOT EXPAND-DEFCLASS |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| WALKER::WALK-TEMPLATE |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| MAKE-DISPATCH-LAMBDA |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| MAKE-EFFECTIVE-METHOD-FUNCTION1 MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE MEMF-TEST-CONVERTER LOAD-PRECOMPILED-DFUN-CONSTRUCTOR TWO-CLASS-DFUN-INFO WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 OPTIMIZE-READER OPTIMIZE-WRITER |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| MAYBE-EXPAND-ACCESSOR-FORM |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| INITIALIZE-INSTANCE-SIMPLE |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| GET-WRAPPERS-FROM-CLASSES |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| LOAD-PRECOMPILED-IIS-ENTRY FILL-CACHE-P ADJUST-CACHE |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| EXPAND-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) LOAD-DEFMETHOD MAKE-DEFMETHOD-FORM MAKE-DEFMETHOD-FORM-INTERNAL EARLY-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE EARLY-ADD-NAMED-METHOD REAL-ADD-NAMED-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T) T) GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) UPDATE-SLOTS-IN-PV MAKE-PARAMETER-REFERENCES MAKE-EMF-CACHE GET-MAKE-INSTANCE-FUNCTION-INTERNAL |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| MAKE-INSTANCE-FUNCTION-COMPLEX |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| MAKE-INSTANCE-FUNCTION-SIMPLE |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| OPTIMIZE-GENERIC-FUNCTION-CALL REAL-MAKE-METHOD-INITARGS-FORM |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| LOAD-FUNCTION-GENERATOR EXPAND-EMF-CALL-METHOD MAKE-FGEN BOOTSTRAP-MAKE-SLOT-DEFINITIONS BOOTSTRAP-ACCESSOR-DEFINITIONS1 MAKE-FINAL-ORDINARY-DFUN-INTERNAL WALKER::WALK-TEMPLATE-HANDLE-REPEAT COMPUTE-PV-SLOT WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS OPTIMIZE-ACCESSOR-CALL MAKE-METHOD-INITARGS-FORM-INTERNAL1)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) GET-METHOD CHECK-INITARGS-2-PLIST CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST MAKE-EMF-CALL CAN-OPTIMIZE-ACCESS1 EMIT-FETCH-WRAPPER FILL-CACHE REAL-GET-METHOD CHECK-INITARGS-1)) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) ENSURE-GENERIC-FUNCTION-USING-CLASS MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE MAKE-EMF-FROM-METHOD EXPAND-EFFECTIVE-METHOD-FUNCTION NAMED-OBJECT-PRINT-FUNCTION FIND-CLASS-FROM-CELL FIND-CLASS-PREDICATE-FROM-CELL INITIALIZE-INFO GET-EFFECTIVE-METHOD-FUNCTION1 GET-DECLARATION GET-METHOD-FUNCTION-PV-CELL EMIT-MISS METHOD-FUNCTION-GET PROBE-CACHE MAP-CACHE PRECOMPUTE-EFFECTIVE-METHODS RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR REAL-ADD-METHOD REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION REAL-ENSURE-GF-USING-CLASS--NULL COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T T *) T) BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) REAL-LOAD-DEFCLASS WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 BOOTSTRAP-MAKE-SLOT-DEFINITION EMIT-SLOT-ACCESS OPTIMIZE-GF-CALL SET-ARG-INFO1 LOAD-DEFCLASS MAKE-EARLY-CLASS-DEFINITION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) T) |(FAST-METHOD SLOT-MISSING (T T T T))| EXPAND-DEFMETHOD LOAD-DEFMETHOD-INTERNAL)) (PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) GET-CACHE FILL-CACHE-FROM-CACHE-P)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) EMIT-DLAP GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION NIL *) COUNT-ALL-DFUNS EMIT-N-N-READERS EMIT-N-N-WRITERS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR UNTRACE-METHOD LIST-LARGE-CACHES UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) (PROCLAIM '(FTYPE (FUNCTION NIL T) RENEW-SYS-FILES GET-EFFECTIVE-METHOD-GENSYM SHOW-EMF-CALL-TRACE BOOTSTRAP-META-BRAID BOOTSTRAP-BUILT-IN-CLASSES LIST-ALL-DFUNS DEFAULT-METHOD-ONLY-DFUN-INFO INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST CACHES-TO-ALLOCATE UPDATE-DISPATCH-DFUNS MAKE-CACHE IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P ALLOCATE-FUNCALLABLE-INSTANCE-2 %%ALLOCATE-INSTANCE--CLASS ALLOCATE-FUNCALLABLE-INSTANCE-1 DISPATCH-DFUN-INFO INITIAL-DISPATCH-DFUN-INFO INITIAL-DFUN-INFO NO-METHODS-DFUN-INFO SHOW-FREE-CACHE-VECTORS MAKE-CPD MAKE-ARG-INFO SHOW-DFUN-CONSTRUCTORS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) (PROCLAIM '(FTYPE (FUNCTION (T) *) EMIT-TWO-CLASS-WRITER EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS NET-CODE-CONVERTER EMIT-IN-CHECKING-CACHE-P COMPILE-IIS-FUNCTIONS ANALYZE-LAMBDA-LIST COMPUTE-APPLICABLE-METHODS-EMF GET-DISPATCH-FUNCTION GENERIC-FUNCTION-NAME-P MAKE-FINAL-DISPATCH-DFUN STRUCTURE-SLOTD-INIT-FORM PARSE-METHOD-GROUP-SPECIFIER METHOD-PROTOTYPE-FOR-GF EARLY-COLLECT-INHERITANCE TYPE-FROM-SPECIALIZER *NORMALIZE-TYPE DEFAULT-CODE-CONVERTER CONVERT-TO-SYSTEM-TYPE EMIT-CONSTANT-VALUE PCL-DESCRIBE GET-GENERIC-FUNCTION-INFO EARLY-METHOD-FUNCTION EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME SPECIALIZER-FROM-TYPE CLASS-EQ-TYPE STRUCTURE-WRAPPER FIND-STRUCTURE-CLASS MAKE-DISPATCH-DFUN FIND-WRAPPER PARSE-DEFMETHOD PROTOTYPES-FOR-MAKE-METHOD-LAMBDA EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER EMIT-TWO-CLASS-READER)) (PROCLAIM '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO| |__si::MAKE-NO-METHODS| |__si::MAKE-INITIAL| |__si::MAKE-INITIAL-DISPATCH| |__si::MAKE-DISPATCH| |__si::MAKE-DEFAULT-METHOD-ONLY| |__si::MAKE-ACCESSOR-DFUN-INFO| |__si::MAKE-ONE-INDEX-DFUN-INFO| MAKE-FAST-METHOD-CALL |__si::MAKE-N-N| MAKE-FAST-INSTANCE-BOUNDP |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS| |__si::MAKE-ONE-INDEX| |__si::MAKE-CHECKING| |__si::MAKE-ARG-INFO| FIX-EARLY-GENERIC-FUNCTIONS STRING-APPEND |__si::MAKE-CACHING| |__si::MAKE-CONSTANT-VALUE| FALSE |STRUCTURE-OBJECT class constructor| PV-WRAPPERS-FROM-PV-ARGS MAKE-PV-TABLE |__si::MAKE-PV-TABLE| INTERN-PV-TABLE CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-STD-INSTANCE| MAKE-INITIALIZE-INFO |__si::MAKE-CACHE| MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| MAKE-METHOD-CALL USE-PACKAGE-PCL ZERO TRUE)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) T) VARIABLE-GLOBALLY-SPECIAL-P SYSTEM:%STRUCTURE-NAME SYSTEM:%COMPILED-FUNCTION-NAME CLASS-OF ALLOCATE-CACHE-VECTOR SORT-SLOTS TWO-CLASS-WRAPPER0 CPD-AFTER GF-INFO-SIMPLE-ACCESSOR-TYPE SORT-CALLS FLUSH-CACHE-VECTOR-INTERNAL INTERN-EQL-SPECIALIZER EXPAND-SHORT-DEFCOMBIN COMPUTE-LINE-SIZE SYMBOL-PKG-NAME ONE-INDEX-CACHE MAKE-CALL-METHODS EXTRACT-LAMBDA-LIST GF-PRECOMPUTE-DFUN-AND-EMF-P CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P EARLY-CLASS-NAME DEFAULT-CONSTANT-CONVERTER CANONICAL-SLOT-NAME INITIALIZE-INFO-BOUND-SLOTS ONE-INDEX-ACCESSOR-TYPE EARLY-CLASS-SLOTDS COMPILE-LAMBDA-UNCOMPILED INITIALIZE-INFO-CACHED-VALID-P GF-INFO-STATIC-C-A-M-EMF INITIAL-DISPATCH-P ONE-INDEX-INDEX GET-MAKE-INSTANCE-FUNCTIONS GF-LAMBDA-LIST DISPATCH-P EXTRACT-PARAMETERS CHECKING-P CHECK-WRAPPER-VALIDITY METHOD-FUNCTION-PLIST EXTRACT-SPECIALIZER-NAMES ECD-CLASS-NAME CLASS-PREDICATE ARG-INFO-KEYWORDS INITIAL-DISPATCH-CACHE UNPARSE-SPECIALIZERS EARLY-GF-NAME EXTRACT-REQUIRED-PARAMETERS CHECK-CACHE %SYMBOL-FUNCTION ACCESSOR-DFUN-INFO-P MAKE-CLASS-EQ-PREDICATE FIND-CYCLE-REASONS FINAL-ACCESSOR-DFUN-TYPE FORMAT-CYCLE-REASONS TWO-CLASS-WRAPPER1 COPY-CACHE COMPLICATED-INSTANCE-CREATION-METHOD INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION MAKE-EQL-PREDICATE DISPATCH-CACHE INITIAL-CACHE DEFAULT-STRUCTUREP GF-DFUN-CACHE CHECKING-FUNCTION NEXT-WRAPPER-FIELD UPDATE-GF-INFO WALKER::ENV-LEXICAL-VARIABLES BOOTSTRAP-ACCESSOR-DEFINITIONS CLASS-FROM-TYPE CACHE-OWNER CACHING-DFUN-INFO INITIALIZE-INFO-KEY STRUCTURE-SLOTD-TYPE DEFAULT-STRUCTURE-INSTANCE-P INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION BOOTSTRAP-CLASS-PREDICATES EARLY-CLASS-DEFINITION DEFAULT-STRUCTURE-TYPE GF-DFUN-INFO GET-BUILT-IN-CLASS-SYMBOL DEFAULT-METHOD-ONLY-CACHE STRUCTURE-TYPE FGEN-GENERATOR INITIALIZE-INFO-WRAPPER DNET-METHODS-P COMPUTE-STD-CPL-PHASE-2 COMPUTE-APPLICABLE-METHODS-EMF-STD-P GET-BUILT-IN-WRAPPER-SYMBOL SETFBOUNDP NET-TEST-CONVERTER INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL GET-PV-CELL-FOR-CLASS ECD-SOURCE DO-STANDARD-DEFSETF-1 METHOD-CALL-P FAST-INSTANCE-BOUNDP-P ACCESSOR-DFUN-INFO-CACHE WALKER::GET-WALKER-TEMPLATE FGEN-SYSTEM GET-SETF-FUNCTION-NAME MAKE-INSTANCE-FUNCTION-SYMBOL CONSTANT-VALUE-DFUN-INFO INTERN-FUNCTION-NAME METHOD-FUNCTION-FROM-FAST-FUNCTION MAKE-FUNCTION-INLINE INTERNED-SYMBOL-P INITIALIZE-INFO-CACHED-RI-VALID-P ECD-METACLASS UPDATE-ALL-C-A-M-GF-INFO STRUCTURE-SLOT-BOUNDP CHECKING-CACHE ONE-INDEX-DFUN-INFO-CACHE METHOD-FUNCTION-PV-TABLE LIST-DFUN EARLY-SLOT-DEFINITION-NAME UPDATE-PV-TABLE-CACHE-INFO USE-CACHING-DFUN-P RESET-CLASS-INITIALIZE-INFO-1 CONSTANT-VALUE-CACHE ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE LIST-LARGE-CACHE GDEFINITION INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST CPD-CLASS DFUN-INFO-CACHE FUNCTION-RETURNING-NIL EARLY-CLASS-SLOTS METHOD-CALL-CALL-METHOD-ARGS METHOD-FUNCTION-METHOD SLOT-READER-SYMBOL %FBOUNDP MAKE-PV-TYPE-DECLARATION NO-METHODS-CACHE COMPILE-LAMBDA-DEFERRED FREE-CACHE KEYWORD-SPEC-NAME STORE-FGEN UPDATE-CLASS-CAN-PRECEDE-P INITIALIZE-INFO-CACHED-NEW-KEYS EARLY-CLASS-PRECEDENCE-LIST ARG-INFO-APPLYP ITERATE::SEQUENCE-ACCESSOR WRAPPER-FIELD N-N-CACHE GF-INFO-C-A-M-EMF-STD-P SLOT-BOUNDP-SYMBOL CLASS-PRECEDENCE-DESCRIPTION-P MAKE-CALLS-TYPE-DECLARATION GBOUNDP PARSE-SPECIALIZERS CACHING-DFUN-COST METHODS-CONTAIN-EQL-SPECIALIZER-P FUNCALLABLE-INSTANCE-P %STD-INSTANCE-WRAPPER STRUCTURE-TYPE-INTERNAL-SLOTDS GENERIC-CLOBBERS-FUNCTION INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS ACCESSOR-DFUN-INFO-ACCESSOR-TYPE GMAKUNBOUND MAP-SPECIALIZERS UNENCAPSULATED-FDEFINITION ONE-INDEX-DFUN-INFO-P SHOW-DFUN-COSTS N-N-ACCESSOR-TYPE MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION RESET-INITIALIZE-INFO INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION MAKE-TYPE-PREDICATE METHOD-FUNCTION-NEEDS-NEXT-METHODS-P %STD-INSTANCE-SLOTS GF-INFO-FAST-MF-P FAST-METHOD-CALL-PV-CELL DFUN-INFO-P ECD-CANONICAL-SLOTS MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION SLOT-VECTOR-SYMBOL UPDATE-GF-SIMPLE-ACCESSOR-TYPE CCLOSUREP RESET-CLASS-INITIALIZE-INFO WRAPPER-FOR-STRUCTURE FTYPE-DECLARATION-FROM-LAMBDA-LIST EVAL-FORM EARLY-SLOT-DEFINITION-LOCATION CPD-SUPERS NO-METHODS-P PV-TABLEP UNDEFMETHOD-1 ONE-CLASS-CACHE WALKER::ENV-WALK-FUNCTION EARLY-METHOD-QUALIFIERS WALKER::ENV-LOCK MAKE-PERMUTATION-VECTOR FGEN-GENSYMS MAP-ALL-GENERIC-FUNCTIONS GET-CACHE-VECTOR FAST-METHOD-CALL-NEXT-METHOD-CALL WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE ONE-INDEX-DFUN-INFO-INDEX UPDATE-GFS-OF-CLASS DEFAULT-TEST-CONVERTER TWO-CLASS-P STD-INSTANCE-P EARLY-COLLECT-CPL ONE-CLASS-ACCESSOR-TYPE STRUCTURE-TYPE-INCLUDED-TYPE-NAME PROCLAIM-INCOMPATIBLE-SUPERCLASSES DEFAULT-CONSTANTP STRUCTURE-OBJECT-P COUNT-DFUN FAST-METHOD-CALL-P CONSTANT-SYMBOL-P ONE-CLASS-INDEX INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION ECD-OTHER-INITARGS CACHING-P EXPAND-LONG-DEFCOMBIN EARLY-COLLECT-SLOTS COMPUTE-MCASE-PARAMETERS ARG-INFO-LAMBDA-LIST BUILT-IN-WRAPPER-OF MAKE-INITIAL-DFUN WRAPPER-OF STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST EXPAND-MAKE-INSTANCE-FORM FREE-CACHE-VECTOR MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION MAKE-INITFUNCTION TWO-CLASS-CACHE DO-STANDARD-DEFSETFS-FOR-DEFCLASS SLOT-INITARGS-FROM-STRUCTURE-SLOTD GFS-OF-TYPE INITIAL-P ARG-INFO-P COMPUTE-CLASS-SLOTS ARG-INFO-PRECEDENCE BUILT-IN-OR-STRUCTURE-WRAPPER1 DEFAULT-METHOD-ONLY-P EARLY-METHOD-STANDARD-ACCESSOR-P CACHE-P MAKE-CONSTANT-FUNCTION STRUCTURE-SLOTD-READER-FUNCTION N-N-P MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION TWO-CLASS-ACCESSOR-TYPE STANDARD-SVUC-METHOD TYPE-CLASS LEGAL-CLASS-NAME-P EARLY-CLASS-NAME-OF EARLY-METHOD-LAMBDA-LIST MAKE-PV-TABLE-TYPE-DECLARATION ARG-INFO-METATYPES TWO-CLASS-INDEX FGEN-TEST FUNCTION-PRETTY-ARGLIST STRUCTURE-SLOTD-NAME FUNCTION-RETURNING-T METHOD-LL->GENERIC-FUNCTION-LL EARLY-CLASS-DIRECT-SUBCLASSES ITERATE::VARIABLES-FROM-LET GET-MAKE-INSTANCE-FUNCTION-SYMBOL INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION ONE-CLASS-WRAPPER0 STRUCTURE-TYPE-P FORCE-CACHE-FLUSHES ARG-INFO-VALID-P GET-MAKE-INSTANCE-FUNCTION FGEN-GENERATOR-LAMBDA EARLY-ACCESSOR-METHOD-SLOT-NAME STRUCTURE-SLOTD-ACCESSOR-SYMBOL FAST-METHOD-CALL-ARG-INFO WALKER::ENV-WALK-FORM %CCLOSURE-ENV CONSTANT-VALUE-P SLOT-WRITER-SYMBOL DFUN-ARG-SYMBOL CACHING-CACHE ARG-INFO-NUMBER-OPTIONAL EARLY-COLLECT-DEFAULT-INITARGS SFUN-P MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION STRUCTURE-SVUC-METHOD EARLY-METHOD-CLASS USE-DEFAULT-METHOD-ONLY-DFUN-P LOOKUP-FGEN ARG-INFO-KEY/REST-P ARG-INFO-NKEYS DEFAULT-SECONDARY-DISPATCH-FUNCTION INITIALIZE-INFO-CACHED-CONSTANTS INITIALIZE-INFO-P EARLY-GF-P INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST WALKER::ENV-DECLARATIONS ONE-INDEX-P ECD-SUPERCLASS-NAMES STRUCTURE-SLOTD-WRITER-FUNCTION ONE-CLASS-P UPDATE-C-A-M-GF-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) WALK-FORM MACROEXPAND-ALL ENSURE-GENERIC-FUNCTION COERCE-TO-CLASS GET-METHOD-FUNCTION GET-FUNCTION GET-FUNCTION1 PARSE-METHOD-OR-SPEC EXTRACT-DECLARATIONS GET-DFUN-CONSTRUCTOR MAP-ALL-CLASSES MAKE-CACHING-DFUN MAKE-METHOD-FUNCTION-INTERNAL PARSE-SPECIALIZED-LAMBDA-LIST MAKE-METHOD-LAMBDA-INTERNAL MAKE-CONSTANT-VALUE-DFUN MAKE-FINAL-DFUN-INTERNAL COMPILE-LAMBDA DISPATCH-DFUN-COST MAKE-INSTANCE-1 ENSURE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) CAPITALIZE-WORDS INITIALIZE-INTERNAL-SLOT-GFS MAKE-TYPE-PREDICATE-NAME SET-DFUN TRACE-METHOD FIND-CLASS-CELL MAKE-FINAL-DFUN PV-TABLE-LOOKUP-PV-ARGS USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS USE-CONSTANT-VALUE-DFUN-P MAKE-EARLY-GF ALLOCATE-FUNCALLABLE-INSTANCE SET-ARG-INFO INITIALIZE-METHOD-FUNCTION UPDATE-DFUN MAKE-SPECIALIZABLE ALLOCATE-STRUCTURE-INSTANCE WALKER::WALKER-ENVIRONMENT-BIND-1 ALLOCATE-STANDARD-INSTANCE ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN MAKE-WRAPPER FIND-CLASS)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) SLOT-BOUNDP SLOT-VALUE SLOT-MAKUNBOUND SAUT-CLASS SPECIALIZER-APPLICABLE-USING-TYPE-P COMPUTE-TEST GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE CLASS-APPLICABLE-USING-CLASS-P SAUT-AND SAUT-NOT SAUT-PROTOTYPE DESTRUCTURE ENSURE-CLASS-VALUES MAKE-DIRECT-SLOTD MAKE-INSTANCE-FUNCTION-TRAP GENERATE-FAST-CLASS-SLOT-ACCESS-P MUTATE-SLOTS-AND-CALLS INVOKE-EMF EMIT-DEFAULT-ONLY-FUNCTION SPLIT-DECLARATIONS EMIT-DEFAULT-ONLY SLOT-NAME-LISTS-FROM-SLOTS EMIT-CHECKING UPDATE-SLOT-VALUE-GF-INFO EMIT-CACHING SDFUN-FOR-CACHING SLOT-UNBOUND-INTERNAL SET-FUNCTION-NAME COMPUTE-STD-CPL-PHASE-1 FORM-LIST-TO-LISP FIND-SUPERCLASS-CHAIN SAUT-CLASS-EQ COMPUTE-APPLICABLE-METHODS-USING-TYPES CHECK-INITARGS-VALUES SAUT-EQL INSURE-DFUN *SUBTYPEP ITERATE::PARSE-DECLARATIONS INITIAL-DFUN)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) VARIABLE-LEXICAL-P WALKER::NOTE-DECLARATION VARIABLE-SPECIAL-P MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING MAKE-DLAP-LAMBDA-LIST ADD-DIRECT-SUBCLASSES COMPUTE-PV MAKE-DFUN-ARG-LIST COMPUTE-CALLS SYSTEM:%SET-COMPILED-FUNCTION-NAME MAKE-FAST-METHOD-CALL-LAMBDA-LIST UPDATE-ALL-PV-TABLE-CACHES UPDATE-CLASS MAP-PV-TABLE-REFERENCES-OF ADD-SLOT-ACCESSORS WALKER::ENVIRONMENT-FUNCTION REMOVE-DIRECT-SUBCLASSES REMOVE-SLOT-ACCESSORS SYMBOL-LESSP SYMBOL-OR-CONS-LESSP |SETF PCL FIND-CLASS| |SETF PCL FIND-CLASS-PREDICATE| PV-WRAPPERS-FROM-ALL-ARGS PV-TABLE-LOOKUP PROCLAIM-DEFGENERIC UPDATE-CPL LIST-EQ UPDATE-SLOTS COMPUTE-APPLICABLE-METHODS-FUNCTION UPDATE-INITS UPDATE-STD-OR-STR-METHODS SET-STANDARD-SVUC-METHOD EMIT-1-NIL-DLAP PLIST-VALUE SET-STRUCTURE-SVUC-METHOD EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES-INTERNAL EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES %SET-CCLOSURE-ENV MEC-ALL-CLASS-LISTS REDEFINE-FUNCTION METHODS-CONVERTER COMPUTE-LAYOUT NO-SLOT PV-WRAPPERS-FROM-ALL-WRAPPERS NET-CONSTANT-CONVERTER AUGMENT-TYPE CHANGE-CLASS-INTERNAL VALUE-FOR-CACHING |SETF PCL METHOD-FUNCTION-PLIST| GET-KEY-ARG GET-KEY-ARG1 SET-METHODS SET-FUNCTION-PRETTY-ARGLIST FIND-STANDARD-II-METHOD MAKE-EARLY-ACCESSOR DOCTOR-DFUN-FOR-THE-DEBUGGER COMPUTE-STD-CPL |SETF PCL GDEFINITION| MAKE-DISCRIMINATING-FUNCTION-ARGLIST ADD-FORMS CPL-INCONSISTENT-ERROR REDIRECT-EARLY-FUNCTION-INTERNAL ADD-TO-CVECTOR BOOTSTRAP-SLOT-INDEX QUALIFIER-CHECK-RUNTIME CPL-FORWARD-REFERENCED-CLASS-ERROR REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO CANONICALIZE-SLOT-SPECIFICATION CANONICALIZE-DEFCLASS-OPTION SET-WRAPPER DEAL-WITH-ARGUMENTS-OPTION PARSE-QUALIFIER-PATTERN SWAP-WRAPPERS-AND-SLOTS ADD-METHOD ITERATE::MV-SETQ MAKE-UNORDERED-METHODS-EMF CLASS-MIGHT-PRECEDE-P ITERATE::EXTRACT-SPECIAL-BINDINGS WALKER::VARIABLE-SYMBOL-MACRO-P RAISE-METATYPE PROCLAIM-DEFMETHOD FDEFINE-CAREFULLY MAKE-INTERNAL-READER-METHOD-FUNCTION MAKE-STD-READER-METHOD-FUNCTION MAKE-STD-WRITER-METHOD-FUNCTION ITERATE::SIMPLE-EXPAND-ITERATE-FORM MAKE-STD-BOUNDP-METHOD-FUNCTION DO-SATISFIES-DEFTYPE MEMF-CONSTANT-CONVERTER COMPUTE-CONSTANTS CLASS-CAN-PRECEDE-P SAUT-NOT-CLASS SAUT-NOT-CLASS-EQ SAUT-NOT-PROTOTYPE GF-MAKE-FUNCTION-FROM-EMF SAUT-NOT-EQL SUPERCLASSES-COMPATIBLE-P FUNCALLABLE-STANDARD-INSTANCE-ACCESS CLASSES-HAVE-COMMON-SUBCLASS-P DESCRIBE-PACKAGE PRINTING-RANDOM-THING-INTERNAL MAKE-CLASS-PREDICATE METHOD-FUNCTION-RETURNING-NIL METHOD-FUNCTION-RETURNING-T VARIABLE-CLASS MAKE-PLIST SLOT-EXISTS-P REMTAIL DESTRUCTURE-INTERNAL ACCESSOR-MISS-FUNCTION UPDATE-INITIALIZE-INFO-INTERNAL N-N-DFUN-INFO MAKE-CAXR MAKE-CDXR STANDARD-INSTANCE-ACCESS CHECKING-DFUN-INFO MAKE-PV-TABLE-INTERNAL FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL REMOVE-METHOD SET-FUNCALLABLE-INSTANCE-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) (IN-PACKAGE "PCL") (DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)| |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| ADD-READER-METHOD SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT REMOVE-READER-METHOD |LISP::T class predicate| EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL |PCL::STANDARD-METHOD-COMBINATION class predicate| |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate| |PCL::STANDARD-SLOT-DEFINITION class predicate| |PCL::STANDARD-OBJECT class predicate| |(FAST-READER-METHOD SLOT-OBJECT METHOD)| |PCL::BUILT-IN-CLASS class predicate| SPECIALIZER-TYPE |LISP::RATIONAL class predicate| |LISP::RATIO class predicate| GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| CLASS-DEFSTRUCT-CONSTRUCTOR |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)| |(FAST-READER-METHOD SLOT-OBJECT SOURCE)| METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)| |(SETF GF-PRETTY-ARGLIST)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)| SPECIALIZERP EXACT-CLASS-SPECIALIZER-P |(FAST-READER-METHOD PCL-CLASS WRAPPER)| |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)| |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-READER-METHOD SLOT-OBJECT INITARGS)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)| |LISP::CHARACTER class predicate| COMPATIBLE-META-CLASS-CHANGE-P |LISP::SEQUENCE class predicate| |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)| |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)| |(BOUNDP READERS)| UPDATE-GF-DFUN |(BOUNDP CLASS-PRECEDENCE-LIST)| |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP DOCUMENTATION)| |(BOUNDP LOCATION)| SPECIALIZER-OBJECT |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)| |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)| |PCL::PCL-CLASS class predicate| |PCL::STD-CLASS class predicate| |(BOUNDP DEFSTRUCT-FORM)| |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| CLASS-EQ-SPECIALIZER-P |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD |(BOUNDP INITFUNCTION)| |(BOUNDP WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)| STRUCTURE-CLASS-P |(BOUNDP WRITERS)| |(BOUNDP INITFORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)| |LISP::BIT-VECTOR class predicate| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)| |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| DOCUMENTATION |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP FUNCTION)| |(BOUNDP LAMBDA-LIST)| METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)| |LISP::ARRAY class predicate| |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS |PCL::DEFINITION-SOURCE-MIXIN class predicate| |(BOUNDP DFUN-STATE)| |LISP::STRUCTURE-OBJECT class predicate| |(BOUNDP FROM-DEFCLASS-P)| |(READER METHOD)| |LISP::STANDARD-OBJECT class predicate| |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)| |(BOUNDP FAST-FUNCTION)| |LISP::COMPLEX class predicate| |(BOUNDP METHOD-CLASS)| |(READER SOURCE)| |(BOUNDP METHOD-COMBINATION)| |(BOUNDP INTERNAL-READER-FUNCTION)| |(BOUNDP INTERNAL-WRITER-FUNCTION)| ACCESSOR-METHOD-CLASS |(BOUNDP DIRECT-METHODS)| |(BOUNDP DIRECT-SLOTS)| |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP DIRECT-SUBCLASSES)| |(BOUNDP OPTIONS)| |(BOUNDP METHODS)| |(WRITER METHOD)| |LISP::BUILT-IN-CLASS class predicate| |PCL::DEPENDENT-UPDATE-MIXIN class predicate| GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| MAKE-BOUNDP-METHOD-FUNCTION |LISP::STRING class predicate| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |PCL::METAOBJECT class predicate| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| CLASS-PREDICATE-NAME |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-OBJECT class predicate| |LISP::SYMBOL class predicate| CLASSP |PCL::EFFECTIVE-SLOT-DEFINITION class predicate| |(COMBINED-METHOD SHARED-INITIALIZE)| LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P |LISP::VECTOR class predicate| |SETF PCL GENERIC-FUNCTION-NAME| |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| |(READER READERS)| DESCRIBE-OBJECT |(READER CLASS-PRECEDENCE-LIST)| |(READER ACCESSOR-FLAGS)| |(READER DOCUMENTATION)| |(READER LOCATION)| CLASS-INITIALIZE-INFO |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION |SETF PCL GF-DFUN-STATE| |(READER INCOMPATIBLE-SUPERCLASS-LIST)| |(READER SPECIALIZERS)| |(READER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF CLASS-INITIALIZE-INFO)| |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)| |SETF PCL CLASS-NAME| |SETF PCL SLOT-DEFINITION-NAME| |(WRITER READER-FUNCTION)| |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)| |(WRITER PREDICATE-NAME)| |(WRITER READERS)| |(READER INITFUNCTION)| |(READER WRITER-FUNCTION)| INITIALIZE-INTERNAL-SLOT-FUNCTIONS |SETF PCL SLOT-DEFINITION-TYPE| |(WRITER CLASS-PRECEDENCE-LIST)| |(READER WRITERS)| |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| METHOD-COMBINATION-P |(WRITER DOCUMENTATION)| |(WRITER LOCATION)| |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)| |SETF PCL METHOD-GENERIC-FUNCTION| |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| |SETF PCL GENERIC-FUNCTION-METHODS| |(READER SLOT-NAME)| |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL SLOT-ACCESSOR-STD-P| |(CALL REAL-MAKE-METHOD-INITARGS-FORM)| |(READER ALLOCATION)| |(WRITER SPECIALIZERS)| |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)| |(WRITER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF METHOD-GENERIC-FUNCTION)| LEGAL-SPECIALIZERS-P |(WRITER PRETTY-ARGLIST)| |SETF PCL OBJECT-PLIST| |LISP::FLOAT class predicate| |(WRITER DEFSTRUCT-FORM)| |(READER GENERIC-FUNCTION)| |(READER FUNCTION)| |(READER LAMBDA-LIST)| |(READER SLOT-DEFINITION)| |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate| |SETF PCL CLASS-DEFSTRUCT-FORM| |SETF PCL SLOT-DEFINITION-INITFORM| |(READER CAN-PRECEDE-LIST)| |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| |(READER PROTOTYPE)| |(WRITER INITFUNCTION)| |(WRITER WRITER-FUNCTION)| |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P |(WRITER INITFORM)| |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST| |SETF PCL SLOT-DEFINITION-INITFUNCTION| |SETF PCL SLOT-DEFINITION-ALLOCATION| |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-LOCATION| |SETF PCL SLOT-ACCESSOR-FUNCTION| |(WRITER SLOT-NAME)| |(BOUNDP NAME)| |(WRITER ALLOCATION)| |(READER FAST-FUNCTION)| |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| |(READER METHOD-COMBINATION)| |(READER INTERNAL-READER-FUNCTION)| |(READER INTERNAL-WRITER-FUNCTION)| METHOD-COMBINATION-OPTIONS |(READER DIRECT-METHODS)| |(READER DIRECT-SLOTS)| |SETF PCL SLOT-DEFINITION-READERS| |(READER BOUNDP-FUNCTION)| |(WRITER GENERIC-FUNCTION)| |(WRITER FUNCTION)| |(READER DIRECT-SUPERCLASSES)| |(READER DIRECT-SUBCLASSES)| |SETF PCL DOCUMENTATION| |(WRITER LAMBDA-LIST)| |LISP::LIST class predicate| FUNCALLABLE-STANDARD-CLASS-P |(BOUNDP CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)| |(WRITER SLOT-DEFINITION)| |(READER OPTIONS)| |(READER METHODS)| |(WRITER CAN-PRECEDE-LIST)| |SETF PCL SLOT-VALUE-USING-CLASS| |SETF PCL SLOT-DEFINITION-CLASS| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(WRITER PROTOTYPE)| |(BOUNDP OBJECT)| |(BOUNDP TYPE)| CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-SLOTS| |SETF PCL CLASS-DIRECT-SLOTS| SLOT-ACCESSOR-FUNCTION |(BOUNDP PLIST)| |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| |SETF PCL SLOT-DEFINITION-WRITERS| |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)| |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| |(BOUNDP SLOTS)| SLOT-CLASS-P MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |PCL::PLIST-MIXIN class predicate| |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)| |(WRITER METHOD-COMBINATION)| |(WRITER INTERNAL-READER-FUNCTION)| |(WRITER INTERNAL-WRITER-FUNCTION)| GET-METHOD |(WRITER DIRECT-METHODS)| |(WRITER DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)| |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUPERCLASSES)| |(WRITER DIRECT-SUBCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(WRITER OPTIONS)| |(WRITER METHODS)| SHORT-METHOD-COMBINATION-P GF-ARG-INFO SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM CLASS-DEFSTRUCT-FORM |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)| |(FAST-READER-METHOD SLOT-OBJECT NAME)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-READER-METHOD SLOT-DEFINITION NAME)| |(FAST-READER-METHOD CLASS NAME)| |(FAST-READER-METHOD CLASS PREDICATE-NAME)| |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)| |LISP::INTEGER class predicate| GF-PRETTY-ARGLIST SAME-SPECIALIZER-P SLOT-DEFINITION-INTERNAL-READER-FUNCTION SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION SLOT-DEFINITION-READER-FUNCTION SLOT-DEFINITION-WRITER-FUNCTION SLOT-DEFINITION-BOUNDP-FUNCTION |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-READER-METHOD SLOT-DEFINITION CLASS)| |(FAST-READER-METHOD SLOT-OBJECT CLASS)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)| |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-READER-METHOD SLOT-OBJECT LOCATION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)| |(FAST-READER-METHOD TRACED-METHOD FUNCTION)| |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)| |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-READER-METHOD SLOT-DEFINITION READERS)| |(FAST-READER-METHOD SLOT-OBJECT READERS)| |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-READER-METHOD SLOT-OBJECT WRITERS)| |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT OBJECT)| |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)| |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT TYPE)| |(FAST-READER-METHOD SLOT-DEFINITION TYPE)| |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)| |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-READER-METHOD SPECIALIZER TYPE)| |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-READER-METHOD SLOT-OBJECT INITFORM)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)| |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD PLIST-MIXIN PLIST)| |(FAST-READER-METHOD SLOT-OBJECT PLIST)| |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)| |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-READER-METHOD SLOT-OBJECT METHODS)| |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-CLASS SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT |PCL::DIRECT-SLOT-DEFINITION class predicate| CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)| |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-DIRECT-GENERIC-FUNCTIONS |(BOUNDP CLASS-EQ-SPECIALIZER)| |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)| |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(SETF SLOT-DEFINITION-CLASS)| |(SETF SLOT-VALUE-USING-CLASS)| |(SETF SLOT-DEFINITION-LOCATION)| |(SETF SLOT-DEFINITION-READER-FUNCTION)| |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-ALLOCATION)| |(SETF SLOT-DEFINITION-INITFUNCTION)| |(SETF SLOT-ACCESSOR-FUNCTION)| |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)| |(SETF SLOT-DEFINITION-READERS)| |(SETF SLOT-DEFINITION-WRITERS)| |(SETF SLOT-DEFINITION-TYPE)| |(SETF SLOT-DEFINITION-INITFORM)| |(BOUNDP INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION GENERIC-FUNCTION-P |PCL::SLOT-DEFINITION class predicate| |LISP::NULL class predicate| |(READER NAME)| |(READER CLASS)| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD SLOT-MISSING (T T T T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| LEGAL-SLOT-NAME-P |(READER OBJECT)| |(READER TYPE)| CLASS-WRAPPER |(READER PLIST)| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD DOCUMENTATION (T))| |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER OBJECT)| |(WRITER TYPE)| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| |(WRITER PLIST)| |(WRITER SLOTS)| |PCL::DOCUMENTATION-MIXIN class predicate| FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P LEGAL-QUALIFIER-P METHOD-P |PCL::SPECIALIZER-WITH-OBJECT class predicate| CLASS-SLOT-CELLS |(COMBINED-METHOD REINITIALIZE-INSTANCE)| |(COMBINED-METHOD INITIALIZE-INSTANCE)| STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| STANDARD-METHOD-P STANDARD-READER-METHOD-P STANDARD-GENERIC-FUNCTION-P |(READER WRAPPER)| |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| |(READER CLASS-EQ-SPECIALIZER)| COMPUTE-DEFAULT-INITARGS COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)| |(CALL REAL-MAKE-METHOD-LAMBDA)| |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-DIRECT-SLOTS)| |(SETF CLASS-SLOTS)| |(READER OPERATOR)| |(CALL REAL-ADD-METHOD)| |(CALL REAL-REMOVE-METHOD)| |(CALL REAL-GET-METHOD)| |(READER ARG-INFO)| METHOD-COMBINATION-TYPE |(READER DEFSTRUCT-CONSTRUCTOR)| |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)| STANDARD-CLASS-P |LISP::NUMBER class predicate| LEGAL-SPECIALIZER-P |PCL::LONG-METHOD-COMBINATION class predicate| |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)| |(WRITER CLASS-EQ-SPECIALIZER)| STANDARD-BOUNDP-METHOD-P |(SETF DOCUMENTATION)| RAW-INSTANCE-ALLOCATOR |SETF PCL CLASS-INITIALIZE-INFO| |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| |(WRITER OPERATOR)| |(WRITER ARG-INFO)| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO STANDARD-WRITER-METHOD-P CLASS-INCOMPATIBLE-SUPERCLASS-LIST |(WRITER DEFSTRUCT-CONSTRUCTOR)| |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER MAKE-A-METHOD |(WRITER INITIALIZE-INFO)| METHOD-COMBINATION-DOCUMENTATION |SETF PCL SLOT-DEFINITION-INITARGS| REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD |(WRITER INITARGS)| |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| |LISP::CONS class predicate| |(BOUNDP METHOD)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT NAME)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)| |(FAST-WRITER-METHOD CLASS NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)| SHORT-COMBINATION-OPERATOR |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)| |(FAST-WRITER-METHOD SLOT-OBJECT READERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)| |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)| |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)| |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)| REMOVE-NAMED-METHOD |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)| LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE READER-METHOD-CLASS REMOVE-METHOD SLOT-DEFINITION-INITFORM UPDATE-INSTANCE-FOR-REDEFINED-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P GENERIC-FUNCTION-NAME REMOVE-DEPENDENT COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION SHARED-INITIALIZE ADD-DIRECT-METHOD SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-ALLOCATION ADD-METHOD GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE SLOT-MAKUNBOUND-USING-CLASS ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD SLOT-DEFINITION-WRITERS COMPUTE-APPLICABLE-METHODS-USING-CLASSES CLASS-PRECEDENCE-LIST)) (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl/pcl/gcl_pcl_precom2.lisp0000644000175000017500000000226012240167764014751 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (precompile-random-code-segments pcl) gcl/pcl/test/0000755000175000017500000000000012240167764012005 5ustar cammcammgcl/pcl/test/make-test.lisp0000644000175000017500000000274212240167764014575 0ustar cammcamm(in-package :pcl) (defun top-level-form-form (form) #+cmu (if (and (consp form) (eq (car form) 'eval-when)) (third form) form) #+kcl (fourth (third form)) #+lcl3.0 (third (third form))) (defun make-test () (let ((table (make-hash-table :test 'eq)) (count 0)) (labels ((fixup (form) (if (consp form) (cons (fixup (car form)) (fixup (cdr form))) (if (and (symbolp form) (null (symbol-package form))) (or (gethash form table) (setf (gethash form table) (intern (format nil "~A-%-~D" (symbol-name form) (incf count)) *the-pcl-package*))) form)))) (with-open-file (out "test.lisp" :direction :output :if-exists :supersede) (declare (type stream out)) (let ((*print-case* :downcase) (*print-pretty* t) (*package* *the-pcl-package*)) (format out "~S~%" '(in-package :pcl)) (let ((i 0) (f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL)))) (dolist (form (cdr (top-level-form-form f))) (let ((name (intern (format nil "FGEN-~D" (incf i))))) (format out "~S~%" `(defun ,name () ,(fixup form)))))) (let ((i 0) (f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL)))) (dolist (form (cdr f)) (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i)))) (form (top-level-form-form form))) (format out "~S~%" `(defun ,name () (list ,(second form) ,(third form) ,(fixup (macroexpand (fifth form)))))))))))))) gcl/pcl/test/bench.lisp0000644000175000017500000004321312240167764013760 0ustar cammcamm;;;-*- Mode: Lisp; Syntax: Common-lisp; Package: user -*- (in-package :bench :use '(:lisp #-pcl :clos)) #+(and kcl pcl) (eval-when (compile load eval) (shadowing-import 'pcl::dotimes) ) #+pcl (eval-when (compile load eval) (pcl::use-package-pcl)) #-cmu (defmacro declaim (arg) `(proclaim ',arg)) ;;;Here are a few homebrew benchmarks for testing out Lisp performance. ;;; BENCH-THIS-LISP: benchmarks for common lisp. ;;; BENCH-THIS-CLOS: benchmarks for CLOS. ;;; BENCH-FLAVORS: ditto for Symbolics flavors. ;;; BE SURE TO CHANGE THE PACKAGE DEFINITION TO GET THE CLOS + LISP ;;; YOU WANT TO TEST. ;;; ;;;Each benchmark is reported as operations per second. Without-interrupts is ;;; used, so the scheduler isn't supposed to get in the way. Accuracy is ;;; generally between one and five percent. ;;; ;;;Elapsed time is measured using get-internal-run-time. Because the accuracy ;;; of this number is fairly crude, it is important to use a large number of ;;; iterations to get an accurate benchmark. The function median-time may ;;; complain to you if you didn't pick enough iterations. ;;; ;;;July 1992. Watch out! In some cases the instruction being timed will be ;;; optimized away by a clever compiler. Beware of benchmarks that are ;;; nearly as fast as *speed-of-empty-loop*. ;;; ;;;Thanks to Ken Anderson for much of this code. ;;; ;;; jeff morrill ;;; jmorrill@bbn.com #+Genera (eval-when (compile load eval) (import '(clos-internals::allocate-instance))) (declaim (optimize (speed 3) (safety 1) (space 0) #+lucid (compilation-speed 0))) ;;;********************************************************************* (deftype positive-integer () '(integer 0 *)) (deftype positive-fixnum () '(and fixnum positive-integer)) (defun repeat (fn n) (declare (type function fn) (type positive-integer n)) (multiple-value-bind (ngroups last) (floor n most-positive-fixnum) (declare (type positive-fixnum ngroups last)) (dotimes (i ngroups) (declare (type positive-fixnum i)) (dotimes (j most-positive-fixnum) (declare (fixnum j)) (funcall fn))) (dotimes (j last) (declare (type positive-fixnum j)) (funcall fn))) n) ;; Most compilers other than KCL have optimizers that make this technique ;; unreliable for simple forms. (eval-when (compile load eval) (declaim (fixnum *simple-repeat-count* *simple-iteration-count* *total-simple-iterations*)) (defparameter *simple-repeat-count* #-kcl 1 #+kcl 10) (defparameter *simple-iteration-count* #-kcl 1 #+kcl 10) (defparameter *total-simple-iterations* (* *simple-repeat-count* *simple-iteration-count*)) ) (defmacro simple-repeat (form) (if (eql *simple-iteration-count* 1) form (let ((result (make-symbol "RESULT"))) `(let ((,result nil)) (dotimes (.i. ,*simple-iteration-count* ,result) (declare (fixnum .i.)) ,@(let ((forms nil)) (dotimes (i *simple-repeat-count* forms) (push `(setq ,result ,form) forms)))))))) (defvar *use-gc-p* t) (defvar *estimated-bytes-per-call* 0) (defvar *bytes-per-word* 4) (declaim (type (and (integer 0 *) fixnum) *bytes-per-word* *estimated-bytes-per-call*)) (defmacro with-optional-gc-control (&body body) `(let (#+cmu (ext:*bytes-consed-between-gcs* (if *use-gc-p* (+ ext:*bytes-consed-between-gcs* (* *estimated-bytes-per-call* n)) ext:*bytes-consed-between-gcs*))) ,@body)) (declaim (single-float *min-time* *one-percent-of-min-time*)) (defvar *min-time* (max 1.0 (/ 400.0 (float internal-time-units-per-second))) "At least 2 orders of magnitude larger than our time resolution.") (defparameter *one-percent-of-min-time* (* *min-time* 0.01)) (defvar *elapsed-time-result*) (defun elapsed-time (function n) "Returns the time (seconds) it takes to call function n times." (declare (type function function) (integer n)) (when (and *use-gc-p* (plusp *estimated-bytes-per-call*)) #+cmu (lisp::gc nil)) (let ((start-time (get-internal-run-time))) (setq *elapsed-time-result* (repeat function n)) (let ((end-time (get-internal-run-time))) (/ (float (abs (- end-time start-time))) (float internal-time-units-per-second))))) (defmacro without-interruption (&body forms) #+genera `(scl:without-interrupts ,@forms) #+lucid `(lcl::with-scheduling-inhibited ,@forms) #+allegro `(excl:without-interrupts ,@forms) #+(and (not genera) (not lucid) (not allegro)) `(progn ,@forms)) (declaim (type (function (t function &optional fixnum t) single-float) median-time-internal)) (defvar *warn-if-too-fast-p* nil) (defun median-time-internal (form function n &optional (I 5) (warn-p *warn-if-too-fast-p*)) "Return the median time it takes to evaluate form." ;; I: number of samples to take. (declare (type function function) (fixnum i)) (without-interruption (funcall function) (let ((results nil)) (dotimes (ignore I) (declare (fixnum ignore)) (let ((time (elapsed-time function n))) (declare (single-float time)) (when (and (< time *min-time*) warn-p) (format t "~% Warning. Evaluating ~S took only ~S seconds.~ ~% You should probably use more iterations." form time)) (push time results))) (nth (truncate I 2) (sort results #'<))))) (defmacro median-time (form n &optional (I 5) (warn-p *warn-if-too-fast-p*)) "Return the median time it takes to evaluate form n times." ;; I: number of samples to take. `(median-time-internal ',form #'(lambda () (simple-repeat ,form)) (ceiling ,n ,*total-simple-iterations*) ,i ,warn-p)) #+debug (defun test () (median-time (sleep 1.0) 5)) ;;;********************************************************************* ;;; OPERATIONS-PER-SECOND actually does the work of computing a benchmark. ;;; The amount of time it takes to execute the form N times is recorded, ;;; minus the time it takes to execute the empty loop. OP/S = N/time. ;;; This quantity is recomputed five times and the median value is returned. ;;; Variance in the numbers increases when memory is being allocated (cons, ;;; make-instance, etc). (declaim (type (function (t function &optional fixnum integer) single-float) time-form-internal)) (defun time-form-internal (form function &optional (i 5) (default 100)) (declare (integer default) (fixnum i)) (with-optional-gc-control (let ((time (median-time-internal form function default i nil))) (declare (single-float time)) (loop (when (> time *one-percent-of-min-time*) (return nil)) (setq default (* default 10)) (setq time (median-time-internal form function default i nil))) (when (< time *min-time*) (setq default (ceiling default (/ time *min-time*))) (setq time (median-time-internal form function default i nil))) (/ time (float default))))) (defmacro time-form (form &optional (i 5)) `(/ (time-form-internal ',form #'(lambda () (simple-repeat ,form)) ,i) ,(float *total-simple-iterations*))) (defun compute-speed-of-empty-loop () (time-form nil)) (declaim (single-float *speed-of-empty-loop*)) (defparameter *speed-of-empty-loop* (compute-speed-of-empty-loop)) (format t "~%Empty loops per second: ~40T~8,3E~%" (/ 1.0 *speed-of-empty-loop*)) (defmacro operations-per-second (form &optional (i 5)) "Return the number of times FORM can evaluate in one second." `(/ 1.0 (- (time-form ,form ,i) *speed-of-empty-loop*))) (defmacro defun-timer (name args &body body) `(defun ,name ,args ,@body)) (defmacro bench (pretty-name name) `(progn (format t "~%~A: " ,pretty-name) (force-output) (format t "~40T~8,3E" (,name)))) ;;;**************************************************************************** ;;;BENCH-THIS-LISP ;#+bench-this-lisp (progn (defun-timer Nmult () (let ((a 2.1)) (operations-per-second (* a a)))) (defun-timer Nadd () (let ((a 2.1)) (operations-per-second (+ a a)))) (defun square (x) (* x x)) (defun-timer funcall-1 () ;; inlined (let ((x 2.1)) (operations-per-second (funcall #'(lambda (a) (* a a)) x)))) (defun f1 (n) n) (defun-timer funcall-2 () (let ((f #'f1) (x 2.1)) (operations-per-second (funcall f x)))) (defun-timer funcall-3 () (let ((x 2.1)) (operations-per-second (f1 x)))) (defun-timer funcall-4 () (let ((x 2.1)) (operations-per-second (funcall #'square x)))) (defun-timer funcall-5 () (let ((x 2.1) (f #'square)) (let ((g #'(lambda (x) (operations-per-second (funcall f x))))) (funcall g x)))) (defun-timer Nsetf () (let ((array (make-array 15))) (operations-per-second (setf (aref array 5) t)))) (defun-timer Nsymeval () (operations-per-second (eval T))) (defun-timer Repeatuations () (operations-per-second (eval '(* 2.1 2.1)))) (defun-timer n-cons () (let ((a 1)) (operations-per-second (cons a a)))) (defvar *object* t) (defun-timer nspecial () (operations-per-second (null *object*))) (defun-timer nlexical () (let ((o t)) (operations-per-second (null o)))) (defun-timer nfree () (let ((o t)) (let ((g #'(lambda () #+genera (declare (sys:downward-function)) (operations-per-second (null o))))) (funcall g)))) (defun-timer nfree2 () (let ((o t)) (let ((g #'(lambda () (let ((f #'(lambda () #+genera (declare (sys:downward-function)) (operations-per-second (null o))))) (funcall f))))) (funcall g)))) (defun-timer ncompilations () (let ((lambda-expression '(lambda (bar) (let ((baz t)) (if baz (cons bar nil)))))) (operations-per-second (compile 'bob lambda-expression)))) (defun bench-this-lisp () (bench "(* 2.1 2.1)" nmult) (bench "(+ 2.1 2.1)" nadd) (bench "funcall & (* 2.1 2.1)" funcall-3) (bench "special reference" nspecial) (bench "lexical reference" nlexical) ;; (bench "ivar reference" n-ivar-ref) (bench "(setf (aref array 5) t)" nsetf) (bench "(funcall lexical-f x)" funcall-2) (bench "(f x)" funcall-3) ;; (Bench "(eval t)" nsymeval) ;; (bench "(eval '(* 2.1 2.1))" repeatuations) ;; (bench "(cons 1 2)" n-cons) ;; (bench "compile simple function" ncompilations) ) ;(bench-this-lisp) ) ;;;************************************************************** #+genera (progn (scl:defflavor bar (a b) () :initable-instance-variables :writable-instance-variables) (scl:defflavor frob (c) (bar) :initable-instance-variables :writable-instance-variables) (scl:defmethod (hop bar) () a) (scl:defmethod (set-hop bar) () (setq a n)) (scl:defmethod (nohop bar) () 5) (defun n-ivar-ref () (let ((i (scl:make-instance 'bar :a 0 :b 0))) (ivar-ref i N))) (scl:defmethod (ivar-ref bar) () (operations-per-second b)) (defun-timer Ninstances () (operations-per-second (flavor:make-instance 'bar))) (defun-timer n-svref () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (scl:symbol-value-in-instance instance 'a)))) (defun-timer n-hop () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (hop instance)))) (defun-timer n-gf () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (nohop instance)))) (defun-timer n-set-hop () (let ((instance (flavor:make-instance 'bar :a 1))) (operations-per-second (set-hop instance)))) (defun-timer n-type-of () (let ((instance (flavor:make-instance 'bar))) (operations-per-second (flavor::%instance-flavor instance)))) (defun-timer n-bar-b () (let ((instance (flavor:make-instance 'bar :a 0 :b 0))) (operations-per-second (bar-b instance)))) (defun-timer n-frob-bar-b () (let ((instance (flavor:make-instance 'frob :a 0 :b 0))) (operations-per-second (bar-b instance)))) (defun bench-flavors () (bench "flavor:make-instance (2 slots)" ninstances) (bench "flavor:symbol-value-in-instance" n-svref) (bench "1 method, 1 dispatch" n-gf) (bench "slot symbol in method (access)" n-hop) (bench "slot symbol in method (modify)" n-hop) (bench "slot accessor bar" n-bar-b) (bench "slot accessor frob" n-frob-bar-b) (bench "instance-flavor" n-type-of)) ) ; end of #+genera ;;;************************************************************** ;;;BENCH-THIS-CLOS ;;; (evolved from Ken Anderson's tests of Symbolics CLOS) #+pcl (let ((*default-pathname-defaults* pcl::*pcl-directory*)) (load "bench-precompile")) (defmethod strange ((x t)) t) ; default method (defmethod area ((x number)) 'green) ; builtin class (defclass point () ((x :initform 0 :accessor x :initarg :x) (y :initform 0 :accessor y :initarg :y))) (defmethod color ((thing point)) 'red) (defmethod address ((thing point)) 'boston) (defmethod area ((thing point)) 0) (defmethod move-to ((p1 point) (p2 point)) 0) (defmethod x-offset ((thing point)) (with-slots (x y) thing x)) (defmethod set-x-offset ((thing point) new-x) (with-slots (x y) thing (setq x new-x))) (defclass box (point) ((width :initform 10 :accessor width :initarg :width) (height :initform 10 :accessor height :initarg :height))) (defmethod area ((thing box)) 0) (defmethod move-to ((box box) (point point)) 0) (defmethod address :around ((thing box)) (call-next-method)) (defvar p (make-instance 'point)) (defvar b (make-instance 'box)) (defun-timer n-strange () (operations-per-second (strange 5))) (defun-timer n-accesses () (operations-per-second (x p))) (defun-timer n-color () (operations-per-second (color p))) (defun-timer n-call-next-method () (let ((p b)) (operations-per-second (address p)))) (defun-timer n-area-1 () (operations-per-second (area p))) (defun-timer n-area-2 () (operations-per-second (area 5))) (defun-timer n-move-1 () (operations-per-second (move-to p p))) (defun-timer n-move-2 () (let ((x p) (y b)) (operations-per-second (move-to x y)))) (defun-timer n-off () (operations-per-second (x-offset p))) (defun-timer n-setoff () (operations-per-second (set-x-offset p 500))) (defun-timer n-slot-value () (operations-per-second (slot-value p 'x))) (defun-timer n-class-of-1 () (operations-per-second (class-of p))) #| ; cmucl can't compile this. (defun-timer n-class-of-2 () (operations-per-second (class-of 5))) |# (defvar nco2 5) (defun-timer n-class-of-2 () (operations-per-second (class-of nco2))) (defvar *size-of-point* (* *bytes-per-word* 8)) (defun-timer n-alloc () (let ((*estimated-bytes-per-call* *size-of-point*) (c (find-class 'point))) (operations-per-second (allocate-instance c)))) (defun-timer n-make () (let ((*estimated-bytes-per-call* *size-of-point*)) (operations-per-second (make-instance 'point)))) (defun-timer n-make-initargs () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4)))) (operations-per-second (make-instance 'point :x 0 :y 5)))) (defun-timer n-make-variable-initargs () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4))) (x 0) (y 5)) (operations-per-second (make-instance 'point :x x :y y)))) #+pcl (#+pcl pcl::expanding-make-instance-top-level #-pcl progn (defun-timer n-make1 () (let ((*estimated-bytes-per-call* *size-of-point*)) (operations-per-second (make-instance 'point)))) (defun-timer n-make-initargs1 () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4)))) (operations-per-second (make-instance 'point :x 0 :y 5)))) (defun-timer n-make-variable-initargs1 () (let ((*estimated-bytes-per-call* (+ *size-of-point* (* *bytes-per-word* 4))) (x 0) (y 5)) (operations-per-second (make-instance 'point :x x :y y)))) ) #+pcl (defun compile-and-load-file-if-newer (file &rest other-files) #-cmu (declare (ignore other-files)) #-cmu (load (compile-file (make-pathname :defaults file :type "lisp"))) #+cmu ; uses compile-file-pathname (labels ((type-fwd (file &optional type) (let ((path (if type (make-pathname :defaults file :type type) file))) (if (probe-file path) (file-write-date path) 0))) (fwd (file) (max (type-fwd file "lisp") (type-fwd (compile-file-pathname file))))) (let ((other-fwd 0)) (dolist (other other-files) (setq other-fwd (max other-fwd (fwd (merge-pathnames other))))) (setq file (merge-pathnames file)) (when (< (type-fwd (compile-file-pathname file)) (max (type-fwd file "lisp") other-fwd)) (compile-file file) (load file))))) #+pcl (let ((*default-pathname-defaults* pcl::*pcl-directory*)) (compile-and-load-file-if-newer "bench-precompile" "bench")) #+(and lucid (not pcl)) (lcl::precompile-generic-functions) (defun bench-this-clos () (bench "1 default method" n-strange) (bench "1 dispatch, 1 method" n-color) (bench "1 dispatch, :around + primary" n-call-next-method) (bench "1 dispatch, 3 methods, instance" n-area-1) (bench "1 dispatch, 3 methods, noninstance" n-area-2) (bench "2 dispatch, 2 methods" n-move-1) (bench "slot reader method" n-accesses) (bench "with-slots (1 access)" n-off) (bench "with-slots (1 modify)" n-setoff) (bench "naked slot-value" n-slot-value) (bench "class-of instance" n-class-of-1) (bench "class-of noninstance" n-class-of-2) (bench "allocate-instance (2 slots)" n-alloc) (let ((two-c-i #-pcl "make-instance (2 constant initargs)" #+pcl "make-instance (2 initargs)")) (let ((opt #+(and pcl (not cmu)) "" #+(and pcl cmu) " (opt)" #-pcl "")) (flet ((c (s) (concatenate 'string s opt))) (bench (c "make-instance (2 slots)") n-make) (bench (c two-c-i) n-make-initargs) #-pcl (bench (c "make-instance (2 variable initargs)") n-make-variable-initargs))) #+(and pcl (not cmu)) (let ((opt " (opt)")) (flet ((c (s) (concatenate 'string s opt))) (bench (c "make-instance (2 slots)") n-make1) (bench (c two-c-i) n-make-initargs1) #-pcl (bench (c "make-instance (2 variable initargs)") n-make-variable-initargs1))))) (bench-this-clos) gcl/pcl/test/time.lisp0000644000175000017500000001124412240167764013636 0ustar cammcamm(in-package "PCL") (proclaim '(optimize (speed 3)(safety 0)(compilation-speed 0))) (defvar *tests*) (setq *tests* nil) (defvar m (car (generic-function-methods #'shared-initialize))) (defvar gf #'shared-initialize) (defvar c (find-class 'standard-class)) (defclass str () ((slot :initform nil :reader str-slot)) (:metaclass structure-class)) (defvar str (make-instance 'str)) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" '(time-slot-value m 'plist 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)" '(time-slot-value m 'generic-function 10000)) *tests*) (push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)" '(time-slot-value str 'slot 10000)) *tests*) (defun time-slot-value (object slot-name n) (time (dotimes (i n) (slot-value object slot-name)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)" '(time-slot-value-function m 10000)) *tests*) (defun time-slot-value-function (object n) (time (dotimes (i n) (slot-value object 'function)))) (push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)" '(time-slot-value-slot str 10000)) *tests*) (defun time-slot-value-slot (object n) (time (dotimes (i n) (slot-value object 'slot)))) (push (cons "Time one-class dfun." '(time-generic-function-methods gf 10000)) *tests*) (defun time-generic-function-methods (object n) (time (dotimes (i n) (generic-function-methods object)))) (push (cons "Time one-index dfun." '(time-class-precedence-list c 10000)) *tests*) (defun time-class-precedence-list (object n) (time (dotimes (i n) (class-precedence-list object)))) (push (cons "Time n-n dfun." '(time-method-function m 10000)) *tests*) (defun time-method-function (object n) (time (dotimes (i n) (method-function object)))) (push (cons "Time caching dfun." '(time-class-slots c 10000)) *tests*) (defun time-class-slots (object n) (time (dotimes (i n) (class-slots object)))) (push (cons "Time typep for classes." '(time-typep-standard-object m 10000)) *tests*) (defun time-typep-standard-object (object n) (time (dotimes (i n) (typep object 'standard-object)))) (push (cons "Time default-initargs." '(time-default-initargs (find-class 'plist-mixin) 1000)) *tests*) (defun time-default-initargs (class n) (time (dotimes (i n) (default-initargs class nil)))) (push (cons "Time make-instance." '(time-make-instance (find-class 'plist-mixin) 1000)) *tests*) (defun time-make-instance (class n) (time (dotimes (i n) (make-instance class)))) (push (cons "Time constant-keys make-instance." '(time-constant-keys-make-instance 1000)) *tests*) (expanding-make-instance-top-level (defun constant-keys-make-instance (n) (dotimes (i n) (make-instance 'plist-mixin)))) (precompile-random-code-segments) (defun time-constant-keys-make-instance (n) (time (constant-keys-make-instance n))) (defun expand-all-macros (form) (walk-form form nil #'(lambda (form context env) (if (and (eq context :eval) (consp form) (symbolp (car form)) (not (special-form-p (car form))) (macro-function (car form))) (values (macroexpand form env)) form)))) (push (cons "Macroexpand meth-structure-slot-value" '(pprint (multiple-value-bind (pgf pm) (prototypes-for-make-method-lambda 'meth-structure-slot-value) (expand-defmethod 'meth-structure-slot-value pgf pm nil '((object str)) '(#'(lambda () (slot-value object 'slot))) nil)))) *tests*) #-kcl (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)." '(disassemble (meth-structure-slot-value str))) *tests*) (defmethod meth-structure-slot-value ((object str)) #'(lambda () (slot-value object 'slot))) #|| ; interesting, but long. (produces 100 lines of output) (push (cons "Macroexpand meth-standard-slot-value" '(pprint (expand-all-macros (expand-defmethod-internal 'meth-standard-slot-value nil '((object standard-method)) '(#'(lambda () (slot-value object 'function))) nil)))) *tests*) (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)." '(disassemble (meth-standard-slot-value m))) *tests*) (defmethod meth-standard-slot-value ((object standard-method)) #'(lambda () (slot-value object 'function))) ||# (defun do-tests () (dolist (doc+form (reverse *tests*)) (format t "~&~%~A~%" (car doc+form)) (pprint (cdr doc+form)) (eval (cdr doc+form)))) gcl/pcl/test/bench.out0000644000175000017500000000312412240167764013615 0ustar cammcamm cmucl17f cmucl17g lucid411g lucid411c 1 default method: 1.810e+6 1.810e+6 1.250E+6 1.000E+7 1 dispatch, 1 method: 7.394e+5 1.173e+6 9.091E+5 1.429E+6 1 dispatch, :around + primary: 5.398e+5 6.441e+5 2.174E+5 1.093E+5 1 dispatch, 3 methods, instance: 7.394e+5 7.130e+5 9.091E+5 1.429E+6 1 dispatch, 3 methods, noninstance: 6.768e+5 1.023e+6 3.509E+5 1.429E+6 2 dispatch, 2 methods: 5.890e+4 9.070e+5 4.255E+5 8.333E+5 slot reader method: 1.533e+6 1.476e+6 1.111E+6 1.429E+6 with-slots (1 access): 2.738e+5 4.994e+5 2.198E+5 6.452E+5 with-slots (1 modify): 4.872e+5 5.961e+5 4.082E+5 5.882E+5 naked slot-value: 1.215e+5 1.687e+5 6.061E+5 8.696E+5 class-of instance: 4.938e+6 4.938e+6 3.333E+6 1.000E+7 class-of noninstance: 1.896e+6 9.070e+5 7.407E+5 2.857E+6 allocate-instance (2 slots): 8.867e+4 6.813e+4 2.475E+4 1.250E+5 make-instance (2 slots) (opt): 5.798e+3 1.002e+5 2.174E+5 1.266E+5 make-instance (2 initargs) (opt): 5.657e+3 7.206e+4 1.099E+5 1.613E+5 make-instance (2 slots): 5.798e+3 1.002e+5 6.969E+3 1.266E+5 make-instance (2 initargs): 5.657e+3 7.206e+4 5.249E+3 1.613E+5 make-instance (2 variable initargs): 1.754E+5 gcl/pcl/test/makediff0000644000175000017500000000167112240167764013503 0ustar cammcamm#! /bin/csh if ( -e diff ) rm diff #set out = /tmp/diff set out = diff #set outtmp = /tmp/difftmp set outtmp = difftmp cat /dev/null >! $out #cd may-day-4b foreach f (*.lisp *.text) #set old = ../may-day-4/$f set old = ../../../may-day-4b/$f echo "====================" >> $out if ( -e $old ) then diff -c5 $old $f >&! $outtmp if (! $status) then echo " " $old >> $out echo " " $f >> $out endif cat $outtmp >> $out else echo " " $old "does not exist." >> $out echo " " $f >> $out cat $f >> $out echo " " >> $out endif end echo "====================" >> $out cd .. #mv $out . #Then, use emacs, and type: # c-X c-F diff RET # c-X ( c-S c-Q TAB ESC c-A c-F c-F RET c-SPACE c-E m-X untabify RET c-A DEL c-E c-X ) # m-X name-last-kbd-macro RET untabify-diff-output RET # m-0 m-X untabify-diff-output RET c-X c-S #or, eval the following expression to define the macro: #(fset 'untabify-diff-output "  øuntabify ") gcl/pcl/test/bench-precompile.lisp0000644000175000017500000000010712240167764016110 0ustar cammcamm(in-package :bench) #+pcl (pcl::precompile-random-code-segments bench) gcl/pcl/test/list-functions.lisp0000644000175000017500000001166412240167764015667 0ustar cammcamm (in-package :pcl) (defvar *defun-list* nil) (defvar *defmethod-list* nil) (defvar *defmacro-list* nil) (defvar *defgeneric-list* nil) (defun list-functions (&optional print-p) (let ((eof '(eof)) (*package* *package*)) (setq *defun-list* nil *defmethod-list* nil *defmacro-list* nil) (labels ((process-form (form) (when (consp form) (case (car form) ((in-package export import shadow shadowing-import) (eval form)) #+lcl3.0 (lcl:handler-bind (eval form)) (let (when print-p (print form))) (defun (push (list (cadr form) (caddr form)) *defun-list*)) (defmethod (push (list (cadr form) (caddr form)) *defmethod-list*)) (defmacro (push (list (cadr form) (caddr form)) *defmacro-list*)) (defgeneric (push (list (cadr form) (caddr form)) *defgeneric-list*)) (eval-when (mapc #'process-form (cddr form))) (progn (mapc #'process-form (cdr form))) ((defvar defparameter defconstant proclaim defsetf defstruct deftype define-compiler-macro)) ((define-walker-template defopcode defoperand define-method-combination define-constructor-code-type defclass)) (t (when print-p (print form))))))) (dolist (file (system-source-files 'pcl)) (with-open-file (in file :direction :input) (loop (let ((form (read in nil eof))) (when (eq form eof) (return nil)) (process-form form)))))) (values (length *defun-list*) (length *defmethod-list*) (length *defmacro-list*) (length *defgeneric-list*)))) (defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions")) (let ((keys nil) (opt nil) (gf-vector (make-array 10 :initial-element nil)) (readers nil) (writers nil) (cv nil) (*package* *the-pcl-package*) (*print-pretty* nil) (s-a-n (find-package "SLOT-ACCESSOR-NAME")) (lisp-sans (mapcar #'slot-reader-symbol '(function type)))) ;; This one has no predefined methods. (defgeneric update-dependent (metaobject dependent &rest initargs)) (map-all-generic-functions #'(lambda (gf) (when (or all-p (let ((name (generic-function-name gf))) (when (consp name) (setq name (cadr name))) (and (not (find #\: (symbol-name name))) (or (eq (symbol-package name) *the-pcl-package*) (and san-p (memq name lisp-sans) (and (eq (symbol-package name) s-a-n) (string= "PCL " (symbol-name name) :end2 4))))))) (let ((ll (generic-function-lambda-list gf))) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords) (analyze-lambda-list ll) (cond ((use-constant-value-dfun-p gf t) (push gf cv)) ((or keysp restp allow-other-keys-p keywords) (push gf keys)) ((plusp noptional) (push gf opt)) ((and (= nrequired 1) (let ((m (generic-function-methods gf))) (and m (every #'standard-reader-method-p m)))) (push gf readers)) ((and (= nrequired 2) (let ((m (generic-function-methods gf))) (and m (every #'standard-writer-method-p m)))) (push gf writers)) (t (push gf (aref gf-vector nrequired))))))))) (with-open-file (out (let* ((system (get-system 'pcl)) (*system-directory* (funcall (car system)))) (make-pathname :defaults (truename (make-source-pathname "defsys")) :name name)) :direction :output) (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%") (format out "(in-package :pcl)~%") (flet ((print-gf-list (list) (setq list (sort (mapcar #'generic-function-name list) #'(lambda (sym1 sym2) (let* ((s1 (if (consp sym1) (cadr sym1) sym1)) (s2 (if (consp sym2) (cadr sym2) sym2)) (p1 (symbol-package s1)) (p2 (symbol-package s2))) (if (eq p1 p2) (string< (symbol-name s1) (symbol-name s2)) (string< (package-name p1) (package-name p2))))))) (dolist (sym list) (let* ((*print-case* :downcase) (gf (gdefinition sym)) (lambda-list (generic-function-lambda-list gf))) (format out "~&~S~%" `(defgeneric ,sym ,lambda-list)) (when show-methods-p (dolist (m (generic-function-methods gf)) (let* ((q (method-qualifiers m)) (qs (if (null q) "" (format nil "~{~S~^ ~}" q))) (s (unparse-specializers m))) (format out "~&; ~7A ~S~%" qs s))) (terpri out)))))) (when cv (format out "~%;;; class predicates~%") (print-gf-list cv)) (when readers (format out "~%;;; readers~%") (print-gf-list readers)) (when writers (format out "~%;;; writers~%") (print-gf-list writers)) (dotimes (i 10) (when (aref gf-vector i) (format out "~%;;; ~D argument~:P ~%" i) (print-gf-list (aref gf-vector i)))) (format out "~%;;; optional arguments ~%") (print-gf-list opt) (format out "~%;;; keyword arguments ~%") (print-gf-list keys)) (terpri out)))) gcl/pcl/extensions/0000755000175000017500000000000012240167764013225 5ustar cammcammgcl/pcl/extensions/extensions.lisp0000644000175000017500000005362512240167764016330 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- ;;; ;;; ************************************************************************* ;;; ;;; File: extensions.lisp. ;;; ;;; by Trent E. Lange, Effective Date 04-23-92 ;;; ;;; ;;; This file contains a small set of useful extensions to PCL. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify and distribute this document. ;;; ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; (in-package 'pcl) (eval-when (compile load eval) (defvar *extensions-exports* '(set-standard-instance-access set-funcallable-instance-access funcallable-instance-slot-value set-funcallable-instance-slot-value funcallable-instance-slot-boundp standard-instance-slot-value set-standard-instance-slot-value standard-instance-slot-boundp structure-instance-slot-value set-structure-instance-slot-value structure-instance-slot-boundp #+pcl-user-instances user-instance-slot-value #+pcl-user-instances set-user-instance-slot-value #+pcl-user-instances user-instance-slot-boundp with-optimized-slots with-standard-instance-slots method-needs-next-methods-p map-all-classes finalize-all-classes updater record-updater)) ) (defclass updater () ((dependent :initarg :dependent :reader dependent))) (defun record-updater (class dependee dependent &rest initargs) (let ((updater (apply #'make-instance class :dependent dependent initargs))) (add-dependent dependee updater) updater)) (defun finalize-all-classes (&optional (root-name 't)) "Makes sure that all classes are finalized. If Root-Name is supplied, then finalizes Root-Name and all of its subclasses and their subclasses." (map-all-classes #'(lambda (class) (unless (class-finalized-p class) (finalize-inheritance class))) root-name)) ;;; ;;; ;;; (defmacro slot-value-from-index (instance wrapper slot-name slots index) "Returns instance's slot-value given slot-name's index." (once-only (index) `(if ,index (let ((val (%svref ,slots ,index))) (if (eq val ',*slot-unbound*) (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name) val)) (if *safe-to-use-slot-value-wrapper-optimizations-p* (get-class-slot-value-1 ,instance ,wrapper ,slot-name) (accessor-slot-value ,instance ,slot-name))))) (defmacro set-slot-value-from-index (instance wrapper slot-name slots index new-value) "Sets instance's slot-value to new-value given slot-name's index." (once-only (index) `(if ,index (setf (%svref ,slots ,index) ,new-value) (if *safe-to-use-set-slot-value-wrapper-optimizations-p* (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) (defsetf slot-value-from-index set-slot-value-from-index) (defmacro with-slots-slot-value-from-index (instance wrapper slot-name slots index variable-instance) "Returns instance's slot-value given slot-name's index." (cond ((consp wrapper) `(let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance))) (variable-instance `(let ((,instance ,variable-instance)) (with-slots-slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index NIL))) (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)))) (defmacro set-with-slots-slot-value-from-index (instance wrapper slot-name slots index variable-instance new-value) "Sets instance's slot-value to new-value given slot-name's index." (cond ((consp wrapper) `(let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (set-with-slots-slot-value-from-index ,instance wrapper ,slot-name ,slots ,index ,variable-instance ,new-value))) (variable-instance `(let ((,instance ,variable-instance)) (set-with-slot-slots-value-from-index ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value))) (T `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index) ,new-value)))) (defsetf with-slots-slot-value-from-index set-with-slots-slot-value-from-index) (defmacro with-slots-slot-value-from-wrapper-and-slots (instance slot-name wrapper slots-layout slots variable-instance) (cond (variable-instance `(let ((,instance ,variable-instance)) (with-slots-slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL))) ((consp wrapper) `(if *safe-to-use-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL)) (accessor-slot-value ,instance ,slot-name))) (T `(if *safe-to-use-slot-value-wrapper-optimizations-p* (slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) (accessor-slot-value ,instance ,slot-name))))) (defmacro set-with-slots-slot-value-from-wrapper-and-slots (instance slot-name wrapper slots-layout slots variable-instance new-value) (cond (variable-instance `(let ((,instance ,variable-instance)) (set-with-slots-slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value))) ((consp wrapper) `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* (let ((wrapper ,wrapper)) (unless (eq (wrapper-state wrapper) 't) (setf wrapper (wrapper-state-trap wrapper ,instance))) (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name wrapper ,slots-layout ,slots NIL) ,new-value)) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))) (T `(if *safe-to-use-set-slot-value-wrapper-optimizations-p* (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL) ,new-value) (setf (accessor-slot-value ,instance ,slot-name) ,new-value))))) (defsetf with-slots-slot-value-from-wrapper-and-slots set-with-slots-slot-value-from-wrapper-and-slots) (defun tree-memq-p (item form) (cond ((consp form) (or (tree-memq-p item (car form)) (tree-memq-p item (cdr form)))) (T (eq item form)))) (defmacro with-optimized-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that is faster because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." ;; E.g. (with-optimized-slots (foo-slot ;; (foo-slot-accessor 'foo-slot) ;; (variable-slot-accessor variable-slot)) ;; instance ;; :instance-form (car instances-of-same-class) ;; (loop for instance in objects-of-same-class ;; as variable-slot in variable-slots ;; collect (list foo-slot ;; foo-slot-accessor ;; variable-slot-accessor))) ;; ==> (loop for instance in objects-of-same-class ;; as variable-slot in variable-slots ;; collect (list (slot-value instance 'foo-slot) ;; (slot-value instance 'foo-slot) ;; (slot-value instance variable-slot))) (build-with-optimized-slots-form slot-entries instance-form body)) (defmacro with-standard-instance-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that assumes that the instance-form evaluates to a standard-instance. The result is undefined if it does not. With-standard-instance-slots is faster than With-Slots because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." (build-with-optimized-slots-form slot-entries instance-form body 'std-instance)) (defun build-with-optimized-slots-form (slot-entries instance-form body &optional instance-type) (let* ((variable-instance (if (eq (car body) :variable-instance) (prog1 (cadr body) (setf body (cddr body))))) (hard-accessors (let ((collect NIL)) (dolist (slot-entry slot-entries (nreverse collect)) (when (and (symbolp slot-entry) (tree-memq-p slot-entry body)) (push (cons slot-entry slot-entry) collect)) (when (and (consp slot-entry) (constantp (second slot-entry)) (tree-memq-p (car slot-entry) body)) (push (cons (car slot-entry) (second (second slot-entry))) collect))))) (variable-accessors (let ((collect NIL)) (dolist (slot-entry slot-entries (nreverse collect)) (when (and (consp slot-entry) (not (constantp (second slot-entry))) (tree-memq-p (car slot-entry) body)) (push slot-entry collect)))))) (if *safe-to-use-slot-wrapper-optimizations-p* (build-maybe-safe-w-o-s-v hard-accessors variable-accessors instance-form body variable-instance instance-type) (build-with-accessor-s-v hard-accessors variable-accessors instance-form body variable-instance)))) (defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors instance-form body variable-instance instance-type) (let* ((instance-string (if (symbolp instance-form) (symbol-name instance-form) "")) (instance-form-var (if (and variable-instance (simple-eval-access-p instance-form)) instance-form (gensym (concatenate 'simple-string instance-string "-INSTANCE-FORM")))) (prototype-form (if variable-instance (if (simple-eval-access-p variable-instance) variable-instance (gensym (concatenate 'simple-string "VARIABLE-INSTANCE" instance-string))) instance-form-var)) (wrapper-var (gensym (concatenate 'simple-string instance-string "-WRAPPER"))) (slots-var (unless variable-instance (gensym (concatenate 'simple-string instance-string "-SLOTS")))) (type-var (when (and variable-instance (not instance-type)) (gensym (concatenate 'simple-string instance-string "-TYPE")))) (type-var-std 1) (type-var-fsc 2) #+pcl-user-instances (type-var-user 3) (slot-index-vars (mapcar #'(lambda (slot-entry) (list (car slot-entry) (cdr slot-entry) (gensym (concatenate 'simple-string (if (string= instance-string "") "INSTANCE-FORM-" instance-string) (symbol-name (cdr slot-entry)) "-INDEX")))) (remove-duplicates hard-accessors :key #'cdr))) (slots-layout-var (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string))) (runtime-slots-form (if variable-instance (ecase instance-type (std-instance `(std-instance-slots ,instance-form-var)) (fsc-instance `(fsc-instance-slots ,instance-form-var)) #+pcl-user-instances (user-instance `(get-user-instance-slots ,instance-form-var)) ((nil) `(case ,type-var (,type-var-std (std-instance-slots ,instance-form-var)) (,type-var-fsc (fsc-instance-slots ,instance-form-var)) #+pcl-user-instances (,type-var-user (get-user-instance-slots ,instance-form-var))))) slots-var)) (runtime-wrapper-form (if variable-instance (ecase instance-type (std-instance `(std-instance-wrapper ,instance-form-var)) (fsc-instance `(fsc-instance-wrapper ,instance-form-var)) #+pcl-user-instances (user-instance `(get-user-instance-wrapper ,instance-form-var)) ((nil) `(case ,type-var (,type-var-std (std-instance-wrapper ,instance-form-var)) (,type-var-fsc (fsc-instance-wrapper ,instance-form-var)) #+pcl-user-instances (,type-var-user (get-user-instance-wrapper ,instance-form-var))))) wrapper-var))) (declare (type simple-string instance-string) (type list slot-index-vars)) `(let (,@(unless variable-instance `((,instance-form-var ,instance-form))) ,@(when (and variable-instance (not (eq prototype-form variable-instance))) `((,prototype-form ,variable-instance))) ,wrapper-var ,slots-layout-var ,@(if variable-instance (if type-var `((type-var 0))) (list slots-var)) ,@(mapcar #'third slot-index-vars)) ,@(when type-var `((declare (type index ,type-var)))) (when *safe-to-use-slot-wrapper-optimizations-p* ,@(ecase instance-type (std-instance `((setf ,wrapper-var (std-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (std-instance-slots ,prototype-form)))))) (fsc-instance `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (fsc-instance-slots ,prototype-form)))))) #+pcl-user-instances (user-instance `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) ,@(unless variable-instance `((setf ,slots-var (get-user-instance-slots ,prototype-form)))))) ((nil) `((cond ((std-instance-p ,prototype-form) (setf ,wrapper-var (std-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-std) `(setf ,slots-var (std-instance-slots ,prototype-form)))) ((fsc-instance-p ,prototype-form) (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-fsc) `(setf ,slots-var (fsc-instance-slots ,prototype-form)))) #+pcl-user-instances ((get-user-instance-p ,prototype-form) (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form)) ,(if variable-instance `(setf ,type-var ,type-var-user) `(setf ,slots-var (get-user-instance-slots ,prototype-form)))))))) ,@(if instance-type (build-w-s-v-find-slot-indices wrapper-var slots-layout-var prototype-form slot-index-vars) `((when ,wrapper-var ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var prototype-form slot-index-vars))))) (symbol-macrolet (,@(mapcar #'(lambda (slot-cons) `(,(car slot-cons) (with-slots-slot-value-from-index ,instance-form-var ,runtime-wrapper-form ',(cdr slot-cons) ,runtime-slots-form ,(third (assoc (car slot-cons) slot-index-vars :test #'eq)) ,(when (and variable-instance (not (eq variable-instance instance-form-var))) variable-instance)))) hard-accessors) ,@(mapcar #'(lambda (variable-cons) `(,(car variable-cons) (with-slots-slot-value-from-wrapper-and-slots ,instance-form-var ,(second variable-cons) ,runtime-wrapper-form ,slots-layout-var ,runtime-slots-form ,(when (and variable-instance (not (eq variable-instance instance-form-var))) variable-instance)))) variable-accessors)) ,@body)))) (defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var prototype-form slot-index-vars) (declare (type list slot-index-vars)) `((unless (eq (wrapper-state ,wrapper-var) 't) (setf ,wrapper-var (wrapper-state-trap ,wrapper-var ,prototype-form))) (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var)) ,@(if (<= (length slot-index-vars) 2) (mapcar #'(lambda (slot-cons) `(setf ,(third slot-cons) (instance-slot-index-from-slots-layout ,slots-layout-var ',(second slot-cons)))) slot-index-vars) ;; More than two slots, so more efficient to search slots-layout-var ;; only once, rather than once for each with instance-slot-index. (labels ((build-comps (slot-vars index) (if slot-vars `(if (eq slot-name ',(second (car slot-vars))) (progn (setf ,(third (car slot-vars)) ,index) (if (= matches ,(1- (length slot-index-vars))) (go end-loop) (setf matches (the fixnum (1+ matches))))) ,(build-comps (cdr slot-vars) index))))) `((block nil (let ((slots-left ,slots-layout-var) (slot-name NIL) (index 0) (matches 0)) (declare (type fixnum index matches)) (when slots-left (tagbody begin-instance-slots-loop (setf slot-name (car slots-left)) ,(build-comps slot-index-vars 'index) (setf index (the fixnum (1+ index))) (if (null (setf slots-left (cdr slots-left))) (go end-loop)) (go begin-instance-slots-loop) end-loop))))))))) (defun build-with-accessor-s-v (hard-accessors variable-accessors instance-form body variable-instance) ;; Build the body for with-optimized-slot-value when it is unsafe ;; and accessor-slot-value must be used. (let ((instance-form-var (if variable-instance instance-form (gensym "INSTANCE-FORM")))) `(let (,@(unless variable-instance `((,instance-form-var ,instance-form)))) (symbol-macrolet (,@(mapcar #'(lambda (slot-cons) `(,(car slot-cons) (accessor-slot-value ,instance-form-var ',(cdr slot-cons)))) hard-accessors) ,@(mapcar #'(lambda (variable-cons) `(,(car variable-cons) (accessor-slot-value ,instance-form-var ,(second variable-cons)))) variable-accessors)) ,@body)))) #-(or KCL IBCL) (export *extensions-exports* *the-pcl-package*) #+(or KCL IBCL) (mapc 'export (list *extensions-exports*) (list *the-pcl-package*)) gcl/pcl/extensions/user-instances.lisp0000644000175000017500000006640412240167764017073 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*- ;;; ;;; ************************************************************************* ;;; ;;; File: user-instances.lisp. ;;; ;;; by Trent E. Lange, Effective Date 06-02-92 ;;; ;;; ;;; This file contains a metaclass (User-Vector-Class) whose instances ;;; are stored as simple-vectors, saving space over PCL's standard instance ;;; representations of PCL at the cost of some class redefinition flexibiliity. ;;; ;;; Permission is granted to any individual or institution to use, copy, ;;; modify and distribute this document. ;;; ;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; This file builds on the PCL-USER-INSTANCES feature of July 92 PCL ;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple ;;; vectors. The first element of the instance vector is the instance's ;;; class wrapper (providing internal PCL information about the instance's ;;; class). The remaining elements of the instance vector are the instance's ;;; slots themselves. ;;; ;;; The space overhead of user-vector-instances is only two vector cells ;;; (one for the vector, one for the wrapper). This is contrast to standard ;;; PCL instances, which have a total overhead of four cells. (Standard ;;; instances in PCL are represented as instances of structure STD-INSTANCE ;;; having two slots, one for the wrapper and one holding a simple-vector ;;; which is the instance's slots). This two-cell space savings per instance ;;; comes at the cost of losing some class redefinition flexibility, since ;;; simple-vectors cannot have their sizes changed dynamically. ;;; All current instances of user-instance-vectors therefore become ;;; permanently obsolete if the classes' instance slots change. ;;; ;;; This code requires July 92 PCL or later compiled with the ;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file). ;;; #-pcl-user-instances (eval-when (compile load eval) (error "Cannot use user-instances, since PCL was compiled without PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)") ) (eval-when (compile load eval) (defclass user-vector-class-mixin () () (:documentation "Use this mixin for metaclasses whose instances are USER-INSTANCES instantiated as simple-vectors. This saves space over the standard instances used by standard-class, at the cost of losing the ability to redefine the slots in a class and still have old instances updated correctly.")) (defclass user-vector-class (user-vector-class-mixin standard-class) () (:documentation "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors. This saves space over the standard instances used by standard-class, at the cost of losing the ability to redefine the slots in a class and still have old instances updated correctly.")) (defmethod validate-superclass ((class user-vector-class-mixin) (new-super T)) (or (typep new-super 'user-vector-class-mixin) (eq new-super (find-class 'standard-object)))) (defclass user-vector-object (standard-object) () (:metaclass user-vector-class)) ) ;;; ;;; ;;; Instance allocation stuff. ;;; (defmacro user-vector-instance-p (object) (once-only (object) `(the boolean (and (simple-vector-p ,object) (plusp (length (the simple-vector ,object))) (wrapper-p (%svref ,object 0)))))) (defmacro user-vector-instance-wrapper (object) `(%svref ,object 0)) (defsetf user-vector-instance-wrapper (object) (new-value) `(setf (%svref ,object 0) ,new-value)) (defmacro user-vector-instance-slots (instance) ;; The slots vector of user-vector instances is the instance itself. instance) (defmacro set-user-vector-instance-slots (instance new-value) `(progn (warn "Attempt to set user-vector-instance-slots of ~S to ~S" ,instance ,new-value) ,new-value)) (defun user-instance-p (x) "Is X a user instance, specifically a user-vector-instance?" (user-vector-instance-p x)) (defun user-instance-slots (x) "Return the slots of this user-vector-instance." (user-vector-instance-slots x)) (defun user-instance-wrapper (x) "Return the wrapper of this user-vector-instance." (user-vector-instance-wrapper x)) (defun set-user-instance-wrapper (x new) (setf (user-vector-instance-wrapper x) new)) (defmacro get-user-instance-p (x) `(user-vector-instance-p ,x)) (defmacro get-user-instance-wrapper (x) `(user-vector-instance-wrapper ,x)) (defmacro get-user-instance-slots (x) `(user-vector-instance-slots ,x)) (eval-when (eval #+cmu load) (force-compile 'user-instance-p) (force-compile 'user-instance-slots) (force-compile 'user-instance-wrapper) (force-compile 'set-user-instance-wrapper)) ;;; ;;; Methods needed for user-vector-class-mixin. ;;; (defconstant *not-a-slot* (gensym "NOT-A-SLOT")) (defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) (finalize-inheritance class)) (let* ((class-wrapper (class-wrapper class)) (copy-instance (wrapper-allocate-static-slot-storage-copy class-wrapper)) (instance (copy-simple-vector copy-instance))) (declare (type simple-vector copy-instance instance)) (setf (user-vector-instance-wrapper instance) class-wrapper) instance)) (defmethod make-instances-obsolete ((class user-vector-class-mixin)) "The slots of user-vector-instances are stored in the instance vector themselves (a simple-vector), so old instances cannot be updated properly." (setf (slot-value class 'prototype) NIL) (warn "Obsoleting user-vector class ~A, all current instances will be invalid..." class)) (defmethod compute-layout :around ((class user-vector-class-mixin) cpl instance-eslotds) ;; First element of user-vector-instance is actually its wrapper. (declare (ignore cpl instance-eslotds)) (cons *not-a-slot* (call-next-method))) (defmethod compute-instance-layout :around ((class user-vector-class-mixin) instance-eslotds) ;; First element of user-vector-instance is actually its wrapper. (declare (ignore instance-eslotds)) (cons *not-a-slot* (call-next-method))) (defmethod wrapper-fetcher ((class user-vector-class-mixin)) 'user-vector-instance-wrapper) (defmethod slots-fetcher ((class user-vector-class-mixin)) 'user-vector-instance-slots) (defmethod raw-instance-allocator ((class user-vector-class-mixin)) 'allocate-user-vector-instance) ;;; ;;; The following functions and methods are not strictly necessary for ;;; user-vector-instances, but do speed things up a bit. ;;; ;;; Inform PCL that it is still safe to use its standard slot-value ;;; optimizations with user-vector-class-mixin's slot-value-using-class ;;; methods: (pushnew '(user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-slot-value-using-class-specializers*) (pushnew '(T user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-set-slot-value-using-class-specializers*) (pushnew '(user-vector-class-mixin standard-object standard-effective-slot-definition) *safe-slot-boundp-using-class-specializers*) (defmethod slot-value-using-class ((class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (%svref (user-vector-instance-slots object) location)) (cons (cdr location)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be read by the default ~s method." slotd 'slot-value-using-class))))) (if (eq value *slot-unbound*) (slot-unbound class object (slot-definition-name slotd)) value))) (defmethod (setf slot-value-using-class) (new-value (class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (setf (%svref (user-vector-instance-slots object) location) new-value)) (cons (setf (cdr location) new-value)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be written by the default ~s method." slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class user-vector-class-mixin) (object standard-object) (slotd standard-effective-slot-definition)) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (%svref (user-vector-instance-slots object) location)) (cons (cdr location)) (t (error "The slot ~s has neither :instance nor :class allocation, ~@ so it can't be read by the default ~s method." slotd 'slot-boundp-using-class))))) (not (eq value *slot-unbound*)))) (defmethod make-optimized-reader-method-function ((class user-vector-class-mixin) generic-function reader-method-prototype slot-name) (declare (ignore generic-function reader-method-prototype)) (make-user-vector-instance-reader-method-function slot-name)) (defmethod make-optimized-writer-method-function ((class user-vector-class-mixin) generic-function reader-method-prototype slot-name) (declare (ignore generic-function reader-method-prototype)) (make-user-vector-instance-writer-method-function slot-name)) (defmethod make-optimized-method-function ((class user-vector-class-mixin) generic-function boundp-method-prototype slot-name) (declare (ignore generic-function boundp-method-prototype)) (make-user-vector-instance-boundp-method-function slot-name)) (defun make-user-vector-instance-reader-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (instance) (user-instance-slot-value instance slot-name))) (defun make-user-vector-instance-writer-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (nv instance) (setf (user-instance-slot-value instance slot-name) nv))) (defun make-user-vector-instance-boundp-method-function (slot-name) (declare #.*optimize-speed*) #'(lambda (instance) (user-instance-slot-boundp instance slot-name))) (defun make-optimized-user-reader-method-function (slot-name index) (declare #.*optimize-speed*) (progn slot-name) #'(lambda (instance) (let ((value (%svref (user-vector-instance-slots instance) index))) (if (eq value *slot-unbound*) (slot-unbound (class-of instance) instance slot-name) value)))) (defun make-optimized-user-writer-method-function (index) (declare #.*optimize-speed*) #'(lambda (nv instance) (setf (%svref (user-vector-instance-slots instance) index) nv))) (defun make-optimized-user-boundp-method-function (index) (declare #.*optimize-speed*) #'(lambda (instance) (not (eq (%svref (user-vector-instance-slots instance) index) *slot-unbound*)))) (defmacro with-user-instance-slots (slot-entries instance-form &body body) "Optimized version of With-Slots that assumes that the instance-form evaluates to a user-vector-instance. The result is undefined if it does not. With-user-vector-instance-slots is faster than With-Slots because it factors out functions common to all slot accesses on the instance. It has two extensions to With-Slots: (1) the second value of slot-entries are evaluated as forms rather than considered to be hard slot-names, allowing access of variable slot-names. (2) if a :variable-instance keyword is the first part of the body, then the instance-form is treated as a variable form, which is always expected to return an instance of the same class. The value of the keyword must be an instance that is the same class as instance-form will always return." (build-with-optimized-slots-form slot-entries instance-form body 'user-instance)) ;;; ;;; Lisp and CLOS print compatability functions: ;;; ;;; This gets really ugly because most lisps don't use PRINT-OBJECT ;;; for the printed representation of their objects like they're supposed ;;; to. (And if the lisp did, it wouldn't be using PCL.). And since ;;; user-vector-instances are implemented as simple-vectors, the only ;;; way to get their printed representations to look right is to make ;;; PRINT-OBJECT object to work. ;;; We therefore have to patch the standard lisp printing functions. ;;; If all goes well, then everything is honky-dory. If it doesn't, then ;;; debugging can get pretty messy since we were screwing with the standard ;;; printing functions. Things should work, but if they don't, then calling ;;; RESTORE-LISP-PRINTERS will get things back to normal. (defvar *old-write* NIL) (defvar *old-princ* NIL) (defvar *old-prin1* NIL) (defvar *old-print* NIL) ;; Structure dummy-print-instance is a structure whose sole purpose ;; in life is to act as a placeholder to allow the print-object of ;; user-vector-class objects to be printed. (defstruct (dummy-print-instance (:print-function print-dummy-print-instance)) (print-object-string nil)) (declaim (type list *dummy-print-instance-garbage*)) (defvar *dummy-print-instance-garbage* NIL) (defconstant *dummy-print-instance-garbage-limit* 100) (defmacro pure-array-p (x &optional (test-user-vector-instance-p T)) "Returns whether item is a 'pure' array -- i.e. not a string, and not something holding a CLOS instance." (once-only (x) `(the boolean (locally (declare (inline arrayp stringp typep)) (and (arrayp ,x) (not (stringp ,x)) #-(or cmu (and lucid pcl)) (not (typep ,x 'structure)) ,@(when test-user-vector-instance-p `((not (user-vector-instance-p ,x)))) #-(or cmu (and lucid pcl)) (not (typep ,x 'standard-object))))))) (defun copy-any-array (old-array &rest keys-passed &key key dimensions) ;; Returns a copy of old-array. If :key is provided, then the ;; elements of the new-array are the result of key applied to ;; old-array's elements. If :dimensions is provided, and it is ;; different than old-array's dimensions, then the new-array is created ;; with those dimensions, and everything that can be copied from ;; old-array is copied into it. It is an error if the rank of ;; the array specified by dimensionss is different than that of the ;; old-array. (declare (type array old-array) (type (or function null) key) (type list dimensions keys-passed)) (cond ((simple-vector-p old-array) (apply #'copy-array-contents old-array (make-array (the index (if dimensions (car dimensions) (length (the simple-vector old-array))))) keys-passed)) ((vectorp old-array) (apply #'copy-array-contents old-array (make-array (the index (if dimensions (car dimensions) (length (the vector old-array)))) :element-type (array-element-type old-array) :adjustable (adjustable-array-p old-array)) keys-passed)) ((arrayp old-array) (let* ((old-dimensions (array-dimensions old-array)) (new-dimensions (or dimensions old-dimensions)) (element-type (array-element-type old-array)) (new-array (make-array new-dimensions :element-type element-type :adjustable (adjustable-array-p old-array)))) (declare (type list old-dimensions new-dimensions) (type array new-array)) (if (or (null dimensions) (equal new-dimensions old-dimensions)) (let* ((displaced-old-array (make-array (array-total-size old-array) :element-type element-type :displaced-to old-array)) (displaced-new-array (make-array (array-total-size new-array) :element-type element-type :displaced-to new-array))) (declare (type array displaced-old-array displaced-new-array)) (copy-array-contents displaced-old-array displaced-new-array :key key)) (let ((first-dimension (min (the index (car new-dimensions)) (the index (car old-dimensions))))) (declare (type index first-dimension)) (walk-dimensions (mapcar #'min (cdr new-dimensions) (cdr old-dimensions)) #'(lambda (post-indices) (copy-array-contents old-array new-array :key key :length first-dimension :post-indices post-indices))))) new-array)))) (defun copy-array-contents (old-array new-array &key key length post-indices &allow-other-keys) ;; Copies the contents of old-array into new-array, using key if ;; supplied. Only the first :length items are copied (defaulting ;; to the length of the old-array). If :post-indices are passed, then ;; they are used as "post" indices to an aref. (macrolet ((do-copy (aref old new key key-type len post-indices) (let ((atype (if (eq aref #'svref) 'simple-vector 'array))) `(dotimes (i (the index ,len)) (setf ,(if post-indices `(apply #'aref (the ,atype ,new) i ,post-indices) `(,aref (the ,atype ,new) i)) ,(if key-type `(funcall (the ,key-type ,key) ,(if post-indices `(apply #'aref (the ,atype ,old) i ,post-indices) `(,aref (the ,atype ,old) i))) (if post-indices `(apply #'aref (the ,atype ,old) i ,post-indices) `(,aref (the ,atype ,old) i))))))) (expand-on-key (aref key old new len post-ind) `(cond ((null ,key) (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind)) ((compiled-function-p ,key) (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind)) (T (do-copy ,aref ,old ,new ,key function ,len ,post-ind))))) (if (simple-vector-p old-array) (progn (when post-indices (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS from simple-vector")) (unless length (setf length (min (length (the simple-vector old-array)) (length (the simple-vector new-array))))) (expand-on-key svref key old-array new-array length NIL)) (progn (unless length (setf length (min (the index (car (array-dimensions old-array))) (the index (car (array-dimensions new-array)))))) (if post-indices (expand-on-key #'aref key old-array new-array length post-indices) (expand-on-key aref key old-array new-array length NIL))))) new-array) (declaim (ftype (function (list function) T) walk-dimensions)) (defun walk-dimensions (dimensions fn) (declare (type list dimensions) (type function fn)) ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks ;; through every possible combination from 0 to 1- each of those ;; dimensions, and calling fn on each of them. (let ((compiled-p (compiled-function-p fn))) (labels ((doit (dims apply-dims) (declare (type list dims apply-dims)) (if (cdr dims) (let ((last-dim NIL) (dims-left NIL)) (loop (when (null (cdr dims)) (setf last-dim (car dims)) (return)) (if dims-left (nconc dims-left (list (car dims))) (setf dims-left (list (car dims)))) (setf dims (cdr dims))) (dotimes (i (the index last-dim)) (doit dims-left (cons i apply-dims)))) (if compiled-p (dotimes (i (the index (car dims))) (funcall (the compiled-function fn) (cons i apply-dims))) (dotimes (i (the index (car dims))) (funcall fn (cons i apply-dims))))))) (doit dimensions NIL)))) (defmacro funcall-printer (applyer print-function object keys) `(progn (if (or (arrayp ,object) (consp ,object)) (multiple-value-bind (converted-item garbage) (convert-user-vector-instances-to-dummy-print-instances ,object) (,applyer (the compiled-function ,print-function) converted-item ,keys) (deallocate-dummy-print-instances garbage)) (,applyer (the compiled-function ,print-function) ,object ,keys)) ,object)) (defun print-dummy-print-instance (instance stream depth) (declare (ignore depth)) (let ((*print-pretty* NIL)) (funcall (the compiled-function *old-princ*) (dummy-print-instance-print-object-string instance) stream))) (defun allocate-dummy-print-instance (print-object-string) (if *dummy-print-instance-garbage* (let ((instance (pop *dummy-print-instance-garbage*))) (setf (dummy-print-instance-print-object-string instance) print-object-string) instance) (make-dummy-print-instance :print-object-string print-object-string))) (defun dummy-print-instance-of (user-vector-instance) (allocate-dummy-print-instance (with-output-to-string (str) (print-object user-vector-instance str)))) (defun deallocate-dummy-print-instances (dummies) (let ((count (length *dummy-print-instance-garbage*))) (declare (type index count)) (dolist (dummy dummies) (when (> count *dummy-print-instance-garbage-limit*) (return)) (push dummy *dummy-print-instance-garbage*) (setf count (the index (1+ count)))))) (defun convert-user-vector-instances-to-dummy-print-instances (item) (let ((print-length (or *print-length* 1000)) (print-level (or *print-level* 1000)) (dummy-print-instances-used NIL)) (declare (fixnum print-length print-level)) (labels ((doit (item level length) (declare (fixnum level length)) (labels ((user-vector-instance-visible-within-p (item level length) (declare (fixnum level length)) (cond ((>= length print-length) NIL) ((> level print-level) NIL) ((= level print-level) (user-vector-instance-p item)) (T (cond ((user-vector-instance-p item) T) ((consp item) (or (user-vector-instance-visible-within-p (car item) (the fixnum (1+ level)) 0) (user-vector-instance-visible-within-p (cdr item) level (the fixnum (1+ length))))) ((and *print-array* (pure-array-p item)) (let ((next-level (the fixnum (1+ level)))) (declare (fixnum next-level)) (dotimes (i (1- (length (the array item))) NIL) (unless (< i print-length) (return NIL)) (if (user-vector-instance-visible-within-p (aref item i) next-level 0) (return T)))))))))) ;; doit body (cond ((user-vector-instance-p item) (let ((dummy (dummy-print-instance-of item))) (push dummy dummy-print-instances-used) dummy)) ((consp item) (if (user-vector-instance-visible-within-p item level length) (cons (doit (car item) (the fixnum (1+ level)) length) (doit (cdr item) level (the fixnum (1+ length)))) item)) ((and *print-array* (pure-array-p item NIL)) (if (user-vector-instance-visible-within-p item level length) (copy-any-array item :key #'(lambda (item) (if (user-vector-instance-p item) (let ((dummy (dummy-print-instance-of item))) (push dummy dummy-print-instances-used) dummy) item)) :dimensions (mapcar #'1+ (array-dimensions item))) item)) (T item))))) ;; convert-user-vector-instances-to-dummy-print-instances body (let ((converted (doit item 0 0))) (values converted dummy-print-instances-used))))) (force-compile 'convert-user-vector-instances-to-dummy-print-instances) (unless *old-write* (setf *old-write* (symbol-function 'write))) (defun new-write (object &rest keys-passed) (declare (list keys-passed)) (funcall-printer apply *old-write* object keys-passed)) (force-compile 'write) (setf (symbol-function 'write) (symbol-function 'new-write)) (unless *old-princ* (setf *old-princ* (symbol-function 'princ))) (defun princ (object &optional stream) (funcall-printer funcall *old-princ* object stream)) (force-compile 'princ) (unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1))) (defun prin1 (object &optional stream) (funcall-printer funcall *old-prin1* object stream)) (force-compile 'prin1) (unless *old-print* (setf *old-print* (symbol-function 'print))) (defun print (object &optional stream) (funcall-printer funcall *old-print* object stream)) (force-compile 'print) (defun new-write-to-string (object &rest keys-passed) (declare (list keys-passed)) (with-output-to-string (string-stream) (apply #'write object :stream string-stream keys-passed))) (force-compile 'write-to-string) (setf (symbol-function 'write-to-string) (symbol-function 'new-write-to-string)) (defun princ-to-string (object) (with-output-to-string (string-stream) (funcall-printer funcall *old-princ* object string-stream) string-stream)) (force-compile 'princ-to-string) (defun prin1-to-string (object) (with-output-to-string (string-stream) (funcall-printer funcall *old-prin1* object string-stream) string-stream)) (force-compile 'prin1-to-string) (defun restore-lisp-printers () (setf (symbol-function 'write) *old-write*) (setf (symbol-function 'princ) *old-princ*) (setf (symbol-function 'prin1) *old-prin1*) (setf (symbol-function 'print) *old-print*)) gcl/pcl/extensions/inline.lisp0000644000175000017500000002233612240167764015402 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- (in-package :pcl) ;; This file contains some of the things that will have to change to support ;; inlining of methods. (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The method-lambda argument to make-method-lambda, ~S,~ is not a lambda form" method-lambda)) (multiple-value-bind (documentation declarations real-body) (extract-declarations (cddr method-lambda) env) (let* ((name-decl (get-declaration 'method-name declarations)) (sll-decl (get-declaration 'method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) (generic-function-name (when method-name (car method-name))) (specialized-lambda-list (or sll-decl (cadr method-lambda)))) (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters (mapcar #'(lambda (r s) (declare (ignore s)) r) parameters specializers)) (slots (mapcar #'list required-parameters)) (calls (list nil)) (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters declarations method-name specializers)) (class-declarations `(declare ,@(remove nil (mapcar #'(lambda (a s) (and (symbolp s) (neq s 't) `(class ,a ,s))) parameters specializers)))) (method-lambda ;; Remove the documentation string and insert the ;; appropriate class declarations. The documentation ;; string is removed to make it easy for us to insert ;; new declarations later, they will just go after the ;; cadr of the method lambda. The class declarations ;; are inserted to communicate the class of the method's ;; arguments to the code walk. `(lambda ,lambda-list ,class-declarations ,@declarations (progn ,@parameters-to-reference) (block ,(if (listp generic-function-name) (cadr generic-function-name) generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p (eval (car real-body)))) (plist (if (and constant-value-p (or (typep constant-value '(or number character)) (and (symbolp constant-value) (symbol-package constant-value)))) (list :constant-value constant-value) ())) (applyp (dolist (p lambda-list nil) (cond ((memq p '(&optional &rest &key)) (return t)) ((eq p '&aux) (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep next-method-p-p) (walk-method-lambda method-lambda required-parameters env slots calls) (multiple-value-bind (ignore walked-declarations walked-lambda-body) (extract-declarations (cddr walked-lambda)) (declare (ignore ignore)) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p 't plist))) (when (some #'cdr slots) (multiple-value-bind (slot-name-lists call-list) (slot-name-lists-from-slots slots calls) (let ((pv-table-symbol (make-symbol "pv-table"))) (setq plist `(,@(when slot-name-lists `(:slot-name-lists ,slot-name-lists)) ,@(when call-list `(:call-list ,call-list)) :pv-table-symbol ,pv-table-symbol ,@plist)) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists ,pv-table-symbol) ,@walked-lambda-body)))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) (setq lambda-list (nconc (ldiff lambda-list aux) (list '&allow-other-keys) aux)))) (values `(lambda (.method-args. .next-methods.) (simple-lexical-method-functions (,lambda-list .method-args. .next-methods. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p :closurep ,closurep :applyp ,applyp) ,@walked-declarations ,@walked-lambda-body)) `(,@(when plist `(:plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) (define-inline-function slot-value (instance slot-name) (form closure-p env) :predicate (and (not closure-p) (constantp slot-name)) :inline-arguments (required-parameters slots) :inline (optimize-slot-value slots (can-optimize-access form required-parameters env) form)) ;collect information about: ; uses of the required-parameters ; uses of call-next-method and next-method-p: ; called-p ; apply-p ; arglist info ;optimize calls to slot-value, set-slot-value, slot-boundp ;optimize calls to find-class ;optimize generic-function calls (defun make-walk-function (required-parameters info slots calls) #'(lambda (form context env) (cond ((not (eq context ':eval)) form) ((not (listp form)) form) ((eq (car form) 'call-next-method) (setq call-next-method-p 't) form) ((eq (car form) 'next-method-p) (setq next-method-p-p 't) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p 't) (setq closurep t) form) ((eq (cadr form) 'next-method-p) (setq next-method-p-p 't) (setq closurep t) form) (t nil)))) ((and (or (eq (car form) 'slot-value) (eq (car form) 'set-slot-value) (eq (car form) 'slot-boundp)) (constantp (caddr form))) (let ((parameter (can-optimize-access form required-parameters env))) (ecase (car form) (slot-value (optimize-slot-value slots parameter form)) (set-slot-value (optimize-set-slot-value slots parameter form)) (slot-boundp (optimize-slot-boundp slots parameter form))))) ((and (or (symbolp (car form)) (and (consp (car form)) (eq (caar form) 'setf))) (gboundp (car form)) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition (car form))) (funcallable-instance-p (gdefinition (car form))))) (optimize-generic-function-call form required-parameters env slots calls)) (t form)))) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let* ((call-next-method-p nil) ;flag indicating that call-next-method ;should be in the method definition (closurep nil) ;flag indicating that #'call-next-method ;was seen in the body of a method (next-method-p-p nil) ;flag indicating that next-method-p ;should be in the method definition (walk-functions `((call-next-method-p ,#'(lambda (form closure-p env) (setq call-next-method-p 't) (when closure-p (setq closurep t)) form)) (next-method-p ,#'(lambda (form closure-p env) (setq next-method-p-p 't) (when closure-p (setq closurep t)) form)) ((slot-value set-slot-value slot-boundp) ,#'(lambda (form closure-p env) (if (and (not closure-p) (constantp (caddr form))) (let ((walked-lambda (walk-form method-lambda env (make-walk-function `((call-next-method-p ,#'(lambda (form closure-p env) (setq call-next-method-p 't) (when closure-p (setq closurep t)) form)) (next-method-p ,#'(lambda (form closure-p env) (setq next-method-p-p 't) (when closure-p (setq closurep t)) form)) ((slot-value set-slot-value slot-boundp) ,#'(lambda (form closure-p env) ( (values walked-lambda call-next-method-p closurep next-method-p-p))))) (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs ':function)) (method-spec (getf initargs ':method-spec)) (plist (getf initargs ':plist)) (pv-table-symbol (getf plist ':pv-table-symbol)) (pv-table nil) (mff (getf initargs ':fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) (when mff (setf (method-function-get mff p) v)))) (when method-spec (when mf (setq mf (set-function-name mf method-spec))) (when mff (let ((name `(,(or (get (car method-spec) 'fast-sym) (setf (get (car method-spec) 'fast-sym) (intern (format nil "FAST-~A" (car method-spec)) *the-pcl-package*))) ,@(cdr method-spec)))) (set-function-name mff name) (unless mf (set-mf-property :name name))))) (when plist (let ((snl (getf plist :slot-name-lists)) (cl (getf plist :call-list))) (when (or snl cl) (setq pv-table (intern-pv-table :slot-name-lists snl :call-list cl)) (when pv-table (set pv-table-symbol pv-table)) (set-mf-property :pv-table pv-table))) (loop (when (null plist) (return nil)) (set-mf-property (pop plist) (pop plist))) (when method (set-mf-property :method method)) (when return-function-p (or mf (method-function-from-fast-function mff))))))) gcl/pcl/impl/0000755000175000017500000000000012240167764011767 5ustar cammcammgcl/pcl/impl/gold-hill/0000755000175000017500000000000012240167764013642 5ustar cammcammgcl/pcl/impl/gold-hill/gold-patches.lisp0000644000175000017500000001314612240167764017112 0ustar cammcamm;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*- (in-package 'user) (setq c::optimize-speed 3) (setq c::optimize-safety 0) (setq c::optimize-space 0) (remprop 'macroexpand 'c::fdesc) (remprop 'macroexpand-1 'c::fdesc) ;;; this is here to fix the printer so it will find the print ;;; functions on structures that have 'em. (in-package 'lisp) (defun %write-structure (struct output-stream print-vars level) (let* ((name (svref struct 0)) (pfun (or (let ((temp (get name 'structure-descriptor))) (and temp (dd-print-function temp))) (get name :print-function)))) (declare (symbol name)) (cond (pfun (funcall pfun struct output-stream level)) ((and (pv-level print-vars) (>= level (pv-level print-vars))) (write-char #\# output-stream)) ((and (pv-circle print-vars) (%write-circle struct output-stream (pv-circle print-vars)))) (t (let ((pv-length (pv-length print-vars)) (pv-pretty (pv-pretty print-vars))) (when pv-pretty (pp-push-level pv-pretty)) (incf level) (write-string "#s(" output-stream) (cond ((and pv-length (>= 0 pv-length)) (write-string "...")) (t (%write-symbol name output-stream print-vars) (do ((i 0 (1+ i)) (n 0) (slots (dd-slots (get name 'structure-descriptor)) (rest slots))) ((endp slots)) (declare (fixnum i n) (list slots)) (when pv-pretty (pp-insert-break pv-pretty *structure-keyword-slot-spec* t)) (write-char #\space output-stream) (when (and pv-length (>= (incf n) pv-length)) (write-string "..." output-stream) (return)) (write-char #\: output-stream) (%write-symbol-name (symbol-name (dsd-name (first slots))) output-stream print-vars) (when pv-pretty (pp-insert-break pv-pretty *structure-data-slot-spec* nil)) (write-char #\space output-stream) (when (and pv-length (>= (incf n) pv-length)) (write-string "..." output-stream) (return)) (%write-object (svref struct (dsd-index (first slots))) output-stream print-vars level)))) (write-char #\) output-stream) (when pv-pretty (pp-pop-level pv-pretty))))))) (eval-when (eval) (compile '%write-structure)) ;;; ;;; Apparently, whoever implemented the TIME macro didn't consider that ;;; someone might want to use it in a non-null lexical environment. Of ;;; course this fix is a loser since it binds a whole mess of variables ;;; around the evaluation of form, but it will do for now. ;;; (in-package 'lisp) (DEFmacro TIME (FORM) `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS) (FORMAT *trace-output* "~&Evaluating: ~A" ,form) ;; read the start time. (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START) (SYS::%SYSINT #X21 #X2C00 0 0 0)) ;; Eval the form. (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form))) ;; Read the end time. (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH) (SYS::%SYSINT #X21 #X2C00 0 0 0)) ;; Unpack start and end times. (SETQ S-HSEC (LOGAND START #X0FF) F-HSEC (LOGAND FINISH #X0FF) S-SEC (LSH START -8) F-SEC (LSH FINISH -8) S-MIN (LOGAND #X0FF S-MIN) F-MIN (LOGAND #X0FF F-MIN)) (SETQ F-HSEC (- F-HSEC S-HSEC)) ; calc hundreths (IF (MINUSP F-HSEC) (SETQ F-HSEC (+ F-HSEC 100) F-SEC (1- F-SEC))) (SETQ F-SEC (- F-SEC S-SEC)) ; calc seconds (IF (MINUSP F-SEC) (SETQ F-SEC (+ F-SEC 60) F-MIN (1- F-MIN))) (SETQ F-MIN (- F-MIN S-MIN)) ; calc minutes (IF (MINUSP F-MIN) (INCF F-MIN 60)) (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%" F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC) (VALUES-LIST VALS))) ;;; ;;; Patch to PROGV ;;; (in-package sys::*compiler-package-load*) ;;; This is a fully portable (though not very efficient) ;;; implementation of PROGV as a macro. It does its own special ;;; binding (shallow binding) by saving the original values in a ;;; list, and marking things that were originally unbound. (defun PORTABLE-PROGV-BIND (symbol old-vals place-holder) (let ((val-to-save '#:value-to-save)) `(let ((,val-to-save (if (boundp ,symbol) (symbol-value ,symbol) ,place-holder))) (if ,old-vals (rplacd (last ,old-vals) (ncons ,val-to-save)) (setq ,old-vals (ncons ,val-to-save)))))) (defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder) (let ((val-to-restore '#:value-to-restore)) `(let ((,val-to-restore (pop ,old-vals))) (if (eq ,val-to-restore ,place-holder) (makunbound ,symbol) (setf (symbol-value ,symbol) ,val-to-restore))))) (deftransform PROGV PORTABLE-PROGV-TRANSFORM (symbols-form values-form &rest body) (let ((symbols-lst '#:symbols-list) (values-lst '#:values-list) (syms '#:symbols) (vals '#:values) (sym '#:symbol) (old-vals '#:old-values) (unbound-holder ''#:unbound-holder)) `(let ((,symbols-lst ,symbols-form) (,values-lst ,values-form) (,old-vals nil)) (unless (and (listp ,symbols-lst) (listp ,values-lst)) (error "PROGV: Both symbols and values must be lists")) (unwind-protect (do ((,syms ,symbols-lst (cdr ,syms)) (,vals ,values-lst (cdr ,vals)) (,sym nil)) ((null ,syms) (progn ,@body)) (setq ,sym (car ,syms)) (if (symbolp ,sym) ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder) (error "PROGV: Object to be bound not a symbol: ~S" ,sym)) (if ,vals (setf (symbol-value ,sym) (first ,vals)) (makunbound ,sym))) (dolist (,sym ,symbols-lst) ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder)))))) gcl/pcl/impl/gold-hill/gold-low.lisp0000644000175000017500000000337312240167764016265 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; (in-package 'pcl) ;;; fix a bug in gcl macro-expander (or->cond->or->cond->...) (setf (get 'cond 'lisp::macro-expander) nil) ;;; fix another bug in gcl3_0 case macro-expander (defun lisp::eqv (a b) (eql a b)) (defun printing-random-thing-internal (thing stream) (multiple-value-bind (offaddr baseaddr) (sys:%pointer thing) (princ baseaddr stream) (princ ", " stream) (princ offaddr stream))) ;;; ;;; This allows the compiler to compile a file with many "DEFMETHODS" ;;; in succession. ;;; (dolist (x '(defmethod defgeneric defclass precompile-random-code-segments)) (setf (get x 'gcl::compile-separately) t)) gcl/pcl/impl/hp/0000755000175000017500000000000012240167764012376 5ustar cammcammgcl/pcl/impl/hp/hp-low.lisp0000644000175000017500000000245712240167764014505 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the HP Common Lisp version of the file low. ;;; ;;; (in-package 'pcl) (defun printing-random-thing-internal (thing stream) (format stream "~O" (prim:@inf thing))) gcl/pcl/impl/cmu/0000755000175000017500000000000012240167764012553 5ustar cammcammgcl/pcl/impl/cmu/README0000644000175000017500000000077412240167764013443 0ustar cammcammTo install, put this version of PCL in cmucl's source directory, and name it pcl. rename the cmucl file tools/pclcom.lisp to tools/pclcom.lisp.original link the file impl/cmu/pclcom.lisp to cmucl/tools/pclcom.lisp link the file impl/cmu/pclload.lisp to pclload.lisp For example, cd cmucl17f mv pcl pcl.original <> cd tools mv pclcom.lisp pclcom.lisp.original ln -s ../pcl/impl/cmu/pclcom.lisp pclcom.lisp cd ../pcl ln -s impl/cmu/pclload.lisp pclload.lisp gcl/pcl/impl/cmu/pclload.lisp0000644000175000017500000000063012240167764015061 0ustar cammcamm(in-package "PCL") (unless (find-package "SLOT-ACCESSOR-NAME") (make-package "SLOT-ACCESSOR-NAME")) (rename-package "PCL" "PCL" '("OLD-PCL")) (rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '("OLD-SLOT-ACCESSOR-NAME")) (import 'kernel:funcallable-instance-p) (load "target:pcl/defsys") (load-pcl) (rename-package "PCL" "PCL" '()) (rename-package "SLOT-ACCESSOR-NAME" "SLOT-ACCESSOR-NAME" '()) gcl/pcl/impl/cmu/cmu-low.lisp0000644000175000017500000001610012240167764015025 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the CMU Lisp version of the file low. ;;; (in-package :pcl) #+small (setq *optimize-speed* '(optimize (speed 3) (safety 0) (debug 0.5) (ext:inhibit-warnings 3))) (defmacro dotimes ((var count &optional (result nil)) &body body) `(lisp:dotimes (,var (the fixnum ,count) ,result) (declare (fixnum ,var)) ,@body)) ;;; Just use our without-interrupts. We don't have the INTERRUPTS-ON/OFF local ;;; macros spec'ed in low.lisp, but they aren't used. ;;; (defmacro without-interrupts (&rest stuff) `(sys:without-interrupts ,@stuff)) (defun function-arglist (fcn) "Returns the argument list of a compiled function, if possible." (cond ((symbolp fcn) (when (fboundp fcn) (function-arglist (symbol-function fcn)))) ((eval:interpreted-function-p fcn) (eval:interpreted-function-arglist fcn)) ((functionp fcn) (let ((lambda-expr (function-lambda-expression fcn))) (if lambda-expr (cadr lambda-expr) (let ((function (kernel:%closure-function fcn))) (values (read-from-string (kernel:%function-arglist function))))))))) ;;; And returns the function, not the *name*. (defun set-function-name (fcn new-name) "Set the name of a compiled function object." (declare (special *boot-state* *the-class-standard-generic-function*)) (cond ((symbolp fcn) (set-function-name (symbol-function fcn) new-name)) ((funcallable-instance-p fcn) (if (if (eq *boot-state* 'complete) (typep fcn 'generic-function) (eq (class-of fcn) *the-class-standard-generic-function*)) (setf (kernel:%funcallable-instance-info fcn 1) new-name) (typecase fcn (kernel:byte-closure (set-function-name (kernel:byte-closure-function fcn) new-name)) (kernel:byte-function (setf (kernel:byte-function-name fcn) new-name)))) fcn) ((eval:interpreted-function-p fcn) (setf (eval:interpreted-function-name fcn) new-name) fcn) (t (let ((header (kernel:%closure-function fcn))) #+cmu17 (setf (c::%function-name header) new-name) #-cmu17 (system:%primitive c::set-function-name header new-name)) fcn))) (in-package "C") (def-source-context pcl:defmethod (name &rest stuff) (let ((arg-pos (position-if #'listp stuff))) (if arg-pos `(pcl:defmethod ,name ,@(subseq stuff 0 arg-pos) ,(nth-value 2 (pcl::parse-specialized-lambda-list (elt stuff arg-pos)))) `(pcl:defmethod ,name "")))) (in-package "PCL") ;;;; STD-INSTANCE ;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate ;;; between functions (including FINs) and normal instances, so we can return ;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) ;;; are changed to pcl-instance-p. ;;; (defmacro std-instance-p (x) `(kernel:%instancep ,x)) (defmacro pcl-instance-p (x) `(typep (kernel:layout-of ,x) 'wrapper)) ;;; We define this as STANDARD-INSTANCE, since we're going to clobber the ;;; layout with some standard-instance layout as soon as we make it, and we ;;; want the accesor to still be type-correct. ;;; (defstruct (standard-instance (:predicate nil) (:constructor %%allocate-instance--class--fn ()) (:alternate-metaclass kernel:instance lisp:standard-class kernel:make-standard-class)) (slots nil)) ;;; Must immediately setf the std-instance-wrapper after calling this. (defmacro %%allocate-instance--class () `(ext:truly-the standard-instance (kernel:%make-instance 2))) ;;; Both of these operations "work" on structures, which allows the above ;;; weakening of std-instance-p. ;;; (defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) (defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) (defmacro get-wrapper (inst) (ext:once-only ((wrapper `(wrapper-of ,inst))) `(progn (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?") ,wrapper))) (defmacro get-instance-wrapper-or-nil (inst) (ext:once-only ((wrapper `(wrapper-of ,inst))) `(if (typep ,wrapper 'wrapper) ,wrapper nil))) ;;; get-slots harmless (defmacro get-slots-or-nil (inst) (ext:once-only ((n-inst inst)) `(when (pcl-instance-p ,n-inst) (if (std-instance-p ,n-inst) (std-instance-slots ,n-inst) (fsc-instance-slots ,n-inst))))) ;;;; Structure-instance stuff: (pushnew :structure-wrapper *features*) (defun structure-functions-exist-p () t) (defun structure-instance-p (x) (typep x 'lisp:structure-object)) (defun structurep (x) (typep x 'lisp:structure-object)) (defun structure-type (x) (lisp:class-name (kernel:layout-class (kernel:%instance-layout x)))) (defun structure-type-p (type) (and (symbolp type) (let ((class (lisp:find-class type nil))) (and class (typep (kernel:layout-info (kernel:class-layout class)) 'kernel:defstruct-description))))) (defun get-structure-dd (type) (kernel:layout-info (kernel:class-layout (lisp:find-class type)))) (defun structure-type-included-type-name (type) (let ((include (kernel::dd-include (get-structure-dd type)))) (if (consp include) (car include) include))) (defun structure-type-slot-description-list (type) (nthcdr (length (let ((include (structure-type-included-type-name type))) (and include (kernel:dd-slots (get-structure-dd include))))) (kernel:dd-slots (get-structure-dd type)))) (defun structure-slotd-name (slotd) (kernel:dsd-name slotd)) (defun structure-slotd-accessor-symbol (slotd) (kernel:dsd-accessor slotd)) (defun structure-slotd-reader-function (slotd) (fdefinition (kernel:dsd-accessor slotd))) (defun structure-slotd-writer-function (slotd) (unless (kernel:dsd-read-only slotd) (fdefinition `(setf ,(kernel:dsd-accessor slotd))))) (defun structure-slotd-type (slotd) (kernel:dsd-type slotd)) (defun structure-slotd-init-form (slotd) (kernel::dsd-default slotd)) gcl/pcl/impl/cmu/pclcom.lisp0000644000175000017500000000407312240167764014725 0ustar cammcamm;; This is "target:tools/pclcom.lisp" (in-package "USER") (when (find-package "PCL") (setf (compiler-macro-function 'make-instance) nil) ;; ;; Undefine all generic functions exported from Lisp so that bootstrapping ;; doesn't get confused. (let ((class (find-class 'generic-function nil))) (when class (do-external-symbols (sym "LISP") (when (and (fboundp sym) (typep (fdefinition sym) class)) (fmakunbound sym)) (let ((ssym `(setf ,sym))) (when (and (fboundp ssym) (typep (fdefinition ssym) class)) (fmakunbound ssym)))))) ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots. (let ((wot (find-symbol "*FIND-CLASS*" "PCL"))) (when (and wot (boundp wot)) (do-hash (name ignore (symbol-value wot)) (declare (ignore ignore)) (let ((class (find-class name nil))) (cond ((not class)) ((typep class 'kernel::std-class) (setf (kernel:class-cell-class (kernel:find-class-cell name)) nil) (setf (info type kind name) nil)) (t (setf (kernel:class-pcl-class class) nil))))))) (rename-package "PCL" "OLD-PCL") (make-package "PCL")) (when (find-package "SLOT-ACCESSOR-NAME") (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME")) (setf c:*suppress-values-declaration* t) (pushnew :setf *features*) (setf (search-list "pcl:") '("target:pcl/")) (let ((obj (make-pathname :defaults "pcl:defsys" :type (c:backend-fasl-file-type c:*backend*)))) (when (< (or (file-write-date obj) 0) (file-write-date "pcl:defsys.lisp")) (compile-file "pcl:defsys" :byte-compile t))) (load "pcl:defsys" :verbose t) (import 'kernel:funcallable-instance-p (find-package "PCL")) (with-compilation-unit (:optimize '(optimize (debug #+small .5 #-small 2) (speed 2) (safety #+small 0 #-small 2) (inhibit-warnings 2)) :optimize-interface '(optimize-interface #+small (safety 1)) :context-declarations '((:external (declare (optimize-interface (safety 2) (debug 1)))) ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) (declare (optimize (speed 0)))))) (pcl::compile-pcl)) gcl/pcl/impl/ibcl/0000755000175000017500000000000012240167764012700 5ustar cammcammgcl/pcl/impl/ibcl/ibcl-low.lisp0000644000175000017500000002546512240167764015315 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for Kyoto Common Lisp (KCL) (in-package 'pcl) ;;; ;;; The reason these are here is because the KCL compiler does not allow ;;; LET to return FIXNUM values as values of (c) type int, hence the use ;;; of LOCALLY (which expands into (LET () (DECLARE ...) ...)) forces ;;; conversion of ints to objects. ;;; (defmacro %logand (&rest args) (reduce-variadic-to-binary 'logand args 0 t 'fixnum)) ;(defmacro %logxor (&rest args) ; (reduce-variadic-to-binary 'logxor args 0 t 'fixnum)) (defmacro %+ (&rest args) (reduce-variadic-to-binary '+ args 0 t 'fixnum)) ;(defmacro %- (x y) ; `(the fixnum (- (the fixnum ,x) (the fixnum ,y)))) (defmacro %* (&rest args) (reduce-variadic-to-binary '* args 1 t 'fixnum)) (defmacro %/ (x y) `(the fixnum (/ (the fixnum ,x) (the fixnum ,y)))) (defmacro %1+ (x) `(the fixnum (1+ (the fixnum ,x)))) (defmacro %1- (x) `(the fixnum (1- (the fixnum ,x)))) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) ;;; ;;; std-instance-p ;;; (si:define-compiler-macro std-instance-p (x) (once-only (x) `(and (si:structurep ,x) (eq (si:structure-name ,x) 'std-instance)))) (dolist (inline '((si:structurep ((t) compiler::boolean nil nil "type_of(#0)==t_structure") compiler::inline-always) (si:structure-name ((t) t nil nil "(#0)->str.str_name") compiler::inline-unsafe))) (setf (get (first inline) (third inline)) (list (second inline)))) (setf (get 'cclosure-env 'compiler::inline-always) (list '((t) t nil nil "(#0)->cc.cc_env"))) ;;; ;;; turbo-closure patch. See the file kcl-mods.text for details. ;;; #+:turbo-closure (progn (CLines "object tc_cc_env_nthcdr (n,tc)" "object n,tc; " "{return (type_of(tc)==t_cclosure&& " " tc->cc.cc_turbo!=NULL&& " " type_of(n)==t_fixnum)? " " tc->cc.cc_turbo[fix(n)]: " ; assume that n is in bounds " Cnil; " "} " ) (defentry tc-cclosure-env-nthcdr (object object) (object tc_cc_env_nthcdr)) (setf (get 'tc-cclosure-env-nthcdr 'compiler::inline-unsafe) '(((fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]"))) ) ;;;; low level stuff to hack compiled functions and compiled closures. ;;; ;;; The primary client for this is fsc-low, but since we make some use of ;;; it here (e.g. to implement set-function-name-1) it all appears here. ;;; (eval-when (compile eval) (defmacro define-cstruct-accessor (accessor structure-type field value-type field-type tag-name) (let ((setf (intern (concatenate 'string "SET-" (string accessor)))) (caccessor (format nil "pcl_get_~A_~A" structure-type field)) (csetf (format nil "pcl_set_~A_~A" structure-type field)) (vtype (intern (string-upcase value-type)))) `(progn (CLines ,(format nil "~A ~A(~A) ~%~ object ~A; ~%~ { return ((~A) ~A->~A.~A); } ~%~ ~%~ ~A ~A(~A, new) ~%~ object ~A; ~%~ ~A new; ~%~ { return ((~A)(~A->~A.~A = ~Anew)); } ~%~ " value-type caccessor structure-type structure-type value-type structure-type tag-name field value-type csetf structure-type structure-type value-type value-type structure-type tag-name field field-type )) (defentry ,accessor (object) (,vtype ,caccessor)) (defentry ,setf (object ,vtype) (,vtype ,csetf)) (defsetf ,accessor ,setf) ))) ) ;;; ;;; struct cfun { /* compiled function header */ ;;; short t, m; ;;; object cf_name; /* compiled function name */ ;;; int (*cf_self)(); /* entry address */ ;;; object cf_data; /* data the function uses */ ;;; /* for GBC */ ;;; char *cf_start; /* start address of the code */ ;;; int cf_size; /* code size */ ;;; }; ;;; add field-type tag-name (define-cstruct-accessor cfun-name "cfun" "cf_name" "object" "(object)" "cf") (define-cstruct-accessor cfun-self "cfun" "cf_self" "int" "(int (*)())" "cf") (define-cstruct-accessor cfun-data "cfun" "cf_data" "object" "(object)" "cf") (define-cstruct-accessor cfun-start "cfun" "cf_start" "int" "(char *)" "cf") (define-cstruct-accessor cfun-size "cfun" "cf_size" "int" "(int)" "cf") (CLines "object pcl_cfunp (x) " "object x; " "{if(x->c.t == (int) t_cfun) " " return (Ct); " " else " " return (Cnil); " " } " ) (defentry cfunp (object) (object pcl_cfunp)) ;;; ;;; struct cclosure { /* compiled closure header */ ;;; short t, m; ;;; object cc_name; /* compiled closure name */ ;;; int (*cc_self)(); /* entry address */ ;;; object cc_env; /* environment */ ;;; object cc_data; /* data the closure uses */ ;;; /* for GBC */ ;;; char *cc_start; /* start address of the code */ ;;; int cc_size; /* code size */ ;;; }; ;;; (define-cstruct-accessor cclosure-name "cclosure" "cc_name" "object" "(object)" "cc") (define-cstruct-accessor cclosure-self "cclosure" "cc_self" "int" "(int (*)())" "cc") (define-cstruct-accessor cclosure-data "cclosure" "cc_data" "object" "(object)" "cc") (define-cstruct-accessor cclosure-start "cclosure" "cc_start" "int" "(char *)" "cc") (define-cstruct-accessor cclosure-size "cclosure" "cc_size" "int" "(int)" "cc") (define-cstruct-accessor cclosure-env "cclosure" "cc_env" "object" "(object)" "cc") (CLines "object pcl_cclosurep (x) " "object x; " "{if(x->c.t == (int) t_cclosure) " " return (Ct); " " else " " return (Cnil); " " } " ) (defentry cclosurep (object) (object pcl_cclosurep)) ;; ;;;;;; Load Time Eval ;; ;;; ;;; This doesn't work because it looks at a global variable to see if it is ;;; in the compiler rather than looking at the macroexpansion environment. ;;; ;;; The result is that if in the process of compiling a file, we evaluate a ;;; form that has a call to load-time-eval, we will get faked into thinking ;;; that we are compiling that form. ;;; ;;; THIS NEEDS TO BE DONE RIGHT!!! ;;; ;(defmacro load-time-eval (form) ; ;; In KCL there is no compile-to-core case. For things that we are ; ;; "compiling to core" we just expand the same way as if were are ; ;; compiling a file since the form will be evaluated in just a little ; ;; bit when gazonk.o is loaded. ; (if (and (boundp 'compiler::*compiler-input*) ;Hack to see of we are ; compiler::*compiler-input*) ;in the compiler! ; `'(si:|#,| . ,form) ; `(progn ,form))) (defmacro load-time-eval (form) (read-from-string (format nil "'#,~S" form))) (defmacro memory-block-ref (block offset) `(svref (the simple-vector ,block) (the fixnum ,offset))) ;; ;;;;;; Generating CACHE numbers ;; ;;; This needs more work to be sure it is going as fast as possible. ;;; - The calls to si:address should be open-coded. ;;; - The logand should be open coded. ;;; ;(defmacro symbol-cache-no (symbol mask) ; (if (and (constantp symbol) ; (constantp mask)) ; `(load-time-eval (logand (ash (si:address ,symbol) -2) ,mask)) ; `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) (defmacro object-cache-no (object mask) `(logand (the fixnum (si:address ,object)) ,mask)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (defun set-function-name-1 (fn new-name ignore) (cond ((cclosurep fn) (setf (cclosure-name fn) new-name)) ((cfunp fn) (setf (cfun-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) #| (defconstant most-positive-small-fixnum 1024) /* should be supplied */ (defconstant most-negative-small-fixnum -1024) /* by ibuki */ (defmacro symbol-cache-no (symbol mask) (if (constantp mask) (if (and (> mask 0) (< mask most-positive-small-fixnum)) (if (constantp symbol) `(load-time-eval (coffset ,symbol ,mask 2)) `(coffset ,symbol ,mask 2)) (if (constantp symbol) `(load-time-eval (logand (ash (the fixnum (si:address ,symbol)) -2) ,mask)) `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) `(logand (ash (the fixnum (si:address ,symbol)) -2) ,mask))) (defmacro object-cache-no (object mask) (if (and (constantp mask) (> mask 0) (< mask most-positive-small-fixnum)) `(coffset ,object ,mask 4) `(logand (ash (the fixnum (si:address ,object)) -4) ,mask))) (CLines "object pcl_coffset (sym,mask,lshift)" "object sym,mask,lshift;" "{" " return(small_fixnum(((int)sym >> fix(lshift)) & fix(mask)));" "}" ) (defentry coffset (object object object) (object pcl_coffset)) |# gcl/pcl/impl/ibcl/ibcl-patches.lisp0000644000175000017500000001036412240167764016133 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'system) ;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere ;;; in the lambda-list. The former allows deviation from the CL spec, ;;; but what the heck. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) (defvar *old-defmacro*) (defun new-defmacro (whole env) (flet ((call-old-definition (new-whole) (funcall *old-defmacro* new-whole env))) (if (not (and (consp whole) (consp (cdr whole)) (consp (cddr whole)) (consp (cdddr whole)))) (call-old-definition whole) (let* ((ll (caddr whole)) (env-tail (do ((tail ll (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail))))) (if env-tail (call-old-definition (list* (car whole) (cadr whole) (append (list '&environment (cadr env-tail)) (ldiff ll env-tail) (cddr env-tail)) (cdddr whole))) (call-old-definition whole)))))) (eval-when (load eval) (unless (boundp '*old-defmacro*) (setq *old-defmacro* (macro-function 'defmacro)) (setf (macro-function 'defmacro) #'new-defmacro))) ;;; ;;; setf patches ;;; (in-package 'system) (defun get-setf-method (form) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value form) (unless (listp vars) (error "The temporary variables component, ~s, of the setf-method for ~s is not a list." vars form)) (unless (listp vals) (error "The values forms component, ~s, of the setf-method for ~s is not a list." vals form)) (unless (listp stores) (error "The store variables component, ~s, of the setf-method for ~s is not a list." stores form)) (unless (= (list-length stores) 1) (error "Multiple store-variables are not allowed.")) (values vars vals stores store-form access-form))) (defun get-setf-method-multiple-value (form) (cond ((symbolp form) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form))) ((or (not (consp form)) (not (symbolp (car form)))) (error "Cannot get the setf-method of ~S." form)) ((get (car form) 'setf-method) (apply (get (car form) 'setf-method) (cdr form))) ((get (car form) 'setf-update-fn) (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym))) (values vars (cdr form) (list store) `(,(get (car form) 'setf-update-fn) ,@vars ,store) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym)) (l (get (car form) 'setf-lambda)) (f `(lambda ,(car l) (funcall #'(lambda ,(cadr l) ,@(cddr l)) ',store)))) (values vars (cdr form) (list store) (apply f vars) (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand-1 form))) (t (error "Cannot expand the SETF form ~S." form)))) gcl/pcl/impl/franz/0000755000175000017500000000000012240167764013107 5ustar cammcammgcl/pcl/impl/franz/quadlap.lisp0000644000175000017500000004124512240167764015435 0ustar cammcamm;; -[Thu Mar 1 10:54:27 1990 by jkf]- ;; pcl to quad translation ;; $Header$ ;; ;; copyright (c) 1990 Franz Inc. ;; (in-package :compiler) (defvar *arg-to-treg* nil) (defvar *cvar-to-index* nil) (defvar *reg-array* nil) (defvar *closure-treg* nil) (defvar *nargs-treg* nil) (defvar *debug-sparc* nil) (defmacro pcl-make-lambda (&key required) `(list 'lambda nil :unknown-type 0 compiler::.function-level. ,required nil nil nil nil nil nil nil nil nil nil 'compiler::none nil nil nil nil nil nil nil nil nil 0 nil)) (defmacro pcl-make-varrec (&key name loc contour-level) `(list ,name nil 0 nil ,loc nil t compiler::.function-level. nil nil :unknown-type nil nil ,contour-level)) (defmacro pcl-make-lap (&key lap constants cframe-size locals) `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil)) (defstruct preg ;; pseudo reg descritpor treg ; associated treg index ; :index if this is an index type reg ; :vector if this is a vector type reg ) (defun pcl::excl-lap-closure-generator (closure-vars-names arg-names index-regs vector-regs fixnum-vector-regs t-regs lap-code) (let ((function (pcl::excl-lap-closure-gen closure-vars-names arg-names index-regs (append vector-regs fixnum-vector-regs) t-regs lap-code))) #'(lambda (&rest closure-vals) (insert-closure-vals function closure-vals)))) (defun pcl::excl-lap-closure-gen (closure-vars-names arg-names index-regs vector-regs t-regs lap-code) (let ((*quads* nil) (*treg-num* 0) (*all-tregs* nil) (*bb-count* 0) *treg-bv-size* *treg-vector* (*next-catch-frame* 0) (*max-catch-frame* -1) *catch-labels* *top-label* *mv-treg* *mv-treg-target* *zero-treg* *nil-treg* *bbs* *bb* lap ;; bbs *cross-block-regs* *const-tregs* *move-tregs* *actuals* *ignore-argcount* *binds-specs* *bvl-current-bv* ; for bitvector cacher *bvl-used-bvs* *bvl-index* (*inhibit-call-count* t) ; this fcn *arg-to-treg* *cvar-to-index* *reg-array* minargs maxargs *closure-treg* node otherargregs *nargs-treg* ) (if* *debug-sparc* then (format t ">>** << Generating sparc lap code~%")) (setq *nil-treg* #+allegro-v4.0 (new-reg :global t) #-allegro-v4.0 (new-reg) *mv-treg* (new-reg) *mv-treg-target* (list *mv-treg*) *zero-treg* (comp::new-reg)) ; examine given args (setq minargs 0 maxargs 0) (let (requireds) (dolist (arg arg-names) (if* (eq '&rest arg) then (setq maxargs nil) else (if* (null arg) then ; we want a name even though we won't use it (setq arg (gensym))) (incf minargs) (incf maxargs) (push (cons arg (new-reg)) *arg-to-treg*) (push (pcl-make-varrec :name arg :loc (cdr (car *arg-to-treg*)) :contour-level 0) requireds) )) (setq node (pcl-make-lambda :required (nreverse requireds)))) (setq *arg-to-treg* (nreverse *arg-to-treg*)) ; build closure vector list (let ((index -1)) (dolist (cvar closure-vars-names) (push (cons cvar (incf index)) *cvar-to-index*))) (let ((maxreg (max (apply #'max (cons -1 index-regs)) (apply #'max (cons -1 vector-regs)) (apply #'max (cons -1 t-regs))))) (setq *reg-array* (make-array (1+ maxreg)))) (dolist (index index-regs) (setf (svref *reg-array* index) (make-preg :treg (new-reg) :index :index))) (dolist (vector vector-regs) (setf (svref *reg-array* vector) (make-preg :treg (new-reg) :index :vector))) (dolist (tr t-regs) (setf (svref *reg-array* tr) (make-preg :treg (new-reg)))) (if* closure-vars-names then (setq *closure-treg* (new-reg))) (setq *nargs-treg* (new-reg)) ;; (md-allocate-global-tregs) ; function entry (qe nop :arg :first-block) (qe entry) (qe argcount :arg (list minargs maxargs)) (qe lambda :d (mapcar #'cdr *arg-to-treg*)) (qe register :arg :nargs :d (list *nargs-treg*)) (if* *closure-treg* then ; put the first closure vector in *closure-treg* (qe extract-closure-vec :d (list *closure-treg*)) (let ((offsetreg (new-reg))) (qe const :arg (mdparam 'md-cons-car-adj) :d (list offsetreg)) (qe ref :u (list *closure-treg* offsetreg) :d (list *closure-treg*) :arg :long)) ) (excl-gen-quads lap-code) (if* *debug-sparc* then (do-quad-list (quad next *quads*) (format t "~a~%" quad)) (format t "basic blocks~%")) (setq *bbs* (qc-compute-basic-blocks *quads*)) (excl::target-class-case ((:r :m) (setq *actuals* (qc-compute-actuals *bbs*)))) (qc-live-variable-analysis *bbs*) (setq *treg-bv-size* (* 16 (truncate (+ *treg-num* 15) 16))) (qc-build-treg-vector) (let ((*dump-bbs* nil) (r::*local-regs* ; use the in registers that aren't in use (append r::*local-regs* (if* maxargs then (nthcdr maxargs r::*in-regs* ))))) (unwind-protect (progn ; machine specific code generation (multiple-value-bind (lap-code literals size-struct locals) #+(target-class r m e) (progn #+allegro-v4.0 (md-codegen node *bbs* nil otherargregs) #-allegro-v4.0 (md-codegen node *bbs* *nil-treg* *mv-treg* *zero-treg* nil otherargregs)) #-(target-class r m e) (md-codegen node *bbs*) (setq lap (pcl-make-lap :lap lap-code :constants literals :cframe-size size-struct :locals locals))) lap) (giveback-bvs))) #+ignore (progn (format t "sparc code pre optimization~%") (dolist (instr (lap-lap lap)) (format t "> ~a~%" instr))) (md-optimize lap) ; peephole optimize (if* *debug-sparc* then (format t "sparc code post optimization~%") (dolist (instr (lap-lap lap)) (format t "> ~a~%" instr))) (md-assemble lap) (setq last-lap lap) (nl-runtime-make-a-fcnobj lap))) (defun qe-slot-access (operand offset dest) ;; access a slot in a structure (let ((temp (new-reg))) (qe const :arg offset :d (list temp)) (qe ref :u (list (get-treg-of operand) temp) :d (list (get-treg-of dest)) :arg :long))) (defun get-treg-of (operand &optional res-operand) ;; get the appropriate treg for the operand (let ((prefer-treg (and res-operand (simple-get-treg-of res-operand)))) (if* (numberp operand) then (let ((treg (new-reg))) (qe const :arg operand :d (list treg)) treg) elseif (consp operand) then (ecase (car operand) (:reg (preg-treg (svref *reg-array* (cadr operand)))) (:arg (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) (if* (null x) then (error "where is arg ~s" operand) else x))) (:cvar (let ((res-treg (or prefer-treg (new-reg))) (temp-treg (new-reg))) (qe const :arg (+ (mdparam 'md-svector-data0-adj) (* 4 (cdr (assoc (cadr operand) *cvar-to-index* :test #'eq)))) :d (list temp-treg)) (qe ref :u (list *closure-treg* temp-treg) :d (list res-treg) :arg :long) res-treg)) (:constant (let ((treg (or prefer-treg (new-reg)))) (qe const :arg (if* (fixnump (cadr operand)) then (* 8 (cadr operand)) ; md!! else (cadr operand)) :d (list treg)) treg)) (:index-constant ; operand invented by jkf to denote an index type constant (let ((treg (or prefer-treg (new-reg)))) (qe const :arg (if* (fixnump (cadr operand)) then (* 4 (cadr operand)) ; md!! else (cadr operand)) :d (list treg)) treg))) else (error "bad operand: ~s" operand)))) (defun simple-get-treg-of (operand) ;; get the treg if it is so simple that we don't have to ;; emit any instructions to access it. ;; return nil if we can't do it. (if* (numberp operand) then nil elseif (consp operand) then (case (car operand) (:reg (preg-treg (svref *reg-array* (cadr operand)))) (:arg (let ((x (cdr (assoc (cadr operand) *arg-to-treg* :test #'eq)))) (if* (null x) then nil else x)))) else nil)) (defun index-p (operand) ;; determine if the result of this operand is an index value ;* it would be better if conversion between lisp values and ; index values were made explicit in the lap code (and (consp operand) (or (and (eq :reg (car operand)) (eq :index (preg-index (svref *reg-array* (cadr operand))))) (member (car operand) '(:i+ :i- :ilogand :ilogxor :i1+) :test #'eq)) t)) (defun gen-index-treg (operand) ;; return the non-index type operand in a index treg (if* (and (consp operand) (eq ':constant (car operand))) then (get-treg-of `(:index-constant ,(cadr operand))) else (let ((treg (get-treg-of operand)) (new-reg (new-reg)) (shift-reg (new-reg))) (qe const :arg 1 :d (list shift-reg)) (qe lsr :u (list treg shift-reg) :d (list new-reg)) new-reg))) (defun vector-preg-p (operand) (and (consp operand) (eq :reg (car operand)) (eq :vector (preg-index (svref *reg-array* (cadr operand)))))) (defun excl-gen-quads (laps) ;; generate quads from the lap (dolist (lap laps) (if* *debug-sparc* then (format t ">> ~a~%" lap)) (block again (let ((opcode (car lap)) (op1 (cadr lap)) (op2 (caddr lap))) (case opcode (:move ; can be either simple (both args registers) ; or one arg can be complex and the other simple (case (car op2) ((:iref :instance-ref) ;; assume that this is a lisp store ;;(warn "assuming lisp store in ~s" lap) (let (op1-treg) (if* (not (vector-preg-p (cadr op2))) then ; must offset before store (error "must use vector register in ~s" lap) else (setq op1-treg (get-treg-of (cadr op2)))) (qe set :u (list op1-treg (get-treg-of (caddr op2)) (get-treg-of op1)) :arg :lisp) (return-from again))) (:cdr ;; it certainly is a lisp stoer (let (op1-treg const-reg) (setq op1-treg (get-treg-of (cadr op2))) (setq const-reg (new-reg)) (qe const :arg (mdparam 'md-cons-cdr-adj) :d (list const-reg)) (qe set :u (list op1-treg const-reg (get-treg-of op1)) :arg :lisp) (return-from again)))) ; the 'to'address is simple, the from address may not be (let ((index1 (index-p op1)) (index2 (index-p op2)) (vector1 (vector-preg-p op1)) (vector2 (vector-preg-p op2))) (ecase (car op1) ((:reg :cvar :arg :constant :lisp-symbol) (qe move :u (list (get-treg-of op1 op2)) :d (list (get-treg-of op2)))) (:std-wrapper (qe-slot-access (cadr op1) (+ (* 1 4) (comp::mdparam 'md-svector-data0-adj)) op2)) (:std-slots (qe-slot-access (cadr op1) (+ (* 2 4) (comp::mdparam 'md-svector-data0-adj)) op2)) (:fsc-wrapper (qe-slot-access (cadr op1) (+ (* (- 15 1) 4) (comp::mdparam 'md-function-const0-adj)) op2)) (:fsc-slots (qe-slot-access (cadr op1) (+ (* (- 15 2) 4) (comp::mdparam 'md-function-const0-adj)) op2)) ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper) (qe call :arg 'pcl::built-in-or-structure-wrapper :u (list (get-treg-of (cadr op1))) :d (list (get-treg-of op2)))) (:other-wrapper (warn "do other-wrapper")) ((:i+ :i- :ilogand :ilogxor) (qe arith :arg (cdr (assoc (car op1) '((:i+ . :+) (:i- . :-) (:ilogand . :logand) (:ilogxor . :logxor)) :test #'eq)) :u (list (get-treg-of (cadr op1)) (get-treg-of (caddr op1))) :d (list (get-treg-of op2)))) (:i1+ (let ((const-reg (new-reg))) (qe const :arg 4 ; an index value of 1 :d (list const-reg)) (qe arith :arg :+ :u (list const-reg (get-treg-of (cadr op1))) :d (list (get-treg-of op2))))) ((:iref :cref :instance-ref) (let (op1-treg) (if* (not (vector-preg-p (cadr op1))) then ; must offset before store (error "must use vector register in ~s" lap) else (setq op1-treg (get-treg-of (cadr op1)))) (qe ref :u (list op1-treg (get-treg-of (caddr op1) op2)) :d (list (get-treg-of op2)) :arg :long))) (:cdr (let ((const-reg (new-reg))) (qe const :arg (mdparam 'md-cons-cdr-adj) :d (list const-reg)) (qe ref :arg :long :u (list (get-treg-of (cadr op1)) const-reg) :d (list (get-treg-of op2)))))) (if* (not (eq index1 index2)) then (let ((shiftamt (new-reg))) (qe const :arg 1 :d (list shiftamt)) (if* (and index1 (not index2)) then ; converting from index to non-index (qe lsl :u (list (get-treg-of op2) shiftamt) :d (list (get-treg-of op2))) elseif (and (not index1) index2) ; converting to an index then (qe lsr :u (list (get-treg-of op2) shiftamt) :d (list (get-treg-of op2))))) elseif (and vector2 (not vector1)) then ; add vector offset (let ((tempreg (new-reg)) (vreg (get-treg-of op2))) (qe const :arg (mdparam 'md-svector-data0-adj) :d (list tempreg)) (qe arith :arg :+ :u (list vreg tempreg) :d (list vreg)))))) (:fix= (let (tr1 tr2) (if* (index-p op1) then (setq tr1 (get-treg-of op1)) (if* (not (index-p op2)) then (setq tr2 (gen-index-treg op2)) else (setq tr2 (get-treg-of op2))) elseif (index-p op2) then ; assert: op1 isn't an index treg (setq tr1 (gen-index-treg op1)) (setq tr2 (get-treg-of op2)) else (setq tr1 (get-treg-of op1) tr2 (get-treg-of op2))) (qe bcc :u (list tr1 tr2) :arg (cadddr lap) :arg2 :eq ))) ((:eq :neq :fix=) (if* (not (eq (index-p op1) (index-p op2))) then (error "non matching operands indexwise in: ~s" lap)) (qe bcc :u (list (get-treg-of op1) (get-treg-of op2)) :arg (cadddr lap) :arg2 (cdr (assoc opcode '((:eq . :eq) (:neq . :ne)) :test #'eq)))) (:izerop (qe bcc :u (list (get-treg-of op1) *zero-treg*) :arg (caddr lap) :arg2 :eq)) (:std-instance-p (let ((treg (get-treg-of op1)) (tempreg (new-reg)) (temp2reg (new-reg)) (offsetreg (new-reg)) (nope (pc-genlab))) (qe typecheck :u (list treg) :arg nope :arg2 '(not structure)) (qe const :arg 'pcl::std-instance :d (list tempreg)) (qe const :arg (mdparam 'md-svector-data0-adj) :d (list offsetreg)) (qe ref :u (list treg offsetreg) :d (list temp2reg) :arg :long) (qe bcc :arg2 :eq :u (list tempreg temp2reg) :arg (caddr lap)) (qe label :arg nope))) (:fsc-instance-p (let ((treg (get-treg-of op1)) (nope (pc-genlab)) (offsetreg (new-reg)) (tempreg (new-reg)) (checkreg (new-reg))) (qe typecheck :u (list treg) :arg nope :arg2 '(not compiled-function)) (qe const :arg (mdparam 'md-function-flags-adj) :d (list offsetreg)) (qe ref :u (list treg offsetreg) :d (list tempreg) :arg :ubyte) (qe const :arg pcl::funcallable-instance-flag-bit :d (list checkreg)) (qe bcc :u (list checkreg tempreg) :arg (caddr lap) :arg2 :bit-and) (qe label :arg nope))) (:built-in-instance-p ; always true (qe bra :arg (caddr lap))) (:jmp (qe tail-funcall :u (list *nargs-treg* (get-treg-of op1)))) (:structure-instance-p ; always true (qe bra :arg (caddr lap))) (:return (let (op-treg) (if* (index-p op1) then ; convert to lisp before returning (let ((shiftamt (new-reg))) (setq op-treg (new-reg)) (qe const :arg 1 :d (list shiftamt)) (qe lsl :u (list (get-treg-of op1) shiftamt) :d (list op-treg))) else (setq op-treg (get-treg-of op1))) (qe move :u (list op-treg) :d *mv-treg-target*) (qe return :u *mv-treg-target*))) (:go (qe bra :arg (cadr lap))) (:label (qe label :arg (cadr lap))) (t (warn "ignoring ~s" lap))))))) (defun insert-closure-vals (function closure-vals) ;; build a fucntion from the lap and insert (let ((newfun (sys::copy-function function))) (setf (excl::fn_closure newfun) (list (apply 'vector closure-vals))) newfun)) ; test case: ; (pcl::defclass foo () (a b c)) ; (pcl::defmethod barx ((a foo) b c) a ) ; (apply 'pcl::excl-lap-closure-generator pcl::*tcase*) ; ; to turn it on (if* (not (and (boundp 'user::noquad) (symbol-value 'user::noquad))) then (setq pcl::*make-lap-closure-generator* 'pcl::excl-lap-closure-generator)) gcl/pcl/impl/franz/excl-low.lisp0000644000175000017500000001046012240167764015533 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the EXCL (Franz) lisp version of the file portable-low. ;;; ;;; This is for version 1.1.2. Many of the special symbols now in the lisp ;;; package (e.g. lisp::pointer-to-fixnum) will be in some other package in ;;; a later release so this will need to be changed. ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(let ((outer-interrupts excl::*without-interrupts*) (excl::*without-interrupts* 0)) (macrolet ((interrupts-on () '(unless outer-interrupts (setq excl::*without-interrupts* nil))) (interrupts-off () '(setq excl::*without-interrupts* 0))) ,.body))) (eval-when (compile load eval) (unless (fboundp 'excl::sy_hash) (setf (symbol-function 'excl::sy_hash) (symbol-function 'excl::_sy_hash-value))) ) (defmacro memq (item list) (let ((list-var (gensym)) (item-var (gensym))) `(prog ((,list-var ,list) (,item-var ,item)) start (cond ((null ,list-var) (return nil)) ((eq (car ,list-var) ,item-var) (return ,list-var)) (t (pop ,list-var) (go start)))))) (defun std-instance-p (x) (and (excl::structurep x) (locally (declare #.*optimize-speed*) (eq (svref x 0) 'std-instance)))) (excl::defcmacro std-instance-p (x) (once-only (x) `(and (excl::structurep ,x) (locally (declare #.*optimize-speed*) (eq (svref ,x 0) 'std-instance))))) (excl::defcmacro fast-method-call-p (x) (once-only (x) `(and (excl::structurep ,x) (locally (declare #.*optimize-speed*) (eq (svref ,x 0) 'fast-method-call))))) (defmacro %std-instance-wrapper (x) `(svref ,x 1)) (defmacro %std-instance-slots (x) `(svref ,x 2)) (defun printing-random-thing-internal (thing stream) (format stream "~O" (excl::pointer-to-fixnum thing))) #-vax (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((excl::function-object-p fn) (setf (excl::fn_symdef fn) new-name)) (t nil)) fn) (defun function-arglist (f) (excl::arglist f)) (defun symbol-append (sym1 sym2 &optional (package *package*)) ;; This is a version of symbol-append from macros.cl ;; It insures that all created symbols are of one case and that ;; case is the current prefered case. ;; This special version of symbol-append is not necessary if all you ;; want to do is compile and run pcl in a case-insensitive-upper ;; version of cl. ;; (let ((string (string-append sym1 sym2))) (case excl::*current-case-mode* ((:case-insensitive-lower :case-sensitive-lower) (setq string (string-downcase string))) ((:case-insensitive-upper :case-sensitive-upper) (setq string (string-upcase string)))) (intern string package))) ;;; Define inspector hooks for PCL object instances. (defun (:property pcl::std-instance :inspector-function) (object) (let ((class (class-of object))) (cons (inspect::make-field-def "class" #'class-of :lisp) (mapcar #'(lambda (slot) (inspect::make-field-def (string (slot-definition-name slot)) #'(lambda (x) (slot-value-using-class class x slot)) :lisp)) (slots-to-inspect class object))))) (defun (:property pcl::std-instance :inspector-type-function) (x) (class-name (class-of x))) gcl/pcl/impl/franz/cpatch.lisp0000644000175000017500000000136312240167764015245 0ustar cammcamm;; -[Thu Feb 22 08:38:07 1990 by jkf]- ;; cpatch.cl ;; compiler patch for the fast clos ;; ;; copyright (c) 1990 Franz Inc. ;; (in-package :comp) (def-quad-op tail-funcall qp-end-block ;; u = (argcount function-object) ;; ;; does a tail call to the function-object given ;; never returns ) (defun-in-runtime sys::copy-function (func)) (in-package :hyperion) (def-quad-hyp r-tail-funcall comp::tail-funcall (u d quad) ;; u = (argcount function) ;; (r-move-single-to-loc (treg-loc (car u)) *count-reg*) (r-move-single-to-loc (treg-loc (cadr u)) *fcnin-reg*) (re restore *zero-reg* *zero-reg*) (re move.l `(d #.r-function-start-adj #.*fcnout-reg*) '#.*ctr2-reg*) (re jmpl '(d 0 #.*ctr2-reg*) *zero-reg*) (re nop)) gcl/pcl/impl/kcl/0000755000175000017500000000000012240167764012540 5ustar cammcammgcl/pcl/impl/kcl/sys-proclaim.lisp0000644000175000017500000012601412240167764016057 0ustar cammcamm (IN-PACKAGE "USER") (PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM) PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) PCL::FAST-INSTANCE-BOUNDP-INDEX PCL::ONE-INDEX-LIMIT-FN PCL::N-N-ACCESSORS-LIMIT-FN PCL::CHECKING-LIMIT-FN PCL::PV-CACHE-LIMIT-FN PCL::CACHE-NLINES PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE PCL::CACHE-MASK PCL::ARG-INFO-NUMBER-REQUIRED PCL::DEFAULT-LIMIT-FN PCL::CACHE-COUNT PCL::CACHING-LIMIT-FN PCL::PV-TABLE-PV-SIZE PCL::EARLY-CLASS-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) (PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) (PROCLAIM '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) (PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) (PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME PCL::MAKE-KEYWORD)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) (PROCLAIM '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) *) PCL::MEMF-CODE-CONVERTER PCL::REAL-LOAD-DEFCLASS PCL::CACHE-MISS-VALUES-INTERNAL PCL::GENERATE-DISCRIMINATION-NET-INTERNAL PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION PCL::DO-SHORT-METHOD-COMBINATION WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::WALK-GATHERING-BODY PCL::CACHE-MISS-VALUES PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P PCL::ACCESSOR-VALUES1 PCL::EMIT-READER/WRITER PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER WALKER::WALK-MULTIPLE-VALUE-SETQ PCL::GENERATING-LISP PCL::EMIT-READER/WRITER-FUNCTION PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION WALKER::WALK-LET-IF PCL::SET-SLOT-VALUE PCL::CONVERT-METHODS PCL::SLOT-VALUE-USING-CLASS-DFUN PCL::SLOT-BOUNDP-USING-CLASS-DFUN PCL::CHECK-METHOD-ARG-INFO PCL::LOAD-LONG-DEFCOMBIN PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN PCL::MAKE-FINAL-CACHING-DFUN PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN PCL::GET-CLASS-SLOT-VALUE-1 PCL::ACCESSOR-VALUES-INTERNAL PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS PCL::CHECKING-MISS PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) *) PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN WALKER::WALK-TEMPLATE-HANDLE-REPEAT)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION PCL::BOOTSTRAP-ACCESSOR-DEFINITION PCL::GET-ACCESSOR-METHOD-FUNCTION PCL::EMIT-CHECKING-OR-CACHING PCL::EMIT-CHECKING-OR-CACHING-FUNCTION PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN PCL::LOAD-SHORT-DEFCOMBIN PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION PCL::MAKE-SHARED-INITIALIZE-FORM-LIST PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN PCL::MAKE-FINAL-CHECKING-DFUN PCL::ACCESSOR-VALUES PCL::SET-CLASS-SLOT-VALUE-1 PCL::GENERATE-DISCRIMINATION-NET PCL::REAL-MAKE-METHOD-LAMBDA PCL::ORDER-SPECIALIZERS WALKER::WALK-TEMPLATE PCL::ACCESSOR-MISS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) ITERATE::ITERATE-TRANSFORM-BODY)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) PCL::SLOT-VALUE-OR-DEFAULT PCL::MAKE-EFFECTIVE-METHOD-FUNCTION PCL::GET-EFFECTIVE-METHOD-FUNCTION PCL::MAKE-N-N-ACCESSOR-DFUN WALKER:NESTED-WALK-FORM PCL::MAKE-CHECKING-DFUN PCL::LOAD-DEFGENERIC PCL::TYPES-FROM-ARGUMENTS PCL::MAKE-DEFAULT-INITARGS-FORM-LIST PCL::MAKE-FINAL-ACCESSOR-DFUN PCL::MAKE-ACCESSOR-TABLE PCL::GET-SIMPLE-INITIALIZATION-FUNCTION PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) *) PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS PCL::GET-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) ITERATE::SIMPLE-EXPAND-GATHERING-FORM ITERATE::RENAME-AND-CAPTURE-VARIABLES ITERATE::VARIABLE-SAME-P PCL::GET-FUNCTION-GENERATOR WALKER:VARIABLE-DECLARATION PCL::GET-NEW-FUNCTION-GENERATOR PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO PCL::ONE-CLASS-DFUN-INFO PCL::MAP-ALL-ORDERS SYSTEM::APPLY-DISPLAY-FUN PCL::NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL PCL::MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA PCL::OPTIMIZE-GF-CALL-INTERNAL PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P WALKER::WALK-COMPILER-LET PCL::SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY WALKER::WALK-MACROLET PCL::FIX-SLOT-ACCESSORS WALKER::WALK-MULTIPLE-VALUE-BIND PCL:COMPUTE-EFFECTIVE-METHOD WALKER::WALK-SETQ WALKER::WALK-SYMBOL-MACROLET PCL::EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY PCL::EMIT-BOUNDP-CHECK WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* PCL::EXPAND-DEFGENERIC PCL::EMIT-GREATER-THAN-1-DLAP PCL::EMIT-1-T-DLAP PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL PCL::ENTRY-IN-CACHE-P PCL::CONVERT-TABLE PCL::MAKE-METHOD-SPEC PCL::TRACE-EMF-CALL-INTERNAL PCL::FLUSH-CACHE-TRAP PCL::SET-FUNCTION-NAME-1 PCL::OBSOLETE-INSTANCE-TRAP PCL::COMPUTE-PRECEDENCE PCL::PRINT-STD-INSTANCE PCL::|SETF PCL METHOD-FUNCTION-GET| PCL::|SETF PCL PLIST-VALUE| WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE PCL::OPTIMIZE-SET-SLOT-VALUE PCL::DECLARE-STRUCTURE PCL::OPTIMIZE-SLOT-BOUNDP PCL::PRINT-CACHE PCL::COMPUTE-STD-CPL-PHASE-3 PCL::FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS PCL::MAKE-TOP-LEVEL-FORM PCL::INVALIDATE-WRAPPER PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1 PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE PCL::MEMF-TEST-CONVERTER PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR PCL::TWO-CLASS-DFUN-INFO WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 PCL::OPTIMIZE-READER PCL::OPTIMIZE-WRITER PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY PCL::MAYBE-EXPAND-ACCESSOR-FORM PCL::INITIALIZE-INSTANCE-SIMPLE PCL::GET-WRAPPERS-FROM-CLASSES PCL::LOAD-PRECOMPILED-IIS-ENTRY PCL::FILL-CACHE-P PCL::ADJUST-CACHE PCL::EXPAND-CACHE PCL::EXPAND-SYMBOL-MACROLET-INTERNAL PCL::BOOTSTRAP-SET-SLOT PCL::EXPAND-DEFCLASS PCL::GET-CACHE )) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) PCL::LOAD-FUNCTION-GENERATOR PCL::EXPAND-EMF-CALL-METHOD PCL::MAKE-FGEN PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS1 PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL PCL::COMPUTE-PV-SLOT WALKER::WALK-BINDINGS-1 PCL::OPTIMIZE-INSTANCE-ACCESS PCL::OPTIMIZE-ACCESSOR-CALL PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL1 PCL::UPDATE-SLOTS-IN-PV PCL::MAKE-PARAMETER-REFERENCES PCL::MAKE-EMF-CACHE PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL PCL::MAKE-INSTANCE-FUNCTION-COMPLEX PCL::MAKE-INSTANCE-FUNCTION-SIMPLE PCL::OPTIMIZE-GENERIC-FUNCTION-CALL PCL::REAL-MAKE-METHOD-INITARGS-FORM )) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE PCL::MAKE-EMF-FROM-METHOD PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::FIND-CLASS-FROM-CELL PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::INITIALIZE-INFO PCL::GET-EFFECTIVE-METHOD-FUNCTION1 PCL::GET-DECLARATION PCL::GET-METHOD-FUNCTION-PV-CELL PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::EMIT-MISS PCL::METHOD-FUNCTION-GET PCL::PROBE-CACHE PCL::MAP-CACHE PCL::GET-CACHE-FROM-CACHE PCL::PRECOMPUTE-EFFECTIVE-METHODS PCL::RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA PCL::CPL-ERROR PCL::REAL-ADD-METHOD PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION PCL::REAL-ENSURE-GF-USING-CLASS--NULL PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T) T) PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS PCL::OPTIMIZE-GF-CALL PCL::SET-ARG-INFO1 PCL::LOAD-DEFCLASS PCL::MAKE-EARLY-CLASS-DEFINITION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) PCL::LOAD-DEFMETHOD PCL::MAKE-DEFMETHOD-FORM PCL::MAKE-DEFMETHOD-FORM-INTERNAL PCL::EARLY-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) PCL::CHECK-INITARGS-2-PLIST PCL::CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST PCL::MAKE-EMF-CALL PCL::CAN-OPTIMIZE-ACCESS1 PCL::EMIT-FETCH-WRAPPER PCL::FILL-CACHE PCL::REAL-GET-METHOD PCL::CHECK-INITARGS-1 PCL::GET-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD PCL::LOAD-DEFMETHOD-INTERNAL )) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T T *) T) PCL::BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::RENEW-SYS-FILES PCL::EMIT-N-N-READERS PCL::EMIT-N-N-WRITERS)) (PROCLAIM '(FTYPE (FUNCTION NIL T) PCL::GET-EFFECTIVE-METHOD-GENSYM PCL::SHOW-EMF-CALL-TRACE PCL::BOOTSTRAP-META-BRAID PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::LIST-ALL-DFUNS PCL::DEFAULT-METHOD-ONLY-DFUN-INFO PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST PCL::CACHES-TO-ALLOCATE PCL::UPDATE-DISPATCH-DFUNS PCL::MAKE-CACHE PCL::RESET-PCL-PACKAGE PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2 PCL::%%ALLOCATE-INSTANCE--CLASS PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1 PCL::DISPATCH-DFUN-INFO PCL::INITIAL-DISPATCH-DFUN-INFO PCL::INITIAL-DFUN-INFO PCL::NO-METHODS-DFUN-INFO PCL::SHOW-FREE-CACHE-VECTORS PCL::MAKE-CPD PCL::MAKE-ARG-INFO PCL::SHOW-DFUN-CONSTRUCTORS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) PCL::UNTRACE-METHOD PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR PCL::LIST-LARGE-CACHES PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) (PROCLAIM '(FTYPE (FUNCTION (*) T) PCL::|__si::MAKE-DFUN-INFO| PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-INITIAL| PCL::|__si::MAKE-INITIAL-DISPATCH| PCL::|__si::MAKE-DISPATCH| PCL::|__si::MAKE-DEFAULT-METHOD-ONLY| PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| PCL::MAKE-FAST-METHOD-CALL PCL::|__si::MAKE-N-N| PCL::MAKE-FAST-INSTANCE-BOUNDP PCL::|__si::MAKE-ONE-CLASS| PCL::|__si::MAKE-TWO-CLASS| PCL::|__si::MAKE-ONE-INDEX| PCL::|__si::MAKE-CHECKING| PCL::|__si::MAKE-ARG-INFO| PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::STRING-APPEND PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE| PCL::FALSE PCL::|STRUCTURE-OBJECT class constructor| PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE PCL::|__si::MAKE-PV-TABLE| PCL::INTERN-PV-TABLE PCL::CALLED-FIN-WITHOUT-FUNCTION PCL::|__si::MAKE-STD-INSTANCE| PCL::TRUE PCL::MAKE-INITIALIZE-INFO PCL::|__si::MAKE-CACHE| PCL::MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| PCL::MAKE-METHOD-CALL)) (PROCLAIM '(FTYPE (FUNCTION (T) *) PCL::TYPE-FROM-SPECIALIZER PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE PCL::DEFAULT-CODE-CONVERTER PCL::CONVERT-TO-SYSTEM-TYPE PCL::EMIT-CONSTANT-VALUE PCL::SFUN-P PCL::PCL-DESCRIBE PCL::GET-GENERIC-FUNCTION-INFO PCL::EARLY-METHOD-FUNCTION PCL::EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::STRUCTURE-WRAPPER PCL::FIND-STRUCTURE-CLASS PCL::MAKE-DISPATCH-DFUN PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA PCL::FORCE-CACHE-FLUSHES PCL::EMIT-ONE-CLASS-READER PCL::EMIT-ONE-CLASS-WRITER PCL::EMIT-TWO-CLASS-READER PCL::EMIT-TWO-CLASS-WRITER PCL::EMIT-ONE-INDEX-READERS PCL::EMIT-ONE-INDEX-WRITERS PCL::NET-CODE-CONVERTER PCL::EMIT-IN-CHECKING-CACHE-P PCL::COMPILE-IIS-FUNCTIONS PCL::ANALYZE-LAMBDA-LIST PCL::COMPUTE-APPLICABLE-METHODS-EMF PCL::GET-DISPATCH-FUNCTION PCL::INSURE-CACHING-DFUN PCL::%FBOUNDP PCL::CCLOSUREP PCL::GENERIC-FUNCTION-NAME-P PCL::MAKE-FINAL-DISPATCH-DFUN PCL::STRUCTURE-SLOTD-INIT-FORM PCL::PARSE-METHOD-GROUP-SPECIFIER PCL::METHOD-PROTOTYPE-FOR-GF PCL::EARLY-COLLECT-INHERITANCE)) (PROCLAIM '(FTYPE (FUNCTION (T) T) PCL::UNENCAPSULATED-FDEFINITION PCL::DFUN-INFO-P PCL::NO-METHODS-P PCL::MAKE-TYPE-PREDICATE PCL::DEFAULT-TEST-CONVERTER PCL::INITIAL-P PCL::UNPARSE-TYPE-LIST PCL::MAKE-CALL-METHODS PCL::DEFAULT-CONSTANT-CONVERTER PCL::INITIAL-DISPATCH-P PCL::DISPATCH-P PCL::GBOUNDP PCL::GMAKUNBOUND PCL::DEFAULT-CONSTANTP PCL::DEFAULT-METHOD-ONLY-P PCL::FGEN-TEST PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-P PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM PCL::ONE-INDEX-DFUN-INFO-P PCL::FAST-METHOD-CALL-P PCL::N-N-P PCL::FAST-INSTANCE-BOUNDP-P PCL::METHOD-FUNCTION-PV-TABLE PCL::METHOD-FUNCTION-METHOD PCL::STORE-FGEN PCL::ONE-CLASS-P PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST PCL::FGEN-GENSYMS PCL::TWO-CLASS-P PCL::ARG-INFO-LAMBDA-LIST PCL::ARG-INFO-PRECEDENCE PCL::ARG-INFO-METATYPES PCL::FGEN-GENERATOR-LAMBDA SYSTEM:%STRUCTURE-NAME PCL::ARG-INFO-NUMBER-OPTIONAL SYSTEM:%COMPILED-FUNCTION-NAME PCL::ARG-INFO-KEY/REST-P PCL::ONE-INDEX-P PCL::ARG-INFO-KEYWORDS PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P PCL::GF-INFO-STATIC-C-A-M-EMF PCL::CHECKING-P PCL::GF-INFO-C-A-M-EMF-STD-P PCL::GF-INFO-FAST-MF-P PCL::UNDEFMETHOD-1 PCL::ARG-INFO-P PCL::FAST-METHOD-CALL-ARG-INFO PCL::ARG-INFO-NKEYS PCL::GF-DFUN-CACHE PCL:CLASS-OF PCL::GF-DFUN-INFO PCL::FUNCTION-RETURNING-NIL PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE PCL::EVAL-FORM PCL::ONE-INDEX-DFUN-INFO-INDEX PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD PCL::TYPE-CLASS PCL::ONE-CLASS-WRAPPER0 PCL::EXTRACT-PARAMETERS PCL::CLASS-PREDICATE PCL::EXTRACT-REQUIRED-PARAMETERS PCL::MAKE-CLASS-EQ-PREDICATE PCL::TWO-CLASS-WRAPPER1 PCL::MAKE-EQL-PREDICATE PCL::CHECKING-FUNCTION PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS PCL::INITIALIZE-INFO-KEY PCL::BOOTSTRAP-CLASS-PREDICATES PCL::GET-BUILT-IN-CLASS-SYMBOL PCL::INITIALIZE-INFO-WRAPPER PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::DO-STANDARD-DEFSETF-1 PCL::CACHING-P PCL::GFS-OF-TYPE PCL::LEGAL-CLASS-NAME-P PCL::STRUCTURE-TYPE-P PCL::CONSTANT-VALUE-P PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P SYSTEM::NEXT-STACK-FRAME PCL::WRAPPER-FIELD PCL::NEXT-WRAPPER-FIELD PCL::SETFBOUNDP PCL::GET-SETF-FUNCTION-NAME PCL::USE-CACHING-DFUN-P PCL::MAKE-PV-TYPE-DECLARATION PCL::MAKE-CALLS-TYPE-DECLARATION PCL::MAP-SPECIALIZERS WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::SLOT-VECTOR-SYMBOL PCL::MAKE-PERMUTATION-VECTOR PCL::STRUCTURE-OBJECT-P PCL::EXPAND-MAKE-INSTANCE-FORM PCL::MAKE-CONSTANT-FUNCTION PCL::FUNCTION-RETURNING-T PCL::SORT-SLOTS PCL::SORT-CALLS PCL::SYMBOL-PKG-NAME PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P PCL::INITIALIZE-INFO-BOUND-SLOTS PCL::INITIALIZE-INFO-CACHED-VALID-P PCL::GET-MAKE-INSTANCE-FUNCTIONS PCL::INITIALIZE-INFO-CACHED-RI-VALID-P PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST PCL::INITIALIZE-INFO-CACHED-NEW-KEYS PCL::UPDATE-C-A-M-GF-INFO PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE PCL::UPDATE-GFS-OF-CLASS PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS PCL::STANDARD-SVUC-METHOD PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION PCL:EXTRACT-LAMBDA-LIST PCL::%CCLOSURE-ENV PCL::STRUCTURE-SVUC-METHOD PCL::INITIALIZE-INFO-CACHED-CONSTANTS PCL:EXTRACT-SPECIALIZER-NAMES PCL::METHOD-FUNCTION-PLIST PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION PCL::INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL PCL::INTERNED-SYMBOL-P PCL::GDEFINITION PCL::UPDATE-CLASS-CAN-PRECEDE-P PCL::%STD-INSTANCE-WRAPPER PCL::%STD-INSTANCE-SLOTS PCL::PV-TABLEP PCL::STD-INSTANCE-P PCL::COMPUTE-MCASE-PARAMETERS PCL::COMPUTE-CLASS-SLOTS PCL::MAKE-PV-TABLE-TYPE-DECLARATION PCL::NET-TEST-CONVERTER PCL:INTERN-EQL-SPECIALIZER PCL::MAKE-INSTANCE-FUNCTION-SYMBOL PCL::UPDATE-ALL-C-A-M-GF-INFO PCL::UPDATE-PV-TABLE-CACHE-INFO PCL::DFUN-INFO-CACHE PCL::NO-METHODS-CACHE PCL::ARG-INFO-APPLYP PCL::INITIAL-CACHE PCL::INITIAL-DISPATCH-CACHE PCL::CHECK-CACHE PCL::DISPATCH-CACHE PCL::CLASS-FROM-TYPE PCL::DEFAULT-METHOD-ONLY-CACHE PCL::DNET-METHODS-P PCL::ACCESSOR-DFUN-INFO-CACHE PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION PCL::ONE-INDEX-DFUN-INFO-CACHE PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE PCL::METHOD-CALL-CALL-METHOD-ARGS PCL::KEYWORD-SPEC-NAME PCL::N-N-CACHE PCL::GENERIC-CLOBBERS-FUNCTION PCL::N-N-ACCESSOR-TYPE PCL::FAST-METHOD-CALL-PV-CELL PCL::WRAPPER-FOR-STRUCTURE PCL::ONE-CLASS-CACHE PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL PCL::ONE-CLASS-ACCESSOR-TYPE PCL::ONE-CLASS-INDEX PCL::BUILT-IN-WRAPPER-OF PCL::TWO-CLASS-CACHE PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1 PCL::TWO-CLASS-ACCESSOR-TYPE PCL::TWO-CLASS-INDEX PCL::ALLOCATE-CACHE-VECTOR PCL::TWO-CLASS-WRAPPER0 PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::ONE-INDEX-CACHE PCL::EARLY-CLASS-NAME PCL::ONE-INDEX-ACCESSOR-TYPE PCL::ONE-INDEX-INDEX PCL::INTERN-FUNCTION-NAME PCL::CHECKING-CACHE PCL::COMPILE-LAMBDA-UNCOMPILED PCL::GF-LAMBDA-LIST PCL::CACHING-CACHE PCL::CONSTANT-VALUE-CACHE PCL::COMPILE-LAMBDA-DEFERRED PCL::FUNCALLABLE-INSTANCE-P PCL::RESET-CLASS-INITIALIZE-INFO PCL::GET-CACHE-VECTOR PCL::CONSTANT-SYMBOL-P PCL::FREE-CACHE-VECTOR PCL::EARLY-METHOD-LAMBDA-LIST PCL::ARG-INFO-VALID-P PCL::DFUN-ARG-SYMBOL PCL::EARLY-METHOD-CLASS PCL::EARLY-GF-P PCL::EARLY-GF-NAME PCL::CACHING-DFUN-INFO PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P PCL::CONSTANT-VALUE-DFUN-INFO PCL::RESET-CLASS-INITIALIZE-INFO-1 PCL::FREE-CACHE PCL::PARSE-SPECIALIZERS PCL::RESET-INITIALIZE-INFO PCL::EARLY-METHOD-QUALIFIERS PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES PCL::WRAPPER-OF PCL::EARLY-METHOD-STANDARD-ACCESSOR-P PCL::FUNCTION-PRETTY-ARGLIST PCL::GET-MAKE-INSTANCE-FUNCTION PCL::CHECK-WRAPPER-VALIDITY PCL::UNPARSE-SPECIALIZERS PCL::%SYMBOL-FUNCTION PCL::FINAL-ACCESSOR-DFUN-TYPE PCL::COMPLICATED-INSTANCE-CREATION-METHOD PCL::DEFAULT-STRUCTUREP PCL::UPDATE-GF-INFO PCL::CACHE-OWNER PCL::DEFAULT-STRUCTURE-INSTANCE-P PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE PCL::COMPUTE-STD-CPL-PHASE-2 PCL::GET-PV-CELL-FOR-CLASS PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST PCL::CACHE-P PCL::STRUCTURE-SLOTD-NAME PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION PCL::STRUCTURE-SLOTD-WRITER-FUNCTION PCL::FIND-CYCLE-REASONS PCL::EARLY-CLASS-DEFINITION PCL::ECD-SOURCE PCL::STRUCTURE-SLOTD-TYPE PCL::FORMAT-CYCLE-REASONS PCL::ECD-METACLASS PCL::CPD-CLASS PCL::EARLY-CLASS-PRECEDENCE-LIST PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P PCL::CPD-SUPERS PCL::EXPAND-LONG-DEFCOMBIN PCL::EARLY-CLASS-NAME-OF PCL::CPD-AFTER PCL::EXPAND-SHORT-DEFCOMBIN PCL::EARLY-CLASS-SLOTDS PCL::CPD-COUNT PCL::EARLY-SLOT-DEFINITION-NAME PCL::SLOT-READER-SYMBOL PCL::EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK PCL::MAKE-INITIAL-DFUN PCL::EARLY-ACCESSOR-METHOD-SLOT-NAME PCL::SLOT-WRITER-SYMBOL WALKER::ENV-DECLARATIONS WALKER::ENV-LEXICAL-VARIABLES PCL::LIST-DFUN PCL::SLOT-BOUNDP-SYMBOL PCL::MAP-ALL-GENERIC-FUNCTIONS PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION PCL::EARLY-CLASS-DIRECT-SUBCLASSES PCL::MAKE-FUNCTION-INLINE PCL::LIST-LARGE-CACHE PCL::CLASS-PRECEDENCE-DESCRIPTION-P PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION WALKER::ENV-WALK-FUNCTION WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE PCL::COUNT-DFUN PCL::MAKE-INITFUNCTION PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::VARIABLES-FROM-LET WALKER::ENV-WALK-FORM PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION PCL::INITIALIZE-INFO-P PCL::ECD-CLASS-NAME PCL::COPY-CACHE PCL::COMPUTE-LINE-SIZE PCL::CANONICAL-SLOT-NAME WALKER::GET-WALKER-TEMPLATE PCL::EARLY-CLASS-SLOTS PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS PCL::EARLY-COLLECT-CPL PCL::EARLY-COLLECT-SLOTS PCL::METHOD-LL->GENERIC-FUNCTION-LL PCL::EARLY-COLLECT-DEFAULT-INITARGS PCL::ECD-SUPERCLASS-NAMES PCL::METHOD-CALL-P PCL::STRUCTURE-SLOT-BOUNDP ITERATE::SEQUENCE-ACCESSOR PCL::ECD-CANONICAL-SLOTS PCL::ECD-OTHER-INITARGS)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) PCL::COERCE-TO-CLASS PCL::GET-METHOD-FUNCTION WALKER:MACROEXPAND-ALL PCL::GET-FUNCTION PCL::GET-FUNCTION1 PCL:ENSURE-GENERIC-FUNCTION PCL::PARSE-METHOD-OR-SPEC PCL::EXTRACT-DECLARATIONS PCL::GET-DFUN-CONSTRUCTOR PCL::MAP-ALL-CLASSES PCL::MAKE-CACHING-DFUN WALKER:WALK-FORM PCL:ENSURE-CLASS PCL::MAKE-METHOD-FUNCTION-INTERNAL PCL::PARSE-SPECIALIZED-LAMBDA-LIST PCL::MAKE-METHOD-LAMBDA-INTERNAL PCL::MAKE-CONSTANT-VALUE-DFUN PCL::MAKE-FINAL-DFUN-INTERNAL PCL::COMPILE-LAMBDA)) (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) (PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) PCL::SAUT-CLASS PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP PCL::COMPUTE-TEST PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL PCL::COMPUTE-CODE PCL::CLASS-APPLICABLE-USING-CLASS-P PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-PROTOTYPE COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL:SLOT-BOUNDP PCL::DESTRUCTURE PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE PCL::ENSURE-CLASS-VALUES PCL::MAKE-DIRECT-SLOTD PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P PCL::MUTATE-SLOTS-AND-CALLS PCL::INVOKE-EMF PCL::EMIT-DEFAULT-ONLY-FUNCTION PCL::SPLIT-DECLARATIONS PCL::EMIT-DEFAULT-ONLY COMPILER::C2LAMBDA-EXPR-WITH-KEY PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING PCL::UPDATE-SLOT-VALUE-GF-INFO PCL::EMIT-CACHING PCL::SDFUN-FOR-CACHING PCL::SLOT-UNBOUND-INTERNAL PCL::MAKE-INSTANCE-1 PCL::SET-FUNCTION-NAME PCL::COMPUTE-STD-CPL-PHASE-1 PCL::FORM-LIST-TO-LISP PCL::FIND-SUPERCLASS-CHAIN PCL::SAUT-CLASS-EQ PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES PCL::CHECK-INITARGS-VALUES PCL::SAUT-EQL PCL::*SUBTYPEP ITERATE::PARSE-DECLARATIONS PCL::INITIAL-DFUN)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) PCL::MAKE-TYPE-PREDICATE-NAME PCL::SET-DFUN PCL:FIND-CLASS PCL::TRACE-METHOD PCL::FIND-CLASS-CELL PCL::MAKE-FINAL-DFUN PCL::PV-TABLE-LOOKUP-PV-ARGS PCL::USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE PCL::EARLY-METHOD-SPECIALIZERS PCL::USE-CONSTANT-VALUE-DFUN-P PCL::MAKE-EARLY-GF PCL::ALLOCATE-FUNCALLABLE-INSTANCE PCL::SET-ARG-INFO PCL::INITIALIZE-METHOD-FUNCTION PCL::UPDATE-DFUN PCL::MAKE-SPECIALIZABLE PCL::ALLOCATE-STRUCTURE-INSTANCE PCL::ALLOCATE-STANDARD-INSTANCE WALKER::WALKER-ENVIRONMENT-BIND-1 ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN PCL::MAKE-WRAPPER)) (PROCLAIM '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS PCL::SORT-METHODS)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) PCL::FDEFINE-CAREFULLY PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION PCL::MAKE-STD-READER-METHOD-FUNCTION PCL::MAKE-STD-WRITER-METHOD-FUNCTION ITERATE::SIMPLE-EXPAND-ITERATE-FORM PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION PCL::DO-SATISFIES-DEFTYPE PCL::MEMF-CONSTANT-CONVERTER PCL::COMPUTE-CONSTANTS PCL::CLASS-CAN-PRECEDE-P PCL::SAUT-NOT-CLASS PCL::SAUT-NOT-CLASS-EQ PCL::SAUT-NOT-PROTOTYPE PCL::GF-MAKE-FUNCTION-FROM-EMF PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P PCL::CLASSES-HAVE-COMMON-SUBCLASS-P SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD SYSTEM::DISPLAY-ENV PCL::DESCRIBE-PACKAGE SYSTEM::DISPLAY-COMPILED-ENV PCL::PRINTING-RANDOM-THING-INTERNAL PCL::MAKE-CLASS-PREDICATE PCL::METHOD-FUNCTION-RETURNING-NIL PCL::METHOD-FUNCTION-RETURNING-T PCL::VARIABLE-CLASS PCL::MAKE-PLIST PCL::REMTAIL PCL:REMOVE-METHOD PCL:SLOT-EXISTS-P PCL::DESTRUCTURE-INTERNAL PCL::ACCESSOR-MISS-FUNCTION PCL::UPDATE-INITIALIZE-INFO-INTERNAL PCL::N-N-DFUN-INFO PCL::MAKE-CAXR PCL::MAKE-CDXR WALKER:VARIABLE-LEXICAL-P WALKER:VARIABLE-SPECIAL-P PCL::CHECKING-DFUN-INFO PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION PCL::MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING PCL::MAKE-DLAP-LAMBDA-LIST PCL::ADD-DIRECT-SUBCLASSES PCL::COMPUTE-PV PCL::MAKE-DFUN-ARG-LIST PCL::COMPUTE-CALLS PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST PCL::UPDATE-ALL-PV-TABLE-CACHES PCL::UPDATE-CLASS PCL::MAP-PV-TABLE-REFERENCES-OF PCL::ADD-SLOT-ACCESSORS WALKER::ENVIRONMENT-FUNCTION PCL::REMOVE-DIRECT-SUBCLASSES PCL::REMOVE-SLOT-ACCESSORS PCL::SYMBOL-LESSP PCL::SYMBOL-OR-CONS-LESSP PCL::|SETF PCL FIND-CLASS| PCL::|SETF PCL FIND-CLASS-PREDICATE| PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::PV-TABLE-LOOKUP PCL::PROCLAIM-DEFGENERIC PCL::UPDATE-CPL PCL::LIST-EQ PCL::UPDATE-SLOTS PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::UPDATE-INITS PCL::UPDATE-STD-OR-STR-METHODS PCL::SET-STANDARD-SVUC-METHOD PCL::EMIT-1-NIL-DLAP PCL::PLIST-VALUE PCL::SET-STRUCTURE-SVUC-METHOD PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::MEC-ALL-CLASSES-INTERNAL PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION PCL::MEC-ALL-CLASSES PCL::%SET-CCLOSURE-ENV PCL::MEC-ALL-CLASS-LISTS PCL::REDEFINE-FUNCTION PCL::METHODS-CONVERTER PCL::COMPUTE-LAYOUT PCL::NO-SLOT PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS PCL::NET-CONSTANT-CONVERTER PCL::AUGMENT-TYPE PCL::CHANGE-CLASS-INTERNAL PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION PCL::VALUE-FOR-CACHING PCL:STANDARD-INSTANCE-ACCESS PCL::|SETF PCL METHOD-FUNCTION-PLIST| PCL::GET-KEY-ARG PCL::GET-KEY-ARG1 PCL::SET-METHODS PCL::SET-FUNCTION-PRETTY-ARGLIST PCL::FIND-STANDARD-II-METHOD PCL::MAKE-EARLY-ACCESSOR PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::COMPUTE-STD-CPL PCL::|SETF PCL GDEFINITION| PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST PCL::ADD-FORMS PCL::CPL-INCONSISTENT-ERROR PCL::REDIRECT-EARLY-FUNCTION-INTERNAL PCL::ADD-TO-CVECTOR PCL::BOOTSTRAP-SLOT-INDEX PCL::QUALIFIER-CHECK-RUNTIME PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR PCL::REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO PCL::CANONICALIZE-SLOT-SPECIFICATION PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SET-WRAPPER PCL::DEAL-WITH-ARGUMENTS-OPTION PCL::PARSE-QUALIFIER-PATTERN PCL::SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ PCL::MAKE-UNORDERED-METHODS-EMF PCL::CLASS-MIGHT-PRECEDE-P ITERATE::EXTRACT-SPECIAL-BINDINGS WALKER::VARIABLE-SYMBOL-MACRO-P PCL::RAISE-METATYPE)) (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) (DOLIST (PCL::V '(PCL::ADD-READER-METHOD PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P PCL::OBJECT-PLIST PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE PCL::CLASS-DEFSTRUCT-CONSTRUCTOR PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP PCL::EXACT-CLASS-SPECIALIZER-P PCL::COMPATIBLE-META-CLASS-CHANGE-P PCL::UPDATE-GF-DFUN PCL::SPECIALIZER-OBJECT PCL::ACCESSOR-METHOD-SLOT-NAME PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS PCL::DOCUMENTATION PCL::METHOD-PRETTY-ARGLIST PCL::CLASS-EQ-SPECIALIZER PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS PCL::ACCESSOR-METHOD-CLASS PCL::GENERIC-FUNCTION-PRETTY-ARGLIST PCL::MAKE-BOUNDP-METHOD-FUNCTION PCL::CLASS-PREDICATE-NAME PCL::CLASSP PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD PCL::LEGAL-LAMBDA-LIST-P PCL::|SETF PCL GENERIC-FUNCTION-NAME| PCL::DESCRIBE-OBJECT PCL::CLASS-INITIALIZE-INFO PCL::MAKE-WRITER-METHOD-FUNCTION PCL::|SETF PCL GF-DFUN-STATE| PCL::|SETF PCL SLOT-DEFINITION-NAME| PCL::|SETF PCL CLASS-NAME| PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS PCL::|SETF PCL SLOT-DEFINITION-TYPE| PCL::METHOD-COMBINATION-P PCL::|SETF PCL GENERIC-FUNCTION-METHODS| PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| PCL::|SETF PCL METHOD-GENERIC-FUNCTION| PCL::|SETF PCL SLOT-ACCESSOR-STD-P| PCL::LEGAL-SPECIALIZERS-P PCL::|SETF PCL OBJECT-PLIST| PCL::|SETF PCL SLOT-DEFINITION-INITFORM| PCL::|SETF PCL CLASS-DEFSTRUCT-FORM| PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS| PCL::SLOT-ACCESSOR-STD-P PCL::|SETF PCL GF-PRETTY-ARGLIST| PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-LOCATION| PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION| PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION| PCL::METHOD-COMBINATION-OPTIONS PCL::|SETF PCL SLOT-DEFINITION-READERS| PCL::|SETF PCL DOCUMENTATION| PCL::FUNCALLABLE-STANDARD-CLASS-P PCL::|SETF PCL SLOT-DEFINITION-CLASS| PCL::|SETF PCL SLOT-VALUE-USING-CLASS| PCL::CLASS-CAN-PRECEDE-LIST PCL::|SETF PCL CLASS-DIRECT-SLOTS| PCL::|SETF PCL CLASS-SLOTS| PCL::SLOT-ACCESSOR-FUNCTION PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| PCL::|SETF PCL SLOT-DEFINITION-WRITERS| PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION PCL::LEGAL-METHOD-FUNCTION-P PCL::GET-METHOD PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO PCL::SPECIALIZER-METHOD-TABLE PCL::MAKE-METHOD-INITARGS-FORM PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST PCL::SAME-SPECIALIZER-P PCL::SLOT-DEFINITION-BOUNDP-FUNCTION PCL::SLOT-DEFINITION-WRITER-FUNCTION PCL::SLOT-DEFINITION-READER-FUNCTION PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION PCL::SLOT-DEFINITION-CLASS PCL::EQL-SPECIALIZER-OBJECT PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS PCL::ADD-WRITER-METHOD PCL::LONG-METHOD-COMBINATION-FUNCTION PCL::GENERIC-FUNCTION-P PCL::LEGAL-SLOT-NAME-P PCL::CLASS-WRAPPER PCL::DEFINITION-SOURCE PCL::DEFAULT-INITARGS PCL::CLASS-SLOT-VALUE PCL::FORWARD-REFERENCED-CLASS-P PCL::GF-FAST-METHOD-FUNCTION-P PCL::LEGAL-QUALIFIER-P PCL::METHOD-P PCL::CLASS-SLOT-CELLS PCL::STANDARD-ACCESSOR-METHOD-P PCL::STANDARD-GENERIC-FUNCTION-P PCL::STANDARD-READER-METHOD-P PCL::STANDARD-METHOD-P PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS PCL::COMPUTE-DEFAULT-INITARGS PCL::|SETF PCL CLASS-SLOT-VALUE| PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P PCL::LEGAL-SPECIALIZER-P PCL::COMPUTE-SLOT-ACCESSOR-INFO PCL::STANDARD-BOUNDP-METHOD-P PCL::RAW-INSTANCE-ALLOCATOR PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| PCL::|SETF PCL CLASS-INITIALIZE-INFO| PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO PCL::STANDARD-WRITER-METHOD-P PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST PCL::WRAPPER-FETCHER PCL::METHOD-COMBINATION-DOCUMENTATION PCL::|SETF PCL SLOT-DEFINITION-INITARGS| PCL::REMOVE-BOUNDP-METHOD PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| PCL::SHORT-COMBINATION-OPERATOR PCL::REMOVE-NAMED-METHOD PCL::LEGAL-DOCUMENTATION-P PCL:CLASS-DIRECT-SUPERCLASSES PCL:CLASS-DIRECT-SUBCLASSES PCL:CLASS-DIRECT-DEFAULT-INITARGS PCL:SLOT-DEFINITION-READERS PCL:SLOT-VALUE-USING-CLASS PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL:CHANGE-CLASS PCL:METHOD-FUNCTION PCL:DIRECT-SLOT-DEFINITION-CLASS PCL:MAKE-METHOD-LAMBDA PCL:EFFECTIVE-SLOT-DEFINITION-CLASS PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE PCL:GENERIC-FUNCTION-LAMBDA-LIST PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS PCL:COMPUTE-DISCRIMINATING-FUNCTION PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME PCL:REMOVE-DEPENDENT PCL:COMPUTE-CLASS-PRECEDENCE-LIST PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS PCL:ACCESSOR-METHOD-SLOT-DEFINITION PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD PCL:SLOT-DEFINITION-LOCATION PCL:SLOT-DEFINITION-INITFUNCTION PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD PCL:GENERIC-FUNCTION-METHOD-CLASS PCL:METHOD-SPECIALIZERS PCL:SLOT-DEFINITION-INITARGS PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS PCL:SPECIALIZER-DIRECT-METHODS PCL:GENERIC-FUNCTION-METHOD-COMBINATION PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS PCL:GENERIC-FUNCTION-METHODS PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST PCL:MAKE-INSTANCE PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS PCL:METHOD-GENERIC-FUNCTION PCL:REMOVE-DIRECT-SUBCLASS PCL:MAKE-INSTANCES-OBSOLETE PCL:SLOT-MAKUNBOUND-USING-CLASS PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS PCL:SLOT-MISSING PCL:MAP-DEPENDENTS PCL:FIND-METHOD-COMBINATION PCL:ENSURE-CLASS-USING-CLASS PCL:NO-APPLICABLE-METHOD PCL:SLOT-DEFINITION-WRITERS PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL:CLASS-PRECEDENCE-LIST)) (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl/pcl/impl/kcl/sys-package.lisp0000644000175000017500000001540312240167764015643 0ustar cammcamm ;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES '("S-A-N")) ;;; Definitions for package PCL of type ESTABLISH (LISP::IN-PACKAGE "PCL" :USE LISP::NIL) ;;; Definitions for package ITERATE of type ESTABLISH (LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) ;;; Definitions for package WALKER of type ESTABLISH (LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES '("S-A-N")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package PCL of type EXPORT (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION PCL::GENERIC-FUNCTION-METHOD-COMBINATION PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS PCL::ADD-METHOD PCL::WITH-ACCESSORS PCL::SLOT-DEFINITION-ALLOCATION PCL::SLOT-DEFINITION-INITFUNCTION PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE PCL::STANDARD-GENERIC-FUNCTION PCL::ACCESSOR-METHOD-SLOT-DEFINITION PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE PCL::SLOT-DEFINITION-NAME PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) ;;; Definitions for package ITERATE of type EXPORT (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING ITERATE::WITH-GATHERING ITERATE::INTERVAL)) ;;; Definitions for package WALKER of type EXPORT (LISP::IN-PACKAGE "WALKER" :USE '("LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package PCL of type SHADOW (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package WALKER of type SHADOW (LISP::IN-PACKAGE "WALKER") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) (lisp::in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) gcl/pcl/impl/kcl/kcl-low.lisp0000644000175000017500000003522512240167764015010 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for Kyoto Common Lisp (KCL) (in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name %instance-ref %set-instance-ref)) (in-package 'pcl) (shadow 'lisp:dotimes) (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) (declare (ignore doc)) (let ((limit (gensym)) (label (gensym))) `(let ((,limit ,form) (,var 0)) (declare (fixnum ,limit ,var)) ,@decls (block nil (tagbody ,label (when (>= ,var ,limit) (return-from nil ,val)) ,@bod (setq ,var (the fixnum (1+ ,var))) (go ,label))))))) (defun memq (item list) (member item list :test #'eq)) (defun assq (item list) (assoc item list :test #'eq)) (defun posq (item list) (position item list :test #'eq)) (si:define-compiler-macro memq (item list) (let ((var (gensym))) (once-only (item) `(let ((,var ,list)) (loop (unless ,var (return nil)) (when (eq ,item (car ,var)) (return ,var)) (setq ,var (cdr ,var))))))) (si:define-compiler-macro assq (item list) (let ((var (gensym))) (once-only (item) `(dolist (,var ,list nil) (when (eq ,item (car ,var)) (return ,var)))))) (si:define-compiler-macro posq (item list) (let ((var (gensym)) (index (gensym))) (once-only (item) `(let ((,var ,list) (,index 0)) (declare (fixnum ,index)) (dolist (,var ,list nil) (when (eq ,item ,var) (return ,index)) (incf ,index)))))) (defun printing-random-thing-internal (thing stream) (format stream "~X" (si:address thing))) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) ;;; ;;; std-instance-p ;;; #-akcl (si:define-compiler-macro std-instance-p (x) (once-only (x) `(and (si:structurep ,x) (eq (si:%structure-name ,x) 'std-instance)))) #+akcl (progn #-new-kcl-wrapper ;; declare that std-instance-p may be computed simply, and will not change. (si::freeze-defstruct 'std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj); else super_funcall(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) ) ;;; ;;; turbo-closure patch. See the file kcl-mods.text for details. ;;; #-turbo-closure-env-size (clines " object cclosure_env_nthcdr (n,cc) int n; object cc; { object env; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env; }") #+turbo-closure-env-size (clines " object cclosure_env_nthcdr (n,cc) int n; object cc; { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") ;; This is the completely safe version. (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed) (eval-when (compile load eval) #+new-kcl-wrapper (progn (defun instance-ref (slots index) (si:structure-ref1 slots index)) (defun set-instance-ref (slots index value) (si:structure-set1 slots index value)) (defsetf instance-ref set-instance-ref) (defsetf %instance-ref %set-instance-ref) ) (defsetf structure-def set-structure-def) ;;((name args-type result-type side-effect-p new-object-p c-expression) ...) (defparameter *kcl-function-inlines* '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure") #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name") #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") #+new-kcl-wrapper (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]") #+new-kcl-wrapper (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline))))) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let* ((*package* *the-pcl-package*) (name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((make-function-inline ',(cons name (cdr inline))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (,name ,@vars)) (make-function-inline ',inline)))))) *kcl-function-inlines*))) (define-inlines) ) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) #+akcl (clines "#define AKCL206") (clines " #ifdef AKCL206 use_fast_links(); #endif object set_cclosure (result_cc,value_cc,available_size) object result_cc,value_cc; int available_size; { object result_env_tail,value_env_tail; int i; #ifdef AKCL206 /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ use_fast_links(3,Cnil,result_cc); #endif result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; #ifndef AKCL206 result_cc->cc.cc_start=value_cc->cc.cc_start; result_cc->cc.cc_size=value_cc->cc.cc_size; #endif return result_cc; }") (defentry %set-cclosure (object object int) (object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) #+akcl (setq s-data (get type 'si::s-data)) #-akcl (get type 'si::is-a-structure) (null #+akcl (si::s-data-type s-data) #-akcl (get type 'si::structure-type)))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))) #-akcl (get type 'si::structure-include))) (defun structure-type-internal-slotds (type) #+akcl (si::s-data-slot-descriptions (get type 'si::s-data)) #-akcl (get type 'si::structure-slot-descriptions)) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) #-new-kcl-wrapper (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) #+akcl (si:structure-ref1 x offset) #-akcl (si:structure-ref x type offset))) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym reader (and (not read-only-p) writer))))))) #+new-kcl-wrapper (list slotd)) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) #+new-kcl-wrapper (defun si::slot-reader-function (slot) (let ((offset (si::slot-offset slot))) (si:turbo-closure #'(lambda (x) (si::structure-ref1 x offset))))) #+new-kcl-wrapper (defun si::slot-writer-function (slot) (let ((offset (si::slot-offset slot))) (si:turbo-closure #'(lambda (x) (si::structure-set1 x offset))))) (mapcar #'(lambda (fname value) (setf (symbol-function fname) (symbol-function value))) '(structure-slotd-name structure-slotd-accessor-symbol structure-slotd-reader-function structure-slotd-writer-function structure-slotd-type structure-slotd-init-form) #-new-kcl-wrapper '(first second third fourth function-returning-nil function-returning-nil) #+new-kcl-wrapper '(si::slot-name si::slot-accessor-name si::slot-reader-function si::slot-writer-function si::slot-type si::slot-default-init)) ;; Construct files sys-proclaim.lisp and sys-package.lisp ;; The file sys-package.lisp must be loaded first, since the ;; package sys-proclaim.lisp will refer to symbols and they must ;; be in the right packages. sys-proclaim.lisp contains function ;; declarations and declarations that certain things are closures. (defun renew-sys-files() ;; packages: (compiler::get-packages "sys-package.lisp") (with-open-file (st "sys-package.lisp" :direction :output :if-exists :append) (format st "(in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (let ((*package* (find-package 'user))) (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) ;;(format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") ))) gcl/pcl/impl/kcl/misc-kcl-patches.text0000644000175000017500000002374612240167764016611 0ustar cammcammc/cmpaux.c *** c/cmpaux.c Mon Jul 6 00:14:55 1992 --- ../akcl-1-615/c/cmpaux.c Thu Jun 18 20:01:07 1992 *************** *** 229,239 **** if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) return x->st.st_self; if (x->st.st_dim == leng && ( leng % sizeof(object)) ) ! { x->st.st_self[leng] = 0; return x->st.st_self; } else {char *res=malloc(leng+1); bcopy(x->st.st_self,res,leng); --- 229,240 ---- if (leng > 0 && leng < x->st.st_dim && x->st.st_self[leng]==0) return x->st.st_self; if (x->st.st_dim == leng && ( leng % sizeof(object)) ) ! { if(x->st.st_self[leng] != 0) ! x->st.st_self[leng] = 0; return x->st.st_self; } else {char *res=malloc(leng+1); bcopy(x->st.st_self,res,leng); c/main.c *** c/main.c Mon Jul 6 00:14:59 1992 --- ../akcl-1-615/c/main.c Fri Jul 3 02:19:37 1992 *************** *** 611,621 **** {catch_fatal = -1; if (sgc_enabled) { sgc_quit();} if (sgc_enabled==0) { install_segmentation_catcher() ;} ! FEerror("Caught fatal error [memory may be damaged]"); } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX abort(); #endif --- 611,621 ---- {catch_fatal = -1; if (sgc_enabled) { sgc_quit();} if (sgc_enabled==0) { install_segmentation_catcher() ;} ! FEerror("Caught fatal error [memory may be damaged] ~A",1,make_simple_string(s)); } printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX abort(); #endif *************** *** 853,872 **** siLsave_system() { int i; - #ifdef HAVE_YP_UNBIND - extern object truename(),namestring(); check_arg(1); ! /* prevent subsequent consultation of yp by getting ! truename now*/ ! vs_base[0]=namestring(truename(vs_base[0])); ! {char name[200]; ! char *dom = name; ! if (0== getdomainname(dom,sizeof(name))) ! yp_unbind(dom);} #endif saving_system = TRUE; GBC(t_contiguous); --- 853,867 ---- siLsave_system() { int i; check_arg(1); ! #ifdef HAVE_YP_UNBIND ! /* see unixsave.c */ ! {char *dname; ! yp_get_default_domain(&dname);} #endif saving_system = TRUE; GBC(t_contiguous); c/num_log.c *** c/num_log.c Mon Jul 6 00:15:00 1992 --- ../akcl-1-615/c/num_log.c Mon Jun 15 21:15:59 1992 *************** *** 266,286 **** return(~j); } int big_bitp(x, p) ! object x; ! int p; { GEN u = MP(x); int ans ; int i = p /32; if (signe(u) < 0) { save_avma; u = complementi(u); restore_avma; } ! if (i < lgef(u)) { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} else if (big_sign(x) < 0) ans = 1; else ans = 0; return ans; } --- 266,286 ---- return(~j); } int big_bitp(x, p) ! object x; ! int p; { GEN u = MP(x); int ans ; int i = p /32; if (signe(u) < 0) { save_avma; u = complementi(u); restore_avma; } ! if (i < lgef(u) -MP_CODE_WORDS) { ans = ((MP_ITH_WORD(u,i,lgef(u))) & (1 << p%32));} else if (big_sign(x) < 0) ans = 1; else ans = 0; return ans; } c/unixsave.c *** c/unixsave.c Mon Jul 6 00:15:07 1992 --- ../akcl-1-615/c/unixsave.c Fri Jul 3 02:52:36 1992 *************** *** 71,81 **** --- 71,160 ---- break; } else break; } + #include "page.h" + /* string is aligned on a word boundary */ + int + find_string_in_memory(string,length,other_p,function) + char *string; + int length,other_p; + int *function(); + { + int *imem_first,*imem_last,*imem,word; + char *mem; + int len,page_first,page_last,i; + int maxpage = page(heap_end); + if(((int)string & 3) == 0 && length >= 4) /* just to be safe */ + {word=*(int *)string; + for (page_first = 0; page_first < maxpage; page_first++) + if ((enum type)type_map[page_first] != t_other) + break; + for (; page_first < maxpage; page_first++) + if (((enum type)type_map[page_first] == t_other)?other_p:!other_p) + {for (page_last = page_first+1; page_last < maxpage; page_last++) + if ( !(((enum type)type_map[page_last] == t_other)?other_p:!other_p) ) + break; + imem_first=(int *)pagetochar(page_first); + imem_last=(int *)( ( ((int)pagetochar(page_last)) - length) &~3 ); + for (imem = imem_first; imem <= imem_last; imem++) + if (*imem == word) + {mem=(char *)imem; + for(i=4; i=length) + if((*function)(mem)) + return TRUE;}}} + return FALSE; + } + + int + fsim_first(address) + char *address; + { + return TRUE; + } + + int + fsim_reset_pointer(address) + char **address; + { + *address = NULL; + return FALSE; + } + + #define t_other_PAGES TRUE + #define NOT_t_other_PAGES FALSE + + int + reset_other_pointers(address) + char *address; + { + int word=(int)address; + find_string_in_memory(&word,4,t_other_PAGES,fsim_reset_pointer); + } + + int + maybe_reset_pointers(address) + char *address; + { + int word=(int)address; + if(!find_string_in_memory(&word,4,NOT_t_other_PAGES,fsim_first)) + reset_other_pointers(address); + return FALSE; + } + + reset_other_pointers_to_string(string) + char *string; + { + int length=strlen(string)+1; + find_string_in_memory(string,length,t_other_PAGES,maybe_reset_pointers); + } + + bool saving_system; + memory_save(original_file, save_file) char *original_file, *save_file; { MEM_SAVE_LOCALS; char *data_begin, *data_end; int original_data; *************** *** 100,110 **** --- 179,206 ---- n = open(save_file, O_CREAT|O_WRONLY, 0777); if (n != 1 || (save = fdopen(n, "w")) != stdout) { fprintf(stderr, "Can't open the save file.\n"); exit(1); } + setbuf(save, stdout_buf); + + #ifdef HAVE_YP_UNBIND + /* yp_get_default_domain() caches the result of getdomainname() in + a malloc'ed block of memory; and gethostbyname saves the result of + yp_get_default_domain() in yet another chunk of memory. These + cached values will cause problems if the saved image is run on a + machine having a different local domainname. [When getdomainname + is called (by CLX, for example) KCL will wait forever.] There doesn't + seem to be any way to uncache these things (apparently yp_unbind does + not do this), nor any good way to find these blocks of memory. */ + + if(saving_system) + {char *dname; + yp_get_default_domain(&dname); + reset_other_pointers(dname);} + #endif READ_HEADER; FILECPY_HEADER; for (n = header.a_data, p = data_begin; ; n -= BUFSIZ, p += BUFSIZ) cmpnew/cmpcall.lsp *** cmpnew/cmpcall.lsp Mon Jul 6 00:15:13 1992 --- ../akcl-1-615/cmpnew/cmpcall.lsp Thu Jun 18 21:43:24 1992 *************** *** 118,127 **** --- 118,128 ---- ;;; responsible for maintaining this condition. (let ((*vs* *vs*) (form (caddr funob))) (declare (object form)) (cond ((and (listp args) *use-sfuncall* + (<= (length (cdr args)) 10) ;;Determine if only one value at most is required: (or (eq *value-to-go* 'trash) (and (consp *value-to-go*) (eq (car *value-to-go*) 'var)) lsp/autoload.lsp *** lsp/autoload.lsp Mon Jul 6 00:15:27 1992 --- ../akcl-1-615/lsp/autoload.lsp Tue Jun 16 02:36:45 1992 *************** *** 430,440 **** '(cons fixnum bignum ratio short-float long-float complex character symbol package hash-table array vector string bit-vector structure stream random-state readtable pathname ! cfun cclosure sfun gfun cfdata spice fat-string )) (defun room (&optional x) (let ((l (multiple-value-list (si:room-report))) maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage rbused rbfree nrbpage --- 430,440 ---- '(cons fixnum bignum ratio short-float long-float complex character symbol package hash-table array vector string bit-vector structure stream random-state readtable pathname ! cfun cclosure sfun gfun vfun cfdata spice fat-string dclosure)) (defun room (&optional x) (let ((l (multiple-value-list (si:room-report))) maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage rbused rbfree nrbpage lsp/cmpinit.lsp *** lsp/cmpinit.lsp Mon Jul 6 00:15:28 1992 --- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 *************** *** 4,12 **** (setq compiler::*eval-when-defaults* '(compile eval load)) (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! ! ;;;;; --- 4,13 ---- (setq compiler::*eval-when-defaults* '(compile eval load)) (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! (unless (get 'si::basic-wrapper 'si::s-data) ! (setf (get 'si::s-data 'si::s-data) nil) ! (load "../lsp/defstruct.lsp")) ;;;;; gcl/pcl/impl/kcl/kcl-patches.lisp0000644000175000017500000002731012240167764015632 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "COMPILER") #+akcl (eval-when (compile load eval) (when (<= system::*akcl-version* 609) (pushnew :pre_akcl_610 *features*)) (if (and (boundp 'si::*akcl-version*) (>= si::*akcl-version* 604)) (progn (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) (when (fboundp 'si::allocate-growth) (pushnew :turbo-closure *features*))) ;; patch around compiler bug. (when (<= si::*akcl-version* 609) (let ((vcs "static int Vcs; ")) (unless (search vcs compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string vcs compiler::*cmpinclude-string*))))) (let ((rset "int Rset; ")) (unless (search rset compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string rset compiler::*cmpinclude-string*)))) (when (get 'si::basic-wrapper 'si::s-data) (pushnew :new-kcl-wrapper *features*) (pushnew :structure-wrapper *features*)) ) #+akcl (progn (unless (fboundp 'real-c2lambda-expr-with-key) (setf (symbol-function 'real-c2lambda-expr-with-key) (symbol-function 'c2lambda-expr-with-key))) (defun c2lambda-expr-with-key (lambda-list body) (declare (special *sup-used*)) (setq *sup-used* t) (real-c2lambda-expr-with-key lambda-list body)) ;There is a bug in the implementation of *print-circle* that ;causes some akcl debugging commands (including :bt and :bl) ;to cause the following error when PCL is being used: ;Unrecoverable error: value stack overflow. ;When a CLOS object is printed, travel_push_object ends up ;traversing almost the whole class structure, thereby overflowing ;the value-stack. ;from lsp/debug.lsp. ;*print-circle* is badly implemented in kcl. ;it has two separate problems that should be fixed: ; 1. it traverses the printed object putting all objects found ; on the value stack (rather than in a hash table or some ; other structure; this is a problem because the size of the value stack ; is fixed, and a potentially unbounded number of objects ; need to be traversed), and ; 2. it blindly traverses all slots of any ; kind of structure including std-object structures. ; This is safe, but not always necessary, and is very time-consuming ; for CLOS objects (because it will always traverse every class). ;For now, avoid using *print-circle* T when it will cause problems. (eval-when (compile eval) (defmacro si::f (op &rest args) `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) (defmacro si::fb (op &rest args) `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) ) (defun si::display-env (n env) (do ((v (reverse env) (cdr v))) ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) (or (and (consp (car v)) (listp (cdar v))) (return)) (let ((*print-circle* (can-use-print-circle-p (cadar v)))) (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) (defun si::display-compiled-env ( plength ihs &aux (base (si::ihs-vs ihs)) (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) (format si::*display-string* "") (do ((i base ) (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) (format si::*display-string* "~a~@[~d~]=~s~@[,~]" (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) (si::fb < (setq i (si::f + i 1)) end))))) (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") (defentry objnull-p (object) (object "objnull_p")) (defun can-use-print-circle-p (x) (catch 'can-use-print-circle-p (can-use-print-circle-p1 x nil))) (defun can-use-print-circle-p1 (x so-far) (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? (if (member x so-far) (throw 'can-use-print-circle-p t) (let ((so-far (cons x so-far))) (flet ((can-use-print-circle-p (x) (can-use-print-circle-p1 x so-far))) (typecase x (vector (or (not (eq 't (array-element-type x))) (every #'can-use-print-circle-p x))) (cons (and (can-use-print-circle-p (car x)) (can-use-print-circle-p (cdr x)))) (array (or (not (eq 't (array-element-type x))) (let* ((rank (array-rank x)) (dimensions (make-list rank))) (dotimes (i rank) (setf (nth i dimensions) (array-dimension x i))) (or (member 0 dimensions) (do ((cursor (make-list rank :initial-element 0))) (nil) (declare (:dynamic-extent cursor)) (unless (can-use-print-circle-p (apply #'aref x cursor)) (return nil)) (when (si::increment-cursor cursor dimensions) (return t))))))) (t (or (not (si:structurep x)) (let* ((def (si:structure-def x)) (name (si::s-data-name def)) (len (si::s-data-length def)) (pfun (si::s-data-print-function def))) (and (null pfun) (dotimes (i len t) (unless (can-use-print-circle-p (si:structure-ref x name i)) (return nil))))))))))))) (defun si::apply-display-fun (display-fun n lis) (let ((*print-length* si::*debug-print-level*) (*print-level* si::*debug-print-level*) (*print-pretty* nil) (*PRINT-CASE* :downcase) (*print-circle* nil) ) (setf (fill-pointer si::*display-string*) 0) (format si::*display-string* "{") (funcall display-fun n lis) (when (si::fb > (fill-pointer si::*display-string*) n) (setf (fill-pointer si::*display-string*) n) (format si::*display-string* "...")) (format si::*display-string* "}") ) si::*display-string* ) ;The old definition of this had a bug: ;sometimes it returned without calling mv-values. (defun si::next-stack-frame (ihs &aux line-info li i k na) (cond ((si::fb < ihs si::*ihs-base*) (si::mv-values nil nil nil nil nil)) ((let (fun) ;; next lower visible ihs (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) (setq na fun) (cond ((and (setq line-info (get fun 'si::line-info)) (do ((j (si::f + ihs 1) (si::f - j 1)) (form )) ((<= j i) nil) (setq form (si::ihs-fun j)) (cond ((setq li (si::get-line-of-form form line-info)) (return-from si::next-stack-frame (si::mv-values i fun li ;; filename (car (aref line-info 0)) ;;environment (list (si::vs (setq k (si::ihs-vs j))) (si::vs (1+ k)) (si::vs (+ k 2))))))))))))) ((and (not (special-form-p na)) (not (get na 'si::dbl-invisible)) (fboundp na)) (si::mv-values i na nil nil (if (si::ihs-not-interpreted-env i) nil (let ((i (si::ihs-vs i))) (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) (t (si::mv-values nil nil nil nil nil)))) ) #+pre_akcl_610 (progn ;(proclaim '(optimize (safety 0) (speed 3) (space 1))) ;Not needed... make-top-level-form generates defuns now. ;(setq compiler::*compile-ordinaries* t) (eval-when (compile load eval) (unless (fboundp 'original-co1typep) (setf (symbol-function 'original-co1typep) #'co1typep)) ) (defun new-co1typep (f args) (or (original-co1typep f args) (let ((x (car args)) (type (cadr args))) (when (constantp type) (let ((ntype (si::normalize-type (eval type)))) (when (and (eq (car ntype) 'satisfies) (cadr ntype) (symbolp (cadr ntype)) (symbol-package (cadr ntype))) (c1expr `(the boolean (,(cadr ntype) ,x))))))))) (setf (symbol-function 'co1typep) #'new-co1typep) ) #-(or akcl xkcl) (progn (in-package 'system) ;;; This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere ;;; in the lambda-list. The former allows deviation from the CL spec, ;;; but what the heck. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3)))) (defvar *old-defmacro*) (defun new-defmacro (whole env) (flet ((call-old-definition (new-whole) (funcall *old-defmacro* new-whole env))) (if (not (and (consp whole) (consp (cdr whole)) (consp (cddr whole)) (consp (cdddr whole)))) (call-old-definition whole) (let* ((ll (caddr whole)) (env-tail (do ((tail ll (cdr tail))) ((not (consp tail)) nil) (when (eq '&environment (car tail)) (return tail))))) (if env-tail (call-old-definition (list* (car whole) (cadr whole) (append (list '&environment (cadr env-tail)) (ldiff ll env-tail) (cddr env-tail)) (cdddr whole))) (call-old-definition whole)))))) (eval-when (load eval) (unless (boundp '*old-defmacro*) (setq *old-defmacro* (macro-function 'defmacro)) (setf (macro-function 'defmacro) #'new-defmacro))) ;;; ;;; setf patches ;;; (defun get-setf-method (form) (multiple-value-bind (vars vals stores store-form access-form) (get-setf-method-multiple-value form) (unless (listp vars) (error "The temporary variables component, ~s, of the setf-method for ~s is not a list." vars form)) (unless (listp vals) (error "The values forms component, ~s, of the setf-method for ~s is not a list." vals form)) (unless (listp stores) (error "The store variables component, ~s, of the setf-method for ~s is not a list." stores form)) (unless (= (list-length stores) 1) (error "Multiple store-variables are not allowed.")) (values vars vals stores store-form access-form))) (defun get-setf-method-multiple-value (form) (cond ((symbolp form) (let ((store (gensym))) (values nil nil (list store) `(setq ,form ,store) form))) ((or (not (consp form)) (not (symbolp (car form)))) (error "Cannot get the setf-method of ~S." form)) ((get (car form) 'setf-method) (apply (get (car form) 'setf-method) (cdr form))) ((get (car form) 'setf-update-fn) (let ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym))) (values vars (cdr form) (list store) `(,(get (car form) 'setf-update-fn) ,@vars ,store) (cons (car form) vars)))) ((get (car form) 'setf-lambda) (let* ((vars (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (cdr form))) (store (gensym)) (l (get (car form) 'setf-lambda)) (f `(lambda ,(car l) (funcall #'(lambda ,(cadr l) ,@(cddr l)) ',store)))) (values vars (cdr form) (list store) (apply f vars) (cons (car form) vars)))) ((macro-function (car form)) (get-setf-method-multiple-value (macroexpand-1 form))) (t (error "Cannot expand the SETF form ~S." form)))) ) gcl/pcl/impl/kcl/new-kcl-wrapper.text0000644000175000017500000016433212240167764016475 0ustar cammcammThe new-kcl-wrapper modifications make the storage of standard-objects and structure objects much more similar than before. These changes should greatly speed up WRAPPER-OF for structure objects and should speed up WRAPPER-OF for standard-instances also (but not funcallable instances). Look first at the defstructs defined here (scan this file for "(defstruct ("). Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of the wrapper structure. Finally, look in low.lisp, at the "#+new-structure-wrapper" for the definition of %allocate-instance--class. You need to have akcl-1-615 to use this file. This file contains new versions of the files V/c/structure.c and V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp. -- The gbc changes allow the garbage collector to work correctly even when structures which define other structures (ones which can be the value of STRUCTURE-DEF) are not allocated in static storage. c/gbc.c *** c/gbc.c Tue Jun 30 04:11:00 1992 --- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992 *************** *** 427,453 **** break; goto COPY_STRING; case t_structure: mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! break; ! {object def=x->str.str_def; ! unsigned char * s_type = &SLOT_TYPE(def,0); ! unsigned short *s_pos= & SLOT_POS(def,0); ! for (i = 0, j = S_DATA(def)->length; i < j; i++) if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! S_DATA(def)->size); } else ! x->str.str_self = (object *) ! copy_relblock((char *)p, S_DATA(def)->size); }} break; case t_stream: switch (x->sm.sm_mode) { --- 427,461 ---- break; goto COPY_STRING; case t_structure: + x->d.m = 2; mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! {x->d.m = TRUE; break;} ! {object def=x->str.str_def; ! struct s_data *sdef=S_DATA(def); ! unsigned char *s_type; ! unsigned short *s_pos; ! if((int)what_to_collect >= (int)t_contiguous && ! !inheap(sdef) && def->d.m==TRUE) ! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); ! s_type = sdef->raw->ust.ust_self; ! s_pos = &USHORT(sdef->slot_position,0); ! for (i = 0, j = sdef->length; i < j; i++) if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! sdef->size); } else ! x->str.str_self = (object *) ! copy_relblock((char *)p, sdef->size); }} + x->d.m = TRUE; break; case t_stream: switch (x->sm.sm_mode) { *** c/sgbc.c Mon Jun 15 21:16:01 1992 --- akcl-1-615/c/sgbc.c Wed Jul 1 18:37:24 1992 *************** *** 355,386 **** if (cp == NULL) break; goto COPY_STRING; case t_structure: sgc_mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! break; ! {object def=x->str.str_def; ! unsigned char * s_type = &SLOT_TYPE(def,0); ! unsigned short *s_pos= & SLOT_POS(def,0); ! for (i = 0, j = S_DATA(def)->length; i < j; i++) if (s_type[i]==0 && ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) ) sgc_mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! S_DATA(def)->size); } else if(SGC_RELBLOCK_P(p)) x->str.str_self = (object *) ! copy_relblock((char *)p, S_DATA(def)->size); }} break; case t_stream: switch (x->sm.sm_mode) { case smm_input: --- 355,394 ---- if (cp == NULL) break; goto COPY_STRING; case t_structure: + x->d.m = 2; sgc_mark_object(x->str.str_def); p = x->str.str_self; if (p == NULL) ! {x->d.m = TRUE; break;} ! {object def=x->str.str_def; ! struct s_data *sdef=S_DATA(def); ! unsigned char *s_type; ! unsigned short *s_pos; ! if((int)what_to_collect >= (int)t_contiguous && ! !inheap(sdef) && def->d.m==TRUE) ! sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start)); ! s_type = sdef->raw->ust.ust_self; ! s_pos = &USHORT(sdef->slot_position,0); ! for (i = 0, j = sdef->length; i < j; i++) if (s_type[i]==0 && ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i])) ) sgc_mark_object(STREF(object,x,s_pos[i])); if ((int)what_to_collect >= (int)t_contiguous) { if (inheap(x->str.str_self)) { if (what_to_collect == t_contiguous) mark_contblock((char *)p, ! sdef->size); } else if(SGC_RELBLOCK_P(p)) x->str.str_self = (object *) ! copy_relblock((char *)p, sdef->size); }} + x->d.m = TRUE; break; case t_stream: switch (x->sm.sm_mode) { case smm_input: cmpnew/cmpinit.lsp *** cmpnew/cmpinit.lsp Tue Jun 30 04:11:13 1992 --- ../akcl-1-615/cmpnew/cmpinit.lsp Mon Jun 22 18:41:51 1992 *************** *** 4,7 **** --- 4,10 ---- (load "sys-proclaim.lisp") (setq compiler::*eval-when-defaults* '(compile eval load)) ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel cmpeval)) (load (format nil "~(~a~).lsp" v))) + (unless (get 'si::basic-wrapper 'si::s-data) + (setf (get 'si::s-data 'si::s-data) nil) + (load "../lsp/defstruct.lsp")) lsp/cmpinit.lsp *** lsp/cmpinit.lsp Tue Jun 30 04:11:26 1992 --- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992 *************** *** 5,12 **** (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! ! ;;;;; --- 5,13 ---- (or (fboundp 'si::get-&environment) (load "defmacro.lsp")) ;(or (get 'si::s-data 'si::s-data) ; (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp"))) (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp")) ! (unless (get 'si::basic-wrapper 'si::s-data) ! (setf (get 'si::s-data 'si::s-data) nil) ! (load "../lsp/defstruct.lsp")) ;;;;; lsp/describe.lsp *** lsp/describe.lsp Tue Jun 30 04:11:27 1992 --- ../akcl-1-615/lsp/describe.lsp Tue Jun 23 16:39:07 1992 *************** *** 266,282 **** (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) ! (let* ((sd (get name 'si::s-data)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" ! (aref spos (nth 4 v)) ! (let ((type (nth 2 v))) (if (eq t type) nil type)) ! (car v) ! (structure-ref1 x (nth 4 v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) --- 266,282 ---- (defun inspect-structure (x &aux name) (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name :Slot Value" (setq name (type-of x))) ! (let* ((sd (structure-def x)) (spos (s-data-slot-position sd))) (dolist (v (s-data-slot-descriptions sd)) (format t "~%~4d:~@[[~s] ~]~20a:~s" ! (aref spos (slot-offset v)) ! (let ((type (slot-type v))) (if (eq t type) nil type)) ! (slot-name v) ! (structure-ref1 x (slot-offset v)))))) (defun inspect-object (object &aux (*inspect-level* *inspect-level*)) (inspect-indent) ============================================================================== =============================== c/structure.c ================================ Changes file for /kcl/c/structure.c Usage \n@s[Original text\n@s|Replacement Text\n@s] See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c for a program to merge change files. Anything not between "\n@s[" and "\n@s]" is a simply a comment. This file was constructed using emacs and merge.el by (Bill Schelter) wfs@carl.ma.utexas.edu ****Change:(orig (15 17 d)) @s[object siSstructure_print_function; object siSstructure_slot_descriptions; object siSstructure_include; @s| @s] ****Change:(orig (18 18 a)) @s[ @s| #define COERCE_DEF(x) if (type_of(x)==t_symbol) \ x=getf(x->s.s_plist,siLs_data,Cnil) #define check_type_structure(x) \ if(type_of((x))!=t_structure) \ FEwrong_type_argument(Sstructure,(x)) @s] ****Change:(orig (22 31 c)) @s[{ do { if (type_of(x) != t_symbol) return(FALSE); @s, } while (x != Cnil); return(FALSE); } @s|{ if (x==y) return 1; if (type_of(x)!= t_structure || type_of(y)!=t_structure) FEerror("bad call to structure_subtypep",0); {if (S_DATA(y)->included == Cnil) return 0; while ((x=S_DATA(x)->includes) != Cnil) { if (x==y) return 1;} return 0; }} @s] ****Change:(orig (32 32 a)) @s[ @s| static bad_raw_type() { FEerror("Bad raw struct type",0);} @s] ****Change:(orig (34 34 c)) @s[structure_ref(x, name, n) @s|structure_ref(x, name, i) @s] ****Change:(orig (36 38 c)) @s[object x, name; int n; { int i; @s|object x, name; int i; {unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || (type_of(name)!=t_structure) || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name), x); s_pos = &SLOT_POS(x->str.str_def,0); switch((SLOT_TYPE(x->str.str_def,i))) { case aet_object: return(STREF(object,x,s_pos[i])); case aet_fix: return(make_fixnum((STREF(int,x,s_pos[i])))); case aet_ch: return(code_char(STREF(char,x,s_pos[i]))); case aet_bit: case aet_char: return(make_fixnum(STREF(char,x,s_pos[i]))); case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i]))); case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i]))); case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i]))); case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i]))); case aet_short: return(make_fixnum(STREF(short,x,s_pos[i]))); default: bad_raw_type(); return 0; }} @s] ****Change:(orig (40 43 c)) @s[ if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, name)) FEwrong_type_argument(name, x); return(x->str.str_self[n]); @s| void siLstructure_ref1() {object x=vs_base[0]; int n=fix(vs_base[1]); object def; check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) FEerror("Structure ref out of bounds",0); vs_base[0]=structure_ref(x,x->str.str_def,n); vs_top=vs_base+1; @s] ****Change:(orig (45 45 a)) @s[} @s|} void siLstructure_set1() {object x=vs_base[0]; int n=fix(vs_base[1]); object v=vs_base[2]; object def; check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) FEerror("Structure ref out of bounds",0); vs_base[0]=structure_set(x,x->str.str_def,n,v); vs_top=vs_base+1; } @s] ****Change:(orig (47 47 c)) @s[structure_set(x, name, n, v) @s|structure_set(x, name, i, v) @s] ****Change:(orig (49 51 c)) @s[object x, name, v; int n; { int i; @s|object x, name, v; int i; {unsigned short *s_pos; COERCE_DEF(name); if (type_of(x) != t_structure || type_of(name) != t_structure || !structure_subtypep(x->str.str_def, name)) FEwrong_type_argument((type_of(name)==t_structure ? S_DATA(name)->name : name) , x); @s] ****Change:(orig (53 57 c)) @s[ if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, name)) FEwrong_type_argument(name, x); x->str.str_self[n] = v; @s, return(v); @s|#ifdef SGC /* make sure the structure header is on a writable page */ if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0; #endif s_pos= & SLOT_POS(x->str.str_def,0); switch(SLOT_TYPE(x->str.str_def,i)){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); } return(v); @s] ****Change:(orig (59 59 a)) @s[} @s|} void siLstructure_subtype_p() {object x,y; check_arg(2); x=vs_base[0]; y=vs_base[1]; if (type_of(x)!=t_structure) {vs_base[0]=Cnil; goto BOTTOM;} x=x->str.str_def; COERCE_DEF(y); if (structure_subtypep(x,y)) vs_base[0]=Ct; else vs_base[0]=Cnil; BOTTOM: vs_top=vs_base+1; } static object slot_name(x) object x; { if(type_of(x)==t_cons) return car(x); if(type_of(x)==t_structure) return x->str.str_self[0]; return Cnil; } @s] ****Change:(orig (64 64 a)) @s[object x; { object *p, s; @s|object x; { object *p, s; struct s_data *def=S_DATA(x->str.str_def); @s] ****Change:(orig (66 69 c)) @s[ s = getf(x->str.str_name->s.s_plist, siSstructure_slot_descriptions, Cnil); vs_push(x->str.str_name); @s| s = def->slot_descriptions; vs_push(def->name); @s] ****Change:(orig (72 73 c)) @s[ for (i=0, n=x->str.str_length; !endp(s)&&ic.c_cdr, i++) { *p = make_cons(car(s->c.c_car), Cnil); @s| for (i=0, n=def->length; !endp(s)&&ic.c_cdr, i++) { *p = make_cons(slot_name(s->c.c_car), Cnil); @s] ****Change:(orig (75 75 c)) @s[ *p = make_cons(x->str.str_self[i], Cnil); @s| *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil); @s] ****Change:(orig (81 81 a)) @s[ stack_cons(); return(vs_pop); } @s| stack_cons(); return(vs_pop); } void @s] ****Change:(orig (84 85 c)) @s[ object x; int narg, i; @s| object x,name,*base; struct s_data *def; int narg, i,size; base=vs_base; if ((narg = vs_top - base) == 0) too_few_arguments(); x = alloc_object(t_structure); name=base[0]; COERCE_DEF(name); if (type_of(name)!=t_structure || (def=S_DATA(name))->length != --narg) FEerror("Bad make_structure args for type ~a",1, base[0]); x->str.str_def = name; x->str.str_self = NULL; size=S_DATA(name)->size; base[0] = x; x->str.str_self = (object *) (def->staticp == Cnil ? alloc_relblock(size) : alloc_contblock(size)); /* There may be holes in the structure. We want them zero, so that equal can work better. */ if (S_DATA(name)->has_holes != Cnil) bzero(x->str.str_self,size); {unsigned char *s_type; unsigned short *s_pos; s_pos= (&SLOT_POS(x->str.str_def,0)); s_type = (&(SLOT_TYPE(x->str.str_def,0))); base=base+1; for (i = 0; i < narg; i++) {object v=base[i]; switch(s_type[i]){ case aet_object: STREF(object,x,s_pos[i])=v; break; case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break; case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break; case aet_bit: case aet_char: STREF(char,x,s_pos[i])=fix(v); break; case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break; case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break; case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break; case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break; case aet_short: STREF(short,x,s_pos[i])=fix(v); break; default: bad_raw_type(); @s] ****Change:(orig (87 97 c)) @s[ if ((narg = vs_top - vs_base) == 0) too_few_arguments(); x = alloc_object(t_structure); x->str.str_name = vs_base[0]; @s, x->str.str_self[i] = vs_top[i]; @s| }} vs_top = base; vs_base=base-1; } @s] ****Change:(orig (99 99 a)) @s[} @s|} void @s] ****Change:(orig (103 103 c)) @s[ object x, y; int i, j; @s| object x, y; struct s_data *def; @s] ****Change:(orig (105 105 c)) @s[ check_arg(2); @s| if (vs_top-vs_base < 1) too_few_arguments(); @s] ****Change:(orig (107 110 c)) @s[ if (type_of(x) != t_structure || x->str.str_name != vs_base[1]) FEwrong_type_argument(vs_base[1], x); vs_base[1] = y = alloc_object(t_structure); y->str.str_name = x->str.str_name; @s| check_type_structure(x); vs_base[0] = y = alloc_object(t_structure); def=S_DATA(y->str.str_def = x->str.str_def); @s] ****Change:(orig (112 116 c)) @s[ y->str.str_length = j = x->str.str_length; y->str.str_self = (object *)alloc_relblock(sizeof(object)*j); for (i = 0; i < j; i++) y->str.str_self[i] = x->str.str_self[i]; @s, vs_base++; @s| y->str.str_self = (object *)alloc_relblock(def->size); bcopy(x->str.str_self,y->str.str_self,def->size); vs_top=vs_base+1; @s] ****Change:(orig (118 118 a)) @s[} @s|} void siLcopy_structure_header() { object x, y; if (vs_top-vs_base < 1) too_few_arguments(); x = vs_base[0]; check_type_structure(x); vs_base[0] = y = alloc_object(t_structure); y->str.str_def = x->str.str_def; y->str.str_self = x->str.str_self; vs_top=vs_base+1; } void @s] ****Change:(orig (122 124 c)) @s[ if (type_of(vs_base[0]) != t_structure) FEwrong_type_argument(Sstructure, vs_base[0]); vs_base[0] = vs_base[0]->str.str_name; @s| check_type_structure(vs_base[0]); vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name; @s] ****Change:(orig (127 127 c)) @s[} siLstructure_ref() @s|} #define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \ structure_slot_position(str,name)) object structure_ref_new(x, name, i) object x,name,i; @s] ****Change:(orig (129 131 c)) @s[ object x; int i; check_arg(3); @s| return structure_ref(x,name,FIND_SLOT(x,i)); } @s] ****Change:(orig (133 144 c)) @s[ x = vs_base[0]; if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, vs_base[1])) FEwrong_type_argument(vs_base[1], x); @s, vs_base[0] = x->str.str_self[i]; vs_top = vs_base+1; @s|object structure_set_new(x, name, i, v) object x,name,i,v; { return structure_set(x,name,FIND_SLOT(x,i),v); @s] ****Change:(orig (146 146 a)) @s[} @s|} void siLstructure_ref() { check_arg(3); vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]); vs_top=vs_base+1; } void @s] ****Change:(orig (149 150 d)) @s[siLstructure_set() { object x; int i; @s|siLstructure_set() { @s] ****Change:(orig (152 163 c)) @s[ x = vs_base[0]; if (type_of(x) != t_structure || !structure_subtypep(x->str.str_name, vs_base[1])) @s, x->str.str_self[i] = vs_base[3]; @s| structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]); @s] ****Change:(orig (166 166 a)) @s[ vs_base = vs_top-1; } @s| vs_base = vs_top-1; } void @s] ****Change:(orig (228 228 c)) @s[init_structure_function() @s|void siLmake_s_data_structure() {object x,y,raw,*base; int i; check_arg(5); x=vs_base[0]; base=vs_base; raw=vs_base[1]; y=alloc_object(t_structure); y->str.str_def=y; y->str.str_self = (object *)( x->v.v_self); S_DATA(y)->name =siLs_data; S_DATA(y)->length=(raw->v.v_dim); S_DATA(y)->raw =raw; for(i=3; iv.v_dim; i++) y->str.str_self[i]=Cnil; S_DATA(y)->slot_position=base[2]; S_DATA(y)->slot_descriptions=base[3]; S_DATA(y)->staticp=base[4]; S_DATA(y)->size = (raw->v.v_dim)*sizeof(object); vs_base[0]=y; vs_top=vs_base+1; } object siSstructure_init,siSstructure_init_named; object siSname,siSdefault_init; object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions; static object slot_value(str,name) object str,name; @s] ****Change:(orig (230 237 c)) @s[ siSstructure_print_function = make_si_ordinary("STRUCTURE-PRINT-FUNCTION"); enter_mark_origin(&siSstructure_print_function); siSstructure_slot_descriptions @s, enter_mark_origin(&siSstructure_include); @s| top: if(type_of(str)==t_structure) return structure_ref_new(str,str->str.str_def,name); if(str->c.c_car==siSstructure_init_named) {object new=get(str->c.c_cdr,siLs_data); str->c.c_car=siSstructure_init; str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} if(siSstructure_init!=car(str)) FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0); {object key=intern(coerce_to_string(name),keyword_package); object value=getf(cdddr(str),key,NULL); if(value!=NULL) return value; else {object slots; if(str==caddr(str)&&name==siSslot_descriptions) FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0); slots=slot_value(caddr(str),siSslot_descriptions); for(;!endp(slots);slots=cdr(slots)) if(name==slot_value(car(slots),siSname)) {object result,form=slot_value(car(slots),siSdefault_init); object *old_vs_base=vs_base,*old_vs_top=vs_top; vs_base=vs_top;vs_push(form);Leval();result=vs_base[0]; vs_base=old_vs_base; vs_top=old_vs_top; return result;} FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}} return Cnil; } @s] ****Change:(orig (238 238 a)) @s[ @s| int structure_slot_position(str,name) object str,name; { if(type_of(name)==t_fixnum) return fix(name); else {object slotd_list; int pos; check_type_structure(str); slotd_list=S_DATA(str->str.str_def)->slot_descriptions; for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list)) {object slotd=car(slotd_list); if(name==((type_of(slotd)==t_structure)? slotd->str.str_self[0]:slot_value(slotd,siSname))) return pos;} FEerror("Slot ~S not found in structure ~S",2,name,str); return 0;} } static object make_structures_internal(value) object value; { object str,def; int def_index,i,ind; switch(type_of(value)) {case t_cons: if(value->c.c_car==siSstructure_init_named) {object new=get(value->c.c_cdr,siLs_data); value->c.c_car=siSstructure_init; value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);} if(car(value)!=siSstructure_init) {value->c.c_car=make_structures_internal(value->c.c_car); value->c.c_cdr=make_structures_internal(value->c.c_cdr); break;} if(type_of(cadr(value))==t_structure) {value=value->c.c_cdr->c.c_car; break;} {object def=caddr(value),plist=cdddr(value),result; object slots,slots_tail; int size,staticp,len,i; if(def!=value)def=make_structures_internal(def); result=alloc_object(t_structure); result->str.str_def=(def==value)?result:def; result->str.str_self=NULL; value->c.c_cdr->c.c_car=result; size=fixint(slot_value(def,siSsize)); staticp=Cnil!=slot_value(def,siSstaticp); slots=slot_value(def,siSslot_descriptions); len=length(slots); result->str.str_self=(object *)(staticp?alloc_contblock(size): alloc_relblock(size)); bzero(result->str.str_self,size); if(def==value) {S_DATA(result)->raw=slot_value(def,siSraw); S_DATA(result)->slot_position=slot_value(def,siSslot_position);} for(i=0,slots_tail=slots; istr.str_def,i,svalue);} for(i=0,slots_tail=slots; istr.str_def,i); svalue=make_structures_internal(svalue); structure_set(result,result->str.str_def,i,svalue);} value=result; break;} case t_vector: if ((enum aelttype)value->v.v_elttype == aet_object) {int i,len=value->v.v_dim; for(i=0; iv.v_self[i]=make_structures_internal(value->v.v_self[i]);} break; case t_symbol: {object plist=value->s.s_plist,next; for(;!endp(plist);plist=cddr(plist)) {next=plist->c.c_cdr; if(plist->c.c_car==siLs_data&& type_of(next->c.c_car)==t_cons) next->c.c_car=make_structures_internal(next->c.c_car);} break;}} return value; } void siLmake_structures() { check_arg(1); vs_base[0]=make_structures_internal(vs_base[0]); } void siLstructure_def() {check_arg(1); check_type_structure(vs_base[0]); vs_base[0]=vs_base[0]->str.str_def; } short aet_sizes [] = { sizeof(object), /* aet_object t */ sizeof(char), /* aet_ch string-char */ sizeof(char), /* aet_bit bit */ sizeof(fixnum), /* aet_fix fixnum */ sizeof(float), /* aet_sf short-float */ sizeof(double), /* aet_lf long-float */ sizeof(char), /* aet_char signed char */ sizeof(char), /* aet_uchar unsigned char */ sizeof(short), /* aet_short signed short */ sizeof(short) /* aet_ushort unsigned short */ }; void siLsize_of() { object x= vs_base[0]; int i; i= aet_sizes[get_aelttype(x)]; vs_base[0]=make_fixnum(i); } void siLaet_type() {vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));} /* Return N such that something of type ARG can be aligned on an address which is a multiple of N */ void siLalignment() {struct {double x; int y; double z; float x1; int y1; float z1;} joe; joe.z=3.0; if (vs_base[0]==Slong_float) {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;} else if (vs_base[0]==Sshort_float) {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;} else {siLsize_of();} } void swap_structure_contents(str1,str2) object str1,str2; { object def1,*self1; check_type_structure(str1); check_type_structure(str2); def1=str1->str.str_def; self1=str1->str.str_self; str1->str.str_def=str2->str.str_def; str1->str.str_self=str2->str.str_self; str2->str.str_def=def1; str2->str.str_self=self1; } void siLswap_structure_contents() { check_arg(2); swap_structure_contents(vs_base[0],vs_base[1]); vs_base[0]=Cnil; vs_top=vs_base+1; } void siLset_structure_def() {check_arg(2); check_type_structure(vs_base[0]); check_type_structure(vs_base[1]); vs_base[0]->str.str_def=vs_base[1]; vs_base[0]=vs_base[1]; vs_top=vs_base+1; } init_structure_function() { siLs_data=make_si_ordinary("S-DATA"); siSstructure_init=make_si_ordinary("STRUCTURE-INIT"); siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED"); siSname=make_si_ordinary("NAME"); siSdefault_init=make_si_ordinary("DEFAULT-INIT"); siSraw=make_si_ordinary("RAW"); siSslot_position=make_si_ordinary("SLOT-POSITION"); siSsize=make_si_ordinary("SIZE"); siSstaticp=make_si_ordinary("STATICP"); siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS"); @s] ****Change:(orig (239 239 a)) @s[ make_si_function("MAKE-STRUCTURE", siLmake_structure); @s| make_si_function("MAKE-STRUCTURE", siLmake_structure); make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure); @s] ****Change:(orig (240 240 a)) @s[ make_si_function("COPY-STRUCTURE", siLcopy_structure); @s| make_si_function("COPY-STRUCTURE", siLcopy_structure); make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header); @s] ****Change:(orig (242 242 a)) @s[ make_si_function("STRUCTURE-REF", siLstructure_ref); @s| make_si_function("STRUCTURE-REF", siLstructure_ref); make_si_function("STRUCTURE-DEF", siLstructure_def); make_si_function("STRUCTURE-REF1", siLstructure_ref1); make_si_function("STRUCTURE-SET1", siLstructure_set1); @s] ****Change:(orig (245 245 c)) @s[ make_si_function("STRUCTUREP", siLstructurep); @s| make_si_function("STRUCTUREP", siLstructurep); make_si_function("SIZE-OF", siLsize_of); make_si_function("ALIGNMENT",siLalignment); make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p); @s] ****Change:(orig (247 247 a)) @s[ make_si_function("LIST-NTH", siLlist_nth); @s| make_si_function("LIST-NTH", siLlist_nth); make_si_function("AET-TYPE",siLaet_type); make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents); make_si_function("SET-STRUCTURE-DEF", siLset_structure_def); make_si_function("MAKE-STRUCTURES", siLmake_structures); @s] ============================================================================== ============================== V/lsp/defstruct.lsp ============================= Changes file for /kcl/lsp/defstruct.lsp Usage \n@s[Original text\n@s|Replacement Text\n@s] See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c for a program to merge change files. Anything not between "\n@s[" and "\n@s]" is a simply a comment. This file was constructed using emacs and merge.el by (Bill Schelter) wfs@carl.ma.utexas.edu ****Change:(orig (20 71 c)) @s[(defun make-access-function (name conc-name type named slot-name default-init slot-type read-only offset) (declare (ignore named default-init slot-type)) @s, ((error "~S is an illegal structure type." type))))) @s|(defvar *accessors* (make-array 10 :adjustable t)) (defvar *list-accessors* (make-array 2 :adjustable t)) (defvar *vector-accessors* (make-array 2 :adjustable t)) @s] ****Change:(orig (72 72 a)) @s[ @s| (or (fboundp 'record-fn) (setf (symbol-function 'record-fn) #'(lambda (&rest l) l nil))) @s] ****Change:(orig (73 73 a)) @s[ @s| (defun boot-slot-value (str name) (if (structurep str) (structure-ref str (structure-def str) name) (getf (cdddr str) (intern (string name) :keyword)))) (defun boot-set-slot-value (str name new-value) (if (structurep str) (structure-set str (structure-def str) name new-value) (setf (getf (cdddr str) (intern (string name) :keyword)) new-value))) (defun boot-subtypep (type1 type2) (or (eq type1 type2) (let* ((s-data (get type1 's-data)) (include (boot-s-data-name (boot-slot-value s-data 'includes)))) (boot-subtypep include type2)))) (defun make-slot-boot (&rest args) (if (get 's-data 's-data) (apply #'make-slot args) (list* 'structure-init nil '(structure-init-named . slot) args))) (defun make-s-data-boot (&rest args) (if (get 's-data 's-data) (apply #'make-s-data args) (list* 'structure-init nil '(structure-init-named . s-data) args))) (defun make-boot-accessor (slot accessor) (setf (symbol-function accessor) #'(lambda (object) (boot-slot-value object slot))) (let ((writer (intern (format nil "SET ~A" accessor)))) (setf (symbol-function writer) #'(lambda (object value) (boot-set-slot-value object slot value))) (eval `(defsetf ,accessor ,writer)))) (defmacro defstructboot (name &rest slots) (let ((conc-name (if (listp name) (string (second (assoc :conc-name (cdr name)))) (format nil "~A-" name)))) `(progn ,@(mapcar #'(lambda (slot) (let ((fname (intern (format nil "~A~A" conc-name slot)))) `(make-boot-accessor ',slot ',fname))) slots)))) (defstructboot (slot (:conc-name boot-slot-)) name default-init type read-only offset accessor-name type-changed) (defstructboot (s-data-internal (:conc-name boot-s-data-)) name length raw included includes staticp print-function slot-descriptions slot-position size has-holes) (defstructboot (basic-wrapper (:conc-name boot-wrapper-)) cache-number-vector state class) (defstructboot (s-data (:conc-name boot-s-data-)) frozen documentation constructors offset named type conc-name) (defun make-access-function (name conc-name type named include no-fun slot) (declare (ignore named)) (let* ((slot-name (boot-slot-name slot)) (slot-type (boot-slot-type slot)) (read-only (boot-slot-read-only slot)) (offset (boot-slot-offset slot)) (access-function (intern (si:string-concatenate (string conc-name) (string slot-name)))) accsrs dont-overwrite) (unless (boot-slot-accessor-name slot) (setf (boot-slot-accessor-name slot) access-function)) (ecase type ((nil) (setf accsrs *accessors*)) (list (setf accsrs *list-accessors*)) (vector (setf accsrs *vector-accessors*))) (or (> (length accsrs) offset) (adjust-array accsrs (+ offset 10))) (unless dont-overwrite (record-fn access-function 'defun '(t) slot-type) (or no-fun (and (fboundp access-function) (eq (aref accsrs offset) (symbol-function access-function))) (setf (symbol-function access-function) (or (aref accsrs offset) (setf (aref accsrs offset) (cond ((eq accsrs *accessors*) #'(lambda (x) (or (structurep x) (error "~a is not a structure" x)) (structure-ref1 x offset))) ((eq accsrs *list-accessors*) #'(lambda(x) (si:list-nth offset x))) ((eq accsrs *vector-accessors*) #'(lambda(x) (aref x offset))))))))) (cond (read-only (remprop access-function 'structure-access) (setf (get access-function 'struct-read-only) t)) (t (remprop access-function 'setf-update-fn) (remprop access-function 'setf-lambda) (remprop access-function 'setf-documentation) (let ((tem (get access-function 'structure-access))) (cond ((and (consp tem) include (if (consp (get include 's-data)) (boot-subtypep include (car tem)) (subtypep include (car tem))) (eql (cdr tem) offset)) ;; don't change overwrite accessor of subtype. (setq dont-overwrite t) ) (t (setf (get access-function 'structure-access) (cons (if type type name) offset))))))) nil)) @s] ****Change:(orig (80 89 c)) @s[ (cond ((null x) ;; If the slot-description is NIL, ;; it is in the padding of initial-offset. nil) @s, (t (car x)))) @s| (or (boot-slot-name x) (and (boot-slot-default-init x) ;; If the slot name is NIL, ;; it is the structure name. ;; This is for typed structures with names. (list 'quote (boot-slot-default-init x))))) @s] ****Change:(orig (94 97 c)) @s[ (cond ((null x) nil) ((null (car x)) nil) ((null (cadr x)) (list (car x))) (t (list (list (car x) (cadr x)))))) @s| (when (boot-slot-name x) (if (boot-slot-default-init x) (list (list (boot-slot-name x) (boot-slot-default-init x))) (list (boot-slot-name x))))) @s] ****Change:(orig (248 248 d)) @s[ ((error "~S is an illegal structure type" type))))) @s| ((error "~S is an illegal structure type" type))))) @s] ****Change:(orig (252 265 d)) @s[ (defun make-copier (name copier type named) (declare (ignore named)) (cond ((null type) @s, ((error "~S is an illegal structure type." type)))) @s| @s] ****Change:(orig (267 275 c)) @s[ (cond ((null type) ;; If TYPE is NIL, the predicate searches the link ;; of structure-include, until there is no included structure. `(defun ,predicate (x) @s, (setq n (get n 'structure-include)))))) @s| (cond ((null type)) ; done in define-structure @s] ****Change:(orig (282 283 c)) @s[ (> (length x) ,name-offset) (eq (elt x ,name-offset) ',name)))) @s| (> (the fixnum (length x)) ,name-offset) (eq (aref (the (vector t) x) ,name-offset) ',name)))) @s] ****Change:(orig (294 294 a)) @s[ ((= i 0) (and (consp y) (eq (car y) ',name))) @s| ((= i 0) (and (consp y) (eq (car y) ',name))) (declare (fixnum i)) @s] ****Change:(orig (300 301 c)) @s[;;; and returns a list of the form: ;;; (slot-name default-init slot-type read-only offset) @s|;;; and returns a slot. @s] ****Change:(orig (325 325 c)) @s[ (list slot-name default-init slot-type read-only offset))) @s| (make-slot-boot :name slot-name :default-init default-init :type slot-type :read-only read-only :offset offset))) @s] ****Change:(orig (335 335 c)) @s[ (let ((sds (member (caar olds) news :key #'car))) @s| (let* ((old (car olds)) (sds (member (boot-slot-name old) news :key #'slot-name)) (new (car sds))) @s] ****Change:(orig (337 348 c)) @s[ (when (and (null (cadddr (car sds))) (cadddr (car olds))) ;; If read-only is true in the old ;; and false in the new, signal an error. @s, (car (cddddr (car olds)))) @s| (when (and (null (boot-slot-read-only new)) (boot-slot-read-only old)) ;; If read-only is true in the old ;; and false in the new, signal an error. (error "~S is an illegal include slot-description." new)) ;; If (setf (boot-slot-type new) (best-array-element-type (boot-slot-type new))) (when (not (equal (normalize-type (or (boot-slot-type new) t)) (normalize-type (or (boot-slot-type old) t)))) (error "Type mismmatch for included slot ~a" new)) (cons (make-slot :name (boot-slot-name new) :default-init (boot-slot-default-init new) :type (boot-slot-type new) :read-only (boot-slot-read-only new) :offset (boot-slot-offset old)) @s] ****Change:(orig (353 353 a)) @s[ (overwrite-slot-descriptions news (cdr olds)))))))) @s| (overwrite-slot-descriptions news (cdr olds)))))))) (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t)) @s] ****Change:(orig (355 355 c)) @s[;;; The DEFSTRUCT macro. @s|(defun make-t-type (n include slot-descriptions &aux i) (let ((res (make-array n :element-type 'unsigned-char :static t))) (when include (let ((tem (get include 's-data))raw) (or tem (error "Included structure undefined ~a" include)) (setq raw (boot-s-data-raw tem)) (dotimes (i (min n (length raw))) (setf (aref res i) (aref raw i))))) (dolist (v slot-descriptions) (setq i (boot-slot-offset v)) (let ((type (boot-slot-type v))) (cond ((<= (the fixnum (alignment type)) #. (alignment t)) (setf (aref res i) (aet-type type)))))) (cond ((< n (length *all-t-s-type*)) (dotimes (i n) (cond ((not (eql (the fixnum (aref res i)) 0)) (return-from make-t-type res)))) *all-t-s-type*) (t res)))) @s] ****Change:(orig (356 356 a)) @s[ @s| (defvar *standard-slot-positions* (let ((ar (make-array 50 :element-type 'unsigned-short :static t))) (dotimes (i 50) (declare (fixnum i)) (setf (aref ar i)(* #. (size-of t) i))) ar)) (eval-when (compile ) (proclaim '(function round-up (fixnum fixnum ) fixnum)) ) (defun round-up (a b) (declare (fixnum a b)) (setq a (ceiling a b)) (the fixnum (* a b))) (defun get-slot-pos (leng include slot-descriptions &aux type small-types has-holes) (declare (special *standard-slot-positions*)) include (dolist (v slot-descriptions) (when (boot-slot-name v) (setf type (best-array-element-type (boot-slot-type v)) (boot-slot-type v) type) (let ((val (boot-slot-default-init v))) (unless (typep val type) (if (and (symbolp val) (constantp val)) (setf val (symbol-value val))) (and (constantp val) (setf (boot-slot-default-init v) (coerce val type))))) (cond ((memq type '(signed-char unsigned-char short unsigned-short long-float bit)) (setq small-types t))))) (cond ((and (null small-types) (< leng (length *standard-slot-positions*)) (list *standard-slot-positions* (* leng #. (size-of t)) nil))) (t (let ((ar (make-array leng :element-type 'unsigned-short :static t)) (pos 0)(i 0)(align 0)type (next-pos 0)) (declare (fixnum pos i align next-pos)) ;; A default array. (dolist (v slot-descriptions) (setq type (boot-slot-type v)) (setq align (alignment type)) (unless (<= align #. (alignment t)) (setq type t) (setf (boot-slot-type v) t) (setq align #. (alignment t)) (setf (boot-slot-type-changed v) t)) (setq next-pos (round-up pos align)) (or (eql pos next-pos) (setq has-holes t)) (setq pos next-pos) (setf (aref ar i) pos) (incf pos (size-of type)) (incf i)) (list ar (round-up pos (size-of t)) has-holes) )))) (defun define-structure (name conc-name type named slot-descriptions copier static include print-function constructors offset predicate &optional documentation no-funs &aux leng) (and (consp type) (eq (car type) 'vector)(setq type 'vector)) (setq leng (length slot-descriptions)) (setq slot-descriptions (mapcar #'(lambda (info) (make-slot-boot :name (first info) :default-init (second info) :type (third info) :read-only (fourth info) :offset (fifth info) :accessor-name (sixth info) :type-changed (seventh info))) slot-descriptions)) (dolist (x slot-descriptions) (when (boot-slot-name x) (make-access-function name conc-name type named include no-funs x))) (when (and copier (not no-funs)) (setf (symbol-function copier) (ecase type ((nil) #'si::copy-structure) (list #'copy-list) (vector #'copy-seq)))) (let ((include-str (and include (get include 's-data)))) (when (and (eq include 's-data-internal) (not (eq name 'basic-wrapper))) (error "only ~s can include ~s" 'basic-wrapper 's-data-internal)) (when include-str (cond ((and (not (consp include-str)) (s-data-frozen include-str) (or (not (s-data-included include-str)) (not (let ((te (get name 's-data))) (and te (eq (s-data-includes te) include-str)))))) (warn " ~a was frozen but now included" include))) (let ((old-included (boot-slot-value include-str 'included))) (unless (member name old-included) (boot-set-slot-value include-str 'included (cons name old-included))))) (let* ((tem (get name 's-data)) (g-s-p (and (null type) (get-slot-pos leng include slot-descriptions))) (slot-position (car g-s-p)) (size (if g-s-p (cadr g-s-p) 0)) (has-holes (caddr g-s-p)) (def (make-s-data-boot :name name :length leng :raw (and (null type) (make-t-type leng include slot-descriptions)) :slot-position slot-position :size size :has-holes has-holes :staticp static :includes include-str :print-function print-function :slot-descriptions slot-descriptions :constructors constructors :offset offset :type type :named named :documentation documentation :conc-name conc-name))) (check-s-data tem def name) (when (and (consp def) (eq name 's-data)) (make-structures def)))) (when documentation (setf (get name 'structure-documentation) documentation)) (when (and (null type) predicate) (record-fn predicate 'defun '(t) t) (or no-funs (setf (symbol-function predicate) #'(lambda (x) (si::structure-subtype-p x name)))) (setf (get predicate 'compiler::co1) 'compiler::co1structure-predicate) (setf (get predicate 'struct-predicate) name)) nil) (defun check-s-data (old new name) (unless (and old (member name '(slot s-data-internal basic-wrapper s-data))) (when (and old (eq (structure-def old) (get 's-data 's-data))) (boot-set-slot-value new 'included (boot-slot-value old 'included)) (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen))) (unless (and old (eq (structure-def old) (get 's-data 's-data)) (let ((new-cnv (boot-slot-value new 'cache-number-vector)) (old-cnv (boot-slot-value old 'cache-number-vector))) (boot-set-slot-value new 'cache-number-vector old-cnv) (prog1 (equalp new old) (boot-set-slot-value new 'cache-number-vector new-cnv)))) (when old (warn "structure ~a is changing" name) (when (eq (structure-def old) (get 's-data 's-data)) (boot-set-slot-value old 'state (list ':obsolete new)))) (setf (get name 's-data) new)))) @s] ****Change:(orig (364 364 c)) @s[ predicate predicate-specified include @s| predicate predicate-specified include include-s-data @s] ****Change:(orig (367 367 c)) @s[ offset name-offset documentation) @s| offset name-offset documentation static) @s] ****Change:(orig (370 370 c)) @s[ ;; The defstruct options are supplied. @s| ;; The defstruct options are supplied. @s] ****Change:(orig (390 425 c)) @s[ (cond ((and (consp (car os)) (not (endp (cdar os)))) (setq o (caar os) v (cadar os)) (case o (:conc-name @s, (t (error "~S is an illegal defstruct option." o)))))) @s| (cond ((and (consp (car os)) (not (endp (cdar os)))) (setq o (caar os) v (cadar os)) (case o (:conc-name (if (null v) (setq conc-name "") (setq conc-name v))) (:constructor (if (null v) (setq no-constructor t) (if (endp (cddar os)) (setq constructors (cons v constructors)) (setq constructors (cons (cdar os) constructors))))) (:copier (setq copier v)) (:static (setq static v)) (:predicate (setq predicate v) (setq predicate-specified t)) (:include (setq include (cdar os)) (unless (setq include-s-data (get v 's-data)) (error "~S is an illegal included structure." v))) (:print-function (and (consp v) (eq (car v) 'function) (setq v (second v))) (setq print-function v)) (:type (setq type v)) (:initial-offset (setq initial-offset v)) (t (error "~S is an illegal defstruct option." o)))) (t (if (consp (car os)) (setq o (caar os)) (setq o (car os))) (case o (:constructor (setq constructors (cons default-constructor constructors))) ((:conc-name :copier :predicate :print-function)) (:named (setq named t)) (t (error "~S is an illegal defstruct option." o)))))) @s] ****Change:(orig (426 426 a)) @s[ @s| (setq conc-name (intern (string conc-name))) (and include-s-data (not print-function) (setq print-function (boot-s-data-print-function include-s-data))) @s] ****Change:(orig (434 435 c)) @s[ (when include (unless (equal type (get (car include) 'structure-type)) @s| (when include-s-data (unless (equal type (boot-s-data-type include-s-data)) @s] ****Change:(orig (442 443 c)) @s[ (t (setq offset (get (car include) 'structure-offset)))) @s| (t (setq offset (boot-s-data-offset include-s-data)))) @s] ****Change:(orig (457 458 c)) @s[ (setq sds (cons (parse-slot-description (car ds) offset) sds)) (setq offset (1+ offset))) @s| (setq sds (cons (parse-slot-description (car ds) offset) sds)) (setq offset (1+ offset))) @s] ****Change:(orig (464 464 c)) @s[ (cons (list nil name) slot-descriptions))) @s| (cons (make-slot :default-init name) slot-descriptions))) @s] ****Change:(orig (469 469 c)) @s[ (append (make-list initial-offset) slot-descriptions))) @s| (append (mapcar #'make-named-slot (make-list initial-offset)) slot-descriptions))) @s] ****Change:(orig (473 486 c)) @s[ (cond ((null include)) ((endp (cdr include)) (setq slot-descriptions (append (get (car include) 'structure-slot-descriptions) @s, slot-descriptions)))) @s| (let ((include-slot-descriptions (and include (boot-s-data-slot-descriptions include-s-data)))) (cond ((null include)) ((endp (cdr include)) (setq slot-descriptions (append include-slot-descriptions slot-descriptions))) (t (setq slot-descriptions (append (overwrite-slot-descriptions (mapcar #'(lambda (sd) (parse-slot-description sd 0)) (cdr include)) include-slot-descriptions) slot-descriptions))))) @s] ****Change:(orig (489 492 c)) @s[ ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors (error "Contradictory constructor options."))) @s| ;; If a constructor option is NIL, ;; no constructor should have been specified. (when constructors (error "Contradictory constructor options."))) @s] ****Change:(orig (494 495 c)) @s[ ;; If no constructor is specified, ;; the default-constructor is made. @s| ;; If no constructor is specified, ;; the default-constructor is made. @s] ****Change:(orig (497 497 a)) @s[ (setq constructors (list default-constructor)))) @s| (setq constructors (list default-constructor)))) ;; We need a default constructor for the sharp-s-reader (or (member t (mapcar 'symbolp constructors)) (push (intern (string-concatenate "__si::" default-constructor)) constructors)) @s] ****Change:(orig (509 509 c)) @s[ (error "An print function is supplied to a typed structure.")) @s| (error "A print function is supplied to a typed structure.")) `(progn (define-structure ',name ',conc-name ',type ',named ',(mapcar #'(lambda (slotd) (list (boot-slot-name slotd) (boot-slot-default-init slotd) (boot-slot-type slotd) (boot-slot-read-only slotd) (boot-slot-offset slotd) (boot-slot-accessor-name slotd) (boot-slot-type-changed slotd))) slot-descriptions) ',copier ',static ',include ',print-function ',constructors ',offset ',predicate ',documentation) @s] ****Change:(orig (511 542 c)) @s[ `(progn (si:putprop ',name '(defstruct ,name ,@slots) 'defstruct-form) (si:putprop ',name t 'is-a-structure) @s, (si:putprop ',name ,documentation 'structure-documentation) ',name))) @s| ,@(mapcar #'(lambda (constructor) (make-constructor name constructor type named slot-descriptions)) constructors) ,@(if (and type predicate) (list (make-predicate name predicate type named name-offset))) ',name ))) @s] ****Change:(orig (544 544 a)) @s[ @s| (eval-when (compile load eval) (defconstant wrapper-cache-number-adds-ok 4) (defconstant wrapper-cache-number-length (- (integer-length most-positive-fixnum) wrapper-cache-number-adds-ok)) (defconstant wrapper-cache-number-mask (1- (expt 2 wrapper-cache-number-length))) (defvar *get-wrapper-cache-number* (make-random-state)) (defun get-wrapper-cache-number () (let ((n 0)) (declare (fixnum n)) (loop (setq n (logand wrapper-cache-number-mask (random most-positive-fixnum *get-wrapper-cache-number*))) (unless (zerop n) (return n))))) ) (eval-when (compile load eval) (defconstant wrapper-cache-number-vector-length 8) (deftype cache-number-vector () `(simple-array fixnum (8))) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) ) (defun make-wrapper-cache-number-vector () (let ((cnv (make-array #.wrapper-cache-number-vector-length :element-type 'fixnum))) (dotimes (i #.wrapper-cache-number-vector-length) (setf (aref cnv i) (get-wrapper-cache-number))) cnv)) (defstruct (slot (:static t) (:constructor make-slot) (:constructor make-named-slot (name))) name default-init (type t) read-only offset accessor-name type-changed) ;; All of the fields of s-data-internal must coincide with ;; the C structure s_data (see object.h). (defstruct (s-data-internal (:conc-name s-data-) (:constructor nil) (:static t)) ;; all of these slots are used by c code name ; a symbol (length 0 :type fixnum) ; length of slot-descriptions raw ; a static array of unsigned-short (enum aelttype) included ; a list of the names of structures including this one includes ; nil or a s-data structure staticp ; t or nil print-function ; nil, a symbol, or a lambda expression slot-descriptions ; a list of slots slot-position ; a static array of unsigned-short (size 0 :type fixnum) ; total size to allocate has-holes) ; t or nil (defstruct (basic-wrapper (:include s-data-internal) (:conc-name wrapper-) (:constructor nil) (:static t)) (cache-number-vector (make-wrapper-cache-number-vector)) (state t) ; either t or a list (state-sym new-wrapper) ;; where state-sym is either :flush or :obsolete (class nil)) ;(get name 'si::s-data) ;returns one of these: (defstruct (s-data (:include basic-wrapper) (:static t)) ;; these slots are used only from lisp frozen ; t or nil ; t means won't include this documentation constructors ; a list of either a symbol or a list symbol, arglist offset ; the total number of slots and placeholders named ; t or nil type ; one of: nil, list, or vector conc-name) ; an interned symbol #|| (import '(si::wrapper-state si::wrapper-class si::basic-wrapper)) (defstruct (wrapper (:include basic-wrapper) (:print-function print-wrapper) (:constructor make-wrapper-internal) (:predicate wrapper-p) (:conc-name wrapper-)) (class-slots nil :type list)) (defun print-wrapper (instance stream depth) (printing-random-thing (wrapper stream) (format stream "Wrapper ~S" (wrapper-class wrapper)))) ||# (defun update-wrapper-state (old new same-p) (unless (consp old) (setf (wrapper-state old) (list (if same-p ':flush ':obsolete) new)))) (defun freeze-defstruct (name) (let ((tem (and (symbolp name) (get name 's-data)))) (if tem (setf (s-data-frozen tem) t)))) @s] ****Change:(orig (551 553 c)) @s[ (let ((l (read stream))) (unless (get (car l) 'is-a-structure) (error "~S is not a structure." (car l))) @s| (let* ((l (prog1 (read stream t nil t) (if *read-suppress* (return-from sharp-s-reader nil)))) (sd (or (get (car l) 's-data) (error "~S is not a structure." (car l))))) @s] ****Change:(orig (558 558 c)) @s[ (do ((cs (get (car l) 'structure-constructors) (cdr cs))) @s| (do ((cs (s-data-constructors sd) (cdr cs))) @s] ****Change:(orig (571 571 d)) @s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader) @s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader) @s] ****Change:(orig (582 582 c)) @s[(defstruct person name age sex) @s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char) sex) (defstruct person1 name (age 20 :type fixnum) sex) @s] ****Change:(orig (584 584 c)) @s[(defstruct (astronaut (:include person (age 45)) @s|(defstruct joe a (a1 0 :type (mod 30)) (a2 0 :type (mod 30)) (a3 0 :type (mod 30)) (a4 0 :type (mod 30)) ) ;(defstruct person name age sex) (defstruct (astronaut (:include person (age 45 :type fixnum)) @s] ****Change:(orig (605 605 a)) @s[ associative identity) @s| associative identity) @s] ============================================================================== gcl/pcl/impl/kcl/makefile.akcl0000644000175000017500000000146712240167764015161 0ustar cammcamm# makefile for making pcl -- W. Schelter. # Directions: # make -f makefile.akcl compile # make -f makefile.akcl saved_pcl SHELL=/bin/sh LISP=akcl SETUP='(load "pkg.lisp")(load "defsys.lisp")' \ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ '(load "sys-proclaim.lisp")(compiler::emit-fn t)' compile: echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} saved_pcl: echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} # remake the sys-package.lisp and sys-proclaim.lisp files # Those files may be empty on a first build. remake-sys-files: echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} cp sys-proclaim.lisp xxx cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp clean: rm -f *.o gcl/pcl/impl/kcl/kcl-notes.text0000644000175000017500000000352512240167764015352 0ustar cammcamm Some notes on using "5/1/90 May Day PCL (REV 4b)" with KCL and AKCL. 1. KCL will try to load the PCL file "init" when it starts up, if you rename the files as is mentioned in defsys.lisp and the currect directory is the one containing PCL. I suggest that you do not rename any file except maybe "defsys", and also that you change the (files-renamed-p t) to (files-renamed-p nil) in defsys.lisp. 2. Do not comment out the file kcl-patches.lisp, even if you are using AKCL. It contins a patch to make compiler messages more informative for AKCL, and also sets compiler::*compile-ordinaries* to T, so that methods will get compiled. 3. While fixup.lisp compiles, there will be a pause, because KCL's compiler is not reentrant, and some uncompiled code is run. If you want, you can change the form (fix-early-generic-functions) to (fix-early-generic-functions t) in fixup.lisp to see what is happening. 4. (If you are using AKCL 605 or newer, skip this step.) If you want, you can apply the changes in kcl-mods.text to your KCL or AKCL to make PCL run faster. The file kcl-mods.text is different from what it was in versions of PCL earlier than May Day PCL. If you do not make these changes, or if you made the old changes, things will still work. 5. If you are using AKCL, and you previously used the kcl-low.lisp file from rascal.ics.utexas.edu, you should not use it this time. The kcl-low.lisp that comes with May Day PCL works fine. (If you insist on using an old version of kcl-low.lisp, you will need to use an old version of the KCL part of fin.lisp as well: this is what is done for IBCL, by the way.) 6. I recommend that you use AKCL version 457 or newer rather than using KCL or an older version of AKCL, because there are some bugs in KCL that cause problems for May Day PCL. gcl/pcl/impl/kcl/kcl-mods.text0000644000175000017500000002052712240167764015165 0ustar cammcammIf you have akcl version 604 or newer, do not make these patches. (1) Turbo closure patch To make the turbo closure stuff work, make the following changes to KCL. These changes can also work for an IBCL. The three patches in this file add two features (reflected in the value of *features*) to your KCL or IBCL: a feature named :TURBO-CLOSURE which increases the speed of the code generated by FUNCALLABLE-INSTANCE-DATA-1 (previous versions of the file kcl-mods.text had this feature only), and a feature named :TURBO-CLOSURE-ENV-SIZE which increases the speed of the function FUNCALLABLE-INSTANCE-P. (This file comprises two features rather than just one to allow the PCL system to be work in KCL systems that do not have this patch, or that have the old version of this patch.) The first of these patches changes the turbo_closure function to store the size of the environment in the turbo structure. The second of patch fixes a garbage-collector bug in which the turbo structure was sometimes ignored, AND also adapts the garbage-collector to conform to the change made in the first patch. The bug has been fixed in newer versions of AKCL, but it is still necessary to apply this patch, if the first and third patches are applied. The third change pushes :turbo-closure and :turbo-closure-env-size on the *features* list so that PCL will know that turbo closures are enabled. Note that these changes have to be made before PCL is compiled, and a PCL which is compiled in a KCL/IBCL with these changes can only be run in a KCL/IBCL with these changes. (1-1) edit the function turbo_closure in the file kcl/c/cfun.c, change the lines ---------- turbo_closure(fun) object fun; { object l; int n; for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) ; fun->cc.cc_turbo = (object *)alloc_contblock(n*sizeof(object)); for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) fun->cc.cc_turbo[n] = l; } ---------- to ---------- turbo_closure(fun) object fun; { object l,*block; int n; if(fun->cc.cc_turbo==NULL) {for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr); block=(object *)alloc_contblock((1+n)*sizeof(object)); *block=make_fixnum(n); fun->cc.cc_turbo = block+1; /* equivalent to &block[1] */ for (n = 0, l = fun->cc.cc_env; !endp(l); n++, l = l->c.c_cdr) fun->cc.cc_turbo[n] = l;} } ---------- (1-2) edit the function mark_object in the file kcl/c/gbc.c, Find the lines following case t_cclosure: in mark_object. If they look like the ones between the lines marked (KCL), make the first change, but if the look like the lines marked (AKCL), apply the second change instead, and if the file sgbc.c exists, apply the third change to it. (1-2-1) Change: (KCL)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (x->cc.cc_start == NULL) break; if (what_to_collect == t_contiguous) { if (get_mark_bit((int *)(x->cc.cc_start))) break; mark_contblock(x->cc.cc_start, x->cc.cc_size); if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (KCL)---------- to (KCL new)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) if (x->cc.cc_turbo != NULL) { mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } if (x->cc.cc_start == NULL) break; if (what_to_collect == t_contiguous) { if (get_mark_bit((int *)(x->cc.cc_start))) break; mark_contblock(x->cc.cc_start, x->cc.cc_size); } break; (KCL new)---------- (1-2-2) Or, Change: (AKCL)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (AKCL)---------- To: (AKCL new)---------- case t_cclosure: mark_object(x->cc.cc_name); mark_object(x->cc.cc_env); mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } break; (AKCL new)---------- (1-2-3) In sgbc.c (if it exists), Change: (AKCL)---------- case t_cclosure: sgc_mark_object(x->cc.cc_name); sgc_mark_object(x->cc.cc_env); sgc_mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) { for (i = 0, y = x->cc.cc_env; type_of(y) == t_cons; i++, y = y->c.c_cdr); mark_contblock((char *)(x->cc.cc_turbo), i*sizeof(object)); } } break; (AKCL)---------- To: (AKCL new)---------- case t_cclosure: sgc_mark_object(x->cc.cc_name); sgc_mark_object(x->cc.cc_env); sgc_mark_object(x->cc.cc_data); if (what_to_collect == t_contiguous) { if (x->cc.cc_turbo != NULL) mark_contblock((char *)(x->cc.cc_turbo-1), (1+fix(*(x->cc.cc_turbo-1)))*sizeof(object)); } break; (AKCL new)---------- (1-3) edit the function init_main in the file kcl/c/main.c, change the lines where setting the value of *features* to add a :turbo-closure and a :turbo-closure-env-size into the list in your KCL/IBCL. For example, in Sun4(SunOS) version of IBCL changing the lines: ---------- make_special("*FEATURES*", make_cons(make_ordinary("SUN4"), make_cons(make_ordinary("SPARC"), make_cons(make_ordinary("IEEE-FLOATING-POINT"), make_cons(make_ordinary("UNIX"), make_cons(make_ordinary("BSD"), make_cons(make_ordinary("COMMON"), make_cons(make_ordinary("IBCL"), Cnil)))))))); ---------- to ---------- make_special("*FEATURES*", make_cons(make_ordinary("SUN4"), make_cons(make_ordinary("SPARC"), make_cons(make_ordinary("IEEE-FLOATING-POINT"), make_cons(make_ordinary("UNIX"), make_cons(make_ordinary("BSD"), make_cons(make_ordinary("COMMON"), make_cons(make_ordinary("IBCL"), make_cons(make_keyword("TURBO-CLOSURE"), make_cons(make_keyword("TURBO-CLOSURE-ENV-SIZE"), Cnil)))))))))); ---------- But, if the C macro ADD_FEATURE is defined at the end of main.c, use it instead. Insert the lines: ADD_FEATURE("TURBO-CLOSURE"); ADD_FEATURE("TURBO-CLOSURE-ENV-SIZE"); After the line: ADD_FEATURE("AKCL"); gcl/pcl/impl/kcl/sysdef.lisp0000644000175000017500000001011712240167764014726 0ustar cammcamm;;; -*- Mode: Lisp; Base: 10; Syntax: Common-Lisp; Package: DSYS -*- ;;; File: sysdef.lisp ;;; Author: Richard Harris (in-package "DSYS") (defvar *pcl-compiled-p* nil) (defvar *pcl-loaded-p* nil) (unless (boundp 'pcl::*redefined-functions*) (setq pcl::*redefined-functions* nil)) (defun reset-pcl-package () (pcl::reset-pcl-package) (let ((defsys (subfile '("pcl") :name "defsys"))) (setq pcl::*pcl-directory* defsys) (load-file defsys)) (mapc #'(lambda (path) (setf (lfi-fwd (get-loaded-file-info path)) 0)) (pcl-binary-files))) (defun pcl-binary-files () (pcl::system-binary-files 'pcl::pcl)) (defun maybe-load-defsys (&optional compile-defsys-p) (let ((defsys (subfile '("pcl") :name "defsys")) (*use-default-pathname-type* nil) (*skip-load-if-loaded-p* t) (*skip-compile-file-fwd* 0)) (set 'pcl::*pcl-directory* defsys) (when compile-defsys-p (compile-file defsys)) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) #+ignore (reset-pcl-package))) (load-file defsys))) (defun maybe-load-pcl (&optional force-p) (unless (and (null force-p) (fboundp 'pcl::system-binary-files) (every #'(lambda (path) (let* ((path-fwd (file-write-date path)) (lfi (get-loaded-file-info path))) (and lfi path-fwd (= path-fwd (lfi-fwd lfi))))) (pcl-binary-files))) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) (reset-pcl-package))) (pcl::load-pcl))) (defsystem pcl (:pretty-name "PCL") #+akcl (:forms :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp"))) (unless (probe-file cfn) (run-unix-command (format nil "ln -s ~A ~A" (namestring (merge-pathnames "../cmpnew/collectfn.lsp" si::*system-directory*)) (namestring cfn)))))) #+akcl "collectfn" (:forms :compile (progn (maybe-load-defsys t) (if (and (fboundp 'pcl::operation-transformations) (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp"))) (every #'(lambda (trans) (eq (car trans) :load)) (pcl::operation-transformations 'pcl::pcl :compile)))) (maybe-load-pcl) (let ((b-s 'pcl::*boot-state*)) (when (and (boundp b-s) (symbol-value b-s)) (reset-pcl-package)) #+akcl (compiler::emit-fn t) #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" si::*system-directory*)) (#+cmu with-compilation-unit #-cmu progn #+cmu (:optimize '(optimize (user::debug-info #+(and small (not testing)) .5 #-(and small (not testing)) 2) (speed #+testing 1 #-testing 2) (safety #+testing 3 #-testing 0) #+ignore (user::inhibit-warnings 2)) :context-declarations '(#+ignore (:external (declare (user::optimize-interface (safety 2) (debug-info 1)))))) (proclaim #+testing *testing-declaration* #-testing *fast-declaration*) (pcl::compile-pcl)) (reset-pcl-package) (maybe-load-pcl t))) #+cmu (purify)) :load (progn (maybe-load-pcl) #+cmu (purify)))) (defparameter *pcl-files* '((("systems") "lisp" "pcl") (("pcl") "lisp" "sysdef" "boot" "braid" "cache" "cloe-low" "cmu-low" "combin" "compat" "construct" "coral-low" "cpatch" "cpl" "ctypes" "defclass" "defcombin" "defs" "defsys" "dfun" "dlap" "env" "excl-low" "fin" "fixup" "fngen" "fsc" "gcl-patches" "genera-low" "gold-low" "hp-low" "ibcl-low" "ibcl-patches" "init" "iterate" "kcl-low" "kcl-patches" "lap" "low" "lucid-low" "macros" "methods" "pcl-env-internal" "pcl-env" "pkg" "plap" "precom1" "precom2" "precom4" "pyr-low" "pyr-patches" "quadlap" "rel-7-2-patches" "rel-8-patches" "slots" "std-class" "sys-proclaim" "ti-low" "ti-patches" "vaxl-low" "vector" "walk" "xerox-low" "xerox-patches") (("pcl") "text" "12-7-88-notes" "3-17-88-notes" "3-19-87-notes" "4-21-87-notes" "4-29-87-notes" "5-22-87-notes" "5-22-89-notes" "8-28-88-notes" "get-pcl" "kcl-mods" "kcl-notes" "lap" "notes" "pcl-env" "readme"))) gcl/pcl/impl/xerox/0000755000175000017500000000000012240167764013134 5ustar cammcammgcl/pcl/impl/xerox/xerox-low.lisp0000644000175000017500000001357312240167764016002 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 1100 (Xerox version) of the file portable-low. ;;; (in-package 'pcl) (defmacro load-time-eval (form) `(il:LOADTIMECONSTANT ,form)) ;;; ;;; make the pointer from an instance to its class wrapper be an xpointer. ;;; this prevents instance creation from spending a lot of time incrementing ;;; the large refcount of the class-wrapper. This is safe because there will ;;; always be some other pointer to the wrapper to keep it around. ;;; #+Xerox-Medley (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor %%allocate-instance--class ()) (:fast-accessors t) (:print-function %print-std-instance)) (wrapper nil :type il:fullxpointer) (slots nil)) #+Xerox-Lyric (eval-when (eval load compile) (il:datatype std-instance ((wrapper il:fullxpointer) slots)) (xcl:definline std-instance-p (x) (typep x 'std-instance)) (xcl:definline %%allocate-instance--class () (il:create std-instance)) (xcl:definline %std-instance-wrapper (x) (il:fetch (std-instance wrapper) il:of x)) (xcl:definline %std-instance-slots (x) (il:fetch (std-instance slots) il:of x)) (xcl:definline set-%std-instance-wrapper (x value) (il:replace (std-instance wrapper) il:of x il:with value)) (xcl:definline set-%std-instance-slots (x value) (il:replace (std-instance slots) il:of x il:with value)) (defsetf %std-instance-wrapper set-%std-instance-wrapper) (defsetf %std-instance-slots set-%std-instance-slots) (il:defprint 'std-instance '%print-std-instance) ) (defun %print-std-instance (instance &optional stream depth) ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is ;; not correct. In particular, it makes no mention of the third argument. (cond ((streamp stream) ;; Use the standard PCL printing method, then return T to tell ;; the printer that we have done the printing ourselves. (print-std-instance instance stream depth) t) (t ;; Internal printing (again, see the IRM section 25.3.3). ;; Return a list containing the string of characters that ;; would be printed, if the object were being printed for ;; real. (list (with-output-to-string (stream) (print-std-instance instance stream depth)))))) ;; ;;;;;; FUNCTION-ARGLIST ;; (defun function-arglist (x) ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and ;; strings instead of symbols. How silly. (let ((arglist (il:arglist x))) (when (symbolp arglist) ;; This could be due to trying to extract the arglist of an interpreted ;; function (though why that should be hard is beyond me). On the other ;; hand, if the function is compiled, it helps to ask for the "smart" ;; arglist. (setq arglist (if (consp (symbol-function x)) (second (symbol-function x)) (il:arglist x t)))) (if (symbolp arglist) ;; Probably never get here, but just in case (list '&rest 'rest) ;; Make sure there are no strings where there should be symbols (if (some #'stringp arglist) (mapcar #'(lambda (a) (if (symbolp a) a (intern a))) arglist) arglist)))) (defun printing-random-thing-internal (thing stream) (let ((*print-base* 8)) (princ (il:\\hiloc thing) stream) (princ "," stream) (princ (il:\\loloc thing) stream))) (defun record-definition (name type &optional parent-name parent-type) (declare (ignore type parent-name)) ()) ;;; ;;; FIN uses this too! ;;; (eval-when (compile load eval) (il:datatype il:compiled-closure (il:fnheader il:environment)) (il:blockrecord closure-overlay ((funcallable-instance-p il:flag))) ) (defun compiled-closure-fnheader (compiled-closure) (il:fetch (il:compiled-closure il:fnheader) il:of compiled-closure)) (defun set-compiled-closure-fnheader (compiled-closure nv) (il:replace (il:compiled-closure il:fnheader) il:of compiled-closure nv)) (defsetf compiled-closure-fnheader set-compiled-closure-fnheader) ;;; ;;; In Lyric, and until the format of FNHEADER changes, getting the name from ;;; a compiled closure looks like this: ;;; ;;; (fetchfield '(nil 4 pointer) ;;; (fetch (compiled-closure fnheader) closure)) ;;; ;;; Of course this is completely non-robust, but it will work for now. This ;;; is not the place to go into a long tyrade about what is wrong with having ;;; record package definitions go away when you ship the sysout; there isn't ;;; enough diskspace. ;;; (defun set-function-name-1 (fn new-name uninterned-name) (cond ((typep fn 'il:compiled-closure) (il:\\rplptr (compiled-closure-fnheader fn) 4 new-name) (when (and (consp uninterned-name) (eq (car uninterned-name) 'method)) (let ((debug (si::compiled-function-debugging-info fn))) (when debug (setf (cdr debug) uninterned-name))))) (t nil)) fn) gcl/pcl/impl/xerox/pcl-env.lisp0000644000175000017500000017341612240167764015405 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.com) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Xerox-Lisp specific environment hacking for PCL (in-package "PCL") ;; ;; Protect the Corporation ;; (eval-when (eval load) (format *terminal-io* "~&;PCL-ENV Copyright (c) 1987, 1988, 1989, by ~ Xerox Corporation. All rights reserved.~%")) ;;; Make funcallable instances (FINs) print by calling print-object. (eval-when (eval load) (il:defprint 'il:compiled-closure 'il:print-closure)) (defun il:print-closure (x &optional stream depth) ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is ;; not correct. In particular, it makes no mention of the third argument. (cond ((not (funcallable-instance-p x)) ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for ;; printing closures (il:\\cclosure.defprint x stream)) ((streamp stream) ;; Use the standard PCL printing method, then return T to tell ;; the printer that we have done the printing ourselves. (print-object x stream) t) (t ;; Internal printing (again, see the IRM section 25.3.3). ;; Return a list containing the string of characters that ;; would be printed, if the object were being printed for ;; real. (with-output-to-string (stream) (list (print-object x stream)))))) ;;; Naming methods (defun gf-named (gf-name) (let ((spec (cond ((symbolp gf-name) gf-name) ((and (consp gf-name) (eq (first gf-name) 'setf) (symbolp (second gf-name)) (null (cddr gf-name))) (get-setf-function-name (second gf-name))) (t nil)))) (if (and (fboundp spec) (generic-function-p (symbol-function spec))) (symbol-function spec) nil))) (defun generic-function-method-names (gf-name hasdefp) (if hasdefp (let ((names nil)) (maphash #'(lambda (key value) (declare (ignore value)) (when (and (consp key) (eql (car key) gf-name)) (pushnew key names))) (gethash 'methods xcl:*definition-hash-table*)) names) (let ((gf (gf-named gf-name))) (when gf (mapcar #'full-method-name (generic-function-methods gf)))))) (defun full-method-name (method) "Return the full name of the method" (let ((specializers (mapcar #'(lambda (x) (cond ((eq x 't) t) ((consp x) x) (t (class-name x)))) (method-type-specifiers method)))) ;; Now go through some hair to make sure that specializer is ;; really right. Once PCL returns the right value for ;; specializers this can be taken out. (let* ((arglist (method-arglist method)) (number-required (or (position-if #'(lambda (x) (member x lambda-list-keywords)) arglist) (length arglist))) (diff (- number-required (length specializers)))) (when (> diff 0) (setq specializers (nconc (copy-list specializers) (make-list diff :initial-element 't))))) (make-full-method-name (generic-function-name (method-generic-function method)) (method-qualifiers method) specializers))) (defun make-full-method-name (generic-function-name qualifiers arg-types) "Return the full name of a method, given the generic-function name, the method qualifiers, and the arg-types" ;; The name of the method is: ;; ( .. ;; (..)) (labels ((remove-trailing-ts (l) (if (null l) nil (let ((tail (remove-trailing-ts (cdr l)))) (if (null tail) (if (eq (car l) 't) nil (list (car l))) (if (eq l tail) l (cons (car l) tail))))))) `(,generic-function-name ,@qualifiers ,(remove-trailing-ts arg-types)))) (defun parse-full-method-name (method-name) "Parse the method name, returning the gf-name, the qualifiers, and the arg-types." (values (first method-name) (butlast (rest method-name)) (car (last method-name)))) (defun prompt-for-full-method-name (gf-name &optional has-def-p) "Prompt the user for the full name of a method on the given generic function name" (let ((method-names (generic-function-method-names gf-name has-def-p))) (cond ((null method-names) nil) ((null (cdr method-names)) (car method-names)) (t (il:menu (il:create il:menu il:items il:_ ;If HAS-DEF-P, include only ; those methods that have a ; symbolic def'n that we can ; find (remove-if #'null (mapcar #'(lambda (m) (if (or (not has-def-p) (il:hasdef m 'methods)) `(,(with-output-to-string (s) (dolist (x m) (format s "~A " x)) s) ',m) nil)) method-names)) il:title il:_ "Which method?")))))) ;;; Converting generic defining macros into DEFDEFINER macros (defmacro make-defdefiner (definer-name definer-type type-description &body definer-options) "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE" (let ((old-definer-macro-name (intern (string-append definer-name " old definition") (symbol-package definer-name))) (old-definer-macro-expander (intern (string-append definer-name " old expander") (symbol-package definer-name)))) `(progn ;; First, move the current defining function off to some safe ;; place (unmake-defdefiner ',definer-name) (cond ((not (fboundp ',definer-name)) (error "~A has no definition!" ',definer-name)) ((fboundp ',old-definer-macro-name)) ((macro-function ',definer-name) ; We have to move the macro ; expansion function as well, ; so it won't get clobbered ; when the original macro is ; redefined. See AR 7410. (let* ((expansion-function (macro-function ',definer-name))) (setf (symbol-function ',old-definer-macro-expander) (loop (if (symbolp expansion-function) (setq expansion-function (symbol-function expansion-function)) (return expansion-function)))) (setf (macro-function ',old-definer-macro-name) ',old-definer-macro-expander) (setf (get ',definer-name 'make-defdefiner) expansion-function))) (t (error "~A does not name a macro." ',definer-name))) ;; Make sure the type is defined (xcl:def-define-type ,definer-type ,type-description) ;; Now redefine the definer, using DEFEDFINER and the original def'n (xcl:defdefiner ,(if definer-options (cons definer-name definer-options) definer-name) ,definer-type (&body b) `(,',old-definer-macro-name ,@,'b))))) (defun unmake-defdefiner (definer-name) (let ((old-expander (get definer-name 'make-defdefiner))) (when old-expander (setf (macro-function definer-name old-expander)) (remprop definer-name 'make-defdefiner)))) ;;; For tricking ED into being able to use just the generic-function-name ;;; instead of the full method name (defun source-manager-method-edit-fn (name type source editcoms options) "Edit a method of the given name" (let ((full-name (if (gf-named name) ;If given the name of a ; generic-function, try to get ; the full method name (prompt-for-full-method-name name t) ; Otherwise it should name the ; method name))) (when (not (null full-name)) (il:default.editdef full-name type source editcoms options)) (or full-name name))) ;Return the name (defun source-manager-method-hasdef-fn (name type &optional source) "Is there a method defined with the given name?" (cond ((not (eq type 'methods)) nil) ((or (symbolp name) (and (consp name) (eq (first name) 'setf) (symbolp (second name)) (null (cddr name)))) ;; If passed in the name of a generic-function, pretend that ;; there is a method by that name if there is a generic function ;; by that name, and there is a method whose source we can find. (if (and (not (null (gf-named name))) (find-if #'(lambda (m) (il:hasdef m type source)) (generic-function-method-names name t))) name nil)) ((and (consp name) (>= (length name) 2)) ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*)) (when (il:getdef name type source '(il:nocopy il:noerror)) name)) (t ;; Nothing else can name a method nil))) ;;; Initialize the PCL env (defun initialize-pcl-env nil "Initialize the Xerox PCL environment" ;; Set up SourceManager DEFDEFINERS for classes and methods. ;; ;; Make sure to define methods before classes, so that (IL:FILES?) will build ;; filecoms that have classes before methods. (unless (il:hasdef 'methods 'il:filepkgtype) (make-defdefiner defmethod methods "methods" (:name (lambda (form) (multiple-value-bind (name qualifiers arglist) (parse-defmethod (cdr form)) (make-full-method-name name qualifiers (extract-specializer-names arglist))))) (:undefiner (lambda (method-name) (multiple-value-bind (name qualifiers arg-types) (parse-full-method-name method-name) (let* ((gf (gf-named name)) (method (when gf (get-method gf qualifiers (mapcar #'find-class arg-types))))) (when method (remove-method gf method)))))))) ;; Include support for DEFGENERIC, if that is defined (unless (or (not (fboundp 'defgeneric)) (il:hasdef 'generic-functions 'il:filepkgtype)) (make-defdefiner defgeneric generic-functions "generic-function definitions")) ;; DEFCLASS FileManager stuff (unless (il:hasdef 'classes 'il:filepkgtype) (make-defdefiner defclass classes "class definitions" (:undefiner (lambda (name) (when (find-class name t) (setf (find-class name) nil))))) ;; CLASSES "include" TYPES. (il:filepkgcom 'classes 'il:contents #'(lambda (com name type &optional reason) (declare (ignore name reason)) (if (member type '(il:types classes) :test #'eq) (cdr com) nil)))) ;; Set up the hooks so that ED can be handed the name of a generic function, ;; and end up editing a method instead (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn 'il:hasdef 'source-manager-method-hasdef-fn) ;; Set up the inspect macro. The right way to do this is to ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now... (push '((il:function pcl-object-p) . \\internal-inspect-object) il:inspectmacros) ;; Unmark any SourceManager changes caused by this loadup (dolist (com (il:filepkgchanges)) (dolist (name (cdr com)) (when (and (symbolp name) (eq (symbol-package name) (find-package "PCL"))) (il:unmarkaschanged name (car com)))))) (eval-when (eval load) (initialize-pcl-env)) ;;; Inspecting PCL objects (defun pcl-object-p (x) "Is the datum a PCL object?" (or (std-instance-p x) (fsc-instance-p x))) (defun \\internal-inspect-object (x type where) (inspect-object x type where)) (defun \\internal-inspect-slot-names (x) (inspect-slot-names x)) (defun \\internal-inspect-slot-value (x slot-name) (inspect-slot-value x slot-name)) (defun \\internal-inspect-setf-slot-value (x slot-name value) (inspect-setf-slot-value x slot-name value)) (defun \\internal-inspect-slot-name-command (slot-name x window) (inspect-slot-name-command slot-name x window)) (defun \\internal-inspect-title (x y) (inspect-title x y)) (defmethod inspect-object (x type where) "Open an insect window on the object x" (il:inspectw.create x '\\internal-inspect-slot-names '\\internal-inspect-slot-value '\\internal-inspect-setf-slot-value '\\internal-inspect-slot-name-command nil nil '\\internal-inspect-title nil where #'(lambda (n v) ;Same effect as NIL, but avoids bug in (declare (ignore v)) ; INSPECTW.CREATE n))) (defmethod inspect-slot-names (x) "Return a list of names of slots of the object that should be shown in the inspector" (mapcar #'(lambda (slotd) (slot-value slotd 'name)) (slots-to-inspect (class-of x) x))) (defmethod inspect-slot-value (x slot-name) (cond ((not (slot-exists-p x slot-name)) "** no such slot **") ((not (slot-boundp x slot-name)) "** slot not bound **") (t (slot-value x slot-name)))) (defmethod inspect-setf-slot-value (x slot-name value) "Used by the inspector to set the value fo a slot" ;; Make this UNDO-able (il:undosave `(inspect-setf-slot-value ,x ,slot-name ,(slot-value x slot-name))) ;; Then change the value (setf (slot-value x slot-name) value)) (defmethod inspect-slot-name-command (slot-name x window) "Allows the user to select a menu item to change a slot value in an inspect window" ;; This code is a very slightly hacked version of the system function ;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the ;; standard version makes some nasty assumptions about ;; structure-objects that are not true for PCL objects. (declare (special il:|SetPropertyMenu|)) (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu) il:|SetPropertyMenu|) (t (il:setq il:|SetPropertyMenu| (il:|create| il:menu il:items il:_ '((set 'set "Allows a new value to be entered" ))))))) (set ;; The user want to set the value (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name window)) il:newvalue il:pwindow) (il:ttydisplaystream (il:setq il:pwindow (il:getpromptwindow window 3))) (il:clearbuf t t) (il:resetlst (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window) (list 'il:\\itemw.flipitem il:oldvalueitem window)) (il:resetsave (il:tty.process (il:this.process))) (il:resetsave (il:printlevel 4 3)) (il:|printout| t "Enter the new " slot-name " for " x t "The expression read will be EVALuated." t "> ") (il:setq il:newvalue (il:lispx (il:lispxread t t) '>)) ; clear tty buffer because it ; sometimes has stuff left. (il:clearbuf t t)) (il:closew il:pwindow) (return (il:inspectw.replace window slot-name il:newvalue))))))) (defmethod inspect-title (x window) "Return the title to use in an inspect window viewing x" (format nil "Inspecting a ~A" (class-name (class-of x)))) (defmethod inspect-title ((x standard-class) window) (format nil "Inspecting the class ~A" (class-name x))) ;;; Debugger support for PCL (il:filesload pcl-env-internal) ;; Non-PCL specific changes to the debugger ;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be ;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP ;; property. (dolist (fn '(si::*unwind-protect* il:*env* evalhook xcl::nohook xcl::undohook xcl::execa0001 xcl::execa0001a0002 xcl::|interpret-UNDOABLY| cl::|interpret-IF| cl::|interpret-FLET| cl::|interpret-LET| cl::|interpret-LETA0001| cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001| il:do-event il:eval-input apply t)) (setf (get fn 'xcl::uninterestingp) t)) (defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg) "Return TRUE iff the frame should be visible for a short backtrace." (declare (special il:openfns)) (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos))) (typecase xcl::name (symbol (case xcl::name (il:*env* ;; *ENV* is used by ENVEVAL etc. nil) (il:errorset (or (<= (il:stknargs xcl::pos) 1) (not (eq (il:stkarg 2 xcl::pos nil) 'il:internal)))) (il:eval (or (<= (il:stknargs xcl::pos) 1) (not (eq (il:stkarg 2 xcl::pos nil) 'xcl::internal)))) (il:apply (or (<= (il:stknargs xcl::pos) 2) (not (il:stkarg 3 xcl::pos nil)))) (otherwise (cond ((get xcl::name 'xcl::uninterestingp) ;; Explicitly declared uninteresting. nil) ((eq (il:chcon1 xcl::name) (char-code #\\)) ;; Implicitly declared uninteresting by starting the ;; name with a "\". nil) ((or (member xcl::name il:openfns :test #'eq) (eq xcl::name 'funcall)) ;;The function won't be seen when compiled, so only show ;;it if INTERPFLG it true xcl::interpflg) (t ;; Interesting by default. t))))) (cons (case (car xcl::name) (:broken t) (otherwise nil))) (otherwise nil)))) (setq il:*short-backtrace-filter* 'xcl::interesting-frame-p) (eval-when (eval compile) (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))) ;; Change the frame inspector to open up lexical environments ;; Since the DEFSTRUCT is going to build the accessors in the package that is ;; current at read-time, and we want the accessors to reside in the IL ;; package, we have got to make sure that the defstruct happens when the ;; package is IL. (in-package "IL") (cl:defstruct (frame-prop-name (:type cl:list)) (label-fn 'nill) (value-fn (function (lambda (prop-name framespec) (frame-prop-name-data prop-name)))) (setf-fn 'nill) (inspect-fn (function (lambda (value prop-name framespec window) (default.inspectw.valuecommandfn value prop-name (car framespec) window)))) (data nil)) (cl:in-package "PCL") (defun il:debugger-stack-frame-prop-names (il:framespec) ;; Frame prop-names are structures of the form ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA) (let ((il:pos (car il:framespec)) (il:backtrace-item (cadr il:framespec))) (il:if (eq 'eval (il:stkname il:pos)) il:then (let ((il:expression (il:stkarg 1 il:pos)) (il:environment (il:stkarg 2 il:pos))) `(,(il:make-frame-prop-name :inspect-fn (il:function (il:lambda (il:value il:prop-name il:framespec il:window) (il:inspect/as/function il:value (car il:framespec) il:window))) :data il:expression) ,(il:make-frame-prop-name :data "ENVIRONMENT") ,@(il:for il:aspect il:in `((,(and il:environment (il:environment-vars il:environment)) "vars") (,(and il:environment (il:environment-functions il:environment)) "functions") (,(and il:environment (il:environment-blocks il:environment)) "blocks") (,(and il:environment (il:environment-tagbodies il:environment)) "tag bodies")) il:bind il:group-name il:p-list il:eachtime (il:setq il:group-name (cadr il:aspect)) (il:setq il:p-list (car il:aspect)) il:when (not (null il:p-list)) il:join `(,(il:make-frame-prop-name :data il:group-name) ,@(il:for il:p il:on il:p-list il:by cddr il:collect (il:make-frame-prop-name :label-fn (il:function (il:lambda (il:prop-name il:framespec) (car (il:frame-prop-name-data il:prop-name)))) :value-fn (il:function (il:lambda (il:prop-name il:framespec) (cadr (il:frame-prop-name-data il:prop-name)))) :setf-fn (il:function (il:lambda (il:prop-name il:framespec il:new-value) (il:change (cadr (il:frame-prop-name-data il:prop-name)) il:new-value))) :data il:p)))))) il:else (flet ((il:build-name (&key il:arg-name il:arg-number) (il:make-frame-prop-name :label-fn (il:function (il:lambda (il:prop-name il:framespec) (car (il:frame-prop-name-data il:prop-name)))) :value-fn (il:function (il:lambda (il:prop-name il:framespec) (il:stkarg (cadr (il:frame-prop-name-data il:prop-name)) (car il:framespec)))) :setf-fn (il:function (il:lambda (il:prop-name il:framespec il:new-value) (il:setstkarg (cadr (il:frame-prop-name-data il:prop-name)) (car il:framespec) il:new-value))) :data (list il:arg-name il:arg-number)))) (let ((il:nargs (il:stknargs il:pos t)) (il:nargs1 (il:stknargs il:pos)) (il:fnname (il:stkname il:pos)) il:argname (il:arglist)) (and (il:litatom il:fnname) (il:ccodep il:fnname) (il:setq il:arglist (il:listp (il:smartarglist il:fnname)))) `(,(il:make-frame-prop-name :inspect-fn (il:function (il:lambda (il:value il:prop-name il:framespec il:window) (il:inspect/as/function il:value (car il:framespec) il:window))) :data (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item)) ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist)) lambda-list-keywords) il:do (il:setq il:mode il:argname)) (il:build-name :arg-name (or (il:stkargname il:i il:pos) ; special (if (case il:mode ((nil &optional) il:argname) (t nil)) (string il:argname) (il:concat "arg " (- il:i 1)))) :arg-number il:i))) ,@(let* ((il:novalue "No value") (il:slots (il:for il:pvar il:from 0 il:as il:i il:from (il:add1 il:nargs1) il:to il:nargs il:by 1 il:when (and (il:neq il:novalue (il:stkarg il:i il:pos il:novalue)) (or (il:setq il:argname (il:stkargname il:i il:pos)) (il:setq il:argname (il:concat "local " il:pvar))) ) il:collect (il:build-name :arg-name il:argname :arg-number il:i)))) (and il:slots (cons (il:make-frame-prop-name :data "locals") il:slots))))))))) (defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name) (il:apply* (il:frame-prop-name-value-fn il:prop-name) il:prop-name il:framespec)) (defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue) (il:apply* (il:frame-prop-name-setf-fn il:prop-name) il:prop-name il:framespec il:newvalue)) (defun il:debugger-stack-frame-value-command (il:datum il:prop-name il:framespec il:window) (il:apply* (il:frame-prop-name-inspect-fn il:prop-name) il:datum il:prop-name il:framespec il:window)) (defun il:debugger-stack-frame-title (il:framespec &optional il:window) (declare (ignore il:window)) (il:concat (il:stkname (car il:framespec)) " Frame")) (defun il:debugger-stack-frame-property (il:prop-name il:framespec) (il:apply* (il:frame-prop-name-label-fn il:prop-name) il:prop-name il:framespec)) ;; Teaching the debugger that there are other file-manager types that can ;; appear on the stack (defvar xcl::*function-types* '(il:fns il:functions) "Manager types that can appear on the stack") ;; Redefine a couple of system functions to use the above stuff #+Xerox-Lyric (progn (defun il:attach-backtrace-menu (&optional (il:ttywindow (il:wfromds (il:ttydisplaystream))) il:skip) (let ((il:bkmenu (il:|create| il:menu il:items il:_ (il:collect-backtrace-items il:ttywindow il:skip) il:whenselectedfn il:_ (il:function il:backtrace-item-selected) il:whenheldfn il:_ #'(il:lambda (il:item il:menu il:button) (declare (ignore il:item il:menu)) (case il:button (il:left (il:promptprint "Open a frame inspector on this stack frame" )) (il:middle (il:promptprint "Inspect/Edit this function")) )) il:menuoutlinesize il:_ 0 il:menufont il:_ il:backtracefont il:menucolumns il:_ 1)) (il:ttyregion (il:windowprop il:ttywindow 'il:region)) il:btw) (cond ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow) il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu)) (eql (il:|fetch| (il:menu il:whenselectedfn) il:|of| (car il:btw)) (il:function il:backtrace-item-selected))) il:|do| (return il:atw))) (il:deletemenu (car (il:windowprop il:btw 'il:menu)) nil il:btw) (il:windowprop il:btw 'il:extent nil) (il:clearw il:btw)) ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region) (il:widthifwindow (il:imin (il:|fetch| (il:menu il:imagewidth ) il:|of| il:bkmenu) il:|MaxBkMenuWidth|)) (il:|fetch| (il:region il:height) il:|of| il:ttyregion ) 'il:left))) (il:attachwindow il:btw il:ttywindow (cond ((il:igreaterp (il:|fetch| (il:region il:left) il:|of| (il:windowprop il:btw 'il:region)) (il:|fetch| (il:region il:left) il:|of| il:ttyregion)) 'il:right) (t 'il:left)) nil 'il:localclose) (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process)) )) (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position il:xcoord il:_ 0 il:ycoord il:_ (il:idifference (il:windowprop il:btw 'il:height) (il:|fetch| (il:menu il:imageheight ) il:|of| il:bkmenu )))))) (defun il:backtrace-item-selected (il:item il:menu il:button) (il:resetlst (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item) )) (cond ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu)) (il:menudeselect il:olditem il:menu) )) (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu) 'il:mainwindow)) (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position)) (il:setq il:pos (il:stknth (- il:framespecn) il:bkpos)) (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos))) (and il:lp (il:stknth 0 il:pos il:lp))) (il:menuselect il:item il:menu) (if (eq il:button 'il:middle) (progn (il:resetsave nil (list 'il:relstk il:pos)) (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name) il:|of| il:item) il:pos il:ttywindow)) (progn (il:setq il:framewindow (xcl:with-profile (il:process.eval (il:windowprop il:ttywindow 'il:process) '(let ((il:profile (xcl:copy-profile (xcl:find-profile "READ-PRINT")))) (setf (xcl::profile-entry-value ' xcl:*eval-function* il:profile) xcl:*eval-function*) (xcl:save-profile il:profile)) t) (il:inspectw.create (list il:pos il:item) 'il:debugger-stack-frame-prop-names 'il:debugger-stack-frame-fetchfn 'il:debugger-stack-frame-storefn nil ' il:debugger-stack-frame-value-command nil ' il:debugger-stack-frame-title nil ( il:make-frame-inspect-window il:ttywindow) 'il:debugger-stack-frame-property))) (cond ((not (il:windowprop il:framewindow 'il:mainwindow)) (il:attachwindow il:framewindow il:ttywindow (cond ((il:igreaterp (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop il:framewindow 'il:region)) (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop il:ttywindow 'il:region))) 'il:top) (t 'il:bottom)) nil 'il:localclose) (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow )))))) (return)))) (defun il:collect-backtrace-items (xcl::tty-window xcl::skip) (let* ((xcl::items (cons nil nil)) (xcl::items-tail xcl::items)) (macrolet ((xcl::collect-item (xcl::new-item) `(progn (setf (rest xcl::items-tail) (cons ,xcl::new-item nil)) (pop xcl::items-tail)))) (let* ((xcl::filter-fn (cond ((null xcl::skip) #'xcl:true) ((eq xcl::skip t) il:*short-backtrace-filter*) (t xcl::skip))) (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window ' il:stack-position))) (xcl::next-frame xcl::top-frame) (xcl::frame-number 0) xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) (loop (when (null xcl::next-frame) (return)) (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) (funcall xcl::filter-fn xcl::next-frame)) (when (null xcl::last-frame-consumed) (setf xcl::last-frame-consumed xcl::next-frame)) (when xcl::interesting-p (when (null xcl::use-frame) (setf xcl::use-frame xcl::last-frame-consumed)) (when (null xcl::label) (setf xcl::label (il:stkname xcl::use-frame)) (if (member xcl::label '(eval il:eval il:apply apply) :test 'eq) (setf xcl::label (il:stkarg 1 xcl::use-frame)))) (loop (cond ((not (typep xcl::next-frame 'il:stackp)) (error "~%Use-frame ~S not found" xcl::use-frame)) ((xcl::stack-eql xcl::next-frame xcl::use-frame) (return)) (t (incf xcl::frame-number) (setf xcl::next-frame (il:stknth -1 xcl::next-frame xcl::next-frame))))) (xcl::collect-item (il:|create| il:bkmenuitem il:label il:_ (let ((*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (prin1-to-string xcl::label)) il:bkmenuinfo il:_ xcl::frame-number il:frame-name il:_ xcl::label))) (loop (cond ((not (typep xcl::next-frame 'il:stackp)) (error "~%Last-frame-consumed ~S not found" xcl::last-frame-consumed)) ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed ) (incf xcl::frame-number) (setf xcl::next-frame (il:stknth -1 xcl::next-frame xcl::next-frame))) (return))))))) (rest xcl::items))) ) #+Xerox-Medley (progn (defun dbg::attach-backtrace-menu (&optional tty-window skip) (declare (special il:\\term.ofd il:backtracefont)) (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream)))) (prog (btw bkmenu (tty-region (il:windowprop tty-window 'il:region)) ;; And, for the FORMAT below... (*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (setq bkmenu (il:|create| il:menu il:items il:_ (dbg::collect-backtrace-items tty-window skip) il:whenselectedfn il:_ 'dbg::backtrace-item-selected il:menuoutlinesize il:_ 0 il:menufont il:_ il:backtracefont il:menucolumns il:_ 1 il:whenheldfn il:_ #'(il:lambda (item menu button) (declare (ignore item menu)) (case button (il:left (il:promptprint "Open a frame inspector on this stack frame")) (il:middle (il:promptprint "Inspect/Edit this function")))))) (cond ((setq btw (dolist (atw (il:attachedwindows tty-window)) ;; Test for an attached window that has a backtrace menu in ;; it. (when (and (setq btw (il:windowprop atw 'il:menu)) (eq (il:|fetch| (il:menu il:whenselectedfn) il:|of| (car btw)) 'dbg::backtrace-item-selected)) (return atw)))) ;; If there is alread a backtrace window, delete the old menu from ;; it. (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw) (il:windowprop btw 'il:extent nil) (il:clearw btw)) ((setq btw (il:createw (dbg::region-next-to (il:windowprop tty-window 'il:region) (il:widthifwindow (il:imin (il:|fetch| (il:menu il:imagewidth) il:|of| bkmenu) il:|MaxBkMenuWidth|)) (il:|fetch| (il:region il:height) il:|of| tty-region) :left))) ; put bt window at left of TTY ; window unless ttywindow is ; near left edge. (il:attachwindow btw tty-window (if (il:igreaterp (il:|fetch| (il:region il:left) il:|of| (il:windowprop btw 'il:region)) (il:|fetch| (il:region il:left) il:|of| tty-region)) 'il:right 'il:left) nil 'il:localclose) ;; So that button clicks will switch the TTY (il:windowprop btw 'il:process (il:windowprop tty-window 'il:process)))) (il:addmenu bkmenu btw (il:|create| il:position il:xcoord il:_ 0 il:ycoord il:_ (- (il:windowprop btw 'il:height) (il:|fetch| (il:menu il:imageheight) il:|of| bkmenu)))) ;; IL:ADDMENU sets up buttoneventfn for window that we don't ;; want. We want to catch middle button events before the menu ;; handler, so that we can pop up edit/inspect menu for the frame ;; currently selected. So replace the buttoneventfn, and can ;; nuke the cursorin and cursormoved guys, cause don't need them. (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn) (il:windowprop btw 'il:cursorinfn nil) (il:windowprop btw 'il:cursormovedfn nil))) (defun dbg::collect-backtrace-items (tty-window skip) (xcl:with-collection ;; ;; There are a number of possibilities for the values returned by the ;; filter-fn. ;; ;; (1) INTERESTING-P is false, and the other values are all NIL. This ;; is the simple case where the stack frame NEXT-POS should be ignored ;; completly, and processing should continue with the next frame. ;; ;; (2) INTERESTING-P is true, and the other values are all NIL. This ;; is the simple case where the stack frame NEXT-POS should appear in ;; the backtrace as is, and processing should continue with the next ;; frame. ;; ;; [Note that these two cases take care of old values of the ;; filter-fn.] ;; ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack ;; frame. In that case, ignore all stack frames from NEXT-POS to ;; LAST-FRAME-CONSUMED, inclusive. ;; ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack ;; frame. In this case, the backtrace should include a single entry ;; coresponding to the frame USE-FRAME (which defaults to ;; LAST-FRAME-CONSUMED), and processing should continue with the next ;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be ;; the label that appears in the backtrace menu; otherwise the name of ;; USE-FRAME will be used (or the form being EVALed if the frame is an ;; EVAL frame). ;; (let* ((filter (cond ((null skip) #'xcl:true) ((eq skip t) il:*short-backtrace-filter*) (t skip))) (top-frame (il:stknth 0 (il:getwindowprop tty-window 'dbg::stack-position))) (next-frame top-frame) (frame-number 0) interestingp last-frame-consumed frame-to-use label-to-use) (loop (when (null next-frame) (return)) ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED, ;; FRAME-TO-USE, and LABEL-TO-USE (multiple-value-setq (interestingp last-frame-consumed frame-to-use label-to-use) (funcall filter next-frame)) (when (null last-frame-consumed) (setf last-frame-consumed next-frame)) (when interestingp (when (null frame-to-use) (setf frame-to-use last-frame-consumed)) (when (null label-to-use) (setf label-to-use (il:stkname frame-to-use)) (if (member label-to-use '(eval il:eval il:apply apply) :test 'eq) (setf label-to-use (il:stkarg 1 frame-to-use)))) ;; Walk the stack until we find the frame to use (loop (cond ((not (typep next-frame 'il:stackp)) (error "~%Use-frame ~S not found" frame-to-use)) ((xcl::stack-eql next-frame frame-to-use) (return)) (t (incf frame-number) (setf next-frame (il:stknth -1 next-frame next-frame))))) ;; Add the menu item to the list under construction (xcl:collect (il:|create| il:bkmenuitem il:label il:_ (let ((*print-level* 2) (*print-length* 3) (*print-escape* t) (*print-gensym* t) (*print-pretty* nil) (*print-circle* nil) (*print-radix* 10) (*print-array* nil) (il:*print-structure* nil)) (prin1-to-string label-to-use)) il:bkmenuinfo il:_ frame-number il:frame-name il:_ label-to-use))) ;; Update NEXT-POS (loop (cond ((not (typep next-frame 'il:stackp)) (error "~%Last-frame-consumed ~S not found" last-frame-consumed)) ((prog1 (xcl::stack-eql next-frame last-frame-consumed) (incf frame-number) (setf next-frame (il:stknth -1 next-frame next-frame))) (return)))))))) (defun dbg::backtrace-menu-buttoneventfn (window &aux menu) (setq menu (car (il:listp (il:windowprop window 'il:menu)))) (unless (or (il:lastmousestate il:up) (null menu)) (il:totopw window) (cond ((il:lastmousestate il:middle) ;; look for a selected frame in this menu, and then pop up ;; the editor invoke menu for that frame. don't change the ;; selection, just present the edit menu. (let* ((selection (il:menu.handler menu (il:windowprop window 'il:dsp))) (tty-window (il:windowprop window 'il:mainwindow)) (last-pos (il:windowprop tty-window 'dbg::lastpos))) ;; don't have to worry about releasing POS because we ;; only look at it here (nobody here hangs on to it) ;; and we will be around for less time than LASTPOS. ;; The debugger is responsible for releasing LASTPOS. (il:inspect/as/function (cond ((and selection (il:|fetch| (il:bkmenuitem il:frame-name) il:|of| (car selection)))) ((and (symbolp (il:stkname last-pos)) (il:getd (il:stkname last-pos))) (il:stkname last-pos)) (t 'il:nill)) last-pos tty-window))) (t (let ((selection (il:menu.handler menu (il:windowprop window 'il:dsp)))) (when selection (il:doselecteditem menu (car selection) (cdr selection)))))))) ;; This function isn't really redefined, but it needs to be recomiled since we ;; changed the def'n of the BKMENUITEM record. (defun dbg::backtrace-item-selected (item menu button) ;;When a frame name is selected in the backtrace menu, this is the function ;;that gets called. (declare (special il:brkenv) (ignore button)) (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item)) (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow)) (bkpos (il:windowprop tty-window 'dbg::stack-position)) (pos (il:stknth (- frame-spec) bkpos))) (let ((lp (il:windowprop tty-window 'dbg::lastpos))) (and lp (il:stknth 0 pos lp))) ;; change the item selected from OLDITEM to ITEM. Only do this on left ;; buttons now. Middle just pops up the edit menu, doesn't select. -woz (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu))) (when old-item (il:menudeselect old-item menu)) (il:menuselect item menu)) ;; Change the lexical environment so it is the one in effect as of this ;; frame. (il:process.eval (il:windowprop tty-window (quote dbg::process)) `(setq il:brkenv ',(il:find-lexical-environment pos)) t) (let ((frame-window (xcl:with-profile (il:process.eval (il:windowprop tty-window 'il:process) `(let ((profile (xcl:copy-profile (xcl:find-profile "READ-PRINT")))) (setf (xcl::profile-entry-value 'xcl:*eval-function* profile) xcl:*eval-function*) (xcl:save-profile profile)) t) (il:inspectw.create pos #'(lambda (pos) (dbg::stack-frame-properties pos t)) 'dbg::stack-frame-fetchfn 'dbg::stack-frame-storefn nil 'dbg::stack-frame-value-command nil (format nil "~S Frame" (il:stkname pos)) nil (dbg::make-frame-inspect-window tty-window) 'dbg::stack-frame-property)))) (when (not (il:windowprop frame-window 'il:mainwindow)) (il:attachwindow frame-window tty-window (if (> (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop frame-window 'il:region)) (il:|fetch| (il:region il:bottom) il:|of| (il:windowprop tty-window 'il:region))) 'il:top 'il:bottom) nil 'il:localclose) (il:windowaddprop frame-window 'il:closefn 'il:detachwindow))))) ) ;end of Xerox-Medley (defun il:select.fns.editor (&optional function) ;; gives the user a menu choice of editors. (il:menu (il:|create| il:menu il:items il:_ (cond ((il:ccodep function) '((il:|InspectCode| 'il:inspectcode "Shows the compiled code.") (il:|DisplayEdit| 'ed "Edit it with the display editor") (il:|TtyEdit| 'il:ef "Edit it with the standard editor"))) ((il:closure-p function) '((il:|Inspect| 'inspect "Inspect this object"))) (t '((il:|DisplayEdit| 'ed "Edit it with the display editor") (il:|TtyEdit| 'il:ef "Edit it with the standard editor")))) il:centerflg il:_ t))) ;; ;; PCL specific extensions to the debugger ;; There are some new things that act as functions, and that we want to be ;; able to edit from a backtrace window (pushnew 'methods xcl::*function-types*) (eval-when (eval compile load) (unless (generic-function-p (symbol-function 'il:inspect/as/function)) (make-specializable 'il:inspect/as/function))) (defmethod il:inspect/as/function (name stack-pointer debugger-window) ;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer ;; and window of the break in which this inspect command was called. (declare (ignore debugger-window)) (let ((editor (il:select.fns.editor name))) (case editor ((nil) ;; No editor chosen, so don't do anything nil) (il:inspectcode ;; Inspect the compiled code (let ((frame (xcl::stack-pointer-frame stack-pointer))) (if (and (il:stackp stack-pointer) (xcl::stack-frame-valid-p frame)) (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame))) (cond ((eq (il:\\get-compiled-code-base name) code-base) name) (t ;; Function executing in this frame is not ;; the one in the definition cell of its ;; name, so fetch the real code. Have to ;; pass a CCODEP (il:make-compiled-closure code-base)))) nil nil nil (xcl::stack-frame-pc frame)) (il:inspectcode name)))) (ed ;; Use the standard editor. ;; This used to take care to apply the editor in the debugger ;; process, so forms evaluated in the editor happen in the ;; context of the break. But that doesn't count for much any ;; more, now that lexical variables are the way to go. Better to ;; use the LEX debugger command (thank you, Herbie) and ;; shift-select pieces of code from the editor into the debugger ;; window. (ed name `(,@xcl::*function-types* :display))) (otherwise (funcall editor name))))) (defmethod il:inspect/as/function ((name standard-object) stkp window) (when (il:menu (il:|create| il:menu il:items il:_ '(("Inspect" t "Inspect this object")))) (inspect name))) (defmethod il:inspect/as/function ((x standard-method) stkp window) (let* ((generic-function-name (slot-value (slot-value x 'generic-function) 'name)) (method-name (full-method-name x)) (editor (il:select.fns.editor method-name))) (il:allow.button.events) (case editor (ed (ed method-name '(:display methods))) (il:inspectcode (il:inspectcode (slot-value x 'function))) ((nil) nil) (otherwise (funcall editor method-name))))) ;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods ;; and generic-functions on the stack. (defun interesting-frame-p (stack-pos &optional interp-flag) ;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and ;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description ;; of how these values are used. (labels ((function-matches-frame-p (function frame) "Is the function being called in this frame?" (let* ((frame-name (il:stkname frame)) (code-being-run (cond ((typep frame-name 'il:closure) frame-name) ((and (consp frame-name) (eq 'il:\\interpreter (xcl::stack-frame-name (il:\\stackargptr frame)))) frame-name) (t (xcl::stack-frame-fn-header (il:\\stackargptr frame)))))) (or (eq function code-being-run) (and (typep function 'il:compiled-closure) (eq (xcl::compiled-closure-fnheader function) code-being-run))))) (generic-function-from-frame (frame) "If this the frame of a generic function return the gf, otherwise return NIL." ;; Generic functions are implemented as compiled closures. On the ;; stack, we only see the fnheader for the the closure. This could ;; be a discriminator code, or in the default method only case it ;; will be the actual method function. To tell if this is a generic ;; function frame, we have to check very carefully to see if the ;; right stuff is on the stack. Specifically, the closure's ccode, ;; and the first local variable has to be a ptrhunk big enough to be ;; a FIN environment, and fin-env-fin of that ptrhunk has to point ;; to a generic function whose ccode and environment match. (let ((n-args (il:stknargs frame)) (env nil) (gf nil)) (if (and ;; is there at least one local? (> (il:stknargs frame t) n-args) ;; and does the local contain something that might be ;; the closure environment of a funcallable instance? (setf env (il:stkarg (1+ n-args) frame)) ;; and does the local contain something that might be ;; the closure environment of a funcallable instance? (typep env *fin-env-type*) (setf gf (fin-env-fin env)) ;; whose fin-env-fin points to a generic function? (generic-function-p gf) ;; whose environment is the same as env? (eq (xcl::compiled-closure-env gf) env) ;; and whose code is the same as the code for this ;; frame? (function-matches-frame-p gf frame)) gf nil)))) (let ((frame-name (il:stkname stack-pos))) ;; See if there is a generic-function on the stack at this ;; location. (let ((gf (generic-function-from-frame stack-pos))) (when gf (return-from interesting-frame-p (values t stack-pos stack-pos gf)))) ;; See if this is an interpreted method. The method body is ;; wrapped in a (BLOCK ...). We look for an ;; interpreted call to BLOCK whose block-name is the name of ;; generic-function. (when (and (eq frame-name 'eval) (consp (il:stkarg 1 stack-pos)) (eq (first (il:stkarg 1 stack-pos)) 'block) (symbolp (second (il:stkarg 1 stack-pos))) (fboundp (second (il:stkarg 1 stack-pos))) (generic-function-p (symbol-function (second (il:stkarg 1 stack-pos))))) (let* ((form (il:stkarg 1 stack-pos)) (block-name (second form)) (generic-function (symbol-function block-name)) (methods (generic-function-methods (symbol-function block-name)))) ;; If this is really a method being called from a ;; generic-function, the g-f should be no more than a ;; few(?) frames up the stack. Check for the method call ;; by looking for a call to APPLY, where the function ;; being applied is the code in one of the methods. (do ((i 100 (1- i)) (previous-pos stack-pos current-pos) (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) (found-method nil) (method-pos)) ((or (null current-pos) (<= i 0)) nil) (cond ((equalp generic-function (generic-function-from-frame current-pos)) (if found-method (return-from interesting-frame-p (values t previous-pos method-pos found-method)) (return))) (found-method nil) ((eq (il:stkname current-pos) 'apply) (dolist (method methods) (when (eq (method-function method) (il:stkarg 1 current-pos)) (setq method-pos current-pos) (setq found-method method) (return)))))))) ;; Try to handle compiled methods (when (and (symbolp frame-name) (not (fboundp frame-name)) (eq (il:chcon1 frame-name) (il:charcode il:\()) (or (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 13) (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 12) (string-equal "(method " (symbol-name frame-name) :start2 0 :end2 8))) ;; Looks like a name that PCL consed up. See if there is a ;; GF nearby up the stack. If there is, use it to help ;; determine which method we have. (do ((i 30 (1- i)) (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) (gf)) ((or (null current-pos) (<= i 0)) nil) (setq gf (generic-function-from-frame current-pos)) (when gf (dolist (method (generic-function-methods gf)) (when (function-matches-frame-p (method-function method) stack-pos) (return-from interesting-frame-p (values t stack-pos stack-pos method)))) (return)))) ;; If we haven't already returned, use the default method. (xcl::interesting-frame-p stack-pos interp-flag)))) (setq il:*short-backtrace-filter* 'interesting-frame-p) ;;; Support for undo (defun undoable-setf-slot-value (object slot-name new-value) (if (slot-boundp object slot-name) (il:undosave (list 'undoable-setf-slot-value object slot-name (slot-value object slot-name))) (il:undosave (list 'slot-makunbound object slot-name))) (setf (slot-value object slot-name) new-value)) (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value) ;;; Support for ?= and friends ;; The arglists for generic-functions are built using gensyms, and don't reflect ;; any keywords (they are all included in an &REST arg). Rather then use the ;; arglist in the code, we use the one that PCL kindly keeps in the generic-function. (xcl:advise-function 'il:smartarglist '(if (and il:explainflg (symbolp il:fn) (fboundp il:fn) (generic-function-p (symbol-function il:fn))) (generic-function-pretty-arglist (symbol-function il:fn)) (xcl:inner)) :when :around :priority :last) (setf (get 'defclass 'il:argnames) '(nil (class-name (#\{ superclass-name #\} #\*) (#\{ slot-specifier #\} #\*) #\{ slot-option #\} #\*))) (setf (get 'defmethod 'il:argnames) '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\* specialized-lambda-list #\{ declaration #\| doc-string #\} #\* #\{ form #\} #\*))) ;;; Prettyprinting support, the result of Harley Davis. ;; Support the standard Prettyprinter. This is really minimal right now. If ;; anybody wants to fix this, I'd be happy to include their code. In fact, ;; there is almost no support for Commonlisp in the standard Prettyprinter, so ;; the field is wide open to hackers with time on their hands. (setf (get 'defmethod :definition-print-template) ;Not quite right, since it '(:name :arglist :body)) ; doesn't handle qualifiers, ; but it will have to do. (defun defclass-prettyprint (form) (let ((left (il:dspxposition)) (char-width (il:charwidth (il:charcode x) *standard-output*))) (xcl:destructuring-bind (defclass name supers slots . options) form (princ "(") (prin1 defclass) (princ " ") (prin1 name) (princ " ") (if (null supers) (princ "()") ;Print "()" instead of "nil" (il:sequential.prettyprint (list supers) (il:dspxposition))) (if (null slots) (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*) (princ "()")) (il:sequential.prettyprint (list slots) (+ left (* 4 char-width)))) (when options (il:sequential.prettyprint options (+ left (* 2 char-width)))) (princ ")") nil))) (let ((pprint-macro (assoc 'defclass il:prettyprintmacros))) (if (null pprint-macro) (push (cons 'defclass 'defclass-prettyprint) il:prettyprintmacros) (setf (cdr pprint-macro) 'defclass-prettyprint))) (defun binder-prettyprint (form) ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS ;; that are of the form (fn (var ...) form &rest body). ;; This code is far from correct, but it's better than nothing. (if (and (consp form) (not (null (cdddr form)))) ;; I have no idea what I'm doing here. Seems I can copy and edit somebody ;; elses code without understanding it. (let ((body-indent (+ (il:dspxposition) (* 2 (il:charwidth (il:charcode x) *standard-output*)))) (form-indent (+ (il:dspxposition) (* 4 (il:charwidth (il:charcode x) *standard-output*))))) (princ "(") (prin1 (first form)) (princ " ") (il:superprint (second form) form nil *standard-output*) (il:sequential.prettyprint (list (third form)) form-indent) (il:sequential.prettyprint (cdddr form) body-indent) (princ ")") nil) ;Return NIL to indicate that we did ; the printing t)) ;Return true to use default printing (dolist (fn '(multiple-value-bind with-accessors with-slots)) (let ((pprint-macro (assoc fn 'il:prettyprintmacros))) (if (null pprint-macro) (push (cons fn 'binder-prettyprint) il:prettyprintmacros) (setf (cdr pprint-macro) 'binder-prettyprint)))) ;; SEdit has its own prettyprinter, so we need to support that too. This is due ;; to Harley Davis. Really. (push (cons :slot-spec '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0) (sedit::set-indent . 1) (sedit::next-inline? 1 break sedit::from-indent . 1) (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0)) ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0) (sedit::set-indent . 1) (sedit::next-inline? 1 break sedit::from-indent . 1) (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) break sedit::from-indent . 0)))) sedit:*indent-alist*) (setf (sedit:get-format :slot-spec) '(:indent :slot-spec :inline t)) (setf (sedit:get-format :slot-spec-list) '(:indent :binding-list :args (:slot-spec) :inline nil)) (setf (sedit:get-format 'defclass) '(:indent ((2) 1) :args (:keyword nil nil :slot-spec-list nil) :sublists (4))) (setf (sedit:get-format 'defmethod) '(:indent ((2)) :args (:keyword nil :lambda-list nil) :sublists (3))) (setf (sedit:get-format 'defgeneric) 'defun) (setf (sedit:get-format 'generic-flet) 'flet) (setf (sedit:get-format 'generic-labels) 'flet) (setf (sedit:get-format 'call-next-method) '(:indent (1) :args (:keyword nil))) (setf (sedit:get-format 'symbol-macrolet) 'let) (setf (sedit:get-format 'with-accessors) '(:indent ((1) 1) :args (:keyword :binding-list nil) :sublists (2) :miser :never)) (setf (sedit:get-format 'with-slots) 'with-accessors) (setf (sedit:get-format 'make-instance) '(:indent ((1)) :args (:keyword nil :slot-spec-list))) (setf (sedit:get-format '*make-instance) 'make-instance) ;;; PrettyFileIndex stuff, the product of Harley Davis. (defvar *pfi-class-type* '(class defclass pfi-class-namer)) (defvar *pfi-method-type* '(method defmethod pfi-method-namer) "Handles method for prettyfileindex") (defvar *pfi-index-accessors* nil "t -> each slot accessor gets a listing in the index.") (defvar *pfi-method-index* :group ":group, :separate, :both, or nil") (defun pfi-add-class-type () (pushnew *pfi-class-type* il:*pfi-types*)) (defun pfi-add-method-type () (pushnew *pfi-method-type* il:*pfi-types*)) (defun pfi-class-namer (expression entry) (let ((class-name (second expression))) ;; Following adds all slot readers/writers/accessors as separate entries in ;; the index. Probably a mistake. (if *pfi-index-accessors* (let ((slot-list (fourth expression)) (accessor-names nil)) (labels ((add-accessor (method-index name-index) (push (case *pfi-method-index* (:group method-index) (:separate name-index) ((t :both) (list method-index name-index)) ((nil) nil) (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*))) accessor-names)) (add-reader (reader-name) (add-accessor `(method (,reader-name (,class-name))) `(,reader-name (,class-name)))) (add-writer (writer-name) (add-accessor `(method ((setf ,writer-name) (t ,class-name))) `((setf ,writer-name) (t ,class-name))))) (dolist (slot-def slot-list) (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args)) (slot-arg (first rest-slot-args) (first rest-slot-args))) ((null rest-slot-args)) (case slot-arg (:reader (add-reader (second rest-slot-args))) (:writer (add-writer (second rest-slot-args))) (:accessor (add-reader (second rest-slot-args)) (add-writer (second rest-slot-args))) (otherwise nil)))) (cons `(class (,class-name)) accessor-names))) class-name))) (defun pfi-method-namer (expression entry) (let ((method-name (second expression)) (specializers nil) (qualifiers nil) lambda-list) (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers)) (qualifier (first rest-qualifiers) (first rest-qualifiers))) ((listp qualifier) (setq lambda-list qualifier) (setq qualifiers (reverse qualifiers)) qualifiers) (push qualifier qualifiers)) (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list)) (arg (first rest-lambda-list) (first rest-lambda-list))) ((or (member arg lambda-list-keywords) (null rest-lambda-list)) (setq specializers (reverse specializers))) (push (if (listp arg) (second arg) t) specializers)) (let ((method-index `(method (,method-name ,@qualifiers ,specializers))) (name-index `(,method-name ,@qualifiers ,specializers))) (case *pfi-method-index* (:group method-index) (:separate name-index) ((t :both) (list method-index name-index)) ((nil) nil) (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*)))))) (defun pfi-install-pcl () (pfi-add-method-type) (pfi-add-class-type)) (eval-when (eval load) (when (boundp (quote il:*pfi-types*)) (pfi-install-pcl)) ) gcl/pcl/impl/xerox/pcl-env.text0000644000175000017500000001061512240167764015411 0ustar cammcammA (very) few words about PCL-ENV. If you require more information, consult the source code. While it is not particularly well documented, it is the final arbiter of truth regarding its own functionality. The file PCL-ENV.LISP defines some low-level facilities to integrate PCL into the XeroxLisp environment. The first order of business is teaching the FileManager (nee FilePackage) about CLOS defineing forms. This in turn brings us to the issue of names. o Names and the FileManager For the FileManager to keep track of defining forms, it needs to know how to extract a (unique) name and FileManager type from the form. PCL-ENV includes FileManager support for the definers DEFCLASS, DEFGENERIC, and DEFMETHOD. DEFCLASS The name of a DEFCLASS form is the name of the class defined by the form. The FileManager type is PCL::CLASSES. There is a FileManager "undefiner" provided for DEFCLASS. DEFGENERIC The name of a DEFGENERIC form is the name of the generic-function defined by the form. The FileManager type is PCL::GENERIC-FUNCTIONS. DEFMETHOD The name of a DEFMETHOD form is a list of the form ( {}* ({*})). The FileManager type is PCL::METHODS. There is a FileManager "undefiner" provided for DEFMETHOD. However, note that if a generic-function was created as a side-effect of the DEFMETHOD, the undefiner will leave the generic-function defined (albet with no methods). When editing, it would be onerous to require the programmer to type in the full name of a method. PCL-ENV arranges it so that (ED ) will ask the programmer which method on that generic-function should be edited. (If there is only one method, it is assumed that that is the method to be edited.) As of the Victoria-Day release, EQL specialized methods are handled correctly. o Inspecting CLOS objects (and metaobjects) PCL-ENV defines a protocol that is used to inspect objects, and arranges that the standard INSPECT function uses this protocol. Programmers can use this protocol by defining additional methods on the following generic-functions. INSPECT-SLOT-NAMES object Returns a list of "slots" to include in the inspector. The default method returns a list of all slots on the object. INSPECT-SLOT-VALUE object slot-name Returns the value to associated with the slot-name in the inspector. Slot-name is one of the items returned by INSPECT-SLOT-NAMES. The default method returns (SLOT-VALUE object slot-name). INSPECT-SETF-SLOT-VALUE object slot-name new-value Sets the value associated with the slot-name in the inspector. Slot-name is one of the items returned by INSPECT-SLOT-NAMES. The default method executes (SETF (SLOT-VALUE object slot-name) new-value). INSPECT-TITLE object inspect-window Returns the title to use in the inspect-window when inspecting object. The default returns the string "Inspecting the class " when the object is a class, or "Inspecting a " otherwise. o Debugging and the Stack Debugging in PCL is complicated by generic-functions and methods appear on the stack not as single objects, but as collections of functions that the programmer did not directly call. PCL-ENV redefines a number of internal debugger functions to simplify the presentation of the stack, and allow the programmer to access to the original defining forms from the stack. These changes only affect the "short" display backtrace (brought up by BT in a break window); the full backtrace (brought up by BT!) is unaffected. o Misc Prettyprinting The support for standard Prettyprinting is pretty minimal. Only DEFMETHOD, DEFCLASS, WITH-ACCESSORS, and WITH-SLOTS are supported, and they aren't really done right. Thanks to Harley Davis, PCL-ENV defines SEdit pretty-print specs for the forms DEFCLASS, DEFMETHOD, DEFGENERIC, GENERIC-FLET, GENERIC-LABELS, CALL-NEXT-METHOD, SYMBOL-MACROLET, WITH-ACCESSORS, WITH-SLOTS, and MAKE-INSTANCE. ?= The function SMARTARGLIST is changed to return appropriate values for the arglists of generic-functions. The macros DEFCLASS and DEFMETHOD have "pretty" arglists defined. PrettyFileIndex Again thanks to Harley Davis, PCL-ENV teaches PRETTY-FILE-INDEX about classes, methods, and accessors. The variables PCL::*PFI-INDEX-ACCESSORS* and PCL::*PFI-METHOD-INDEX* may be changed by the user to tailor the computation of the file index. Note that the file PRETTY-FILE-INDEX must be loaded before PCL-ENV for this to take effect. --- smL 25-May-89 gcl/pcl/impl/xerox/pcl-env-internal.lisp0000644000175000017500000002030112240167764017177 0ustar cammcamm(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL") (il:filecreated "28-Aug-87 18:42:36" il:{phylum}pcl-env-internal.\;1 8356 il:|changes| il:|to:| (il:vars il:pcl-env-internalcoms) (il:props (il:pcl-env-internal il:makefile-environment)) (il:functions stack-eql stack-pointer-frame stack-frame-valid-p stack-frame-fn-header stack-frame-pc fnheader-debugging-info stack-frame-name compiled-closure-fnheader compiled-closure-env) ) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (il:prettycomprint il:pcl-env-internalcoms) (il:rpaqq il:pcl-env-internalcoms ( (il:* il:|;;;| "***************************************") (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") (il:* il:|;;;| "") (il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.") (il:* il:|;;;| " ") (il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.") (il:* il:|;;;| " ") (il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:") (il:* il:|;;;| " CommonLoops Coordinator") (il:* il:|;;;| " Xerox Artifical Intelligence Systems") (il:* il:|;;;| " 2400 Hanover St.") (il:* il:|;;;| " Palo Alto, CA 94303") (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") (il:* il:|;;;| "") (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") (il:* il:|;;;| " *************************************************************************") (il:* il:|;;;| "") (il:declare\: il:dontcopy (il:prop il:makefile-environment il:pcl-env-internal)) (il:* il:\; "We're off to hack the system...") (il:declare\: il:eval@compile il:dontcopy (il:files pcl::abc) (il:* il:|;;| "The Deltas and The East and The Freeze") ) (il:functions stack-eql stack-pointer-frame stack-frame-valid-p stack-frame-fn-header stack-frame-pc fnheader-debugging-info stack-frame-name compiled-closure-fnheader compiled-closure-env))) (il:* il:|;;;| "***************************************") (il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") (il:* il:|;;;| "") (il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws." ) (il:* il:|;;;| " ") (il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification." ) (il:* il:|;;;| " ") (il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:" ) (il:* il:|;;;| " CommonLoops Coordinator") (il:* il:|;;;| " Xerox Artifical Intelligence Systems") (il:* il:|;;;| " 2400 Hanover St.") (il:* il:|;;;| " Palo Alto, CA 94303") (il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") (il:* il:|;;;| "") (il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") (il:* il:|;;;| " *************************************************************************") (il:* il:|;;;| "") (il:declare\: il:dontcopy (il:putprops il:pcl-env-internal il:makefile-environment (:package "XCL" :readtable "XCL")) ) (il:* il:\; "We're off to hack the system...") (il:declare\: il:eval@compile il:dontcopy (il:filesload pcl::abc) ) (defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x) (il:stackp y) (eql (il:fetch (il:stackp il:edfxp ) il:of x) (il:fetch (il:stackp il:edfxp ) il:of y)))) (defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer)) (defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame))) (defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame)) (defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame)) (defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc) il:of fnheader)) (name-table-words (let ((size (il:fetch (il:fnheader il:ntsize) il:of fnheader))) (if (zerop size) il:wordsperquad (* size 2)))) (past-name-table-in-words (+ (il:fetch (il:fnheader il:overheadwords ) il:of fnheader) name-table-words))) (and (= (- start-pc (* il:bytesperword past-name-table-in-words)) il:bytespercell) (il:* il:|;;| "It's got a debugging-info list.") (il:\\getbaseptr fnheader past-name-table-in-words)))) (defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame)) (defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of| closure)) (defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure)) (il:putprops il:pcl-env-internal il:copyright ("Xerox Corporation" 1987)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop gcl/pcl/impl/xerox/xerox-patches.lisp0000644000175000017500000002260412240167764016623 0ustar cammcamm;;; -*- Mode: Lisp; Package: XCL-USER; Base: 10.; Syntax: Common-Lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; (in-package "XCL-USER") ;;; Patch a bug with Lambda-substitution #+Xerox-Lyric (defun compiler::meta-call-lambda-substitute (node) (let* ((fn (compiler::call-fn node)) (var-list (compiler::lambda-required fn)) (spec-effects (il:for var il:in var-list il:unless (eq (compiler::variable-scope var) :lexical) il:collect (compiler::effects-representation var))) ;; Bind *SUBST-OCCURED* just so that META-SUBST-VAR-REF ahs a binding ;; to set even when nobody cares. (compiler::*subst-occurred* nil)) (il:for var il:in var-list il:as tail il:on (compiler::call-args node) il:when (and (eq (compiler::variable-scope var) :lexical) (compiler::substitutable-p (car tail) var) (dolist (compiler::spec-effect spec-effects t) (when (not (compiler::null-effects-intersection compiler::spec-effect (compiler::node-affected (car tail)))) (return nil))) (dolist (compiler::later-arg (cdr tail) t) (when (not (compiler::passable (car tail) compiler::later-arg)) (return nil)))) il:do (setf (compiler::lambda-body fn) (compiler::meta-substitute (car tail) var (compiler::lambda-body fn)))) (when (null (compiler::node-meta-p (compiler::lambda-body fn))) (setf (compiler::node-meta-p fn) nil) (setq compiler::*made-changes* t)))) ;;; Some simple optimizations missing from the compiler. ;; Shift by a constant. ;; Unfortunately, these cause the compiler to generate spurious warning ;; messages about "Unknown function IL:LLSH1 called from ..." It's not often ;; you come across a place where COMPILER-LET is really needed. #+Xerox-Lyric (progn (defvar *ignore-shift-by-constant-optimization* nil "Marker used for informing the shift-by-constant optimizers that they are in the shift function, and should not optimize.") (defun il:lrsh1 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:lrsh x 1))) (defun il:lrsh8 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:lrsh x 8))) (defun il:llsh1 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:llsh x 1))) (defun il:llsh8 (x) (compiler-let ((*ignore-shift-by-constant-optimization* t)) (il:llsh x 8))) (defoptimizer il:lrsh il:right-shift-by-constant (x n &environment env) (if (and (constantp n) (not *ignore-shift-by-constant-optimization*)) (let ((shift-factor (eval n))) (cond ((not (numberp shift-factor)) (error "Non-numeric arg to ~S, ~S" 'il:lrsh shift-factor)) ((= shift-factor 0) x) ((< shift-factor 0) `(il:llsh ,x ,(- shift-factor))) ((< shift-factor 8) `(il:lrsh (il:lrsh1 ,x) ,(1- shift-factor))) (t `(il:lrsh (il:lrsh8 ,x) ,(- shift-factor 8))))) 'compiler:pass)) (defoptimizer il:llsh il:left-shift-by-constant (x n &environment env) (if (and (constantp n) (not *ignore-shift-by-constant-optimization*)) (let ((shift-factor (eval n))) (cond ((not (numberp shift-factor)) (error "Non-numeric arg to ~S, ~S" 'il:llsh shift-factor)) ((= shift-factor 0) x) ((< shift-factor 0) `(il:lrsh ,x ,(- shift-factor))) ((< shift-factor 8) `(il:llsh (il:llsh1 ,x) ,(1- shift-factor))) (t `(il:llsh (il:llsh8 ,x) ,(- shift-factor 8))))) 'compiler:pass)) ) ;; Simple TYPEP optimiziation #+Xerox-Lyric (defoptimizer typep type-t-test (object type) "Everything is of type T" (if (and (constantp type) (eq (eval type) t)) `(progn ,object t) 'compiler:pass)) ;;; Declare side-effects (actually, lack of side-effects) info for some ;;; internal arithmetic functions. These are needed because the compiler runs ;;; the optimizers before checking the side-effects, so side-effect ;;; declarations on the "real" functions are oft times ignored. #+Xerox-Lyric (progn (il:putprops cl::%+ compiler::side-effects-data (:none . :none)) (il:putprops cl::%- compiler::side-effects-data (:none . :none)) (il:putprops cl::%* compiler::side-effects-data (:none . :none)) (il:putprops cl::%/ compiler::side-effects-data (:none . :none)) (il:putprops cl::%logior compiler::side-effects-data (:none . :none)) (il:putprops cl::%logeqv compiler::side-effects-data (:none . :none)) (il:putprops cl::%= compiler::side-effects-data (:none . :none)) (il:putprops cl::%> compiler::side-effects-data (:none . :none)) (il:putprops cl::%< compiler::side-effects-data (:none . :none)) (il:putprops cl::%>= compiler::side-effects-data (:none . :none)) (il:putprops cl::%<= compiler::side-effects-data (:none . :none)) (il:putprops cl::%/= compiler::side-effects-data (:none . :none)) (il:putprops il:lrsh1 compiler::side-effects-data (:none . :none)) (il:putprops il:lrsh8 compiler::side-effects-data (:none . :none)) (il:putprops il:llsh1 compiler::side-effects-data (:none . :none)) (il:putprops il:llsh8 compiler::side-effects-data (:none . :none)) ) ;;; Fix a nit in the compiler #+Xerox-Lyric (progn (il:unadvise 'compile) (il:advise 'compile ':around '(let (compiler::*input-stream*) (inner))) ) ;;; While no person would generate code like (logor x), macro can (and do). (defun optimize-logical-op-1-arg (form env ctxt) (declare (ignore env ctxt)) (if (= 2 (length form)) (second form) 'compiler::pass)) (xcl:defoptimizer logior optimize-logical-op-1-arg) (xcl:defoptimizer logxor optimize-logical-op-1-arg) (xcl:defoptimizer logand optimize-logical-op-1-arg) (xcl:defoptimizer logeqv optimize-logical-op-1-arg) #+Xerox-Medley ;; A bug compiling LABELS (defun compiler::meta-call-labels (compiler::node compiler:context) ;; This is similar to META-CALL-LAMBDA, but we have some extra information. ;; There are only required arguments, and we have the correct number of them. (let ((compiler::*made-changes* nil)) ;; First, substitute the functions wherever possible. (dolist (compiler::fn-pair (compiler::labels-funs compiler::node) (when (null (compiler::node-meta-p (compiler::labels-body compiler::node))) (setf (compiler::node-meta-p compiler::node) nil) (setq compiler::*made-changes* t))) (when (compiler::substitutable-p (cdr compiler::fn-pair) (car compiler::fn-pair)) (let ((compiler::*subst-occurred* nil)) ;; First try substituting into the body. (setf (compiler::labels-body compiler::node) (compiler::meta-substitute (cdr compiler::fn-pair) (car compiler::fn-pair) (compiler::labels-body compiler::node))) (when (not compiler::*subst-occurred*) ;; Wasn't in the body - try the other functions. (dolist (compiler::target-pair (compiler::labels-funs compiler::node)) (unless (eq compiler::target-pair compiler::fn-pair) (setf (cdr compiler::target-pair) (compiler::meta-substitute (cdr compiler::fn-pair) (car compiler::fn-pair) (cdr compiler::target-pair))) (when compiler::*subst-occurred* ;Found it, we can stop now. (setf (compiler::node-meta-p compiler::node) nil) (setq compiler::*made-changes* t) (return))))) ;; May need to reanalyze the node, since things might have changed. ;; Note that reanalyzing the parts of the node this way means the the ;; state in the enclosing loop is not lost. (dolist (compiler::fns (compiler::labels-funs compiler::node)) (compiler::meval (cdr compiler::fns) :argument)) (compiler::meval (compiler::labels-body compiler::node) :return)))) ;; Now remove any functions that aren't referenced. (dolist (compiler::fn-pair (prog1 (compiler::labels-funs compiler::node) (setf (compiler::labels-funs compiler::node) nil))) (cond ((null (compiler::variable-read-refs (car compiler::fn-pair))) (compiler::release-tree (cdr compiler::fn-pair)) (setq compiler::*made-changes* t)) (t (push compiler::fn-pair (compiler::labels-funs compiler::node))))) ;; If there aren't any functions left, replace the node with its body. (when (null (compiler::labels-funs compiler::node)) (let ((compiler::body (compiler::labels-body compiler::node))) (setf (compiler::labels-body compiler::node) nil) (compiler::release-tree compiler::node) (setq compiler::node compiler::body compiler::*made-changes* t))) ;; Finally, set the meta-p flag if everythings OK. (if (null compiler::*made-changes*) (setf (compiler::node-meta-p compiler::node) compiler:context) (setf (compiler::node-meta-p compiler::node) nil))) compiler::node) gcl/pcl/impl/symbolics/0000755000175000017500000000000012240167764013773 5ustar cammcammgcl/pcl/impl/symbolics/genera-low.lisp0000644000175000017500000003274212240167764016734 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 3600 version of the file portable-low. ;;; (in-package 'pcl) (pushnew ':pcl-internals dbg:*all-invisible-frame-types*) #+IMach ;On the I-Machine these are (eval-when (compile load eval) ;faster than the versions ;that use :test #'eq. (defmacro memq (item list) `(member ,item ,list)) (defmacro assq (item list) `(assoc ,item ,list)) (defmacro rassq (item list) `(rassoc ,item ,list)) (defmacro delq (item list) `(delete ,item ,list)) (defmacro posq (item list) `(position ,item ,list)) ) compiler:: (defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form) (matchp form (('cl:the type subform) (ignore type) subform) (* form))) (defmacro %ash (x count) (if (and (constantp count) (zerop (eval count))) x `(the fixnum (ash (the fixnum ,x ) ,count)))) ;;; ;;; ;;; (defmacro without-interrupts (&body body) `(let ((outer-scheduling-state si:inhibit-scheduling-flag) (si:inhibit-scheduling-flag t)) (macrolet ((interrupts-on () '(when (null outer-scheduling-state) (setq si:inhibit-scheduling-flag nil))) (interrupts-off () '(setq si:inhibit-scheduling-flag t))) (progn outer-scheduling-state) ,.body))) ;;; ;;; It would appear that #, does not work properly in Genera. At least I can't get it ;;; to work when I use it inside of std-instance-p (defined later in this file). So, ;;; all of this is just to support that. ;;; ;;; WHEN EXPANDS-TO ;;; compile to a file (#:EVAL-AT-LOAD-TIME-MARKER .

) ;;; compile to core ' ;;; not in compiler at all (progn ) ;;; ;;; Believe me when I tell you that I don't know why it is I need both a ;;; transformer and an optimizer to get this to work. Believe me when I ;;; tell you that I don't really care why either. ;;; (defmacro load-time-eval (form) ;; The interpreted definition of load-time-eval. This definition ;; never gets compiled. (let ((value (gensym))) `(multiple-value-bind (,value) (progn ,form) ,value))) (compiler:deftransformer (load-time-eval optimize-load-time-eval) (form) (compiler-is-a-loser-internal form)) (compiler:defoptimizer (load-time-eval transform-load-time-eval) (form) (compiler-is-a-loser-internal form)) (defun compiler-is-a-loser-internal (form) ;; When compiling a call to load-time-eval the compiler will call ;; this optimizer before the macro expansion. (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need ;this boundp check ;but it can't hurt. (funcall *compile-function* :to-core-p)) ;; Compiling to core. ;; Evaluate the form now, and expand into a constant ;; (the result of evaluating the form). `',(eval (cadr form)) ;; Compiling to a file. ;; Generate the magic which causes the dumper compiler and loader ;; to do magic and evaluate the form at load time. `',(cons compiler:eval-at-load-time-marker (cadr form)))) ;; ;;;;;; Memory Block primitives. *** ;; (defmacro make-memory-block (size &optional area) `(make-array ,size :area ,area)) (defmacro memory-block-ref (block offset) ;Don't want to go faster yet. `(aref ,block ,offset)) (defvar class-wrapper-area) (eval-when (load eval) (si:make-area :name 'class-wrapper-area :room t :gc :static)) (eval-when (compile load eval) (remprop '%%allocate-instance--class 'inline)) (eval-when (compile load eval) (scl:defflavor std-instance ((wrapper nil) (slots nil)) () (:constructor %%allocate-instance--class()) :ordered-instance-variables) (defvar *std-instance-flavor* (flavor:find-flavor 'std-instance)) ) #-imach (scl:defsubst pcl-%instance-flavor (instance) (declare (compiler:do-not-record-macroexpansions)) (sys::%make-pointer sys:dtp-array (sys:%p-contents-as-locative (sys:follow-structure-forwarding instance)))) #+imach (scl:defsubst pcl-%instance-flavor (instance) (sys:%instance-flavor instance)) (scl::defsubst std-instance-p (x) (and (sys:instancep x) (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*)))) (scl:defmethod (:print-self std-instance) (stream depth slashify) (declare (ignore slashify)) (print-std-instance scl:self stream depth)) (scl:defmethod (:describe std-instance) () (describe-object scl:self *standard-output*)) (defmacro %std-instance-wrapper (std-instance) `(sys:%instance-ref ,std-instance 1)) (defmacro %std-instance-slots (std-instance) `(sys:%instance-ref ,std-instance 2)) (scl:compile-flavor-methods std-instance) (defun printing-random-thing-internal (thing stream) (format stream "~\\si:address\\" (si:%pointer thing))) ;;; ;;; This is hard, I am sweating. ;;; (defun function-arglist (function) (zl:arglist function t)) (defun function-pretty-arglist (function) (zl:arglist function)) ;; New (& complete) fspec handler. ;; 1. uses a single #'equal htable where stored elements are (fn . plist) ;; (maybe we should store the method object instead) ;; 2. also implements the fspec-plist operators here. ;; 3. fdefine not only stores the method, but actually does the loading here! ;; ;;; ;;; genera-low.lisp (replaces old method-function-spec-handler) ;;; ;; New (& complete) fspec handler. ;; 1. uses a single #'equal htable where stored elements are (fn . plist) ;; (maybe we should store the method object instead) ;; 2. also implements the fspec-plist operators here. ;; 3. fdefine not only stores the method, but actually does the loading here! ;; (defvar *method-htable* (make-hash-table :test #'equal :size 500)) (sys:define-function-spec-handler method (op spec &optional arg1 arg2) (if (eq op 'sys:validate-function-spec) (and (let ((gspec (cadr spec))) (or (symbolp gspec) (and (listp gspec) (eq (car gspec) 'setf) (symbolp (cadr gspec)) (null (cddr gspec))))) (let ((tail (cddr spec))) (loop (cond ((null tail) (return nil)) ((listp (car tail)) (return t)) ((atom (pop tail))) (t (return nil)))))) (let ((table *method-htable*) (key spec)) (case op ((si:fdefinedp si:fdefinition) (car (gethash key table nil))) (si:fundefine (remhash key table)) (si:fdefine (let ((old (gethash key table nil)) (quals nil) (specs nil) (ptr (cddr spec))) (setq specs (loop (cond ((null ptr) (return nil)) ((listp (car ptr)) (return (car ptr))) (t (push (pop ptr) quals))))) (setf (gethash key table) (cons arg1 (cdr old))))) (si:get (let ((old (gethash key table nil))) (getf (cdr old) arg1))) (si:plist (let ((old (gethash key table nil))) (cdr old))) (si:putprop (let ((old (gethash key table nil))) (unless old (setf old (cons nil nil)) (setf (gethash key table) old)) (setf (getf (cdr old) arg2) arg1))) (si:remprop (let ((old (gethash key table nil))) (when old (remf (cdr old) arg1)))) (otherwise (si:function-spec-default-handler op spec arg1 arg2)))))) #|| ;; this guy is just a stub to make the fspec handler simpler (and so I could trace it ;; easier). (defun pcl-fdefine-helper (gspec qualifiers specializers fn) (let* ((dlist (scl:debugging-info fn)) (class (cadr (assoc 'pcl-method-class dlist))) (lambda-list (let ((ll-stuff (assoc 'pcl-lambda-list dlist))) (if ll-stuff (cadr ll-stuff) (arglist fn)))) (doc (cadr (assoc 'pcl-documentation dlist))) (plist (cadr (assoc 'pcl-plist dlist)))) (load-defmethod (or class 'standard-method) gspec qualifiers specializers lambda-list doc (getf plist :pv-table-cache-symbol) plist fn))) ||# ;; define a few special declarations to get pushed onto the function's debug-info ;; list... note that we do not need to do a (proclaim (declarations ...)) here. ;; (eval-when (compile load eval) (setf (get 'pcl-plist 'si:debug-info) t) (setf (get 'pcl-documentation 'si:debug-info) t) (setf (get 'pcl-method-class 'si:debug-info) t) (setf (get 'pcl-lambda-list 'si:debug-info) t) ) (eval-when (load eval) (setf (get 'defmethod 'zwei:definition-function-spec-type) 'defun (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun (get 'method 'si:definition-type-name) "method" (get 'method 'si:definition-type-name) "method" (get 'declass 'zwei:definition-function-spec-type) 'defclass (get 'defclass 'si:definition-type-name) "Class" (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1)) ) (defun (:property defmethod zwei::definition-function-spec-parser) (bp) (zwei:parse-pcl-defmethod-for-zwei bp nil)) ;;; ;;; Previously, if a source file in a PCL-based package contained what looks ;;; like flavor defmethod forms (i.e. an (IN-PACKAGE 'non-pcl-package) form ;;; appears at top level, and then a flavor-style defmethod form) appear, the ;;; parser would break. ;;; ;;; Now, if we can't parse the defmethod form, we send it to the flavor ;;; defmethod parser instead. ;;; ;;; Also now supports multi-line arglist sectionizing. ;;; zwei: (defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp) (block parser (flet ((barf (&optional (error t)) (return-from parser (cond ((eq error :flavor) (funcall (get 'flavor:defmethod 'zwei::definition-function-spec-parser) bp-after-defmethod)) (t (values nil nil nil error)))))) (let ((bp-after-generic (forward-sexp bp-after-defmethod)) (qualifiers ()) (specializers ()) (spec nil) (ignore1 nil) (ignore2 nil)) (when bp-after-generic (multiple-value-bind (generic error-p) (read-fspec-item-from-interval bp-after-defmethod bp-after-generic) (if error-p (barf) ; error here is really bad.... BARF! (progn (when (listp generic) (if (and (symbolp (car generic)) (string-equal (cl:symbol-name (car generic)) "SETF")) (setq generic (second generic) ; is a (setf xxx) form setfp t) (barf :flavor))) ; make a last-ditch-effort with flavor parser (let* ((bp1 bp-after-generic) (bp2 (forward-sexp bp1))) (cl:loop (if (null bp2) (barf :more) ; item not closed - need another line! (multiple-value-bind (item error-p) (read-fspec-item-from-interval bp1 bp2) (cond (error-p (barf)) ; ((listp item) (setq qualifiers (nreverse qualifiers)) (cl:multiple-value-setq (ignore1 ignore2 specializers) (pcl::parse-specialized-lambda-list item)) (setq spec (pcl::make-method-spec (if setfp `(cl:setf ,generic) generic) qualifiers specializers)) (return (values spec 'defun (string-interval bp-after-defmethod bp2)))) (t (push item qualifiers) (setq bp1 bp2 bp2 (forward-sexp bp2)))))))))))))))) zwei: (progn (defun indent-clos-defmethod (ignore bp defmethod-paren &rest ignore) (let ((here (forward-over *whitespace-chars* (forward-word defmethod-paren)))) (loop until (char-equal (bp-char here) #\() do (setf here (forward-over *whitespace-chars* (forward-sexp here)))) (if (bp-< here bp) (values defmethod-paren nil 2) (values defmethod-paren nil 4)))) (defindentation (pcl::defmethod . indent-clos-defmethod))) ;;; ;;; Teach zwei that when it gets the name of a generic function as an argument ;;; it should edit all the methods of that generic function. This works for ;;; ED as well as meta-point. ;;; (zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR) :around setup-function-specs-to-edit-advice () (let ((old-definitions (cadddr arglist)) (new-definitions ()) (new nil)) (dolist (old old-definitions) (setq new (setup-function-specs-to-edit-advice-1 old)) (push (or new (list old)) new-definitions)) (setf (cadddr arglist) (apply #'append (reverse new-definitions))) :do-it)) (defun setup-function-specs-to-edit-advice-1 (spec) (and (or (symbolp spec) (and (listp spec) (eq (car spec) 'setf))) (gboundp spec) (generic-function-p (gdefinition spec)) (mapcar #'(lambda (m) (make-method-spec spec (method-qualifiers m) (unparse-specializers (method-specializers m)))) (generic-function-methods (gdefinition spec))))) gcl/pcl/impl/symbolics/rel-7-2-patches.lisp0000644000175000017500000003600112240167764017376 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; Does simple constant folding. This works for everything that doesn't have ;;; side-effects. ;;; ALL operands must be constant. ;;; Note that commutative-constant-folder can hack this case perfectly well ;;; by himself for the functions he handles. (defun constant-fold-optimizer (form) (let ((eval-when-load-p nil)) (flet ((constant-form-p (x) (when (constant-form-p x) (cond ((and (listp x) (eq (car x) 'quote) (listp (cadr x)) (eq (caadr x) eval-at-load-time-marker)) (setq eval-when-load-p t) (cdadr x)) (t x))))) (if (every (cdr form) #'constant-form-p) (if eval-when-load-p (list 'quote (list* eval-at-load-time-marker (car form) (mapcar #'constant-form-p (cdr form)))) (condition-case (error-object) (multiple-value-call #'(lambda (&rest values) (if (= (length values) 1) `',(first values) `(values ,@(mapcar #'(lambda (x) `',x) values)))) (eval form)) (error (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" form error-object) form))) form)))) ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; ;;; The damn compiler doesn't compile random forms that appear at top level. ;;; Its difficult to do because you have to get an associated function spec ;;; to go with those forms. This handles that by defining a special form, ;;; top-level-form that compiles its body. It takes a list of eval-when ;;; times just like eval when does. It also takes a name which it uses ;;; to construct a function spec for the top-level-form function it has ;;; to create. ;;; ; ;si:: ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) ; ;si:: ;(define-function-spec-handler pcl::top-level-form ; (operation fspec &optional arg1 arg2) ; (let ((name (cadr fspec))) ; (selectq operation ; (validate-function-spec (and (= (length fspec) 2) ; (or (symbolp name) ; (listp name)))) ; (fdefine ; (setf (gethash name *top-level-form-fdefinitions*) arg1)) ; ((fdefinition fdefinedp) ; (gethash name *top-level-form-fdefinitions*)) ; (fdefinition-location ; (ferror "It is not possible to get the fdefinition-location of ~s." ; fspec)) ; (fundefine (remhash name *top-level-form-fdefinitions*)) ; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) ; ;;; ;;; This is basically stolen from PROGN (surprised?) ;;; ;(si:define-special-form pcl::top-level-form (name times ; &body body ; &environment env) ; (declare lt:(arg-template . body) (ignore name)) ; (si:check-eval-when-times times) ; (when (member 'eval times) (si:eval-body body env))) ; ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) ; (lt::mapforms-list original-form form (cddr form) 'eval usage)) ;;; This is the normal function for looking at each form read from the file and calling ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) ; (CATCH-ERROR-RESTART ; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) ; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) ; (LET ((ERROR-MESSAGE-HOOK ; #'(LAMBDA () ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" ; DBG:*ERROR-MESSAGE-PRINLEVEL* ; DBG:*ERROR-MESSAGE-PRINLENGTH* ; FORM)))) ; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) ; (WHEN (LISTP FORM) ;Ignore atoms at top-level ; (LET ((FUNCTION (FIRST FORM))) ; (SELECTQ FUNCTION ; ((QUOTE)) ;and quoted constants e.g. 'COMPILE ; ((PROGN) ; (DOLIST (FORM (CDR FORM)) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) ; ((EVAL-WHEN) ; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) ; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) ; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) ; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) ; (FORMS (CDDR FORM))) ; (COND (LOAD-P ; (DOLIST (FORM FORMS) ; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) ; (COMPILE-P ; (DOLIST (FORM FORMS) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) ; ((DEFUN) ; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) ; (IF (EQ (CDR TEM) (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) ; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) ; ((MACRO) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) ; ((DECLARE) ; (DOLIST (FORM (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) ; ;; (DECLARE (SPECIAL ... has load-time action as well. ; ;; All other DECLARE's do not. ; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) ; ((COMPILER-LET) ; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) ; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) ; ((SI:DEFINE-SPECIAL-FORM) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) ; ((MULTIPLE-DEFINITION) ; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) ; (LET ((NAME-VALID (AND (NOT (NULL NAME)) ; (OR (SYMBOLP NAME) ; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) ; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) ; (UNLESS (AND NAME-VALID TYPE-VALID) ; (WARN "(~S ~S ~S ...) is invalid because~@ ; ~:[~S is not valid as a definition name~;~*~]~ ; ~:[~&~S is not valid as a definition type~;~*~]" ; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) ; (LET* ((COMPILED-BODY NIL) ; (COMPILE-FUNCTION *COMPILE-FUNCTION*) ; (*COMPILE-FUNCTION* ; (LAMBDA (OPERATION &REST ARGS) ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (SELECTQ OPERATION ; (:DUMP-FORM ; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM ; (FIRST ARGS)) ; COMPILED-BODY)) ; (:INSTALL-DEFINITION ; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) ; COMPILED-BODY)) ; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) ; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) ; ,@LOCAL-DECLARATIONS))) ; (DOLIST (FORM BODY) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) ; (FUNCALL COMPILE-FUNCTION :DUMP-FORM ; `(LOAD-MULTIPLE-DEFINITION ; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) ; ((pcl::top-level-form) ; (destructuring-bind (name times . body) ; (cdr form) ; (si:check-eval-when-times times) ; (let ((compile-p (or (memq 'compile times) ; (and compile-time-too (memq 'eval times)))) ; (load-p (or (memq 'load times) ; (memq 'cl:load times))) ; (fspec `(pcl::top-level-form ,name))) ; (cond (load-p ; (compile-from-stream-1 ; `(progn (defun ,fspec () . ,body) ; (funcall (function ,fspec))) ; (and compile-p ':force))) ; (compile-p ; (dolist (b body) ; (funcall *compile-form-function* form ':force nil))))))) ; (OTHERWISE ; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) ; (IF TEM ; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) ; ; dw:: (defun symbol-flavor-or-cl-type (symbol) (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent non-atomic-deftype)) (multiple-value-bind (result foundp) (gethash symbol *flavor-or-cl-type-cache*) (let ((frob (if foundp result (setf (gethash symbol *flavor-or-cl-type-cache*) (or (get symbol 'flavor:flavor) (not (null (defstruct-type-p symbol))) (let* ((deftype (get symbol 'deftype)) (descriptor (symbol-presentation-type-descriptor symbol)) (typep (unless (and descriptor (presentation-type-explicit-type-function descriptor)) ;; Don't override the one defined in the presentation-type. (get symbol 'typep))) (atomic-subtype-parent (find-atomic-subtype-parent symbol)) (non-atomic-deftype (when (and (not descriptor) deftype) (not (member (first (type-arglist symbol)) '(&rest &key &optional)))))) (if (or typep (not (atom deftype)) non-atomic-deftype ;; deftype overrides atomic-subtype-parent. (and (not deftype) atomic-subtype-parent)) (list-in-area *handler-dynamic-area* deftype typep atomic-subtype-parent non-atomic-deftype) deftype))))))) (locally (declare (inline compiled-function-p)) (etypecase frob (array (values frob)) (null (values nil)) ((member t) (values nil t)) (compiled-function (values nil nil frob)) (lexical-closure (values nil nil frob)) (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) frob (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) (symbol (values nil nil nil nil frob))))))) ;;; ;;; The variable zwei::*sectionize-line-lookahead* controls how many lines the parser ;;; is willing to look ahead while trying to parse a definition. Even 2 lines is enough ;;; for just about all cases, but there isn't much overhead, and 10 should be enough ;;; to satisfy pretty much everyone... but feel free to change it. ;;; - MT 880921 ;;; zwei: (defvar *sectionize-line-lookahead* 3) zwei: (DEFMETHOD (:SECTIONIZE-BUFFER MAJOR-MODE :DEFAULT) (FIRST-BP LAST-BP BUFFER STREAM INT-STREAM ADDED-COMPLETIONS) ADDED-COMPLETIONS ;ignored, obsolete (WHEN STREAM (SEND-IF-HANDLES STREAM :SET-RETURN-DIAGRAMS-AS-LINES T)) (INCF *SECTIONIZE-BUFFER*) (LET ((BUFFER-TICK (OR (SEND-IF-HANDLES BUFFER :SAVE-TICK) *TICK*)) OLD-CHANGED-SECTIONS) (TICK) ;; Flush old section nodes. Also collect the names of those that are modified, they are ;; the ones that will be modified again after a revert buffer. (DOLIST (NODE (NODE-INFERIORS BUFFER)) (AND (> (NODE-TICK NODE) BUFFER-TICK) (PUSH (LIST (SECTION-NODE-FUNCTION-SPEC NODE) (SECTION-NODE-DEFINITION-TYPE NODE)) OLD-CHANGED-SECTIONS)) (FLUSH-BP (INTERVAL-FIRST-BP NODE)) (FLUSH-BP (INTERVAL-LAST-BP NODE))) (DO ((LINE (BP-LINE FIRST-BP) (LINE-NEXT INT-LINE)) (LIMIT (BP-LINE LAST-BP)) (EOFFLG) (ABNORMAL T) (DEFINITION-LIST NIL) (BP (COPY-BP FIRST-BP)) (FUNCTION-SPEC) (DEFINITION-TYPE) (STR) (INT-LINE) (first-time t) (future-line) ; we actually read into future line (future-int-line) (PREV-NODE-START-BP FIRST-BP) (PREV-NODE-DEFINITION-LINE NIL) (PREV-NODE-FUNCTION-SPEC NIL) (PREV-NODE-TYPE 'HEADER) (PREVIOUS-NODE NIL) (NODE-LIST NIL) (STATE (SEND SELF :INITIAL-SECTIONIZATION-STATE))) (NIL) ;; If we have a stream, read another line. (when (AND STREAM (NOT EOFFLG)) (let ((lookahead (if future-line 1 *sectionize-line-lookahead*))) (dotimes (i lookahead) ; startup lookahead (MULTIPLE-VALUE (future-LINE EOFFLG) (LET ((DEFAULT-CONS-AREA *LINE-AREA*)) (SEND STREAM ':LINE-IN LINE-LEADER-SIZE))) (IF future-LINE (SETQ future-INT-LINE (FUNCALL INT-STREAM ':LINE-OUT future-LINE))) (when first-time (setq first-time nil) (setq line future-line) (setq int-line future-int-line)) (when eofflg (return))))) (SETQ INT-LINE LINE) (when int-line (MOVE-BP BP INT-LINE 0)) ;Record as potentially start-bp for a section ;; See if the line is the start of a defun. (WHEN (AND LINE (LET (ERR) (MULTIPLE-VALUE (FUNCTION-SPEC DEFINITION-TYPE STR ERR STATE) (SEND SELF ':SECTION-NAME INT-LINE BP STATE)) (NOT ERR))) (PUSH (LIST FUNCTION-SPEC DEFINITION-TYPE) DEFINITION-LIST) (SECTION-COMPLETION FUNCTION-SPEC STR NIL) ;; List methods under both names for user ease. (LET ((OTHER-COMPLETION (SEND SELF ':OTHER-SECTION-NAME-COMPLETION FUNCTION-SPEC INT-LINE))) (WHEN OTHER-COMPLETION (SECTION-COMPLETION FUNCTION-SPEC OTHER-COMPLETION NIL))) (LET ((PREV-NODE-END-BP (BACKWARD-OVER-COMMENT-LINES BP ':FORM-AS-BLANK))) ;; Don't make a section node if it's completely empty. This avoids making ;; a useless Buffer Header section node. Just set all the PREV variables ;; so that the next definition provokes the *right thing* (UNLESS (BP-= PREV-NODE-END-BP PREV-NODE-START-BP) (SETQ PREVIOUS-NODE (ADD-SECTION-NODE PREV-NODE-START-BP (SETQ PREV-NODE-START-BP PREV-NODE-END-BP) PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) (EQ PREV-NODE-TYPE TYPE))) *TICK* BUFFER-TICK) BUFFER-TICK)) (PUSH PREVIOUS-NODE NODE-LIST))) (SETQ PREV-NODE-FUNCTION-SPEC FUNCTION-SPEC PREV-NODE-TYPE DEFINITION-TYPE PREV-NODE-DEFINITION-LINE INT-LINE)) ;; After processing the last line, exit. (WHEN (OR #+ignore EOFFLG (null line) (AND (NULL STREAM) (EQ LINE LIMIT))) ;; If reading a stream, we should not have inserted a CR ;; after the eof line. (WHEN STREAM (DELETE-INTERVAL (FORWARD-CHAR LAST-BP -1 T) LAST-BP T)) ;; The rest of the buffer is part of the last node (UNLESS (SEND SELF ':SECTION-NAME-TRIVIAL-P) ;; ---oh dear, what sort of section will this be? A non-empty HEADER ;; ---node. Well, ok for now. (PUSH (ADD-SECTION-NODE PREV-NODE-START-BP LAST-BP PREV-NODE-FUNCTION-SPEC PREV-NODE-TYPE PREV-NODE-DEFINITION-LINE BUFFER PREVIOUS-NODE (IF (LOOP FOR (FSPEC TYPE) IN OLD-CHANGED-SECTIONS THEREIS (AND (EQ PREV-NODE-FUNCTION-SPEC FSPEC) (EQ PREV-NODE-TYPE TYPE))) *TICK* BUFFER-TICK) BUFFER-TICK) NODE-LIST) (SETF (LINE-NODE (BP-LINE LAST-BP)) (CAR NODE-LIST))) (SETF (NODE-INFERIORS BUFFER) (NREVERSE NODE-LIST)) (SETF (NAMED-BUFFER-WITH-SECTIONS-FIRST-SECTION BUFFER) (CAR (NODE-INFERIORS BUFFER))) (SETQ ABNORMAL NIL) ;timing windows here ;; Speed up completion if enabled. (WHEN SI:*ENABLE-AARRAY-SORTING-AFTER-LOADS* (SI:SORT-AARRAY *ZMACS-COMPLETION-AARRAY*)) (SETQ *ZMACS-COMPLETION-AARRAY* (FOLLOW-STRUCTURE-FORWARDING *ZMACS-COMPLETION-AARRAY*)) (RETURN (VALUES (CL:SETF (ZMACS-SECTION-LIST BUFFER) (NREVERSE DEFINITION-LIST)) ABNORMAL)))))) gcl/pcl/impl/symbolics/cloe-low.lisp0000644000175000017500000000231012240167764016401 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmacro object-cache-no (object mask) `(logand (sys::address-of ,object) ,mask)) gcl/pcl/impl/symbolics/rel-8-patches.lisp0000644000175000017500000002361412240167764017246 0ustar cammcamm;;; -*- Mode: LISP; Syntax: Common-lisp; Package: ZL-USER; Base: 10; Patch-File: T -*- ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:l-COMPILER;OPTIMIZE.LISP.179") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; Does simple constant folding. This works for everything that doesn't have ;;; side-effects. ;;; ALL operands must be constant. ;;; Note that commutative-constant-folder can hack this case perfectly well ;;; by himself for the functions he handles. (defun constant-fold-optimizer (form) (let ((eval-when-load-p nil)) (flet ((constant-form-p (x) (when (constant-form-p x) (cond ((and (listp x) (eq (car x) 'quote) (listp (cadr x)) (eq (caadr x) eval-at-load-time-marker)) (setq eval-when-load-p t) (cdadr x)) (t x))))) (if (every (cdr form) #'constant-form-p) (if eval-when-load-p (list 'quote (list* eval-at-load-time-marker (car form) (mapcar #'constant-form-p (cdr form)))) (condition-case (error-object) (multiple-value-call #'(lambda (&rest values) (if (= (length values) 1) `',(first values) `(values ,@(mapcar #'(lambda (x) `',x) values)))) (eval form)) (error (phase-1-warning "Constant form left unoptimized: ~S~%because: ~~A~" form error-object) form))) form)))) ;===================================== (SYSTEM-INTERNALS:BEGIN-PATCH-SECTION) (SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:L-COMPILER;COMFILE.LISP.85") (SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES "-*- Mode: Lisp; Package: Compiler; Lowercase: T; Base: 8 -*-") ;;; ;;; The damn compiler doesn't compile random forms that appear at top level. ;;; Its difficult to do because you have to get an associated function spec ;;; to go with those forms. This handles that by defining a special form, ;;; top-level-form that compiles its body. It takes a list of eval-when ;;; times just like eval when does. It also takes a name which it uses ;;; to construct a function spec for the top-level-form function it has ;;; to create. ;;; ; ;si:: ;(defvar *top-level-form-fdefinitions* (cl:make-hash-table :test #'equal)) ; ;si:: ;(define-function-spec-handler pcl::top-level-form ; (operation fspec &optional arg1 arg2) ; (let ((name (cadr fspec))) ; (selectq operation ; (validate-function-spec (and (= (length fspec) 2) ; (or (symbolp name) ; (listp name)))) ; (fdefine ; (setf (gethash name *top-level-form-fdefinitions*) arg1)) ; ((fdefinition fdefinedp) ; (gethash name *top-level-form-fdefinitions*)) ; (fdefinition-location ; (ferror "It is not possible to get the fdefinition-location of ~s." ; fspec)) ; (fundefine (remhash name *top-level-form-fdefinitions*)) ; (otherwise (function-spec-default-handler operation fspec arg1 arg2))))) ; ;;; ;;; This is basically stolen from PROGN (surprised?) ;;; ;(si:define-special-form pcl::top-level-form (name times ; &body body ; &environment env) ; (declare lt:(arg-template . body) (ignore name)) ; (si:check-eval-when-times times) ; (when (member 'eval times) (si:eval-body body env))) ; ;(defun (:property pcl::top-level-form lt:mapforms) (original-form form usage) ; (lt::mapforms-list original-form form (cddr form) 'eval usage)) ;;; This is the normal function for looking at each form read from the file and calling ;;; *COMPILE-FORM-FUNCTION* on the sub-forms of it. ;;; COMPILE-TIME-TOO means override the normal cases that eval at compile time. It is ;;; used for recursive calls under (EVAL-WHEN (COMPILE LOAD) ...). ;(DEFUN COMPILE-FROM-STREAM-1 (FORM &OPTIONAL (COMPILE-TIME-TOO NIL)) ; (CATCH-ERROR-RESTART ; (SYS:ERROR "Skip compiling form ~2,2\COMPILER:SHORT-S-FORMAT\" FORM) ; (LET ((DEFAULT-CONS-AREA (FUNCALL *COMPILE-FUNCTION* ':CONS-AREA))) ; (LET ((ERROR-MESSAGE-HOOK ; #'(LAMBDA () ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (FORMAT T "~&While processing ~V,V\COMPILER:SHORT-S-FORMAT\" ; DBG:*ERROR-MESSAGE-PRINLEVEL* ; DBG:*ERROR-MESSAGE-PRINLENGTH* ; FORM)))) ; (SETQ FORM (FUNCALL *COMPILE-FUNCTION* ':MACRO-EXPAND FORM))) ; (WHEN (LISTP FORM) ;Ignore atoms at top-level ; (LET ((FUNCTION (FIRST FORM))) ; (SELECTQ FUNCTION ; ((QUOTE)) ;and quoted constants e.g. 'COMPILE ; ((PROGN) ; (DOLIST (FORM (CDR FORM)) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO))) ; ((EVAL-WHEN) ; (SI:CHECK-EVAL-WHEN-TIMES (CADR FORM)) ; (LET ((COMPILE-P (OR (MEMQ 'COMPILE (CADR FORM)) ; (AND COMPILE-TIME-TOO (MEMQ 'EVAL (CADR FORM))))) ; (LOAD-P (OR (MEMQ 'LOAD (CADR FORM)) (MEMQ 'CL:LOAD (CADR FORM)))) ; (FORMS (CDDR FORM))) ; (COND (LOAD-P ; (DOLIST (FORM FORMS) ; (COMPILE-FROM-STREAM-1 FORM (AND COMPILE-P ':FORCE)))) ; (COMPILE-P ; (DOLIST (FORM FORMS) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM ':FORCE NIL)))))) ; ((DEFUN) ; (LET ((TEM (DEFUN-COMPATIBILITY (CDR FORM) :WARN-IF-OBSOLETE T))) ; (IF (EQ (CDR TEM) (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T) ; (COMPILE-FROM-STREAM-1 TEM COMPILE-TIME-TOO)))) ; ((MACRO) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) T)) ; ((DECLARE) ; (DOLIST (FORM (CDR FORM)) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM (OR COMPILE-TIME-TOO T) ; ;; (DECLARE (SPECIAL ... has load-time action as well. ; ;; All other DECLARE's do not. ; (MEMQ (CAR FORM) '(SPECIAL ZL:UNSPECIAL))))) ; ((COMPILER-LET) ; (COMPILER-LET-INTERNAL (CADR FORM) (CDDR FORM) ; #'COMPILE-FROM-STREAM-1 COMPILE-TIME-TOO)) ; ((SI:DEFINE-SPECIAL-FORM) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)) ; ((MULTIPLE-DEFINITION) ; (DESTRUCTURING-BIND (NAME TYPE . BODY) (CDR FORM) ; (LET ((NAME-VALID (AND (NOT (NULL NAME)) ; (OR (SYMBOLP NAME) ; (AND (LISTP NAME) (NEQ (CAR NAME) 'QUOTE))))) ; (TYPE-VALID (AND (NOT (NULL TYPE)) (SYMBOLP TYPE)))) ; (UNLESS (AND NAME-VALID TYPE-VALID) ; (WARN "(~S ~S ~S ...) is invalid because~@ ; ~:[~S is not valid as a definition name~;~*~]~ ; ~:[~&~S is not valid as a definition type~;~*~]" ; 'MULTIPLE-DEFINITION NAME TYPE NAME-VALID NAME TYPE-VALID TYPE))) ; (LET* ((COMPILED-BODY NIL) ; (COMPILE-FUNCTION *COMPILE-FUNCTION*) ; (*COMPILE-FUNCTION* ; (LAMBDA (OPERATION &REST ARGS) ; (DECLARE (SYS:DOWNWARD-FUNCTION)) ; (SELECTQ OPERATION ; (:DUMP-FORM ; (PUSH (FUNCALL COMPILE-FUNCTION :OPTIMIZE-TOP-LEVEL-FORM ; (FIRST ARGS)) ; COMPILED-BODY)) ; (:INSTALL-DEFINITION ; (PUSH (FORM-FOR-DEFINE *COMPILER* (FIRST ARGS) (SECOND ARGS)) ; COMPILED-BODY)) ; (OTHERWISE (CL:APPLY COMPILE-FUNCTION OPERATION ARGS))))) ; (LOCAL-DECLARATIONS `((FUNCTION-PARENT ,NAME ,TYPE) ; ,@LOCAL-DECLARATIONS))) ; (DOLIST (FORM BODY) ; (COMPILE-FROM-STREAM-1 FORM COMPILE-TIME-TOO)) ; (FUNCALL COMPILE-FUNCTION :DUMP-FORM ; `(LOAD-MULTIPLE-DEFINITION ; ',NAME ',TYPE ',(NREVERSE COMPILED-BODY) NIL))))) ; ((pcl::top-level-form) ; (destructuring-bind (name times . body) ; (cdr form) ; (si:check-eval-when-times times) ; (let ((compile-p (or (memq 'compile times) ; (and compile-time-too (memq 'eval times)))) ; (load-p (or (memq 'load times) ; (memq 'cl:load times))) ; (fspec `(pcl::top-level-form ,name))) ; (cond (load-p ; (compile-from-stream-1 ; `(progn (defun ,fspec () . ,body) ; (funcall (function ,fspec))) ; (and compile-p ':force))) ; (compile-p ; (dolist (b body) ; (funcall *compile-form-function* form ':force nil))))))) ; (OTHERWISE ; (LET ((TEM (AND (SYMBOLP FUNCTION) (GET FUNCTION 'TOP-LEVEL-FORM)))) ; (IF TEM ; (FUNCALL *COMPILE-FORM-FUNCTION* (FUNCALL TEM FORM) COMPILE-TIME-TOO T) ; (FUNCALL *COMPILE-FORM-FUNCTION* FORM COMPILE-TIME-TOO T)))))))))) ; ; dw:: (defun symbol-flavor-or-cl-type (symbol) (declare (values flavor defstruct-p deftype-fun typep-fun atomic-subtype-parent non-atomic-deftype)) (multiple-value-bind (result foundp) (gethash symbol *flavor-or-cl-type-cache*) (let ((frob (if foundp result (setf (gethash symbol *flavor-or-cl-type-cache*) (or (get symbol 'flavor:flavor) (let ((class (get symbol 'clos-internals::class-for-name))) (when (and class (not (typep class 'clos:built-in-class))) class)) (not (null (defstruct-type-p symbol))) (let* ((deftype (get symbol 'deftype)) (descriptor (symbol-presentation-type-descriptor symbol)) (typep (unless (and descriptor (presentation-type-explicit-type-function descriptor)) ;; Don't override the one defined in the presentation-type. (get symbol 'typep))) (atomic-subtype-parent (find-atomic-subtype-parent symbol)) (non-atomic-deftype (when (and (not descriptor) deftype) (not (member (first (type-arglist symbol)) '(&rest &key &optional)))))) (if (or typep (not (atom deftype)) non-atomic-deftype ;; deftype overrides atomic-subtype-parent. (and (not deftype) atomic-subtype-parent)) (list-in-area *handler-dynamic-area* deftype typep atomic-subtype-parent non-atomic-deftype) deftype))))))) (locally (declare (inline compiled-function-p)) (etypecase frob (array (values frob)) (instance (values frob)) (null (values nil)) ((member t) (values nil t)) (compiled-function (values nil nil frob)) (lexical-closure (values nil nil frob)) (list (destructuring-bind (deftype typep atomic-subtype-parent non-atomic-deftype) frob (values nil nil deftype typep atomic-subtype-parent non-atomic-deftype))) (symbol (values nil nil nil nil frob))))))) gcl/pcl/impl/gcl/0000755000175000017500000000000012240167764012534 5ustar cammcammgcl/pcl/impl/gcl/sys-proclaim.lisp0000644000175000017500000025706312240167764016064 0ustar cammcamm (IN-PACKAGE "PCL") (PROCLAIM '(FTYPE (FUNCTION (T) FIXNUM) ONE-INDEX-LIMIT-FN N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN PV-CACHE-LIMIT-FN ARG-INFO-NUMBER-REQUIRED DEFAULT-LIMIT-FN CACHE-COUNT CACHING-LIMIT-FN PV-TABLE-PV-SIZE EARLY-CLASS-SIZE CPD-COUNT FAST-INSTANCE-BOUNDP-INDEX)) (PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) (PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN METHOD-CALL-FUNCTION FAST-METHOD-CALL-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING)) (PROCLAIM '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW PV-TABLE-SLOT-NAME-LISTS PV-TABLE-CALL-LIST)) (PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP)) (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) (PROCLAIM '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME MAKE-KEYWORD)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM) COMPUTE-PRIMARY-CACHE-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) (PROCLAIM '(FTYPE (FUNCTION (T) (OR CACHE NULL)) PV-TABLE-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T T T) *) GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ITERATE::WALK-GATHERING-BODY CACHE-MISS-VALUES MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION OPTIMIZE-SLOT-VALUE-BY-CLASS-P ACCESSOR-VALUES1 EMIT-READER/WRITER EMIT-ONE-OR-N-INDEX-READER/WRITER GENERATING-LISP EMIT-READER/WRITER-FUNCTION EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION WALKER::WALK-LET-IF SET-SLOT-VALUE CONVERT-METHODS |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| CHECK-METHOD-ARG-INFO |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| LOAD-LONG-DEFCOMBIN MAKE-FINAL-N-N-ACCESSOR-DFUN |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| MAKE-FINAL-CACHING-DFUN MAKE-FINAL-CONSTANT-VALUE-DFUN GET-CLASS-SLOT-VALUE-1 ACCESSOR-VALUES-INTERNAL MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION ITERATE::EXPAND-INTO-LET WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES CONSTANT-VALUE-MISS CACHING-MISS |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| CHECKING-MISS GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) *) |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL ADD-METHOD-DECLARATIONS WALK-METHOD-LAMBDA MAKE-TWO-CLASS-ACCESSOR-DFUN |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) *) |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| BOOTSTRAP-ACCESSOR-DEFINITION GET-ACCESSOR-METHOD-FUNCTION EMIT-CHECKING-OR-CACHING EMIT-CHECKING-OR-CACHING-FUNCTION SETF-SLOT-VALUE-USING-CLASS-DFUN LOAD-SHORT-DEFCOMBIN INITIALIZE-INSTANCE-SIMPLE-FUNCTION MAKE-SHARED-INITIALIZE-FORM-LIST MAKE-ONE-CLASS-ACCESSOR-DFUN MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN MAKE-FINAL-CHECKING-DFUN ACCESSOR-VALUES SET-CLASS-SLOT-VALUE-1 GENERATE-DISCRIMINATION-NET REAL-MAKE-METHOD-LAMBDA ORDER-SPECIALIZERS ACCESSOR-MISS |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) *) MEMF-CODE-CONVERTER CACHE-MISS-VALUES-INTERNAL GENERATE-DISCRIMINATION-NET-INTERNAL MAKE-LONG-METHOD-COMBINATION-FUNCTION DO-SHORT-METHOD-COMBINATION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) *) MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS GET-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) *) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1 ITERATE::RENAME-LET-BINDINGS)) (PROCLAIM '(FTYPE (FUNCTION (T T *) *) NESTED-WALK-FORM SLOT-VALUE-OR-DEFAULT MAKE-EFFECTIVE-METHOD-FUNCTION GET-EFFECTIVE-METHOD-FUNCTION MAKE-N-N-ACCESSOR-DFUN MAKE-CHECKING-DFUN LOAD-DEFGENERIC TYPES-FROM-ARGUMENTS MAKE-DEFAULT-INITARGS-FORM-LIST MAKE-FINAL-ACCESSOR-DFUN MAKE-ACCESSOR-TABLE GET-SIMPLE-INITIALIZATION-FUNCTION GET-COMPLEX-INITIALIZATION-FUNCTIONS COMPUTE-SECONDARY-DISPATCH-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) *) |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| ITERATE::ITERATE-TRANSFORM-BODY)) (PROCLAIM '(FTYPE (FUNCTION (T) NON-NEGATIVE-FIXNUM) CACHE-NLINES CACHE-MAX-LOCATION CACHE-SIZE CACHE-MASK)) (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) (PROCLAIM '(FTYPE (FUNCTION (T T T T) T) |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| MAKE-EFFECTIVE-METHOD-FUNCTION1 MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE MEMF-TEST-CONVERTER LOAD-PRECOMPILED-DFUN-CONSTRUCTOR TWO-CLASS-DFUN-INFO WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG* WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 OPTIMIZE-READER OPTIMIZE-WRITER |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| MAYBE-EXPAND-ACCESSOR-FORM |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| INITIALIZE-INSTANCE-SIMPLE |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| GET-WRAPPERS-FROM-CLASSES |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| LOAD-PRECOMPILED-IIS-ENTRY FILL-CACHE-P ADJUST-CACHE |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| EXPAND-CACHE EXPAND-SYMBOL-MACROLET-INTERNAL |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| BOOTSTRAP-SET-SLOT EXPAND-DEFCLASS |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| WALKER::WALK-TEMPLATE |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| MAKE-DISPATCH-LAMBDA |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T) T) |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| CAN-OPTIMIZE-ACCESS |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| OPTIMIZE-SLOT-VALUE |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| OPTIMIZE-SET-SLOT-VALUE |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| DECLARE-STRUCTURE OPTIMIZE-SLOT-BOUNDP PRINT-CACHE FIRST-FORM-TO-LISP ITERATE::OPTIMIZE-ITERATE-FORM WRAP-METHOD-GROUP-SPECIFIER-BINDINGS MAKE-TOP-LEVEL-FORM INVALIDATE-WRAPPER STANDARD-COMPUTE-EFFECTIVE-METHOD MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION WALKER::RECONS ITERATE::OPTIMIZE-GATHERING-FORM WALKER::WALK-MULTIPLE-VALUE-SETQ |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| VARIABLE-DECLARATION |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| ITERATE::SIMPLE-EXPAND-GATHERING-FORM ITERATE::RENAME-AND-CAPTURE-VARIABLES ITERATE::VARIABLE-SAME-P GET-FUNCTION-GENERATOR GET-NEW-FUNCTION-GENERATOR TRACE-METHOD-INTERNAL ONE-INDEX-DFUN-INFO ONE-CLASS-DFUN-INFO MAP-ALL-ORDERS NOTE-PV-TABLE-REFERENCE WALKER::RELIST-INTERNAL MAKE-DFUN-CALL WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA OPTIMIZE-GF-CALL-INTERNAL WALKER::WALK-COMPILER-LET |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| SKIP-FAST-SLOT-ACCESS-P WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET WALKER::WALK-LET* WALKER::WALK-LOCALLY |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| WALKER::WALK-MACROLET |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| FIX-SLOT-ACCESSORS |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| WALKER::WALK-MULTIPLE-VALUE-BIND |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| WALKER::WALK-SETQ |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| WALKER::WALK-SYMBOL-MACROLET |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| EMIT-SLOT-READ-FORM WALKER::WALK-TAGBODY EMIT-BOUNDP-CHECK WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG WALKER::WALK-NAMED-LAMBDA WALKER::WALK-PROG* EXPAND-DEFGENERIC EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP MAKE-METHOD-INITARGS-FORM-INTERNAL ENTRY-IN-CACHE-P CONVERT-TABLE MAKE-METHOD-SPEC TRACE-EMF-CALL-INTERNAL FLUSH-CACHE-TRAP SET-FUNCTION-NAME-1 OBSOLETE-INSTANCE-TRAP COMPUTE-PRECEDENCE PRINT-STD-INSTANCE |SETF PCL METHOD-FUNCTION-GET| |SETF PCL PLIST-VALUE| WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| INITIALIZE-INTERNAL-SLOT-GFS* |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| COMPUTE-EFFECTIVE-METHOD SORT-APPLICABLE-METHODS SORT-METHODS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T) T) |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| LOAD-FUNCTION-GENERATOR EXPAND-EMF-CALL-METHOD MAKE-FGEN BOOTSTRAP-MAKE-SLOT-DEFINITIONS BOOTSTRAP-ACCESSOR-DEFINITIONS1 MAKE-FINAL-ORDINARY-DFUN-INTERNAL WALKER::WALK-TEMPLATE-HANDLE-REPEAT COMPUTE-PV-SLOT WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS OPTIMIZE-ACCESSOR-CALL MAKE-METHOD-INITARGS-FORM-INTERNAL1 UPDATE-SLOTS-IN-PV MAKE-PARAMETER-REFERENCES MAKE-EMF-CACHE GET-MAKE-INSTANCE-FUNCTION-INTERNAL |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| MAKE-INSTANCE-FUNCTION-COMPLEX |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| MAKE-INSTANCE-FUNCTION-SIMPLE |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| OPTIMIZE-GENERIC-FUNCTION-CALL REAL-MAKE-METHOD-INITARGS-FORM |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))|)) (PROCLAIM '(FTYPE (FUNCTION (T T *) T) MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE MAKE-EMF-FROM-METHOD EXPAND-EFFECTIVE-METHOD-FUNCTION NAMED-OBJECT-PRINT-FUNCTION FIND-CLASS-FROM-CELL FIND-CLASS-PREDICATE-FROM-CELL INITIALIZE-INFO GET-EFFECTIVE-METHOD-FUNCTION1 GET-DECLARATION GET-METHOD-FUNCTION-PV-CELL EMIT-MISS METHOD-FUNCTION-GET PROBE-CACHE MAP-CACHE PRECOMPUTE-EFFECTIVE-METHODS RECORD-DEFINITION WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR REAL-ADD-METHOD REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION REAL-ENSURE-GF-USING-CLASS--NULL COMPUTE-SECONDARY-DISPATCH-FUNCTION1 ENSURE-GENERIC-FUNCTION-USING-CLASS)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T) T) REAL-LOAD-DEFCLASS WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1 BOOTSTRAP-MAKE-SLOT-DEFINITION EMIT-SLOT-ACCESS OPTIMIZE-GF-CALL SET-ARG-INFO1 LOAD-DEFCLASS MAKE-EARLY-CLASS-DEFINITION |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T) T) |(FAST-METHOD SLOT-MISSING (T T T T))| EXPAND-DEFMETHOD LOAD-DEFMETHOD-INTERNAL)) (PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) GET-CACHE FILL-CACHE-FROM-CACHE-P)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) EMIT-DLAP GET-SECONDARY-DISPATCH-FUNCTION1)) (PROCLAIM '(FTYPE (FUNCTION (T T T *) T) CHECK-INITARGS-2-PLIST CHECK-INITARGS-2-LIST WALKER::WALK-ARGLIST MAKE-EMF-CALL CAN-OPTIMIZE-ACCESS1 EMIT-FETCH-WRAPPER FILL-CACHE REAL-GET-METHOD CHECK-INITARGS-1 GET-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) LOAD-DEFMETHOD MAKE-DEFMETHOD-FORM MAKE-DEFMETHOD-FORM-INTERNAL EARLY-MAKE-A-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE EARLY-ADD-NAMED-METHOD REAL-ADD-NAMED-METHOD)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T) T) GET-SECONDARY-DISPATCH-FUNCTION2)) (PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) (PROCLAIM '(FTYPE (FUNCTION (T T T T T T T T T *) T) BOOTSTRAP-INITIALIZE-CLASS)) (PROCLAIM '(FTYPE (FUNCTION NIL *) COUNT-ALL-DFUNS EMIT-N-N-READERS EMIT-N-N-WRITERS)) (PROCLAIM '(FTYPE (FUNCTION (*) *) UNTRACE-METHOD LIST-LARGE-CACHES UPDATE-MAKE-INSTANCE-FUNCTION-TABLE INVALID-METHOD-ERROR METHOD-COMBINATION-ERROR)) (PROCLAIM '(FTYPE (FUNCTION NIL T) RENEW-SYS-FILES GET-EFFECTIVE-METHOD-GENSYM SHOW-EMF-CALL-TRACE BOOTSTRAP-META-BRAID BOOTSTRAP-BUILT-IN-CLASSES LIST-ALL-DFUNS DEFAULT-METHOD-ONLY-DFUN-INFO INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST CACHES-TO-ALLOCATE UPDATE-DISPATCH-DFUNS MAKE-CACHE IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P ALLOCATE-FUNCALLABLE-INSTANCE-2 %%ALLOCATE-INSTANCE--CLASS ALLOCATE-FUNCALLABLE-INSTANCE-1 DISPATCH-DFUN-INFO INITIAL-DISPATCH-DFUN-INFO INITIAL-DFUN-INFO NO-METHODS-DFUN-INFO SHOW-FREE-CACHE-VECTORS MAKE-CPD MAKE-ARG-INFO SHOW-DFUN-CONSTRUCTORS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) (PROCLAIM '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO| |__si::MAKE-NO-METHODS| |__si::MAKE-INITIAL| |__si::MAKE-INITIAL-DISPATCH| |__si::MAKE-DISPATCH| |__si::MAKE-DEFAULT-METHOD-ONLY| |__si::MAKE-ACCESSOR-DFUN-INFO| |__si::MAKE-ONE-INDEX-DFUN-INFO| MAKE-FAST-METHOD-CALL |__si::MAKE-N-N| MAKE-FAST-INSTANCE-BOUNDP |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS| |__si::MAKE-ONE-INDEX| |__si::MAKE-CHECKING| |__si::MAKE-ARG-INFO| FIX-EARLY-GENERIC-FUNCTIONS STRING-APPEND |__si::MAKE-CACHING| |__si::MAKE-CONSTANT-VALUE| FALSE |STRUCTURE-OBJECT class constructor| PV-WRAPPERS-FROM-PV-ARGS MAKE-PV-TABLE |__si::MAKE-PV-TABLE| INTERN-PV-TABLE CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-STD-INSTANCE| MAKE-INITIALIZE-INFO |__si::MAKE-CACHE| MAKE-PROGN WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| MAKE-METHOD-CALL TRUE USE-PACKAGE-PCL ZERO)) (PROCLAIM '(FTYPE (FUNCTION (T) *) TYPE-FROM-SPECIALIZER *NORMALIZE-TYPE DEFAULT-CODE-CONVERTER CONVERT-TO-SYSTEM-TYPE EMIT-CONSTANT-VALUE PCL-DESCRIBE GET-GENERIC-FUNCTION-INFO EARLY-METHOD-FUNCTION EARLY-METHOD-STANDARD-ACCESSOR-SLOT-NAME SPECIALIZER-FROM-TYPE CLASS-EQ-TYPE STRUCTURE-WRAPPER FIND-STRUCTURE-CLASS MAKE-DISPATCH-DFUN FIND-WRAPPER PARSE-DEFMETHOD PROTOTYPES-FOR-MAKE-METHOD-LAMBDA EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER EMIT-TWO-CLASS-READER EMIT-TWO-CLASS-WRITER EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS NET-CODE-CONVERTER EMIT-IN-CHECKING-CACHE-P COMPILE-IIS-FUNCTIONS ANALYZE-LAMBDA-LIST COMPUTE-APPLICABLE-METHODS-EMF GET-DISPATCH-FUNCTION GENERIC-FUNCTION-NAME-P MAKE-FINAL-DISPATCH-DFUN STRUCTURE-SLOTD-INIT-FORM PARSE-METHOD-GROUP-SPECIFIER METHOD-PROTOTYPE-FOR-GF EARLY-COLLECT-INHERITANCE)) (PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) (PROCLAIM '(FTYPE (FUNCTION (T) T) COMPILE-LAMBDA-UNCOMPILED GF-LAMBDA-LIST CACHING-CACHE CONSTANT-VALUE-CACHE COMPILE-LAMBDA-DEFERRED FUNCALLABLE-INSTANCE-P SHOW-DFUN-COSTS RESET-CLASS-INITIALIZE-INFO GET-CACHE-VECTOR CONSTANT-SYMBOL-P FREE-CACHE-VECTOR EARLY-METHOD-LAMBDA-LIST ARG-INFO-VALID-P DFUN-ARG-SYMBOL EARLY-METHOD-CLASS EARLY-GF-P EARLY-GF-NAME CACHING-DFUN-INFO COMPUTE-APPLICABLE-METHODS-EMF-STD-P CONSTANT-VALUE-DFUN-INFO RESET-CLASS-INITIALIZE-INFO-1 FREE-CACHE PARSE-SPECIALIZERS RESET-INITIALIZE-INFO EARLY-METHOD-QUALIFIERS PROCLAIM-INCOMPATIBLE-SUPERCLASSES WRAPPER-OF EARLY-METHOD-STANDARD-ACCESSOR-P FUNCTION-PRETTY-ARGLIST GET-MAKE-INSTANCE-FUNCTION CHECK-WRAPPER-VALIDITY UNPARSE-SPECIALIZERS %SYMBOL-FUNCTION FINAL-ACCESSOR-DFUN-TYPE COMPLICATED-INSTANCE-CREATION-METHOD DEFAULT-STRUCTUREP UPDATE-GF-INFO CACHE-OWNER DEFAULT-STRUCTURE-INSTANCE-P DEFAULT-STRUCTURE-TYPE STRUCTURE-TYPE COMPUTE-STD-CPL-PHASE-2 GET-PV-CELL-FOR-CLASS STRUCTURE-TYPE-INCLUDED-TYPE-NAME STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST CACHE-P STRUCTURE-SLOTD-NAME STRUCTURE-SLOTD-ACCESSOR-SYMBOL SFUN-P DEFAULT-SECONDARY-DISPATCH-FUNCTION STRUCTURE-SLOTD-WRITER-FUNCTION FIND-CYCLE-REASONS EARLY-CLASS-DEFINITION ECD-SOURCE STRUCTURE-SLOTD-TYPE FORMAT-CYCLE-REASONS ECD-METACLASS CPD-CLASS EARLY-CLASS-PRECEDENCE-LIST METHODS-CONTAIN-EQL-SPECIALIZER-P MAKE-TYPE-PREDICATE CPD-SUPERS DEFAULT-TEST-CONVERTER EXPAND-LONG-DEFCOMBIN INITIAL-P EARLY-CLASS-NAME-OF FORCE-CACHE-FLUSHES CPD-AFTER EXPAND-SHORT-DEFCOMBIN MAKE-CALL-METHODS DEFAULT-CONSTANT-CONVERTER EARLY-CLASS-SLOTDS INITIAL-DISPATCH-P DISPATCH-P EARLY-SLOT-DEFINITION-NAME SLOT-READER-SYMBOL GBOUNDP GMAKUNBOUND EARLY-SLOT-DEFINITION-LOCATION WALKER::ENV-LOCK DEFAULT-CONSTANTP MAKE-INITIAL-DFUN DEFAULT-METHOD-ONLY-P FGEN-TEST EARLY-ACCESSOR-METHOD-SLOT-NAME SLOT-WRITER-SYMBOL LOOKUP-FGEN WALKER::ENV-DECLARATIONS ACCESSOR-DFUN-INFO-P WALKER::ENV-LEXICAL-VARIABLES FGEN-GENERATOR FGEN-SYSTEM LIST-DFUN %FBOUNDP SLOT-BOUNDP-SYMBOL ONE-INDEX-DFUN-INFO-P CCLOSUREP MAP-ALL-GENERIC-FUNCTIONS FAST-METHOD-CALL-P MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION N-N-P EARLY-CLASS-DIRECT-SUBCLASSES FAST-INSTANCE-BOUNDP-P MAKE-FUNCTION-INLINE METHOD-FUNCTION-PV-TABLE LIST-LARGE-CACHE METHOD-FUNCTION-METHOD STORE-FGEN CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-P INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS UNENCAPSULATED-FDEFINITION MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION METHOD-FUNCTION-NEEDS-NEXT-METHODS-P DFUN-INFO-P MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION FTYPE-DECLARATION-FROM-LAMBDA-LIST NO-METHODS-P WALKER::ENV-WALK-FUNCTION FGEN-GENSYMS WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE TWO-CLASS-P COUNT-DFUN ARG-INFO-LAMBDA-LIST MAKE-INITFUNCTION ARG-INFO-PRECEDENCE MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION ARG-INFO-METATYPES ITERATE::VARIABLES-FROM-LET FGEN-GENERATOR-LAMBDA WALKER::ENV-WALK-FORM ARG-INFO-NUMBER-OPTIONAL MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION ARG-INFO-KEY/REST-P INITIALIZE-INFO-P ONE-INDEX-P ECD-CLASS-NAME ARG-INFO-KEYWORDS COPY-CACHE GF-INFO-SIMPLE-ACCESSOR-TYPE COMPUTE-LINE-SIZE GF-PRECOMPUTE-DFUN-AND-EMF-P CANONICAL-SLOT-NAME GF-INFO-STATIC-C-A-M-EMF WALKER::GET-WALKER-TEMPLATE CHECKING-P EARLY-CLASS-SLOTS GF-INFO-C-A-M-EMF-STD-P STRUCTURE-TYPE-INTERNAL-SLOTDS GF-INFO-FAST-MF-P UNDEFMETHOD-1 EARLY-COLLECT-CPL EARLY-COLLECT-SLOTS ARG-INFO-P METHOD-LL->GENERIC-FUNCTION-LL FAST-METHOD-CALL-ARG-INFO EARLY-COLLECT-DEFAULT-INITARGS ARG-INFO-NKEYS ECD-SUPERCLASS-NAMES GF-DFUN-CACHE GF-DFUN-INFO METHOD-CALL-P STRUCTURE-SLOT-BOUNDP FUNCTION-RETURNING-NIL ITERATE::SEQUENCE-ACCESSOR ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS EVAL-FORM ONE-INDEX-DFUN-INFO-INDEX ECD-OTHER-INITARGS SLOT-INITARGS-FROM-STRUCTURE-SLOTD TYPE-CLASS ONE-CLASS-WRAPPER0 EXTRACT-PARAMETERS CLASS-PREDICATE EXTRACT-REQUIRED-PARAMETERS MAKE-CLASS-EQ-PREDICATE TWO-CLASS-WRAPPER1 MAKE-EQL-PREDICATE CHECKING-FUNCTION BOOTSTRAP-ACCESSOR-DEFINITIONS INITIALIZE-INFO-KEY BOOTSTRAP-CLASS-PREDICATES GET-BUILT-IN-CLASS-SYMBOL INITIALIZE-INFO-WRAPPER GET-BUILT-IN-WRAPPER-SYMBOL DO-STANDARD-DEFSETF-1 CACHING-P GFS-OF-TYPE LEGAL-CLASS-NAME-P STRUCTURE-TYPE-P CONSTANT-VALUE-P USE-DEFAULT-METHOD-ONLY-DFUN-P INITIALIZE-INFO-CACHED-COMBINED-INITARGS-FORM-LIST WRAPPER-FIELD NEXT-WRAPPER-FIELD SETFBOUNDP GET-SETF-FUNCTION-NAME USE-CACHING-DFUN-P MAKE-PV-TYPE-DECLARATION MAKE-CALLS-TYPE-DECLARATION MAP-SPECIALIZERS SLOT-VECTOR-SYMBOL MAKE-PERMUTATION-VECTOR VARIABLE-GLOBALLY-SPECIAL-P STRUCTURE-OBJECT-P EXPAND-MAKE-INSTANCE-FORM MAKE-CONSTANT-FUNCTION FUNCTION-RETURNING-T SORT-SLOTS SORT-CALLS SYMBOL-PKG-NAME CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P INITIALIZE-INFO-BOUND-SLOTS INITIALIZE-INFO-CACHED-VALID-P GET-MAKE-INSTANCE-FUNCTIONS INITIALIZE-INFO-CACHED-RI-VALID-P INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST INITIALIZE-INFO-CACHED-NEW-KEYS UPDATE-C-A-M-GF-INFO INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION UPDATE-GF-SIMPLE-ACCESSOR-TYPE UPDATE-GFS-OF-CLASS INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION DO-STANDARD-DEFSETFS-FOR-DEFCLASS STANDARD-SVUC-METHOD INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION %CCLOSURE-ENV STRUCTURE-SVUC-METHOD INITIALIZE-INFO-CACHED-CONSTANTS CLASS-OF METHOD-FUNCTION-PLIST INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION INITIALIZE-INFO-CACHED-MAKE-INSTANCE-FUNCTION-SYMBOL INTERNED-SYMBOL-P GDEFINITION UPDATE-CLASS-CAN-PRECEDE-P %STD-INSTANCE-WRAPPER %STD-INSTANCE-SLOTS PV-TABLEP STD-INSTANCE-P COMPUTE-MCASE-PARAMETERS COMPUTE-CLASS-SLOTS MAKE-PV-TABLE-TYPE-DECLARATION INTERN-EQL-SPECIALIZER NET-TEST-CONVERTER MAKE-INSTANCE-FUNCTION-SYMBOL UPDATE-ALL-C-A-M-GF-INFO UPDATE-PV-TABLE-CACHE-INFO DFUN-INFO-CACHE EXTRACT-LAMBDA-LIST NO-METHODS-CACHE ARG-INFO-APPLYP CACHING-DFUN-COST INITIAL-CACHE SYSTEM:%STRUCTURE-NAME INITIAL-DISPATCH-CACHE SYSTEM:%COMPILED-FUNCTION-NAME CHECK-CACHE DISPATCH-CACHE CLASS-FROM-TYPE DEFAULT-METHOD-ONLY-CACHE DNET-METHODS-P ACCESSOR-DFUN-INFO-CACHE METHOD-FUNCTION-FROM-FAST-FUNCTION ONE-INDEX-DFUN-INFO-CACHE ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE METHOD-CALL-CALL-METHOD-ARGS KEYWORD-SPEC-NAME N-N-CACHE GENERIC-CLOBBERS-FUNCTION N-N-ACCESSOR-TYPE FAST-METHOD-CALL-PV-CELL WRAPPER-FOR-STRUCTURE ONE-CLASS-CACHE EXTRACT-SPECIALIZER-NAMES FAST-METHOD-CALL-NEXT-METHOD-CALL ONE-CLASS-ACCESSOR-TYPE ONE-CLASS-INDEX BUILT-IN-WRAPPER-OF TWO-CLASS-CACHE BUILT-IN-OR-STRUCTURE-WRAPPER1 TWO-CLASS-ACCESSOR-TYPE TWO-CLASS-INDEX GET-MAKE-INSTANCE-FUNCTION-SYMBOL ALLOCATE-CACHE-VECTOR TWO-CLASS-WRAPPER0 FLUSH-CACHE-VECTOR-INTERNAL ONE-INDEX-CACHE EARLY-CLASS-NAME ONE-INDEX-ACCESSOR-TYPE ONE-INDEX-INDEX INTERN-FUNCTION-NAME CHECKING-CACHE)) (PROCLAIM '(FTYPE (FUNCTION (T *) *) COERCE-TO-CLASS GET-METHOD-FUNCTION GET-FUNCTION GET-FUNCTION1 PARSE-METHOD-OR-SPEC EXTRACT-DECLARATIONS GET-DFUN-CONSTRUCTOR MAP-ALL-CLASSES MAKE-CACHING-DFUN MAKE-METHOD-FUNCTION-INTERNAL PARSE-SPECIALIZED-LAMBDA-LIST MAKE-METHOD-LAMBDA-INTERNAL MAKE-CONSTANT-VALUE-DFUN MAKE-FINAL-DFUN-INTERNAL COMPILE-LAMBDA WALK-FORM MACROEXPAND-ALL ENSURE-CLASS ENSURE-GENERIC-FUNCTION DISPATCH-DFUN-COST)) (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) (PROCLAIM '(FTYPE (FUNCTION (T *) T) CAPITALIZE-WORDS INITIALIZE-INTERNAL-SLOT-GFS FIND-CLASS MAKE-TYPE-PREDICATE-NAME SET-DFUN TRACE-METHOD FIND-CLASS-CELL MAKE-FINAL-DFUN PV-TABLE-LOOKUP-PV-ARGS USE-DISPATCH-DFUN-P WALKER::RELIST* WALKER::RELIST FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS USE-CONSTANT-VALUE-DFUN-P MAKE-EARLY-GF ALLOCATE-FUNCALLABLE-INSTANCE SET-ARG-INFO INITIALIZE-METHOD-FUNCTION UPDATE-DFUN MAKE-SPECIALIZABLE ALLOCATE-STRUCTURE-INSTANCE ALLOCATE-STANDARD-INSTANCE WALKER::WALKER-ENVIRONMENT-BIND-1 ITERATE::FUNCTION-LAMBDA-P ITERATE::MAYBE-WARN MAKE-WRAPPER)) (PROCLAIM '(FTYPE (FUNCTION (T T) *) SLOT-BOUNDP SLOT-VALUE SAUT-CLASS SPECIALIZER-APPLICABLE-USING-TYPE-P COMPUTE-TEST GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE CLASS-APPLICABLE-USING-CLASS-P SAUT-AND SAUT-NOT SAUT-PROTOTYPE DESTRUCTURE ENSURE-CLASS-VALUES MAKE-DIRECT-SLOTD SLOT-MAKUNBOUND MAKE-INSTANCE-FUNCTION-TRAP GENERATE-FAST-CLASS-SLOT-ACCESS-P MUTATE-SLOTS-AND-CALLS INVOKE-EMF EMIT-DEFAULT-ONLY-FUNCTION SPLIT-DECLARATIONS EMIT-DEFAULT-ONLY SLOT-NAME-LISTS-FROM-SLOTS EMIT-CHECKING UPDATE-SLOT-VALUE-GF-INFO EMIT-CACHING SDFUN-FOR-CACHING SLOT-UNBOUND-INTERNAL MAKE-INSTANCE-1 SET-FUNCTION-NAME COMPUTE-STD-CPL-PHASE-1 FORM-LIST-TO-LISP FIND-SUPERCLASS-CHAIN SAUT-CLASS-EQ COMPUTE-APPLICABLE-METHODS-USING-TYPES CHECK-INITARGS-VALUES SAUT-EQL INSURE-DFUN *SUBTYPEP ITERATE::PARSE-DECLARATIONS INITIAL-DFUN)) (PROCLAIM '(FTYPE (FUNCTION (T T) T) ADD-METHOD DO-SATISFIES-DEFTYPE MEMF-CONSTANT-CONVERTER COMPUTE-CONSTANTS CLASS-CAN-PRECEDE-P SAUT-NOT-CLASS SAUT-NOT-CLASS-EQ SAUT-NOT-PROTOTYPE GF-MAKE-FUNCTION-FROM-EMF SAUT-NOT-EQL SUPERCLASSES-COMPATIBLE-P CLASSES-HAVE-COMMON-SUBCLASS-P DESCRIBE-PACKAGE PRINTING-RANDOM-THING-INTERNAL MAKE-CLASS-PREDICATE METHOD-FUNCTION-RETURNING-NIL METHOD-FUNCTION-RETURNING-T VARIABLE-CLASS MAKE-PLIST REMTAIL DESTRUCTURE-INTERNAL ACCESSOR-MISS-FUNCTION UPDATE-INITIALIZE-INFO-INTERNAL N-N-DFUN-INFO MAKE-CAXR MAKE-CDXR CHECKING-DFUN-INFO FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-PV-TABLE-INTERNAL FIND-SLOT-DEFINITION WALKER::WALK-REPEAT-EVAL WALKER::NOTE-DECLARATION MAKE-DFUN-LAMBDA-LIST WALKER::NOTE-LEXICAL-BINDING MAKE-DLAP-LAMBDA-LIST ADD-DIRECT-SUBCLASSES COMPUTE-PV MAKE-DFUN-ARG-LIST COMPUTE-CALLS MAKE-FAST-METHOD-CALL-LAMBDA-LIST UPDATE-ALL-PV-TABLE-CACHES UPDATE-CLASS MAP-PV-TABLE-REFERENCES-OF ADD-SLOT-ACCESSORS WALKER::ENVIRONMENT-FUNCTION REMOVE-DIRECT-SUBCLASSES REMOVE-SLOT-ACCESSORS SYMBOL-LESSP SYMBOL-OR-CONS-LESSP |SETF PCL FIND-CLASS| |SETF PCL FIND-CLASS-PREDICATE| PV-WRAPPERS-FROM-ALL-ARGS PV-TABLE-LOOKUP PROCLAIM-DEFGENERIC UPDATE-CPL LIST-EQ UPDATE-SLOTS COMPUTE-APPLICABLE-METHODS-FUNCTION VARIABLE-LEXICAL-P VARIABLE-SPECIAL-P UPDATE-INITS UPDATE-STD-OR-STR-METHODS SET-STANDARD-SVUC-METHOD EMIT-1-NIL-DLAP PLIST-VALUE SET-STRUCTURE-SVUC-METHOD EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES-INTERNAL EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION MEC-ALL-CLASSES %SET-CCLOSURE-ENV MEC-ALL-CLASS-LISTS REDEFINE-FUNCTION METHODS-CONVERTER COMPUTE-LAYOUT NO-SLOT PV-WRAPPERS-FROM-ALL-WRAPPERS NET-CONSTANT-CONVERTER AUGMENT-TYPE CHANGE-CLASS-INTERNAL VALUE-FOR-CACHING |SETF PCL METHOD-FUNCTION-PLIST| GET-KEY-ARG GET-KEY-ARG1 SET-METHODS SET-FUNCTION-PRETTY-ARGLIST FIND-STANDARD-II-METHOD MAKE-EARLY-ACCESSOR DOCTOR-DFUN-FOR-THE-DEBUGGER COMPUTE-STD-CPL |SETF PCL GDEFINITION| MAKE-DISCRIMINATING-FUNCTION-ARGLIST ADD-FORMS CPL-INCONSISTENT-ERROR REDIRECT-EARLY-FUNCTION-INTERNAL ADD-TO-CVECTOR BOOTSTRAP-SLOT-INDEX QUALIFIER-CHECK-RUNTIME CPL-FORWARD-REFERENCED-CLASS-ERROR REAL-REMOVE-METHOD WALKER::ENVIRONMENT-MACRO CANONICALIZE-SLOT-SPECIFICATION CANONICALIZE-DEFCLASS-OPTION SET-WRAPPER DEAL-WITH-ARGUMENTS-OPTION PARSE-QUALIFIER-PATTERN SWAP-WRAPPERS-AND-SLOTS ITERATE::MV-SETQ MAKE-UNORDERED-METHODS-EMF CLASS-MIGHT-PRECEDE-P ITERATE::EXTRACT-SPECIAL-BINDINGS WALKER::VARIABLE-SYMBOL-MACRO-P RAISE-METATYPE SLOT-EXISTS-P PROCLAIM-DEFMETHOD STANDARD-INSTANCE-ACCESS REMOVE-METHOD SET-FUNCALLABLE-INSTANCE-FUNCTION SYSTEM:%SET-COMPILED-FUNCTION-NAME FDEFINE-CAREFULLY MAKE-INTERNAL-READER-METHOD-FUNCTION MAKE-STD-READER-METHOD-FUNCTION MAKE-STD-WRITER-METHOD-FUNCTION ITERATE::SIMPLE-EXPAND-ITERATE-FORM MAKE-STD-BOUNDP-METHOD-FUNCTION)) (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) (IN-PACKAGE "PCL") (DOLIST (V '(|(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-WRITER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-WRITER-METHOD SLOT-OBJECT METHODS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| ADD-READER-METHOD SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT REMOVE-READER-METHOD |LISP::T class predicate| EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)| OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL |PCL::STANDARD-OBJECT class predicate| |PCL::STANDARD-SLOT-DEFINITION class predicate| |PCL::STANDARD-DIRECT-SLOT-DEFINITION class predicate| |PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| |PCL::STANDARD-METHOD-COMBINATION class predicate| |(FAST-READER-METHOD SLOT-OBJECT METHOD)| |PCL::BUILT-IN-CLASS class predicate| SPECIALIZER-TYPE |LISP::RATIO class predicate| |LISP::RATIONAL class predicate| GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)| CLASS-DEFSTRUCT-CONSTRUCTOR |(FAST-READER-METHOD SLOT-OBJECT SOURCE)| |(FAST-READER-METHOD DEFINITION-SOURCE-MIXIN SOURCE)| METHOD-FAST-FUNCTION |(SETF GENERIC-FUNCTION-METHODS)| |(SETF GF-PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-READER-METHOD SLOT-OBJECT ARG-INFO)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| SPECIALIZERP EXACT-CLASS-SPECIALIZER-P |(FAST-READER-METHOD SLOT-OBJECT WRAPPER)| |(FAST-READER-METHOD PCL-CLASS WRAPPER)| |(FAST-READER-METHOD SLOT-OBJECT INITARGS)| |(FAST-READER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |LISP::CHARACTER class predicate| COMPATIBLE-META-CLASS-CHANGE-P |LISP::SEQUENCE class predicate| |(FAST-READER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(FAST-READER-METHOD CLASS CLASS-EQ-SPECIALIZER)| |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)| |(BOUNDP READERS)| UPDATE-GF-DFUN |(BOUNDP CLASS-PRECEDENCE-LIST)| |(BOUNDP ACCESSOR-FLAGS)| |(BOUNDP LOCATION)| |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)| ACCESSOR-METHOD-SLOT-NAME |(BOUNDP SPECIALIZERS)| |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-CLASS |(BOUNDP PRETTY-ARGLIST)| |PCL::PCL-CLASS class predicate| |PCL::STD-CLASS class predicate| |(BOUNDP DEFSTRUCT-FORM)| |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)| CLASS-EQ-SPECIALIZER-P |(FAST-BOUNDP-METHOD SLOT-OBJECT SOURCE)| SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)| REMOVE-WRITER-METHOD |(BOUNDP WRITER-FUNCTION)| |(BOUNDP INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ARG-INFO)| STRUCTURE-CLASS-P |(BOUNDP WRITERS)| |(BOUNDP INITFORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRAPPER)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITARGS)| |LISP::BIT-VECTOR class predicate| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| UPDATE-CONSTRUCTORS |(BOUNDP SLOT-NAME)| |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| DOCUMENTATION |(BOUNDP FUNCTION)| |(BOUNDP GENERIC-FUNCTION)| |(BOUNDP LAMBDA-LIST)| METHOD-PRETTY-ARGLIST |(BOUNDP SLOT-DEFINITION)| |LISP::ARRAY class predicate| |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS |PCL::DEFINITION-SOURCE-MIXIN class predicate| |(BOUNDP DFUN-STATE)| |(BOUNDP FROM-DEFCLASS-P)| |(READER METHOD)| |(CALL STANDARD-COMPUTE-EFFECTIVE-METHOD)| |(BOUNDP FAST-FUNCTION)| |LISP::COMPLEX class predicate| |(BOUNDP METHOD-CLASS)| |(READER SOURCE)| |(BOUNDP INTERNAL-WRITER-FUNCTION)| |(BOUNDP INTERNAL-READER-FUNCTION)| |(BOUNDP METHOD-COMBINATION)| ACCESSOR-METHOD-CLASS |(BOUNDP DIRECT-SLOTS)| |(BOUNDP DIRECT-METHODS)| |(BOUNDP BOUNDP-FUNCTION)| |(BOUNDP DIRECT-SUBCLASSES)| |(BOUNDP DIRECT-SUPERCLASSES)| |(BOUNDP METHODS)| |(BOUNDP OPTIONS)| |(WRITER METHOD)| |PCL::DEPENDENT-UPDATE-MIXIN class predicate| GENERIC-FUNCTION-PRETTY-ARGLIST |(WRITER SOURCE)| |(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))| |(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))| |(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))| |(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))| |(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))| MAKE-BOUNDP-METHOD-FUNCTION |LISP::STRING class predicate| |(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))| |(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))| |PCL::METAOBJECT class predicate| |(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))| |(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))| |(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))| |(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))| |(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))| |(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))| |(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))| |(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))| |(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))| |(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))| |(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))| |(FAST-METHOD CHANGE-CLASS (T SYMBOL))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))| |(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))| |(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))| |(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))| |(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))| |(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))| |(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD MAKE-INSTANCE (SYMBOL))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))| |(FAST-METHOD SPECIALIZER-CLASS (CLASS))| |(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))| |(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))| |(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))| |(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))| |(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))| |(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))| |(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))| |(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))| |(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))| |(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))| |(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))| |(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))| |(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))| |(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))| |(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))| |(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))| |(FAST-METHOD MAKE-INSTANCE (CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))| |(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))| |(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))| |(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))| |(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))| CLASS-PREDICATE-NAME |PCL::STRUCTURE-OBJECT class predicate| |PCL::STRUCTURE-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| |PCL::STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| |LISP::SYMBOL class predicate| CLASSP |PCL::EFFECTIVE-SLOT-DEFINITION class predicate| |(COMBINED-METHOD SHARED-INITIALIZE)| LEGAL-QUALIFIERS-P ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P |LISP::VECTOR class predicate| |SETF PCL GENERIC-FUNCTION-NAME| |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)| |(READER READERS)| DESCRIBE-OBJECT |(READER CLASS-PRECEDENCE-LIST)| |(READER ACCESSOR-FLAGS)| |(READER LOCATION)| |(READER DOCUMENTATION)| CLASS-INITIALIZE-INFO |(SETF CLASS-SLOT-VALUE)| MAKE-WRITER-METHOD-FUNCTION |SETF PCL GF-DFUN-STATE| |(READER INCOMPATIBLE-SUPERCLASS-LIST)| |(READER SPECIALIZERS)| |(READER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF CLASS-INITIALIZE-INFO)| |(READER PRETTY-ARGLIST)| |(READER DEFSTRUCT-FORM)| |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME| |(WRITER READER-FUNCTION)| |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)| |(WRITER PREDICATE-NAME)| |(WRITER READERS)| |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)| INITIALIZE-INTERNAL-SLOT-FUNCTIONS |SETF PCL SLOT-DEFINITION-TYPE| |(WRITER CLASS-PRECEDENCE-LIST)| |(READER WRITERS)| |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)| METHOD-COMBINATION-P |(WRITER LOCATION)| |(WRITER DOCUMENTATION)| |(CALL REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION)| |SETF PCL GENERIC-FUNCTION-METHODS| |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION| |SETF PCL METHOD-GENERIC-FUNCTION| |(READER SLOT-NAME)| |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL SLOT-ACCESSOR-STD-P| |(CALL REAL-MAKE-METHOD-INITARGS-FORM)| |(READER ALLOCATION)| |(WRITER SPECIALIZERS)| |(CALL REAL-ENSURE-GF-USING-CLASS--NULL)| |(WRITER IDENTITY-WITH-ONE-ARGUMENT)| |(SETF METHOD-GENERIC-FUNCTION)| |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P |SETF PCL OBJECT-PLIST| |LISP::FLOAT class predicate| |(WRITER DEFSTRUCT-FORM)| |(READER FUNCTION)| |(READER GENERIC-FUNCTION)| |(READER LAMBDA-LIST)| |(READER SLOT-DEFINITION)| |PCL::CLASS-PROTOTYPE-SPECIALIZER class predicate| |SETF PCL SLOT-DEFINITION-INITFORM| |SETF PCL CLASS-DEFSTRUCT-FORM| |(READER CAN-PRECEDE-LIST)| |SETF PCL GENERIC-FUNCTION-METHOD-CLASS| |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)| |(WRITER INITFUNCTION)| |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P |(WRITER INITFORM)| |(READER DFUN-STATE)| |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST| |SETF PCL SLOT-ACCESSOR-FUNCTION| |SETF PCL SLOT-DEFINITION-LOCATION| |SETF PCL SLOT-DEFINITION-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION| |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION| |SETF PCL SLOT-DEFINITION-ALLOCATION| |SETF PCL SLOT-DEFINITION-INITFUNCTION| |(WRITER SLOT-NAME)| |(BOUNDP NAME)| |(WRITER ALLOCATION)| |(READER FAST-FUNCTION)| |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)| |(READER INTERNAL-WRITER-FUNCTION)| |(READER INTERNAL-READER-FUNCTION)| |(READER METHOD-COMBINATION)| METHOD-COMBINATION-OPTIONS |(READER DIRECT-SLOTS)| |(READER DIRECT-METHODS)| |SETF PCL SLOT-DEFINITION-READERS| |(READER BOUNDP-FUNCTION)| |(WRITER FUNCTION)| |(WRITER GENERIC-FUNCTION)| |(READER DIRECT-SUBCLASSES)| |(READER DIRECT-SUPERCLASSES)| |SETF PCL DOCUMENTATION| |(WRITER LAMBDA-LIST)| |LISP::LIST class predicate| FUNCALLABLE-STANDARD-CLASS-P |(FAST-WRITER-METHOD SLOT-OBJECT METHOD)| |(BOUNDP CLASS)| |(WRITER SLOT-DEFINITION)| |(READER METHODS)| |(READER OPTIONS)| |(WRITER CAN-PRECEDE-LIST)| |SETF PCL SLOT-DEFINITION-CLASS| |SETF PCL SLOT-VALUE-USING-CLASS| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-ACCESSOR-SYMBOL)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION DEFSTRUCT-ACCESSOR-SYMBOL)| |(WRITER PROTOTYPE)| |(BOUNDP OBJECT)| |(BOUNDP TYPE)| CLASS-CAN-PRECEDE-LIST |SETF PCL CLASS-DIRECT-SLOTS| |SETF PCL CLASS-SLOTS| SLOT-ACCESSOR-FUNCTION |(BOUNDP PLIST)| |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST| |SETF PCL SLOT-DEFINITION-WRITERS| |(FAST-WRITER-METHOD SLOT-OBJECT SOURCE)| |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)| |(BOUNDP SLOTS)| SLOT-CLASS-P MAKE-READER-METHOD-FUNCTION LEGAL-METHOD-FUNCTION-P |(FAST-WRITER-METHOD SLOT-OBJECT INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-CLASS INITIALIZE-INFO)| |(FAST-WRITER-METHOD SLOT-OBJECT ARG-INFO)| |PCL::PLIST-MIXIN class predicate| |(WRITER FAST-FUNCTION)| |(WRITER METHOD-CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT WRAPPER)| |(WRITER INTERNAL-WRITER-FUNCTION)| |(WRITER INTERNAL-READER-FUNCTION)| |(WRITER METHOD-COMBINATION)| GET-METHOD |(WRITER DIRECT-SLOTS)| |(WRITER DIRECT-METHODS)| |(FAST-WRITER-METHOD SLOT-OBJECT INITARGS)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITARGS)| |(FAST-WRITER-METHOD SLOT-OBJECT OPERATOR)| |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-CONSTRUCTOR)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-CONSTRUCTOR)| |(WRITER BOUNDP-FUNCTION)| |(WRITER DIRECT-SUBCLASSES)| |(WRITER DIRECT-SUPERCLASSES)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-EQ-SPECIALIZER)| |(WRITER METHODS)| |(WRITER OPTIONS)| SHORT-METHOD-COMBINATION-P GF-ARG-INFO SPECIALIZER-METHOD-TABLE MAKE-METHOD-INITARGS-FORM CLASS-DEFSTRUCT-FORM |LISP::INTEGER class predicate| |(FAST-READER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-READER-METHOD CLASS PREDICATE-NAME)| |(FAST-READER-METHOD CLASS NAME)| |(FAST-READER-METHOD SLOT-DEFINITION NAME)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-NAME)| |(FAST-READER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-READER-METHOD SLOT-OBJECT NAME)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION NAME)| GF-PRETTY-ARGLIST SAME-SPECIALIZER-P SLOT-DEFINITION-BOUNDP-FUNCTION SLOT-DEFINITION-WRITER-FUNCTION SLOT-DEFINITION-READER-FUNCTION SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION SLOT-DEFINITION-INTERNAL-READER-FUNCTION |(FAST-READER-METHOD SLOT-OBJECT CLASS)| |(FAST-READER-METHOD SLOT-DEFINITION CLASS)| |(FAST-READER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-READER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD TRACED-METHOD FUNCTION)| |(FAST-READER-METHOD LONG-METHOD-COMBINATION FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-READER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-READER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-READER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT LOCATION)| |(FAST-READER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-READER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD FAST-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-READER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-READER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-READER-METHOD STANDARD-ACCESSOR-METHOD SLOT-DEFINITION)| |(FAST-READER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-READER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION DOCUMENTATION)| |(FAST-READER-METHOD SLOT-OBJECT WRITERS)| |(FAST-READER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-READER-METHOD SLOT-OBJECT READERS)| |(FAST-READER-METHOD SLOT-DEFINITION READERS)| |(FAST-READER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-READER-METHOD STANDARD-METHOD SPECIALIZERS)| |(FAST-READER-METHOD SHORT-METHOD-COMBINATION IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-READER-METHOD SPECIALIZER TYPE)| |(FAST-READER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-READER-METHOD PCL-CLASS PROTOTYPE)| |(FAST-READER-METHOD CLASS-EQ-SPECIALIZER OBJECT)| |(FAST-READER-METHOD CLASS-PROTOTYPE-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-OBJECT OBJECT)| |(FAST-READER-METHOD EQL-SPECIALIZER OBJECT)| |(FAST-READER-METHOD SLOT-DEFINITION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT TYPE)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION TYPE)| |(FAST-READER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-READER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-READER-METHOD SLOT-OBJECT INITFORM)| |(FAST-READER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-READER-METHOD SLOT-OBJECT PLIST)| |(FAST-READER-METHOD PLIST-MIXIN PLIST)| |(FAST-READER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-READER-METHOD PCL-CLASS CAN-PRECEDE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD PCL-CLASS CLASS-PRECEDENCE-LIST)| |(FAST-READER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-READER-METHOD STANDARD-METHOD LAMBDA-LIST)| |(FAST-READER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-READER-METHOD SLOT-OBJECT SLOTS)| |(FAST-READER-METHOD SLOT-CLASS SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-CLASS DIRECT-SLOTS)| |(FAST-READER-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-READER-METHOD SLOT-OBJECT METHODS)| |(FAST-READER-METHOD STANDARD-GENERIC-FUNCTION METHODS)| |(FAST-READER-METHOD SLOT-OBJECT OPTIONS)| |(FAST-READER-METHOD STANDARD-METHOD-COMBINATION OPTIONS)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUBCLASSES)| |(FAST-READER-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-READER-METHOD CLASS DIRECT-SUPERCLASSES)| SLOT-DEFINITION-CLASS EQL-SPECIALIZER-OBJECT |PCL::DIRECT-SLOT-DEFINITION class predicate| CLASS-CONSTRUCTORS |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT |(FAST-BOUNDP-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT NAME)| |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)| SPECIALIZER-DIRECT-GENERIC-FUNCTIONS |(BOUNDP CLASS-EQ-SPECIALIZER)| |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LOCATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DOCUMENTATION)| |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT WRITERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT READERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OBJECT)| |(FAST-BOUNDP-METHOD SLOT-OBJECT TYPE)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INITFORM)| |(SETF SLOT-VALUE-USING-CLASS)| |(SETF SLOT-DEFINITION-CLASS)| |(SETF SLOT-ACCESSOR-FUNCTION)| |(SETF SLOT-DEFINITION-INITFUNCTION)| |(SETF SLOT-DEFINITION-ALLOCATION)| |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)| |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)| |(SETF SLOT-DEFINITION-WRITER-FUNCTION)| |(SETF SLOT-DEFINITION-READER-FUNCTION)| |(SETF SLOT-DEFINITION-LOCATION)| |(BOUNDP DEFSTRUCT-CONSTRUCTOR)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PLIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-BOUNDP-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(SETF SLOT-DEFINITION-WRITERS)| |(SETF SLOT-DEFINITION-READERS)| |(SETF SLOT-DEFINITION-TYPE)| |(SETF SLOT-DEFINITION-INITFORM)| |(BOUNDP INITIALIZE-INFO)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SLOTS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT FROM-DEFCLASS-P)| |(FAST-BOUNDP-METHOD SLOT-OBJECT METHODS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT OPTIONS)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUBCLASSES)| |(FAST-BOUNDP-METHOD SLOT-OBJECT DIRECT-SUPERCLASSES)| |(FAST-INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION GENERIC-FUNCTION-P |PCL::SLOT-DEFINITION class predicate| |LISP::NULL class predicate| |(READER NAME)| |(READER CLASS)| |(FAST-METHOD DESCRIBE-OBJECT (CLASS T))| |(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))| |(FAST-METHOD DESCRIBE-OBJECT (T T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))| |(FAST-METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))| |(FAST-METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))| |(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))| |(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))| |(FAST-METHOD REMOVE-NAMED-METHOD (T T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))| |(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))| |(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))| |(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))| |(FAST-METHOD PRINT-OBJECT (CLASS T))| |(FAST-METHOD PRINT-OBJECT (T T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))| |(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))| |(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))| |(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))| |(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))| |(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))| |(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))| |(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))| |(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))| |(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))| |(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))| |(FAST-METHOD (SETF DOCUMENTATION) (T T))| |(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))| |(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO (EFFECTIVE-SLOT-DEFINITION T T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))| |(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))| |(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))| |(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))| |(FAST-METHOD SLOT-UNBOUND (T T T))| |(FAST-METHOD SLOT-MISSING (T T T T))| |(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))| |(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))| LEGAL-SLOT-NAME-P |(READER OBJECT)| |(READER TYPE)| CLASS-WRAPPER |(READER PLIST)| |(FAST-METHOD CLASS-PREDICATE-NAME (T))| |(FAST-METHOD DOCUMENTATION (T))| |(FAST-METHOD NO-APPLICABLE-METHOD (T))| |(READER SLOTS)| |(WRITER NAME)| DEFINITION-SOURCE |PCL::SLOT-OBJECT class predicate| DEFAULT-INITARGS |(WRITER CLASS)| CLASS-SLOT-VALUE |(WRITER OBJECT)| |(WRITER TYPE)| |(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))| |(WRITER PLIST)| |(WRITER SLOTS)| |PCL::DOCUMENTATION-MIXIN class predicate| FORWARD-REFERENCED-CLASS-P GF-FAST-METHOD-FUNCTION-P LEGAL-QUALIFIER-P METHOD-P |PCL::SPECIALIZER-WITH-OBJECT class predicate| CLASS-SLOT-CELLS |(COMBINED-METHOD INITIALIZE-INSTANCE)| |(COMBINED-METHOD REINITIALIZE-INSTANCE)| STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)| STANDARD-GENERIC-FUNCTION-P STANDARD-READER-METHOD-P STANDARD-METHOD-P |(READER WRAPPER)| |(READER DEFSTRUCT-ACCESSOR-SYMBOL)| |(READER CLASS-EQ-SPECIALIZER)| COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS COMPUTE-DEFAULT-INITARGS |(SETF CLASS-DEFSTRUCT-FORM)| |(CALL REAL-MAKE-METHOD-LAMBDA)| |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)| |SETF PCL CLASS-SLOT-VALUE| |(SETF CLASS-SLOTS)| |(SETF CLASS-DIRECT-SLOTS)| |(READER OPERATOR)| |(CALL REAL-GET-METHOD)| |(CALL REAL-REMOVE-METHOD)| |(CALL REAL-ADD-METHOD)| |(READER ARG-INFO)| METHOD-COMBINATION-TYPE |(READER DEFSTRUCT-CONSTRUCTOR)| |(INTERNAL-READER-METHOD STANDARD-GENERIC-FUNCTION ARG-INFO)| |(READER INITIALIZE-INFO)| |(WRITER WRAPPER)| STANDARD-CLASS-P |LISP::NUMBER class predicate| LEGAL-SPECIALIZER-P |PCL::LONG-METHOD-COMBINATION class predicate| |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)| COMPUTE-SLOT-ACCESSOR-INFO |(READER INITARGS)| |(WRITER CLASS-EQ-SPECIALIZER)| STANDARD-BOUNDP-METHOD-P |(SETF DOCUMENTATION)| RAW-INSTANCE-ALLOCATOR |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL| |SETF PCL CLASS-INITIALIZE-INFO| |(WRITER OPERATOR)| |(WRITER ARG-INFO)| COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO STANDARD-WRITER-METHOD-P CLASS-INCOMPATIBLE-SUPERCLASS-LIST |(WRITER DEFSTRUCT-CONSTRUCTOR)| |PCL::TRACED-METHOD class predicate| WRAPPER-FETCHER MAKE-A-METHOD |(WRITER INITIALIZE-INFO)| METHOD-COMBINATION-DOCUMENTATION |SETF PCL SLOT-DEFINITION-INITARGS| REMOVE-BOUNDP-METHOD ADD-NAMED-METHOD |LISP::CONS class predicate| |(WRITER INITARGS)| |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR| |(BOUNDP METHOD)| |(FAST-WRITER-METHOD SLOT-OBJECT PREDICATE-NAME)| |(FAST-WRITER-METHOD CLASS NAME)| |(FAST-WRITER-METHOD SLOT-DEFINITION NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-NAME)| |(FAST-WRITER-METHOD SLOT-OBJECT DFUN-STATE)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION DFUN-STATE)| |(FAST-WRITER-METHOD SLOT-OBJECT NAME)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION NAME)| |(BOUNDP SOURCE)| |(SETF GF-DFUN-STATE)| SHORT-COMBINATION-OPERATOR |(FAST-WRITER-METHOD SLOT-OBJECT CLASS)| |(FAST-WRITER-METHOD SLOT-DEFINITION CLASS)| |(FAST-WRITER-METHOD SLOT-OBJECT ACCESSOR-FLAGS)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-CLASS)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-CLASS)| |(FAST-WRITER-METHOD TRACED-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT ALLOCATION)| |(FAST-WRITER-METHOD STANDARD-SLOT-DEFINITION ALLOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD STRUCTURE-SLOT-DEFINITION INTERNAL-READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION BOUNDP-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION WRITER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT READER-FUNCTION)| |(FAST-WRITER-METHOD EFFECTIVE-SLOT-DEFINITION READER-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT LOCATION)| |(FAST-WRITER-METHOD STANDARD-EFFECTIVE-SLOT-DEFINITION LOCATION)| |(FAST-WRITER-METHOD SLOT-OBJECT FAST-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT GENERIC-FUNCTION)| |(FAST-WRITER-METHOD STANDARD-METHOD GENERIC-FUNCTION)| |(FAST-WRITER-METHOD SLOT-OBJECT SLOT-DEFINITION)| |(FAST-WRITER-METHOD SLOT-OBJECT METHOD-COMBINATION)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION METHOD-COMBINATION)| |(FAST-WRITER-METHOD SLOT-OBJECT DOCUMENTATION)| |(FAST-WRITER-METHOD SLOT-OBJECT WRITERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION WRITERS)| |(FAST-WRITER-METHOD SLOT-OBJECT READERS)| |(FAST-WRITER-METHOD SLOT-DEFINITION READERS)| |(FAST-WRITER-METHOD SLOT-OBJECT SPECIALIZERS)| |(FAST-WRITER-METHOD SLOT-OBJECT IDENTITY-WITH-ONE-ARGUMENT)| |(FAST-WRITER-METHOD SLOT-OBJECT PROTOTYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT OBJECT)| |(FAST-WRITER-METHOD SLOT-DEFINITION TYPE)| |(FAST-WRITER-METHOD SLOT-OBJECT TYPE)| REMOVE-NAMED-METHOD |(FAST-WRITER-METHOD SLOT-OBJECT DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD STRUCTURE-CLASS DEFSTRUCT-FORM)| |(FAST-WRITER-METHOD SLOT-OBJECT INITFORM)| |(FAST-WRITER-METHOD SLOT-DEFINITION INITFORM)| |(FAST-WRITER-METHOD SLOT-OBJECT PLIST)| |(FAST-WRITER-METHOD PLIST-MIXIN PLIST)| |(FAST-WRITER-METHOD SLOT-OBJECT INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD PCL-CLASS INCOMPATIBLE-SUPERCLASS-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CAN-PRECEDE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT CLASS-PRECEDENCE-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT LAMBDA-LIST)| |(FAST-WRITER-METHOD SLOT-OBJECT PRETTY-ARGLIST)| |(FAST-WRITER-METHOD STANDARD-GENERIC-FUNCTION PRETTY-ARGLIST)| LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS COMPUTE-APPLICABLE-METHODS CLASS-NAME CLASS-PROTOTYPE READER-METHOD-CLASS REMOVE-METHOD SLOT-DEFINITION-INITFORM UPDATE-INSTANCE-FOR-REDEFINED-CLASS UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME FINALIZE-INHERITANCE GENERIC-FUNCTION-LAMBDA-LIST CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P GENERIC-FUNCTION-NAME REMOVE-DEPENDENT COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION SHARED-INITIALIZE ADD-DIRECT-METHOD SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION SLOT-DEFINITION-ALLOCATION ADD-METHOD GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS REINITIALIZE-INSTANCE VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE SLOT-MAKUNBOUND-USING-CLASS ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING MAP-DEPENDENTS UPDATE-DEPENDENT FIND-METHOD-COMBINATION ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD SLOT-DEFINITION-WRITERS COMPUTE-APPLICABLE-METHODS-USING-CLASSES CLASS-PRECEDENCE-LIST)) (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) gcl/pcl/impl/gcl/gcl_pcl_impl_low.lisp0000644000175000017500000002542512240167764016742 0ustar cammcamm(in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) ;; The generic dotimes macro is now sufficient for the performance ;; gains sought here. Even the declaration extraction should be the ;; same as that provided in do* which dotimes invokes. 20040403 CM ;(defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) ; (multiple-value-bind (doc decls bod) ; (extract-declarations body env) ; (declare (ignore doc)) ; (let ((limit (gensym)) ; (label (gensym))) ; `(let ((,limit ,form) ; (,var 0)) ; (declare (fixnum ,limit ,var)) ; ,@decls ; (block nil ; (tagbody ; ,label ; (when (>= ,var ,limit) (return-from nil ,val)) ; ,@bod ; (setq ,var (the fixnum (1+ ,var))) ; (go ,label))))))) (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (eval-when (compile load eval) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) ) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) (si::freeze-defstruct 'pcl::std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo); else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); else super_funcall_no_event(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) (defun pcl::proclaim-defmethod (x y) y (and (symbolp x) (setf (get x 'compiler::proclaimed-closure ) t))) ;#+turbo-closure-env-size (clines " static object cclosure_env_nthcdr (fixnum n,object cc) { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") (defentry cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (fixnum object) (compiler::static object cclosure_env_nthcdr)) (eval-when (compile eval load) (defparameter *gcl-function-inlines* '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline)))))) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let ((name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((eval-when (compile eval load) (make-function-inline ',(cons name (cdr inline)))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (the ,(caddr inline) (,name ,@vars))) (make-function-inline ',inline)))))) *gcl-function-inlines*))) (define-inlines) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) (clines " object fSuse_fast_links_2(object,object); static object set_cclosure (object result_cc,object value_cc,fixnum available_size) { object result_env_tail,value_env_tail; int i; /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ /* (VFUN_NARGS=2,fSuse_fast_links_2(sLnil,result_cc));*/ fSuse_fast_links_2(sLnil,result_cc); /* use_fast_links(3,Cnil,result_cc); */ result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; return result_cc; }") (defentry %set-cclosure (object object fixnum) (compiler::static object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) (setq s-data (get type 'si::s-data)) (null (si::s-data-type s-data) ))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))))) (defun structure-type-internal-slotds (type) (si::s-data-slot-descriptions (get type 'si::s-data)) ) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) (si:structure-ref1 x offset) )) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym (and (not read-only-p) writer)))))))) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) ;(defun structure-slotd-writer-function (slotd) ; (third slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) (defun renew-sys-files() ;; packages: (compiler::get-packages "sys-package.lisp") (with-open-file (st "sys-package.lisp" :direction :output :if-exists :append) (format st "(lisp::in-package \"SI\") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package \"PCL\") ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) (format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") )) gcl/pcl/impl/gcl/sys-package.lisp0000644000175000017500000001537512240167764015647 0ustar cammcamm ;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES '("S-A-N")) ;;; Definitions for package PCL of type ESTABLISH (LISP::IN-PACKAGE "PCL" :USE LISP::NIL) ;;; Definitions for package ITERATE of type ESTABLISH (LISP::IN-PACKAGE "ITERATE" :USE LISP::NIL) ;;; Definitions for package WALKER of type ESTABLISH (LISP::IN-PACKAGE "WALKER" :USE LISP::NIL) ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES '("S-A-N")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package PCL of type EXPORT (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION PCL::GENERIC-FUNCTION-METHOD-COMBINATION PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS PCL::ADD-METHOD PCL::WITH-ACCESSORS PCL::SLOT-DEFINITION-ALLOCATION PCL::SLOT-DEFINITION-INITFUNCTION PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE PCL::STANDARD-GENERIC-FUNCTION PCL::ACCESSOR-METHOD-SLOT-DEFINITION PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE PCL::SLOT-DEFINITION-NAME PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS PCL::SLOT-VALUE-USING-CLASS PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) ;;; Definitions for package ITERATE of type EXPORT (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING ITERATE::WITH-GATHERING ITERATE::INTERVAL)) ;;; Definitions for package WALKER of type EXPORT (LISP::IN-PACKAGE "WALKER" :USE '("LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package PCL of type SHADOW (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package WALKER of type SHADOW (LISP::IN-PACKAGE "WALKER") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) (in-package 'SI) (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) gcl/pcl/impl/gcl/README0000644000175000017500000000045112240167764013414 0ustar cammcammIncludes changes for gcl version 2.0 by W. Schelter To compile ln -s impl/gcl/makefile.gcl makefile.gcl ln -s impl/gcl/sys-package.lisp sys-package.lisp ln -s impl/gcl/sys-proclaim.lisp sys-proclaim.lisp make -f makefile.gcl compile Then to make saved version make -f makefile.gcl saved_pcl gcl/pcl/impl/gcl/makefile.gcl0000644000175000017500000000177212240167764015007 0ustar cammcamm# makefile for making pcl -- W. Schelter. # Directions: # make -f makefile.gcl compile # make -f makefile.gcl saved_pcl LISP=gcl SETUP='(load "sys-package.lisp")' \ '(setq *features* (delete (quote kcl) *features*))'\ '(load "defsys.lisp")(push (quote kcl) *features*)' \ '(setq pcl::*default-pathname-extensions* (cons "lisp" "o"))' \ '(setq pcl::*pathname-extensions* (cons "lisp" "o"))' \ '(load "sys-proclaim.lisp")(compiler::emit-fn t)' compile: echo ${SETUP} '(pcl::compile-pcl)' | ${LISP} saved_pcl: echo ${SETUP} '(pcl::load-pcl)(si::save-system "saved_pcl")' | ${LISP} # remake the sys-package.lisp and sys-proclaim.lisp files # Those files may be empty on a first build. remake-sys-files: echo ${SETUP} '(pcl::load-pcl)(in-package "PCL")(renew-sys-files)' | ${LISP} cp sys-proclaim.lisp xxx cat xxx | sed -e "s/COMPILER::CMP-ANON//g" > sys-proclaim.lisp rm xxx tar: make -f makefile.gcl tar1 DIR=`pwd` tar1: (cd .. ; tar cvf - `basename ${DIR}` | gzip -c > `basename ${DIR}`.tgz) gcl/pcl/impl/gcl/gcl-low.lisp0000644000175000017500000002473712240167764015006 0ustar cammcamm(in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package 'pcl) (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (defmacro memq (item list) `(member ,item ,list :test #'eq)) (defmacro assq (item list) `(assoc ,item ,list :test #'eq)) (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) (declare (ignore doc)) (let ((limit (gensym)) (label (gensym))) `(let ((,limit ,form) (,var 0)) (declare (fixnum ,limit ,var)) ,@decls (block nil (tagbody ,label (when (>= ,var ,limit) (return-from nil ,val)) ,@bod (setq ,var (the fixnum (1+ ,var))) (go ,label))))))) (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:address thing))) (eval-when (compile load eval) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*)) ) (defmacro %svref (vector index) `(svref (the simple-vector ,vector) (the fixnum ,index))) (defsetf %svref (vector index) (new-value) `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,new-value)) (si::freeze-defstruct 'pcl::std-instance) (si::freeze-defstruct 'method-call) (si::freeze-defstruct 'fast-method-call) (defvar *pcl-funcall* `(lambda (loc) (compiler::wt-nl "{object _funobj = " loc ";" "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo)) (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo); else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))(); else super_funcall_no_event(_funobj);}"))) (setq compiler::*super-funcall* *pcl-funcall*) (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall ,fn ,pv-cell ,next-method-call ,@args)) (defun pcl::proclaim-defmethod (x y) y (and (symbolp x) (setf (get x 'compiler::proclaimed-closure ) t))) ;#+turbo-closure-env-size (clines " static object cclosure_env_nthcdr (n,cc) int n; object cc; { object env,*turbo; if(n<0)return Cnil; if(type_of(cc)!=t_cclosure)return Cnil; if((turbo=cc->cc.cc_turbo)==NULL) {env=cc->cc.cc_env; while(n-->0) {if(type_of(env)!=t_cons)return Cnil; env=env->c.c_cdr;} return env;} else {if(n>=fix(*(turbo-1)))return Cnil; return turbo[n];} }") (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) ;; This is the unsafe but fast version. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr)) (eval-when (compile eval load) (defparameter *gcl-function-inlines* '( (%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL") (%symbol-function (t) t nil nil "(#0)->s.s_gfdef") (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]") (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name") (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)") (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure") (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun") (%cclosure-env (t) t nil nil "(#0)->cc.cc_env") (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)") #+turbo-closure (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]") (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))"))) (defun make-function-inline (inline) (setf (get (car inline) 'compiler::inline-always) (list (if (fboundp 'compiler::flags) (let ((opt (cdr inline))) (list (first opt) (second opt) (logior (if (fourth opt) 1 0) ; allocates-new-storage (if (third opt) 2 0) ; side-effect (if nil 4 0) ; constantp (if (eq (car inline) 'logxor) 8 0)) ;result type from args (fifth opt))) (cdr inline))))) ) (defmacro define-inlines () `(progn ,@(mapcan #'(lambda (inline) (let ((name (intern (format nil "~S inline" (car inline)))) (vars (mapcar #'(lambda (type) (declare (ignore type)) (gensym)) (cadr inline)))) `((eval-when (compile eval load) (make-function-inline ',(cons name (cdr inline)))) ,@(when (or (every #'(lambda (type) (eq type 't)) (cadr inline)) (char= #\% (aref (symbol-name (car inline)) 0))) `((defun ,(car inline) ,vars ,@(mapcan #'(lambda (var var-type) (unless (eq var-type 't) `((declare (type ,var-type ,var))))) vars (cadr inline)) (the ,(caddr inline) (,name ,@vars))) (make-function-inline ',inline)))))) *gcl-function-inlines*))) (define-inlines) (defsetf si:%compiled-function-name si:%set-compiled-function-name) (defsetf %cclosure-env %set-cclosure-env) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (cond ((compiled-function-p fn) (si::turbo-closure fn) (when (symbolp new-name) (pcl::proclaim-defmethod new-name nil)) (setf (si:%compiled-function-name fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda-block)) (setf (cadr fn) new-name)) ((and (listp fn) (eq (car fn) 'lambda)) (setf (car fn) 'lambda-block (cdr fn) (cons new-name (cdr fn))))) fn) (clines " object fSuse_fast_links(); static object set_cclosure (result_cc,value_cc,available_size) object result_cc,value_cc; int available_size; { object result_env_tail,value_env_tail; int i; /* If we are currently using fast linking, */ /* make sure to remove the link for result_cc. */ (VFUN_NARGS=2,fSuse_fast_links(sLnil,result_cc)); /* use_fast_links(3,Cnil,result_cc); */ result_env_tail=result_cc->cc.cc_env; value_env_tail=value_cc->cc.cc_env; for(i=available_size; result_env_tail!=Cnil && i>0; result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail)) CMPcar(result_env_tail)=CMPcar(value_env_tail), i--; result_cc->cc.cc_self=value_cc->cc.cc_self; result_cc->cc.cc_data=value_cc->cc.cc_data; return result_cc; }") (defentry %set-cclosure (object object int) (object set_cclosure)) (defun structure-functions-exist-p () t) (si:define-compiler-macro structure-instance-p (x) (once-only (x) `(and (si:structurep ,x) (not (eq (si:%structure-name ,x) 'std-instance))))) (defun structure-type (x) (and (si:structurep x) (si:%structure-name x))) (si:define-compiler-macro structure-type (x) (once-only (x) `(and (si:structurep ,x) (si:%structure-name ,x)))) (defun structure-type-p (type) (or (not (null (gethash type *structure-table*))) (let (#+akcl(s-data nil)) (and (symbolp type) (setq s-data (get type 'si::s-data)) (null (si::s-data-type s-data) ))))) (defun structure-type-included-type-name (type) (or (car (gethash type *structure-table*)) (let ((includes (si::s-data-includes (get type 'si::s-data)))) (when includes (si::s-data-name includes))))) (defun structure-type-internal-slotds (type) (si::s-data-slot-descriptions (get type 'si::s-data)) ) (defun structure-type-slot-description-list (type) (or (cdr (gethash type *structure-table*)) (mapcan #'(lambda (slotd) (when (and slotd (car slotd)) (let ((offset (fifth slotd))) (let ((reader #'(lambda (x) (si:structure-ref1 x offset) )) (writer #'(lambda (v x) (si:structure-set x type offset v)))) #+turbo-closure (si:turbo-closure reader) #+turbo-closure (si:turbo-closure writer) (let* ((reader-sym (let ((*package* *the-pcl-package*)) (intern (format nil "~s SLOT~D" type offset)))) (writer-sym (get-setf-function-name reader-sym)) (slot-name (first slotd)) (read-only-p (fourth slotd))) (setf (symbol-function reader-sym) reader) (setf (symbol-function writer-sym) writer) (do-standard-defsetf-1 reader-sym) (list (list slot-name reader-sym (and (not read-only-p) writer)))))))) (let ((slotds (structure-type-internal-slotds type)) (inc (structure-type-included-type-name type))) (if inc (nthcdr (length (structure-type-internal-slotds inc)) slotds) slotds))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) ;(defun structure-slotd-writer-function (slotd) ; (third slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) (defun renew-sys-files() ;; packages: (compiler::get-packages "sys-package.lisp") (with-open-file (st "sys-package.lisp" :direction :output :if-exists :append) (format st "(lisp::in-package \"SI\") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package \"PCL\") ")) ;; proclaims (compiler::make-all-proclaims "*.fn") (with-open-file (st "sys-proclaim.lisp" :direction :output :if-exists :append) (format st "~%(IN-PACKAGE \"PCL\")~%") (print `(dolist (v ', (sloop::sloop for v in-package "PCL" when (get v 'compiler::proclaimed-closure) collect v)) (setf (get v 'compiler::proclaimed-closure) t)) st) (format st "~%") )) gcl/pcl/impl/gcl/gcl-patches.lisp0000644000175000017500000001671412240167764015630 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package "COMPILER") ;; do evaluation of top level forms at compile time. (eval-when (compile eval load) (setq *EVAL-WHEN-COMPILE* t) ) (pushnew :turbo-closure *features*) (pushnew :turbo-closure-env-size *features*) ;; patch around compiler bug. (let ((rset "int Rset; ")) (unless (search rset compiler::*cmpinclude-string*) (setq compiler::*cmpinclude-string* (concatenate 'string rset compiler::*cmpinclude-string*)))) (when (get 'si::basic-wrapper 'si::s-data) (pushnew :new-kcl-wrapper *features*) (pushnew :structure-wrapper *features*)) #+akcl (progn (unless (fboundp 'real-c2lambda-expr-with-key) (setf (symbol-function 'real-c2lambda-expr-with-key) (symbol-function 'c2lambda-expr-with-key))) (defun c2lambda-expr-with-key (lambda-list body) (declare (special *sup-used*)) (setq *sup-used* t) (real-c2lambda-expr-with-key lambda-list body)) ;There is a bug in the implementation of *print-circle* that ;causes some akcl debugging commands (including :bt and :bl) ;to cause the following error when PCL is being used: ;Unrecoverable error: value stack overflow. ;When a CLOS object is printed, travel_push_object ends up ;traversing almost the whole class structure, thereby overflowing ;the value-stack. ;from lsp/debug.lsp. ;*print-circle* is badly implemented in kcl. ;it has two separate problems that should be fixed: ; 1. it traverses the printed object putting all objects found ; on the value stack (rather than in a hash table or some ; other structure; this is a problem because the size of the value stack ; is fixed, and a potentially unbounded number of objects ; need to be traversed), and ; 2. it blindly traverses all slots of any ; kind of structure including std-object structures. ; This is safe, but not always necessary, and is very time-consuming ; for CLOS objects (because it will always traverse every class). ;For now, avoid using *print-circle* T when it will cause problems. (eval-when (compile eval ) (defmacro si::f (op &rest args) `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))) (defmacro si::fb (op &rest args) `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )) ) (defun si::display-env (n env) (do ((v (reverse env) (cdr v))) ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n))) (or (and (consp (car v)) (listp (cdar v))) (return)) (let ((*print-circle* (can-use-print-circle-p (cadar v)))) (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))) (defun si::display-compiled-env ( plength ihs &aux (base (si::ihs-vs ihs)) (end (min (si::ihs-vs (1+ ihs)) (si::vs-top)))) (format si::*display-string* "") (do ((i base ) (v (get (si::ihs-fname ihs) 'si::debug) (cdr v))) ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength))) (let ((*print-circle* (can-use-print-circle-p (si::vs i)))) (format si::*display-string* "~a~@[~d~]=~s~@[,~]" (or (car v) 'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i) (si::fb < (setq i (si::f + i 1)) end))))) (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)") (defentry objnull-p (object) (object "objnull_p")) (defun can-use-print-circle-p (x) (catch 'can-use-print-circle-p (can-use-print-circle-p1 x nil))) (defun can-use-print-circle-p1 (x so-far) (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe? (if (member x so-far) (throw 'can-use-print-circle-p t) (let ((so-far (cons x so-far))) (flet ((can-use-print-circle-p (x) (can-use-print-circle-p1 x so-far))) (typecase x (vector (or (not (eq 't (array-element-type x))) (every #'can-use-print-circle-p x))) (cons (and (can-use-print-circle-p (car x)) (can-use-print-circle-p (cdr x)))) (array (or (not (eq 't (array-element-type x))) (let* ((rank (array-rank x)) (dimensions (make-list rank))) (dotimes (i rank) (setf (nth i dimensions) (array-dimension x i))) (or (member 0 dimensions) (do ((cursor (make-list rank :initial-element 0))) (nil) (declare (:dynamic-extent cursor)) (unless (can-use-print-circle-p (apply #'aref x cursor)) (return nil)) (when (si::increment-cursor cursor dimensions) (return t))))))) (t (or (not (si:structurep x)) (let* ((def (si:structure-def x)) (name (si::s-data-name def)) (len (si::s-data-length def)) (pfun (si::s-data-print-function def))) (and (null pfun) (dotimes (i len t) (unless (can-use-print-circle-p (si:structure-ref x name i)) (return nil))))))))))))) (defun si::apply-display-fun (display-fun n lis) (let ((*print-length* si::*debug-print-level*) (*print-level* si::*debug-print-level*) (*print-pretty* nil) (*PRINT-CASE* :downcase) (*print-circle* nil) ) (setf (fill-pointer si::*display-string*) 0) (format si::*display-string* "{") (funcall display-fun n lis) (when (si::fb > (fill-pointer si::*display-string*) n) (setf (fill-pointer si::*display-string*) n) (format si::*display-string* "...")) (format si::*display-string* "}") ) si::*display-string* ) ;The old definition of this had a bug: ;sometimes it returned without calling mv-values. (defun si::next-stack-frame (ihs &aux line-info li i k na) (cond ((si::fb < ihs si::*ihs-base*) (si::mv-values nil nil nil nil nil)) ((let (fun) ;; next lower visible ihs (si::mv-setq (fun i) (si::get-next-visible-fun ihs)) (setq na fun) (cond ((and (setq line-info (get fun 'si::line-info)) (do ((j (si::f + ihs 1) (si::f - j 1)) (form )) ((<= j i) nil) (setq form (si::ihs-fun j)) (cond ((setq li (si::get-line-of-form form line-info)) (return-from si::next-stack-frame (si::mv-values i fun li ;; filename (car (aref line-info 0)) ;;environment (list (si::vs (setq k (si::ihs-vs j))) (si::vs (1+ k)) (si::vs (+ k 2))))))))))))) ((and (not (special-form-p na)) (not (get na 'si::dbl-invisible)) (fboundp na)) (si::mv-values i na nil nil (if (si::ihs-not-interpreted-env i) nil (let ((i (si::ihs-vs i))) (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2))))))) (t (si::mv-values nil nil nil nil nil)))) ) gcl/pcl/impl/coral/0000755000175000017500000000000012240167764013067 5ustar cammcammgcl/pcl/impl/coral/coral-low.lisp0000644000175000017500000000434112240167764015661 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) #-:ccl-1.3 (ccl::add-transform 'std-instance-p :inline #'(lambda (call) (ccl::verify-arg-count call 1 1) (let ((arg (cadr call))) `(and (eq (ccl::%type-of ,arg) 'structure) (eq (%svref ,arg 0) 'std-instance))))) (eval-when (eval compile load) (proclaim '(inline std-instance-p))) (defun printing-random-thing-internal (thing stream) (prin1 (ccl::%ptr-to-int thing) stream)) (defun set-function-name-1 (function new-name uninterned-name) (declare (ignore uninterned-name)) (cond ((ccl::lfunp function) (ccl::lfun-name function new-name))) function) (defun doctor-dfun-for-the-debugger (gf dfun) #+:ccl-1.3 (let* ((gfspec (and (symbolp (generic-function-name gf)) (generic-function-name gf))) (arglist (generic-function-pretty-arglist gf))) (when gfspec (setf (get gfspec 'ccl::%lambda-list) (if (and arglist (listp arglist)) (format nil "~{~A~^ ~}" arglist) (format nil "~:A" arglist))))) dfun) gcl/pcl/impl/lucid/0000755000175000017500000000000012240167764013067 5ustar cammcammgcl/pcl/impl/lucid/lucid-low.lisp0000644000175000017500000003013412240167764015660 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the Lucid lisp version of the file portable-low. ;;; ;;; Lucid: (415)329-8400 ;;; (in-package 'pcl) ;;; First, import some necessary "internal" or Lucid-specific symbols (eval-when (eval compile load) (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind #+LCL3.0 ((lcl:warning #'(lambda (condition) (declare (ignore condition)) (lcl:muffle-warning)))) (let ((importer #+LCL3.0 #'sys:import-from-lucid-pkg #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID"))) (if (and x (fboundp x)) (symbol-function x) ;; Only the #'(lambda (x) ...) below is really needed, ;; but when available, the "internal" function ;; 'import-from-lucid-pkg' provides better checking. #'(lambda (name) (import (intern name "LUCID"))))))) ;; ;; We need the following "internal", undocumented Lucid goodies: (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE" #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE")) ;; ;; For without-interrupts. ;; #+LCL3.0 (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as SYS:, whereas in 3.0 lisps, they are homed in the ;; LUCID-COMMON-LISP package. (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*")) ;; ;; We import the following symbols, because in 2.1 Lisps they have to be ;; accessed as LUCID::, whereas in 3.0 lisps, they have to be ;; accessed as SYS: (mapc importer '( "NEW-STRUCTURE" "STRUCTURE-REF" "STRUCTUREP" "STRUCTURE-TYPE" "STRUCTURE-LENGTH" "PROCEDUREP" "PROCEDURE-SYMBOL" "PROCEDURE-REF" "SET-PROCEDURE-REF" )) ; ;; ; ;; The following is for the "patch" to the general defstruct printer. ; (mapc importer '( ; "OUTPUT-STRUCTURE" "DEFSTRUCT-INFO" ; "OUTPUT-TERSE-OBJECT" "DEFAULT-STRUCTURE-PRINT" ; "STRUCTURE-TYPE" "*PRINT-OUTPUT*" ; )) ;; ;; The following is for a "patch" affecting compilation of %logand&. ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS ;; on *FEATURES*, so this conditionalizes correctly for APOLLO. #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) (mapc importer '("COPY-STRUCTURE" "GET-FDESC" "SET-FDESC")) nil)) ;; end of eval-when ) ;;; ;;; Patch up for the fact that the PCL package creation in defsys.lisp ;;; will probably have an explicit :use list ?? ;;; ;;; #+LCL3.0 (use-package *default-make-package-use-list*) #+lcl3.0 (progn (defvar *saved-compilation-speed* 3) ; the production compiler sometimes ; screws up vars within labels (defmacro dont-use-production-compiler () '(eval-when (compile) (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0)) (proclaim '(optimize (compilation-speed 3))))) (defmacro use-previous-compiler () `(eval-when (compile) (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*))))) ) (defmacro %logand (x y) #-VAX `(%logand& ,x ,y) #+VAX `(logand&-variable ,x ,y)) ;;; Fix for VAX LCL #+VAX (defun logand&-variable (x y) (logand&-variable x y)) ;;; Fix for other LCLs #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) (eval-when (compile load eval) (let* ((logand&-fdesc (get-fdesc 'logand&)) (%logand&-fdesc (copy-structure logand&-fdesc))) (setf (structure-ref %logand&-fdesc 0 t) '%logand&) (setf (structure-ref %logand&-fdesc 7 t) nil) (setf (structure-ref %logand&-fdesc 8 t) nil) (set-fdesc '%logand& %logand&-fdesc)) (eval-when (load) (defun %logand& (x y) (%logand& x y))) (eval-when (eval) (compile '%logand& '(lambda (x y) (%logand& x y)))) );#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX) ;;; ;;; From: JonL ;;; Date: November 28th, 1988 ;;; ;;; Here's a better attempt to do the without-interrupts macro for LCL3.0. ;;; For the 2.1 release, maybe you should just ignore it (i.e, turn it ;;; into a PROGN and "take your chances") since there isn't a uniform way ;;; to do inhibition. 2.1 has interrupts, but no multiprocessing. ;;; ;;; The best bet for protecting the cache is merely to inhibit the ;;; scheduler, since asynchronous interrupts are only run when "scheduled". ;;; Of course, there may be other interrupts, which can cons and which ;;; could cause a GC; but at least they wouldn't be running PCL type code. ;;; ;;; Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again, ;;; but rather simply restore it to the state outside the scope of the call ;;; to WITHOUT-INTERRUPTS. Note also that an explicit call to ;;; MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if ;;; there are any interrupts/schedulings pending; at least the test to see ;;; if any are pending is very fast. #+LCL3.0 (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () `(when (null outer-scheduling-state) (setq lcl:*inhibit-scheduling* nil) (when *scheduler-wakeup* (maybe-call-scheduler)))) (interrupts-off () '(setq lcl:*inhibit-scheduling* t))) (let ((outer-scheduling-state lcl:*inhibit-scheduling*)) (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body) (when (and (null outer-scheduling-state) *scheduler-wakeup*) (maybe-call-scheduler)))))) ;;; The following should override the definitions provided by lucid-low. ;;; #+(or LCL3.0 (and APOLLO DOMAIN/OS)) (progn (defstruct-simple-predicate std-instance std-instance-p) (defstruct-simple-predicate fast-method-call fast-method-call-p) (defstruct-simple-predicate method-call method-call-p) ) (defun set-function-name-1 (fn new-name ignore) (declare (ignore ignore)) (if (not (procedurep fn)) (error "~S is not a procedure." fn) (if (compiled-function-p fn) ;; This is one of: ;; compiled-function, funcallable-instance, compiled-closure ;; or a macro. ;; So just go ahead and set its name. ;; Only change the name when necessary: maybe it is read-only. (unless (eq new-name (procedure-ref fn procedure-symbol)) (set-procedure-ref fn procedure-symbol new-name)) ;; This is an interpreted function. ;; Seems like any number of different things can happen depending ;; vaguely on what release you are running. Try to do something ;; reasonable. (let ((symbol (procedure-ref fn procedure-symbol))) (cond ((symbolp symbol) ;; In fact, this is the name of the procedure. ;; Just set it. (set-procedure-ref fn procedure-symbol new-name)) ((and (listp symbol) (eq (car symbol) 'lambda)) (setf (car symbol) 'named-lambda (cdr symbol) (cons new-name (cdr symbol)))) ((eq (car symbol) 'named-lambda) (setf (cadr symbol) new-name)))))) fn) (defun function-arglist (fn) (arglist fn)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (%pointer thing))) ;;; ;;; 16-Feb-90 Jon L White ;;; ;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0 ;;; release environment. This adds type optimizers for FUNCALL so that ;;; forms such as: ;;; ;;; (FUNCALL (THE PROCEDURE F) ...) ;;; ;;; and: ;;; ;;; (LET ((F (Frobulate))) ;;; (DECLARE (TYPE COMPILED-FUNCTION F)) ;;; (FUNCALL F ...)) ;;; ;;; will just jump directly to the procedure code, rather than waste time ;;; trying to coerce the functional argument into a procedure. ;;; (in-package "LUCID") ;;; (DECLARE-MACHINE-CLASS COMMON) (set-up-compiler-target 'common) (set-function-descriptor 'FUNCALL :TYPE 'LISP :PREDS 'NIL :EFFECTS 'T :OPTIMIZER #'(lambda (form &optional environment) (declare (ignore form environment)) (let* ((fun (second form)) (lambdap (and (consp fun) (eq (car fun) 'function) (consp (second fun)) (memq (car (second fun)) '(lambda internal-lambda))))) (if (not lambdap) form (alphatize (cons (second fun) (cddr form)) environment)))) :FUNCTIONTYPE '(function (function &rest t) (values &rest t)) :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T) ,#'(lambda (anode fun &rest args) (declare (ignore anode fun args)) `(FAST-FUNCALL ,fun ,@args))) ((COMPILED-FUNCTION &REST T) (VALUES &REST T) ,#'(lambda (anode fun &rest args) (declare (ignore anode fun args)) `(FAST-FUNCALL ,fun ,@args)))) :LAMBDALIST '(FN &REST ARGUMENTS) :ARGS '(1 NIL) :VALUES '(0 NIL) ) (def-compiler-macro fast-funcall (&rest args &environment env) (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV) `(FUNCALL-SUBR . ,args) `(&FUNCALL . ,args))) (setf (symbol-function 'funcall-subr) #'funcall) ;;; (UNDECLARE-MACHINE-CLASS) (restore-compiler-params) (in-package 'pcl) (pushnew :structure-wrapper *features*) (defun structure-functions-exist-p () t) (defun structure-instance-p (x) (and (structurep x) (not (eq 'std-instance (structure-type x))))) (defvar *structure-type* nil) (defvar *structure-length* nil) (defun structure-type-p (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (or (and s-data (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this (and type (eq *structure-type* type))))) (defun structure-type-included-type-name (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this (defun structure-type-slot-description-list (type) (declare (special lucid::*defstructs*)) (let ((s-data (gethash type lucid::*defstructs*))) (if s-data (nthcdr (let ((include (structure-ref s-data 6 'defstruct))) (if include (let ((inc-s-data (gethash include lucid::*defstructs*))) (if inc-s-data (length (structure-ref inc-s-data 7 'defstruct)) 0)) 0)) (map 'list #'(lambda (slotd) (let* ((ds 'lucid::defstruct-slot) (slot-name (system:structure-ref slotd 0 ds)) (position (system:structure-ref slotd 1 ds)) (accessor (system:structure-ref slotd 2 ds)) (read-only-p (system:structure-ref slotd 5 ds))) (list slot-name accessor #'(lambda (x) (system:structure-ref x position type)) (unless read-only-p #'(lambda (v x) (setf (system:structure-ref x position type) v)))))) (structure-ref s-data 7 'defstruct))) ; slots - Fix this (let ((result (make-list *structure-length*))) (dotimes (i *structure-length* result) (let* ((name (format nil "SLOT~D" i)) (slot-name (intern name (or (symbol-package type) *package*))) (i i)) (setf (elt result i) (list slot-name nil #'(lambda (x) (system:structure-ref x i type)) nil)))))))) (defun structure-slotd-name (slotd) (first slotd)) (defun structure-slotd-accessor-symbol (slotd) (second slotd)) (defun structure-slotd-reader-function (slotd) (third slotd)) (defun structure-slotd-writer-function (slotd) (fourth slotd)) gcl/pcl/impl/pyramid/0000755000175000017500000000000012240167764013434 5ustar cammcammgcl/pcl/impl/pyramid/pyr-patches.lisp0000644000175000017500000000043712240167764016570 0ustar cammcamm(in-package 'pcl) ;;; This next kludge disables macro memoization (the default) since somewhere ;;; in PCL, the memoization is getting in the way. (eval-when (load eval) (format t "~&;;; Resetting *MACROEXPAND-HOOK* to #'FUNCALL~%") (setq lisp::*macroexpand-hook* #'funcall)) gcl/pcl/impl/pyramid/pyr-low.lisp0000644000175000017500000000344012240167764015737 0ustar cammcamm;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the Pyramid version of low.lisp -- it runs with versions 1.1 ;;; and newer -- Created by David Bein Mon May 4 11:22:30 1987 ;;; (in-package 'pcl) ;; ;;;;;; Cache No's ;; ;;; The purpose behind the shift is that the bottom 2 bits are always 0 ;;; We use the same scheme for symbols and objects although a good ;;; case may be made for shifting objects more since they will ;;; be aligned differently... ;(defmacro symbol-cache-no (symbol mask) ; `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) ; (the fixnum ,mask))) (defmacro object-cache-no (symbol mask) `(logand (the fixnum (ash (lisp::%sp-make-fixnum ,symbol) -2)) (the fixnum ,mask))) gcl/pcl/impl/ti/0000755000175000017500000000000012240167764012403 5ustar cammcammgcl/pcl/impl/ti/ti-patches.lisp0000644000175000017500000000763112240167764015344 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package 'pcl) ;;; ;;; This little bit of magic keeps the dumper from dumping the lexical ;;; definition of call-next-method when it dumps method functions that ;;; come from defmethod forms. ;;; (proclaim '(notinline nil)) (eval-when (load) (setf (get 'function 'si:type-predicate) 'functionp)) ;; fix defsetf to deal with do-standard-defsetf #!C ; From file SETF.LISP#> KERNEL; VIRGO: #8R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; SETF.#" (defmacro defsetf (access-function arg1 &optional arg2 &environment env &body body) "Define a SETF expander for ACCESS-FUNCTION. DEFSETF has two forms: The simple form (DEFSETF access-function update-function [doc-string]) can be used as follows: After (DEFSETF GETFROB PUTFROB), \(SETF (GETFROB A 3) FOO) ==> (PUTFROB A 3 FOO). The complex form is like DEFMACRO: \(DEFSETF access-function access-lambda-list newvalue-lambda-list body...) except there are TWO lambda-lists. The first one represents the argument forms to the ACCESS-FUNCTION. Only &OPTIONAL and &REST are allowed here. The second has only one argument, representing the value to be stored. The body of the DEFSETF definition must then compute a replacement for the SETF form, just as for any other macro. When the body is executed, the args in the lambda-lists will not really contain the value-expression or parts of the form to be set; they will contain gensymmed variables which SETF may or may not eliminate by substitution." ;; REF and VAL are arguments to the expansion function (if (null body) `(defdecl ,access-function setf-method ,arg1) (multiple-value-bind (body decls doc-string) (parse-body body env t) (let* ((access-ll arg1) (value-names arg2) (expansion (let (all-arg-names) (dolist (x access-ll) (cond ((symbolp x) (if (not (member x lambda-list-keywords :test #'eq)) (push x all-arg-names) (when (eq x '&rest) (return)))) ;;9/20/88 clm (t ; it's a list after &optional (push (car x) all-arg-names)))) (setq all-arg-names (reverse all-arg-names)) `(let ((tempvars (mapcar #'(lambda (ignore) (gensym)) ',all-arg-names)) (storevar (gensym))) (values tempvars (list . ,all-arg-names) (list storevar) (let ((,(car value-names) storevar) . ,(loop for arg in all-arg-names for i = 0 then (1+ i) collect `(,arg (nth ,i tempvars)))) ,@decls . ,body) `(,',access-function . ,tempvars)))))) `(define-setf-method ,access-function ,arg1 ,@doc-string ,expansion) )))) )) gcl/pcl/impl/ti/ti-low.lisp0000644000175000017500000000557612240167764014524 0ustar cammcamm;;; -*- Mode:LISP; Package:(PCL (Lisp WALKER)); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; This is the 3600 version of the file portable-low. ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(let ((outer-scheduling-state si:inhibit-scheduling-flag) (si:inhibit-scheduling-flag t)) (macrolet ((interrupts-on () '(when (null outer-scheduling-state) (setq si:inhibit-scheduling-flag nil))) (interrupts-off () '(setq si:inhibit-scheduling-flag t))) ,.body))) (si:defsubst std-instance-p (x) (si:typep-structure-or-flavor x 'std-instance)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (si:%pointer thing))) (eval-when (compile load eval) ;There seems to be some bug with (setq si::inhibit-displacing-flag t)) ;macrolet'd macros or something. ;This gets around it but its not ;really the right fix. (defun function-arglist (f) (sys::arglist f t)) (defun record-definition (type spec &rest ignore) (if (eql type 'method) (sys:record-source-file-name spec 'defun :no-query) (sys:record-source-file-name spec type :no-query))) (ticl:defprop method method-function-spec-handler sys:function-spec-handler) (defun method-function-spec-handler (function function-spec &optional arg1 arg2) (let ((symbol (second function-spec))) (case function (sys:validate-function-spec t) (otherwise (sys:function-spec-default-handler function function-spec arg1 arg2))))) ;;;Edited by Reed Hastings 13 Aug 87 16:59 ;;;Edited by Reed Hastings 2 Nov 87 22:58 (defun set-function-name (function new-name) (when (si:get-debug-info-struct function) (setf (si:get-debug-info-field (si:get-debug-info-struct function) :name) new-name)) function) gcl/pcl/impl/vaxlisp/0000755000175000017500000000000012240167764013455 5ustar cammcammgcl/pcl/impl/vaxlisp/vaxl-low.lisp0000644000175000017500000000513212240167764016120 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; The version of low for VAXLisp ;;; (in-package 'pcl) (defmacro without-interrupts (&body body) `(macrolet ((interrupts-on () `(when (null outer-scheduling-state) (setq system::*critical-section-p* nil) (when (system::%sp-interrupt-queued-p) (system::interrupt-dequeuer t)))) (interrupts-off () `(setq system::*critical-section-p* t))) (let ((outer-scheduling-state system::*critical-section-p*)) (prog1 (let ((system::*critical-section-p* t)) ,@body) (when (and (null outer-scheduling-state) (system::%sp-interrupt-queued-p)) (system::interrupt-dequeuer t)))))) ;; ;;;;;; Load Time Eval ;; (defmacro load-time-eval (form) `(progn ,form)) ;; ;;;;;; Generating CACHE numbers ;; ;;; How are symbols in VAXLisp actually arranged in memory? ;;; Should we be shifting the address? ;;; Are they relocated? ;;; etc. ;(defmacro symbol-cache-no (symbol mask) ; `(logand (the fixnum (system::%sp-pointer->fixnum ,symbol)) ,mask)) (defmacro object-cache-no (object mask) `(logand (the fixnum (system::%sp-pointer->fixnum ,object)) ,mask)) ;; ;;;;;; printing-random-thing-internal ;; (defun printing-random-thing-internal (thing stream) (format stream "~O" (system::%sp-pointer->fixnum thing))) (defun function-arglist (fn) (system::function-lambda-vars (symbol-function fn))) (defun set-function-name-1 (fn name ignore) (cond ((system::slisp-compiled-function-p fn) (system::%sp-b-store fn 3 name))) fn) gcl/pcl/sys-package.lisp0000644000175000017500000043310112240167764014130 0ustar cammcamm ;;; Definitions for package WALKER of type ESTABLISH (LISP::MAKE-PACKAGE "WALKER" :USE LISP::NIL) ;;; Definitions for package ITERATE of type ESTABLISH (LISP::MAKE-PACKAGE "ITERATE" :USE LISP::NIL) ;;; Definitions for package PCL of type ESTABLISH (LISP::MAKE-PACKAGE "PCL" :USE LISP::NIL) ;;; Definitions for package SLOT-ACCESSOR-NAME of type ESTABLISH (LISP::MAKE-PACKAGE "SLOT-ACCESSOR-NAME" :USE LISP::NIL :NICKNAMES '("S-A-N")) ;;; Definitions for package TK of type ESTABLISH (LISP::IN-PACKAGE "TK" :USE LISP::NIL) ;;; Definitions for package DEFPACKAGE of type ESTABLISH (LISP::IN-PACKAGE "DEFPACKAGE" :USE LISP::NIL) ;;; Definitions for package ANSI-LOOP of type ESTABLISH (LISP::IN-PACKAGE "ANSI-LOOP" :USE LISP::NIL) ;;; Definitions for package SERROR of type ESTABLISH (LISP::IN-PACKAGE "SERROR" :USE LISP::NIL) ;;; Definitions for package COMMON-LISP of type ESTABLISH (LISP::IN-PACKAGE "COMMON-LISP" :USE LISP::NIL) ;;; Definitions for package WALKER of type EXPORT (LISP::IN-PACKAGE "WALKER" :USE '("LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS* WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P)) ;;; Definitions for package ITERATE of type EXPORT (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(ITERATE::SUMMING ITERATE::MINIMIZING ITERATE::PLIST-ELEMENTS ITERATE::ITERATE* ITERATE::MAXIMIZING ITERATE::LIST-TAILS ITERATE::*ITERATE-WARNINGS* ITERATE::GATHERING ITERATE::EACHTIME ITERATE::ELEMENTS ITERATE::GATHER ITERATE::LIST-ELEMENTS ITERATE::WHILE ITERATE::ITERATE ITERATE::UNTIL ITERATE::JOINING ITERATE::COLLECTING ITERATE::WITH-GATHERING ITERATE::INTERVAL)) ;;; Definitions for package PCL of type EXPORT (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER")) (LISP::IMPORT '(LISP::STANDARD-CLASS LISP::STRUCTURE-CLASS LISP::STANDARD-METHOD LISP::GENERIC-FUNCTION LISP::STANDARD-GENERIC-FUNCTION LISP::STANDARD-OBJECT LISP::BUILT-IN-CLASS LISP::METHOD-COMBINATION LISP::METHOD)) (LISP::EXPORT '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION PCL::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT PCL::MAP-DEPENDENTS PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST LISP::STANDARD-CLASS PCL::PRINT-OBJECT LISP::STRUCTURE-CLASS PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS PCL::REINITIALIZE-INSTANCE LISP::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE PCL::SYMBOL-MACROLET LISP::GENERIC-FUNCTION PCL::GENERIC-FUNCTION-METHOD-COMBINATION PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS PCL::ADD-METHOD PCL::WITH-ACCESSORS PCL::SLOT-DEFINITION-ALLOCATION PCL::SLOT-DEFINITION-INITFUNCTION PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE LISP::STANDARD-GENERIC-FUNCTION PCL::ACCESSOR-METHOD-SLOT-DEFINITION PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P PCL::COMPUTE-DISCRIMINATING-FUNCTION LISP::STANDARD-OBJECT PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS LISP::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE PCL::SLOT-DEFINITION-NAME PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS PCL::SLOT-VALUE-USING-CLASS LISP::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE PCL::GENERIC-LABELS LISP::METHOD PCL::SLOT-DEFINITION-READERS PCL::CLASS-DIRECT-DEFAULT-INITARGS PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES '("S-A-N")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package TK of type EXPORT (LISP::IN-PACKAGE "TK" :USE '("SLOOP" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT 'LISP::NIL) ;;; Definitions for package DEFPACKAGE of type EXPORT (LISP::IN-PACKAGE "DEFPACKAGE" :USE '("SLOOP" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(DEFPACKAGE::DEFPACKAGE)) ;;; Definitions for package ANSI-LOOP of type EXPORT (LISP::IN-PACKAGE "ANSI-LOOP" :USE '("LISP")) (LISP::IMPORT '(LISP::LOOP)) (LISP::EXPORT '(ANSI-LOOP::LOOP-FINISH LISP::LOOP)) ;;; Definitions for package SERROR of type EXPORT (LISP::IN-PACKAGE "SERROR" :USE '("SLOOP" "LISP")) (LISP::IMPORT 'LISP::NIL) (LISP::EXPORT '(SERROR::ERROR-CONTINUE-STRING SERROR::COND-ANY-ERROR SERROR::ERROR-STRING SERROR::DEF-ERROR-TYPE SERROR::ERROR-FORMAT-ARGS SERROR::ERROR-NAME SERROR::CONDITION-CASE SERROR::COND-ERROR)) ;;; Definitions for package COMMON-LISP of type EXPORT (LISP::IN-PACKAGE "COMMON-LISP" :USE 'LISP::NIL) (LISP::IMPORT '(LISP::NIL LISP::T)) (LISP::EXPORT '(LISP::NIL LISP::T)) ;;; Definitions for package WALKER of type SHADOW (LISP::IN-PACKAGE "WALKER") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::CDDAR LISP::SHIFTF LISP::REMHASH LISP::CHAR-EQUAL LISP::NOTEVERY LISP::TRUNCATE LISP::SEARCH LISP::SPECIAL-FORM-P LISP::MAKE-BROADCAST-STREAM LISP::CDDDDR LISP::UNLESS LISP::INTERN LISP::CADDDR LISP::LOGANDC1 LISP::READ-DELIMITED-LIST LISP::END-OF-FILE LISP::APPLY LISP::SUBST-IF-NOT LISP::CIS LISP::ADJUSTABLE-ARRAY-P LISP::SUBSTITUTE-IF LISP::FILE-STREAM LISP::QUIT LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::CONTROL-ERROR LISP::MAKE-STRING-OUTPUT-STREAM LISP::MAKE-STRING-INPUT-STREAM LISP::*STANDARD-INPUT* LISP::STANDARD-OBJECT LISP::GENSYM LISP::EQUALP LISP::DELETE-PACKAGE LISP::COMPLEXP SYSTEM::ALLOCATE LISP::MULTIPLE-VALUE-BIND LISP::CDAADR LISP::VECTOR-PUSH-EXTEND LISP::RENAME-PACKAGE LISP::CAAADR LISP::*EVALHOOK* LISP::UNTRACE LISP::STRING-CHAR LISP::KYOTO LISP::INTEGERP LISP::DENOMINATOR LISP::FLET LISP::HELP LISP::WITH-INPUT-FROM-STRING LISP::SHORT-SITE-NAME LISP::FILE-NAMESTRING LISP::WRITE-LINE LISP::UNINTERN LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME LISP::WITH-OPEN-STREAM LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES LISP::UNDEFINED-FUNCTION LISP::IEEE-FLOATING-POINT LISP::INTERSECTION LISP::CCLOSURE LISP::BOOLE-2 LISP::LOGTEST LISP::*QUERY-IO* LISP::MAX LISP::DEFSTRUCT LISP::CDDDAR LISP::ELT LISP::INSPECT LISP::CADDAR LISP::LIST-LENGTH LISP::NSET-DIFFERENCE LISP::STRING-CAPITALIZE LISP::ASSOC-IF-NOT LISP::+++ LISP::BYTE LISP::CHAR LISP::CONJUGATE LISP::CHAR-FONT-LIMIT LISP::CHAR-CODE-LIMIT LISP::SERIOUS-CONDITION LISP::CDAR LISP::COPY-ALIST LISP::FILE-LENGTH LISP::DECLARE LISP::BOOLE-1 LISP::RANDOM-STATE-P LISP::VECTOR-PUSH LISP::USE-PACKAGE LISP::CHAR-BITS LISP::GENERIC-FUNCTION LISP::IMAGPART LISP::BROADCAST-STREAM LISP::CDAAAR LISP::CAAAAR LISP::GET-DISPATCH-MACRO-CHARACTER LISP::SET-DISPATCH-MACRO-CHARACTER LISP::STRING> LISP::GO LISP::NSUBST-IF-NOT LISP::FOURTH LISP::DEFINE-SETF-METHOD LISP::DO LISP::STORAGE-CONDITION LISP::BIT-ORC2 LISP::STRING-TRIM LISP::MAPC LISP::PACKAGE LISP::NUMERATOR LISP::MACROLET LISP::HASH-TABLE-SIZE LISP::LDB-TEST LISP::READER-ERROR LISP::ROW-MAJOR-AREF LISP::CHAR-NOT-GREATERP LISP::REM LISP::ARRAYP LISP::CDADR LISP::FFLOOR LISP::SUBST-IF LISP::FIND-IF LISP::MAKE-SYMBOL LISP::MAKE-PACKAGE LISP::STRING= LISP::MAPLIST LISP::WRITE LISP::ATOM LISP::BIT-VECTOR LISP::DECF LISP::LOGXOR LISP::MULTIPLE-VALUES-LIMIT LISP::OPTIMIZE LISP::REST LISP::FIND-IF-NOT LISP::COUNT LISP::FMAKUNBOUND LISP::LIST LISP::BOOLE-NOR LISP::ZEROP LISP::// LISP::RASSOC LISP::1+ LISP::RASSOC-IF LISP::NOTANY LISP::LAST LISP::*PRINT-PRETTY* LISP::MAPCAN LISP::DEFMACRO LISP::SHADOW LISP::NRECONC LISP::++ LISP::LIST* LISP::STRING< LISP::SOFTWARE-VERSION LISP::*GENSYM-COUNTER* LISP::REMOVE-DUPLICATES LISP::PARSE-NAMESTRING LISP::UPPER-CASE-P LISP::MAKE-CONCATENATED-STREAM LISP::DO-EXTERNAL-SYMBOLS LISP::CONCATENATE LISP::CHAR-CONTROL-BIT LISP::WARN LISP::BIGNUM LISP::SIMPLE-VECTOR-P LISP::DELETE-DUPLICATES LISP::NAMESTRING LISP::BIT-ORC1 LISP::SAFETY LISP::MEMBER-IF LISP::COPY-SEQ LISP::ECHO-STREAM LISP::Y-OR-N-P LISP::COMPLEX LISP::COUNT-IF-NOT LISP::REDUCE LISP::ASSOC-IF LISP::MACRO-FUNCTION LISP::MAKE-SYNONYM-STREAM LISP::NUMBERP LISP::SXHASH LISP::CAR LISP::LOGORC2 LISP::UNSIGNED-CHAR LISP::BYTE-POSITION LISP::UNIX LISP::DEFLA LISP::ENCODE-UNIVERSAL-TIME LISP::LOWER-CASE-P LISP::EVAL-WHEN LISP::ARRAY-TOTAL-SIZE LISP::DO* LISP::TRUENAME LISP::RANDOM-STATE LISP::WARNING LISP::FTYPE LISP::FLOATING-POINT-INVALID-OPERATION LISP::PARSE-ERROR LISP::INT-CHAR LISP::LAMBDA-PARAMETERS-LIMIT LISP::GET-INTERNAL-RUN-TIME LISP::GET-INTERNAL-REAL-TIME LISP::SIGNED-BYTE LISP::VECTOR LISP::PACKAGE-ERROR LISP::DESCRIBE LISP::UNREAD-CHAR LISP::WRITE-STRING LISP::OTHERWISE LISP::SPECIFIC-CORRECTABLE-ERROR LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGORC1 LISP::PROVIDE LISP::THROW LISP::TYPE-ERROR LISP::FORMAT LISP::DEFPARAMETER LISP::REMF LISP::DEFINE-MODIFY-MACRO LISP::MOST-NEGATIVE-LONG-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MULTIPLE-VALUE-CALL LISP::TYPE-OF LISP::TAG LISP::&AUX LISP::TAGBODY LISP::SIMPLE-STRING-P LISP::READTABLEP LISP::READTABLE LISP::ARRAY-DIMENSION LISP::FILE-ERROR LISP::SLEEP LISP::SYNONYM-STREAM LISP::MINUSP LISP::DELETE-FILE LISP::CELL-ERROR LISP::COPY-READTABLE LISP::NUMBER LISP::WRITE-CHAR LISP::RENAME-FILE LISP::UNSIGNED-SHORT LISP::STRUCTURE-OBJECT LISP::QUOTE LISP::CADR LISP::BOOLE-IOR LISP::LISTP LISP::CHARACTERP LISP::CHARACTER LISP::LISP-IMPLEMENTATION-TYPE LISP::LOGICAL-PATHNAME LISP::CDADDR LISP::TAILP LISP::CAADDR LISP::PATHNAME-TYPE LISP::PLUSP LISP::CASE LISP::MACHINE-TYPE LISP::LOAD LISP::ENDP LISP::FRESH-LINE LISP::DEFCONSTANT LISP::SYMBOL LISP::VALUES LISP::SET-DIFFERENCE LISP::*PRINT-ARRAY* LISP::SET-EXCLUSIVE-OR LISP::PROG2 LISP::DIVISION-BY-ZERO LISP::PHASE LISP::CAAAR LISP::ETYPECASE LISP::CTYPECASE LISP::NOT LISP::BOOLE-C2 LISP::NTH LISP::SPECIAL-OPERATOR-P LISP::STREAM-ELEMENT-TYPE LISP::IDENTITY LISP::*PRINT-RADIX* LISP::MEMBER LISP::SHORT-FLOAT LISP::NIL LISP::ACONS LISP::MOD LISP::EQL LISP::CADDR LISP::/// LISP::KEYWORDP LISP::COERCE LISP::BSD LISP::CHAR-FONT LISP::*PRINT-LEVEL* LISP::PROBE-FILE LISP::PATHNAME-DIRECTORY LISP::PROG1 LISP::STABLE-SORT LISP::SIMPLE-WARNING LISP::CONDITION LISP::SQRT LISP::REQUIRE LISP::GCD LISP::GETHASH LISP::ISQRT LISP::DEFVAR LISP::LAMBDA-CLOSURE LISP::STREAM LISP::REMOVE-IF LISP::DECLARATION LISP::APROPOS LISP::READ-LINE LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LONG-SITE-NAME LISP::NSTRING-UPCASE LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::LONG-FLOAT-EPSILON LISP::*BREAK-ENABLE* LISP::BIT-NAND LISP::ALPHANUMERICP LISP::FROUND LISP::LAMBDA-LIST-KEYWORDS LISP::CDADAR LISP::LENGTH LISP::OR LISP::TWO-WAY-STREAM LISP::COSH LISP::CAADAR LISP::WRITE-BYTE LISP::RATIONALP LISP::FIND LISP::SUBSTITUTE-IF-NOT LISP::DEPOSIT-FIELD LISP::FLOATING-POINT-UNDERFLOW LISP::FLOATING-POINT-OVERFLOW LISP::WITH-OPEN-FILE LISP::BOOLE-ANDC2 LISP::IF LISP::RATIONAL LISP::PARSE-INTEGER LISP::SFUN LISP::MOST-POSITIVE-LONG-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-SHORT-FLOAT LISP::PSETQ LISP::COMPILE LISP::VALUES-LIST LISP::GRAPHIC-CHAR-P LISP::LOCALLY LISP::SIGNED-CHAR LISP::BOOLE-C1 LISP::FLOATP LISP::DOUBLE-FLOAT LISP::DEFTYPE LISP::UNEXPORT LISP::SYSTEM LISP::GFUN LISP::MAKE-ARRAY LISP::ROOM LISP::APROPOS-LIST LISP::ASIN LISP::SETQ LISP::CFUN LISP::CHAR>= LISP::SYMBOLP LISP::PATHNAMEP LISP::TIME LISP::VECTOR-POP LISP::LABELS LISP::TENTH LISP::SET-SYNTAX-FROM-CHAR LISP::TYPECASE LISP::NINTH LISP::WITH-PACKAGE-ITERATOR LISP::SYMBOL-PACKAGE LISP::FLOAT-RADIX LISP::*LINK-ARRAY* LISP::VECTORP LISP::REMOVE LISP::EVAL LISP::** LISP::CHAR-CODE LISP::YES-OR-NO-P LISP::INTEGER-DECODE-FLOAT LISP::APPEND LISP::DRIBBLE LISP::USER-HOMEDIR-PATHNAME LISP::RETURN-FROM LISP::CHAR-UPCASE LISP::STREAMP LISP::DOTIMES LISP::CHAR<= LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::SIGNED-SHORT LISP::CONSTANTP LISP::COMPILER-LET LISP::FLOAT-PRECISION LISP::IMPORT LISP::*TRACE-OUTPUT* LISP::TERPRI LISP::&ALLOW-OTHER-KEYS LISP::PATHNAME-DEVICE LISP::CHAR-INT LISP::STRING-STREAM LISP::STRING LISP::DPB LISP::LDB LISP::CDR LISP::DOLIST LISP::DEFCFUN LISP::BOOLE-ANDC1 LISP::STYLE-WARNING LISP::BREAK LISP::CHAR-NOT-EQUAL LISP::PROGV LISP::*STANDARD-OUTPUT* LISP::FIXNUM LISP::NUNION LISP::*PRINT-READABLY* LISP::MULTIPLE-VALUE-SETQ LISP::PRIN1 LISP::PACKAGE-USED-BY-LIST LISP::PACKAGE-USE-LIST LISP::SUBLIS LISP::SCHAR LISP::MAKE-ECHO-STREAM LISP::INLINE LISP::DECLAIM LISP::SCALE-FLOAT LISP::*PRINT-LENGTH* LISP::PROG LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SHORT-FLOAT-EPSILON LISP::&WHOLE LISP::INPUT-STREAM-P LISP::SIMPLE-BASE-STRING LISP::PROG* LISP::DECODE-UNIVERSAL-TIME LISP::WITH-OUTPUT-TO-STRING LISP::COMMONP LISP::EVENP LISP::DELETE LISP::SUBST LISP::FUNCALL LISP::CHAR-NOT-LESSP LISP::SGC LISP::COS LISP::PATHNAME LISP::NTHCDR LISP::COMPILATION-SPEED LISP::*BREAK-ON-WARNINGS* LISP::CLRHASH LISP::*PRINT-GENSYM* LISP::SIXTH LISP::MAKE-RANDOM-STATE LISP::FIRST LISP::LOGNOT LISP::ROUND LISP::AREF LISP::DIGIT-CHAR LISP::*** LISP::LOGNAND LISP::CDDR LISP::SEVENTH LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::DOUBLE-FLOAT-EPSILON LISP::VARIABLE LISP::LISP-IMPLEMENTATION-VERSION LISP::BIT-XOR LISP::RPLACD LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::FINISH-OUTPUT LISP::PROCLAIM LISP::MAKE-STRING LISP::BASE-STRING LISP::BSD386 LISP::MACHINE-VERSION LISP::*APPLYHOOK* LISP::LOGCOUNT LISP::REMOVE-IF-NOT LISP::LOGBITP LISP::SPEED LISP::BOOLE-AND LISP::STANDARD-METHOD LISP::STRINGP LISP::GET-SETF-METHOD LISP::SVREF LISP::DELETE-IF-NOT LISP::LISTEN LISP::FUNCTION LISP::CHAR-HYPER-BIT LISP::MEMBER-IF-NOT LISP::CHAR-SUPER-BIT LISP::SPACE LISP::CDAAR LISP::STANDARD-CHAR-P LISP::MERGE LISP::CHAR-NAME LISP::EXPORT LISP::CEILING LISP::SINGLE-FLOAT LISP::INT LISP::CHAR-META-BIT LISP::ACOS LISP::DESTRUCTURING-BIND LISP::CDDDR LISP::GMP LISP::ECASE LISP::MAP LISP::CCASE LISP::LAMBDA LISP::ALPHA-CHAR-P LISP::ASH LISP::BIT-AND LISP::SOFTWARE-TYPE LISP::AND LISP::FIND-ALL-SYMBOLS LISP::SECOND LISP::LOGEQV LISP::CHAR-BITS-LIMIT LISP::SHADOWING-IMPORT LISP::DOUBLE LISP::STEP LISP::FCEILING LISP::NULL LISP::REVERSE LISP::MACRO LISP::MOST-NEGATIVE-FIXNUM LISP::PACKAGEP LISP::NBUTLAST LISP::REVAPPEND LISP::STANDARD-CLASS LISP::FILL LISP::NSUBST-IF LISP::PI LISP::BY LISP::INTEGER LISP::NSTRING-CAPITALIZE LISP::EQ LISP::CHAR-BIT LISP::STRING-EQUAL LISP::REMPROP LISP::LAMBDA-BLOCK LISP::LDIFF LISP::&KEY LISP::RATIONALIZE LISP::FLOAT-SIGN LISP::READ-PRESERVING-WHITESPACE LISP::PUSHNEW LISP::GET-PROPERTIES LISP::CHAR> LISP::READ-FROM-STRING LISP::STRING-GREATERP LISP::DIRECTORY-NAMESTRING LISP::PSETF LISP::PPRINT LISP::DISASSEMBLE LISP::>= LISP::NSUBSTITUTE LISP::IN-PACKAGE LISP::BYE LISP::LCM LISP::<= LISP::DEFUN LISP::LONG-FLOAT LISP::ATAN LISP::MACROEXPAND-1 LISP::DIRECTORY LISP::ARRAY-RANK LISP::SYMBOL-PLIST LISP::HASH-TABLE-P LISP::UNION LISP::MC68020 LISP::PRINT LISP::PROGN LISP::PATHNAME-HOST LISP::/= LISP::CHAR= LISP::*READ-BASE* LISP::FLOATING-POINT-INEXACT LISP::MAKE-SEQUENCE LISP::SIGNUM LISP::STREAM-ERROR LISP::LOGNOR LISP::1- LISP::RASSOC-IF-NOT LISP::SIMPLE-ARRAY LISP::NTH-VALUE LISP::RATIO LISP::STRING-LESSP LISP::CONCATENATED-STREAM LISP::REAL LISP::SUBSTITUTE LISP::DIGIT-CHAR-P LISP::CHAR< LISP::INTEGER-LENGTH LISP::EQUAL LISP::COPY-SYMBOL LISP::CHAR-DOWNCASE LISP::DECODE-FLOAT LISP::NCONC LISP::ROTATEF LISP::ARRAY-ROW-MAJOR-INDEX LISP::WITH-HASH-TABLE-ITERATOR LISP::CLOSE LISP::RANDOM LISP::ARRAY LISP::CATCH LISP::MERGE-PATHNAMES LISP::GET-OUTPUT-STREAM-STRING LISP::OBJECT LISP::PROGRAM-ERROR LISP::NINTERSECTION LISP::ASINH LISP::IGNORE LISP::BOOLE-CLR LISP::SET-CHAR-BIT LISP::BIT-NOT LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SINGLE-FLOAT-EPSILON LISP::MULTIPLE-VALUE-LIST LISP::POSITION-IF-NOT LISP::SAVE LISP::BIT-VECTOR-P LISP::BIT-EQV LISP::FLOAT-DIGITS LISP::ARRAY-DISPLACEMENT LISP::FILE-POSITION LISP::BOTH-CASE-P LISP::RETURN LISP::MAPHASH LISP::MOST-POSITIVE-FIXNUM LISP::READ-BYTE LISP::COPY-TREE LISP::CHAR-GREATERP LISP::CHECK-TYPE LISP::MACHINE-INSTANCE LISP::CONSTANTLY LISP::FUNCTIONP LISP::EVERY LISP::STRING/= LISP::STRING>= LISP::STRING<= LISP::MAKE-HASH-TABLE LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::SIMPLE-CONDITION LISP::&REST LISP::SYMBOL-FUNCTION LISP::RPLACA LISP::*TERMINAL-IO* LISP::CHAR/= LISP::PRINT-NOT-READABLE LISP::CONS LISP::*EVAL-WHEN-COMPILE* LISP::CADAR LISP::SIMPLE-BIT-VECTOR LISP::READ-CHAR-NO-HANG LISP::CDDADR LISP::BIT-ANDC2 LISP::NSTRING-DOWNCASE LISP::CADADR LISP::BOOLE-NAND LISP::LOG LISP::STANDARD-CHAR LISP::DOCUMENTATION LISP::GET-UNIVERSAL-TIME LISP::BIT-NOR LISP::SPECIFIC-ERROR LISP::APPLYHOOK LISP::ARRAY-RANK-LIMIT LISP::ABS LISP::GBC LISP::&ENVIRONMENT LISP::PATHNAME-NAME LISP::BOOLEAN LISP::*READ-SUPPRESS* LISP::VOID LISP::PACKAGE-NAME LISP::COMPILE-FILE-PATHNAME LISP::SINH LISP::SYMBOL-VALUE LISP::STRING-RIGHT-TRIM LISP::SBIT LISP::REALP LISP::TANH LISP::MAKE-PATHNAME LISP::ASSOC LISP::DEFSETF LISP::ODDP LISP::UNWIND-PROTECT LISP::READ LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::COUNT-IF LISP::OUTPUT-STREAM-P LISP::BLOCK LISP::AKCL LISP::COPY-LIST LISP::ARRAY-IN-BOUNDS-P LISP::UNBOUND-SLOT LISP::SET LISP::HASH-TABLE-TEST LISP::PACKAGE-SHADOWING-SYMBOLS LISP::ADJUST-ARRAY LISP::EXP LISP::TYPE LISP::FILE-WRITE-DATE LISP::MAKE-LIST LISP::LET LISP::FORCE-OUTPUT LISP::CDDAAR LISP::BIT-ANDC1 LISP::GET LISP::ARITHMETIC-ERROR LISP::CADAAR LISP::BIT LISP::KCL LISP::&OPTIONAL LISP::GCL LISP::FILE-AUTHOR LISP::NSUBLIS LISP::*PRINT-CIRCLE* LISP::*MODULES* LISP::BUILT-IN-CLASS LISP::*READTABLE* LISP::SORT LISP::MAPCON LISP::*MACROEXPAND-HOOK* LISP::PUSH LISP::POSITION-IF LISP::SUBSETP LISP::CAAR LISP::BOOLE-SET LISP::STRING-CHAR-P LISP::*LOAD-VERBOSE* LISP::STRING-DOWNCASE LISP::STRING-UPCASE LISP::DELETE-IF LISP::HOST-NAMESTRING LISP::STRING-LEFT-TRIM LISP::CALL-ARGUMENTS-LIMIT LISP::DEFENTRY LISP::CLEAR-INPUT LISP::DO-SYMBOLS LISP::STRUCTURE-CLASS LISP::MISMATCH LISP::MAPL LISP::MULTIPLE-VALUE-PROG1 LISP::REALPART LISP::NSUBSTITUTE-IF LISP::COND LISP::PACKAGE-NICKNAMES LISP::COMPILED-FUNCTION-P LISP::CONSP LISP::SATISFIES LISP::&BODY LISP::MAP-INTO LISP::FLOAT LISP::SIMPLE-TYPE-ERROR LISP::ED LISP::ERROR LISP::ACOSH LISP::WHEN LISP::OPEN LISP::THE LISP::BIT-IOR LISP::MAPCAR LISP::PATHNAME-VERSION LISP::*RANDOM-STATE* LISP::SEQUENCE LISP::CAADR LISP::SUBTYPEP LISP::MASK-FIELD LISP::FIND-SYMBOL LISP::INCF LISP::SOME LISP::SIMPLE-BIT-VECTOR-P LISP::FIND-PACKAGE LISP::*DEBUG-IO* LISP::POSITION LISP::GET-DECODED-TIME LISP::ARRAY-ELEMENT-TYPE LISP::LET* LISP::TRUNCATE_USE_C LISP::COMPLEMENT LISP::EVALHOOK LISP::COMPILED-FUNCTION LISP::ARRAY-DIMENSIONS LISP::BOOLE-EQV LISP::*ERROR-OUTPUT* LISP::EXTENDED-CHAR LISP::STRUCTURE LISP::NREVERSE LISP::ADJOIN LISP::NSET-EXCLUSIVE-OR LISP::METHOD LISP::T LISP::COMMON LISP::BOOLE-ORC2 LISP::BOOLE-ORC1 LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::LOGIOR LISP::CERROR LISP::FIFTH LISP::ASSERT LISP::CLEAR-OUTPUT LISP::HASH-TABLE LISP::CLINES LISP::BOOLE LISP::BOOLE-XOR LISP::ARRAY-DIMENSION-LIMIT LISP::DO-ALL-SYMBOLS LISP::COMPILE-FILE LISP::*FEATURES* LISP::LOGAND LISP::REPLACE LISP::> LISP::= LISP::< LISP::LOGANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::PROCLAMATION LISP::TYPEP LISP::SIN LISP::BUTLAST LISP::MACROEXPAND LISP::SETF LISP::FLOOR LISP::STRING-NOT-EQUAL LISP::TAN LISP::SPECIAL LISP::MIN LISP::CODE-CHAR LISP::/ LISP::- LISP::ATANH LISP::+ LISP::* LISP::MAKUNBOUND LISP::*PACKAGE* LISP::GETF LISP::PEEK-CHAR LISP::READ-CHAR LISP::STRING-NOT-GREATERP LISP::ENOUGH-NAMESTRING LISP::SUBSEQ LISP::NAME-CHAR LISP::MAKE-CHAR LISP::BASE-CHAR LISP::FTRUNCATE LISP::UNUSE-PACKAGE LISP::THIRD LISP::PAIRLIS LISP::EXPT LISP::GENTEMP LISP::LAMBDA-BLOCK-CLOSURE LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::LOOP LISP::KEYWORD LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::NSUBSTITUTE-IF-NOT LISP::*PRINT-CASE* LISP::*PRINT-BASE* LISP::*PRINT-ESCAPE* LISP::BYTE-SIZE LISP::EIGHTH LISP::CHAR-LESSP LISP::CLX-LITTLE-ENDIAN LISP::HASH-TABLE-COUNT LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::TREE-EQUAL LISP::WRITE-TO-STRING LISP::STANDARD-GENERIC-FUNCTION LISP::FILL-POINTER LISP::STRING-NOT-LESSP LISP::CLASS LISP::PRINC-TO-STRING LISP::PRIN1-TO-STRING)) ;;; Definitions for package ITERATE of type SHADOW (LISP::IN-PACKAGE "ITERATE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::CDDAR LISP::SHIFTF LISP::REMHASH LISP::CHAR-EQUAL LISP::NOTEVERY LISP::TRUNCATE LISP::SEARCH LISP::SPECIAL-FORM-P LISP::MAKE-BROADCAST-STREAM LISP::CDDDDR LISP::UNLESS LISP::INTERN LISP::CADDDR LISP::LOGANDC1 LISP::READ-DELIMITED-LIST LISP::END-OF-FILE WALKER::VARIABLE-LEXICAL-P LISP::APPLY LISP::SUBST-IF-NOT LISP::CIS LISP::ADJUSTABLE-ARRAY-P LISP::SUBSTITUTE-IF LISP::FILE-STREAM LISP::QUIT LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::CONTROL-ERROR LISP::MAKE-STRING-OUTPUT-STREAM LISP::MAKE-STRING-INPUT-STREAM LISP::*STANDARD-INPUT* LISP::STANDARD-OBJECT LISP::GENSYM LISP::EQUALP LISP::DELETE-PACKAGE LISP::COMPLEXP SYSTEM::ALLOCATE LISP::MULTIPLE-VALUE-BIND LISP::CDAADR LISP::VECTOR-PUSH-EXTEND LISP::RENAME-PACKAGE LISP::CAAADR LISP::*EVALHOOK* LISP::UNTRACE LISP::STRING-CHAR LISP::KYOTO LISP::INTEGERP LISP::DENOMINATOR LISP::FLET LISP::HELP LISP::WITH-INPUT-FROM-STRING LISP::SHORT-SITE-NAME LISP::FILE-NAMESTRING LISP::WRITE-LINE LISP::UNINTERN LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME LISP::WITH-OPEN-STREAM LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES WALKER::VARIABLE-DECLARATION LISP::UNDEFINED-FUNCTION LISP::IEEE-FLOATING-POINT LISP::INTERSECTION LISP::CCLOSURE LISP::BOOLE-2 LISP::LOGTEST LISP::*QUERY-IO* LISP::MAX LISP::DEFSTRUCT LISP::CDDDAR LISP::ELT LISP::INSPECT LISP::CADDAR LISP::LIST-LENGTH LISP::NSET-DIFFERENCE LISP::STRING-CAPITALIZE LISP::ASSOC-IF-NOT LISP::+++ LISP::BYTE LISP::CHAR LISP::CONJUGATE LISP::CHAR-FONT-LIMIT LISP::CHAR-CODE-LIMIT LISP::SERIOUS-CONDITION LISP::CDAR LISP::COPY-ALIST LISP::FILE-LENGTH LISP::DECLARE LISP::BOOLE-1 LISP::RANDOM-STATE-P LISP::VECTOR-PUSH LISP::USE-PACKAGE LISP::CHAR-BITS LISP::GENERIC-FUNCTION LISP::IMAGPART LISP::BROADCAST-STREAM LISP::CDAAAR LISP::CAAAAR LISP::GET-DISPATCH-MACRO-CHARACTER LISP::SET-DISPATCH-MACRO-CHARACTER LISP::STRING> LISP::GO LISP::NSUBST-IF-NOT LISP::FOURTH LISP::DEFINE-SETF-METHOD LISP::DO LISP::STORAGE-CONDITION LISP::BIT-ORC2 LISP::STRING-TRIM LISP::MAPC LISP::PACKAGE LISP::NUMERATOR LISP::MACROLET LISP::HASH-TABLE-SIZE LISP::LDB-TEST LISP::READER-ERROR LISP::ROW-MAJOR-AREF LISP::CHAR-NOT-GREATERP LISP::REM LISP::ARRAYP LISP::CDADR LISP::FFLOOR LISP::SUBST-IF LISP::FIND-IF LISP::MAKE-SYMBOL LISP::MAKE-PACKAGE LISP::STRING= LISP::MAPLIST LISP::WRITE LISP::ATOM LISP::BIT-VECTOR LISP::DECF LISP::LOGXOR LISP::MULTIPLE-VALUES-LIMIT LISP::OPTIMIZE LISP::REST LISP::FIND-IF-NOT LISP::COUNT LISP::FMAKUNBOUND LISP::LIST LISP::BOOLE-NOR LISP::ZEROP LISP::// LISP::RASSOC LISP::1+ LISP::RASSOC-IF LISP::NOTANY LISP::LAST LISP::*PRINT-PRETTY* LISP::MAPCAN LISP::DEFMACRO LISP::SHADOW LISP::NRECONC LISP::++ LISP::LIST* LISP::STRING< LISP::SOFTWARE-VERSION LISP::*GENSYM-COUNTER* LISP::REMOVE-DUPLICATES LISP::PARSE-NAMESTRING LISP::UPPER-CASE-P LISP::MAKE-CONCATENATED-STREAM LISP::DO-EXTERNAL-SYMBOLS LISP::CONCATENATE LISP::CHAR-CONTROL-BIT LISP::WARN LISP::BIGNUM LISP::SIMPLE-VECTOR-P LISP::DELETE-DUPLICATES LISP::NAMESTRING LISP::BIT-ORC1 LISP::SAFETY LISP::MEMBER-IF LISP::COPY-SEQ LISP::ECHO-STREAM LISP::Y-OR-N-P LISP::COMPLEX LISP::COUNT-IF-NOT LISP::REDUCE LISP::ASSOC-IF LISP::MACRO-FUNCTION LISP::MAKE-SYNONYM-STREAM LISP::NUMBERP LISP::SXHASH LISP::CAR LISP::LOGORC2 LISP::UNSIGNED-CHAR LISP::BYTE-POSITION LISP::UNIX LISP::DEFLA LISP::ENCODE-UNIVERSAL-TIME LISP::LOWER-CASE-P LISP::EVAL-WHEN LISP::ARRAY-TOTAL-SIZE LISP::DO* LISP::TRUENAME LISP::RANDOM-STATE LISP::WARNING LISP::FTYPE LISP::FLOATING-POINT-INVALID-OPERATION LISP::PARSE-ERROR LISP::INT-CHAR LISP::LAMBDA-PARAMETERS-LIMIT LISP::GET-INTERNAL-RUN-TIME LISP::GET-INTERNAL-REAL-TIME LISP::SIGNED-BYTE LISP::VECTOR LISP::PACKAGE-ERROR LISP::DESCRIBE LISP::UNREAD-CHAR LISP::WRITE-STRING LISP::OTHERWISE LISP::SPECIFIC-CORRECTABLE-ERROR LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGORC1 LISP::PROVIDE LISP::THROW LISP::TYPE-ERROR LISP::FORMAT LISP::DEFPARAMETER LISP::REMF LISP::DEFINE-MODIFY-MACRO LISP::MOST-NEGATIVE-LONG-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MULTIPLE-VALUE-CALL LISP::TYPE-OF LISP::TAG LISP::&AUX LISP::TAGBODY LISP::SIMPLE-STRING-P LISP::READTABLEP LISP::READTABLE LISP::ARRAY-DIMENSION LISP::FILE-ERROR LISP::SLEEP LISP::SYNONYM-STREAM LISP::MINUSP LISP::DELETE-FILE LISP::CELL-ERROR LISP::COPY-READTABLE LISP::NUMBER LISP::WRITE-CHAR LISP::RENAME-FILE LISP::UNSIGNED-SHORT LISP::STRUCTURE-OBJECT LISP::QUOTE LISP::CADR LISP::BOOLE-IOR LISP::LISTP LISP::CHARACTERP LISP::CHARACTER LISP::LISP-IMPLEMENTATION-TYPE LISP::LOGICAL-PATHNAME LISP::CDADDR LISP::TAILP LISP::CAADDR LISP::PATHNAME-TYPE LISP::PLUSP LISP::CASE LISP::MACHINE-TYPE LISP::LOAD LISP::ENDP LISP::FRESH-LINE LISP::DEFCONSTANT LISP::SYMBOL LISP::VALUES LISP::SET-DIFFERENCE LISP::*PRINT-ARRAY* LISP::SET-EXCLUSIVE-OR LISP::PROG2 LISP::DIVISION-BY-ZERO LISP::PHASE LISP::CAAAR LISP::ETYPECASE LISP::CTYPECASE LISP::NOT LISP::BOOLE-C2 LISP::NTH LISP::SPECIAL-OPERATOR-P LISP::STREAM-ELEMENT-TYPE LISP::IDENTITY LISP::*PRINT-RADIX* LISP::MEMBER LISP::SHORT-FLOAT LISP::NIL LISP::ACONS LISP::MOD LISP::EQL LISP::CADDR LISP::/// LISP::KEYWORDP LISP::COERCE LISP::BSD LISP::CHAR-FONT LISP::*PRINT-LEVEL* LISP::PROBE-FILE LISP::PATHNAME-DIRECTORY LISP::PROG1 LISP::STABLE-SORT LISP::SIMPLE-WARNING LISP::CONDITION LISP::SQRT LISP::REQUIRE LISP::GCD LISP::GETHASH LISP::ISQRT LISP::DEFVAR LISP::LAMBDA-CLOSURE LISP::STREAM LISP::REMOVE-IF LISP::DECLARATION LISP::APROPOS LISP::READ-LINE LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LONG-SITE-NAME LISP::NSTRING-UPCASE LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::LONG-FLOAT-EPSILON LISP::*BREAK-ENABLE* LISP::BIT-NAND LISP::ALPHANUMERICP LISP::FROUND LISP::LAMBDA-LIST-KEYWORDS LISP::CDADAR LISP::LENGTH LISP::OR WALKER::VARIABLE-GLOBALLY-SPECIAL-P LISP::TWO-WAY-STREAM LISP::COSH LISP::CAADAR LISP::WRITE-BYTE LISP::RATIONALP LISP::FIND LISP::SUBSTITUTE-IF-NOT LISP::DEPOSIT-FIELD LISP::FLOATING-POINT-UNDERFLOW LISP::FLOATING-POINT-OVERFLOW LISP::WITH-OPEN-FILE LISP::BOOLE-ANDC2 LISP::IF LISP::RATIONAL LISP::PARSE-INTEGER LISP::SFUN LISP::MOST-POSITIVE-LONG-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-SHORT-FLOAT LISP::PSETQ LISP::COMPILE LISP::VALUES-LIST LISP::GRAPHIC-CHAR-P LISP::LOCALLY LISP::SIGNED-CHAR LISP::BOOLE-C1 LISP::FLOATP LISP::DOUBLE-FLOAT LISP::DEFTYPE LISP::UNEXPORT LISP::SYSTEM LISP::GFUN LISP::MAKE-ARRAY LISP::ROOM LISP::APROPOS-LIST LISP::ASIN LISP::SETQ LISP::CFUN LISP::CHAR>= LISP::SYMBOLP LISP::PATHNAMEP LISP::TIME LISP::VECTOR-POP LISP::LABELS LISP::TENTH LISP::SET-SYNTAX-FROM-CHAR LISP::TYPECASE LISP::NINTH LISP::WITH-PACKAGE-ITERATOR LISP::SYMBOL-PACKAGE LISP::FLOAT-RADIX LISP::*LINK-ARRAY* LISP::VECTORP LISP::REMOVE LISP::EVAL LISP::** WALKER::*VARIABLE-DECLARATIONS* LISP::CHAR-CODE LISP::YES-OR-NO-P LISP::INTEGER-DECODE-FLOAT LISP::APPEND LISP::DRIBBLE LISP::USER-HOMEDIR-PATHNAME LISP::RETURN-FROM LISP::CHAR-UPCASE LISP::STREAMP LISP::DOTIMES LISP::CHAR<= LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::SIGNED-SHORT LISP::CONSTANTP LISP::COMPILER-LET LISP::FLOAT-PRECISION LISP::IMPORT LISP::*TRACE-OUTPUT* LISP::TERPRI LISP::&ALLOW-OTHER-KEYS LISP::PATHNAME-DEVICE LISP::CHAR-INT LISP::STRING-STREAM WALKER::WALK-FORM LISP::STRING LISP::DPB LISP::LDB LISP::CDR LISP::DOLIST LISP::DEFCFUN LISP::BOOLE-ANDC1 LISP::STYLE-WARNING LISP::BREAK LISP::CHAR-NOT-EQUAL LISP::PROGV LISP::*STANDARD-OUTPUT* LISP::FIXNUM LISP::NUNION LISP::*PRINT-READABLY* LISP::MULTIPLE-VALUE-SETQ LISP::PRIN1 LISP::PACKAGE-USED-BY-LIST LISP::PACKAGE-USE-LIST LISP::SUBLIS LISP::SCHAR LISP::MAKE-ECHO-STREAM LISP::INLINE LISP::DECLAIM LISP::SCALE-FLOAT LISP::*PRINT-LENGTH* LISP::PROG LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SHORT-FLOAT-EPSILON LISP::&WHOLE LISP::INPUT-STREAM-P LISP::SIMPLE-BASE-STRING LISP::PROG* LISP::DECODE-UNIVERSAL-TIME LISP::WITH-OUTPUT-TO-STRING LISP::COMMONP LISP::EVENP LISP::DELETE LISP::SUBST LISP::FUNCALL LISP::CHAR-NOT-LESSP LISP::SGC LISP::COS LISP::PATHNAME LISP::NTHCDR LISP::COMPILATION-SPEED LISP::*BREAK-ON-WARNINGS* LISP::CLRHASH LISP::*PRINT-GENSYM* LISP::SIXTH LISP::MAKE-RANDOM-STATE LISP::FIRST LISP::LOGNOT LISP::ROUND LISP::AREF LISP::DIGIT-CHAR LISP::*** LISP::LOGNAND LISP::CDDR LISP::SEVENTH LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::DOUBLE-FLOAT-EPSILON LISP::VARIABLE LISP::LISP-IMPLEMENTATION-VERSION LISP::BIT-XOR LISP::RPLACD LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::FINISH-OUTPUT LISP::PROCLAIM LISP::MAKE-STRING LISP::BASE-STRING LISP::BSD386 LISP::MACHINE-VERSION LISP::*APPLYHOOK* LISP::LOGCOUNT LISP::REMOVE-IF-NOT LISP::LOGBITP LISP::SPEED LISP::BOOLE-AND LISP::STANDARD-METHOD LISP::STRINGP LISP::GET-SETF-METHOD LISP::SVREF LISP::DELETE-IF-NOT LISP::LISTEN LISP::FUNCTION LISP::CHAR-HYPER-BIT LISP::MEMBER-IF-NOT LISP::CHAR-SUPER-BIT LISP::SPACE LISP::CDAAR LISP::STANDARD-CHAR-P LISP::MERGE LISP::CHAR-NAME LISP::EXPORT LISP::CEILING LISP::SINGLE-FLOAT LISP::INT LISP::CHAR-META-BIT LISP::ACOS LISP::DESTRUCTURING-BIND LISP::CDDDR LISP::GMP LISP::ECASE LISP::MAP LISP::CCASE LISP::LAMBDA LISP::ALPHA-CHAR-P LISP::ASH LISP::BIT-AND WALKER::NESTED-WALK-FORM LISP::SOFTWARE-TYPE LISP::AND LISP::FIND-ALL-SYMBOLS LISP::SECOND LISP::LOGEQV LISP::CHAR-BITS-LIMIT LISP::SHADOWING-IMPORT LISP::DOUBLE LISP::STEP LISP::FCEILING LISP::NULL LISP::REVERSE LISP::MACRO LISP::MOST-NEGATIVE-FIXNUM LISP::PACKAGEP LISP::NBUTLAST LISP::REVAPPEND LISP::STANDARD-CLASS LISP::FILL LISP::NSUBST-IF LISP::PI LISP::BY LISP::INTEGER LISP::NSTRING-CAPITALIZE LISP::EQ LISP::CHAR-BIT LISP::STRING-EQUAL LISP::REMPROP LISP::LAMBDA-BLOCK LISP::LDIFF LISP::&KEY LISP::RATIONALIZE LISP::FLOAT-SIGN LISP::READ-PRESERVING-WHITESPACE LISP::PUSHNEW LISP::GET-PROPERTIES LISP::CHAR> LISP::READ-FROM-STRING LISP::STRING-GREATERP LISP::DIRECTORY-NAMESTRING LISP::PSETF LISP::PPRINT LISP::DISASSEMBLE LISP::>= LISP::NSUBSTITUTE LISP::IN-PACKAGE LISP::BYE LISP::LCM LISP::<= LISP::DEFUN LISP::LONG-FLOAT LISP::ATAN LISP::MACROEXPAND-1 LISP::DIRECTORY LISP::ARRAY-RANK LISP::SYMBOL-PLIST LISP::HASH-TABLE-P LISP::UNION LISP::MC68020 LISP::PRINT LISP::PROGN LISP::PATHNAME-HOST LISP::/= LISP::CHAR= LISP::*READ-BASE* LISP::FLOATING-POINT-INEXACT LISP::MAKE-SEQUENCE LISP::SIGNUM LISP::STREAM-ERROR LISP::LOGNOR LISP::1- LISP::RASSOC-IF-NOT LISP::SIMPLE-ARRAY LISP::NTH-VALUE LISP::RATIO LISP::STRING-LESSP LISP::CONCATENATED-STREAM LISP::REAL LISP::SUBSTITUTE LISP::DIGIT-CHAR-P LISP::CHAR< LISP::INTEGER-LENGTH LISP::EQUAL LISP::COPY-SYMBOL LISP::CHAR-DOWNCASE LISP::DECODE-FLOAT LISP::NCONC LISP::ROTATEF LISP::ARRAY-ROW-MAJOR-INDEX LISP::WITH-HASH-TABLE-ITERATOR LISP::CLOSE LISP::RANDOM LISP::ARRAY LISP::CATCH LISP::MERGE-PATHNAMES LISP::GET-OUTPUT-STREAM-STRING LISP::OBJECT LISP::PROGRAM-ERROR LISP::NINTERSECTION LISP::ASINH LISP::IGNORE LISP::BOOLE-CLR LISP::SET-CHAR-BIT LISP::BIT-NOT WALKER::MACROEXPAND-ALL LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SINGLE-FLOAT-EPSILON LISP::MULTIPLE-VALUE-LIST LISP::POSITION-IF-NOT LISP::SAVE LISP::BIT-VECTOR-P LISP::BIT-EQV LISP::FLOAT-DIGITS LISP::ARRAY-DISPLACEMENT LISP::FILE-POSITION LISP::BOTH-CASE-P LISP::RETURN LISP::MAPHASH LISP::MOST-POSITIVE-FIXNUM LISP::READ-BYTE LISP::COPY-TREE LISP::CHAR-GREATERP LISP::CHECK-TYPE LISP::MACHINE-INSTANCE LISP::CONSTANTLY LISP::FUNCTIONP LISP::EVERY LISP::STRING/= LISP::STRING>= LISP::STRING<= LISP::MAKE-HASH-TABLE LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::SIMPLE-CONDITION LISP::&REST LISP::SYMBOL-FUNCTION LISP::RPLACA LISP::*TERMINAL-IO* LISP::CHAR/= LISP::PRINT-NOT-READABLE LISP::CONS LISP::*EVAL-WHEN-COMPILE* LISP::CADAR LISP::SIMPLE-BIT-VECTOR LISP::READ-CHAR-NO-HANG LISP::CDDADR LISP::BIT-ANDC2 LISP::NSTRING-DOWNCASE LISP::CADADR LISP::BOOLE-NAND LISP::LOG LISP::STANDARD-CHAR LISP::DOCUMENTATION LISP::GET-UNIVERSAL-TIME LISP::BIT-NOR LISP::SPECIFIC-ERROR LISP::APPLYHOOK LISP::ARRAY-RANK-LIMIT LISP::ABS LISP::GBC LISP::&ENVIRONMENT LISP::PATHNAME-NAME LISP::BOOLEAN LISP::*READ-SUPPRESS* LISP::VOID LISP::PACKAGE-NAME LISP::COMPILE-FILE-PATHNAME LISP::SINH LISP::SYMBOL-VALUE LISP::STRING-RIGHT-TRIM LISP::SBIT LISP::REALP LISP::TANH LISP::MAKE-PATHNAME LISP::ASSOC LISP::DEFSETF LISP::ODDP LISP::UNWIND-PROTECT LISP::READ LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::COUNT-IF LISP::OUTPUT-STREAM-P LISP::BLOCK LISP::AKCL LISP::COPY-LIST LISP::ARRAY-IN-BOUNDS-P LISP::UNBOUND-SLOT LISP::SET LISP::HASH-TABLE-TEST LISP::PACKAGE-SHADOWING-SYMBOLS LISP::ADJUST-ARRAY LISP::EXP LISP::TYPE LISP::FILE-WRITE-DATE LISP::MAKE-LIST LISP::LET LISP::FORCE-OUTPUT LISP::CDDAAR LISP::BIT-ANDC1 LISP::GET LISP::ARITHMETIC-ERROR LISP::CADAAR LISP::BIT LISP::KCL LISP::&OPTIONAL LISP::GCL LISP::FILE-AUTHOR LISP::NSUBLIS LISP::*PRINT-CIRCLE* LISP::*MODULES* LISP::BUILT-IN-CLASS LISP::*READTABLE* LISP::SORT LISP::MAPCON LISP::*MACROEXPAND-HOOK* LISP::PUSH LISP::POSITION-IF LISP::SUBSETP LISP::CAAR LISP::BOOLE-SET LISP::STRING-CHAR-P LISP::*LOAD-VERBOSE* LISP::STRING-DOWNCASE LISP::STRING-UPCASE LISP::DELETE-IF LISP::HOST-NAMESTRING LISP::STRING-LEFT-TRIM LISP::CALL-ARGUMENTS-LIMIT LISP::DEFENTRY LISP::CLEAR-INPUT LISP::DO-SYMBOLS LISP::STRUCTURE-CLASS LISP::MISMATCH LISP::MAPL LISP::MULTIPLE-VALUE-PROG1 LISP::REALPART LISP::NSUBSTITUTE-IF LISP::COND LISP::PACKAGE-NICKNAMES LISP::COMPILED-FUNCTION-P LISP::CONSP WALKER::WALK-FORM-EXPAND-MACROS-P LISP::SATISFIES LISP::&BODY LISP::MAP-INTO LISP::FLOAT LISP::SIMPLE-TYPE-ERROR LISP::ED LISP::ERROR LISP::ACOSH WALKER::DEFINE-WALKER-TEMPLATE LISP::WHEN LISP::OPEN LISP::THE LISP::BIT-IOR LISP::MAPCAR LISP::PATHNAME-VERSION LISP::*RANDOM-STATE* LISP::SEQUENCE LISP::CAADR LISP::SUBTYPEP LISP::MASK-FIELD LISP::FIND-SYMBOL LISP::INCF LISP::SOME LISP::SIMPLE-BIT-VECTOR-P LISP::FIND-PACKAGE LISP::*DEBUG-IO* LISP::POSITION LISP::GET-DECODED-TIME LISP::ARRAY-ELEMENT-TYPE LISP::LET* LISP::TRUNCATE_USE_C LISP::COMPLEMENT LISP::EVALHOOK LISP::COMPILED-FUNCTION LISP::ARRAY-DIMENSIONS LISP::BOOLE-EQV LISP::*ERROR-OUTPUT* LISP::EXTENDED-CHAR LISP::STRUCTURE LISP::NREVERSE LISP::ADJOIN LISP::NSET-EXCLUSIVE-OR LISP::METHOD LISP::T LISP::COMMON LISP::BOOLE-ORC2 LISP::BOOLE-ORC1 LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::LOGIOR LISP::CERROR LISP::FIFTH LISP::ASSERT LISP::CLEAR-OUTPUT LISP::HASH-TABLE LISP::CLINES LISP::BOOLE LISP::BOOLE-XOR LISP::ARRAY-DIMENSION-LIMIT LISP::DO-ALL-SYMBOLS LISP::COMPILE-FILE LISP::*FEATURES* LISP::LOGAND LISP::REPLACE LISP::> LISP::= LISP::< LISP::LOGANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::PROCLAMATION LISP::TYPEP LISP::SIN LISP::BUTLAST LISP::MACROEXPAND LISP::SETF LISP::FLOOR LISP::STRING-NOT-EQUAL LISP::TAN LISP::SPECIAL LISP::MIN LISP::CODE-CHAR LISP::/ LISP::- LISP::ATANH LISP::+ LISP::* LISP::MAKUNBOUND LISP::*PACKAGE* LISP::GETF LISP::PEEK-CHAR LISP::READ-CHAR LISP::STRING-NOT-GREATERP LISP::ENOUGH-NAMESTRING LISP::SUBSEQ LISP::NAME-CHAR LISP::MAKE-CHAR LISP::BASE-CHAR LISP::FTRUNCATE LISP::UNUSE-PACKAGE LISP::THIRD LISP::PAIRLIS LISP::EXPT LISP::GENTEMP LISP::LAMBDA-BLOCK-CLOSURE LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::LOOP LISP::KEYWORD LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::NSUBSTITUTE-IF-NOT LISP::*PRINT-CASE* LISP::*PRINT-BASE* LISP::*PRINT-ESCAPE* LISP::BYTE-SIZE LISP::EIGHTH LISP::CHAR-LESSP WALKER::VARIABLE-SPECIAL-P LISP::CLX-LITTLE-ENDIAN LISP::HASH-TABLE-COUNT LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::TREE-EQUAL LISP::WRITE-TO-STRING LISP::STANDARD-GENERIC-FUNCTION LISP::FILL-POINTER LISP::STRING-NOT-LESSP LISP::CLASS LISP::PRINC-TO-STRING LISP::PRIN1-TO-STRING)) ;;; Definitions for package PCL of type SHADOW (LISP::IN-PACKAGE "PCL") (LISP::SHADOW '( PCL::DOTIMES PCL::DOCUMENTATION PCL::DOCUMENTATION)) (LISP::SHADOWING-IMPORT '( LISP::DOTIMES LISP::DOTIMES)) (LISP::IMPORT '(LISP::STANDARD-CLASS LISP::STRUCTURE-CLASS LISP::STANDARD-METHOD LISP::GENERIC-FUNCTION LISP::STANDARD-GENERIC-FUNCTION LISP::STANDARD-OBJECT LISP::BUILT-IN-CLASS LISP::METHOD-COMBINATION LISP::METHOD LISP::OTHERWISE LISP::SIMPLE-CONDITION LISP::FLOOR LISP::NSUBLIS LISP::YES-OR-NO-P LISP::CLOSE LISP::WITH-INPUT-FROM-STRING LISP::EQL LISP::*APPLYHOOK* LISP::MASK-FIELD LISP::*DEBUG-IO* LISP::VOID LISP::RANDOM-STATE-P LISP::DELETE-FILE LISP::WITH-HASH-TABLE-ITERATOR LISP::FLOAT LISP::RENAME-FILE LISP::LAMBDA-BLOCK LISP::RANDOM-STATE LISP::UPPER-CASE-P LISP::GO LISP::GRAPHIC-CHAR-P LISP::DO LISP::PATHNAME-TYPE LISP::STANDARD-CHAR LISP::PROCLAIM LISP::BLOCK LISP::LOWER-CASE-P LISP::// LISP::UNIX LISP::*PRINT-READABLY* LISP::CEILING LISP::SIMPLE-BASE-STRING LISP::NOT LISP::PATHNAME-NAME LISP::MULTIPLE-VALUE-BIND LISP::*TRACE-OUTPUT* LISP::USE-PACKAGE LISP::PATHNAME-DEVICE LISP::SUBSEQ LISP::SET-EXCLUSIVE-OR LISP::GENSYM LISP::REALPART LISP::CODE-CHAR LISP::FLOAT-RADIX LISP::READ-CHAR LISP::PEEK-CHAR LISP::BASE-CHAR LISP::MAKE-CHAR LISP::NAME-CHAR LISP::GBC LISP::COS LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::*BREAK-ON-WARNINGS* LISP::INPUT-STREAM-P LISP::*PRINT-PRETTY* LISP::*QUERY-IO* LISP::*PRINT-ARRAY* LISP::DEFCFUN LISP::*LOAD-VERBOSE* LISP::FIND-IF LISP::POSITION LISP::MAKE-SEQUENCE LISP::TAG LISP::BOOLE-C2 LISP::SET-DISPATCH-MACRO-CHARACTER LISP::GET-DISPATCH-MACRO-CHARACTER LISP::COMPLEMENT LISP::PAIRLIS LISP::STANDARD-CHAR-P LISP::*PRINT-LEVEL* LISP::ALPHA-CHAR-P LISP::SIXTH LISP::*PRINT-RADIX* LISP::ARRAY-IN-BOUNDS-P LISP::DEPOSIT-FIELD LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::RATIONAL LISP::NOTANY LISP::POP LISP::PPRINT LISP::CONDITION LISP::READTABLE LISP::READTABLEP LISP::TWO-WAY-STREAM LISP::SPECIFIC-ERROR LISP::BIT-VECTOR-P WALKER::VARIABLE-DECLARATION LISP::DECLARE LISP::SPECIAL LISP::DIGIT-CHAR-P LISP::GET-UNIVERSAL-TIME LISP::SHADOWING-IMPORT LISP::INT LISP::SPECIFIC-CORRECTABLE-ERROR LISP::CLEAR-INPUT LISP::SOFTWARE-VERSION LISP::LOAD LISP::ENDP LISP::DOUBLE LISP::LAMBDA LISP::MAKE-SYNONYM-STREAM LISP::LISTP LISP::TERPRI LISP::SATISFIES LISP::BOOLE-ORC1 LISP::BOOLE-ORC2 LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::NUNION LISP::SLEEP LISP::NSUBSTITUTE LISP::FIRST LISP::COMPLEX LISP::UNTRACE LISP::FMAKUNBOUND LISP::RPLACA LISP::INSPECT LISP::MULTIPLE-VALUE-PROG1 LISP::LOGICAL-PATHNAME LISP::CLASS LISP::INCF LISP::*ERROR-OUTPUT* LISP::DO-SYMBOLS LISP::>= LISP::<= LISP::BOTH-CASE-P LISP::/= LISP::1- LISP::KEYWORDP LISP::ROTATEF LISP::KYOTO LISP::REMPROP LISP::LONG-SITE-NAME LISP::LIST* LISP::PACKAGEP LISP::UNBOUND-VARIABLE LISP::LOGIOR LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::CALL-ARGUMENTS-LIMIT LISP::APROPOS LISP::TYPEP LISP::DPB LISP::CHECK-TYPE LISP::LOG LISP::*READ-SUPPRESS* LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::NINTH LISP::THROW LISP::DEFPARAMETER LISP::&OPTIONAL LISP::WRITE-CHAR LISP::FLOAT-PRECISION LISP::DOLIST LISP::*PACKAGE* LISP::GMP LISP::STRUCTURE-OBJECT WALKER::*VARIABLE-DECLARATIONS* LISP::*BREAK-ENABLE* LISP::SET-CHAR-BIT LISP::FLET LISP::WITH-PACKAGE-ITERATOR ITERATE::GATHER LISP::MOD LISP::ELT LISP::MACHINE-INSTANCE LISP::REMOVE LISP::FLOAT-SIGN LISP::*EVAL-WHEN-COMPILE* LISP::LOGANDC1 LISP::COERCE LISP::PACKAGE-NICKNAMES LISP::CHAR-CONTROL-BIT LISP::FIND-PACKAGE LISP::LIST LISP::UNEXPORT LISP::LOGXOR LISP::BIT-ANDC1 LISP::CCLOSURE LISP::ARRAY-RANK-LIMIT LISP::POSITION-IF-NOT LISP::STYLE-WARNING LISP::UNUSE-PACKAGE LISP::PRINT-NOT-READABLE LISP::VECTOR-POP LISP::MERGE-PATHNAMES LISP::BYTE LISP::HASH-TABLE-SIZE LISP::KEYWORD LISP::DIGIT-CHAR LISP::LENGTH LISP::CHAR>= LISP::DO-EXTERNAL-SYMBOLS LISP::CHAR<= LISP::&KEY LISP::*READ-BASE* LISP::CHAR-CODE-LIMIT LISP::CHAR-FONT-LIMIT LISP::1+ LISP::++ LISP::*GENSYM-COUNTER* LISP::BYTE-SIZE LISP::FIFTH LISP::&ENVIRONMENT LISP::AND LISP::STABLE-SORT LISP::CHAR-NOT-LESSP LISP::BIT-EQV LISP::CHAR/= LISP::POSITIVE-FIXNUM LISP::CHAR-UPCASE LISP::BIT-NOT LISP::IGNORE ITERATE::INTERVAL LISP::BIT-XOR LISP::MAKE-PACKAGE LISP::EIGHTH LISP::MAKE-HASH-TABLE LISP::IN-PACKAGE LISP::TYPE LISP::WITH-OUTPUT-TO-STRING LISP::RETURN LISP::SHIFTF LISP::SIGNUM LISP::FIXNUM LISP::BIT-NOR LISP::THIRD LISP::BIT-IOR LISP::AKCL LISP::SINH LISP::STRING-LESSP LISP::CHAR-NOT-EQUAL ITERATE::WHILE LISP::COMPILED-FUNCTION LISP::LISP-IMPLEMENTATION-VERSION LISP::FIND LISP::EXPT LISP::FILL LISP::TIME LISP::STRING-CHAR LISP::NSUBST-IF-NOT LISP::** WALKER::WALK-FORM-EXPAND-MACROS-P LISP::UNSIGNED-SHORT LISP::READ-CHAR-NO-HANG LISP::MACROEXPAND LISP::SHORT-FLOAT LISP::NOTINLINE LISP::IDENTITY LISP::SYMBOL-VALUE LISP::TRUNCATE LISP::BIT-ORC1 LISP::IMAGPART LISP::CHAR-DOWNCASE LISP::STRING-EQUAL SYSTEM::ALLOCATE LISP::SYMBOL-PACKAGE LISP::SVREF LISP::FBOUNDP LISP::BUTLAST LISP::MOST-NEGATIVE-FIXNUM LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-LONG-FLOAT LISP::INTERSECTION LISP::SEVENTH LISP::CHAR-LESSP LISP::DENOMINATOR LISP::OUTPUT-STREAM-P LISP::INTERN LISP::MINUSP LISP::MAKE-TWO-WAY-STREAM LISP::CONCATENATED-STREAM LISP::LAMBDA-LIST-KEYWORDS LISP::INTEGERP LISP::STRING-CHAR-P LISP::MAPLIST LISP::FILE-AUTHOR LISP::SCALE-FLOAT LISP::FTYPE LISP::READ-DELIMITED-LIST LISP::COPY-TREE LISP::UNREAD-CHAR LISP::ZEROP LISP::STRING-UPCASE LISP::STRING-DOWNCASE LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::FTRUNCATE LISP::ARRAY-ELEMENT-TYPE LISP::ALPHANUMERICP LISP::PI LISP::MAP-INTO LISP::ARITHMETIC-ERROR LISP::PROVIDE LISP::BY LISP::SIMPLE-VECTOR LISP::OBJECT LISP::MACRO-FUNCTION LISP::PHASE LISP::NBUTLAST LISP::BIT LISP::SFUN LISP::READ-LINE LISP::HASH-TABLE-COUNT LISP::CHAR-NAME LISP::GFUN LISP::TYPE-ERROR LISP::*MODULES* LISP::&ALLOW-OTHER-KEYS LISP::CONCATENATE LISP::CFUN LISP::TREE-EQUAL LISP::CHAR-EQUAL LISP::FILE-ERROR LISP::SUBSTITUTE WALKER::WALK-FORM LISP::LOGEQV LISP::CELL-ERROR LISP::ARRAY-ROW-MAJOR-INDEX LISP::DEFINE-MODIFY-MACRO LISP::CIS LISP::SIGNED-CHAR LISP::MERGE LISP::CHAR> LISP::CHAR= LISP::NSTRING-CAPITALIZE LISP::CHAR< LISP::IEEE-FLOATING-POINT LISP::MULTIPLE-VALUE-SETQ LISP::QUOTE LISP::READ-BYTE LISP::COMPILE-FILE LISP::REQUIRE LISP::MEMBER-IF LISP::UNSIGNED-BYTE LISP::ASSERT LISP::VECTOR LISP::CLINES LISP::TENTH LISP::LISTEN LISP::MULTIPLE-VALUES-LIMIT LISP::CHAR-BITS LISP::BIGNUM LISP::LIST-LENGTH LISP::WRITE-TO-STRING LISP::FROUND LISP::PRIN1-TO-STRING LISP::PRINC-TO-STRING LISP::FILE-LENGTH LISP::APROPOS-LIST LISP::REMOVE-IF-NOT LISP::PARSE-ERROR ITERATE::LIST-ELEMENTS LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::STRING-NOT-LESSP LISP::PACKAGE-ERROR LISP::DELETE-IF-NOT LISP::MEMBER-IF-NOT LISP::LONG-FLOAT LISP::SIMPLE-VECTOR-P LISP::ARRAY-RANK LISP::LAMBDA-PARAMETERS-LIMIT LISP::DEFVAR LISP::DEFSTRUCT LISP::BOOLEAN LISP::SUBTYPEP LISP::EVERY LISP::MAKE-ARRAY LISP::REMOVE-DUPLICATES LISP::SUBLIS LISP::DELETE-DUPLICATES LISP::FUNCTIONP LISP::FUNCTION LISP::REMOVE-IF LISP::WHEN LISP::ADJUSTABLE-ARRAY-P LISP::/// LISP::APPEND LISP::SIN LISP::RASSOC-IF-NOT LISP::FRESH-LINE LISP::MIN LISP::SET-SYNTAX-FROM-CHAR LISP::SETQ LISP::NAMESTRING ITERATE::COLLECTING LISP::VECTORP LISP::BROADCAST-STREAM LISP::*EVALHOOK* LISP::EVENP LISP::REST LISP::STRING-NOT-EQUAL LISP::MULTIPLE-VALUE-CALL LISP::SINGLE-FLOAT-EPSILON LISP::SINGLE-FLOAT-NEGATIVE-EPSILON ITERATE::ELEMENTS LISP::LIST-ALL-PACKAGES LISP::MAPCON LISP::FILE-STREAM LISP::CONSTANTP LISP::NIL LISP::SETF LISP::WRITE-STRING LISP::MAKE-STRING-INPUT-STREAM LISP::MAKE-STRING-OUTPUT-STREAM LISP::COPY-ALIST LISP::GETF LISP::CONSTANTLY LISP::MACROEXPAND-1 LISP::NSUBST LISP::PUSH LISP::STORAGE-CONDITION LISP::*TERMINAL-IO* LISP::MAPCAR LISP::ISQRT LISP::CHAR LISP::HELP* LISP::DELETE-PACKAGE LISP::LOGORC2 LISP::RENAME-PACKAGE LISP::EXP LISP::MAPCAN LISP::MACHINE-TYPE LISP::LAMBDA-CLOSURE LISP::DEFUN LISP::LOGORC1 LISP::ASSOC LISP::PATHNAME-VERSION LISP::DO* LISP::NSUBSTITUTE-IF-NOT LISP::SYMBOL LISP::NINTERSECTION LISP::REPLACE LISP::TAGBODY LISP::CHAR-CODE LISP::DEFCONSTANT LISP::DEFMACRO LISP::PACKAGE-NAME LISP::LOGCOUNT LISP::FUNCALL LISP::DECLAIM LISP::NSUBST-IF LISP::DEFTYPE LISP::ECHO-STREAM LISP::NTHCDR LISP::SYMBOLP LISP::ACONS LISP::LONG-FLOAT-EPSILON LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::ACOSH LISP::DESTRUCTURING-BIND LISP::SUBSETP LISP::NUMBERP LISP::SUBST LISP::DEFLA LISP::DOTIMES LISP::BOOLE-C1 LISP::LET* LISP::GET-SETF-METHOD LISP::READ-FROM-STRING LISP::STRING LISP::SUBST-IF-NOT LISP::*PRINT-GENSYM* LISP::CLX-LITTLE-ENDIAN LISP::NCONC LISP::COMPILATION-SPEED LISP::EVALHOOK LISP::MAKE-ECHO-STREAM LISP::NUMBER LISP::ERROR LISP::HELP LISP::BASE-STRING LISP::MAKE-STRING LISP::WRITE-BYTE LISP::IF LISP::FOURTH LISP::*RANDOM-STATE* WALKER::VARIABLE-SPECIAL-P LISP::NULL LISP::CHAR-GREATERP LISP::REMF LISP::BYE LISP::ASSOC-IF-NOT LISP::MEMBER LISP::LOGBITP LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::*PRINT-LENGTH* LISP::INTEGER-LENGTH LISP::STRINGP LISP::LDIFF LISP::REALP LISP::CDDDDR LISP::CADDDR LISP::DELETE-IF LISP::PUSHNEW LISP::SOFTWARE-TYPE LISP::ARRAY LISP::*PRINT-CIRCLE* LISP::CDDDAR LISP::SHORT-SITE-NAME LISP::CADDAR LISP::QUIT LISP::*PRINT-ESCAPE* LISP::*PRINT-BASE* LISP::*PRINT-CASE* LISP::OPTIMIZE WALKER::VARIABLE-GLOBALLY-SPECIAL-P LISP::BOOLE-XOR LISP::&WHOLE LISP::LOCALLY LISP::GET-DECODED-TIME LISP::ATOM LISP::CDADDR LISP::LAMBDA-BLOCK-CLOSURE LISP::CAADDR LISP::SUBST-IF LISP::COUNT-IF-NOT LISP::CDADAR LISP::DEFSETF LISP::CAADAR LISP::SXHASH LISP::BOOLE-EQV LISP::PROGV LISP::NSET-EXCLUSIVE-OR LISP::CERROR LISP::STRING<= LISP::STRING>= LISP::STRING/= LISP::SIMPLE-BIT-VECTOR LISP::BOOLE-NOR LISP::COMPILE-FILE-PATHNAME LISP::SEARCH LISP::COPY-SYMBOL LISP::BOOLE-IOR LISP::RATIO LISP::PROGN LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::RPLACD LISP::&BODY LISP::DIVISION-BY-ZERO LISP::CHAR-NOT-GREATERP LISP::NRECONC LISP::ASINH LISP::ROW-MAJOR-AREF LISP::CDDDR LISP::MC68020 LISP::MACROLET LISP::GET-INTERNAL-REAL-TIME LISP::GET-INTERNAL-RUN-TIME LISP::EQUAL LISP::NUMERATOR LISP::THE WALKER::VARIABLE-LEXICAL-P LISP::CDDAR LISP::MOST-POSITIVE-FIXNUM LISP::CHAR-BITS-LIMIT LISP::MOST-POSITIVE-SHORT-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-LONG-FLOAT LISP::EVAL LISP::HOST-NAMESTRING LISP::NSUBSTITUTE-IF LISP::PSETQ LISP::EQUALP LISP::SET LISP::BOOLE-CLR LISP::CATCH LISP::LET LISP::BYTE-POSITION LISP::FILE-WRITE-DATE LISP::SCHAR LISP::GET LISP::ACOS LISP::GET-OUTPUT-STREAM-STRING LISP::BOOLE-AND LISP::NSET-DIFFERENCE LISP::WRITE-LINE LISP::PACKAGE LISP::APPLYHOOK LISP::ATANH LISP::PSETF LISP::SIMPLE-BIT-VECTOR-P LISP::FLOATP LISP::BOOLE-SET LISP::PATHNAME LISP::PROG2 LISP::PROG1 LISP::PROBE-FILE LISP::CDADR LISP::MAKE-BROADCAST-STREAM LISP::FIND-SYMBOL LISP::PRINT LISP::CHAR-HYPER-BIT LISP::HASH-TABLE-TEST LISP::PACKAGE-USE-LIST LISP::PACKAGE-USED-BY-LIST LISP::READ-PRESERVING-WHITESPACE LISP::DRIBBLE LISP::CDAAR LISP::ARRAYP LISP::PROG* LISP::*STANDARD-OUTPUT* LISP::WRITE LISP::INLINE LISP::DECLARATION LISP::FORCE-OUTPUT LISP::LOGAND ITERATE::ITERATE LISP::REVAPPEND LISP::BOOLE-2 LISP::VARIABLE ITERATE::WITH-GATHERING LISP::PRINC LISP::FILE-NAMESTRING LISP::SPECIAL-OPERATOR-P LISP::MAKE-RANDOM-STATE LISP::DECF LISP::ED LISP::BOOLE-1 LISP::BOOLE-NAND LISP::BSD386 LISP::REAL LISP::&AUX LISP::GETHASH LISP::CLEAR-OUTPUT LISP::COMPLEXP LISP::STEP LISP::*STANDARD-INPUT* LISP::APPLY LISP::WITH-OPEN-STREAM LISP::ECASE LISP::&REST LISP::CCASE LISP::FCEILING LISP::CLRHASH LISP::PARSE-INTEGER LISP::LOGANDC2 LISP::COUNT LISP::DIRECTORY-NAMESTRING LISP::PRIN1 LISP::READ LISP::CDDR LISP::SGC LISP::SAVE LISP::PACKAGE-SHADOWING-SYMBOLS LISP::ODDP LISP::STRING> LISP::USER-HOMEDIR-PATHNAME LISP::LAST LISP::BIT-ANDC2 ITERATE::ITERATE* LISP::REM LISP::MAPHASH LISP::MAKE-SYMBOL LISP::STRING= LISP::ASIN LISP::SQRT LISP::CDR LISP::PROG LISP::ROUND LISP::STRING< LISP::STRING-LEFT-TRIM LISP::TAILP LISP::CHARACTER LISP::CHARACTERP LISP::SYMBOL-PLIST LISP::Y-OR-N-P LISP::SERIOUS-CONDITION LISP::ENCODE-UNIVERSAL-TIME LISP::REMHASH LISP::WARN ITERATE::EACHTIME ITERATE::*ITERATE-WARNINGS* LISP::IMPORT LISP::CDAR LISP::RATIONALIZE LISP::HASH-TABLE-P LISP::FLOATING-POINT-OVERFLOW LISP::FLOATING-POINT-UNDERFLOW LISP::NSTRING-UPCASE LISP::BREAK LISP::CASE LISP::MAKE-CONCATENATED-STREAM LISP::COMPILE LISP::+++ LISP::ATAN LISP::STRING-RIGHT-TRIM LISP::SHORT-FLOAT-EPSILON LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::FILL-POINTER LISP::COUNT-IF LISP::RATIONALP LISP::NOTEVERY LISP::CDDADR LISP::FLOATING-POINT-INEXACT LISP::FILE-POSITION LISP::MAKE-PATHNAME LISP::CADADR LISP::SYMBOL-FUNCTION LISP::CDDAAR LISP::ARRAY-HAS-FILL-POINTER-P LISP::MAPL LISP::CADAAR LISP::SBIT LISP::SECOND LISP::COPY-SEQ LISP::WITH-OPEN-FILE LISP::EXPORT LISP::POSITION-IF LISP::BOOLE-ANDC2 LISP::CDAADR LISP::CAAADR LISP::STREAM-ERROR LISP::BOOLE-ANDC1 LISP::FLOATING-POINT-INVALID-OPERATION LISP::CDAAAR LISP::CONSP LISP::GET-PROPERTIES LISP::CAAAAR LISP::INTEGER-DECODE-FLOAT LISP::STRING-GREATERP LISP::EXTENDED-CHAR LISP::MAPC LISP::SYNONYM-STREAM LISP::MACRO LISP::PROGRAM-ERROR LISP::TRACE LISP::TANH LISP::UNLESS LISP::FFLOOR ITERATE::UNTIL LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::SIMPLE-TYPE-ERROR LISP::BOOLE LISP::DECODE-UNIVERSAL-TIME LISP::CADDR LISP::INTEGER LISP::OR LISP::UNINTERN LISP::ASSOC-IF LISP::STREAM LISP::*LINK-ARRAY* WALKER::NESTED-WALK-FORM LISP::VALUES LISP::*READTABLE* LISP::CADAR LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::STRING-TRIM LISP::PROCLAMATION WALKER::MACROEXPAND-ALL LISP::*** LISP::SYMBOL-NAME LISP::TRUENAME LISP::SPICE LISP::FIND-ALL-SYMBOLS LISP::BIT-ORC2 LISP::STRING-STREAM LISP::UNWIND-PROTECT LISP::FIND-IF-NOT LISP::WARNING LISP::STREAMP LISP::UNDEFINED-FUNCTION LISP::DOUBLE-FLOAT LISP::ARRAY-DIMENSIONS LISP::DO-ALL-SYMBOLS LISP::ARRAY-DIMENSION-LIMIT LISP::ARRAY-DISPLACEMENT LISP::CHAR-INT LISP::ABS LISP::NTH LISP::LOGNOT LISP::BIT-NAND LISP::MAX ITERATE::PLIST-ELEMENTS ITERATE::GATHERING LISP::LOGNOR LISP::COPY-LIST LISP::CAADR LISP::COMMONP LISP::BIT-VECTOR LISP::FINISH-OUTPUT LISP::SIMPLE-ARRAY LISP::LCM LISP::SAFETY LISP::EVAL-WHEN LISP::MAKE-LIST LISP::MAKUNBOUND LISP::SORT LISP::AREF LISP::CHAR-BIT LISP::CAAAR LISP::COMPILED-FUNCTION-P WALKER::DEFINE-WALKER-TEMPLATE LISP::ARRAY-TOTAL-SIZE LISP::KCL LISP::BOUNDP LISP::GCL LISP::LISP-IMPLEMENTATION-TYPE LISP::SYSTEM LISP::SIGNED-SHORT LISP::COMPILER-LET ITERATE::LIST-TAILS LISP::NTH-VALUE LISP::STREAM-ELEMENT-TYPE LISP::UNSIGNED-CHAR LISP::ADJOIN LISP::COSH LISP::REVERSE LISP::SPEED LISP::EQ LISP::UNBOUND-SLOT LISP::ENOUGH-NAMESTRING LISP::INT-CHAR LISP::CONTROL-ERROR LISP::ARRAY-DIMENSION LISP::ADJUST-ARRAY LISP::SINGLE-FLOAT ITERATE::JOINING LISP::NSTRING-DOWNCASE LISP::PLUSP LISP::RANDOM LISP::MISMATCH LISP::LOOP LISP::SEQUENCE LISP::STRING-CAPITALIZE LISP::DIRECTORY LISP::CADR LISP::DEFENTRY LISP::READER-ERROR LISP::MULTIPLE-VALUE-LIST LISP::ROOM SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTURE-REF LISP::CONS LISP::CONJUGATE LISP::HASH-TABLE LISP::RASSOC-IF LISP::*FEATURES* LISP::ASH LISP::FLOAT-DIGITS LISP::FORMAT ITERATE::MINIMIZING LISP::STRUCTURE SYSTEM::STRUCTUREP ITERATE::MAXIMIZING LISP::CHAR-SUPER-BIT LISP::CHAR-META-BIT LISP::REDUCE LISP::LDB LISP::CHAR-FONT LISP::DECODE-FLOAT LISP::STRING-NOT-GREATERP LISP::PATHNAME-DIRECTORY LISP::UNION LISP::CAR LISP::COPY-READTABLE LISP::VALUES-LIST LISP::GENTEMP LISP::NREVERSE LISP::LOGTEST LISP::DEFINE-SETF-METHOD LISP::BIT-AND LISP::TRUNCATE_USE_C ITERATE::SUMMING LISP::PATHNAME-HOST LISP::SPACE LISP::LDB-TEST LISP::SUBSTITUTE-IF LISP::END-OF-FILE LISP::VECTOR-PUSH-EXTEND LISP::LOGNAND LISP::TYPECASE LISP::SIMPLE-STRING-P LISP::SIMPLE-STRING LISP::SUBSTITUTE-IF-NOT LISP::CAAR LISP::RASSOC LISP::PARSE-NAMESTRING LISP::*MACROEXPAND-HOOK* LISP::MAP LISP::COND LISP::SIMPLE-WARNING LISP::T LISP::SPECIAL-FORM-P LISP::DESCRIBE LISP::RETURN-FROM LISP::CTYPECASE LISP::ETYPECASE LISP::SOME LISP::LABELS LISP::> LISP::= LISP::< LISP::COMMON LISP::SHADOW LISP::/ LISP::- LISP::+ LISP::* LISP::DELETE LISP::PATHNAMEP LISP::SET-DIFFERENCE LISP::TYPE-OF LISP::VECTOR-PUSH LISP::MACHINE-VERSION LISP::GCD LISP::BSD LISP::SIGNED-BYTE LISP::OPEN LISP::DISASSEMBLE LISP::TAN)) ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT 'LISP::NIL) ;;; Definitions for package TK of type SHADOW (LISP::IN-PACKAGE "TK") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::EXP LISP::DEFVAR LISP::DISASSEMBLE LISP::DELETE-IF LISP::UNSIGNED-SHORT LISP::GFUN LISP::NSUBST-IF-NOT LISP::CIS LISP::LOGAND LISP::BIT-EQV LISP::UNIX LISP::RANDOM LISP::COPY-LIST SYSTEM::*DEFAULT-INFO-FILES* LISP::KEYWORDP LISP::CADAR LISP::MERGE-PATHNAMES LISP::BOOLE-C2 LISP::BIT-NOT LISP::CFUN LISP::STANDARD-OBJECT LISP::STRINGP LISP::METHOD-COMBINATION LISP::NSET-EXCLUSIVE-OR LISP::CLOSE LISP::INTEGER-DECODE-FLOAT LISP::CHAR-NOT-EQUAL LISP::COSH LISP::NTHCDR LISP::GET-UNIVERSAL-TIME LISP::YES-OR-NO-P LISP::READ-LINE LISP::LET* LISP::PATHNAME-TYPE LISP::FLOAT-PRECISION LISP::PROG* SYSTEM::HEADER LISP::SYMBOL-NAME LISP::LOG LISP::OR LISP::PACKAGE-SHADOWING-SYMBOLS LISP::BREAK LISP::STRUCTURE-OBJECT LISP::ROTATEF LISP::SQRT LISP::CONS LISP::NSUBST-IF LISP::UNWIND-PROTECT LISP::CONSP SLOOP::DEF-LOOP-MACRO LISP::FLOAT-SIGN LISP::*EVALHOOK* LISP::CHAR-BIT LISP::SOME LISP::MAPC SYSTEM::*TK-CONNECTION* LISP::SETF LISP::CEILING LISP::&BODY LISP::CDAR LISP::MAKE-LIST LISP::MAKE-HASH-TABLE LISP::STRING-UPCASE LISP::STRING-DOWNCASE LISP::STYLE-WARNING LISP::ASINH LISP::NRECONC LISP::NSTRING-DOWNCASE LISP::SECOND LISP::RATIONALP LISP::SET-DISPATCH-MACRO-CHARACTER LISP::GET-DISPATCH-MACRO-CHARACTER LISP::CHECK-TYPE LISP::MAKE-STRING-INPUT-STREAM LISP::MAKE-STRING-OUTPUT-STREAM LISP::*BREAK-ON-WARNINGS* LISP::BYE LISP::SAFETY LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::*LOAD-VERBOSE* LISP::OTHERWISE LISP::NBUTLAST LISP::SORT LISP::WARNING LISP::DEFLA LISP::PROGN LISP::PUSHNEW LISP::SYSTEM SYSTEM::INFO-AUX LISP::CHAR= LISP::SIGNED-SHORT LISP::MAKE-ECHO-STREAM LISP::BIT-AND LISP::EXPORT LISP::EQ LISP::SOFTWARE-TYPE LISP::LOGTEST LISP::LIST-ALL-PACKAGES LISP::DEFTYPE LISP::GETF LISP::ROW-MAJOR-AREF LISP::TYPECASE LISP::CHAR-CONTROL-BIT SYSTEM::STRING-MATCH LISP::HASH-TABLE-TEST LISP::USER-HOMEDIR-PATHNAME LISP::SYMBOL-PACKAGE LISP::BOOLEAN LISP::HOST-NAMESTRING LISP::IN-PACKAGE LISP::CAAR SYSTEM::SHOW-INFO LISP::INTERN LISP::CONDITION LISP::IEEE-FLOATING-POINT LISP::LOGNOT LISP::SUBST-IF-NOT LISP::COPY-READTABLE LISP::REVAPPEND LISP::SYMBOL LISP::BIT-VECTOR LISP::SEARCH LISP::STREAM-ELEMENT-TYPE LISP::POP LISP::GO LISP::LIST LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::PARSE-ERROR LISP::VALUES LISP::DESTRUCTURING-BIND LISP::RANDOM-STATE LISP::LISTP LISP::CHAR/= LISP::REMPROP LISP::DO LISP::HELP* LISP::ABS LISP::&KEY LISP::VECTOR-PUSH-EXTEND LISP::PACKAGE-NICKNAMES LISP::MULTIPLE-VALUE-PROG1 SLOOP::LOOP-RETURN LISP::END-OF-FILE LISP::*DEFAULT-PATHNAME-DEFAULTS* SYSTEM::OFFER-CHOICES LISP::EXPT SYSTEM::PRINT-NODE LISP::READER-ERROR LISP::REMHASH LISP::BLOCK LISP::PACKAGE-ERROR LISP::LAMBDA-CLOSURE LISP::PARSE-INTEGER LISP::TIME LISP::COERCE LISP::FIND-IF LISP::UNREAD-CHAR LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM SYSTEM::*INFO-WINDOW* LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR SYSTEM::BEGIN LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE LISP::SPECIFIC-ERROR LISP::FIRST LISP::ALPHANUMERICP LISP::WITH-HASH-TABLE-ITERATOR LISP::SCALE-FLOAT LISP::CONCATENATED-STREAM LISP::CONTROL-ERROR LISP::FINISH-OUTPUT LISP::LAMBDA-PARAMETERS-LIMIT LISP::PRINC LISP::ADJOIN LISP::PI LISP::DOUBLE-FLOAT LISP::READTABLE LISP::READTABLEP LISP::ARRAY-RANK-LIMIT SYSTEM::INFO-SUBFILE LISP::RENAME-FILE LISP::READ-CHAR LISP::PEEK-CHAR LISP::REMOVE-DUPLICATES LISP::BYTE LISP::*MODULES* LISP::GET-OUTPUT-STREAM-STRING LISP::MULTIPLE-VALUE-BIND LISP::VECTORP LISP::RASSOC-IF-NOT LISP::UNINTERN SLOOP::LOOP-FINISH LISP::SPECIFIC-CORRECTABLE-ERROR LISP::CDADAR LISP::FUNCTION LISP::LOGORC2 LISP::*PACKAGE* LISP::STRING-NOT-GREATERP LISP::INTERSECTION LISP::SPACE LISP::SEVENTH LISP::BASE-CHAR LISP::MAKE-CHAR LISP::NAME-CHAR LISP::SBIT LISP::CAADAR LISP::TAILP LISP::*TERMINAL-IO* LISP::STREAM-ERROR LISP::BOOLE-ANDC1 LISP::DO-ALL-SYMBOLS LISP::MAKUNBOUND LISP::PROVIDE LISP::THROW LISP::LENGTH LISP::CDAAR LISP::&AUX LISP::ARRAY-DISPLACEMENT LISP::PAIRLIS LISP::*PRINT-GENSYM* LISP::COMPILE-FILE-PATHNAME LISP::CAR LISP::FTRUNCATE LISP::DELETE-DUPLICATES LISP::NREVERSE LISP::APROPOS LISP::STRING-RIGHT-TRIM LISP::STEP LISP::BIT-NOR LISP::ARRAY-TOTAL-SIZE LISP::ECHO-STREAM SYSTEM::*TK-LIBRARY* LISP::DEFINE-SETF-METHOD LISP::FMAKUNBOUND LISP::SUBST-IF LISP::GET-DECODED-TIME LISP::LONG-FLOAT LISP::SIMPLE-WARNING LISP::CHAR-HYPER-BIT LISP::TAG LISP::RATIO LISP::EVENP LISP::QUOTE SYSTEM::AUTOLOAD LISP::SIMPLE-STRING LISP::NSUBSTITUTE LISP::LAST LISP::NSET-DIFFERENCE LISP::COUNT LISP::CDAAAR LISP::SET-DIFFERENCE SLOOP::DEF-LOOP-FOR LISP::PPRINT LISP::SHORT-FLOAT-EPSILON LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SET-CHAR-BIT LISP::ACOSH LISP::LISTEN LISP::GENTEMP LISP::ERROR LISP::BSD LISP::ADJUST-ARRAY LISP::CLINES LISP::IF LISP::CAAAAR LISP::SET-SYNTAX-FROM-CHAR LISP::STRING-TRIM LISP::DIGIT-CHAR LISP::BOOLE-AND LISP::STRING> LISP::CAAAR LISP::GETHASH LISP::FILL-POINTER SLOOP::DEF-LOOP-MAP LISP::CDADDR LISP::DIRECTORY-NAMESTRING LISP::DEFUN LISP::TRUNCATE SYSTEM::FILE LISP::DEFENTRY LISP::ALPHA-CHAR-P LISP::SYMBOL-FUNCTION LISP::SUBSTITUTE-IF-NOT LISP::LDB-TEST LISP::FLOAT-DIGITS LISP::BIT-VECTOR-P LISP::CAADDR LISP::VARIABLE LISP::NUMERATOR LISP::NOTINLINE LISP::CHAR-LESSP LISP::WARN LISP::CHAR-NOT-LESSP LISP::ARRAY-DIMENSION-LIMIT LISP::MOD LISP::SXHASH LISP::PACKAGE-USE-LIST LISP::PACKAGE-USED-BY-LIST LISP::MACHINE-INSTANCE LISP::ARRAYP LISP::*GENSYM-COUNTER* LISP::UPPER-CASE-P LISP::*PRINT-CIRCLE* LISP::FTYPE LISP::THE SLOOP::LOCAL-FINISH SYSTEM::NAME LISP::COMPILER-LET LISP::WRITE-TO-STRING LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::SEQUENCE LISP::FILE-AUTHOR LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH LISP::SIMPLE-STRING-P LISP::PRINT LISP::MULTIPLE-VALUES-LIMIT LISP::PRIN1-TO-STRING LISP::PRINC-TO-STRING LISP::SIMPLE-CONDITION LISP::TERPRI LISP::CDAADR LISP::FLOATING-POINT-OVERFLOW LISP::FLOATING-POINT-UNDERFLOW LISP::CALL-ARGUMENTS-LIMIT LISP::COPY-SEQ LISP::FUNCALL SYSTEM::END LISP::CLRHASH LISP::SHORT-SITE-NAME LISP::LONG-FLOAT-EPSILON LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::ASSOC-IF-NOT LISP::CAAADR LISP::STRING-CHAR LISP::LOGANDC1 LISP::WITH-PACKAGE-ITERATOR LISP::NUMBERP LISP::COMPLEX LISP::AND LISP::EVAL-WHEN LISP::LOOP LISP::READ-FROM-STRING LISP::*STANDARD-OUTPUT* LISP::CHAR-NAME LISP::COMPILE-FILE LISP::FLOAT LISP::*ERROR-OUTPUT* LISP::TYPE-ERROR LISP::COMPILATION-SPEED LISP::LOGXOR LISP::LIST-LENGTH LISP::DRIBBLE LISP::EXTENDED-CHAR LISP::MAP SYSTEM::IDESCRIBE LISP::ARRAY-ELEMENT-TYPE LISP::ROUND LISP::STRING-LEFT-TRIM LISP::DECLAIM LISP::SAVE LISP::SIN LISP::*PRINT-LENGTH* LISP::DECLARATION LISP::DECODE-FLOAT LISP::PATHNAME-NAME LISP::STRING= LISP::PHASE LISP::SPICE LISP::RASSOC LISP::LISP-IMPLEMENTATION-TYPE LISP::UNTRACE LISP::PRINT-NOT-READABLE LISP::ARRAY-ROW-MAJOR-INDEX LISP::SUBSTITUTE-IF LISP::BOOLE LISP::TRUENAME LISP::DEFCONSTANT LISP::VALUES-LIST LISP::*LINK-ARRAY* LISP::&REST SYSTEM::TKCONNECT LISP::MAKE-RANDOM-STATE LISP::CHAR> SYSTEM::INFO-ERROR LISP::BYTE-SIZE LISP::MIN LISP::CDDDR LISP::BIT-IOR LISP::VECTOR LISP::UNSIGNED-BYTE LISP::SERIOUS-CONDITION LISP::SYMBOL-PLIST LISP::*READTABLE* LISP::SIMPLE-BIT-VECTOR-P LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LOWER-CASE-P SYSTEM::ALLOCATE LISP::EQUALP LISP::SUBSTITUTE LISP::SUBSEQ LISP::MINUSP LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-LONG-FLOAT LISP::FILE-LENGTH LISP::FILE-ERROR LISP::HASH-TABLE LISP::SPEED LISP::COMMON LISP::*PRINT-RADIX* LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::RATIONAL LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::FRESH-LINE LISP::WHEN LISP::COMPILE LISP::FLET LISP::SPECIAL LISP::CLASS LISP::CELL-ERROR LISP::RPLACD LISP::TYPE-OF LISP::SPECIAL-OPERATOR-P LISP::DESCRIBE LISP::POSITION LISP::STABLE-SORT LISP::BOTH-CASE-P SYSTEM::*CASE-FOLD-SEARCH* LISP::SYMBOLP LISP::*PRINT-READABLY* LISP::SHADOW LISP::STREAM LISP::CHAR-BITS LISP::MAKE-ARRAY LISP::FUNCTIONP LISP::&WHOLE LISP::SUBST LISP::SCHAR LISP::ARRAY-DIMENSION LISP::COND LISP::DO-EXTERNAL-SYMBOLS LISP::CHAR-CODE-LIMIT LISP::CHAR-FONT-LIMIT LISP::SATISFIES LISP::MASK-FIELD LISP::ARITHMETIC-ERROR LISP::CADDR LISP::LAMBDA-LIST-KEYWORDS LISP::MACRO LISP::STRING-NOT-EQUAL LISP::STRING-LESSP LISP::USE-PACKAGE LISP::MULTIPLE-VALUE-SETQ LISP::>= LISP::LOGEQV LISP::*EVAL-WHEN-COMPILE* LISP::HASH-TABLE-P LISP::GRAPHIC-CHAR-P LISP::EQL LISP::MAPHASH SYSTEM::SETUP-INFO LISP::NINTERSECTION LISP::<= LISP::NAMESTRING LISP::MAKE-CONCATENATED-STREAM LISP::SHORT-FLOAT LISP::FILE-STREAM LISP::WRITE-LINE LISP::VECTOR-PUSH LISP::ENDP LISP::DIRECTORY LISP::TYPE LISP::ASSOC-IF LISP::DPB LISP::TYPEP LISP::FIFTH LISP::LOGNAND LISP::SIGNED-BYTE LISP::EVERY LISP::SUBLIS LISP::NULL LISP::FLOATP LISP::STRING< LISP::*TRACE-OUTPUT* LISP::WRITE-CHAR LISP::SGC LISP::STANDARD-GENERIC-FUNCTION LISP::MAPL LISP::PROG1 LISP::COMPLEXP LISP::PROCLAMATION LISP::INSPECT LISP::MACROEXPAND-1 LISP::BIT-ANDC1 LISP::SETQ LISP::CHAR>= LISP::REALPART LISP::LDIFF LISP::SINH LISP::BROADCAST-STREAM LISP::BASE-STRING LISP::MAKE-STRING SYSTEM::GET-MATCH LISP::CDDDAR LISP::INTEGER-LENGTH LISP::OUTPUT-STREAM-P LISP::NUNION LISP::/= LISP::PACKAGE-NAME LISP::ECASE LISP::PATHNAME LISP::APPLY LISP::CHAR-INT LISP::TAN LISP::MOST-NEGATIVE-FIXNUM LISP::MAKE-SYNONYM-STREAM LISP::MACROEXPAND LISP::CADDAR LISP::ISQRT LISP::CCASE LISP::GCD LISP::KEYWORD LISP::UNLESS LISP::MAP-INTO LISP::SYNONYM-STREAM LISP::SUBSETP LISP::POSITION-IF LISP::INCF LISP::SHIFTF LISP::BOOLE-XOR LISP::REM LISP::LOGNOR LISP::FIND LISP::MAX LISP::SIMPLE-VECTOR-P LISP::IMPORT LISP::MACHINE-VERSION LISP::SHADOWING-IMPORT LISP::BOOLE-EQV LISP::CONJUGATE LISP::READ-CHAR-NO-HANG LISP::WRITE-BYTE LISP::STRING LISP::WITH-OUTPUT-TO-STRING LISP::BYTE-POSITION LISP::STANDARD-CHAR LISP::MEMBER-IF LISP::CHAR-BITS-LIMIT LISP::NSTRING-UPCASE LISP::DEFMACRO LISP::BUTLAST LISP::CDDAAR LISP::IMAGPART LISP::LOGANDC2 LISP::HASH-TABLE-SIZE LISP::FFLOOR LISP::*PRINT-LEVEL* LISP::DEFSTRUCT LISP::DELETE-PACKAGE LISP::BOOLE-CLR LISP::DO-SYMBOLS LISP::INTEGERP LISP::NUMBER LISP::CADAAR LISP::NIL LISP::T LISP::DELETE LISP::DEFCFUN LISP::DEFINE-MODIFY-MACRO LISP::COMPILED-FUNCTION LISP::NOTEVERY LISP::BOOLE-2 LISP::STRUCTURE LISP::UNBOUND-SLOT LISP::RENAME-PACKAGE LISP::SIGNUM LISP::CDDDDR LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::FILE-POSITION LISP::LOGBITP LISP::LAMBDA-BLOCK LISP::STANDARD-METHOD LISP::UNSIGNED-CHAR LISP::PSETQ LISP::EVAL LISP::CERROR LISP::CHAR-GREATERP LISP::GET-SETF-METHOD LISP::SYMBOL-VALUE LISP::+++ LISP::LCM LISP::BOOLE-NAND LISP::SIMPLE-ARRAY LISP::CADDDR LISP::SIMPLE-BIT-VECTOR LISP::CHAR-META-BIT LISP::PRIN1 LISP::BIT-ORC1 LISP::PSETF LISP::RETURN LISP::MAKE-PATHNAME LISP::DOTIMES LISP::DEPOSIT-FIELD LISP::*QUERY-IO* LISP::&ENVIRONMENT LISP::ARRAY-DIMENSIONS LISP::BSD386 LISP::MAKE-BROADCAST-STREAM LISP::BOOLE-ANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::INPUT-STREAM-P LISP::DIGIT-CHAR-P LISP::*STANDARD-INPUT* LISP::BOUNDP LISP::ODDP LISP::READ-DELIMITED-LIST LISP::SIXTH LISP::SUBTYPEP LISP::NSTRING-CAPITALIZE LISP::DECLARE LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE SYSTEM::*MATCH-DATA* LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT LISP::TANH SYSTEM::END-WAITING LISP::ATAN LISP::NOT LISP::STRING-CHAR-P LISP::LONG-SITE-NAME LISP::PATHNAME-VERSION LISP::MAPCAN LISP::REQUIRE LISP::RPLACA LISP::TAGBODY LISP::COPY-ALIST LISP::CADADR LISP::MAPCAR LISP::> LISP::FIND-PACKAGE LISP::FBOUNDP LISP::CLX-LITTLE-ENDIAN LISP::= LISP::DEFSETF LISP::ZEROP LISP::MC68020 LISP::UNUSE-PACKAGE LISP::MOST-POSITIVE-SHORT-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-LONG-FLOAT LISP::LOGICAL-PATHNAME LISP::APPLYHOOK LISP::< LISP::LOGCOUNT LISP::ENOUGH-NAMESTRING LISP::MULTIPLE-VALUE-LIST SYSTEM::MATCH-END LISP::TWO-WAY-STREAM LISP::CDDR LISP::ASSOC LISP::REMF LISP::LDB LISP::MACROLET LISP::CDADR SYSTEM::*CURRENT-INFO-DATA* LISP::UNION LISP::FIND-ALL-SYMBOLS LISP::MAKE-PACKAGE LISP::&OPTIONAL LISP::THIRD LISP::LABELS LISP::BOOLE-C1 LISP::FIND-IF-NOT LISP::LOAD LISP::DELETE-IF-NOT LISP::ACONS LISP::UNDEFINED-FUNCTION LISP::SIGNED-CHAR LISP::INT LISP::PACKAGEP LISP::ENCODE-UNIVERSAL-TIME LISP::FORMAT LISP::TENTH LISP::STRUCTURE-CLASS LISP::MEMBER-IF-NOT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::KCL LISP::BOOLE-1 LISP::REDUCE LISP::SVREF LISP::NTH-VALUE LISP::FORCE-OUTPUT LISP::NSUBSTITUTE-IF-NOT LISP::CATCH LISP::STORAGE-CONDITION LISP::MERGE LISP::CASE LISP::CLEAR-INPUT LISP::REPLACE LISP::*** LISP::GENERIC-FUNCTION LISP::GCL LISP::/ LISP::BOOLE-SET LISP::SOFTWARE-VERSION LISP::APROPOS-LIST LISP::POSITION-IF-NOT LISP::READ-BYTE LISP::FLOAT-RADIX SYSTEM::INFO-DATA LISP::DECF LISP::PROG LISP::- LISP::MAPCON LISP::CADR LISP::EQUAL LISP::CAADR LISP::+ LISP::PATHNAME-DEVICE LISP::MACRO-FUNCTION LISP::MAPLIST LISP::REVERSE LISP::FIND-SYMBOL LISP::* LISP::LOCALLY LISP::BIT-ANDC2 LISP::COMMONP LISP::*FEATURES* LISP::DIVISION-BY-ZERO LISP::ARRAY SYSTEM::INFO LISP::DOUBLE LISP::DEFPARAMETER LISP::PATHNAME-DIRECTORY LISP::STRING-NOT-LESSP LISP::ELT LISP::NTH LISP::RETURN-FROM LISP::BIGNUM LISP::MAKE-SYMBOL LISP::FILL LISP::CHAR-CODE LISP::*PRINT-ESCAPE* LISP::*PRINT-BASE* LISP::*PRINT-CASE* LISP::FLOATING-POINT-INVALID-OPERATION LISP::NSUBST LISP::SIMPLE-VECTOR LISP::ARRAY-IN-BOUNDS-P LISP::READ-PRESERVING-WHITESPACE LISP::ATANH LISP::ATOM LISP::BIT-NAND LISP::VECTOR-POP LISP::MEMBER LISP::REMOVE LISP::CHAR<= LISP::PUSH LISP::PROGRAM-ERROR LISP::KYOTO LISP::CHAR-UPCASE LISP::*PRINT-PRETTY* LISP::MOST-POSITIVE-FIXNUM LISP::PATHNAME-HOST LISP::DOCUMENTATION LISP::// LISP::UNEXPORT LISP::PROBE-FILE LISP::STANDARD-CLASS LISP::GET-INTERNAL-REAL-TIME LISP::GET-INTERNAL-RUN-TIME LISP::NOTANY LISP::QUIT LISP::ROOM LISP::*APPLYHOOK* LISP::COS LISP::CHAR-DOWNCASE LISP::CONSTANTLY LISP::RATIONALIZE LISP::LISP-IMPLEMENTATION-VERSION LISP::CONSTANTP LISP::HASH-TABLE-COUNT LISP::STREAMP SYSTEM::*INFO-PATHS* LISP::*BREAK-ENABLE* LISP::1- LISP::BIT-XOR LISP::STRING-STREAM LISP::GET-PROPERTIES LISP::COUNT-IF-NOT LISP::BIT LISP::ASH LISP::NSUBLIS LISP::FOURTH LISP::STRING<= LISP::STRING>= LISP::STRING/= LISP::SLEEP LISP::LAMBDA-BLOCK-CLOSURE LISP::HELP LISP::TREE-EQUAL LISP::SET LISP::INT-CHAR LISP::STRING-GREATERP LISP::SINGLE-FLOAT-EPSILON LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SPECIAL-FORM-P LISP::COMPLEMENT LISP::WRITE LISP::NCONC LISP::DECODE-UNIVERSAL-TIME LISP::BUILT-IN-CLASS LISP::*RANDOM-STATE* LISP::BOOLE-ORC1 LISP::BOOLE-ORC2 LISP::FILE-NAMESTRING LISP::VOID LISP::BIT-ORC2 LISP::1+ LISP::PROG2 SLOOP::SLOOP SYSTEM::MATCH-BEGINNING LISP::*READ-SUPPRESS* LISP::DOLIST LISP::SIMPLE-BASE-STRING LISP::LET LISP::CHAR-NOT-GREATERP LISP::PATHNAMEP LISP::READ LISP::RANDOM-STATE-P SYSTEM::TAGS LISP::CDDAR LISP::BY LISP::SFUN LISP::REMOVE-IF LISP::&ALLOW-OTHER-KEYS LISP::FROUND LISP::CHAR-EQUAL LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::EIGHTH LISP::OPTIMIZE LISP::++ LISP::DO* LISP::SIMPLE-TYPE-ERROR LISP::ASIN LISP::SINGLE-FLOAT LISP::CCLOSURE LISP::REAL LISP::CHARACTER LISP::CHARACTERP LISP::GET SYSTEM::NODE LISP::OBJECT LISP::REALP LISP::FCEILING LISP::COPY-SYMBOL LISP::CHAR LISP::STANDARD-CHAR-P LISP::*DEBUG-IO* LISP::FIXNUM LISP::COMPILED-FUNCTION-P LISP::COUNT-IF LISP::** LISP::METHOD LISP::WITH-OPEN-FILE LISP::PACKAGE LISP::TRUNCATE_USE_C LISP::IGNORE LISP::IDENTITY LISP::CTYPECASE LISP::ETYPECASE LISP::PROGV LISP::NSUBSTITUTE-IF LISP::BOOLE-NOR SLOOP::DEF-LOOP-COLLECT)) ;;; Definitions for package DEFPACKAGE of type SHADOW (LISP::IN-PACKAGE "DEFPACKAGE") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::EXP LISP::DEFVAR LISP::DISASSEMBLE LISP::DELETE-IF LISP::UNSIGNED-SHORT LISP::GFUN LISP::NSUBST-IF-NOT LISP::CIS LISP::LOGAND LISP::BIT-EQV LISP::UNIX LISP::RANDOM LISP::COPY-LIST LISP::KEYWORDP LISP::CADAR LISP::MERGE-PATHNAMES LISP::BOOLE-C2 LISP::BIT-NOT LISP::CFUN LISP::STANDARD-OBJECT LISP::STRINGP LISP::METHOD-COMBINATION LISP::NSET-EXCLUSIVE-OR LISP::CLOSE LISP::INTEGER-DECODE-FLOAT LISP::CHAR-NOT-EQUAL LISP::COSH LISP::NTHCDR LISP::GET-UNIVERSAL-TIME LISP::YES-OR-NO-P LISP::READ-LINE LISP::LET* LISP::PATHNAME-TYPE LISP::FLOAT-PRECISION LISP::PROG* LISP::SYMBOL-NAME LISP::LOG LISP::OR LISP::PACKAGE-SHADOWING-SYMBOLS LISP::BREAK LISP::STRUCTURE-OBJECT LISP::ROTATEF LISP::SQRT LISP::CONS LISP::NSUBST-IF LISP::UNWIND-PROTECT LISP::CONSP SLOOP::DEF-LOOP-MACRO LISP::FLOAT-SIGN LISP::*EVALHOOK* LISP::CHAR-BIT LISP::SOME LISP::MAPC LISP::SETF LISP::CEILING LISP::&BODY LISP::CDAR LISP::MAKE-LIST LISP::MAKE-HASH-TABLE LISP::STRING-UPCASE LISP::STRING-DOWNCASE LISP::STYLE-WARNING LISP::ASINH LISP::NRECONC LISP::NSTRING-DOWNCASE LISP::SECOND LISP::RATIONALP LISP::SET-DISPATCH-MACRO-CHARACTER LISP::GET-DISPATCH-MACRO-CHARACTER LISP::CHECK-TYPE LISP::MAKE-STRING-INPUT-STREAM LISP::MAKE-STRING-OUTPUT-STREAM LISP::*BREAK-ON-WARNINGS* LISP::BYE LISP::SAFETY LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::*LOAD-VERBOSE* LISP::OTHERWISE LISP::NBUTLAST LISP::SORT LISP::WARNING LISP::DEFLA LISP::PROGN LISP::PUSHNEW LISP::SYSTEM LISP::CHAR= LISP::SIGNED-SHORT LISP::MAKE-ECHO-STREAM LISP::BIT-AND LISP::EXPORT LISP::EQ LISP::SOFTWARE-TYPE LISP::LOGTEST LISP::LIST-ALL-PACKAGES LISP::DEFTYPE LISP::GETF LISP::ROW-MAJOR-AREF LISP::TYPECASE LISP::CHAR-CONTROL-BIT LISP::HASH-TABLE-TEST LISP::USER-HOMEDIR-PATHNAME LISP::SYMBOL-PACKAGE LISP::BOOLEAN LISP::HOST-NAMESTRING LISP::IN-PACKAGE LISP::CAAR LISP::INTERN LISP::CONDITION LISP::IEEE-FLOATING-POINT LISP::LOGNOT LISP::SUBST-IF-NOT LISP::COPY-READTABLE LISP::REVAPPEND LISP::SYMBOL LISP::BIT-VECTOR LISP::SEARCH LISP::STREAM-ELEMENT-TYPE LISP::POP LISP::GO LISP::LIST LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::PARSE-ERROR LISP::VALUES LISP::DESTRUCTURING-BIND LISP::RANDOM-STATE LISP::LISTP LISP::CHAR/= LISP::REMPROP LISP::DO LISP::HELP* LISP::ABS LISP::&KEY LISP::VECTOR-PUSH-EXTEND LISP::PACKAGE-NICKNAMES LISP::MULTIPLE-VALUE-PROG1 SLOOP::LOOP-RETURN LISP::END-OF-FILE LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::EXPT LISP::READER-ERROR LISP::REMHASH LISP::BLOCK LISP::PACKAGE-ERROR LISP::LAMBDA-CLOSURE LISP::PARSE-INTEGER LISP::TIME LISP::COERCE LISP::FIND-IF LISP::UNREAD-CHAR LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE LISP::SPECIFIC-ERROR LISP::FIRST LISP::ALPHANUMERICP LISP::WITH-HASH-TABLE-ITERATOR LISP::SCALE-FLOAT LISP::CONCATENATED-STREAM LISP::CONTROL-ERROR LISP::FINISH-OUTPUT LISP::LAMBDA-PARAMETERS-LIMIT LISP::PRINC LISP::ADJOIN LISP::PI LISP::DOUBLE-FLOAT LISP::READTABLE LISP::READTABLEP LISP::ARRAY-RANK-LIMIT LISP::RENAME-FILE LISP::READ-CHAR LISP::PEEK-CHAR LISP::REMOVE-DUPLICATES LISP::BYTE LISP::*MODULES* LISP::GET-OUTPUT-STREAM-STRING LISP::MULTIPLE-VALUE-BIND LISP::VECTORP LISP::RASSOC-IF-NOT LISP::UNINTERN SLOOP::LOOP-FINISH LISP::SPECIFIC-CORRECTABLE-ERROR LISP::CDADAR LISP::FUNCTION LISP::LOGORC2 LISP::*PACKAGE* LISP::STRING-NOT-GREATERP LISP::INTERSECTION LISP::SPACE LISP::SEVENTH LISP::BASE-CHAR LISP::MAKE-CHAR LISP::NAME-CHAR LISP::SBIT LISP::CAADAR LISP::TAILP LISP::*TERMINAL-IO* LISP::STREAM-ERROR LISP::BOOLE-ANDC1 LISP::DO-ALL-SYMBOLS LISP::MAKUNBOUND LISP::PROVIDE LISP::THROW LISP::LENGTH LISP::CDAAR LISP::&AUX LISP::ARRAY-DISPLACEMENT LISP::PAIRLIS LISP::*PRINT-GENSYM* LISP::COMPILE-FILE-PATHNAME LISP::CAR LISP::FTRUNCATE LISP::DELETE-DUPLICATES LISP::NREVERSE LISP::APROPOS LISP::STRING-RIGHT-TRIM LISP::STEP LISP::BIT-NOR LISP::ARRAY-TOTAL-SIZE LISP::ECHO-STREAM LISP::DEFINE-SETF-METHOD LISP::FMAKUNBOUND LISP::SUBST-IF LISP::GET-DECODED-TIME LISP::LONG-FLOAT LISP::SIMPLE-WARNING LISP::CHAR-HYPER-BIT LISP::TAG LISP::RATIO LISP::EVENP LISP::QUOTE LISP::SIMPLE-STRING LISP::NSUBSTITUTE LISP::LAST LISP::NSET-DIFFERENCE LISP::COUNT LISP::CDAAAR LISP::SET-DIFFERENCE SLOOP::DEF-LOOP-FOR LISP::PPRINT LISP::SHORT-FLOAT-EPSILON LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SET-CHAR-BIT LISP::ACOSH LISP::LISTEN LISP::GENTEMP LISP::ERROR LISP::BSD LISP::ADJUST-ARRAY LISP::CLINES LISP::IF LISP::CAAAAR LISP::SET-SYNTAX-FROM-CHAR LISP::STRING-TRIM LISP::DIGIT-CHAR LISP::BOOLE-AND LISP::STRING> LISP::CAAAR LISP::GETHASH LISP::FILL-POINTER SLOOP::DEF-LOOP-MAP LISP::CDADDR LISP::DIRECTORY-NAMESTRING LISP::DEFUN LISP::TRUNCATE LISP::DEFENTRY LISP::ALPHA-CHAR-P LISP::SYMBOL-FUNCTION LISP::SUBSTITUTE-IF-NOT LISP::LDB-TEST LISP::FLOAT-DIGITS LISP::BIT-VECTOR-P LISP::CAADDR LISP::VARIABLE LISP::NUMERATOR LISP::NOTINLINE LISP::CHAR-LESSP LISP::WARN LISP::CHAR-NOT-LESSP LISP::ARRAY-DIMENSION-LIMIT LISP::MOD LISP::SXHASH LISP::PACKAGE-USE-LIST LISP::PACKAGE-USED-BY-LIST LISP::MACHINE-INSTANCE LISP::ARRAYP LISP::*GENSYM-COUNTER* LISP::UPPER-CASE-P LISP::*PRINT-CIRCLE* LISP::FTYPE LISP::THE SLOOP::LOCAL-FINISH LISP::COMPILER-LET LISP::WRITE-TO-STRING LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::SEQUENCE LISP::FILE-AUTHOR LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH LISP::SIMPLE-STRING-P LISP::PRINT LISP::MULTIPLE-VALUES-LIMIT LISP::PRIN1-TO-STRING LISP::PRINC-TO-STRING LISP::SIMPLE-CONDITION LISP::TERPRI LISP::CDAADR LISP::FLOATING-POINT-OVERFLOW LISP::FLOATING-POINT-UNDERFLOW LISP::CALL-ARGUMENTS-LIMIT LISP::COPY-SEQ LISP::FUNCALL LISP::CLRHASH LISP::SHORT-SITE-NAME LISP::LONG-FLOAT-EPSILON LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::ASSOC-IF-NOT LISP::CAAADR LISP::STRING-CHAR LISP::LOGANDC1 LISP::WITH-PACKAGE-ITERATOR LISP::NUMBERP LISP::COMPLEX LISP::AND LISP::EVAL-WHEN LISP::LOOP LISP::READ-FROM-STRING LISP::*STANDARD-OUTPUT* LISP::CHAR-NAME LISP::COMPILE-FILE LISP::FLOAT LISP::*ERROR-OUTPUT* LISP::TYPE-ERROR LISP::COMPILATION-SPEED LISP::LOGXOR LISP::LIST-LENGTH LISP::DRIBBLE LISP::EXTENDED-CHAR LISP::MAP LISP::ARRAY-ELEMENT-TYPE LISP::ROUND LISP::STRING-LEFT-TRIM LISP::DECLAIM LISP::SAVE LISP::SIN LISP::*PRINT-LENGTH* LISP::DECLARATION LISP::DECODE-FLOAT LISP::PATHNAME-NAME LISP::STRING= LISP::PHASE LISP::SPICE LISP::RASSOC LISP::LISP-IMPLEMENTATION-TYPE LISP::UNTRACE LISP::PRINT-NOT-READABLE LISP::ARRAY-ROW-MAJOR-INDEX LISP::SUBSTITUTE-IF LISP::BOOLE LISP::TRUENAME LISP::DEFCONSTANT LISP::VALUES-LIST LISP::*LINK-ARRAY* LISP::&REST LISP::MAKE-RANDOM-STATE LISP::CHAR> LISP::BYTE-SIZE LISP::MIN LISP::CDDDR LISP::BIT-IOR LISP::VECTOR LISP::UNSIGNED-BYTE LISP::SERIOUS-CONDITION LISP::SYMBOL-PLIST LISP::*READTABLE* LISP::SIMPLE-BIT-VECTOR-P LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LOWER-CASE-P SYSTEM::ALLOCATE LISP::EQUALP LISP::SUBSTITUTE LISP::SUBSEQ LISP::MINUSP LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-LONG-FLOAT LISP::FILE-LENGTH LISP::FILE-ERROR LISP::HASH-TABLE LISP::SPEED LISP::COMMON LISP::*PRINT-RADIX* LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::RATIONAL LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::FRESH-LINE LISP::WHEN LISP::COMPILE LISP::FLET LISP::SPECIAL LISP::CLASS LISP::CELL-ERROR LISP::RPLACD LISP::TYPE-OF LISP::SPECIAL-OPERATOR-P LISP::DESCRIBE LISP::POSITION LISP::STABLE-SORT LISP::BOTH-CASE-P LISP::SYMBOLP LISP::*PRINT-READABLY* LISP::SHADOW LISP::STREAM LISP::CHAR-BITS LISP::MAKE-ARRAY LISP::FUNCTIONP LISP::&WHOLE LISP::SUBST LISP::SCHAR LISP::ARRAY-DIMENSION LISP::COND LISP::DO-EXTERNAL-SYMBOLS LISP::CHAR-CODE-LIMIT LISP::CHAR-FONT-LIMIT LISP::SATISFIES LISP::MASK-FIELD LISP::ARITHMETIC-ERROR LISP::CADDR LISP::LAMBDA-LIST-KEYWORDS LISP::MACRO LISP::STRING-NOT-EQUAL LISP::STRING-LESSP LISP::USE-PACKAGE LISP::MULTIPLE-VALUE-SETQ LISP::>= LISP::LOGEQV LISP::*EVAL-WHEN-COMPILE* LISP::HASH-TABLE-P LISP::GRAPHIC-CHAR-P LISP::EQL LISP::MAPHASH LISP::NINTERSECTION LISP::<= LISP::NAMESTRING LISP::MAKE-CONCATENATED-STREAM LISP::SHORT-FLOAT LISP::FILE-STREAM LISP::WRITE-LINE LISP::VECTOR-PUSH LISP::ENDP LISP::DIRECTORY LISP::TYPE LISP::ASSOC-IF LISP::DPB LISP::TYPEP LISP::FIFTH LISP::LOGNAND LISP::SIGNED-BYTE LISP::EVERY LISP::SUBLIS LISP::NULL LISP::FLOATP LISP::STRING< LISP::*TRACE-OUTPUT* LISP::WRITE-CHAR LISP::SGC LISP::STANDARD-GENERIC-FUNCTION LISP::MAPL LISP::PROG1 LISP::COMPLEXP LISP::PROCLAMATION LISP::INSPECT LISP::MACROEXPAND-1 LISP::BIT-ANDC1 LISP::SETQ LISP::CHAR>= LISP::REALPART LISP::LDIFF LISP::SINH LISP::BROADCAST-STREAM LISP::BASE-STRING LISP::MAKE-STRING LISP::CDDDAR LISP::INTEGER-LENGTH LISP::OUTPUT-STREAM-P LISP::NUNION LISP::/= LISP::PACKAGE-NAME LISP::ECASE LISP::PATHNAME LISP::APPLY LISP::CHAR-INT LISP::TAN LISP::MOST-NEGATIVE-FIXNUM LISP::MAKE-SYNONYM-STREAM LISP::MACROEXPAND LISP::CADDAR LISP::ISQRT LISP::CCASE LISP::GCD LISP::KEYWORD LISP::UNLESS LISP::MAP-INTO LISP::SYNONYM-STREAM LISP::SUBSETP LISP::POSITION-IF LISP::INCF LISP::SHIFTF LISP::BOOLE-XOR LISP::REM LISP::LOGNOR LISP::FIND LISP::MAX LISP::SIMPLE-VECTOR-P LISP::IMPORT LISP::MACHINE-VERSION LISP::SHADOWING-IMPORT LISP::BOOLE-EQV LISP::CONJUGATE LISP::READ-CHAR-NO-HANG LISP::WRITE-BYTE LISP::WITH-OUTPUT-TO-STRING LISP::BYTE-POSITION LISP::STANDARD-CHAR LISP::STRING LISP::MEMBER-IF LISP::CHAR-BITS-LIMIT LISP::NSTRING-UPCASE LISP::DEFMACRO LISP::BUTLAST LISP::CDDAAR LISP::IMAGPART LISP::LOGANDC2 LISP::HASH-TABLE-SIZE LISP::FFLOOR LISP::*PRINT-LEVEL* LISP::DEFSTRUCT LISP::DELETE-PACKAGE LISP::BOOLE-CLR LISP::DO-SYMBOLS LISP::INTEGERP LISP::NUMBER LISP::CADAAR LISP::NIL LISP::T LISP::DELETE LISP::DEFCFUN LISP::DEFINE-MODIFY-MACRO LISP::COMPILED-FUNCTION LISP::NOTEVERY LISP::BOOLE-2 LISP::STRUCTURE LISP::UNBOUND-SLOT LISP::RENAME-PACKAGE LISP::SIGNUM LISP::CDDDDR LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::FILE-POSITION LISP::LOGBITP LISP::LAMBDA-BLOCK LISP::STANDARD-METHOD LISP::UNSIGNED-CHAR LISP::PSETQ LISP::EVAL LISP::CERROR LISP::CHAR-GREATERP LISP::GET-SETF-METHOD LISP::SYMBOL-VALUE LISP::+++ LISP::LCM LISP::BOOLE-NAND LISP::SIMPLE-ARRAY LISP::CADDDR LISP::SIMPLE-BIT-VECTOR LISP::CHAR-META-BIT LISP::PRIN1 LISP::BIT-ORC1 LISP::PSETF LISP::RETURN LISP::MAKE-PATHNAME LISP::DOTIMES LISP::DEPOSIT-FIELD LISP::*QUERY-IO* LISP::&ENVIRONMENT LISP::ARRAY-DIMENSIONS LISP::BSD386 LISP::MAKE-BROADCAST-STREAM LISP::BOOLE-ANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::INPUT-STREAM-P LISP::DIGIT-CHAR-P LISP::*STANDARD-INPUT* LISP::BOUNDP LISP::ODDP LISP::READ-DELIMITED-LIST LISP::SIXTH LISP::SUBTYPEP LISP::NSTRING-CAPITALIZE LISP::DECLARE LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT LISP::TANH LISP::ATAN LISP::NOT LISP::STRING-CHAR-P LISP::LONG-SITE-NAME LISP::PATHNAME-VERSION LISP::MAPCAN LISP::REQUIRE LISP::RPLACA LISP::TAGBODY LISP::COPY-ALIST LISP::CADADR LISP::MAPCAR LISP::> LISP::FIND-PACKAGE LISP::FBOUNDP LISP::CLX-LITTLE-ENDIAN LISP::= LISP::DEFSETF LISP::ZEROP LISP::MC68020 LISP::UNUSE-PACKAGE LISP::MOST-POSITIVE-SHORT-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-LONG-FLOAT LISP::LOGICAL-PATHNAME LISP::APPLYHOOK LISP::< LISP::LOGCOUNT LISP::ENOUGH-NAMESTRING LISP::MULTIPLE-VALUE-LIST LISP::TWO-WAY-STREAM LISP::CDDR LISP::ASSOC LISP::REMF LISP::LDB LISP::MACROLET LISP::CDADR LISP::UNION LISP::FIND-ALL-SYMBOLS LISP::MAKE-PACKAGE LISP::&OPTIONAL LISP::THIRD LISP::LABELS LISP::BOOLE-C1 LISP::FIND-IF-NOT LISP::LOAD LISP::DELETE-IF-NOT LISP::ACONS LISP::UNDEFINED-FUNCTION LISP::SIGNED-CHAR LISP::INT LISP::PACKAGEP LISP::ENCODE-UNIVERSAL-TIME LISP::FORMAT LISP::TENTH LISP::STRUCTURE-CLASS LISP::MEMBER-IF-NOT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::KCL LISP::BOOLE-1 LISP::REDUCE LISP::SVREF LISP::NTH-VALUE LISP::FORCE-OUTPUT LISP::NSUBSTITUTE-IF-NOT LISP::CATCH LISP::STORAGE-CONDITION LISP::MERGE LISP::CASE LISP::CLEAR-INPUT LISP::REPLACE LISP::*** LISP::GENERIC-FUNCTION LISP::GCL LISP::/ LISP::BOOLE-SET LISP::SOFTWARE-VERSION LISP::APROPOS-LIST LISP::POSITION-IF-NOT LISP::READ-BYTE LISP::FLOAT-RADIX LISP::DECF LISP::PROG LISP::- LISP::MAPCON LISP::CADR LISP::EQUAL LISP::CAADR LISP::+ LISP::PATHNAME-DEVICE LISP::MACRO-FUNCTION LISP::MAPLIST LISP::REVERSE LISP::FIND-SYMBOL LISP::* LISP::LOCALLY LISP::BIT-ANDC2 LISP::COMMONP LISP::*FEATURES* LISP::DIVISION-BY-ZERO LISP::ARRAY LISP::DOUBLE LISP::DEFPARAMETER LISP::PATHNAME-DIRECTORY LISP::STRING-NOT-LESSP LISP::ELT LISP::NTH LISP::RETURN-FROM LISP::BIGNUM LISP::MAKE-SYMBOL LISP::FILL LISP::CHAR-CODE LISP::*PRINT-ESCAPE* LISP::*PRINT-BASE* LISP::*PRINT-CASE* LISP::FLOATING-POINT-INVALID-OPERATION LISP::NSUBST LISP::SIMPLE-VECTOR LISP::ARRAY-IN-BOUNDS-P LISP::READ-PRESERVING-WHITESPACE LISP::ATANH LISP::ATOM LISP::BIT-NAND LISP::VECTOR-POP LISP::MEMBER LISP::REMOVE LISP::CHAR<= LISP::PUSH LISP::PROGRAM-ERROR LISP::KYOTO LISP::CHAR-UPCASE LISP::*PRINT-PRETTY* LISP::MOST-POSITIVE-FIXNUM LISP::PATHNAME-HOST LISP::DOCUMENTATION LISP::// LISP::UNEXPORT LISP::PROBE-FILE LISP::STANDARD-CLASS LISP::GET-INTERNAL-REAL-TIME LISP::GET-INTERNAL-RUN-TIME LISP::NOTANY LISP::QUIT LISP::ROOM LISP::*APPLYHOOK* LISP::COS LISP::CHAR-DOWNCASE LISP::CONSTANTLY LISP::RATIONALIZE LISP::LISP-IMPLEMENTATION-VERSION LISP::CONSTANTP LISP::HASH-TABLE-COUNT LISP::STREAMP LISP::*BREAK-ENABLE* LISP::1- LISP::BIT-XOR LISP::STRING-STREAM LISP::GET-PROPERTIES LISP::COUNT-IF-NOT LISP::BIT LISP::ASH LISP::NSUBLIS LISP::FOURTH LISP::STRING<= LISP::STRING>= LISP::STRING/= LISP::SLEEP LISP::LAMBDA-BLOCK-CLOSURE LISP::HELP LISP::TREE-EQUAL LISP::SET LISP::INT-CHAR LISP::STRING-GREATERP LISP::SINGLE-FLOAT-EPSILON LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SPECIAL-FORM-P LISP::COMPLEMENT LISP::WRITE LISP::NCONC LISP::DECODE-UNIVERSAL-TIME LISP::BUILT-IN-CLASS LISP::*RANDOM-STATE* LISP::BOOLE-ORC1 LISP::BOOLE-ORC2 LISP::FILE-NAMESTRING LISP::VOID LISP::BIT-ORC2 LISP::1+ LISP::PROG2 SLOOP::SLOOP LISP::*READ-SUPPRESS* LISP::DOLIST LISP::SIMPLE-BASE-STRING LISP::LET LISP::CHAR-NOT-GREATERP LISP::PATHNAMEP LISP::READ LISP::RANDOM-STATE-P LISP::CDDAR LISP::BY LISP::SFUN LISP::REMOVE-IF LISP::&ALLOW-OTHER-KEYS LISP::FROUND LISP::CHAR-EQUAL LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::EIGHTH LISP::OPTIMIZE LISP::++ LISP::DO* LISP::SIMPLE-TYPE-ERROR LISP::ASIN LISP::SINGLE-FLOAT LISP::CCLOSURE LISP::REAL LISP::CHARACTER LISP::CHARACTERP LISP::GET LISP::OBJECT LISP::REALP LISP::FCEILING LISP::COPY-SYMBOL LISP::CHAR LISP::STANDARD-CHAR-P LISP::*DEBUG-IO* LISP::FIXNUM LISP::COMPILED-FUNCTION-P LISP::COUNT-IF LISP::** LISP::METHOD LISP::WITH-OPEN-FILE LISP::PACKAGE LISP::TRUNCATE_USE_C LISP::IGNORE LISP::IDENTITY LISP::CTYPECASE LISP::ETYPECASE LISP::PROGV LISP::NSUBSTITUTE-IF LISP::BOOLE-NOR SLOOP::DEF-LOOP-COLLECT)) ;;; Definitions for package ANSI-LOOP of type SHADOW (LISP::IN-PACKAGE "ANSI-LOOP") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::LOOP LISP::EXP LISP::DEFVAR LISP::DISASSEMBLE LISP::DELETE-IF LISP::UNSIGNED-SHORT LISP::GFUN LISP::NSUBST-IF-NOT LISP::CIS LISP::LOGAND LISP::BIT-EQV LISP::UNIX LISP::RANDOM LISP::COPY-LIST LISP::KEYWORDP LISP::CADAR LISP::MERGE-PATHNAMES LISP::BOOLE-C2 LISP::BIT-NOT LISP::CFUN LISP::STANDARD-OBJECT LISP::STRINGP LISP::METHOD-COMBINATION LISP::NSET-EXCLUSIVE-OR LISP::CLOSE LISP::INTEGER-DECODE-FLOAT LISP::CHAR-NOT-EQUAL LISP::COSH LISP::NTHCDR LISP::GET-UNIVERSAL-TIME LISP::YES-OR-NO-P LISP::READ-LINE LISP::LET* LISP::PATHNAME-TYPE LISP::FLOAT-PRECISION LISP::PROG* LISP::SYMBOL-NAME LISP::LOG LISP::OR LISP::PACKAGE-SHADOWING-SYMBOLS LISP::BREAK LISP::STRUCTURE-OBJECT LISP::ROTATEF LISP::SQRT LISP::CONS LISP::NSUBST-IF LISP::UNWIND-PROTECT LISP::CONSP LISP::FLOAT-SIGN LISP::*EVALHOOK* LISP::CHAR-BIT LISP::SOME LISP::MAPC LISP::SETF LISP::CEILING LISP::&BODY LISP::CDAR LISP::MAKE-LIST LISP::MAKE-HASH-TABLE LISP::STRING-UPCASE LISP::STRING-DOWNCASE LISP::STYLE-WARNING LISP::ASINH LISP::NRECONC LISP::NSTRING-DOWNCASE LISP::SECOND LISP::RATIONALP LISP::SET-DISPATCH-MACRO-CHARACTER LISP::GET-DISPATCH-MACRO-CHARACTER LISP::CHECK-TYPE LISP::MAKE-STRING-INPUT-STREAM LISP::MAKE-STRING-OUTPUT-STREAM LISP::*BREAK-ON-WARNINGS* LISP::BYE LISP::SAFETY LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::*LOAD-VERBOSE* LISP::OTHERWISE LISP::NBUTLAST LISP::SORT LISP::WARNING LISP::DEFLA LISP::PROGN LISP::PUSHNEW LISP::SYSTEM LISP::CHAR= LISP::SIGNED-SHORT LISP::MAKE-ECHO-STREAM LISP::BIT-AND LISP::EXPORT LISP::EQ LISP::SOFTWARE-TYPE LISP::LOGTEST LISP::LIST-ALL-PACKAGES LISP::DEFTYPE LISP::GETF LISP::ROW-MAJOR-AREF LISP::TYPECASE LISP::CHAR-CONTROL-BIT LISP::HASH-TABLE-TEST LISP::USER-HOMEDIR-PATHNAME LISP::SYMBOL-PACKAGE LISP::BOOLEAN LISP::HOST-NAMESTRING LISP::IN-PACKAGE LISP::CAAR LISP::INTERN LISP::CONDITION LISP::IEEE-FLOATING-POINT LISP::LOGNOT LISP::SUBST-IF-NOT LISP::COPY-READTABLE LISP::REVAPPEND LISP::SYMBOL LISP::BIT-VECTOR LISP::SEARCH LISP::STREAM-ELEMENT-TYPE LISP::POP LISP::GO LISP::LIST LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::PARSE-ERROR LISP::VALUES LISP::DESTRUCTURING-BIND LISP::RANDOM-STATE LISP::LISTP LISP::CHAR/= LISP::REMPROP LISP::DO LISP::HELP* LISP::ABS LISP::&KEY LISP::VECTOR-PUSH-EXTEND LISP::PACKAGE-NICKNAMES LISP::MULTIPLE-VALUE-PROG1 LISP::END-OF-FILE LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::EXPT LISP::READER-ERROR LISP::REMHASH LISP::BLOCK LISP::PACKAGE-ERROR LISP::LAMBDA-CLOSURE LISP::PARSE-INTEGER LISP::TIME LISP::COERCE LISP::FIND-IF LISP::UNREAD-CHAR LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE LISP::SPECIFIC-ERROR LISP::FIRST LISP::ALPHANUMERICP LISP::WITH-HASH-TABLE-ITERATOR LISP::SCALE-FLOAT LISP::CONCATENATED-STREAM LISP::CONTROL-ERROR LISP::FINISH-OUTPUT LISP::LAMBDA-PARAMETERS-LIMIT LISP::PRINC LISP::ADJOIN LISP::PI LISP::DOUBLE-FLOAT LISP::READTABLE LISP::READTABLEP LISP::ARRAY-RANK-LIMIT LISP::RENAME-FILE LISP::READ-CHAR LISP::PEEK-CHAR LISP::REMOVE-DUPLICATES LISP::BYTE LISP::*MODULES* LISP::GET-OUTPUT-STREAM-STRING LISP::MULTIPLE-VALUE-BIND LISP::VECTORP LISP::RASSOC-IF-NOT LISP::UNINTERN LISP::SPECIFIC-CORRECTABLE-ERROR LISP::CDADAR LISP::FUNCTION LISP::LOGORC2 LISP::*PACKAGE* LISP::STRING-NOT-GREATERP LISP::INTERSECTION LISP::SPACE LISP::SEVENTH LISP::BASE-CHAR LISP::MAKE-CHAR LISP::NAME-CHAR LISP::SBIT LISP::CAADAR LISP::TAILP LISP::*TERMINAL-IO* LISP::STREAM-ERROR LISP::BOOLE-ANDC1 LISP::DO-ALL-SYMBOLS LISP::MAKUNBOUND LISP::PROVIDE LISP::THROW LISP::LENGTH LISP::CDAAR LISP::&AUX LISP::ARRAY-DISPLACEMENT LISP::PAIRLIS LISP::*PRINT-GENSYM* LISP::COMPILE-FILE-PATHNAME LISP::CAR LISP::FTRUNCATE LISP::DELETE-DUPLICATES LISP::NREVERSE LISP::APROPOS LISP::STRING-RIGHT-TRIM LISP::STEP LISP::BIT-NOR LISP::ARRAY-TOTAL-SIZE LISP::ECHO-STREAM LISP::DEFINE-SETF-METHOD LISP::FMAKUNBOUND LISP::SUBST-IF LISP::GET-DECODED-TIME LISP::LONG-FLOAT LISP::SIMPLE-WARNING LISP::CHAR-HYPER-BIT LISP::TAG LISP::RATIO LISP::EVENP LISP::QUOTE LISP::SIMPLE-STRING LISP::NSUBSTITUTE LISP::LAST LISP::NSET-DIFFERENCE LISP::COUNT LISP::CDAAAR LISP::SET-DIFFERENCE LISP::PPRINT LISP::SHORT-FLOAT-EPSILON LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SET-CHAR-BIT LISP::ACOSH LISP::LISTEN LISP::GENTEMP LISP::ERROR LISP::BSD LISP::ADJUST-ARRAY LISP::CLINES LISP::IF LISP::CAAAAR LISP::SET-SYNTAX-FROM-CHAR LISP::STRING-TRIM LISP::DIGIT-CHAR LISP::BOOLE-AND LISP::STRING> LISP::CAAAR LISP::GETHASH LISP::FILL-POINTER LISP::CDADDR LISP::DIRECTORY-NAMESTRING LISP::DEFUN LISP::TRUNCATE LISP::DEFENTRY LISP::ALPHA-CHAR-P LISP::SYMBOL-FUNCTION LISP::SUBSTITUTE-IF-NOT LISP::LDB-TEST LISP::FLOAT-DIGITS LISP::BIT-VECTOR-P LISP::CAADDR LISP::VARIABLE LISP::NUMERATOR LISP::NOTINLINE LISP::CHAR-LESSP LISP::WARN LISP::CHAR-NOT-LESSP LISP::ARRAY-DIMENSION-LIMIT LISP::MOD LISP::SXHASH LISP::PACKAGE-USE-LIST LISP::PACKAGE-USED-BY-LIST LISP::MACHINE-INSTANCE LISP::ARRAYP LISP::*GENSYM-COUNTER* LISP::UPPER-CASE-P LISP::*PRINT-CIRCLE* LISP::FTYPE LISP::THE LISP::COMPILER-LET LISP::WRITE-TO-STRING LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::SEQUENCE LISP::FILE-AUTHOR LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH LISP::SIMPLE-STRING-P LISP::PRINT LISP::MULTIPLE-VALUES-LIMIT LISP::PRIN1-TO-STRING LISP::PRINC-TO-STRING LISP::SIMPLE-CONDITION LISP::TERPRI LISP::CDAADR LISP::FLOATING-POINT-OVERFLOW LISP::FLOATING-POINT-UNDERFLOW LISP::CALL-ARGUMENTS-LIMIT LISP::COPY-SEQ LISP::FUNCALL LISP::CLRHASH LISP::SHORT-SITE-NAME LISP::LONG-FLOAT-EPSILON LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::ASSOC-IF-NOT LISP::CAAADR LISP::STRING-CHAR LISP::LOGANDC1 LISP::WITH-PACKAGE-ITERATOR LISP::NUMBERP LISP::COMPLEX LISP::AND LISP::EVAL-WHEN LISP::READ-FROM-STRING LISP::*STANDARD-OUTPUT* LISP::CHAR-NAME LISP::COMPILE-FILE LISP::FLOAT LISP::*ERROR-OUTPUT* LISP::TYPE-ERROR LISP::COMPILATION-SPEED LISP::LOGXOR LISP::LIST-LENGTH LISP::DRIBBLE LISP::EXTENDED-CHAR LISP::MAP LISP::ARRAY-ELEMENT-TYPE LISP::ROUND LISP::STRING-LEFT-TRIM LISP::DECLAIM LISP::SAVE LISP::SIN LISP::*PRINT-LENGTH* LISP::DECLARATION LISP::DECODE-FLOAT LISP::PATHNAME-NAME LISP::STRING= LISP::PHASE LISP::SPICE LISP::RASSOC LISP::LISP-IMPLEMENTATION-TYPE LISP::UNTRACE LISP::PRINT-NOT-READABLE LISP::ARRAY-ROW-MAJOR-INDEX LISP::SUBSTITUTE-IF LISP::BOOLE LISP::TRUENAME LISP::DEFCONSTANT LISP::VALUES-LIST LISP::*LINK-ARRAY* LISP::&REST LISP::MAKE-RANDOM-STATE LISP::CHAR> LISP::BYTE-SIZE LISP::MIN LISP::CDDDR LISP::BIT-IOR LISP::VECTOR LISP::UNSIGNED-BYTE LISP::SERIOUS-CONDITION LISP::SYMBOL-PLIST LISP::*READTABLE* LISP::SIMPLE-BIT-VECTOR-P LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LOWER-CASE-P SYSTEM::ALLOCATE LISP::EQUALP LISP::SUBSTITUTE LISP::SUBSEQ LISP::MINUSP LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-LONG-FLOAT LISP::FILE-LENGTH LISP::FILE-ERROR LISP::HASH-TABLE LISP::SPEED LISP::COMMON LISP::*PRINT-RADIX* LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::RATIONAL LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::FRESH-LINE LISP::WHEN LISP::COMPILE LISP::FLET LISP::SPECIAL LISP::CLASS LISP::CELL-ERROR LISP::RPLACD LISP::TYPE-OF LISP::SPECIAL-OPERATOR-P LISP::DESCRIBE LISP::POSITION LISP::STABLE-SORT LISP::BOTH-CASE-P LISP::SYMBOLP LISP::*PRINT-READABLY* LISP::SHADOW LISP::STREAM LISP::CHAR-BITS LISP::MAKE-ARRAY LISP::FUNCTIONP LISP::&WHOLE LISP::SUBST LISP::SCHAR LISP::ARRAY-DIMENSION LISP::COND LISP::DO-EXTERNAL-SYMBOLS LISP::CHAR-CODE-LIMIT LISP::CHAR-FONT-LIMIT LISP::SATISFIES LISP::MASK-FIELD LISP::ARITHMETIC-ERROR LISP::CADDR LISP::LAMBDA-LIST-KEYWORDS LISP::MACRO LISP::STRING-NOT-EQUAL LISP::STRING-LESSP LISP::USE-PACKAGE LISP::MULTIPLE-VALUE-SETQ LISP::>= LISP::LOGEQV LISP::*EVAL-WHEN-COMPILE* LISP::HASH-TABLE-P LISP::GRAPHIC-CHAR-P LISP::EQL LISP::MAPHASH LISP::NINTERSECTION LISP::<= LISP::NAMESTRING LISP::MAKE-CONCATENATED-STREAM LISP::SHORT-FLOAT LISP::FILE-STREAM LISP::WRITE-LINE LISP::VECTOR-PUSH LISP::ENDP LISP::DIRECTORY LISP::TYPE LISP::ASSOC-IF LISP::DPB LISP::TYPEP LISP::FIFTH LISP::LOGNAND LISP::SIGNED-BYTE LISP::EVERY LISP::SUBLIS LISP::NULL LISP::FLOATP LISP::STRING< LISP::*TRACE-OUTPUT* LISP::WRITE-CHAR LISP::SGC LISP::STANDARD-GENERIC-FUNCTION LISP::MAPL LISP::PROG1 LISP::COMPLEXP LISP::PROCLAMATION LISP::INSPECT LISP::MACROEXPAND-1 LISP::BIT-ANDC1 LISP::SETQ LISP::CHAR>= LISP::REALPART LISP::LDIFF LISP::SINH LISP::BROADCAST-STREAM LISP::BASE-STRING LISP::MAKE-STRING LISP::CDDDAR LISP::INTEGER-LENGTH LISP::OUTPUT-STREAM-P LISP::NUNION LISP::/= LISP::PACKAGE-NAME LISP::ECASE LISP::PATHNAME LISP::APPLY LISP::CHAR-INT LISP::TAN LISP::MOST-NEGATIVE-FIXNUM LISP::MAKE-SYNONYM-STREAM LISP::MACROEXPAND LISP::CADDAR LISP::ISQRT LISP::CCASE LISP::GCD LISP::KEYWORD LISP::UNLESS LISP::MAP-INTO LISP::SYNONYM-STREAM LISP::SUBSETP LISP::POSITION-IF LISP::INCF LISP::SHIFTF LISP::BOOLE-XOR LISP::REM LISP::LOGNOR LISP::FIND LISP::MAX LISP::SIMPLE-VECTOR-P LISP::IMPORT LISP::MACHINE-VERSION LISP::SHADOWING-IMPORT LISP::BOOLE-EQV LISP::CONJUGATE LISP::READ-CHAR-NO-HANG LISP::WRITE-BYTE LISP::WITH-OUTPUT-TO-STRING LISP::BYTE-POSITION LISP::STANDARD-CHAR LISP::STRING LISP::MEMBER-IF LISP::CHAR-BITS-LIMIT LISP::NSTRING-UPCASE LISP::DEFMACRO LISP::BUTLAST LISP::CDDAAR LISP::IMAGPART LISP::LOGANDC2 LISP::HASH-TABLE-SIZE LISP::FFLOOR LISP::*PRINT-LEVEL* LISP::DEFSTRUCT LISP::DELETE-PACKAGE LISP::BOOLE-CLR LISP::DO-SYMBOLS LISP::INTEGERP LISP::NUMBER LISP::CADAAR LISP::NIL LISP::T LISP::DELETE LISP::DEFCFUN LISP::DEFINE-MODIFY-MACRO LISP::COMPILED-FUNCTION LISP::NOTEVERY LISP::BOOLE-2 LISP::STRUCTURE LISP::UNBOUND-SLOT LISP::RENAME-PACKAGE LISP::SIGNUM LISP::CDDDDR LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::FILE-POSITION LISP::LOGBITP LISP::LAMBDA-BLOCK LISP::STANDARD-METHOD LISP::UNSIGNED-CHAR LISP::PSETQ LISP::EVAL LISP::CERROR LISP::CHAR-GREATERP LISP::GET-SETF-METHOD LISP::SYMBOL-VALUE LISP::+++ LISP::LCM LISP::BOOLE-NAND LISP::SIMPLE-ARRAY LISP::CADDDR LISP::SIMPLE-BIT-VECTOR LISP::CHAR-META-BIT LISP::PRIN1 LISP::BIT-ORC1 LISP::PSETF LISP::RETURN LISP::MAKE-PATHNAME LISP::DOTIMES LISP::DEPOSIT-FIELD LISP::*QUERY-IO* LISP::&ENVIRONMENT LISP::ARRAY-DIMENSIONS LISP::BSD386 LISP::MAKE-BROADCAST-STREAM LISP::BOOLE-ANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::INPUT-STREAM-P LISP::DIGIT-CHAR-P LISP::*STANDARD-INPUT* LISP::BOUNDP LISP::ODDP LISP::READ-DELIMITED-LIST LISP::SIXTH LISP::SUBTYPEP LISP::NSTRING-CAPITALIZE LISP::DECLARE LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT LISP::TANH LISP::ATAN LISP::NOT LISP::STRING-CHAR-P LISP::LONG-SITE-NAME LISP::PATHNAME-VERSION LISP::MAPCAN LISP::REQUIRE LISP::RPLACA LISP::TAGBODY LISP::COPY-ALIST LISP::CADADR LISP::MAPCAR LISP::> LISP::FIND-PACKAGE LISP::FBOUNDP LISP::CLX-LITTLE-ENDIAN LISP::= LISP::DEFSETF LISP::ZEROP LISP::MC68020 LISP::UNUSE-PACKAGE LISP::MOST-POSITIVE-SHORT-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-LONG-FLOAT LISP::LOGICAL-PATHNAME LISP::APPLYHOOK LISP::< LISP::LOGCOUNT LISP::ENOUGH-NAMESTRING LISP::MULTIPLE-VALUE-LIST LISP::TWO-WAY-STREAM LISP::CDDR LISP::ASSOC LISP::REMF LISP::LDB LISP::MACROLET LISP::CDADR LISP::UNION LISP::FIND-ALL-SYMBOLS LISP::MAKE-PACKAGE LISP::&OPTIONAL LISP::THIRD LISP::LABELS LISP::BOOLE-C1 LISP::FIND-IF-NOT LISP::LOAD LISP::DELETE-IF-NOT LISP::ACONS LISP::UNDEFINED-FUNCTION LISP::SIGNED-CHAR LISP::INT LISP::PACKAGEP LISP::ENCODE-UNIVERSAL-TIME LISP::FORMAT LISP::TENTH LISP::STRUCTURE-CLASS LISP::MEMBER-IF-NOT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::KCL LISP::BOOLE-1 LISP::REDUCE LISP::SVREF LISP::NTH-VALUE LISP::FORCE-OUTPUT LISP::NSUBSTITUTE-IF-NOT LISP::CATCH LISP::STORAGE-CONDITION LISP::MERGE LISP::CASE LISP::CLEAR-INPUT LISP::REPLACE LISP::*** LISP::GENERIC-FUNCTION LISP::GCL LISP::/ LISP::BOOLE-SET LISP::SOFTWARE-VERSION LISP::APROPOS-LIST LISP::POSITION-IF-NOT LISP::READ-BYTE LISP::FLOAT-RADIX LISP::DECF LISP::PROG LISP::- LISP::MAPCON LISP::CADR LISP::EQUAL LISP::CAADR LISP::+ LISP::PATHNAME-DEVICE LISP::MACRO-FUNCTION LISP::MAPLIST LISP::REVERSE LISP::FIND-SYMBOL LISP::* LISP::LOCALLY LISP::BIT-ANDC2 LISP::COMMONP LISP::*FEATURES* LISP::DIVISION-BY-ZERO LISP::ARRAY LISP::DOUBLE LISP::DEFPARAMETER LISP::PATHNAME-DIRECTORY LISP::STRING-NOT-LESSP LISP::ELT LISP::NTH LISP::RETURN-FROM LISP::BIGNUM LISP::MAKE-SYMBOL LISP::FILL LISP::CHAR-CODE LISP::*PRINT-ESCAPE* LISP::*PRINT-BASE* LISP::*PRINT-CASE* LISP::FLOATING-POINT-INVALID-OPERATION LISP::NSUBST LISP::SIMPLE-VECTOR LISP::ARRAY-IN-BOUNDS-P LISP::READ-PRESERVING-WHITESPACE LISP::ATANH LISP::ATOM LISP::BIT-NAND LISP::VECTOR-POP LISP::MEMBER LISP::REMOVE LISP::CHAR<= LISP::PUSH LISP::PROGRAM-ERROR LISP::KYOTO LISP::CHAR-UPCASE LISP::*PRINT-PRETTY* LISP::MOST-POSITIVE-FIXNUM LISP::PATHNAME-HOST LISP::DOCUMENTATION LISP::// LISP::UNEXPORT LISP::PROBE-FILE LISP::STANDARD-CLASS LISP::GET-INTERNAL-REAL-TIME LISP::GET-INTERNAL-RUN-TIME LISP::NOTANY LISP::QUIT LISP::ROOM LISP::*APPLYHOOK* LISP::COS LISP::CHAR-DOWNCASE LISP::CONSTANTLY LISP::RATIONALIZE LISP::LISP-IMPLEMENTATION-VERSION LISP::CONSTANTP LISP::HASH-TABLE-COUNT LISP::STREAMP LISP::*BREAK-ENABLE* LISP::1- LISP::BIT-XOR LISP::STRING-STREAM LISP::GET-PROPERTIES LISP::COUNT-IF-NOT LISP::BIT LISP::ASH LISP::NSUBLIS LISP::FOURTH LISP::STRING<= LISP::STRING>= LISP::STRING/= LISP::SLEEP LISP::LAMBDA-BLOCK-CLOSURE LISP::HELP LISP::TREE-EQUAL LISP::SET LISP::INT-CHAR LISP::STRING-GREATERP LISP::SINGLE-FLOAT-EPSILON LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SPECIAL-FORM-P LISP::COMPLEMENT LISP::WRITE LISP::NCONC LISP::DECODE-UNIVERSAL-TIME LISP::BUILT-IN-CLASS LISP::*RANDOM-STATE* LISP::BOOLE-ORC1 LISP::BOOLE-ORC2 LISP::FILE-NAMESTRING LISP::VOID LISP::BIT-ORC2 LISP::1+ LISP::PROG2 LISP::*READ-SUPPRESS* LISP::DOLIST LISP::SIMPLE-BASE-STRING LISP::LET LISP::CHAR-NOT-GREATERP LISP::PATHNAMEP LISP::READ LISP::RANDOM-STATE-P LISP::CDDAR LISP::BY LISP::SFUN LISP::REMOVE-IF LISP::&ALLOW-OTHER-KEYS LISP::FROUND LISP::CHAR-EQUAL LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::EIGHTH LISP::OPTIMIZE LISP::++ LISP::DO* LISP::SIMPLE-TYPE-ERROR LISP::ASIN LISP::SINGLE-FLOAT LISP::CCLOSURE LISP::REAL LISP::CHARACTER LISP::CHARACTERP LISP::GET LISP::OBJECT LISP::REALP LISP::FCEILING LISP::COPY-SYMBOL LISP::CHAR LISP::STANDARD-CHAR-P LISP::*DEBUG-IO* LISP::FIXNUM LISP::COMPILED-FUNCTION-P LISP::COUNT-IF LISP::** LISP::METHOD LISP::WITH-OPEN-FILE LISP::PACKAGE LISP::TRUNCATE_USE_C LISP::IGNORE LISP::IDENTITY LISP::CTYPECASE LISP::ETYPECASE LISP::PROGV LISP::NSUBSTITUTE-IF LISP::BOOLE-NOR)) ;;; Definitions for package SERROR of type SHADOW (LISP::IN-PACKAGE "SERROR") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::EXP LISP::DEFVAR LISP::DISASSEMBLE LISP::DELETE-IF LISP::UNSIGNED-SHORT LISP::GFUN LISP::NSUBST-IF-NOT LISP::CIS LISP::LOGAND LISP::BIT-EQV LISP::UNIX LISP::RANDOM LISP::COPY-LIST LISP::KEYWORDP LISP::CADAR LISP::MERGE-PATHNAMES LISP::BOOLE-C2 LISP::BIT-NOT LISP::CFUN LISP::STANDARD-OBJECT LISP::STRINGP LISP::METHOD-COMBINATION LISP::NSET-EXCLUSIVE-OR LISP::CLOSE LISP::INTEGER-DECODE-FLOAT LISP::CHAR-NOT-EQUAL LISP::COSH LISP::NTHCDR LISP::GET-UNIVERSAL-TIME LISP::YES-OR-NO-P LISP::READ-LINE LISP::LET* LISP::PATHNAME-TYPE LISP::FLOAT-PRECISION LISP::PROG* LISP::SYMBOL-NAME LISP::LOG LISP::OR LISP::PACKAGE-SHADOWING-SYMBOLS LISP::BREAK LISP::STRUCTURE-OBJECT LISP::ROTATEF LISP::SQRT LISP::CONS LISP::NSUBST-IF LISP::UNWIND-PROTECT LISP::CONSP SLOOP::DEF-LOOP-MACRO LISP::FLOAT-SIGN LISP::*EVALHOOK* LISP::CHAR-BIT LISP::SOME LISP::MAPC LISP::SETF LISP::CEILING LISP::&BODY LISP::CDAR LISP::MAKE-LIST LISP::MAKE-HASH-TABLE LISP::STRING-UPCASE LISP::STRING-DOWNCASE LISP::STYLE-WARNING LISP::ASINH LISP::NRECONC LISP::NSTRING-DOWNCASE LISP::SECOND LISP::RATIONALP LISP::SET-DISPATCH-MACRO-CHARACTER LISP::GET-DISPATCH-MACRO-CHARACTER LISP::CHECK-TYPE LISP::MAKE-STRING-INPUT-STREAM LISP::MAKE-STRING-OUTPUT-STREAM LISP::*BREAK-ON-WARNINGS* LISP::BYE LISP::SAFETY LISP::*READ-DEFAULT-FLOAT-FORMAT* LISP::*LOAD-VERBOSE* LISP::OTHERWISE LISP::NBUTLAST LISP::SORT LISP::WARNING LISP::DEFLA LISP::PROGN LISP::PUSHNEW LISP::SYSTEM LISP::CHAR= LISP::SIGNED-SHORT LISP::MAKE-ECHO-STREAM LISP::BIT-AND LISP::EXPORT LISP::EQ LISP::SOFTWARE-TYPE LISP::LOGTEST LISP::LIST-ALL-PACKAGES LISP::DEFTYPE LISP::GETF LISP::ROW-MAJOR-AREF LISP::TYPECASE LISP::CHAR-CONTROL-BIT LISP::HASH-TABLE-TEST LISP::USER-HOMEDIR-PATHNAME LISP::SYMBOL-PACKAGE LISP::BOOLEAN LISP::HOST-NAMESTRING LISP::IN-PACKAGE LISP::CAAR LISP::INTERN LISP::CONDITION LISP::IEEE-FLOATING-POINT LISP::LOGNOT LISP::SUBST-IF-NOT LISP::COPY-READTABLE LISP::REVAPPEND LISP::SYMBOL LISP::BIT-VECTOR LISP::SEARCH LISP::STREAM-ELEMENT-TYPE LISP::POP LISP::GO LISP::LIST LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::PARSE-ERROR LISP::VALUES LISP::DESTRUCTURING-BIND LISP::RANDOM-STATE LISP::LISTP LISP::CHAR/= LISP::REMPROP LISP::DO LISP::HELP* LISP::ABS LISP::&KEY LISP::VECTOR-PUSH-EXTEND LISP::PACKAGE-NICKNAMES LISP::MULTIPLE-VALUE-PROG1 SLOOP::LOOP-RETURN LISP::END-OF-FILE LISP::*DEFAULT-PATHNAME-DEFAULTS* LISP::EXPT LISP::READER-ERROR LISP::REMHASH LISP::BLOCK LISP::PACKAGE-ERROR LISP::LAMBDA-CLOSURE LISP::PARSE-INTEGER LISP::TIME LISP::COERCE LISP::FIND-IF LISP::UNREAD-CHAR LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE LISP::SPECIFIC-ERROR LISP::FIRST LISP::ALPHANUMERICP LISP::WITH-HASH-TABLE-ITERATOR LISP::SCALE-FLOAT LISP::CONCATENATED-STREAM LISP::CONTROL-ERROR LISP::FINISH-OUTPUT LISP::LAMBDA-PARAMETERS-LIMIT LISP::PRINC LISP::ADJOIN LISP::PI LISP::DOUBLE-FLOAT LISP::READTABLE LISP::READTABLEP LISP::ARRAY-RANK-LIMIT LISP::RENAME-FILE LISP::READ-CHAR LISP::PEEK-CHAR LISP::REMOVE-DUPLICATES LISP::BYTE LISP::*MODULES* LISP::GET-OUTPUT-STREAM-STRING LISP::MULTIPLE-VALUE-BIND LISP::VECTORP LISP::RASSOC-IF-NOT LISP::UNINTERN SLOOP::LOOP-FINISH LISP::SPECIFIC-CORRECTABLE-ERROR LISP::CDADAR LISP::FUNCTION LISP::LOGORC2 LISP::*PACKAGE* LISP::STRING-NOT-GREATERP LISP::INTERSECTION LISP::SPACE LISP::SEVENTH LISP::BASE-CHAR LISP::MAKE-CHAR LISP::NAME-CHAR LISP::SBIT LISP::CAADAR LISP::TAILP LISP::*TERMINAL-IO* LISP::STREAM-ERROR LISP::BOOLE-ANDC1 LISP::DO-ALL-SYMBOLS LISP::MAKUNBOUND LISP::PROVIDE LISP::THROW LISP::LENGTH LISP::CDAAR LISP::&AUX LISP::ARRAY-DISPLACEMENT LISP::PAIRLIS LISP::*PRINT-GENSYM* LISP::COMPILE-FILE-PATHNAME LISP::CAR LISP::FTRUNCATE LISP::DELETE-DUPLICATES LISP::NREVERSE LISP::APROPOS LISP::STRING-RIGHT-TRIM LISP::STEP LISP::BIT-NOR LISP::ARRAY-TOTAL-SIZE LISP::ECHO-STREAM LISP::DEFINE-SETF-METHOD LISP::FMAKUNBOUND LISP::SUBST-IF LISP::GET-DECODED-TIME LISP::LONG-FLOAT LISP::SIMPLE-WARNING LISP::CHAR-HYPER-BIT LISP::TAG LISP::RATIO LISP::EVENP LISP::QUOTE LISP::SIMPLE-STRING LISP::NSUBSTITUTE LISP::LAST LISP::NSET-DIFFERENCE LISP::COUNT LISP::CDAAAR LISP::SET-DIFFERENCE SLOOP::DEF-LOOP-FOR LISP::PPRINT LISP::SHORT-FLOAT-EPSILON LISP::SHORT-FLOAT-NEGATIVE-EPSILON LISP::SET-CHAR-BIT LISP::ACOSH LISP::LISTEN LISP::GENTEMP LISP::ERROR LISP::BSD LISP::ADJUST-ARRAY LISP::CLINES LISP::IF LISP::CAAAAR LISP::SET-SYNTAX-FROM-CHAR LISP::STRING-TRIM LISP::DIGIT-CHAR LISP::BOOLE-AND LISP::STRING> LISP::CAAAR LISP::GETHASH LISP::FILL-POINTER SLOOP::DEF-LOOP-MAP LISP::CDADDR LISP::DIRECTORY-NAMESTRING LISP::DEFUN LISP::TRUNCATE LISP::DEFENTRY LISP::ALPHA-CHAR-P LISP::SYMBOL-FUNCTION LISP::SUBSTITUTE-IF-NOT LISP::LDB-TEST LISP::FLOAT-DIGITS LISP::BIT-VECTOR-P LISP::CAADDR LISP::VARIABLE LISP::NUMERATOR LISP::NOTINLINE LISP::CHAR-LESSP LISP::WARN LISP::CHAR-NOT-LESSP LISP::ARRAY-DIMENSION-LIMIT LISP::MOD LISP::SXHASH LISP::PACKAGE-USE-LIST LISP::PACKAGE-USED-BY-LIST LISP::MACHINE-INSTANCE LISP::ARRAYP LISP::*GENSYM-COUNTER* LISP::UPPER-CASE-P LISP::*PRINT-CIRCLE* LISP::FTYPE LISP::THE SLOOP::LOCAL-FINISH LISP::COMPILER-LET LISP::WRITE-TO-STRING LISP::ARRAY-TOTAL-SIZE-LIMIT LISP::SEQUENCE LISP::FILE-AUTHOR LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH LISP::SIMPLE-STRING-P LISP::PRINT LISP::MULTIPLE-VALUES-LIMIT LISP::PRIN1-TO-STRING LISP::PRINC-TO-STRING LISP::SIMPLE-CONDITION LISP::TERPRI LISP::CDAADR LISP::FLOATING-POINT-OVERFLOW LISP::FLOATING-POINT-UNDERFLOW LISP::CALL-ARGUMENTS-LIMIT LISP::COPY-SEQ LISP::FUNCALL LISP::CLRHASH LISP::SHORT-SITE-NAME LISP::LONG-FLOAT-EPSILON LISP::LONG-FLOAT-NEGATIVE-EPSILON LISP::ASSOC-IF-NOT LISP::CAAADR LISP::STRING-CHAR LISP::LOGANDC1 LISP::WITH-PACKAGE-ITERATOR LISP::NUMBERP LISP::COMPLEX LISP::AND LISP::EVAL-WHEN LISP::LOOP LISP::READ-FROM-STRING LISP::*STANDARD-OUTPUT* LISP::CHAR-NAME LISP::COMPILE-FILE LISP::FLOAT LISP::*ERROR-OUTPUT* LISP::TYPE-ERROR LISP::COMPILATION-SPEED LISP::LOGXOR LISP::LIST-LENGTH LISP::DRIBBLE LISP::EXTENDED-CHAR LISP::MAP LISP::ARRAY-ELEMENT-TYPE LISP::ROUND LISP::STRING-LEFT-TRIM LISP::DECLAIM LISP::SAVE LISP::SIN LISP::*PRINT-LENGTH* LISP::DECLARATION LISP::DECODE-FLOAT LISP::PATHNAME-NAME LISP::STRING= LISP::PHASE LISP::SPICE LISP::RASSOC LISP::LISP-IMPLEMENTATION-TYPE LISP::UNTRACE LISP::PRINT-NOT-READABLE LISP::ARRAY-ROW-MAJOR-INDEX LISP::SUBSTITUTE-IF LISP::BOOLE LISP::TRUENAME LISP::DEFCONSTANT LISP::VALUES-LIST LISP::*LINK-ARRAY* LISP::&REST LISP::MAKE-RANDOM-STATE LISP::CHAR> LISP::BYTE-SIZE LISP::MIN LISP::CDDDR LISP::BIT-IOR LISP::VECTOR LISP::UNSIGNED-BYTE LISP::SERIOUS-CONDITION LISP::SYMBOL-PLIST LISP::*READTABLE* LISP::SIMPLE-BIT-VECTOR-P LISP::LEAST-POSITIVE-SHORT-FLOAT LISP::LEAST-POSITIVE-SINGLE-FLOAT LISP::LEAST-POSITIVE-DOUBLE-FLOAT LISP::LEAST-POSITIVE-LONG-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-POSITIVE-NORMALIZED-LONG-FLOAT LISP::LOWER-CASE-P SYSTEM::ALLOCATE LISP::EQUALP LISP::SUBSTITUTE LISP::SUBSEQ LISP::MINUSP LISP::MOST-NEGATIVE-SHORT-FLOAT LISP::MOST-NEGATIVE-SINGLE-FLOAT LISP::MOST-NEGATIVE-DOUBLE-FLOAT LISP::MOST-NEGATIVE-LONG-FLOAT LISP::FILE-LENGTH LISP::FILE-ERROR LISP::HASH-TABLE LISP::SPEED LISP::COMMON LISP::*PRINT-RADIX* LISP::POSITIVE-FIXNUM LISP::UNBOUND-VARIABLE LISP::RATIONAL LISP::UPGRADED-ARRAY-ELEMENT-TYPE LISP::FRESH-LINE LISP::WHEN LISP::COMPILE LISP::FLET LISP::SPECIAL LISP::CLASS LISP::CELL-ERROR LISP::RPLACD LISP::TYPE-OF LISP::SPECIAL-OPERATOR-P LISP::DESCRIBE LISP::POSITION LISP::STABLE-SORT LISP::BOTH-CASE-P LISP::SYMBOLP LISP::*PRINT-READABLY* LISP::SHADOW LISP::STREAM LISP::CHAR-BITS LISP::MAKE-ARRAY LISP::FUNCTIONP LISP::&WHOLE LISP::SUBST LISP::SCHAR LISP::ARRAY-DIMENSION LISP::COND LISP::DO-EXTERNAL-SYMBOLS LISP::CHAR-CODE-LIMIT LISP::CHAR-FONT-LIMIT LISP::SATISFIES LISP::MASK-FIELD LISP::ARITHMETIC-ERROR LISP::CADDR LISP::LAMBDA-LIST-KEYWORDS LISP::MACRO LISP::STRING-NOT-EQUAL LISP::STRING-LESSP LISP::USE-PACKAGE LISP::MULTIPLE-VALUE-SETQ LISP::>= LISP::LOGEQV LISP::*EVAL-WHEN-COMPILE* LISP::HASH-TABLE-P LISP::GRAPHIC-CHAR-P LISP::EQL LISP::MAPHASH LISP::NINTERSECTION LISP::<= LISP::NAMESTRING LISP::MAKE-CONCATENATED-STREAM LISP::SHORT-FLOAT LISP::FILE-STREAM LISP::WRITE-LINE LISP::VECTOR-PUSH LISP::ENDP LISP::DIRECTORY LISP::TYPE LISP::ASSOC-IF LISP::DPB LISP::TYPEP LISP::FIFTH LISP::LOGNAND LISP::SIGNED-BYTE LISP::EVERY LISP::SUBLIS LISP::NULL LISP::FLOATP LISP::STRING< LISP::*TRACE-OUTPUT* LISP::WRITE-CHAR LISP::SGC LISP::STANDARD-GENERIC-FUNCTION LISP::MAPL LISP::PROG1 LISP::COMPLEXP LISP::PROCLAMATION LISP::INSPECT LISP::MACROEXPAND-1 LISP::BIT-ANDC1 LISP::SETQ LISP::CHAR>= LISP::REALPART LISP::LDIFF LISP::SINH LISP::BROADCAST-STREAM LISP::BASE-STRING LISP::MAKE-STRING LISP::CDDDAR LISP::INTEGER-LENGTH LISP::OUTPUT-STREAM-P LISP::NUNION LISP::/= LISP::PACKAGE-NAME LISP::ECASE LISP::PATHNAME LISP::APPLY LISP::CHAR-INT LISP::TAN LISP::MOST-NEGATIVE-FIXNUM LISP::MAKE-SYNONYM-STREAM LISP::MACROEXPAND LISP::CADDAR LISP::ISQRT LISP::CCASE LISP::GCD LISP::KEYWORD LISP::UNLESS LISP::MAP-INTO LISP::SYNONYM-STREAM LISP::SUBSETP LISP::POSITION-IF LISP::INCF LISP::SHIFTF LISP::BOOLE-XOR LISP::REM LISP::LOGNOR LISP::FIND LISP::MAX LISP::SIMPLE-VECTOR-P LISP::IMPORT LISP::MACHINE-VERSION LISP::SHADOWING-IMPORT LISP::BOOLE-EQV LISP::CONJUGATE LISP::READ-CHAR-NO-HANG LISP::WRITE-BYTE LISP::WITH-OUTPUT-TO-STRING LISP::BYTE-POSITION LISP::STANDARD-CHAR LISP::STRING LISP::MEMBER-IF LISP::CHAR-BITS-LIMIT LISP::NSTRING-UPCASE LISP::DEFMACRO LISP::BUTLAST LISP::CDDAAR LISP::IMAGPART LISP::LOGANDC2 LISP::HASH-TABLE-SIZE LISP::FFLOOR LISP::*PRINT-LEVEL* LISP::DEFSTRUCT LISP::DELETE-PACKAGE LISP::BOOLE-CLR LISP::DO-SYMBOLS LISP::INTEGERP LISP::NUMBER LISP::CADAAR LISP::NIL LISP::T LISP::DELETE LISP::DEFCFUN LISP::DEFINE-MODIFY-MACRO LISP::COMPILED-FUNCTION LISP::NOTEVERY LISP::BOOLE-2 LISP::STRUCTURE LISP::UNBOUND-SLOT LISP::RENAME-PACKAGE LISP::SIGNUM LISP::CDDDDR LISP::GET-SETF-METHOD-MULTIPLE-VALUE LISP::FILE-POSITION LISP::LOGBITP LISP::LAMBDA-BLOCK LISP::STANDARD-METHOD LISP::UNSIGNED-CHAR LISP::PSETQ LISP::EVAL LISP::CERROR LISP::CHAR-GREATERP LISP::GET-SETF-METHOD LISP::SYMBOL-VALUE LISP::+++ LISP::LCM LISP::BOOLE-NAND LISP::SIMPLE-ARRAY LISP::CADDDR LISP::SIMPLE-BIT-VECTOR LISP::CHAR-META-BIT LISP::PRIN1 LISP::BIT-ORC1 LISP::PSETF LISP::RETURN LISP::MAKE-PATHNAME LISP::DOTIMES LISP::DEPOSIT-FIELD LISP::*QUERY-IO* LISP::&ENVIRONMENT LISP::ARRAY-DIMENSIONS LISP::BSD386 LISP::MAKE-BROADCAST-STREAM LISP::BOOLE-ANDC2 LISP::MAKE-TWO-WAY-STREAM LISP::INPUT-STREAM-P LISP::DIGIT-CHAR-P LISP::*STANDARD-INPUT* LISP::BOUNDP LISP::ODDP LISP::READ-DELIMITED-LIST LISP::SIXTH LISP::SUBTYPEP LISP::NSTRING-CAPITALIZE LISP::DECLARE LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT LISP::TANH LISP::ATAN LISP::NOT LISP::STRING-CHAR-P LISP::LONG-SITE-NAME LISP::PATHNAME-VERSION LISP::MAPCAN LISP::REQUIRE LISP::RPLACA LISP::TAGBODY LISP::COPY-ALIST LISP::CADADR LISP::MAPCAR LISP::> LISP::FIND-PACKAGE LISP::FBOUNDP LISP::CLX-LITTLE-ENDIAN LISP::= LISP::DEFSETF LISP::ZEROP LISP::MC68020 LISP::UNUSE-PACKAGE LISP::MOST-POSITIVE-SHORT-FLOAT LISP::MOST-POSITIVE-SINGLE-FLOAT LISP::MOST-POSITIVE-DOUBLE-FLOAT LISP::MOST-POSITIVE-LONG-FLOAT LISP::LOGICAL-PATHNAME LISP::APPLYHOOK LISP::< LISP::LOGCOUNT LISP::ENOUGH-NAMESTRING LISP::MULTIPLE-VALUE-LIST LISP::TWO-WAY-STREAM LISP::CDDR LISP::ASSOC LISP::REMF LISP::LDB LISP::MACROLET LISP::CDADR LISP::UNION LISP::FIND-ALL-SYMBOLS LISP::MAKE-PACKAGE LISP::&OPTIONAL LISP::THIRD LISP::LABELS LISP::BOOLE-C1 LISP::FIND-IF-NOT LISP::LOAD LISP::DELETE-IF-NOT LISP::ACONS LISP::UNDEFINED-FUNCTION LISP::SIGNED-CHAR LISP::INT LISP::PACKAGEP LISP::ENCODE-UNIVERSAL-TIME LISP::FORMAT LISP::TENTH LISP::STRUCTURE-CLASS LISP::MEMBER-IF-NOT LISP::LEAST-NEGATIVE-SHORT-FLOAT LISP::LEAST-NEGATIVE-SINGLE-FLOAT LISP::LEAST-NEGATIVE-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-LONG-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT LISP::LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT LISP::KCL LISP::BOOLE-1 LISP::REDUCE LISP::SVREF LISP::NTH-VALUE LISP::FORCE-OUTPUT LISP::NSUBSTITUTE-IF-NOT LISP::CATCH LISP::STORAGE-CONDITION LISP::MERGE LISP::CASE LISP::CLEAR-INPUT LISP::REPLACE LISP::*** LISP::GENERIC-FUNCTION LISP::GCL LISP::/ LISP::BOOLE-SET LISP::SOFTWARE-VERSION LISP::APROPOS-LIST LISP::POSITION-IF-NOT LISP::READ-BYTE LISP::FLOAT-RADIX LISP::DECF LISP::PROG LISP::- LISP::MAPCON LISP::CADR LISP::EQUAL LISP::CAADR LISP::+ LISP::PATHNAME-DEVICE LISP::MACRO-FUNCTION LISP::MAPLIST LISP::REVERSE LISP::FIND-SYMBOL LISP::* LISP::LOCALLY LISP::BIT-ANDC2 LISP::COMMONP LISP::*FEATURES* LISP::DIVISION-BY-ZERO LISP::ARRAY LISP::DOUBLE LISP::DEFPARAMETER LISP::PATHNAME-DIRECTORY LISP::STRING-NOT-LESSP LISP::ELT LISP::NTH LISP::RETURN-FROM LISP::BIGNUM LISP::MAKE-SYMBOL LISP::FILL LISP::CHAR-CODE LISP::*PRINT-ESCAPE* LISP::*PRINT-BASE* LISP::*PRINT-CASE* LISP::FLOATING-POINT-INVALID-OPERATION LISP::NSUBST LISP::SIMPLE-VECTOR LISP::ARRAY-IN-BOUNDS-P LISP::READ-PRESERVING-WHITESPACE LISP::ATANH LISP::ATOM LISP::BIT-NAND LISP::VECTOR-POP LISP::MEMBER LISP::REMOVE LISP::CHAR<= LISP::PUSH LISP::PROGRAM-ERROR LISP::KYOTO LISP::CHAR-UPCASE LISP::*PRINT-PRETTY* LISP::MOST-POSITIVE-FIXNUM LISP::PATHNAME-HOST LISP::DOCUMENTATION LISP::// LISP::UNEXPORT LISP::PROBE-FILE LISP::STANDARD-CLASS LISP::GET-INTERNAL-REAL-TIME LISP::GET-INTERNAL-RUN-TIME LISP::NOTANY LISP::QUIT LISP::ROOM LISP::*APPLYHOOK* LISP::COS LISP::CHAR-DOWNCASE LISP::CONSTANTLY LISP::RATIONALIZE LISP::LISP-IMPLEMENTATION-VERSION LISP::CONSTANTP LISP::HASH-TABLE-COUNT LISP::STREAMP LISP::*BREAK-ENABLE* LISP::1- LISP::BIT-XOR LISP::STRING-STREAM LISP::GET-PROPERTIES LISP::COUNT-IF-NOT LISP::BIT LISP::ASH LISP::NSUBLIS LISP::FOURTH LISP::STRING<= LISP::STRING>= LISP::STRING/= LISP::SLEEP LISP::LAMBDA-BLOCK-CLOSURE LISP::HELP LISP::TREE-EQUAL LISP::SET LISP::INT-CHAR LISP::STRING-GREATERP LISP::SINGLE-FLOAT-EPSILON LISP::SINGLE-FLOAT-NEGATIVE-EPSILON LISP::SPECIAL-FORM-P LISP::COMPLEMENT LISP::WRITE LISP::NCONC LISP::DECODE-UNIVERSAL-TIME LISP::BUILT-IN-CLASS LISP::*RANDOM-STATE* LISP::BOOLE-ORC1 LISP::BOOLE-ORC2 LISP::FILE-NAMESTRING LISP::VOID LISP::BIT-ORC2 LISP::1+ LISP::PROG2 SLOOP::SLOOP LISP::*READ-SUPPRESS* LISP::DOLIST LISP::SIMPLE-BASE-STRING LISP::LET LISP::CHAR-NOT-GREATERP LISP::PATHNAMEP LISP::READ LISP::RANDOM-STATE-P LISP::CDDAR LISP::BY LISP::SFUN LISP::REMOVE-IF LISP::&ALLOW-OTHER-KEYS LISP::FROUND LISP::CHAR-EQUAL LISP::MAKE-DISPATCH-MACRO-CHARACTER LISP::EIGHTH LISP::OPTIMIZE LISP::++ LISP::DO* LISP::SIMPLE-TYPE-ERROR LISP::ASIN LISP::SINGLE-FLOAT LISP::CCLOSURE LISP::REAL LISP::CHARACTER LISP::CHARACTERP LISP::GET LISP::OBJECT LISP::REALP LISP::FCEILING LISP::COPY-SYMBOL LISP::CHAR LISP::STANDARD-CHAR-P LISP::*DEBUG-IO* LISP::FIXNUM LISP::COMPILED-FUNCTION-P LISP::COUNT-IF LISP::** LISP::METHOD LISP::WITH-OPEN-FILE LISP::PACKAGE LISP::TRUNCATE_USE_C LISP::IGNORE LISP::IDENTITY LISP::CTYPECASE LISP::ETYPECASE LISP::PROGV LISP::NSUBSTITUTE-IF LISP::BOOLE-NOR SLOOP::DEF-LOOP-COLLECT)) ;;; Definitions for package COMMON-LISP of type SHADOW (LISP::IN-PACKAGE "COMMON-LISP") (LISP::SHADOW 'LISP::NIL) (LISP::SHADOWING-IMPORT 'LISP::NIL) (LISP::IMPORT '(LISP::NIL LISP::T)) (lisp::in-package "SI") (export '(%structure-name %compiled-function-name %set-compiled-function-name)) (in-package "PCL") gcl/pcl/gcl_pcl_methods.lisp0000644000175000017500000016540312240167764015056 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (defmethod print-object (instance stream) (printing-random-thing (instance stream) (let ((name (class-name (class-of instance)))) (if name (format stream "~S" name) (format stream "Instance"))))) (defmethod print-object ((class class) stream) (named-object-print-function class stream)) (defmethod print-object ((slotd slot-definition) stream) (named-object-print-function slotd stream)) (defun named-object-print-function (instance stream &optional (extra nil extra-p)) (printing-random-thing (instance stream) (if extra-p (format stream "~A ~S ~:S" (capitalize-words (class-name (class-of instance))) (slot-value-or-default instance 'name) extra) (format stream "~A ~S" (capitalize-words (class-name (class-of instance))) (slot-value-or-default instance 'name))))) (defmethod print-object ((mc standard-method-combination) stream) (printing-random-thing (mc stream) (format stream "Method-Combination ~S ~S" (slot-value-or-default mc 'type) (slot-value-or-default mc 'options)))) ;;; ;;; ;;; (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) (declare (ignore slot-names)) (with-slots (allocation class) slotd (setq allocation (if (eq allocation :class) class allocation)))) (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key (allocation :instance)) (declare (ignore slot-names)) (unless (eq allocation :instance) (error "structure slots must have :instance allocation"))) (defmethod inform-type-system-about-class ((class structure-class) (name t)) nil) ;;; ;;; METHODS ;;; ;;; Methods themselves are simple inanimate objects. Most properties of ;;; methods are immutable, methods cannot be reinitialized. The following ;;; properties of methods can be changed: ;;; METHOD-GENERIC-FUNCTION ;;; METHOD-FUNCTION ?? ;;; ;;; (defmethod method-function ((method standard-method)) (or (slot-value method 'function) (let ((fmf (slot-value method 'fast-function))) (unless fmf ; the :before shared-initialize method prevents this (error "~S doesn't seem to have a method-function" method)) (setf (slot-value method 'function) (method-function-from-fast-function fmf))))) (defmethod accessor-method-class ((method standard-accessor-method)) (car (slot-value method 'specializers))) (defmethod accessor-method-class ((method standard-writer-method)) (cadr (slot-value method 'specializers))) (defmethod print-object ((method standard-method) stream) (printing-random-thing (method stream) (if (slot-boundp method 'generic-function) (let ((generic-function (method-generic-function method)) (class-name (capitalize-words (class-name (class-of method))))) (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function (generic-function-name generic-function)) (method-qualifiers method) (unparse-specializers method))) (call-next-method)))) (defmethod print-object ((method standard-accessor-method) stream) (printing-random-thing (method stream) (if (slot-boundp method 'generic-function) (let ((generic-function (method-generic-function method)) (class-name (capitalize-words (class-name (class-of method))))) (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function (generic-function-name generic-function)) (accessor-method-slot-name method) (unparse-specializers method))) (call-next-method)))) ;;; ;;; INITIALIZATION ;;; ;;; Error checking is done in before methods. Because of the simplicity of ;;; standard method objects the standard primary method can fill the slots. ;;; ;;; Methods are not reinitializable. ;;; (defmethod reinitialize-instance ((method standard-method) &rest initargs) (declare (ignore initargs)) (error "Attempt to reinitialize the method ~S.~%~ Method objects cannot be reinitialized." method)) (defmethod legal-documentation-p ((object standard-method) x) (if (or (null x) (stringp x)) t "a string or NULL")) (defmethod legal-lambda-list-p ((object standard-method) x) (declare (ignore x)) t) (defmethod legal-method-function-p ((object standard-method) x) (if (functionp x) t "a function")) (defmethod legal-qualifiers-p ((object standard-method) x) (flet ((improper-list () (return-from legal-qualifiers-p "Is not a proper list."))) (dolist-carefully (q x improper-list) (let ((ok (legal-qualifier-p object q))) (unless (eq ok t) (return-from legal-qualifiers-p (format nil "Contains ~S which ~A" q ok))))) t)) (defmethod legal-qualifier-p ((object standard-method) x) (if (and x (atom x)) t "is not a non-null atom")) (defmethod legal-slot-name-p ((object standard-method) x) (cond ((not (symbolp x)) "is not a symbol and so cannot be bound") ((keywordp x) "is a keyword and so cannot be bound") ((memq x '(t nil)) "cannot be bound") ((constantp x) "is a constant and so cannot be bound") (t t))) (defmethod legal-specializers-p ((object standard-method) x) (flet ((improper-list () (return-from legal-specializers-p "Is not a proper list."))) (dolist-carefully (s x improper-list) (let ((ok (legal-specializer-p object s))) (unless (eq ok t) (return-from legal-specializers-p (format nil "Contains ~S which ~A" s ok))))) t)) (defvar *allow-experimental-specializers-p* nil) (defmethod legal-specializer-p ((object standard-method) x) (if (if *allow-experimental-specializers-p* (specializerp x) (or (classp x) (eql-specializer-p x))) t "is neither a class object nor an eql specializer")) (defmethod shared-initialize :before ((method standard-method) slot-names &key qualifiers lambda-list specializers function fast-function documentation) (declare (ignore slot-names)) (flet ((lose (initarg value string) (error "When initializing the method ~S:~%~ The ~S initialization argument was: ~S.~%~ which ~A." method initarg value string))) (let ((check-qualifiers (legal-qualifiers-p method qualifiers)) (check-lambda-list (legal-lambda-list-p method lambda-list)) (check-specializers (legal-specializers-p method specializers)) (check-function (legal-method-function-p method (or function fast-function))) (check-documentation (legal-documentation-p method documentation))) (unless (eq check-qualifiers t) (lose :qualifiers qualifiers check-qualifiers)) (unless (eq check-lambda-list t) (lose :lambda-list lambda-list check-lambda-list)) (unless (eq check-specializers t) (lose :specializers specializers check-specializers)) (unless (eq check-function t) (lose :function function check-function)) (unless (eq check-documentation t) (lose :documentation documentation check-documentation))))) (defmethod shared-initialize :before ((method standard-accessor-method) slot-names &key slot-name slot-definition) (declare (ignore slot-names)) (unless slot-definition (let ((legalp (legal-slot-name-p method slot-name))) (unless (eq legalp t) (error "The value of the :SLOT-NAME initarg ~A." legalp))))) (defmethod shared-initialize :after ((method standard-method) slot-names &rest initargs &key qualifiers method-spec plist) (declare (ignore slot-names method-spec plist)) (initialize-method-function initargs nil method) (setf (plist-value method 'qualifiers) qualifiers) #+ignore (setf (slot-value method 'closure-generator) (method-function-closure-generator (slot-value method 'function)))) (defmethod shared-initialize :after ((method standard-accessor-method) slot-names &key) (declare (ignore slot-names)) (with-slots (slot-name slot-definition) method (unless slot-definition (let ((class (accessor-method-class method))) (when (slot-class-p class) (setq slot-definition (find slot-name (class-direct-slots class) :key #'slot-definition-name))))) (when (and slot-definition (null slot-name)) (setq slot-name (slot-definition-name slot-definition))))) (defmethod method-qualifiers ((method standard-method)) (plist-value method 'qualifiers)) (defvar *the-class-generic-function* (find-class 'generic-function)) (defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) (defmethod print-object ((generic-function generic-function) stream) (named-object-print-function generic-function stream (if (slot-boundp generic-function 'methods) (list (length (generic-function-methods generic-function))) "?"))) (defmethod shared-initialize :before ((generic-function standard-generic-function) slot-names &key (name nil namep) (lambda-list () lambda-list-p) argument-precedence-order declarations documentation (method-class nil method-class-supplied-p) (method-combination nil method-combination-supplied-p)) (declare (ignore slot-names declarations argument-precedence-order documentation lambda-list lambda-list-p)) (when namep (set-function-name generic-function name)) (flet ((initarg-error (initarg value string) (error "When initializing the generic-function ~S:~%~ The ~S initialization argument was: ~A.~%~ It must be ~A." generic-function initarg value string))) (cond (method-class-supplied-p (when (symbolp method-class) (setq method-class (find-class method-class))) (unless (and (classp method-class) (*subtypep (class-eq-specializer method-class) *the-class-method*)) (initarg-error :method-class method-class "a subclass of the class METHOD")) (setf (slot-value generic-function 'method-class) method-class)) ((slot-boundp generic-function 'method-class)) (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD"))) (cond (method-combination-supplied-p (unless (method-combination-p method-combination) (initarg-error :method-combination method-combination "a method combination object"))) ((slot-boundp generic-function 'method-combination)) (t (initarg-error :method-combination "not supplied" "a method combination object"))))) #|| (defmethod reinitialize-instance ((generic-function standard-generic-function) &rest initargs &key name lambda-list argument-precedence-order declarations documentation method-class method-combination) (declare (ignore documentation declarations argument-precedence-order lambda-list name method-class method-combination)) (macrolet ((add-initarg (check name slot-name) `(unless ,check (push (slot-value generic-function ,slot-name) initargs) (push ,name initargs)))) ; (add-initarg name :name 'name) ; (add-initarg lambda-list :lambda-list 'lambda-list) ; (add-initarg argument-precedence-order ; :argument-precedence-order ; 'argument-precedence-order) ; (add-initarg declarations :declarations 'declarations) ; (add-initarg documentation :documentation 'documentation) ; (add-initarg method-class :method-class 'method-class) ; (add-initarg method-combination :method-combination 'method-combination) (apply #'call-next-method generic-function initargs))) ||# ;;; ;;; These three are scheduled for demolition. ;;; (defmethod remove-named-method (generic-function-name argument-specifiers &optional extra) (let ((generic-function ()) (method ())) (cond ((or (null (fboundp generic-function-name)) (not (generic-function-p (setq generic-function (symbol-function generic-function-name))))) (error "~S does not name a generic-function." generic-function-name)) ((null (setq method (get-method generic-function extra (parse-specializers argument-specifiers) nil))) (error "There is no method for the generic-function ~S~%~ which matches the argument-specifiers ~S." generic-function argument-specifiers)) (t (remove-method generic-function method))))) (defun real-add-named-method (generic-function-name qualifiers specializers lambda-list &rest other-initargs) #+copy-&rest-arg (setq other-initargs (copy-list other-initargs)) ;; What about changing the class of the generic-function if there is ;; one. Whose job is that anyways. Do we need something kind of ;; like class-for-redefinition? (let* ((generic-function (ensure-generic-function generic-function-name)) (specs (parse-specializers specializers)) ; (existing (get-method generic-function qualifiers specs nil)) (proto (method-prototype-for-gf generic-function-name)) (new (apply #'make-instance (class-of proto) :qualifiers qualifiers :specializers specs :lambda-list lambda-list other-initargs))) ; (when existing (remove-method generic-function existing)) (add-method generic-function new))) (defun make-specializable (function-name &key (arglist nil arglistp)) (cond ((not (null arglistp))) ((not (fboundp function-name))) ((fboundp 'function-arglist) ;; function-arglist exists, get the arglist from it. (setq arglist (function-arglist function-name))) (t (error "The :arglist argument to make-specializable was not supplied~%~ and there is no version of FUNCTION-ARGLIST defined for this~%~ port of Portable CommonLoops.~%~ You must either define a version of FUNCTION-ARGLIST (which~%~ should be easy), and send it off to the Portable CommonLoops~%~ people or you should call make-specializable again with the~%~ :arglist keyword to specify the arglist."))) (let ((original (and (fboundp function-name) (symbol-function function-name))) (generic-function (make-instance 'standard-generic-function :name function-name)) (nrequireds 0)) (if (generic-function-p original) original (progn (dolist (arg arglist) (if (memq arg lambda-list-keywords) (return) (incf nrequireds))) (setf (gdefinition function-name) generic-function) (set-function-name generic-function function-name) (when arglistp (setf (gf-pretty-arglist generic-function) arglist)) (when original (add-named-method function-name () (make-list nrequireds :initial-element 't) arglist (list :function #'(lambda (args next-methods) (declare (ignore next-methods)) (apply original args))))) generic-function)))) (defun real-get-method (generic-function qualifiers specializers &optional (errorp t)) (let ((hit (dolist (method (generic-function-methods generic-function)) (when (and (equal qualifiers (method-qualifiers method)) (every #'same-specializer-p specializers (method-specializers method))) (return method))))) (cond (hit hit) ((null errorp) nil) (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." generic-function qualifiers specializers))))) ;;; ;;; Compute various information about a generic-function's arglist by looking ;;; at the argument lists of the methods. The hair for trying not to use ;;; &rest arguments lives here. ;;; The values returned are: ;;; number-of-required-arguments ;;; the number of required arguments to this generic-function's ;;; discriminating function ;;; &rest-argument-p ;;; whether or not this generic-function's discriminating ;;; function takes an &rest argument. ;;; specialized-argument-positions ;;; a list of the positions of the arguments this generic-function ;;; specializes (e.g. for a classical generic-function this is the ;;; list: (1)). ;;; (defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function)) ;;(declare (values number-of-required-arguments &rest-argument-p ;; specialized-argument-postions)) (let ((number-required nil) (restp nil) (specialized-positions ()) (methods (generic-function-methods generic-function))) (dolist (method methods) (multiple-value-setq (number-required restp specialized-positions) (compute-discriminating-function-arglist-info-internal generic-function method number-required restp specialized-positions))) (values number-required restp (sort specialized-positions #'<)))) (defun compute-discriminating-function-arglist-info-internal (generic-function method number-of-requireds restp specialized-argument-positions) (declare (ignore generic-function) (type (or null fixnum) number-of-requireds)) (let ((requireds 0)) (declare (fixnum requireds)) ;; Go through this methods arguments seeing how many are required, ;; and whether there is an &rest argument. (dolist (arg (method-lambda-list method)) (cond ((eq arg '&aux) (return)) ((memq arg '(&optional &rest &key)) (return (setq restp t))) ((memq arg lambda-list-keywords)) (t (incf requireds)))) ;; Now go through this method's type specifiers to see which ;; argument positions are type specified. Treat T specially ;; in the usual sort of way. For efficiency don't bother to ;; keep specialized-argument-positions sorted, rather depend ;; on our caller to do that. (iterate ((type-spec (list-elements (method-specializers method))) (pos (interval :from 0))) (unless (eq type-spec *the-class-t*) (pushnew pos specialized-argument-positions))) ;; Finally merge the values for this method into the values ;; for the exisiting methods and return them. Note that if ;; num-of-requireds is NIL it means this is the first method ;; and we depend on that. (values (min (or number-of-requireds requireds) requireds) (or restp (and number-of-requireds (/= number-of-requireds requireds))) specialized-argument-positions))) (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (gathering ((args (collecting))) (iterate ((i (interval :from 0 :below number-required-arguments))) (gather (intern (format nil "Discriminating Function Arg ~D" i)) args))) (when restp `(&rest ,(intern "Discriminating Function &rest Arg"))))) ;;; ;;; ;;; (defmethod generic-function-lambda-list ((gf generic-function)) (gf-lambda-list gf)) (defmethod gf-fast-method-function-p ((gf standard-generic-function)) (gf-info-fast-mf-p (slot-value gf 'arg-info))) (defmethod initialize-instance :after ((gf standard-generic-function) &key (lambda-list nil lambda-list-p) argument-precedence-order) (with-slots (arg-info) gf (if lambda-list-p (set-arg-info gf :lambda-list lambda-list :argument-precedence-order argument-precedence-order) (set-arg-info gf)) (when (arg-info-valid-p arg-info) (update-dfun gf)))) (defmethod reinitialize-instance :after ((gf standard-generic-function) &rest args &key (lambda-list nil lambda-list-p) (argument-precedence-order nil argument-precedence-order-p)) (with-slots (arg-info) gf (if lambda-list-p (if argument-precedence-order-p (set-arg-info gf :lambda-list lambda-list :argument-precedence-order argument-precedence-order) (set-arg-info gf :lambda-list lambda-list)) (set-arg-info gf)) (when (and (arg-info-valid-p arg-info) args (or lambda-list-p (cddr args))) (update-dfun gf)))) ;;; ;;; ;;; (proclaim '(special *lazy-dfun-compute-p*)) (defun set-methods (gf methods) (setf (generic-function-methods gf) nil) (loop (when (null methods) (return gf)) (real-add-method gf (pop methods) methods))) (defun real-add-method (generic-function method &optional skip-dfun-update-p) (if (method-generic-function method) (error "The method ~S is already part of the generic~@ function ~S. It can't be added to another generic~@ function until it is removed from the first one." method (method-generic-function method)) (let* ((name (generic-function-name generic-function)) (qualifiers (method-qualifiers method)) (specializers (method-specializers method)) (existing (get-method generic-function qualifiers specializers nil))) ;; ;; If there is already a method like this one then we must ;; get rid of it before proceeding. Note that we call the ;; generic function remove-method to remove it rather than ;; doing it in some internal way. ;; (when existing (remove-method generic-function existing)) ;; (setf (method-generic-function method) generic-function) (pushnew method (generic-function-methods generic-function)) (dolist (specializer specializers) (add-direct-method specializer method)) (set-arg-info generic-function :new-method method) (unless skip-dfun-update-p (when (member name '(make-instance default-initargs allocate-instance shared-initialize initialize-instance)) (update-make-instance-function-table (type-class (car specializers)))) (update-dfun generic-function)) method))) (defun real-remove-method (generic-function method) (if (neq generic-function (method-generic-function method)) (error "The method ~S is attached to the generic function~@ ~S. It can't be removed from the generic function~@ to which it is not attached." method (method-generic-function method)) (let* ((name (generic-function-name generic-function)) (specializers (method-specializers method)) (methods (generic-function-methods generic-function)) (new-methods (remove method methods))) (setf (method-generic-function method) nil) (setf (generic-function-methods generic-function) new-methods) (dolist (specializer (method-specializers method)) (remove-direct-method specializer method)) (set-arg-info generic-function) (when (member name '(make-instance default-initargs allocate-instance shared-initialize initialize-instance)) (update-make-instance-function-table (type-class (car specializers)))) (update-dfun generic-function) generic-function))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) (defmethod compute-applicable-methods ((generic-function generic-function) arguments) (values (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function arguments 'eql)))) (defmethod compute-applicable-methods-using-classes ((generic-function generic-function) classes) (compute-applicable-methods-using-types generic-function (types-from-arguments generic-function classes 'class-eq))) (defun proclaim-incompatible-superclasses (classes) (setq classes (mapcar #'(lambda (class) (if (symbolp class) (find-class class) class)) classes)) (dolist (class classes) (dolist (other-class classes) (unless (eq class other-class) (pushnew other-class (class-incompatible-superclass-list class)))))) (defun superclasses-compatible-p (class1 class2) (let ((cpl1 (class-precedence-list class1)) (cpl2 (class-precedence-list class2))) (dolist (sc1 cpl1 t) (dolist (ic (class-incompatible-superclass-list sc1)) (when (memq ic cpl2) (return-from superclasses-compatible-p nil)))))) (mapc #'proclaim-incompatible-superclasses '(;; superclass class (built-in-class std-class structure-class) ; direct subclasses of pcl-class (standard-class funcallable-standard-class) ;; superclass metaobject (class eql-specializer class-eq-specializer method method-combination generic-function slot-definition) ;; metaclass built-in-class (number sequence character ; direct subclasses of t, but not array standard-object structure-object) ; or symbol (number array character symbol ; direct subclasses of t, but not sequence standard-object structure-object) (complex float rational) ; direct subclasses of number (integer ratio) ; direct subclasses of rational (list vector) ; direct subclasses of sequence (cons null) ; direct subclasses of list (string bit-vector) ; direct subclasses of vector )) (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer)) nil) (defmethod same-specializer-p ((specl1 class) (specl2 class)) (eq specl1 specl2)) (defmethod specializer-class ((specializer class)) specializer) (defmethod same-specializer-p ((specl1 class-eq-specializer) (specl2 class-eq-specializer)) (eq (specializer-class specl1) (specializer-class specl2))) (defmethod same-specializer-p ((specl1 eql-specializer) (specl2 eql-specializer)) (eq (specializer-object specl1) (specializer-object specl2))) (defmethod specializer-class ((specializer eql-specializer)) (class-of (slot-value specializer 'object))) (defvar *in-gf-arg-info-p* nil) (setf (gdefinition 'arg-info-reader) (let ((mf (initialize-method-function (make-internal-reader-method-function 'standard-generic-function 'arg-info) t))) #'(lambda (&rest args) (funcall mf args nil)))) (defun types-from-arguments (generic-function arguments &optional type-modifier) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info generic-function) (declare (ignore applyp metatypes nkeys)) (let ((types-rev nil)) (dotimes (i nreq) i (unless arguments (error "The function ~S requires at least ~D arguments" (generic-function-name generic-function) nreq)) (let ((arg (pop arguments))) (push (if type-modifier `(,type-modifier ,arg) arg) types-rev))) (values (nreverse types-rev) arg-info)))) (defun get-wrappers-from-classes (nkeys wrappers classes metatypes) (let* ((w wrappers) (w-tail w) (mt-tail metatypes)) (dolist (class (if (listp classes) classes (list classes))) (unless (eq 't (car mt-tail)) (let ((c-w (class-wrapper class))) (unless c-w (return-from get-wrappers-from-classes nil)) (if (eql nkeys 1) (setq w c-w) (setf (car w-tail) c-w w-tail (cdr w-tail))))) (setq mt-tail (cdr mt-tail))) w)) (defun sdfun-for-caching (gf classes) (let ((types (mapcar #'class-eq-type classes))) (multiple-value-bind (methods all-applicable-and-sorted-p) (compute-applicable-methods-using-types gf types) (function-funcall (get-secondary-dispatch-function1 gf methods types nil t all-applicable-and-sorted-p) nil (mapcar #'class-wrapper classes))))) (defun value-for-caching (gf classes) (let ((methods (compute-applicable-methods-using-types gf (mapcar #'class-eq-type classes)))) (method-function-get (or (method-fast-function (car methods)) (method-function (car methods))) :constant-value))) (defun default-secondary-dispatch-function (generic-function) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (let ((methods (compute-applicable-methods generic-function args))) (if methods (let ((emf (get-effective-method-function generic-function methods))) (invoke-emf emf args)) (apply #'no-applicable-method generic-function args))))) (defun list-eq (x y) (loop (when (atom x) (return (eq x y))) (when (atom y) (return nil)) (unless (eq (car x) (car y)) (return nil)) (setq x (cdr x) y (cdr y)))) (defvar *std-cam-methods* nil) (defun compute-applicable-methods-emf (generic-function) (if (eq *boot-state* 'complete) (let* ((cam (gdefinition 'compute-applicable-methods)) (cam-methods (compute-applicable-methods-using-types cam (list `(eql ,generic-function) t)))) (values (get-effective-method-function cam cam-methods) (list-eq cam-methods (or *std-cam-methods* (setq *std-cam-methods* (compute-applicable-methods-using-types cam (list `(eql ,cam) t))))))) (values #'compute-applicable-methods-function t))) (defun compute-applicable-methods-emf-std-p (gf) (gf-info-c-a-m-emf-std-p (gf-arg-info gf))) (defvar *old-c-a-m-gf-methods* nil) (defun update-all-c-a-m-gf-info (c-a-m-gf) (let ((methods (generic-function-methods c-a-m-gf))) (if (and *old-c-a-m-gf-methods* (every #'(lambda (old-method) (member old-method methods)) *old-c-a-m-gf-methods*)) (let ((gfs-to-do nil) (gf-classes-to-do nil)) (dolist (method methods) (unless (member method *old-c-a-m-gf-methods*) (let ((specl (car (method-specializers method)))) (if (eql-specializer-p specl) (pushnew (specializer-object specl) gfs-to-do) (pushnew (specializer-class specl) gf-classes-to-do))))) (map-all-generic-functions #'(lambda (gf) (when (or (member gf gfs-to-do) (dolist (class gf-classes-to-do nil) (member class (class-precedence-list (class-of gf))))) (update-c-a-m-gf-info gf))))) (map-all-generic-functions #'update-c-a-m-gf-info)) (setq *old-c-a-m-gf-methods* methods))) (defun update-gf-info (gf) (update-c-a-m-gf-info gf) (update-gf-simple-accessor-type gf)) (defun update-c-a-m-gf-info (gf) (unless (early-gf-p gf) (multiple-value-bind (c-a-m-emf std-p) (compute-applicable-methods-emf gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))) (defun update-gf-simple-accessor-type (gf) (let ((arg-info (gf-arg-info gf))) (setf (gf-info-simple-accessor-type arg-info) (let* ((methods (generic-function-methods gf)) (class (and methods (class-of (car methods)))) (type (and class (cond ((eq class *the-class-standard-reader-method*) 'reader) ((eq class *the-class-standard-writer-method*) 'writer) ((eq class *the-class-standard-boundp-method*) 'boundp))))) (when (and (gf-info-c-a-m-emf-std-p arg-info) type (dolist (method (cdr methods) t) (unless (eq class (class-of method)) (return nil))) (eq (generic-function-method-combination gf) *standard-method-combination*)) type))))) (defun get-accessor-method-function (gf type class slotd) (let* ((std-method (standard-svuc-method type)) (str-method (structure-svuc-method type)) (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) (types (if (eq type 'writer) `(t ,@types1) types1)) (methods (compute-applicable-methods-using-types gf types)) (std-p (null (cdr methods)))) (values (if std-p (get-optimized-std-accessor-method-function class slotd type) (get-accessor-from-svuc-method-function class slotd (get-secondary-dispatch-function gf methods types `((,(car (or (member std-method methods) (member str-method methods) (error "error in get-accessor-method-function"))) ,(get-optimized-std-slot-value-using-class-method-function class slotd type))) (unless (and (eq type 'writer) (dolist (method methods t) (unless (eq (car (method-specializers method)) *the-class-t*) (return nil)))) (let ((wrappers (list (wrapper-of class) (class-wrapper class) (wrapper-of slotd)))) (if (eq type 'writer) (cons (class-wrapper *the-class-t*) wrappers) wrappers)))) type)) std-p))) ;used by optimize-slot-value-by-class-p (vector.lisp) (defun update-slot-value-gf-info (gf type) (unless *new-class* (update-std-or-str-methods gf type)) (when (and (standard-svuc-method type) (structure-svuc-method type)) (flet ((update-class (class) (when (class-finalized-p class) (dolist (slotd (class-slots class)) (compute-slot-accessor-info slotd type gf))))) (if *new-class* (update-class *new-class*) (map-all-classes #'update-class 'slot-object))))) (defvar *standard-slot-value-using-class-method* nil) (defvar *standard-setf-slot-value-using-class-method* nil) (defvar *standard-slot-boundp-using-class-method* nil) (defvar *structure-slot-value-using-class-method* nil) (defvar *structure-setf-slot-value-using-class-method* nil) (defvar *structure-slot-boundp-using-class-method* nil) (defun standard-svuc-method (type) (case type (reader *standard-slot-value-using-class-method*) (writer *standard-setf-slot-value-using-class-method*) (boundp *standard-slot-boundp-using-class-method*))) (defun set-standard-svuc-method (type method) (case type (reader (setq *standard-slot-value-using-class-method* method)) (writer (setq *standard-setf-slot-value-using-class-method* method)) (boundp (setq *standard-slot-boundp-using-class-method* method)))) (defun structure-svuc-method (type) (case type (reader *structure-slot-value-using-class-method*) (writer *structure-setf-slot-value-using-class-method*) (boundp *structure-slot-boundp-using-class-method*))) (defun set-structure-svuc-method (type method) (case type (reader (setq *structure-slot-value-using-class-method* method)) (writer (setq *structure-setf-slot-value-using-class-method* method)) (boundp (setq *structure-slot-boundp-using-class-method* method)))) (defun update-std-or-str-methods (gf type) (dolist (method (generic-function-methods gf)) (let ((specls (method-specializers method))) (when (and (or (not (eq type 'writer)) (eq (pop specls) *the-class-t*)) (every #'classp specls)) (cond ((and (eq (class-name (car specls)) 'std-class) (eq (class-name (cadr specls)) 'standard-object) (eq (class-name (caddr specls)) 'standard-effective-slot-definition)) (set-standard-svuc-method type method)) ((and (eq (class-name (car specls)) 'structure-class) (eq (class-name (cadr specls)) 'structure-object) (eq (class-name (caddr specls)) 'structure-effective-slot-definition)) (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) (cons (specializer-class spec) (and (classp spec) precompute-p (not (or (eq spec *the-class-t*) (eq spec *the-class-slot-object*) (eq spec *the-class-standard-object*) (eq spec *the-class-structure-object*))) (let ((sc (class-direct-subclasses spec))) (when sc (mapcan #'(lambda (class) (mec-all-classes-internal class precompute-p)) sc)))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) (if (null (cdr classes)) classes (let* ((a-classes (cons nil classes)) (tail classes)) (loop (when (null (cdr tail)) (return (cdr a-classes))) (let ((class (cadr tail)) (ttail (cddr tail))) (if (dolist (c ttail nil) (when (eq class c) (return t))) (setf (cdr tail) (cddr tail)) (setf tail (cdr tail))))))))) (defun mec-all-class-lists (spec-list precompute-p) (if (null spec-list) (list nil) (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p)) (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p))) (mapcan #'(lambda (list) (mapcar #'(lambda (c) (cons c list)) car-all-classes)) all-class-lists)))) (defun make-emf-cache (generic-function valuep cache classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (metatypes (arg-info-metatypes arg-info)) (wrappers (unless (eq nkeys 1) (make-list nkeys))) (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) (default '(default))) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) (let ((wrappers (get-wrappers-from-classes nkeys wrappers classes metatypes))) (when (and wrappers (eq default (probe-cache cache wrappers default))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) ((eq valuep :constant-value) (value-for-caching generic-function classes))))) (setq cache (fill-cache cache wrappers value t)))))))) (if classes-list (mapc #'add-class-list classes-list) (dolist (method (generic-function-methods generic-function)) (mapc #'add-class-list (mec-all-class-lists (method-specializers method) precompute-p)))) cache))) (defmacro class-test (arg class) (cond ((eq class *the-class-t*) 't) ((eq class *the-class-slot-object*) #-(or new-kcl-wrapper cmu17) `(not (eq *the-class-built-in-class* (wrapper-class (std-instance-wrapper (class-of ,arg))))) #+new-kcl-wrapper `(or (std-instance-p ,arg) (fsc-instance-p ,arg)) #+cmu17 `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) #-new-kcl-wrapper ((eq class *the-class-standard-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) #-cmu17 ((eq class *the-class-structure-object*) `(memq ',class (class-precedence-list (class-of ,arg)))) ;; TYPEP is now sometimes faster than doing memq of the cpl (t `(typep ,arg ',(class-name class))))) (defmacro class-eq-test (arg class) `(eq (class-of ,arg) ',class)) (defmacro eql-test (arg object) `(eql ,arg ',object)) (defun dnet-methods-p (form) (and (consp form) (or (eq (car form) 'methods) (eq (car form) 'unordered-methods)))) (defmacro scase (arg &rest clauses) ; This is case, but without gensyms `(let ((.case-arg. ,arg)) (cond ,@(mapcar #'(lambda (clause) (list* (cond ((null (car clause)) nil) ((consp (car clause)) (if (null (cdar clause)) `(eql .case-arg. ',(caar clause)) `(member .case-arg. ',(car clause)))) ((member (car clause) '(t otherwise)) `t) (t `(eql .case-arg. ',(car clause)))) nil (cdr clause))) clauses)))) (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses)) (defun generate-discrimination-net (generic-function methods types sorted-p) (let* ((arg-info (gf-arg-info generic-function)) (precedence (arg-info-precedence arg-info))) (generate-discrimination-net-internal generic-function methods types #'(lambda (methods known-types) (if (or sorted-p (block one-order-p (let ((sorted-methods nil)) (map-all-orders (copy-list methods) precedence #'(lambda (methods) (when sorted-methods (return-from one-order-p nil)) (setq sorted-methods methods))) (setq methods sorted-methods)) t)) `(methods ,methods ,known-types) `(unordered-methods ,methods ,known-types))) #'(lambda (position type true-value false-value) (let ((arg (dfun-arg-symbol position))) (if (eq (car type) 'eql) (let* ((false-case-p (and (consp false-value) (or (eq (car false-value) 'scase) (eq (car false-value) 'mcase)) (eq arg (cadr false-value)))) (false-clauses (if false-case-p (cddr false-value) `((t ,false-value)))) (case-sym (if (and (dnet-methods-p true-value) (if false-case-p (eq (car false-value) 'mcase) (dnet-methods-p false-value))) 'mcase 'scase)) (type-sym `(,(cadr type)))) `(,case-sym ,arg (,type-sym ,true-value) ,@false-clauses)) `(if ,(let ((arg (dfun-arg-symbol position))) (case (car type) (class `(class-test ,arg ,(cadr type))) (class-eq `(class-eq-test ,arg ,(cadr type))))) ,true-value ,false-value)))) #'identity))) (defun class-from-type (type) (if (or (atom type) (eq (car type) 't)) *the-class-t* (case (car type) (and (dolist (type (cdr type) *the-class-t*) (when (and (consp type) (not (eq (car type) 'not))) (return (class-from-type type))))) (not *the-class-t*) (eql (class-of (cadr type))) (class-eq (cadr type)) (class (cadr type))))) (defun precompute-effective-methods (gf caching-p &optional classes-list-p) (let* ((arg-info (gf-arg-info gf)) (methods (generic-function-methods gf)) (precedence (arg-info-precedence arg-info)) (*in-precompute-effective-methods-p* t) (classes-list nil)) (generate-discrimination-net-internal gf methods nil #'(lambda (methods known-types) (when methods (when classes-list-p (push (mapcar #'class-from-type known-types) classes-list)) (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods)))) (map-all-orders methods precedence #'(lambda (methods) (get-secondary-dispatch-function1 gf methods known-types nil caching-p no-eql-specls-p)))))) #'(lambda (position type true-value false-value) (declare (ignore position type true-value false-value)) nil) #'(lambda (type) (if (and (consp type) (eq (car type) 'eql)) `(class-eq ,(class-of (cadr type))) type))) classes-list)) ; we know that known-type implies neither new-type nor `(not ,new-type) (defun augment-type (new-type known-type) (if (or (eq known-type 't) (eq (car new-type) 'eql)) new-type (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and)) (cdr known-type) (list known-type)))) (unless (eq (car new-type) 'not) (setq so-far (mapcan #'(lambda (type) (unless (*subtypep new-type type) (list type))) so-far))) (if (null so-far) new-type `(and ,new-type ,@so-far))))) #+lcl3.0 (dont-use-production-compiler) (defun generate-discrimination-net-internal (gf methods types methods-function test-function type-function) #+cmu (declare (type function methods-function test-function type-function)) (let* ((arg-info (gf-arg-info gf)) (precedence (arg-info-precedence arg-info)) (nreq (arg-info-number-required arg-info)) (metatypes (arg-info-metatypes arg-info))) (labels ((do-column (p-tail contenders known-types) (if p-tail (let* ((position (car p-tail)) (known-type (or (nth position types) t))) (if (eq (nth position metatypes) 't) (do-column (cdr p-tail) contenders (cons (cons position known-type) known-types)) (do-methods p-tail contenders known-type () known-types))) (funcall methods-function contenders (let ((k-t (make-list nreq))) (dolist (index+type known-types) (setf (nth (car index+type) k-t) (cdr index+type))) k-t)))) (do-methods (p-tail contenders known-type winners known-types) ;; ;; ;; is a (sorted) list of methods that must be discriminated ;; ;; is the type of this argument, constructed from tests already made. ;; ;; is a (sorted) list of methods that are potentially applicable ;; after the discrimination has been made. ;; (if (null contenders) (do-column (cdr p-tail) winners (cons (cons (car p-tail) known-type) known-types)) (let* ((position (car p-tail)) (method (car contenders)) (specl (nth position (method-specializers method))) (type (funcall type-function (type-from-specializer specl)))) (multiple-value-bind (app-p maybe-app-p) (specializer-applicable-using-type-p type known-type) (flet ((determined-to-be (truth-value) (if truth-value app-p (not maybe-app-p))) (do-if (truth &optional implied) (let ((ntype (if truth type `(not ,type)))) (do-methods p-tail (cdr contenders) (if implied known-type (augment-type ntype known-type)) (if truth (append winners `(,method)) winners) known-types)))) (cond ((determined-to-be nil) (do-if nil t)) ((determined-to-be t) (do-if t t)) (t (funcall test-function position type (do-if t) (do-if nil)))))))))) (do-column precedence methods ())))) #+lcl3.0 (use-previous-compiler) (defun compute-secondary-dispatch-function (generic-function net &optional method-alist wrappers) (function-funcall (compute-secondary-dispatch-function1 generic-function net) method-alist wrappers)) (defvar *eq-case-table-limit* 15) (defvar *case-table-limit* 10) (defun compute-mcase-parameters (case-list) (unless (eq 't (caar (last case-list))) (error "The key for the last case arg to mcase was not T")) (let* ((eq-p (dolist (case case-list t) (unless (or (eq (car case) 't) (symbolp (caar case))) (return nil)))) (len (1- (length case-list))) (type (cond ((= len 1) :simple) ((<= len (if eq-p *eq-case-table-limit* *case-table-limit*)) :assoc) (t :hash-table)))) (list eq-p type))) (defmacro mlookup (key info default &optional eq-p type) (unless (or (eq eq-p 't) (null eq-p)) (error "Invalid eq-p argument")) (ecase type (:simple `(if (,(if eq-p 'eq 'eql) ,key (car ,info)) (cdr ,info) ,default)) (:assoc `(dolist (e ,info ,default) (when (,(if eq-p 'eq 'eql) (car e) ,key) (return (cdr e))))) (:hash-table `(gethash ,key ,info ,default)))) (defun net-test-converter (form) (if (atom form) (default-test-converter form) (case (car form) ((invoke-effective-method-function invoke-fast-method-call) '.call.) (methods '.methods.) (unordered-methods '.umethods.) (mcase `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form)))) (t (default-test-converter form))))) (defun net-code-converter (form) (if (atom form) (default-code-converter form) (case (car form) ((methods unordered-methods) (let ((gensym (gensym))) (values gensym (list gensym)))) (mcase (let ((mp (compute-mcase-parameters (cddr form))) (gensym (gensym)) (default (gensym))) (values `(mlookup ,(cadr form) ,gensym ,default ,@mp) (list gensym default)))) (t (default-code-converter form))))) (defun net-constant-converter (form generic-function) (or (let ((c (methods-converter form generic-function))) (when c (list c))) (if (atom form) (default-constant-converter form) (case (car form) (mcase (let* ((mp (compute-mcase-parameters (cddr form))) (list (mapcar #'(lambda (clause) (let ((key (car clause)) (meth (cadr clause))) (cons (if (consp key) (car key) key) (methods-converter meth generic-function)))) (cddr form))) (default (car (last list)))) (list (list* ':mcase mp (nbutlast list)) (cdr default)))) (t (default-constant-converter form)))))) (defun methods-converter (form generic-function) (cond ((and (consp form) (eq (car form) 'methods)) (cons '.methods. (get-effective-method-function1 generic-function (cadr form)))) ((and (consp form) (eq (car form) 'unordered-methods)) (default-secondary-dispatch-function generic-function)))) (defun convert-methods (constant method-alist wrappers) (if (and (consp constant) (eq (car constant) '.methods.)) (funcall (the function (cdr constant)) method-alist wrappers) constant)) (defun convert-table (constant method-alist wrappers) (cond ((and (consp constant) (eq (car constant) ':mcase)) (let ((alist (mapcar #'(lambda (k+m) (cons (car k+m) (convert-methods (cdr k+m) method-alist wrappers))) (cddr constant))) (mp (cadr constant))) (ecase (cadr mp) (:simple (car alist)) (:assoc alist) (:hash-table (let ((table (make-hash-table :test (if (car mp) 'eq 'eql)))) (dolist (k+m alist) (setf (gethash (car k+m) table) (cdr k+m))) table))))))) (defun compute-secondary-dispatch-function1 (generic-function net &optional function-p) (cond ((and (eq (car net) 'methods) (not function-p)) (get-effective-method-function1 generic-function (cadr net))) (t (let* ((name (generic-function-name generic-function)) (arg-info (gf-arg-info generic-function)) (metatypes (arg-info-metatypes arg-info)) (applyp (arg-info-applyp arg-info)) (fmc-arg-info (cons (length metatypes) applyp))) (multiple-value-bind (cfunction constants) (get-function1 (make-dispatch-lambda function-p metatypes applyp `((locally (declare #.*optimize-speed*) (let ((emf ,net)) ,(make-emf-call metatypes applyp 'emf))))) #'net-test-converter #'net-code-converter #'(lambda (form) (net-constant-converter form generic-function))) #'(lambda (method-alist wrappers) (let* ((alist (list nil)) (alist-tail alist)) (dolist (constant constants) (let* ((a (or (dolist (a alist nil) (when (eq (car a) constant) (return a))) (cons constant (or (convert-table constant method-alist wrappers) (convert-methods constant method-alist wrappers))))) (new (list a))) (setf (cdr alist-tail) new) (setf alist-tail new))) (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) (if function-p function (make-fast-method-call :function (set-function-name function `(sdfun-method ,name)) :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) (defun make-unordered-methods-emf (generic-function methods) (when *show-make-unordered-methods-emf-calls* (format t "~&make-unordered-methods-emf ~s~%" (generic-function-name generic-function))) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (let* ((types (types-from-arguments generic-function args 'eql)) (smethods (sort-applicable-methods generic-function methods types)) (emf (get-effective-method-function generic-function smethods))) (invoke-emf emf args)))) ;;; ;;; The value returned by compute-discriminating-function is a function ;;; object. It is called a discriminating function because it is called ;;; when the generic function is called and its role is to discriminate ;;; on the arguments to the generic function and then call appropriate ;;; method functions. ;;; ;;; A discriminating function can only be called when it is installed as ;;; the funcallable instance function of the generic function for which ;;; it was computed. ;;; ;;; More precisely, if compute-discriminating-function is called with an ;;; argument , and returns a result , that result must not be ;;; passed to apply or funcall directly. Rather, must be stored as ;;; the funcallable instance function of the same generic function ;;; (using set-funcallable-instance-function). Then the generic function ;;; can be passed to funcall or apply. ;;; ;;; An important exception is that methods on this generic function are ;;; permitted to return a function which itself ends up calling the value ;;; returned by a more specific method. This kind of `encapsulation' of ;;; discriminating function is critical to many uses of the MOP. ;;; ;;; As an example, the following canonical case is legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; (let ((std (call-next-method))) ;;; #'(lambda (arg) ;;; (print (list 'call-to-gf gf arg)) ;;; (funcall std arg)))) ;;; ;;; Because many discriminating functions would like to use a dynamic ;;; strategy in which the precise discriminating function changes with ;;; time it is important to specify how a discriminating function is ;;; permitted itself to change the funcallable instance function of the ;;; generic function. ;;; ;;; Discriminating functions may set the funcallable instance function ;;; of the generic function, but the new value must be generated by making ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any ;;; more specific methods which may have encapsulated the discriminating ;;; function will get a chance to encapsulate the new, inner discriminating ;;; function. ;;; ;;; This implies that if a discriminating function wants to modify itself ;;; it should first store some information in the generic function proper, ;;; and then call compute-discriminating-function. The appropriate method ;;; on compute-discriminating-function will see the information stored in ;;; the generic function and generate a discriminating function accordingly. ;;; ;;; The following is an example of a discriminating function which modifies ;;; itself in accordance with this protocol: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; #'(lambda (arg) ;;; (cond ( ;;; ;;; (set-funcallable-instance-function ;;; gf ;;; (compute-discriminating-function gf)) ;;; (funcall gf arg)) ;;; (t ;;; )))) ;;; ;;; Whereas this code would not be legal: ;;; ;;; (defmethod compute-discriminating-function ((gf my-generic-function)) ;;; #'(lambda (arg) ;;; (cond ( ;;; (set-funcallable-instance-function ;;; gf ;;; #'(lambda (a) ..)) ;;; (funcall gf arg)) ;;; (t ;;; )))) ;;; ;;; NOTE: All the examples above assume that all instances of the class ;;; my-generic-function accept only one argument. ;;; ;;; ;;; ;;; (defun slot-value-using-class-dfun (class object slotd) (declare (ignore class)) (function-funcall (slot-definition-reader-function slotd) object)) (defun setf-slot-value-using-class-dfun (new-value class object slotd) (declare (ignore class)) (function-funcall (slot-definition-writer-function slotd) new-value object)) (defun slot-boundp-using-class-dfun (class object slotd) (declare (ignore class)) (function-funcall (slot-definition-boundp-function slotd) object)) (defmethod compute-discriminating-function ((gf standard-generic-function)) (with-slots (dfun-state arg-info) gf (typecase dfun-state (null (let ((name (generic-function-name gf))) (when (eq name 'compute-applicable-methods) (update-all-c-a-m-gf-info gf)) (cond ((eq name 'slot-value-using-class) (update-slot-value-gf-info gf 'reader) #'slot-value-using-class-dfun) ((equal name '(setf slot-value-using-class)) (update-slot-value-gf-info gf 'writer) #'setf-slot-value-using-class-dfun) ((eq name 'slot-boundp-using-class) (update-slot-value-gf-info gf 'boundp) #'slot-boundp-using-class-dfun) ((gf-precompute-dfun-and-emf-p arg-info) (make-final-dfun gf)) (t (make-initial-dfun gf))))) (function dfun-state) (cons (car dfun-state))))) (defmethod update-gf-dfun ((class std-class) gf) (let ((*new-class* class) #|| (name (generic-function-name gf)) ||# (arg-info (gf-arg-info gf))) (cond #|| ((eq name 'slot-value-using-class) (update-slot-value-gf-info gf 'reader)) ((equal name '(setf slot-value-using-class)) (update-slot-value-gf-info gf 'writer)) ((eq name 'slot-boundp-using-class) (update-slot-value-gf-info gf 'boundp)) ||# ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) (set-dfun gf dfun cache info) ; otherwise cache might get freed twice (update-dfun gf dfun cache info)))))) ;;; ;;; ;;; (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) (defun method-ll->generic-function-ll (ll) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list ll) (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) (remove-if #'(lambda (s) (or (memq s keyword-parameters) (eq s '&allow-other-keys))) ll))) ;;; ;;; This is based on the rules of method lambda list congruency defined in ;;; the spec. The lambda list it constructs is the pretty union of the ;;; lambda lists of all the methods. It doesn't take method applicability ;;; into account at all yet. ;;; (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) (let ((methods (generic-function-methods generic-function)) (arglist ())) (when methods (multiple-value-bind (required optional rest key allow-other-keys) (method-pretty-arglist (car methods)) (dolist (m (cdr methods)) (multiple-value-bind (method-key-keywords method-allow-other-keys method-key) (function-keywords m) ;; we've modified function-keywords to return what we want as ;; the third value, no other change here. (declare (ignore method-key-keywords)) (setq key (union key method-key)) (setq allow-other-keys (or allow-other-keys method-allow-other-keys)))) (when allow-other-keys (setq arglist '(&allow-other-keys))) (when key (setq arglist (nconc (list '&key) key arglist))) (when rest (setq arglist (nconc (list '&rest rest) arglist))) (when optional (setq arglist (nconc (list '&optional) optional arglist))) (nconc required arglist))))) (defmethod method-pretty-arglist ((method standard-method)) (let ((required ()) (optional ()) (rest nil) (key ()) (allow-other-keys nil) (state 'required) (arglist (method-lambda-list method))) (dolist (arg arglist) (cond ((eq arg '&optional) (setq state 'optional)) ((eq arg '&rest) (setq state 'rest)) ((eq arg '&key) (setq state 'key)) ((eq arg '&allow-other-keys) (setq allow-other-keys 't)) ((memq arg lambda-list-keywords)) (t (ecase state (required (push arg required)) (optional (push arg optional)) (key (push arg key)) (rest (setq rest arg)))))) (values (nreverse required) (nreverse optional) rest (nreverse key) allow-other-keys))) gcl/pcl/gcl_pcl_iterate.lisp0000644000175000017500000017113412240167764015046 0ustar cammcamm;;;-*- Package: ITERATE; Syntax: Common-Lisp; Base: 10 -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 (in-package :iterate :use '(:lisp :walker)) (export '(iterate iterate* gathering gather with-gathering interval elements list-elements list-tails plist-elements eachtime while until collecting joining maximizing minimizing summing *iterate-warnings*)) (defvar *iterate-warnings* :any "Controls whether warnings are issued for iterate/gather forms that aren't optimized. NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." ) ;;; ITERATE macro (defmacro iterate (clauses &body body &environment env) (optimize-iterate-form clauses body env)) (defun simple-expand-iterate-form (clauses body) ;; Expand ITERATE. This is the "formal semantics" expansion, which we never ;; use. (let* ((block-name (gensym)) (bound-var-lists (mapcar #'(lambda (clause) (let ((names (first clause))) (if (listp names) names (list names)))) clauses)) (generator-vars (mapcar #'(lambda (clause) (declare (ignore clause)) (gensym)) clauses))) `(block ,block-name (let* ,(mapcan #'(lambda (gvar clause var-list) ; For each clause, bind a ; generator temp to the clause, ; then bind the specified ; var(s) (cons (list gvar (second clause)) (copy-list var-list))) generator-vars clauses bound-var-lists) ;; Note bug in formal semantics: there can be declarations in the head ;; of BODY; they go here, rather than inside loop (loop ,@(mapcar #'(lambda (var-list gen-var) ; Set each bound variable (or ; set of vars) to the result of ; calling the corresponding ; generator `(multiple-value-setq ,var-list (funcall ,gen-var #'(lambda nil (return-from ,block-name))))) bound-var-lists generator-vars) ,@body))))) (defparameter *iterate-temp-vars-list* '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4 iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8) "Temp var names used by ITERATE expansions.") (defun optimize-iterate-form (clauses body iterate-env) (let* ((temp-vars *iterate-temp-vars-list*) (block-name (gensym)) (finish-form `(return-from ,block-name)) (bound-vars (mapcan #'(lambda (clause) (let ((names (first clause))) (if (listp names) (copy-list names) (list names)))) clauses)) iterate-decls generator-decls update-forms bindings leftover-body) (do ((tail bound-vars (cdr tail))) ((null tail)) ; Check for duplicates (when (member (car tail) (cdr tail)) (warn "Variable appears more than once in ITERATE: ~S" (car tail)))) (flet ((get-iterate-temp nil ;; Make temporary var. Note that it is ok to re-use these symbols ;; in each iterate, because they are not used within BODY. (or (pop temp-vars) (gensym)))) (dolist (clause clauses) (cond ((or (not (consp clause)) (not (consp (cdr clause)))) (warn "Bad syntax in ITERATE: clause not of form (var iterator): ~S" clause)) (t (unless (null (cddr clause)) (warn "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" clause)) (multiple-value-bind (let-body binding-type let-bindings localdecls otherdecls extra-body) (expand-into-let (second clause) 'iterate iterate-env) ;; We have expanded the generator clause and parsed it into its LET ;; pieces. (prog* ((vars (first clause)) gen-args renamed-vars) (setq vars (if (listp vars) (copy-list vars) (list vars))) ; VARS is now a (fresh) list of ; all iteration vars bound in ; this clause (cond ((eq let-body :abort) ; Already issued a warning ; about malformedness ) ((null (setq let-body (function-lambda-p let-body 1))) ; Not of the expected form (let ((generator (second clause))) (cond ((and (consp generator) (fboundp (car generator))) ; It looks ok--a macro or ; function here--so the guy who ; wrote it just didn't do it in ; an optimizable way (maybe-warn :definition "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" generator)) (t ; Perhaps it's just a ; misspelling? Probably user ; error (maybe-warn :user "Iterate operator in clause ~S is not fboundp." generator))) (setq let-body :abort))) (t ;; We have something of the form #'(LAMBDA (finisharg) ...), ;; possibly with some LET bindings around it. LET-BODY = ;; ((finisharg) ...). (setq let-body (cdr let-body)) (setq gen-args (pop let-body)) (when let-bindings ;; The first transformation we want to perform is ;; "LET-eversion": turn (let* ((generator (let (..bindings..) ;; #'(lambda ...)))) ..body..) into (let* (..bindings.. ;; (generator #'(lambda ...))) ..body..). This ;; transformation is valid if nothing in body refers to any ;; of the bindings, something we can assure by ;; alpha-converting the inner let (substituting new names for ;; each var). Of course, none of those vars can be special, ;; but we already checked for that above. (multiple-value-setq (let-bindings renamed-vars) (rename-let-bindings let-bindings binding-type iterate-env leftover-body #'get-iterate-temp)) (setq leftover-body nil) ; If there was any leftover ; from previous, it is now ; consumed ) ;; The second transformation is substituting the body of the ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance ;; in the update form (funcall generator #'(lambda () ;; finish-form)), then simplifying that form. The requirement ;; for this part is that the generator body not refer to any ;; variables that are bound between the generator binding and the ;; appearance in the loop body. The only variables bound in that ;; interval are generator temporaries, which have unique names so ;; are no problem, and the iteration variables remaining for ;; subsequent clauses. We'll discover the story as we walk the ;; body. (multiple-value-bind (finishdecl other rest) (parse-declarations let-body gen-args) (declare (ignore finishdecl)) ; Pull out declares, if any, ; separating out the one(s) ; referring to the finish arg, ; which we will throw away (when other ; Combine remaining decls with ; decls extracted from the LET, ; if any (setq otherdecls (nconc otherdecls other))) (setq let-body (cond (otherdecls ; There are interesting ; declarations, so have to keep ; it wrapped. `(let nil (declare ,@otherdecls) ,@rest)) ((null (cdr rest)) ; Only one form left (first rest)) (t `(progn ,@rest))))) (unless (eq (setq let-body (iterate-transform-body let-body iterate-env renamed-vars (first gen-args) finish-form bound-vars clause)) :abort) ;; Skip the rest if transformation failed. Warning has ;; already been issued. ;; Note possible further optimization: if LET-BODY expanded ;; into (prog1 oldvalue prepare-for-next-iteration), as so ;; many do, then we could in most cases split the PROG1 into ;; two pieces: do the (setq var oldvalue) here, and do the ;; prepare-for-next-iteration at the bottom of the loop. ;; This does a slight optimization of the PROG1 and also ;; rearranges the code in a way that a reasonably clever ;; compiler might detect how to get rid of redundant ;; variables altogether (such as happens with INTERVAL and ;; LIST-TAILS); that would make the whole thing closer to ;; what you might have coded by hand. However, to do this ;; optimization, we need to assure that (a) the ;; prepare-for-next-iteration refers freely to no vars other ;; than the internal vars we have extracted from the LET, and ;; (b) that the code has no side effects. These are both ;; true for all the iterators defined by this module, but how ;; shall we represent side-effect info and/or tap into the ;; compiler's knowledge of same? (when localdecls ; There were declarations for ; the generator locals--have to ; keep them for later, and ; rename the vars mentioned (setq generator-decls (nconc generator-decls (mapcar #'(lambda (decl) (let ((head (car decl))) (cons head (if (eq head 'type) (cons (second decl) (sublis renamed-vars (cddr decl))) (sublis renamed-vars (cdr decl)))))) localdecls))))))) ;; Finished analyzing clause now. LET-BODY is the form which, when ;; evaluated, returns updated values for the iteration variable(s) ;; VARS. (when (eq let-body :abort) ;; Some punt case: go with the formal semantics: bind a var to ;; the generator, then call it in the update section (let ((gvar (get-iterate-temp)) (generator (second clause))) (setq let-bindings (list (list gvar (cond (leftover-body ; Have to use this up `(progn ,@(prog1 leftover-body (setq leftover-body nil)) generator)) (t generator))))) (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form))))) (push (mv-setq (copy-list vars) let-body) update-forms) (dolist (v vars) (declare (ignore v)) ; Pop off the vars we have now ; bound from the list of vars ; to watch out for--we'll bind ; them right now (pop bound-vars)) (setq bindings (nconc bindings let-bindings (cond (extra-body ; There was some computation to ; do after the bindings--here's ; our chance (cons (list (first vars) `(progn ,@extra-body nil)) (rest vars))) (t vars)))))))))) (do ((tail body (cdr tail))) ((not (and (consp tail) (consp (car tail)) (eq (caar tail) 'declare))) ;; TAIL now points at first non-declaration. If there were ;; declarations, pop them off so they appear in the right place (unless (eq tail body) (setq iterate-decls (ldiff body tail)) (setq body tail)))) `(block ,block-name (let* ,bindings ,@(and generator-decls `((declare ,@generator-decls))) ,@iterate-decls ,@leftover-body (loop ,@(nreverse update-forms) ,@body))))) (defun expand-into-let (clause parent-name env) ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra ;; body, where BODY is a single form. If multiple forms in a LET, the ;; preceding forms are returned as extra body. Returns :ABORT if it ;; issued a punt warning. (prog ((expansion clause) expandedp binding-type let-bindings let-body) expand (multiple-value-setq (expansion expandedp) (macroexpand-1 expansion env)) (cond ((not (consp expansion)) ; Shouldn't happen ) ((symbolp (setq binding-type (first expansion))) (case binding-type ((let let*) (setq let-bindings (second expansion)) ; List of variable bindings (setq let-body (cddr expansion)) (go handle-let)))) ((and (consp binding-type) (eq (car binding-type) 'lambda) (not (find-if #'(lambda (x) (member x lambda-list-keywords) ) (setq let-bindings (second binding-type))) ) (eql (length (second expansion)) (length let-bindings)) (null (cddr expansion))) ; A simple LAMBDA form can be ; treated as LET (setq let-body (cddr binding-type)) (setq let-bindings (mapcar #'list let-bindings (second expansion)) ) (setq binding-type 'let) (go handle-let))) ;; Fall thru if not a LET (cond (expandedp ; try expanding again (go expand)) (t ; Boring--return form as the ; body (return expansion))) handle-let (return (let ((locals (variables-from-let let-bindings)) extra-body specials) (multiple-value-bind (localdecls otherdecls let-body) (parse-declarations let-body locals) (cond ((setq specials (extract-special-bindings locals localdecls)) (maybe-warn (cond ((find-if #'variable-globally-special-p specials) ; This could be the fault of a ; user proclamation :user) (t :definition)) "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" parent-name clause specials) :abort) (t (values (cond ((not (consp let-body)) ; Null body of LET? unlikely, ; but someone else will likely ; complain nil) ((null (cdr let-body)) ; A single expression, which we ; hope is (function ; (lambda...)) (first let-body)) (t ;; More than one expression. These are forms to ;; evaluate after the bindings but before the ;; generator form is returned. Save them to ;; evaluate in the next convenient place. Note that ;; this is ok, as there is no construct that can ;; cause a LET to return prematurely (without ;; returning also from some surrounding construct). (setq extra-body (butlast let-body)) (car (last let-body)))) binding-type let-bindings localdecls otherdecls extra-body)))))))) (defun variables-from-let (bindings) ;; Return a list of the variables bound in the first argument to LET[*]. (mapcar #'(lambda (binding) (if (consp binding) (first binding) binding)) bindings)) (defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg finish-form bound-vars clause) ;;; This is the second major transformation for a single iterate clause. ;;; LET-BODY is the body of the iterator after we have extracted its local ;;; variables and declarations. We have two main tasks: (1) Substitute ;;; internal temporaries for occurrences of the LET variables; the alist ;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of ;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we ;;; check for forms that would invalidate these transformations: occurrence of ;;; FINISH-ARG outside of a funcall, and free reference to any element of ;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type ;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we ;;; return the transformed body; on failure, :ABORT. (walk-form let-body iterate-env #'(lambda (form context env) (declare (ignore context)) ;; Need to substitute RENAMED-VARS, as well as turn ;; (FUNCALL finish-arg) into the finish form (cond ((symbolp form) (let (renaming) (cond ((and (eq form finish-arg) (variable-same-p form env iterate-env)) ; An occurrence of the finish ; arg outside of FUNCALL ; context--I can't handle this (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." (second clause)) (return-from iterate-transform-body :abort)) ((and (setq renaming (assoc form renamed-vars )) (variable-same-p form env iterate-env)) ; Reference to one of the vars ; we're renaming (cdr renaming)) ((and (member form bound-vars) (variable-same-p form env iterate-env)) ; FORM is a var that is bound ; in this same ITERATE, or ; bound later in this ITERATE*. ; This is a conflict. (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." (second clause) form) (return-from iterate-transform-body :abort)) (t form)))) ((and (consp form) (eq (first form) 'funcall) (eq (second form) finish-arg) (variable-same-p (second form) env iterate-env)) ; (FUNCALL finish-arg) => ; finish-form (unless (null (cddr form)) (maybe-warn :definition "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." (second clause) (cddr form))) finish-form) (t form))))) (defun parse-declarations (tail locals) ;; Extract the declarations from the head of TAIL and divide them into 2 ;; classes: declares about variables in the list LOCALS, and all other ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. (let (localdecls otherdecls form) (loop (unless (and tail (consp (setq form (car tail))) (eq (car form) 'declare)) (return (values localdecls otherdecls tail))) (mapc #'(lambda (decl) (case (first decl) ((inline notinline optimize) ; These don't talk about vars (push decl otherdecls)) (t ; Assume all other kinds are ; for vars (let* ((vars (if (eq (first decl) 'type) (cddr decl) (cdr decl))) (l (intersection locals vars)) other) (cond ((null l) ; None talk about LOCALS (push decl otherdecls)) ((null (setq other (set-difference vars l))) ; All talk about LOCALS (push decl localdecls)) (t ; Some of each (let ((head (cons 'type (and (eq (first decl) 'type) (list (second decl)))))) (push (append head other) otherdecls) (push (append head l) localdecls)))))))) (cdr form)) (pop tail)))) (defun extract-special-bindings (vars decls) ;; Return the subset of VARS that are special, either globally or ;; because of a declaration in DECLS (let ((specials (remove-if-not #'variable-globally-special-p vars))) (dolist (d decls) (when (eq (car d) 'special) (setq specials (union specials (intersection vars (cdr d)))))) specials)) (defun function-lambda-p (form &optional nargs) ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length ;; NARGS, return the lambda expression (let (args body) (and (consp form) (eq (car form) 'function) (consp (setq form (cdr form))) (null (cdr form)) (consp (setq form (car form))) (eq (car form) 'lambda) (consp (setq body (cdr form))) (listp (setq args (car body))) (or (null nargs) (eql (length args) nargs)) form))) (defun rename-let-bindings (let-bindings binding-type env leftover-body &optional tempvarfn) ;; Perform the alpha conversion required for "LET eversion" of (LET[*] ;; LET-BINDINGS . body)--rename each of the variables to an internal name. ;; Returns 2 values: a new set of LET bindings and the alist of old var names ;; to new (so caller can walk the body doing the rest of the renaming). ;; BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of ;; forms that must be eval'ed before the first binding happens. ENV is the ;; macro expansion environment, in case we have to walk a LET*. TEMPVARFN is ;; a function of no args to return a temporary var; if omitted, we use ;; GENSYM. (let (renamed-vars) (values (mapcar #'(lambda (binding) (let ((valueform (cond ((not (consp binding)) ; No initial value nil) ((or (eq binding-type 'let) (null renamed-vars)) ; All bindings are in parallel, ; so none can refer to others (second binding)) (t ; In a LET*, have to substitute ; vars in the 2nd and ; subsequent initialization ; forms (rename-variables (second binding) renamed-vars env)))) (newvar (if tempvarfn (funcall tempvarfn) (gensym)))) (push (cons (if (consp binding) (first binding) binding) newvar) renamed-vars) ; Add new variable to the list ; AFTER we have walked the ; initial value form (when leftover-body ;; Previous clause had some computation to do after ;; its bindings. Here is the first opportunity to ;; do it (setq valueform `(progn ,@leftover-body ,valueform)) (setq leftover-body nil)) (list newvar valueform))) let-bindings) renamed-vars))) (defun rename-variables (form alist env) ;; Walks FORM, renaming occurrences of the key variables in ALIST with ;; their corresponding values. ENV is FORM's environment, so we can ;; make sure we are talking about the same variables. (walk-form form env #'(lambda (form context subenv) (declare (ignore context)) (let (pair) (cond ((and (symbolp form) (setq pair (assoc form alist)) (variable-same-p form subenv env)) (cdr pair)) (t form)))))) (defun mv-setq (vars expr) ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some ;; of the simple cases for benefit of compilers that don't, and I don't care ;; what the value is, and I know that the variables need not be set in ;; parallel, since they can't be used free in EXPR (cond ((null vars) ; EXPR is a side-effect expr) ((not (consp vars)) ; This is an error, but I'll ; let MULTIPLE-VALUE-SETQ ; report it `(multiple-value-setq ,vars ,expr)) ((and (listp expr) (eq (car expr) 'values)) ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq ;; (psetq returns nil, but I don't care about returned value). Do this ;; even for the single variable case so that we catch (mv-setq (a) (values ;; x y)) (pop expr) ; VALUES `(setq ,@(mapcon #'(lambda (tail) (list (car tail) (cond ((or (cdr tail) (null (cdr expr))) ; One result expression for ; this var (pop expr)) (t ; More expressions than vars, ; so arrange to evaluate all ; the rest now. (cons 'prog1 expr))))) vars))) ((null (cdr vars)) ; Simple one variable case `(setq ,(car vars) ,expr)) (t ; General case--I know nothing `(multiple-value-setq ,vars ,expr)))) (defun variable-same-p (var env1 env2) (eq (variable-lexical-p var env1) (variable-lexical-p var env2))) (defun maybe-warn (type &rest warn-args) ;; Issue a warning about not being able to optimize this thing. TYPE ;; is one of :DEFINITION, meaning the definition is at fault, and ;; :USER, meaning the user's code is at fault. (when (case *iterate-warnings* ((nil) nil) ((:user) (eq type :user)) (t t)) (apply #'warn warn-args))) ;; Sample iterators (defmacro interval (&whole whole &key from downfrom to downto above below by type) (cond ((and from downfrom) (error "Can't use both FROM and DOWNFROM in ~S" whole)) ((cdr (remove nil (list to downto above below))) (error "Can't use more than one limit keyword in ~S" whole)) (t (let* ((down (or downfrom downto above)) (limit (or to downto above below)) (inc (cond ((null by) 1) ((constantp by) ; Can inline this increment by)))) `(let ((from ,(or from downfrom 0)) ,@(and limit `((to ,limit))) ,@(and (null inc) `((by ,by)))) ,@(and type `((declare (type ,type from ,@(and limit '(to)) ,@(and (null inc) `(by)))))) #'(lambda (finish) ,@(cond ((null limit) ; We won't use the FINISH arg '((declare (ignore finish))))) (prog1 ,(cond (limit ; Test the limit. If ok, ; return current value and ; increment, else quit `(if (,(cond (above '>) (below '<) (down '>=) (t '<=)) from to) from (funcall finish))) (t ; No test 'from)) (setq from (,(if down '- '+) from ,(or inc 'by)))))))))) (defmacro list-elements (list &key (by '#'cdr)) `(let ((tail ,list)) #'(lambda (finish) (prog1 (if (endp tail) (funcall finish) (first tail)) (setq tail (funcall ,by tail)))))) (defmacro list-tails (list &key (by '#'cdr)) `(let ((tail ,list)) #'(lambda (finish) (prog1 (if (endp tail) (funcall finish) tail) (setq tail (funcall ,by tail)))))) (defmacro elements (sequence) "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." (let* ((type (and (consp sequence) (eq (first sequence) 'the) (second sequence))) (accessor (if type (sequence-accessor type) 'elt)) (listp (eq type 'list))) ;; If type is given via THE, we may be able to generate a good accessor here ;; for the benefit of implementations that aren't smart about (ELT (THE ;; STRING FOO)). I'm not bothering to keep the THE inside the body, ;; however, since I assume any compiler that would understand (AREF (THE ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it. ;; If sequence is declared to be a list, it's better to cdr down it, so we ;; have some extra cases here. Normally folks would write LIST-ELEMENTS, ;; but maybe they wanted to get the index for free... `(let* ((index 0) (s ,sequence) ,@(and (not listp) '((size (length s))))) #'(lambda (finish) (values (cond ,(if listp '((not (endp s)) (pop s)) `((< index size) (,accessor s index))) (t (funcall finish))) (prog1 index (setq index (1+ index)))))))) (defmacro plist-elements (plist) "Generates each time 2 items, the indicator and the value." `(let ((tail ,plist)) #'(lambda (finish) (values (if (endp tail) (funcall finish) (first tail)) (prog1 (if (endp (setq tail (cdr tail))) (funcall finish) (first tail)) (setq tail (cdr tail))))))) (defun sequence-accessor (type) ;; returns the function with which most efficiently to make accesses to ;; a sequence of type TYPE. (case (if (consp type) ; e.g., (VECTOR FLOAT *) (car type) type) ((array simple-array vector) 'aref) (simple-vector 'svref) (string 'char) (simple-string 'schar) (bit-vector 'bit) (simple-bit-vector 'sbit) (t 'elt))) ;; These "iterators" may be withdrawn (defmacro eachtime (expr) `#'(lambda (finish) (declare (ignore finish)) ,expr)) (defmacro while (expr) `#'(lambda (finish) (unless ,expr (funcall finish)))) (defmacro until (expr) `#'(lambda (finish) (when ,expr (funcall finish)))) ; GATHERING macro (defmacro gathering (clauses &body body &environment env) (or (optimize-gathering-form clauses body env) (simple-expand-gathering-form clauses body env))) (defmacro with-gathering (clauses gather-body &body use-body) "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." ;; We may optimize this a little better later for those compilers that ;; don't do a good job on (m-v-bind vars (... (values ...)) ...). `(multiple-value-bind ,(mapcar #'car clauses) (gathering ,clauses ,gather-body) ,@use-body)) (defun simple-expand-gathering-form (clauses body env) (declare (ignore env)) ;; The "formal semantics" of GATHERING. We use this only in cases that can't ;; be optimized. (let ((acc-names (mapcar #'first (if (symbolp clauses) ; Shorthand using anonymous ; gathering site (setq clauses `((*anonymous-gathering-site* (,clauses)))) clauses))) (realizer-names (mapcar #'(lambda (binding) (declare (ignore binding)) (gensym)) clauses))) `(multiple-value-call #'(lambda ,(mapcan #'list acc-names realizer-names) (flet ((gather (value &optional (accumulator *anonymous-gathering-site*) ) (funcall accumulator value))) ,@body (values ,@(mapcar #'(lambda (rname) `(funcall ,rname)) realizer-names)))) ,@(mapcar #'second clauses)))) (defvar *active-gatherers* nil "List of GATHERING bindings currently active during macro expansion)") (defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." ) (defun optimize-gathering-form (clauses body gathering-env) (let* (acc-info leftover-body top-bindings finish-forms top-decls) (dolist (clause (if (symbolp clauses) ; A shorthand `((*anonymous-gathering-site* (,clauses))) clauses)) (multiple-value-bind (let-body binding-type let-bindings localdecls otherdecls extra-body) (expand-into-let (second clause) 'gathering gathering-env) (prog* ((acc-var (first clause)) renamed-vars accumulator realizer) (when (and (consp let-body) (eq (car let-body) 'values) (consp (setq let-body (cdr let-body))) (setq accumulator (function-lambda-p (car let-body))) (consp (setq let-body (cdr let-body))) (setq realizer (function-lambda-p (car let-body) 0)) (null (cdr let-body))) ;; Macro returned something of the form (VALUES #'(lambda (value) ;; ...) #'(lambda () ...)), a function to accumulate values and a ;; function to realize the result. (when binding-type ;; Gatherer expanded into a LET (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" (second clause) `(declare ,@otherdecls)) (go punt))) (when let-bindings ;; The first transformation we want to perform is a ;; variant of "LET-eversion": turn (mv-bind (acc real) ;; (let (..bindings..) (values #'(lambda ...) #'(lambda ;; ...))) ..body..) into (let* (..bindings.. (acc ;; #'(lambda ...)) (real #'(lambda ...))) ..body..). This ;; transformation is valid if nothing in body refers to ;; any of the bindings, something we can assure by ;; alpha-converting the inner let (substituting new names ;; for each var). Of course, none of those vars can be ;; special, but we already checked for that above. (multiple-value-setq (let-bindings renamed-vars) (rename-let-bindings let-bindings binding-type gathering-env leftover-body)) (setq top-bindings (nconc top-bindings let-bindings)) (setq leftover-body nil) ; If there was any leftover ; from previous, it is now ; consumed )) (setq leftover-body (nconc leftover-body extra-body)) ; Computation to do after these ; bindings (push (cons acc-var (rename-and-capture-variables accumulator renamed-vars gathering-env)) acc-info) (setq realizer (rename-variables realizer renamed-vars gathering-env)) (push (cond ((null (cdddr realizer)) ; Simple (LAMBDA () expr) => ; expr (third realizer)) (t ; There could be declarations ; or something, so leave as a ; LET (cons 'let (cdr realizer)))) finish-forms) (unless (null localdecls) ; Declarations about the LET ; variables also has to ; percolate up (setq top-decls (nconc top-decls (sublis renamed-vars localdecls)))) (return)) (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" (second clause)) punt (let ((gs (gensym)) (expansion `(multiple-value-list ,(second clause)))) ; Slow way--bind gensym to the ; macro expansion, and we will ; funcall it in the body (push (list acc-var gs) acc-info) (push `(funcall (cadr ,gs)) finish-forms) (setq top-bindings (nconc top-bindings (list (list gs (cond (leftover-body `(progn ,@(prog1 leftover-body (setq leftover-body nil)) ,expansion)) (t expansion)))))))))) (setq body (walk-gathering-body body gathering-env acc-info)) (cond ((eq body :abort) ; Couldn't finish expansion nil) (t `(let* ,top-bindings ,@(and top-decls `((declare ,@top-decls))) ,body ,(cond ((null (cdr finish-forms)) ; just a single value (car finish-forms)) (t `(values ,@(reverse finish-forms))))))))) (defun rename-and-capture-variables (form alist env) ;; Walks FORM, renaming occurrences of the key variables in ALIST with ;; their corresponding values, and capturing any other free variables. ;; Returns a list of the new form and the list of other closed-over ;; vars. ENV is FORM's environment, so we can make sure we are talking ;; about the same variables. (let (closed) (list (walk-form form env #'(lambda (form context subenv) (declare (ignore context)) (let (pair) (cond ((or (not (symbolp form)) (not (variable-same-p form subenv env))) ; non-variable or one that has ; been rebound form) ((setq pair (assoc form alist)) ; One to rename (cdr pair)) (t ; var is free (pushnew form closed) form))))) closed))) (defun walk-gathering-body (body gathering-env acc-info) ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ;; ACC-INFO is a list of information about each of the gathering "bindings" ;; in the form, in the form (var gatheringfn freevars env) (let ((*active-gatherers* (nconc (mapcar #'car acc-info) *active-gatherers*))) ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER ;; targets. This is so that when we encounter a GATHER not belonging to us ;; we can know whether to warn about it. (walk-form (cons 'progn body) gathering-env #'(lambda (form context env) (declare (ignore context)) (let (info site) (cond ((consp form) (cond ((not (eq (car form) 'gather)) ; We only care about GATHER (when (and (eq (car form) 'function) (eq (cadr form) 'gather)) ; Passed as functional--can't ; macroexpand (maybe-warn :user "Can't optimize GATHERING because of reference to #'GATHER." ) (return-from walk-gathering-body :abort)) form) ((setq info (assoc (setq site (if (null (cddr form)) ' *anonymous-gathering-site* (third form))) acc-info)) ; One of ours--expand (GATHER ; value var). INFO = (var ; gatheringfn freevars env) (unless (null (cdddr form)) (warn "Extra arguments (> 2) in ~S discarded." form) ) (let ((fn (second info))) (cond ((symbolp fn) ; Unoptimized case--just call ; the gatherer. FN is the ; gensym that we bound to the ; list of two values returned ; from the gatherer. `(funcall (car ,fn) ,(second form))) (t ; FN = (lambda (value) ...) (dolist (s (third info)) (unless (or (variable-same-p s env gathering-env) (and (variable-special-p s env) (variable-special-p s gathering-env))) ;; Some var used free in the LAMBDA form has been ;; rebound between here and the parent GATHERING ;; form, so can't substitute the lambda. Ok if it's ;; a special reference both here and in the LAMBDA, ;; because then it's not closed over. (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." s) (return-from walk-gathering-body :abort))) ;; Return ((lambda (value) ...) actual-value). In ;; many cases we could simplify this further by ;; substitution, but we'd have to be careful (for ;; example, we would need to alpha-convert any LET ;; we found inside). Any decent compiler will do it ;; for us. (list fn (second form)))))) ((and (setq info (member site *active-gatherers*)) (or (eq site '*anonymous-gathering-site*) (variable-same-p site env (fourth info)))) ; Some other GATHERING will ; take care of this form, so ; pass it up for now. ; Environment check is to make ; sure nobody shadowed it ; between here and there form) (t ; Nobody's going to handle it (if (eq site '*anonymous-gathering-site*) ; More likely that she forgot ; to mention the site than ; forget to write an anonymous ; gathering. (warn "There is no gathering site specified in ~S." form) (warn "The site ~S in ~S is not defined in an enclosing GATHERING form." site form)) ; Turn it into something else ; so we don't warn twice in the ; nested case `(%orphaned-gather ,@(cdr form))))) ((and (symbolp form) (setq info (assoc form acc-info)) (variable-same-p form env gathering-env)) ; A variable reference to a ; gather binding from ; environment TEM (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." form) (return-from walk-gathering-body :abort)) (t form))))))) ;; Sample gatherers (defmacro collecting (&key initial-value) `(let* ((head ,initial-value) (tail ,(and initial-value `(last head)))) (values #'(lambda (value) (if (null head) (setq head (setq tail (list value))) (setq tail (cdr (rplacd tail (list value)))))) #'(lambda nil head)))) (defmacro joining (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (setq result (nconc result value))) #'(lambda nil result)))) (defmacro maximizing (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (when ,(cond ((and (constantp initial-value) (not (null (eval initial-value)))) ; Initial value is given and we ; know it's not NIL, so leave ; out the null check '(> value result)) (t '(or (null result) (> value result)))) (setq result value))) #'(lambda nil result)))) (defmacro minimizing (&key initial-value) `(let ((result ,initial-value)) (values #'(lambda (value) (when ,(cond ((and (constantp initial-value) (not (null (eval initial-value)))) ; Initial value is given and we ; know it's not NIL, so leave ; out the null check '(< value result)) (t '(or (null result) (< value result)))) (setq result value))) #'(lambda nil result)))) (defmacro summing (&key (initial-value 0)) `(let ((sum ,initial-value)) (values #'(lambda (value) (setq sum (+ sum value))) #'(lambda nil sum)))) ; Easier to read expanded code ; if PROG1 gets left alone (define-walker-template prog1 (nil return walker::repeat (eval))) gcl/pcl/gcl_pcl_defcombin.lisp0000644000175000017500000003525112240167764015336 0ustar cammcamm;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) ;;; ;;; DEFINE-METHOD-COMBINATION ;;; (defmacro define-method-combination (&whole form &rest args) (declare (ignore args)) (if (and (cddr form) (listp (caddr form))) (expand-long-defcombin form) (expand-short-defcombin form))) ;;; ;;; STANDARD method combination ;;; ;;; The STANDARD method combination type is implemented directly by the class ;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does ;;; standard method combination directly and is defined by hand in the file ;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this ;;; file for bootstrapping reasons. ;;; ;;; A commented out copy of this definition appears in combin.lisp. ;;; If you change this definition here, be sure to change it there ;;; also. ;;; (defmethod find-method-combination ((generic-function generic-function) (type (eql 'standard)) options) (when options (method-combination-error "The method combination type STANDARD accepts no options.")) *standard-method-combination*) ;;; ;;; short method combinations ;;; ;;; Short method combinations all follow the same rule for computing the ;;; effective method. So, we just implement that rule once. Each short ;;; method combination object just reads the parameters out of the object ;;; and runs the same rule. ;;; ;;; (defclass short-method-combination (standard-method-combination) ((operator :reader short-combination-operator :initarg :operator) (identity-with-one-argument :reader short-combination-identity-with-one-argument :initarg :identity-with-one-argument)) (:predicate-name short-method-combination-p)) (defun expand-short-defcombin (whole) (let* ((type (cadr whole)) (documentation (getf (cddr whole) :documentation "")) (identity-with-one-arg (getf (cddr whole) :identity-with-one-argument nil)) (operator (getf (cddr whole) :operator type))) (make-top-level-form `(define-method-combination ,type) '(load eval) `(load-short-defcombin ',type ',operator ',identity-with-one-arg ',documentation)))) (defun load-short-defcombin (type operator ioa doc) (let* ((truename (load-truename)) (specializers (list (find-class 'generic-function) (intern-eql-specializer type) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) (new-method nil)) (setq new-method (make-instance 'standard-method :qualifiers () :specializers specializers :lambda-list '(generic-function type options) :function #'(lambda (gf type options) (declare (ignore gf)) (do-short-method-combination type options operator ioa new-method doc)) :definition-source `((define-method-combination ,type) ,truename))) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method))) (defun do-short-method-combination (type options operator ioa method doc) (cond ((null options) (setq options '(:most-specific-first))) ((equal options '(:most-specific-first))) ((equal options '(:most-specific-last))) (t (method-combination-error "Illegal options to a short method combination type.~%~ The method combination type ~S accepts one option which~%~ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." type))) (make-instance 'short-method-combination :type type :options options :operator operator :identity-with-one-argument ioa :definition-source method :documentation doc)) (defmethod compute-effective-method ((generic-function generic-function) (combin short-method-combination) applicable-methods) (let ((type (method-combination-type combin)) (operator (short-combination-operator combin)) (ioa (short-combination-identity-with-one-argument combin)) (around ()) (primary ())) (dolist (m applicable-methods) (let ((qualifiers (method-qualifiers m))) (flet ((lose (method why) (invalid-method-error method "The method ~S ~A.~%~ The method combination type ~S was defined with the~%~ short form of DEFINE-METHOD-COMBINATION and so requires~%~ all methods have either the single qualifier ~S or the~%~ single qualifier :AROUND." method why type type))) (cond ((null qualifiers) (lose m "has no qualifiers")) ((cdr qualifiers) (lose m "has more than one qualifier")) ((eq (car qualifiers) :around) (push m around)) ((eq (car qualifiers) type) (push m primary)) (t (lose m "has an illegal qualifier")))))) (setq around (nreverse around) primary (nreverse primary)) (let ((main-method (if (and (null (cdr primary)) (not (null ioa))) `(call-method ,(car primary) ()) `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) primary))))) (cond ((null primary) `(error "No ~S methods for the generic function ~S." ',type ',generic-function)) ((null around) main-method) (t `(call-method ,(car around) (,@(cdr around) (make-method ,main-method)))))))) ;;; ;;; long method combinations ;;; ;;; (defclass long-method-combination (standard-method-combination) ((function :initarg :function :reader long-method-combination-function))) (defun expand-long-defcombin (form) (let ((type (cadr form)) (lambda-list (caddr form)) (method-group-specifiers (cadddr form)) (body (cddddr form)) (arguments-option ()) (gf-var nil)) (when (and (consp (car body)) (eq (caar body) :arguments)) (setq arguments-option (cdr (pop body)))) (when (and (consp (car body)) (eq (caar body) :generic-function)) (setq gf-var (cadr (pop body)))) (multiple-value-bind (documentation function) (make-long-method-combination-function type lambda-list method-group-specifiers arguments-option gf-var body) (make-top-level-form `(define-method-combination ,type) '(load eval) `(load-long-defcombin ',type ',documentation #',function))))) (defvar *long-method-combination-functions* (make-hash-table :test #'eq)) (defun load-long-defcombin (type doc function) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) *the-class-t*)) (old-method (get-method #'find-method-combination () specializers nil)) (new-method (make-instance 'standard-method :qualifiers () :specializers specializers :lambda-list '(generic-function type options) :function #'(lambda (generic-function type options) (declare (ignore generic-function)) (make-instance 'long-method-combination :type type :documentation doc :options options)) :definition-source `((define-method-combination ,type) ,(load-truename))))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method))) (defmethod compute-effective-method ((generic-function generic-function) (combin long-method-combination) applicable-methods) (funcall (gethash (method-combination-type combin) *long-method-combination-functions*) generic-function combin applicable-methods)) ;;; ;;; ;;; (defun make-long-method-combination-function (type ll method-group-specifiers arguments-option gf-var body) ;;(declare (values documentation function)) (declare (ignore type)) (multiple-value-bind (documentation declarations real-body) (extract-declarations body) (let ((wrapped-body (wrap-method-group-specifier-bindings method-group-specifiers declarations real-body))) (when gf-var (push `(,gf-var .generic-function.) (cadr wrapped-body))) (when arguments-option (setq wrapped-body (deal-with-arguments-option wrapped-body arguments-option))) (when ll (setq wrapped-body `(apply #'(lambda ,ll ,wrapped-body) (method-combination-options .method-combination.)))) (values documentation `(lambda (.generic-function. .method-combination. .applicable-methods.) (progn .generic-function. .method-combination. .applicable-methods.) (block .long-method-combination-function. ,wrapped-body)))))) ;; ;; parse-method-group-specifiers parse the method-group-specifiers ;; (defun wrap-method-group-specifier-bindings (method-group-specifiers declarations real-body) (with-gathering ((names (collecting)) (specializer-caches (collecting)) (cond-clauses (collecting)) (required-checks (collecting)) (order-cleanups (collecting))) (dolist (method-group-specifier method-group-specifiers) (multiple-value-bind (name tests description order required) (parse-method-group-specifier method-group-specifier) (declare (ignore description)) (let ((specializer-cache (gensym))) (gather name names) (gather specializer-cache specializer-caches) (gather `((or ,@tests) (if (equal ,specializer-cache .specializers.) (return-from .long-method-combination-function. '(error "More than one method of type ~S ~ with the same specializers." ',name)) (setq ,specializer-cache .specializers.)) (push .method. ,name)) cond-clauses) (when required (gather `(when (null ,name) (return-from .long-method-combination-function. '(error "No ~S methods." ',name))) required-checks)) (loop (unless (and (constantp order) (neq order (setq order (eval order)))) (return t))) (gather (cond ((eq order :most-specific-first) `(setq ,name (nreverse ,name))) ((eq order :most-specific-last) ()) (t `(ecase ,order (:most-specific-first (setq ,name (nreverse ,name))) (:most-specific-last)))) order-cleanups)))) `(let (,@names ,@specializer-caches) ,@declarations (dolist (.method. .applicable-methods.) (let ((.qualifiers. (method-qualifiers .method.)) (.specializers. (method-specializers .method.))) (progn .qualifiers. .specializers.) (cond ,@cond-clauses))) ,@required-checks ,@order-cleanups ,@real-body))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) (let* ((name (pop method-group-specifier)) (patterns ()) (tests (gathering1 (collecting) (block collect-tests (loop (if (or (null method-group-specifier) (memq (car method-group-specifier) '(:description :order :required))) (return-from collect-tests t) (let ((pattern (pop method-group-specifier))) (push pattern patterns) (gather1 (parse-qualifier-pattern name pattern))))))))) (values name tests (getf method-group-specifier :description (make-default-method-group-description patterns)) (getf method-group-specifier :order :most-specific-first) (getf method-group-specifier :required nil)))) (defun parse-qualifier-pattern (name pattern) (cond ((eq pattern '()) `(null .qualifiers.)) ((eq pattern '*) 't) ((symbolp pattern) `(,pattern .qualifiers.)) ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) (t (error "In the method group specifier ~S,~%~ ~S isn't a valid qualifier pattern." name pattern)))) (defun qualifier-check-runtime (pattern qualifiers) (loop (cond ((and (null pattern) (null qualifiers)) (return t)) ((eq pattern '*) (return t)) ((and pattern qualifiers (eq (car pattern) (car qualifiers))) (pop pattern) (pop qualifiers)) (t (return nil))))) (defun make-default-method-group-description (patterns) (if (cdr patterns) (format nil "methods matching one of the patterns: ~{~S, ~} ~S" (butlast patterns) (car (last patterns))) (format nil "methods matching the pattern: ~S" (car patterns)))) ;;; ;;; This baby is a complete mess. I can't believe we put it in this ;;; way. No doubt this is a large part of what drives MLY crazy. ;;; ;;; At runtime (when the effective-method is run), we bind an intercept ;;; lambda-list to the arguments to the generic function. ;;; ;;; At compute-effective-method time, the symbols in the :arguments ;;; option are bound to the symbols in the intercept lambda list. ;;; (defun deal-with-arguments-option (wrapped-body arguments-option) (let* ((intercept-lambda-list (gathering1 (collecting) (dolist (arg arguments-option) (if (memq arg lambda-list-keywords) (gather1 arg) (gather1 (gensym)))))) (intercept-rebindings (gathering1 (collecting) (iterate ((arg (list-elements arguments-option)) (int (list-elements intercept-lambda-list))) (unless (memq arg lambda-list-keywords) (gather1 `(,arg ',int))))))) ;; ;; (setf (cadr wrapped-body) (append intercept-rebindings (cadr wrapped-body))) ;; ;; Be sure to fill out the intercept lambda list so that it can ;; be too short if it wants to. ;; (cond ((memq '&rest intercept-lambda-list)) ((memq '&allow-other-keys intercept-lambda-list)) ((memq '&key intercept-lambda-list) (setq intercept-lambda-list (append intercept-lambda-list '(&allow-other-keys)))) (t (setq intercept-lambda-list (append intercept-lambda-list '(&rest .ignore.))))) `(let ((inner-result. ,wrapped-body)) `(apply #'(lambda ,',intercept-lambda-list ,,(when (memq '.ignore. intercept-lambda-list) ''(declare (ignore .ignore.))) ,inner-result.) .combined-method-args.)))) gcl/pcl/gcl_pcl_defs.lisp0000644000175000017500000007527312240167764014341 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) (eval-when (compile load eval) (defvar *defclass-times* '(load eval)) ;Probably have to change this ;if you use defconstructor. (defvar *defmethod-times* '(load eval)) (defvar *defgeneric-times* '(load eval)) ; defvar is now actually in macros ;(defvar *boot-state* ()) ;NIL ;EARLY ;BRAID ;COMPLETE (defvar *fegf-started-p* nil) ) (eval-when (load eval) (when (eq *boot-state* 'complete) (error "Trying to load (or compile) PCL in an environment in which it~%~ has already been loaded. This doesn't work, you will have to~%~ get a fresh lisp (reboot) and then load PCL.")) (when *boot-state* (cerror "Try loading (or compiling) PCL anyways." "Trying to load (or compile) PCL in an environment in which it~%~ has already been partially loaded. This may not work, you may~%~ need to get a fresh lisp (reboot) and then load PCL.")) ) ;;; ;;; This is like fdefinition on the Lispm. If Common Lisp had something like ;;; function specs I wouldn't need this. On the other hand, I don't like the ;;; way this really works so maybe function specs aren't really right either? ;;; ;;; I also don't understand the real implications of a Lisp-1 on this sort of ;;; thing. Certainly some of the lossage in all of this is because these ;;; SPECs name global definitions. ;;; ;;; Note that this implementation is set up so that an implementation which ;;; has a 'real' function spec mechanism can use that instead and in that way ;;; get rid of setf generic function names. ;;; (defmacro parse-gspec (spec (non-setf-var . non-setf-case) (setf-var . setf-case)) (declare (indentation 1 1)) #+setf (declare (ignore setf-var setf-case)) (once-only (spec) `(cond (#-setf (symbolp ,spec) #+setf t (let ((,non-setf-var ,spec)) ,@non-setf-case)) #-setf ((and (listp ,spec) (eq (car ,spec) 'setf) (symbolp (cadr ,spec))) (let ((,setf-var (cadr ,spec))) ,@setf-case)) #-setf (t (error "Can't understand ~S as a generic function specifier.~%~ It must be either a symbol which can name a function or~%~ a list like ~S, where the car is the symbol ~S and the cadr~%~ is a symbol which can name a generic function." ,spec '(setf ) 'setf))))) ;;; ;;; If symbol names a function which is traced or advised, return the ;;; unadvised, traced etc. definition. This lets me get at the generic ;;; function object even when it is traced. ;;; (defun unencapsulated-fdefinition (symbol) #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol)) #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol)) #+excl (or (excl::encapsulated-basic-definition symbol) (symbol-function symbol)) #+xerox (il:virginfn symbol) #+setf (fdefinition symbol) #+kcl (symbol-function (let ((sym (get symbol 'si::traced)) first-form) (if (and sym (consp (symbol-function symbol)) (consp (setq first-form (nth 3 (symbol-function symbol)))) (eq (car first-form) 'si::trace-call)) sym symbol))) #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol)) ;;; ;;; If symbol names a function which is traced or advised, redefine ;;; the `real' definition without affecting the advise. ;;; (defun fdefine-carefully (name new-definition) #+Lispm (si:fdefine name new-definition t t) #+Lucid (let ((lucid::*redefinition-action* nil)) (setf (symbol-function name) new-definition)) #+excl (setf (symbol-function name) new-definition) #+xerox (let ((advisedp (member name il:advisedfns :test #'eq)) (brokenp (member name il:brokenfns :test #'eq))) ;; In XeroxLisp (late of envos) tracing is implemented ;; as a special case of "breaking". Advising, however, ;; is treated specially. (xcl:unadvise-function name :no-error t) (xcl:unbreak-function name :no-error t) (setf (symbol-function name) new-definition) (when brokenp (xcl:rebreak-function name)) (when advisedp (xcl:readvise-function name))) #+(and setf (not cmu)) (setf (fdefinition name) new-definition) #+kcl (setf (symbol-function (let ((sym (get name 'si::traced)) first-form) (if (and sym (consp (symbol-function name)) (consp (setq first-form (nth 3 (symbol-function name)))) (eq (car first-form) 'si::trace-call)) sym name))) new-definition) #+cmu (progn (c::%%defun name new-definition nil) (c::note-name-defined name :function) new-definition) #-(or Lispm Lucid excl Xerox setf kcl cmu) (setf (symbol-function name) new-definition)) (defun gboundp (spec) (parse-gspec spec (name (fboundp name)) (name (fboundp (get-setf-function-name name))))) (defun gmakunbound (spec) (parse-gspec spec (name (fmakunbound name)) (name (fmakunbound (get-setf-function-name name))))) (defun gdefinition (spec) (parse-gspec spec (name (or #-setf (macro-function name) ;?? (unencapsulated-fdefinition name))) (name (unencapsulated-fdefinition (get-setf-function-name name))))) (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec) (parse-gspec spec (name (fdefine-carefully name new-value)) (name (fdefine-carefully (get-setf-function-name name) new-value)))) (proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* *the-class-null* *the-class-list* *the-class-integer* *the-class-float* *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* *the-class-array* *the-class-slot-object* *the-class-standard-object* *the-class-structure-object* *the-class-class* *the-class-generic-function* *the-class-built-in-class* *the-class-slot-class* *the-class-structure-class* *the-class-standard-class* *the-class-funcallable-standard-class* *the-class-method* *the-class-standard-method* *the-class-standard-reader-method* *the-class-standard-writer-method* *the-class-standard-boundp-method* *the-class-standard-generic-function* *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots* *the-eslotd-funcallable-standard-class-slots*)) (proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) ;;;; Type specifier hackery: ;;; internal to this file. (defun coerce-to-class (class &optional make-forward-referenced-class-p) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) (ensure-class class)) class)) ;;; Interface (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) (cond ((symbolp type) (or (and (null args) (find-class type)) (ecase type (class (coerce-to-class (car args))) (prototype (make-instance 'class-prototype-specializer :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) #+cmu17 ((and (null args) (typep type 'lisp:class)) (or (kernel:class-pcl-class type) (find-structure-class (lisp:class-name type)))) ((specializerp type) type))) ;;; interface (defun type-from-specializer (specl) (cond ((eq specl 't) 't) ((consp specl) (unless (member (car specl) '(class prototype class-eq eql)) (error "~S is not a legal specializer type" specl)) specl) ((progn (when (symbolp specl) ;;maybe (or (find-class specl nil) (ensure-class specl)) instead? (setq specl (find-class specl))) (or (not (eq *boot-state* 'complete)) (specializerp specl))) (specializer-type specl)) (t (error "~s is neither a type nor a specializer" specl)))) (defun type-class (type) (declare (special *the-class-t*)) (setq type (type-from-specializer type)) (if (atom type) (if (eq type 't) *the-class-t* (error "bad argument to type-class")) (case (car type) (eql (class-of (cadr type))) (prototype (class-of (cadr type))) ;? (class-eq (cadr type)) (class (cadr type))))) (defun class-eq-type (class) (specializer-type (class-eq-specializer class))) (defun inform-type-system-about-std-class (name) (let ((predicate-name (make-type-predicate-name name))) (setf (gdefinition predicate-name) (make-type-predicate name)) (do-satisfies-deftype name predicate-name))) (defun make-type-predicate (name) (let ((cell (find-class-cell name))) #'(lambda (x) (funcall (the function (find-class-cell-predicate cell)) x)))) ;This stuff isn't right. Good thing it isn't used. ;The satisfies predicate has to be a symbol. There is no way to ;construct such a symbol from a class object if class names change. (defun class-predicate (class) (when (symbolp class) (setq class (find-class class))) #'(lambda (object) (memq class (class-precedence-list (class-of object))))) (defun make-class-eq-predicate (class) (when (symbolp class) (setq class (find-class class))) #'(lambda (object) (eq class (class-of object)))) (defun make-eql-predicate (eql-object) #'(lambda (object) (eql eql-object object))) #|| ; The argument to satisfies must be a symbol. (deftype class (&optional class) (if class `(satisfies ,(class-predicate class)) `(satisfies ,(class-predicate 'class)))) (deftype class-eq (class) `(satisfies ,(make-class-eq-predicate class))) ||# #-(or excl cmu17) (deftype eql (type-object) `(member ,type-object)) ;;; Internal to this file. ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. ;;; (defun *normalize-type (type) (cond ((consp type) (if (member (car type) '(not and or)) `(,(car type) ,@(mapcar #'*normalize-type (cdr type))) (if (null (cdr type)) (*normalize-type (car type)) type))) ((symbolp type) (let ((class (find-class type nil))) (if class (let ((type (specializer-type class))) (if (listp type) type `(,type))) `(,type)))) ((or (not (eq *boot-state* 'complete)) (specializerp type)) (specializer-type type)) (t (error "~s is not a type" type)))) ;;; Not used... #+nil (defun unparse-type-list (tlist) (mapcar #'unparse-type tlist)) ;;; Not used... #+nil (defun unparse-type (type) (if (atom type) (if (specializerp type) (unparse-type (specializer-type type)) type) (case (car type) (eql type) (class-eq `(class-eq ,(class-name (cadr type)))) (class (class-name (cadr type))) (t `(,(car type) ,@(unparse-type-list (cdr type))))))) ;;; internal to this file... (defun convert-to-system-type (type) (case (car type) ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) ((class class-eq) ; class-eq is impossible to do right #-cmu17 (class-name (cadr type)) #+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) type)))) ;;; not used... #+nil (defun *typep (object type) (setq type (*normalize-type type)) (cond ((member (car type) '(eql wrapper-eq class-eq class)) (specializer-applicable-using-type-p type `(eql ,object))) ((eq (car type) 'not) (not (*typep object (cadr type)))) (t (typep object (convert-to-system-type type))))) ;;; *SUBTYPEP -- Interface ;;; ;Writing the missing NOT and AND clauses will improve ;the quality of code generated by generate-discrimination-net, but ;calling subtypep in place of just returning (values nil nil) can be ;very slow. *subtypep is used by PCL itself, and must be fast. (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) (if (eq *boot-state* 'early) (values (eq type1 type2) t) (let ((*in-precompute-effective-methods-p* t)) (declare (special *in-precompute-effective-methods-p*)) ;; *in-precompute-effective-methods-p* is not a good name. ;; It changes the way class-applicable-using-class-p works. (setq type1 (*normalize-type type1)) (setq type2 (*normalize-type type2)) (case (car type2) (not (values nil nil)) ; Should improve this. (and (values nil nil)) ; Should improve this. ((eql wrapper-eq class-eq class) (multiple-value-bind (app-p maybe-app-p) (specializer-applicable-using-type-p type2 type1) (values app-p (or app-p (not maybe-app-p))))) (t (subtypep (convert-to-system-type type1) (convert-to-system-type type2)))))))) (defun do-satisfies-deftype (name predicate) #+cmu17 (declare (ignore name predicate)) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) (let* ((specifier `(satisfies ,predicate)) (expand-fn #'(lambda (&rest ignore) (declare (ignore ignore)) specifier))) ;; Specific ports can insert their own way of doing this. Many ;; ports may find the expand-fn defined above useful. ;; (or #+:Genera (setf (get name 'deftype) expand-fn) #+(and :Lucid (not :Prime)) (system::define-macro `(deftype ,name) expand-fn nil) #+ExCL (setf (get name 'excl::deftype-expander) expand-fn) #+:coral (setf (get name 'ccl::deftype-expander) expand-fn))) #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) ;; This is the default for ports for which we don't know any ;; better. Note that for most ports, providing this definition ;; should just speed up class definition. It shouldn't have an ;; effect on performance of most user code. (eval `(deftype ,name () '(satisfies ,predicate)))) (defun make-type-predicate-name (name &optional kind) (if (symbol-package name) (intern (format nil "~@[~A ~]TYPE-PREDICATE ~A ~A" kind (package-name (symbol-package name)) (symbol-name name)) *the-pcl-package*) (make-symbol (format nil "~@[~A ~]TYPE-PREDICATE ~A" kind (symbol-name name))))) (defvar *built-in-class-symbols* ()) (defvar *built-in-wrapper-symbols* ()) (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name)) *the-pcl-package*))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) (pushnew 'class *variable-declarations*) (pushnew 'variable-rebinding *variable-declarations*) (defun variable-class (var env) (caddr (variable-declaration 'class var env))) (defvar *name->class->slotd-table* (make-hash-table)) ;;; ;;; This is used by combined methods to communicate the next methods to ;;; the methods they call. This variable is captured by a lexical variable ;;; of the methods to give it the proper lexical scope. ;;; (defvar *next-methods* nil) (defvar *not-an-eql-specializer* '(not-an-eql-specializer)) (defvar *umi-gfs*) (defvar *umi-complete-classes*) (defvar *umi-reorder*) (defvar *invalidate-discriminating-function-force-p* ()) (defvar *invalid-dfuns-on-stack* ()) (defvar *standard-method-combination*) (defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;*** (defmacro define-gf-predicate (predicate-name &rest classes) `(progn (defmethod ,predicate-name ((x t)) nil) ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t)) classes))) (defun make-class-predicate-name (name) (intern (format nil "~A::~A class predicate" (package-name (symbol-package name)) name) *the-pcl-package*)) (defun plist-value (object name) (getf (object-plist object) name)) (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name) (if new-value (setf (getf (object-plist object) name) new-value) (progn (remf (object-plist object) name) nil))) (defvar *built-in-classes* ;; ;; name supers subs cdr of cpl ;; prototype '(;(t () (number sequence array character symbol) ()) (number (t) (complex float rational) (t)) (complex (number) () (number t) #c(1 1)) (float (number) () (number t) 1.0) (rational (number) (integer ratio) (number t)) (integer (rational) () (rational number t) 1) (ratio (rational) () (rational number t) 1/2) (sequence (t) (list vector) (t)) (list (sequence) (cons null) (sequence t)) (cons (list) () (list sequence t) (nil)) (array (t) (vector) (t) #2A((NIL))) (vector (array sequence) (string bit-vector) (array sequence t) #()) (string (vector) () (vector array sequence t) "") (bit-vector (vector) () (vector array sequence t) #*1) (character (t) () (t) #\c) (symbol (t) (null) (t) symbol) (null (symbol list) () (symbol list sequence t) nil))) #+cmu17 (labels ((direct-supers (class) (if (typep class 'lisp:built-in-class) (kernel:built-in-class-direct-superclasses class) (let ((inherits (kernel:layout-inherits (kernel:class-layout class)))) (list (svref inherits (1- (length inherits))))))) (direct-subs (class) (ext:collect ((res)) (let ((subs (kernel:class-subclasses class))) (when subs (ext:do-hash (sub v subs) (declare (ignore v)) (when (member class (direct-supers sub)) (res sub))))) (res)))) (ext:collect ((res)) (dolist (bic kernel::built-in-classes) (let* ((name (car bic)) (class (lisp:find-class name))) (unless (member name '(t kernel:instance kernel:funcallable-instance function)) (res `(,name ,(mapcar #'lisp:class-name (direct-supers class)) ,(mapcar #'lisp:class-name (direct-subs class)) ,(map 'list #'(lambda (x) (lisp:class-name (kernel:layout-class x))) (reverse (kernel:layout-inherits (kernel:class-layout class)))) ,(let ((found (assoc name *built-in-classes*))) (if found (fifth found) 42))))))) (setq *built-in-classes* (res)))) ;;; ;;; The classes that define the kernel of the metabraid. ;;; (defclass t () () (:metaclass built-in-class)) #+cmu17 (progn (defclass kernel:instance (t) () (:metaclass built-in-class)) (defclass function (t) () (:metaclass built-in-class)) (defclass kernel:funcallable-instance (function) () (:metaclass built-in-class))) (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () (:metaclass slot-class)) (defclass structure-object (slot-object) () (:metaclass structure-class)) (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object (:constructor |STRUCTURE-OBJECT class constructor|))) (defclass standard-object (slot-object) ()) (defclass metaobject (standard-object) ()) (defclass specializer (metaobject) ((type :initform nil :reader specializer-type))) (defclass definition-source-mixin (standard-object) ((source :initform (load-truename) :reader definition-source :initarg :definition-source))) (defclass plist-mixin (standard-object) ((plist :initform () :accessor object-plist))) (defclass documentation-mixin (plist-mixin) ()) (defclass dependent-update-mixin (plist-mixin) ()) ;;; ;;; The class CLASS is a specified basic class. It is the common superclass ;;; of any kind of class. That is any class that can be a metaclass must ;;; have the class CLASS in its class precedence list. ;;; (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer) ((name :initform nil :initarg :name :accessor class-name) (class-eq-specializer :initform nil :reader class-eq-specializer) (direct-superclasses :initform () :reader class-direct-superclasses) (direct-subclasses :initform () :reader class-direct-subclasses) (direct-methods :initform (cons nil nil)) (predicate-name :initform nil :reader class-predicate-name))) ;;; ;;; The class PCL-CLASS is an implementation-specific common superclass of ;;; all specified subclasses of the class CLASS. ;;; (defclass pcl-class (class) ((class-precedence-list :reader class-precedence-list) (can-precede-list :initform () :reader class-can-precede-list) (incompatible-superclass-list :initform () :accessor class-incompatible-superclass-list) (wrapper :initform nil :reader class-wrapper) (prototype :initform nil :reader class-prototype))) (defclass slot-class (pcl-class) ((direct-slots :initform () :accessor class-direct-slots) (slots :initform () :accessor class-slots) (initialize-info :initform nil :accessor class-initialize-info))) ;;; ;;; The class STD-CLASS is an implementation-specific common superclass of ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. ;;; (defclass std-class (slot-class) ()) (defclass standard-class (std-class) ()) (defclass funcallable-standard-class (std-class) ()) (defclass forward-referenced-class (pcl-class) ()) (defclass built-in-class (pcl-class) ()) (defclass structure-class (slot-class) ((defstruct-form :initform () :accessor class-defstruct-form) (defstruct-constructor :initform nil :accessor class-defstruct-constructor) (from-defclass-p :initform nil :initarg :from-defclass-p))) (defclass specializer-with-object (specializer) ()) (defclass exact-class-specializer (specializer) ()) (defclass class-eq-specializer (exact-class-specializer specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass class-prototype-specializer (specializer-with-object) ((object :initarg :class :reader specializer-class :reader specializer-object))) (defclass eql-specializer (exact-class-specializer specializer-with-object) ((object :initarg :object :reader specializer-object :reader eql-specializer-object))) (defvar *eql-specializer-table* (make-hash-table :test 'eql)) (defun intern-eql-specializer (object) (or (gethash object *eql-specializer-table*) (setf (gethash object *eql-specializer-table*) (make-instance 'eql-specializer :object object)))) ;;; ;;; Slot definitions. ;;; (defclass slot-definition (metaobject) ((name :initform nil :initarg :name :accessor slot-definition-name) (initform :initform nil :initarg :initform :accessor slot-definition-initform) (initfunction :initform nil :initarg :initfunction :accessor slot-definition-initfunction) (readers :initform nil :initarg :readers :accessor slot-definition-readers) (writers :initform nil :initarg :writers :accessor slot-definition-writers) (initargs :initform nil :initarg :initargs :accessor slot-definition-initargs) (type :initform t :initarg :type :accessor slot-definition-type) (documentation :initform "" :initarg :documentation) (class :initform nil :initarg :class :accessor slot-definition-class))) (defclass standard-slot-definition (slot-definition) ((allocation :initform :instance :initarg :allocation :accessor slot-definition-allocation))) (defclass structure-slot-definition (slot-definition) ((defstruct-accessor-symbol :initform nil :initarg :defstruct-accessor-symbol :accessor slot-definition-defstruct-accessor-symbol) (internal-reader-function :initform nil :initarg :internal-reader-function :accessor slot-definition-internal-reader-function) (internal-writer-function :initform nil :initarg :internal-writer-function :accessor slot-definition-internal-writer-function))) (defclass direct-slot-definition (slot-definition) ()) (defclass effective-slot-definition (slot-definition) ((reader-function ; #'(lambda (object) ...) :accessor slot-definition-reader-function) (writer-function ; #'(lambda (new-value object) ...) :accessor slot-definition-writer-function) (boundp-function ; #'(lambda (object) ...) :accessor slot-definition-boundp-function) (accessor-flags :initform 0))) (defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) ()) (defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) ((location ; nil, a fixnum, a cons: (slot-name . value) :initform nil :accessor slot-definition-location))) (defclass structure-direct-slot-definition (structure-slot-definition direct-slot-definition) ()) (defclass structure-effective-slot-definition (structure-slot-definition effective-slot-definition) ()) (defclass method (metaobject) ()) (defclass standard-method (definition-source-mixin plist-mixin method) ((generic-function :initform nil :accessor method-generic-function) ; (qualifiers ; :initform () ; :initarg :qualifiers ; :reader method-qualifiers) (specializers :initform () :initarg :specializers :reader method-specializers) (lambda-list :initform () :initarg :lambda-list :reader method-lambda-list) (function :initform nil :initarg :function) ;no writer (fast-function :initform nil :initarg :fast-function ;no writer :reader method-fast-function) ; (documentation ; :initform nil ; :initarg :documentation ; :reader method-documentation) )) (defclass standard-accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name :reader accessor-method-slot-name) (slot-definition :initform nil :initarg :slot-definition :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) (defclass standard-boundp-method (standard-accessor-method) ()) (defclass generic-function (dependent-update-mixin definition-source-mixin documentation-mixin metaobject #+cmu17 kernel:funcallable-instance) () (:metaclass funcallable-standard-class)) (defclass standard-generic-function (generic-function) ((name :initform nil :initarg :name :accessor generic-function-name) (methods :initform () :accessor generic-function-methods) (method-class :initarg :method-class :accessor generic-function-method-class) (method-combination :initarg :method-combination :accessor generic-function-method-combination) (arg-info :initform (make-arg-info) :reader gf-arg-info) (dfun-state :initform () :accessor gf-dfun-state) (pretty-arglist :initform () :accessor gf-pretty-arglist) ) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) (defclass method-combination (metaobject) ()) (defclass standard-method-combination (definition-source-mixin method-combination) ((type :reader method-combination-type :initarg :type) (documentation :reader method-combination-documentation :initarg :documentation) (options :reader method-combination-options :initarg :options))) (defparameter *early-class-predicates* '((specializer specializerp) (exact-class-specializer exact-class-specializer-p) (class-eq-specializer class-eq-specializer-p) (eql-specializer eql-specializer-p) (class classp) (slot-class slot-class-p) (standard-class standard-class-p) (funcallable-standard-class funcallable-standard-class-p) (structure-class structure-class-p) (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) (standard-accessor-method standard-accessor-method-p) (standard-reader-method standard-reader-method-p) (standard-writer-method standard-writer-method-p) (standard-boundp-method standard-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p))) gcl/pcl/gcl_pcl_fast_init.lisp0000644000175000017500000011562212240167764015371 0ustar cammcamm;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; ;;; ;;; This file defines the optimized make-instance functions. ;;; (in-package :pcl) (defvar *compile-make-instance-functions-p* nil) (defun update-make-instance-function-table (&optional (class *the-class-t*)) (when (symbolp class) (setq class (find-class class))) (when (eq class *the-class-t*) (setq class *the-class-slot-object*)) (when (memq *the-class-slot-object* (class-precedence-list class)) (map-all-classes #'reset-class-initialize-info class))) (defun constant-symbol-p (form) (and (constantp form) (let ((object (eval form))) (and (symbolp object) (symbol-package object))))) (defvar *make-instance-function-keys* nil) (defun expand-make-instance-form (form) (let ((class (cadr form)) (initargs (cddr form)) (keys nil)(allow-other-keys-p nil) key value) (when (and (constant-symbol-p class) (let ((initargs-tail initargs)) (loop (when (null initargs-tail) (return t)) (unless (constant-symbol-p (car initargs-tail)) (return nil)) (setq key (eval (pop initargs-tail))) (setq value (pop initargs-tail)) (when (eq ':allow-other-keys key) (setq allow-other-keys-p value)) (push key keys)))) (let* ((class (eval class)) (keys (nreverse keys)) (key (list class keys allow-other-keys-p)) (sym (make-instance-function-symbol key))) (push key *make-instance-function-keys*) (when sym `(,sym ',class ,@initargs)))))) (defmacro expanding-make-instance-top-level (&rest forms &environment env) (let* ((*make-instance-function-keys* nil) (form (macroexpand `(expanding-make-instance ,@forms) env))) `(progn ,@(when *make-instance-function-keys* `((get-make-instance-functions ',*make-instance-function-keys*))) ,form))) (defmacro expanding-make-instance (&rest forms &environment env) `(progn ,@(mapcar #'(lambda (form) (walk-form form env #'(lambda (subform context env) (declare (ignore env)) (or (and (eq context ':eval) (consp subform) (eq (car subform) 'make-instance) (expand-make-instance-form subform)) subform)))) forms))) (defmacro defconstructor (name class lambda-list &rest initialization-arguments) `(expanding-make-instance-top-level (defun ,name ,lambda-list (make-instance ',class ,@initialization-arguments)))) (defun get-make-instance-functions (key-list) (dolist (key key-list) (let* ((cell (find-class-cell (car key))) (make-instance-function-keys (find-class-cell-make-instance-function-keys cell)) (mif-key (cons (cadr key) (caddr key)))) (unless (find mif-key make-instance-function-keys :test #'equal) (push mif-key (find-class-cell-make-instance-function-keys cell)) (let ((class (find-class-cell-class cell))) (when (and class (not (forward-referenced-class-p class))) (update-initialize-info-internal (initialize-info class (car mif-key) nil (cdr mif-key)) 'make-instance-function))))))) (defun make-instance-function-symbol (key) (let* ((class (car key)) (symbolp (symbolp class))) (when (or symbolp (classp class)) (let* ((class-name (if (symbolp class) class (class-name class))) (keys (cadr key)) (allow-other-keys-p (caddr key))) (when (and (or symbolp (and (symbolp class-name) (eq class (find-class class-name nil)))) (symbol-package class-name)) (let ((*package* *the-pcl-package*) (*print-length* nil) (*print-level* nil) (*print-circle* nil) (*print-case* :upcase) (*print-pretty* nil)) (intern (format nil "MAKE-INSTANCE ~S ~S ~S" class-name keys allow-other-keys-p)))))))) (defun make-instance-1 (class &rest initargs) (apply #'make-instance class initargs)) (defmacro define-cached-reader (type name trap) (let ((reader-name (intern (format nil "~A-~A" type name))) (cached-name (intern (format nil "~A-CACHED-~A" type name)))) `(defmacro ,reader-name (info) `(let ((value (,',cached-name ,info))) (if (eq value ':unknown) (progn (,',trap ,info ',',name) (,',cached-name ,info)) value))))) (eval-when (compile load eval) (defparameter initialize-info-cached-slots '(valid-p ; t or (:invalid key) ri-valid-p initargs-form-list combined-initargs-form-list new-keys default-initargs-function shared-initialize-t-function shared-initialize-nil-function constants combined-initialize-function ; allocate-instance + shared-initialize make-instance-function ; nil means use gf make-instance-function-symbol))) (defmacro define-initialize-info () (let ((cached-slot-names (mapcar #'(lambda (name) (intern (format nil "CACHED-~A" name))) initialize-info-cached-slots)) (cached-names (mapcar #'(lambda (name) (intern (format nil "~A-CACHED-~A" 'initialize-info name))) initialize-info-cached-slots))) `(progn (defstruct initialize-info key wrapper ,@(mapcar #'(lambda (name) `(,name :unknown)) cached-slot-names)) (defmacro reset-initialize-info-internal (info) `(progn ,@(mapcar #'(lambda (cname) `(setf (,cname ,info) ':unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) ,@(mapcar #'(lambda (name cached-name) `(unless (eq ':unknown (,cached-name info)) (push ',name slots))) initialize-info-cached-slots cached-names) slots)) ,@(mapcar #'(lambda (name) `(define-cached-reader initialize-info ,name update-initialize-info-internal)) initialize-info-cached-slots)))) (define-initialize-info) (defvar *initialize-info-cache-class* nil) (defvar *initialize-info-cache-initargs* nil) (defvar *initialize-info-cache-info* nil) (defvar *revert-initialize-info-p* nil) (defun reset-initialize-info (info) (setf (initialize-info-wrapper info) (class-wrapper (car (initialize-info-key info)))) (let ((slots-to-revert (if *revert-initialize-info-p* (initialize-info-bound-slots info) '(make-instance-function)))) (reset-initialize-info-internal info) (dolist (slot slots-to-revert) (update-initialize-info-internal info slot)) info)) (defun reset-class-initialize-info (class) (reset-class-initialize-info-1 (class-initialize-info class))) (defun reset-class-initialize-info-1 (cell) (when (consp cell) (when (car cell) (reset-initialize-info (car cell))) (let ((alist (cdr cell))) (dolist (a alist) (reset-class-initialize-info-1 (cdr a)))))) (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) (let ((info nil)) (if (and (eq *initialize-info-cache-class* class) (eq *initialize-info-cache-initargs* initargs)) (setq info *initialize-info-cache-info*) (let ((initargs-tail initargs) (cell (or (class-initialize-info class) (setf (class-initialize-info class) (cons nil nil))))) (loop (when (null initargs-tail) (return nil)) (let ((keyword (pop initargs-tail)) (alist-cell cell)) (when plist-p (if (eq keyword :allow-other-keys) (setq allow-other-keys-arg (pop initargs-tail)) (pop initargs-tail))) (loop (let ((alist (cdr alist-cell))) (when (null alist) (setq cell (cons nil nil)) (setf (cdr alist-cell) (list (cons keyword cell))) (return nil)) (when (eql keyword (caar alist)) (setq cell (cdar alist)) (return nil)) (setq alist-cell alist))))) (setq info (or (car cell) (setf (car cell) (make-initialize-info)))))) (let ((wrapper (initialize-info-wrapper info))) (unless (eq wrapper (class-wrapper class)) (unless wrapper (let* ((initargs-tail initargs) (klist-cell (list nil)) (klist-tail klist-cell)) (loop (when (null initargs-tail) (return nil)) (let ((key (pop initargs-tail))) (setf (cdr klist-tail) (list key))) (setf klist-tail (cdr klist-tail)) (when plist-p (pop initargs-tail))) (setf (initialize-info-key info) (list class (cdr klist-cell) allow-other-keys-arg)))) (reset-initialize-info info))) (setq *initialize-info-cache-class* class) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* info) info)) (defun update-initialize-info-internal (info name) (let* ((key (initialize-info-key info)) (class (car key)) (keys (cadr key)) (allow-other-keys-arg (caddr key))) (ecase name ((initargs-form-list new-keys) (multiple-value-bind (initargs-form-list new-keys) (make-default-initargs-form-list class keys) (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) (setf (initialize-info-cached-new-keys info) new-keys))) ((combined-initargs-form-list) (multiple-value-bind (initargs-form-list new-keys) (make-default-initargs-form-list class keys nil) (setf (initialize-info-cached-combined-initargs-form-list info) initargs-form-list) (setf (initialize-info-cached-new-keys info) new-keys))) ((default-initargs-function) (let ((initargs-form-list (initialize-info-initargs-form-list info))) (setf (initialize-info-cached-default-initargs-function info) (initialize-instance-simple-function 'default-initargs-function info class initargs-form-list)))) ((valid-p ri-valid-p) (flet ((compute-valid-p (methods) (or (not (null allow-other-keys-arg)) (multiple-value-bind (legal allow-other-keys) (check-initargs-values class methods) (or (not (null allow-other-keys)) (dolist (key keys t) (unless (member key legal) (return (cons :invalid key))))))))) (let ((proto (class-prototype class))) (setf (initialize-info-cached-valid-p info) (compute-valid-p (list (list* 'allocate-instance class nil) (list* 'initialize-instance proto nil) (list* 'shared-initialize proto t nil)))) (setf (initialize-info-cached-ri-valid-p info) (compute-valid-p (list (list* 'reinitialize-instance proto nil) (list* 'shared-initialize proto nil nil))))))) ((shared-initialize-t-function) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys t nil) (declare (ignore ignore)) (setf (initialize-info-cached-shared-initialize-t-function info) (initialize-instance-simple-function 'shared-initialize-t-function info class initialize-form-list)))) ((shared-initialize-nil-function) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys nil nil) (declare (ignore ignore)) (setf (initialize-info-cached-shared-initialize-nil-function info) (initialize-instance-simple-function 'shared-initialize-nil-function info class initialize-form-list)))) ((constants combined-initialize-function) (let ((initargs-form-list (initialize-info-combined-initargs-form-list info)) (new-keys (initialize-info-new-keys info))) (multiple-value-bind (initialize-form-list constants) (make-shared-initialize-form-list class new-keys t t) (setf (initialize-info-cached-constants info) constants) (setf (initialize-info-cached-combined-initialize-function info) (initialize-instance-simple-function 'combined-initialize-function info class (append initargs-form-list initialize-form-list)))))) ((make-instance-function-symbol) (setf (initialize-info-cached-make-instance-function-symbol info) (make-instance-function-symbol key))) ((make-instance-function) (let* ((function (get-make-instance-function key)) (symbol (initialize-info-make-instance-function-symbol info))) (setf (initialize-info-cached-make-instance-function info) function) (when symbol (setf (gdefinition symbol) (or function #'make-instance-1))))))) info) (defun get-make-instance-function (key) (let* ((class (car key)) (keys (cadr key))) (unless (eq *boot-state* 'complete) (return-from get-make-instance-function nil)) (when (symbolp class) (setq class (find-class class))) (when (classp class) (unless (class-finalized-p class) (finalize-inheritance class))) (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) (class-and-initargs (list* class initargs)) (make-instance (gdefinition 'make-instance)) (make-instance-methods (compute-applicable-methods make-instance class-and-initargs)) (std-mi-meth (find-standard-ii-method make-instance-methods 'class)) (class+initargs (list class initargs)) (default-initargs (gdefinition 'default-initargs)) (default-initargs-methods (compute-applicable-methods default-initargs class+initargs)) (proto (and (classp class) (class-prototype class))) (initialize-instance-methods (when proto (compute-applicable-methods (gdefinition 'initialize-instance) (list* proto initargs)))) (shared-initialize-methods (when proto (compute-applicable-methods (gdefinition 'shared-initialize) (list* proto t initargs))))) (when (null make-instance-methods) (return-from get-make-instance-function #'(lambda (class &rest initargs) (apply #'no-applicable-method make-instance class initargs)))) (unless (and (null (cdr make-instance-methods)) (eq (car make-instance-methods) std-mi-meth) (null (cdr default-initargs-methods)) (eq (car (method-specializers (car default-initargs-methods))) *the-class-slot-class*) (flet ((check-meth (meth) (let ((quals (method-qualifiers meth))) (if (null quals) (eq (car (method-specializers meth)) *the-class-slot-object*) (and (null (cdr quals)) (or (eq (car quals) ':before) (eq (car quals) ':after))))))) (and (every #'check-meth initialize-instance-methods) (every #'check-meth shared-initialize-methods)))) (return-from get-make-instance-function nil)) (get-make-instance-function-internal class key (default-initargs class initargs) initialize-instance-methods shared-initialize-methods)))) (defun get-make-instance-function-internal (class key initargs initialize-instance-methods shared-initialize-methods) (let* (#|(class-key (car key))|# (keys (cadr key)) (allow-other-keys-p (caddr key)) (allocate-instance-methods (compute-applicable-methods (gdefinition 'allocate-instance) (list* class initargs)))) (unless allow-other-keys-p (unless (check-initargs-1 class initargs (append allocate-instance-methods initialize-instance-methods shared-initialize-methods) t nil) (return-from get-make-instance-function-internal nil))) (cond ((or (cdr allocate-instance-methods) (some #'complicated-instance-creation-method initialize-instance-methods) (some #'complicated-instance-creation-method shared-initialize-methods)) (make-instance-function-complex key class keys initialize-instance-methods shared-initialize-methods)) (t #|(or (not (standard-class-p class)) (not (symbolp class-key)) initialize-instance-methods shared-initialize-methods)|# (make-instance-function-simple key class keys initialize-instance-methods shared-initialize-methods)) #|(t (make-instance-function-basic key class keys))|#))) (defun complicated-instance-creation-method (m) (let ((qual (method-qualifiers m))) (if qual (not (and (null (cdr qual)) (eq (car qual) ':after))) (let ((specl (car (method-specializers m)))) (or (not (classp specl)) (not (eq 'slot-object (class-name specl)))))))) (defun find-standard-ii-method (methods class-names) (dolist (m methods) (when (null (method-qualifiers m)) (let ((specl (car (method-specializers m)))) (when (and (classp specl) (if (listp class-names) (member (class-name specl) class-names) (eq (class-name specl) class-names))) (return m)))))) (defmacro call-initialize-function (initialize-function instance initargs) `(let ((.function. ,initialize-function)) (if (and (consp .function.) (eq (car .function.) 'call-initialize-instance-simple)) (initialize-instance-simple (cadr .function.) (caddr .function.) ,instance ,initargs) (funcall (the function .function.) ,instance ,initargs)))) (defmacro copy-slots (slots-init) #-(or lucid cmu17) `(copy-seq ,slots-init) #+(or lucid cmu17) `(let* ((init ,slots-init) (len (length init)) (v #+lucid (system:new-simple-vector len) #+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len))) (declare (simple-vector init v) (type #-cmu fixnum #+cmu lisp::index len)) (dotimes (i len v) (declare (type #-cmu fixnum #+cmu lisp::index i)) (setf (svref v i) (svref init i))))) (defmacro allocate-standard-instance--macro (wrapper slots-init) #-new-kcl-wrapper `(let ((instance (%%allocate-instance--class))) (setf (std-instance-wrapper instance) ,wrapper) (setf (std-instance-slots instance) (copy-slots ,slots-init)) instance) #+new-kcl-wrapper `(allocate-standard-instance ,wrapper ,slots-init)) (defmacro with-make-instance-function-valid-p-check (initargs-form &body body) `(let ((current-class (if class-cell (find-class-from-cell class-key class-cell) class-symbol))) (if (or (not (eq current-class class-symbol)) (invalid-wrapper-p wrapper)) (make-instance-function-trap current-class ,initargs-form) (progn ,@body)))) (defun make-instance-function-trap (class-symbol initargs) (let* ((info (initialize-info class-symbol initargs)) (fn (initialize-info-make-instance-function info))) (declare (type function fn)) (funcall fn class-symbol initargs))) (defun make-instance-function-simple (key class keys initialize-instance-methods shared-initialize-methods) (let* ((class-key (car key)) (class-cell (when (symbolp class-key) (find-class-cell class-key nil))) (wrapper (class-wrapper class)) (lwrapper (list wrapper)) (allocate-function (cond ((structure-class-p class) #'allocate-structure-instance) ((standard-class-p class) #'allocate-standard-instance) ((funcallable-standard-class-p class) #'allocate-funcallable-instance) (t (error "error in make-instance-function-simple")))) (allocate-macro (cond ((standard-class-p class) 'allocate-standard-instance--macro))) (std-si-meth (find-standard-ii-method shared-initialize-methods 'slot-object)) (shared-initfns (nreverse (mapcar #'(lambda (method) (make-effective-method-function #'shared-initialize `(call-method ,method nil) nil lwrapper)) (remove std-si-meth shared-initialize-methods)))) (std-ii-meth (find-standard-ii-method initialize-instance-methods 'slot-object)) (initialize-initfns (nreverse (mapcar #'(lambda (method) (make-effective-method-function #'initialize-instance `(call-method ,method nil) nil lwrapper)) (remove std-ii-meth initialize-instance-methods))))) (multiple-value-bind (initialize-function constants) (get-simple-initialization-function class keys (caddr key)) (if (eq allocate-macro 'allocate-standard-instance--macro) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let ((instance (allocate-standard-instance--macro wrapper constants))) (call-initialize-function initialize-function instance initargs) (dolist (fn shared-initfns) (invoke-effective-method-function fn t instance t initargs)) (dolist (fn initialize-initfns) (invoke-effective-method-function fn t instance initargs)) instance))) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let* ((instance (funcall allocate-function wrapper constants)) (initargs (call-initialize-function initialize-function instance initargs))) (dolist (fn shared-initfns) (invoke-effective-method-function fn t instance t initargs)) (dolist (fn initialize-initfns) (invoke-effective-method-function fn t instance initargs)) instance))))))) (defun make-instance-function-complex (key class keys initialize-instance-methods shared-initialize-methods) (multiple-value-bind (initargs-function initialize-function) (get-complex-initialization-functions class keys (caddr key)) (let* ((class-key (car key)) (class-cell (when (symbolp class-key) (find-class-cell class-key nil))) (wrapper (class-wrapper class)) (shared-initialize (get-secondary-dispatch-function #'shared-initialize shared-initialize-methods `((class-eq ,class) t t) `((,(find-standard-ii-method shared-initialize-methods 'slot-object) ,#'(lambda (instance init-type &rest initargs) (declare (ignore init-type)) #+copy-&rest-arg (setq initargs (copy-list initargs)) (call-initialize-function initialize-function instance initargs) instance))) (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) (initialize-instance (get-secondary-dispatch-function #'initialize-instance initialize-instance-methods `((class-eq ,class) t) `((,(find-standard-ii-method initialize-instance-methods 'slot-object) ,#'(lambda (instance &rest initargs) #+copy-&rest-arg (setq initargs (copy-list initargs)) (invoke-effective-method-function shared-initialize t instance t initargs)))) (list wrapper *the-wrapper-of-t*)))) #'(lambda (class-symbol &rest initargs) (with-make-instance-function-valid-p-check initargs (let* ((initargs (call-initialize-function initargs-function nil initargs)) (instance (apply #'allocate-instance class initargs))) (invoke-effective-method-function initialize-instance t instance initargs) instance)))))) #| (defmacro call-initialize-function (initialize-function instance initargs) `(let ((.function. ,initialize-function)) (if (and (consp .function.) (eq (car .function.) 'call-initialize-instance-simple)) (initialize-instance-simple (cadr .function.) (caddr .function.) ,instance ,initargs) (funcall (the function .function.) ,instance ,initargs)))) (defun make-instance-function-basic (key class keys) (let* ((class-key (car key)) (class-cell (find-class-cell class-key nil)) (wrapper (class-wrapper class))) (multiple-value-bind (initialize-function constants) (get-simple-initialization-function class keys (caddr key)) #'(lambda (class-symbol &rest initargs) (let ((current-class (find-class-from-cell class-key class-cell))) (if (or (not (eq current-class class-symbol)) (invalid-wrapper-p wrapper)) (make-instance-function-trap current-class initargs-form) (let ((instance (allocate-standard-instance--macro wrapper constants))) (call-initialize-function initialize-function instance initargs) instance))))))) |# (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) (let ((info (initialize-info class keys nil allow-other-keys-arg))) (values (initialize-info-combined-initialize-function info) (initialize-info-constants info)))) (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg separate-p) (let* ((info (initialize-info class keys nil allow-other-keys-arg)) (default-initargs-function (initialize-info-default-initargs-function info))) (if separate-p (values default-initargs-function (initialize-info-shared-initialize-t-function info)) (values default-initargs-function (initialize-info-shared-initialize-t-function (initialize-info class (initialize-info-new-keys info) nil allow-other-keys-arg)))))) (defun add-forms (forms forms-list) (when forms (setq forms (copy-list forms)) (if (null (car forms-list)) (setf (car forms-list) forms) (setf (cddr forms-list) forms)) (setf (cdr forms-list) (last forms))) (car forms-list)) (defun make-default-initargs-form-list (class keys &optional (separate-p t)) (let ((initargs-form-list (cons nil nil)) (default-initargs (class-default-initargs class)) (nkeys keys) (slots-alist (mapcan #'(lambda (slot) (mapcar #'(lambda (arg) (cons arg slot)) (slot-definition-initargs slot))) (class-slots class))) (nslots nil)) (dolist (key nkeys) (pushnew (cdr (assoc key slots-alist)) nslots)) (dolist (default default-initargs) (let* ((key (car default)) (slot (cdr (assoc key slots-alist))) (function (cadr default))) (unless (member slot nslots) (add-forms `((funcall ,function) (push-initarg ,key)) initargs-form-list) (push key nkeys) (push slot nslots)))) (when separate-p (add-forms `((update-initialize-info-cache ,class ,(initialize-info class nkeys nil))) initargs-form-list)) (add-forms `((finish-pushing-initargs)) initargs-form-list) (values (car initargs-form-list) nkeys))) (defun make-shared-initialize-form-list (class keys si-slot-names simple-p) (let* ((initialize-form-list (cons nil nil)) (type (cond ((structure-class-p class) 'structure) ((standard-class-p class) 'standard) ((funcallable-standard-class-p class) 'funcallable) (t (error "error in make-shared-initialize-form-list")))) (wrapper (class-wrapper class)) (constants (when simple-p (make-array (wrapper-no-of-instance-slots wrapper) ':initial-element *slot-unbound*))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) (slots-key (mapcar #'(lambda (slot) (let ((index most-positive-fixnum)) (dolist (key (slot-definition-initargs slot)) (let ((pos (position key keys))) (when pos (setq index (min index pos))))) (cons slot index))) slots)) (slots (stable-sort slots-key #'< :key #'cdr))) (let ((n-popped 0)) (declare (fixnum n-popped)) (dolist (slot+index slots) (let* ((slot (car slot+index)) (name (slot-definition-name slot)) (npop (1+ (- (the fixnum (cdr slot+index)) n-popped)))) (declare (fixnum npop)) (unless (eql (cdr slot+index) most-positive-fixnum) (let* ((pv-offset (1+ (position name slot-names)))) (add-forms `(,@(when (plusp npop) `((pop-initargs ,(the fixnum (* 2 npop))))) (instance-set ,pv-offset ,slot)) initialize-form-list)) (incf n-popped npop))))) (dolist (slot+index slots) (let* ((slot (car slot+index)) (name (slot-definition-name slot))) (when (and (eql (cdr slot+index) most-positive-fixnum) (or (eq si-slot-names 't) (member name si-slot-names))) (let* ((initform (slot-definition-initform slot)) (initfunction (slot-definition-initfunction slot)) (location (unless (eq type 'structure) (slot-definition-location slot))) (pv-offset (1+ (position name slot-names))) (forms (cond ((null initfunction) nil) ((constantp initform) (let ((value (funcall initfunction))) (if (and simple-p (integerp location)) (progn (setf (svref constants location) value) nil) `((const ,value) (instance-set ,pv-offset ,slot))))) (t `((funcall ,(slot-definition-initfunction slot)) (instance-set ,pv-offset ,slot)))))) (add-forms `(,@(unless (or simple-p (null forms)) `((skip-when-instance-boundp ,pv-offset ,slot ,(length forms)))) ,@forms) initialize-form-list))))) (values (car initialize-form-list) constants))) (defvar *class-pv-table-table* (make-hash-table :test 'eq)) (defun get-pv-cell-for-class (class) (let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) (slot-name-lists (list (cons nil slot-names))) (pv-table (gethash class *class-pv-table-table*))) (unless (and pv-table (equal slot-name-lists (pv-table-slot-name-lists pv-table))) (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) (setf (gethash class *class-pv-table-table*) pv-table)) (pv-table-lookup pv-table (class-wrapper class)))) (defvar *initialize-instance-simple-alist* nil) (defvar *note-iis-entry-p* nil) (defvar *compiled-initialize-instance-simple-functions* (make-hash-table :test #'equal)) (defun initialize-instance-simple-function (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) (key (initialize-info-key info)) (sf-key (list* use (class-name (car key)) (cdr key)))) (if (or *compile-make-instance-functions-p* (gethash sf-key *compiled-initialize-instance-simple-functions*)) (multiple-value-bind (form args) (form-list-to-lisp pv-cell form-list) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (setf (gethash sf-key *compiled-initialize-instance-simple-functions*) t) (if entry (setf (cdddr entry) (union (list sf-key) (cdddr entry) :test #'equal)) (progn (setq entry (list* form nil nil (list sf-key))) (setq *initialize-instance-simple-alist* (nconc *initialize-instance-simple-alist* (list entry))))) (unless (or *note-iis-entry-p* (cadr entry)) (setf (cadr entry) (compile-lambda (car entry)))) (if (cadr entry) (apply (the function (cadr entry)) args) `(call-initialize-instance-simple ,pv-cell ,form-list)))) #|| #'(lambda (instance initargs) (initialize-instance-simple pv-cell form-list instance initargs)) ||# `(call-initialize-instance-simple ,pv-cell ,form-list)))) (defun load-precompiled-iis-entry (form function system uses) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (unless entry (setq entry (list* form nil nil nil)) (setq *initialize-instance-simple-alist* (nconc *initialize-instance-simple-alist* (list entry)))) (setf (cadr entry) function) (setf (caddr entry) system) (dolist (use uses) (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) (setf (cdddr entry) (union uses (cdddr entry) :test #'equal)))) (defmacro precompile-iis-functions (&optional system) (let ((index -1)) `(progn ,@(gathering1 (collecting) (dolist (iis-entry *initialize-instance-simple-alist*) (when (or (null (caddr iis-entry)) (eq (caddr iis-entry) system)) (when system (setf (caddr iis-entry) system)) (gather1 (make-top-level-form `(precompile-initialize-instance-simple ,system ,(incf index)) '(load) `(load-precompiled-iis-entry ',(car iis-entry) #',(car iis-entry) ',system ',(cdddr iis-entry)))))))))) (defun compile-iis-functions (after-p) (let ((*compile-make-instance-functions-p* t) (*revert-initialize-info-p* t) (*note-iis-entry-p* (not after-p))) (declare (special *compile-make-instance-functions-p*)) (when (eq *boot-state* 'complete) (update-make-instance-function-table)))) ;(const const) ;(funcall function) ;(push-initarg const) ;(pop-supplied count) ; a positive odd number ;(instance-set pv-offset slotd) ;(skip-when-instance-boundp pv-offset slotd n) (defun initialize-instance-simple (pv-cell form-list instance initargs) (let ((pv (car pv-cell)) (initargs-tail initargs) (slots (get-slots-or-nil instance)) (class (class-of instance)) value) (loop (when (null form-list) (return nil)) (let ((form (pop form-list))) (ecase (car form) (push-initarg (push value initargs) (push (cadr form) initargs)) (const (setq value (cadr form))) (funcall (setq value (funcall (the function (cadr form))))) (pop-initargs (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) (setq value (pop initargs-tail))) (instance-set (instance-write-internal pv slots (cadr form) value (setf (slot-value-using-class class instance (caddr form)) value))) (skip-when-instance-boundp (when (instance-boundp-internal pv slots (cadr form) (slot-boundp-using-class class instance (caddr form))) (dotimes (i (cadddr form)) (pop form-list)))) (update-initialize-info-cache (when (consp initargs) (setq initargs (cons (car initargs) (cdr initargs)))) (setq *initialize-info-cache-class* (cadr form)) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* (caddr form))) (finish-pushing-initargs (setq initargs-tail initargs))))) initargs)) (defun add-to-cvector (cvector constant) (or (position constant cvector) (prog1 (fill-pointer cvector) (vector-push-extend constant cvector)))) (defvar *inline-iis-instance-locations-p* t) (defun first-form-to-lisp (forms cvector pv) (flet ((const (constant) (cond ((or (numberp constant) (characterp constant)) constant) ((and (symbolp constant) (symbol-package constant)) `',constant) (t `(svref cvector ,(add-to-cvector cvector constant)))))) (let ((form (pop (car forms)))) (ecase (car form) (push-initarg `((push value initargs) (push ,(const (cadr form)) initargs))) (const `((setq value ,(const (cadr form))))) (funcall `((setq value (funcall (the function ,(const (cadr form))))))) (pop-initargs `((setq initargs-tail (,@(let ((pop (1- (cadr form)))) (case pop (1 `(cdr)) (3 `(cdddr)) (t `(nthcdr ,pop)))) initargs-tail)) (setq value (pop initargs-tail)))) (instance-set (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) (default `(setf (slot-value-using-class class instance ,(const (caddr form))) value))) (if *inline-iis-instance-locations-p* (typecase location (fixnum `((setf (%instance-ref slots ,(const location)) value))) (cons `((setf (cdr ,(const location)) value))) (t `(,default))) `((instance-write-internal pv slots ,(const pv-offset) value ,default ,(typecase location (fixnum ':instance) (cons ':class) (t ':default))))))) (skip-when-instance-boundp (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) (default `(slot-boundp-using-class class instance ,(const (caddr form))))) `((unless ,(if *inline-iis-instance-locations-p* (typecase location (fixnum `(not (eq (%instance-ref slots ,(const location)) ',*slot-unbound*))) (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) (t default)) `(instance-boundp-internal pv slots ,(const pv-offset) ,default ,(typecase (pvref pv pv-offset) (fixnum ':instance) (cons ':class) (t ':default)))) ,@(let ((sforms (cons nil nil))) (dotimes (i (cadddr form) (car sforms)) (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) (update-initialize-info-cache `((when (consp initargs) (setq initargs (cons (car initargs) (cdr initargs)))) (setq *initialize-info-cache-class* ,(const (cadr form))) (setq *initialize-info-cache-initargs* initargs) (setq *initialize-info-cache-info* ,(const (caddr form))))) (finish-pushing-initargs `((setq initargs-tail initargs))))))) (defmacro iis-body (&body forms) (let ((vars '(initargs-tail pv slots wrapper class value))) `(let ((initargs-tail initargs) (pv (car pv-cell)) (slots nil) (wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil) class value) ,@(progn #-cmu vars #+cmu `((declare (ignorable ,@vars)))) #+cmu17 (cond ((not (typep wrapper 'wrapper))) ((std-instance-p instance) (setq slots (std-instance-slots instance))) (t (setq slots (fsc-instance-slots instance)))) #-cmu17 (cond ((std-instance-p instance) (setq slots (std-instance-slots instance)) (setq wrapper (std-instance-wrapper instance))) ((fsc-instance-p instance) (setq slots (fsc-instance-slots instance)) (setq wrapper (fsc-instance-wrapper instance))) (t (setq wrapper (wrapper-of instance)))) (setq class (wrapper-class wrapper)) ,@forms))) (defun form-list-to-lisp (pv-cell form-list) (let* ((forms (list form-list)) (cvector (make-array (floor (length form-list) 2) :fill-pointer 0 :adjustable t)) (pv (car pv-cell)) (body (let ((rforms (cons nil nil))) (loop (when (null (car forms)) (return (car rforms))) (add-forms (first-form-to-lisp forms cvector pv) rforms)))) (cvector-type `(simple-vector ,(length cvector)))) (values `(lambda (pv-cell cvector) (declare (type ,cvector-type cvector)) #+cmu (declare (ignorable pv-cell cvector)) #'(lambda (instance initargs) (declare #.*optimize-speed*) #+cmu (declare (ignorable instance initargs)) (iis-body ,@body) initargs)) (list pv-cell (coerce cvector cvector-type))))) ;The effect of this is to cause almost all of the overhead of make-instance ;to happen at load time (or maybe at precompile time, as explained in a ;previous message) rather than the first time make-instance is called with ;a given class-name and sequence of keywords. ;This optimization applys only when the first argument and all the even ;numbered arguments are constants evaluating to interned symbols. #+cmu (declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) ; Use this definition in any CL implementation supporting ; both define-compiler-macro and load-time-value. #+cmu (define-compiler-macro make-instance (&whole form &rest args) (declare (ignore args)) (let* ((*make-instance-function-keys* nil) (expanded-form (expand-make-instance-form form))) (if expanded-form `(funcall (the function (symbol-function ;; The symbol is guaranteed to be fbound. ;; Is there a way to declare this? (load-time-value (get-make-instance-function-symbol ',(first *make-instance-function-keys*))))) ,@(cdr expanded-form)) form))) (defun get-make-instance-function-symbol (key) (get-make-instance-functions (list key)) (make-instance-function-symbol key)) gcl/pcl/gcl_pcl_dfun.lisp0000644000175000017500000016363612240167764014355 0ustar cammcamm;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) #| This implementation of method lookup was redone in early August of 89. It has the following properties: - It's modularity makes it easy to modify the actual caching algorithm. The caching algorithm is almost completely separated into the files cache.lisp and dlap.lisp. This file just contains the various uses of it. There will be more tuning as we get more results from Luis' measurements of caching behavior. - The metacircularity issues have been dealt with properly. All of PCL now grounds out properly. Moreover, it is now possible to have metaobject classes which are themselves not instances of standard metaobject classes. ** Modularity of the code ** The actual caching algorithm is isolated in a modest number of functions. The code which generates cache lookup code is all found in cache.lisp and dlap.lisp. Certain non-wrapper-caching special cases are in this file. ** Handling the metacircularity ** In CLOS, method lookup is the potential source of infinite metacircular regress. The metaobject protocol specification gives us wide flexibility in how to address this problem. PCL uses a technique which handles the problem not only for the metacircular language described in Chapter 3, but also for the PCL protocol which includes additional generic functions which control more aspects of the CLOS implementation. The source of the metacircular regress can be seen in a number of ways. One is that the specified method lookup protocol must, as part of doing the method lookup (or at least the cache miss case), itself call generic functions. It is easy to see that if the method lookup for a generic function ends up calling that same generic function there can be trouble. Fortunately, there is an easy solution at hand. The solution is based on the restriction that portable code cannot change the class of a specified metaobject. This restriction implies that for specified generic functions, the method lookup protocol they follow is fixed. More precisely, for such specified generic functions, most generic functions that are called during their own method lookup will not run portable methods. This allows the implementation to usurp the actual generic function call in this case. In short, method lookup of a standard generic function, in the case where the only applicable methods are themselves standard doesn't have to do any method lookup to implement itself. And so, we are saved. |# ;An alist in which each entry is of the form : ; ( . ( ...)) ;Each subentry is of the form: ; ( ) (defvar *dfun-constructors* ()) ;If this is NIL, then the whole mechanism ;for caching dfun constructors is turned ;off. The only time that makes sense is ;when debugging LAP code. (defvar *enable-dfun-constructor-caching* t) (defun show-dfun-constructors () (format t "~&DFUN constructor caching is ~A." (if *enable-dfun-constructor-caching* "enabled" "disabled")) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (format t "~&~S ~S ~A" (cons (car generator-entry) (car args-entry)) (caddr args-entry) (if (cadddr args-entry) "(preliminary)" ""))))) (defvar *raise-metatypes-to-class-p* t) (defun get-dfun-constructor (generator &rest args) (when (and *raise-metatypes-to-class-p* (member generator '(emit-checking emit-caching emit-in-checking-cache-p emit-constant-value))) (setq args (cons (mapcar #'(lambda (mt) (if (eq mt 't) mt 'class)) (car args)) (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) (apply (the function (symbol-function generator)) args) (or (cadr args-entry) (multiple-value-bind (new not-best-p) (apply (the function (symbol-function generator)) args) (let ((entry (list (copy-list args) new (unless not-best-p '+pcl+) not-best-p))) (if generator-entry (push entry (cdr generator-entry)) (push (list generator entry) *dfun-constructors*))) (values new not-best-p)))))) (defun load-precompiled-dfun-constructor (generator args system constructor) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if args-entry (when (fourth args-entry) (let* ((dfun-type (case generator (emit-checking 'checking) (emit-caching 'caching) (emit-constant-value 'constant-value) (emit-default-only 'default-method-only))) (metatypes (car args)) (gfs (when dfun-type (gfs-of-type dfun-type)))) (dolist (gf gfs) (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) (let ((gf-name (generic-function-name gf))) (and (not (eq gf-name 'slot-value-using-class)) (not (equal gf-name '(setf slot-value-using-class))) (not (eq gf-name 'slot-boundp-using-class))))) (update-dfun gf))) (setf (second args-entry) constructor) (setf (third args-entry) system) (setf (fourth args-entry) nil))) (let ((entry (list args constructor system nil))) (if generator-entry (push entry (cdr generator-entry)) (push (list generator entry) *dfun-constructors*)))))) (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn ,@(gathering1 (collecting) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) (when system (setf (caddr args-entry) system)) (gather1 (make-top-level-form `(precompile-dfun-constructor ,(car generator-entry)) '(load) `(load-precompiled-dfun-constructor ',(car generator-entry) ',(car args-entry) ',system ,(apply (symbol-function (car generator-entry)) (car args-entry)))))))))))) ;;; ;;; When all the methods of a generic function are automatically generated ;;; reader or writer methods a number of special optimizations are possible. ;;; These are important because of the large number of generic functions of ;;; this type. ;;; ;;; There are a number of cases: ;;; ;;; ONE-CLASS-ACCESSOR ;;; In this case, the accessor generic function has only been called ;;; with one class of argument. There is no cache vector, the wrapper ;;; of the one class, and the slot index are stored directly as closure ;;; variables of the discriminating function. This case can convert to ;;; either of the next kind. ;;; ;;; TWO-CLASS-ACCESSOR ;;; Like above, but two classes. This is common enough to do specially. ;;; There is no cache vector. The two classes are stored a separate ;;; closure variables. ;;; ;;; ONE-INDEX-ACCESSOR ;;; In this case, the accessor generic function has seen more than one ;;; class of argument, but the index of the slot is the same for all ;;; the classes that have been seen. A cache vector is used to store ;;; the wrappers that have been seen, the slot index is stored directly ;;; as a closure variable of the discriminating function. This case ;;; can convert to the next kind. ;;; ;;; N-N-ACCESSOR ;;; This is the most general case. In this case, the accessor generic ;;; function has seen more than one class of argument and more than one ;;; slot index. A cache vector stores the wrappers and corresponding ;;; slot indexes. Because each cache line is more than one element ;;; long, a cache lock count is used. ;;; (defstruct (dfun-info (:constructor nil) (:print-function print-dfun-info)) (cache nil)) (defun print-dfun-info (dfun-info stream depth) (declare (ignore depth) (stream stream)) (printing-random-thing (dfun-info stream) (format stream "~A" (type-of dfun-info)))) (defstruct (no-methods (:constructor no-methods-dfun-info ()) (:include dfun-info))) (defstruct (initial (:constructor initial-dfun-info ()) (:include dfun-info))) (defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) (:include dfun-info))) (defstruct (dispatch (:constructor dispatch-dfun-info ()) (:include dfun-info))) (defstruct (default-method-only (:constructor default-method-only-dfun-info ()) (:include dfun-info))) ;without caching: ; dispatch one-class two-class default-method-only ;with caching: ; one-index n-n checking caching ;accessor: ; one-class two-class one-index n-n (defstruct (accessor-dfun-info (:constructor nil) (:include dfun-info)) accessor-type) ; (member reader writer) (defmacro dfun-info-accessor-type (di) `(accessor-dfun-info-accessor-type ,di)) (defstruct (one-index-dfun-info (:constructor nil) (:include accessor-dfun-info)) index) (defmacro dfun-info-index (di) `(one-index-dfun-info-index ,di)) (defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) (:include accessor-dfun-info))) (defstruct (one-class (:constructor one-class-dfun-info (accessor-type index wrapper0)) (:include one-index-dfun-info)) wrapper0) (defmacro dfun-info-wrapper0 (di) `(one-class-wrapper0 ,di)) (defstruct (two-class (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1)) (:include one-class)) wrapper1) (defmacro dfun-info-wrapper1 (di) `(two-class-wrapper1 ,di)) (defstruct (one-index (:constructor one-index-dfun-info (accessor-type index cache)) (:include one-index-dfun-info))) (defstruct (checking (:constructor checking-dfun-info (function cache)) (:include dfun-info)) function) (defmacro dfun-info-function (di) `(checking-function ,di)) (defstruct (caching (:constructor caching-dfun-info (cache)) (:include dfun-info))) (defstruct (constant-value (:constructor constant-value-dfun-info (cache)) (:include dfun-info))) (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) (funcall ,function ,generic-function ,@args) (update-dfun ,generic-function dfun cache info))) (defun accessor-miss-function (gf dfun-info) (ecase (dfun-info-accessor-type dfun-info) (reader #'(lambda (arg) (declare (pcl-fast-call)) (accessor-miss gf nil arg dfun-info))) (writer #'(lambda (new arg) (declare (pcl-fast-call)) (accessor-miss gf new arg dfun-info))))) #+cmu (declaim (ext:freeze-type dfun-info)) ;;; ;;; ONE-CLASS-ACCESSOR ;;; (defun make-one-class-accessor-dfun (gf type wrapper index) (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer)) (dfun-info (one-class-dfun-info type index wrapper))) (values (funcall (the function (get-dfun-constructor emit (consp index))) wrapper index (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; ;;; TWO-CLASS-ACCESSOR ;;; (defun make-two-class-accessor-dfun (gf type w0 w1 index) (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer)) (dfun-info (two-class-dfun-info type index w0 w1))) (values (funcall (the function (get-dfun-constructor emit (consp index))) w0 w1 index (accessor-miss-function gf dfun-info)) nil dfun-info))) ;;; ;;; std accessors same index dfun ;;; (defun make-one-index-accessor-dfun (gf type index &optional cache) (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers)) (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values (funcall (the function (get-dfun-constructor emit (consp index))) cache index (accessor-miss-function gf dfun-info)) cache dfun-info))) (defun make-final-one-index-accessor-dfun (gf type index table) (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) (make-one-index-accessor-dfun gf type index cache))) (defun one-index-limit-fn (nlines) (default-limit-fn nlines)) (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers)) (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values (funcall (the function (get-dfun-constructor emit)) cache (accessor-miss-function gf dfun-info)) cache dfun-info))) (defun make-final-n-n-accessor-dfun (gf type table) (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) (make-n-n-accessor-dfun gf type cache))) (defun n-n-accessors-limit-fn (nlines) (default-limit-fn nlines)) (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) (return-from make-checking-dfun (make-caching-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) (if (every #'(lambda (mt) (eq mt 't)) metatypes) (let ((dfun-info (default-method-only-dfun-info))) (values (funcall (the function (get-dfun-constructor 'emit-default-only metatypes applyp)) function) nil dfun-info)) (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) (dfun-info (checking-dfun-info function cache))) (values (funcall (the function (get-dfun-constructor 'emit-checking metatypes applyp)) cache function #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (checking-miss generic-function args dfun-info))) cache dfun-info))))) (defun make-final-checking-dfun (generic-function function classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) (if (every #'(lambda (mt) (eq mt 't)) metatypes) (values #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (invoke-emf function args)) nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn classes-list new-class))) (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp nkeys)) (every #'(lambda (mt) (eq mt 't)) metatypes))) (defun use-caching-dfun-p (generic-function) (some #'(lambda (method) (let ((fmf (if (listp method) (third method) (method-fast-function method)))) (method-function-get fmf ':slot-name-lists))) (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function)))) (defun checking-limit-fn (nlines) (default-limit-fn nlines)) ;;; ;;; ;;; (defun make-caching-dfun (generic-function &optional cache) (unless cache (when (use-constant-value-dfun-p generic-function) (return-from make-caching-dfun (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (caching-dfun-info cache))) (values (funcall (the function (get-dfun-constructor 'emit-caching metatypes applyp)) cache #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (caching-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal generic-function t #'caching-limit-fn classes-list new-class))) (make-caching-dfun generic-function cache))) (defun caching-limit-fn (nlines) (default-limit-fn nlines)) (defun insure-dfun (gf caching-p) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq nkeys)) (when (or (null metatypes) (not (null (car metatypes)))) (cond ((use-constant-value-dfun-p gf) (get-dfun-constructor 'emit-constant-value metatypes)) (caching-p (get-dfun-constructor 'emit-caching metatypes applyp)) ((dolist (mt metatypes t) (unless (eq mt 't) (return nil))) (get-dfun-constructor 'emit-default-only metatypes applyp)) (t (get-dfun-constructor 'emit-checking metatypes applyp)))))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) (methods (if early-p (early-gf-methods gf) (generic-function-methods gf))) (default '(unknown))) (and (null applyp) (or (not (eq *boot-state* 'complete)) (compute-applicable-methods-emf-std-p gf)) (notany #'(lambda (method) (or (and (eq *boot-state* 'complete) (some #'eql-specializer-p (method-specializers method))) (let ((value (method-function-get (if early-p (or (third method) (second method)) (or (method-fast-function method) (method-function method))) :constant-value default))) (if boolean-values-p (not (or (eq value 't) (eq value nil))) (eq value default))))) methods))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info generic-function) (declare (ignore nreq applyp)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (constant-value-dfun-info cache))) (values (funcall (the function (get-dfun-constructor 'emit-constant-value metatypes)) cache #'(lambda (&rest args) (declare (pcl-fast-call)) #+copy-&rest-arg (setq args (copy-list args)) (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) (let ((cache (make-final-ordinary-dfun-internal generic-function :constant-value #'caching-limit-fn classes-list new-class))) (make-constant-value-dfun generic-function cache))) (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) (unless caching-p ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than ;; one (non built-in) typep. ;; Otherwise, it is probably at least as fast to use ;; a caching dfun first, possibly followed by secondary dispatching. (let ((caching-cost (caching-dfun-cost gf))) (< (dispatch-dfun-cost gf caching-cost) caching-cost))))) ;; Try this on print-object, find-method-combination, and documentation. ;; Look at pcl/generic-functions.lisp for other potential test cases. (defun show-dfun-costs (gf) (when (or (symbolp gf) (consp gf)) (setq gf (gdefinition gf))) (format t "~&Name ~S caching cost ~D dispatch cost ~D~%" (generic-function-name gf) (caching-dfun-cost gf) (dispatch-dfun-cost gf))) (defparameter *non-built-in-typep-cost* 1) (defparameter *structure-typep-cost* 1) (defparameter *built-in-typep-cost* 0) (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil #'(lambda (methods known-types) (declare (ignore methods known-types)) 0) #'(lambda (position type true-value false-value) (declare (ignore position)) (let* ((type-test-cost (if (eq 'class (car type)) (let* ((metaclass (class-of (cadr type))) (mcpl (class-precedence-list metaclass))) (cond ((memq *the-class-built-in-class* mcpl) *built-in-typep-cost*) ((memq *the-class-structure-class* mcpl) *structure-typep-cost*) (t *non-built-in-typep-cost*))) 0)) (max-cost-so-far (+ (max true-value false-value) type-test-cost))) (when (and limit (<= limit max-cost-so-far)) (return-from dispatch-dfun-cost max-cost-so-far)) max-cost-so-far)) #'identity)) (defparameter *cache-lookup-cost* 1) (defparameter *wrapper-of-cost* 0) (defparameter *secondary-dfun-call-cost* 1) (defun caching-dfun-cost (gf) (let* ((arg-info (gf-arg-info gf)) (nreq (length (arg-info-metatypes arg-info)))) (+ *cache-lookup-cost* (* *wrapper-of-cost* nreq) (if (methods-contain-eql-specializer-p (generic-function-methods gf)) *secondary-dfun-call-cost* 0)))) #+cmu (progn (setq *non-built-in-typep-cost* 100) (setq *structure-typep-cost* 15) (setq *built-in-typep-cost* 5) (setq *cache-lookup-cost* 30) (setq *wrapper-of-cost* 15) (setq *secondary-dfun-call-cost* 30)) (defun make-dispatch-dfun (gf) (values (get-dispatch-function gf) nil (dispatch-dfun-info))) (defun get-dispatch-function (gf) (let ((methods (generic-function-methods gf))) (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil nil nil t) nil nil))) (defun make-final-dispatch-dfun (gf) (make-dispatch-dfun gf)) (defun update-dispatch-dfuns () (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) (dfun-update gf #'make-dispatch-dfun))) (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn (+ (hash-table-count table) 3))))) (maphash #'(lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) value t))) table) cache)) (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class (equal (type-of (gf-dfun-info generic-function)) (cond ((eq valuep t) 'caching) ((eq valuep :constant-value) 'constant-value) ((null valuep) 'checking))) new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) (get-cache nkeys (not (null valuep)) limit-fn 4)))) (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) (defmacro dfun-miss ((gf args wrappers invalidp nemf &optional type index caching-p applicable) &body body) (unless applicable (setq applicable (gensym))) `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp ,@(when type `(,type ,index))) (cache-miss-values ,gf ,args ',(cond (caching-p 'caching) (type 'accessor) (t 'checking))) (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*))) (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*))) ,@body)) (invoke-emf ,nemf ,args))) ;;; ;;; The dynamically adaptive method lookup algorithm is implemented is ;;; implemented as a kind of state machine. The kinds of discriminating ;;; function is the state, the various kinds of reasons for a cache miss ;;; are the state transitions. ;;; ;;; The code which implements the transitions is all in the miss handlers ;;; for each kind of dfun. Those appear here. ;;; ;;; Note that within the states that cache, there are dfun updates which ;;; simply select a new cache or cache field. Those are not considered ;;; as state transitions. ;;; (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) (defun make-initial-dfun (gf) (let ((initial-dfun (fin-lambda-fn (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) (if (and (eq *boot-state* 'complete) (compute-applicable-methods-emf-std-p gf)) (let* ((caching-p (use-caching-dfun-p gf)) (classes-list (precompute-effective-methods gf caching-p (not *lazy-dfun-compute-p*)))) (if *lazy-dfun-compute-p* (cond ((use-dispatch-dfun-p gf caching-p) (values initial-dfun nil (initial-dispatch-dfun-info))) (t (insure-dfun gf caching-p) (values initial-dfun nil (initial-dfun-info)))) (make-final-dfun-internal gf classes-list))) (let ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) (gf-arg-info gf))) (type nil)) (if (and (gf-precompute-dfun-and-emf-p arg-info) (setq type (final-accessor-dfun-type gf))) (if *early-p* (values (make-early-accessor gf type) nil nil) (make-final-accessor-dfun gf type)) (values initial-dfun nil (initial-dfun-info))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type (reader (fin-lambda-fn (instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-get-slot class-name instance slot-name)))) (writer (fin-lambda-fn (new-value instance) (let* ((class (class-of instance)) (class-name (bootstrap-get-slot 'class class 'name))) (bootstrap-set-slot class-name instance slot-name new-value))))))) (defun initial-dfun (gf args) (dfun-miss (gf args wrappers invalidp nemf ntype nindex) (cond (invalidp) ((and ntype nindex) (dfun-update gf #'make-one-class-accessor-dfun ntype wrappers nindex)) ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t (dfun-update gf #'make-checking-dfun ;; nemf is suitable only for caching, have to do this: (cache-miss-values gf args 'checking)))))) (defun make-final-dfun (gf &optional classes-list) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) (defvar *new-class* nil) (defvar *free-hash-tables* (mapcar #'list '(eq equal eql))) (defmacro with-hash-table ((table test) &body forms) `(let* ((.free. (assoc ',test *free-hash-tables*)) (,table (if (cdr .free.) (pop (cdr .free.)) (make-hash-table :test ',test)))) (multiple-value-prog1 (progn ,@forms) (clrhash ,table) (push ,table (cdr .free.))))) (defmacro with-eq-hash-table ((table) &body forms) `(with-hash-table (,table eq) ,@forms)) (defun final-accessor-dfun-type (gf) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) (cond ((every #'(lambda (method) (if (consp method) (eq *the-class-standard-reader-method* (early-method-class method)) (standard-reader-method-p method))) methods) 'reader) ((every #'(lambda (method) (if (consp method) (eq *the-class-standard-writer-method* (early-method-class method)) (standard-writer-method-p method))) methods) 'writer)))) (defun make-final-accessor-dfun (gf type &optional classes-list new-class) (with-eq-hash-table (table) (multiple-value-bind (table all-index first second size no-class-slots-p) (make-accessor-table gf type table) (if table (cond ((= size 1) (let ((w (class-wrapper first))) (make-one-class-accessor-dfun gf type w all-index))) ((and (= size 2) (or (integerp all-index) (consp all-index))) (let ((w0 (class-wrapper first)) (w1 (class-wrapper second))) (make-two-class-accessor-dfun gf type w0 w1 all-index))) ((or (integerp all-index) (consp all-index)) (make-final-one-index-accessor-dfun gf type all-index table)) (no-class-slots-p (make-final-n-n-accessor-dfun gf type table)) (t (make-final-caching-dfun gf classes-list new-class))) (make-final-caching-dfun gf classes-list new-class))))) (defun make-final-dfun-internal (gf &optional classes-list) (let ((methods (generic-function-methods gf)) type (new-class *new-class*) (*new-class* nil) specls all-same-p) (cond ((null methods) (values (fin-lambda-fn (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) (setq specls (method-specializers (car methods)))) (setq all-same-p (every #'(lambda (method) (and (equal specls (method-specializers method)))) methods)))) (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) ((use-dispatch-dfun-p gf) (make-final-dispatch-dfun gf)) ((and all-same-p (not (use-caching-dfun-p gf))) (let ((emf (get-secondary-dispatch-function gf methods nil))) (make-final-checking-dfun gf emf classes-list new-class))) (t (make-final-caching-dfun gf classes-list new-class))))) (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) (otype (dfun-info-accessor-type dfun-info)) oindex ow0 ow1 cache (args (ecase otype ;The congruence rules assure (reader (list object)) ;us that this is safe despite (writer (list new object))))) ;not knowing the new type yet. (dfun-miss (gf args wrappers invalidp nemf ntype nindex) ;; ;; The following lexical functions change the state of the ;; dfun to that which is their name. They accept arguments ;; which are the parameters of the new state, and get other ;; information from the lexical variables bound above. ;; (flet ((two-class (index w0 w1) (when (zerop (random 2)) (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index)) (one-index (index &optional cache) (dfun-update gf #'make-one-index-accessor-dfun ntype index cache)) (n-n (&optional cache) (if (consp nindex) (dfun-update gf #'make-checking-dfun nemf) (dfun-update gf #'make-n-n-accessor-dfun ntype cache))) (caching () ; because cached accessor emfs are much faster for accessors (dfun-update gf #'make-caching-dfun)) ;; (do-fill (update-fn) (declare (type function update-fn)) (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) (funcall update-fn ncache))))) (cond ((null ntype) (caching)) ((or invalidp (null nindex))) ((not #-cmu17 (or (std-instance-p object) (fsc-instance-p object)) #+cmu17 (pcl-instance-p object)) (caching)) ((or (neq ntype otype) (listp wrappers)) (caching)) (t (ecase ostate (one-class (setq oindex (dfun-info-index dfun-info)) (setq ow0 (dfun-info-wrapper0 dfun-info)) (unless (eq ow0 wrappers) (if (eql nindex oindex) (two-class nindex ow0 wrappers) (n-n)))) (two-class (setq oindex (dfun-info-index dfun-info)) (setq ow0 (dfun-info-wrapper0 dfun-info)) (setq ow1 (dfun-info-wrapper1 dfun-info)) (unless (or (eq ow0 wrappers) (eq ow1 wrappers)) (if (eql nindex oindex) (one-index nindex) (n-n)))) (one-index (setq oindex (dfun-info-index dfun-info)) (setq cache (dfun-info-cache dfun-info)) (if (eql nindex oindex) (do-fill #'(lambda (ncache) (one-index nindex ncache))) (n-n))) (n-n (setq cache (dfun-info-cache dfun-info)) (if (consp nindex) (caching) (do-fill #'n-n)))))))))) (defun checking-miss (generic-function args dfun-info) (let ((oemf (dfun-info-function dfun-info)) (cache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) ((eq oemf nemf) (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun nemf ncache)))) (t (dfun-update generic-function #'make-caching-dfun)))))) (defun caching-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t (let ((ncache (fill-cache ocache wrappers emf))) (unless (eq ncache ocache) (dfun-update generic-function #'make-caching-dfun ncache)))))))) (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) (cond (invalidp) (t (let* ((function (typecase emf (fast-method-call (fast-method-call-function emf)) (method-call (method-call-function emf)))) (value (method-function-get function :constant-value)) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function #'make-constant-value-dfun ncache)))))))) ;;; Given a generic function and a set of arguments to that generic function, ;;; returns a mess of values. ;;; ;;; The compiled effective method function for this set of ;;; arguments. ;;; ;;; Sorted list of applicable methods. ;;; ;;; Is a single wrapper if the generic function has only ;;; one key, that is arg-info-nkeys of the arg-info is 1. ;;; Otherwise a list of the wrappers of the specialized ;;; arguments to the generic function. ;;; ;;; Note that all these wrappers are valid. This function ;;; does invalid wrapper traps when it finds an invalid ;;; wrapper and then returns the new, valid wrapper. ;;; ;;; True if any of the specialized arguments had an invalid ;;; wrapper, false otherwise. ;;; ;;; READER or WRITER when the only method that would be run ;;; is a standard reader or writer method. To be specific, ;;; the value is READER when the method combination is eq to ;;; *standard-method-combination*; there are no applicable ;;; :before, :after or :around methods; and the most specific ;;; primary method is a standard reader method. ;;; ;;; If is READER or WRITER, and the slot accessed is ;;; an :instance slot, this is the index number of that slot ;;; in the object argument. ;;; (defun cache-miss-values (gf args state) (if (null (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf))) (apply #'no-applicable-method gf args) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nreq applyp nkeys)) (with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p wrappers classes types) (error "The function ~S requires at least ~D arguments" gf (length metatypes)) (multiple-value-bind (emf methods accessor-type index) (cache-miss-values-internal gf arg-info wrappers classes types state) (values emf methods dfun-wrappers invalid-wrapper-p accessor-type index)))))) (defun cache-miss-values-internal (gf arg-info wrappers classes types state) (let* ((for-accessor-p (eq state 'accessor)) (for-cache-p (or (eq state 'caching) (eq state 'accessor))) (cam-std-p (or (null arg-info) (gf-info-c-a-m-emf-std-p arg-info)))) (multiple-value-bind (methods all-applicable-and-sorted-p) (if cam-std-p (compute-applicable-methods-using-types gf types) (compute-applicable-methods-using-classes gf classes)) (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) (function-funcall (get-secondary-dispatch-function1 gf methods types nil (and for-cache-p wrappers) all-applicable-and-sorted-p) nil (and for-cache-p wrappers)) (default-secondary-dispatch-function gf)))) (multiple-value-bind (index accessor-type) (and for-accessor-p all-applicable-and-sorted-p methods (accessor-values gf arg-info classes methods)) (values (if (integerp index) index emf) methods accessor-type index)))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) (let* ((accessor-type (gf-info-simple-accessor-type arg-info)) (accessor-class (case accessor-type (reader (car classes)) (writer (cadr classes)) (boundp (car classes))))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values1 (gf accessor-type accessor-class) (let* ((type `(class-eq ,accessor-class)) (types (if (eq accessor-type 'writer) `(t ,type) `(,type))) (methods (compute-applicable-methods-using-types gf types))) (accessor-values-internal accessor-type accessor-class methods))) (defun accessor-values-internal (accessor-type accessor-class methods) (dolist (meth methods) (when (if (consp meth) (early-method-qualifiers meth) (method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) (early-p (not (eq *boot-state* 'complete))) (slot-name (when accessor-class (if (consp meth) (and (early-method-standard-accessor-p meth) (early-method-standard-accessor-slot-name meth)) (and (member *the-class-standard-object* (if early-p (early-class-precedence-list accessor-class) (class-precedence-list accessor-class))) (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) (standard-accessor-method-p meth)) (if early-p (early-accessor-method-slot-name meth) (accessor-method-slot-name meth)))))) (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) (when (eql slot-name (early-slot-definition-name slot)) (return slot))) (find-slot-definition accessor-class slot-name))))) (when (and slotd (or early-p (slot-accessor-std-p slotd accessor-type))) (values (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)) accessor-type)))) (defun make-accessor-table (gf type &optional table) (unless table (setq table (make-hash-table :test 'eq))) (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf))) (all-index nil) (no-class-slots-p t) (early-p (not (eq *boot-state* 'complete))) first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} (dolist (method methods) (let* ((specializers (if (consp method) (early-method-specializers method t) (method-specializers method))) (specl (if (eq type 'reader) (car specializers) (cadr specializers))) (specl-cpl (if early-p (early-class-precedence-list specl) (and (class-finalized-p specl) (class-precedence-list specl)))) (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) (maphash #'(lambda (class slotd) (let ((cpl (if early-p (early-class-precedence-list class) (class-precedence-list class)))) (when (memq specl cpl) (unless (and (or so-p (member *the-class-standard-object* cpl)) (or early-p (slot-accessor-std-p slotd type))) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table))))) (gethash slot-name *name->class->slotd-table*)))) (maphash #'(lambda (class specl+slotd-list) (dolist (sclass (if early-p (early-class-precedence-list class) (class-precedence-list class)) (error "This can't happen")) (let ((a (assq sclass specl+slotd-list))) (when a (let* ((slotd (cdr a)) (index (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)))) (unless index (return-from make-accessor-table nil)) (setf (gethash class table) index) (when (consp index) (setq no-class-slots-p nil)) (setq all-index (if (or (null all-index) (eql all-index index)) index t)) (incf size) (cond ((= size 1) (setq first class)) ((= size 2) (setq second class))) (return nil)))))) table) (values table all-index first second size no-class-slots-p))) (defun compute-applicable-methods-using-types (generic-function types) (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function))) (let ((specls (if (consp method) (early-method-specializers method t) (method-specializers method))) (types types) (possibly-applicable-p t) (applicable-p t)) (dolist (specl specls) (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p) (specializer-applicable-using-type-p specl (pop types)) (unless specl-applicable-p (setq applicable-p nil)) (unless specl-possibly-applicable-p (setq possibly-applicable-p nil) (return nil)))) (when possibly-applicable-p (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) (early-gf-arg-info generic-function) (gf-arg-info generic-function))))) (values (sort-applicable-methods precedence (nreverse possibly-applicable-methods) types) definite-p)))) (defun sort-applicable-methods (precedence methods types) (sort-methods methods precedence #'(lambda (class1 class2 index) (let* ((class (type-class (nth index types))) (cpl (if (eq *boot-state* 'complete) (class-precedence-list class) (early-class-precedence-list class)))) (if (memq class2 (memq class1 cpl)) class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (declare (type function compare-classes-function)) (flet ((sorter (method1 method2) (dolist (index precedence) (let* ((specl1 (nth index (if (listp method1) (early-method-specializers method1 t) (method-specializers method1)))) (specl2 (nth index (if (listp method2) (early-method-specializers method2 t) (method-specializers method2)))) (order (order-specializers specl1 specl2 index compare-classes-function))) (when order (return-from sorter (eq order specl1))))))) (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) (declare (type function compare-classes-function)) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) (bootstrap-get-slot 'specializer specl1 'type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) (bootstrap-get-slot 'specializer specl2 'type)))) (cond ((eq specl1 specl2) nil) ((atom type1) specl2) ((atom type2) specl1) (t (case (car type1) (class (case (car type2) (class (funcall compare-classes-function specl1 specl2 index)) (t specl2))) (prototype (case (car type2) (class (funcall compare-classes-function specl1 specl2 index)) (t specl2))) (class-eq (case (car type2) (eql specl2) (class-eq nil) (class type1))) (eql (case (car type2) (eql nil) (t specl1)))))))) (defun map-all-orders (methods precedence function) (declare (type function function)) (let ((choices nil)) (flet ((compare-classes-function (class1 class2 index) (declare (ignore index)) (let ((choice nil)) (dolist (c choices nil) (when (or (and (eq (first c) class1) (eq (second c) class2)) (and (eq (first c) class2) (eq (second c) class1))) (return (setq choice c)))) (unless choice (setq choice (if (class-might-precede-p class1 class2) (if (class-might-precede-p class2 class1) (list class1 class2 nil t) (list class1 class2 t)) (if (class-might-precede-p class2 class1) (list class2 class1 t) (let ((name1 (class-name class1)) (name2 (class-name class2))) (if (and name1 name2 (symbolp name1) (symbolp name2) (string< (symbol-name name1) (symbol-name name2))) (list class1 class2 t) (list class2 class1 t)))))) (push choice choices)) (car choice)))) (loop (funcall function (sort-methods methods precedence #'compare-classes-function)) (unless (dolist (c choices nil) (unless (third c) (rotatef (car c) (cadr c)) (return (setf (third c) t)))) (return nil)))))) (defvar *in-precompute-effective-methods-p* nil) ;used only in map-all-orders (defun class-might-precede-p (class1 class2) (if (not *in-precompute-effective-methods-p*) (not (member class1 (cdr (class-precedence-list class2)))) (class-can-precede-p class1 class2))) (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list))) (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))) (defun saut-and (specl type) (let ((applicable nil) (possibly-applicable t)) (dolist (type (cdr type)) (multiple-value-bind (appl poss-appl) (specializer-applicable-using-type-p specl type) (when appl (return (setq applicable t))) (unless poss-appl (return (setq possibly-applicable nil))))) (values applicable possibly-applicable))) (defun saut-not (specl type) (let ((ntype (cadr type))) (values nil (case (car ntype) (class (saut-not-class specl ntype)) (class-eq (saut-not-class-eq specl ntype)) (prototype (saut-not-prototype specl ntype)) (eql (saut-not-eql specl ntype)) (t (error "~s cannot handle the second argument ~s" 'specializer-applicable-using-type-p type)))))) (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) (cpl (class-precedence-list class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) (eql (class-of (cadr specl))) (class-eq (cadr specl)) (prototype (cadr specl)) (class (cadr specl)))) (cpl (class-precedence-list class))) (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) (eql (class-of (cadr specl))) (class-eq (cadr specl))))) (not (eq class (cadr ntype))))) (defun saut-not-eql (specl ntype) (case (car specl) (eql (not (eql (cadr specl) (cadr ntype)))) (t t))) (defun class-applicable-using-class-p (specl type) (let ((pred (memq specl (if (eq *boot-state* 'complete) (class-precedence-list type) (early-class-precedence-list type))))) (values pred (or pred (if (not *in-precompute-effective-methods-p*) ;; classes might get common subclass (superclasses-compatible-p specl type) ;; worry only about existing classes (classes-have-common-subclass-p specl type)))))) (defun classes-have-common-subclass-p (class1 class2) (or (eq class1 class2) (let ((class1-subs (class-direct-subclasses class1))) (or (memq class2 class1-subs) (dolist (class1-sub class1-subs nil) (when (classes-have-common-subclass-p class1-sub class2) (return t))))))) (defun saut-class (specl type) (case (car specl) (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) (memq (cadr type) (class-precedence-list class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) (values nil (eq (class-of (cadr specl)) (cadr type))) (let ((pred (case (car specl) (class-eq (eq (cadr specl) (cadr type))) (class (or (eq (cadr specl) (cadr type)) (memq (cadr specl) (if (eq *boot-state* 'complete) (class-precedence-list (cadr type)) (early-class-precedence-list (cadr type))))))))) (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) (values nil nil)) ; fix this someday (defun saut-eql (specl type) (let ((pred (case (car specl) (eql (eql (cadr specl) (cadr type))) (class-eq (eq (cadr specl) (class-of (cadr type)))) (class (memq (cadr specl) (let ((class (class-of (cadr type)))) (if (eq *boot-state* 'complete) (class-precedence-list class) (early-class-precedence-list class)))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) (setq specl (type-from-specializer specl)) (when (eq specl 't) (return-from specializer-applicable-using-type-p (values t t))) ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, ;; and has only what they need. (if (or (atom type) (eq (car type) 't)) (values nil t) (case (car type) (and (saut-and specl type)) (not (saut-not specl type)) (class (saut-class specl type)) (prototype (saut-prototype specl type)) (class-eq (saut-class-eq specl type)) (eql (saut-eql specl type)) (t (error "~s cannot handle the second argument ~s" 'specializer-applicable-using-type-p type))))) (defun map-all-classes (function &optional (root 't)) (declare (type function function)) (let ((braid-p (or (eq *boot-state* 'braid) (eq *boot-state* 'complete)))) (labels ((do-class (class) (mapc #'do-class (if braid-p (class-direct-subclasses class) (early-class-direct-subclasses class))) (funcall function class))) (do-class (if (symbolp root) (find-class root) root))))) ;;; ;;; NOTE: We are assuming a restriction on user code that the method ;;; combination must not change once it is connected to the ;;; generic function. ;;; ;;; This has to be legal, because otherwise any kind of method ;;; lookup caching couldn't work. See this by saying that this ;;; cache, is just a backing cache for the fast cache. If that ;;; cache is legal, this one must be too. ;;; ;;; Don't clear this table! (defvar *effective-method-table* (make-hash-table :test 'eq)) (defun get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods types (not (null method-alist)) (not (null wrappers)) (not (methods-contain-eql-specializer-p methods))) method-alist wrappers)) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p &optional all-applicable-p (all-sorted-p t) function-p) (if (null methods) (if function-p #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) (fin-lambda-fn (&rest args) (apply #'no-applicable-method gf args))) #'(lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) #'(lambda (&rest args) (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) (cons nil nil))))) (if (and (null (cdr methods)) all-applicable-p ; the most common case (null method-alist-p) wrappers-p (not function-p)) (or (car ht-value) (setf (car ht-value) (get-secondary-dispatch-function2 gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p))) (let ((akey (list methods (if all-applicable-p 'all-applicable types) method-alist-p wrappers-p function-p))) (or (cdr (assoc akey (cdr ht-value) :test #'equal)) (let ((value (get-secondary-dispatch-function2 gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p))) (push (cons akey value) (cdr ht-value)) value))))))) (defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p all-applicable-p all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) (make-effective-method-function1 gf effective method-alist-p wrappers-p)) (let ((effective (standard-compute-effective-method gf nil methods))) (make-effective-method-function1 gf effective method-alist-p wrappers-p))) (let ((net (generate-discrimination-net gf methods types all-sorted-p))) (compute-secondary-dispatch-function1 gf net function-p)))) (defun get-effective-method-function (gf methods &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods nil (not (null method-alist)) (not (null wrappers)) t) method-alist wrappers)) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) (defun methods-contain-eql-specializer-p (methods) (and (eq *boot-state* 'complete) (dolist (method methods nil) (when (dolist (spec (method-specializers method) nil) (when (eql-specializer-p spec) (return t))) (return t))))) (defun update-dfun (generic-function &optional dfun cache info) (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p (early-gf-name generic-function) (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) (let* ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function))) (info (gf-dfun-info generic-function))) (unless (eq 'default-method-only (type-of info)) (setq dfun (doctor-dfun-for-the-debugger generic-function #+cmu dfun #-cmu (set-function-name dfun gf-name)))) (set-funcallable-instance-function generic-function dfun) #+cmu (set-function-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) (defvar dfun-count nil) (defvar dfun-list nil) (defvar *minimum-cache-size-to-list*) (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym dfun-list))) (unless a (push (setq a (list sym)) dfun-list)) (push (generic-function-name gf) (cdr a)))) (defun list-all-dfuns () (setq dfun-list nil) (map-all-generic-functions #'list-dfun) dfun-list) (defun list-large-cache (gf) (let* ((sym (type-of (gf-dfun-info gf))) (cache (gf-dfun-cache gf))) (when cache (let ((size (cache-size cache))) (when (>= size *minimum-cache-size-to-list*) (let ((a (assoc size dfun-list))) (unless a (push (setq a (list size)) dfun-list)) (push (let ((name (generic-function-name gf))) (if (eq sym 'caching) name (list name sym))) (cdr a)))))))) (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq dfun-list nil) (map-all-generic-functions #'list-large-cache) (setq dfun-list (sort dfun-list #'< :key #'car)) (mapc #'print dfun-list) (values)) (defun count-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (cache (gf-dfun-cache gf)) (a (assq sym dfun-count))) (unless a (push (setq a (list sym 0 nil)) dfun-count)) (incf (cadr a)) (when cache (let* ((size (cache-size cache)) (b (assoc size (third a)))) (unless b (push (setq b (cons size 0)) (third a))) (incf (cdr b)))))) (defun count-all-dfuns () (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil)) '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY ONE-INDEX N-N CHECKING CACHING DISPATCH))) (map-all-generic-functions #'count-dfun) (mapc #'(lambda (type+count+sizes) (setf (third type+count+sizes) (sort (third type+count+sizes) #'< :key #'car))) dfun-count) (mapc #'(lambda (type+count+sizes) (format t "~&There are ~4d dfuns of type ~s" (cadr type+count+sizes) (car type+count+sizes)) (format t "~% ~S~%" (caddr type+count+sizes))) dfun-count) (values)) (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) (map-all-generic-functions #'(lambda (gf) (when (memq (type-of (gf-dfun-info gf)) type) (push gf gf-list)))) gf-list)) gcl/pcl/README0000644000175000017500000000055712240167764011715 0ustar cammcammTo install PCL at your site, follow the instructions in the defsys.lisp file. If you use gcl (GNU Common Lisp), follow the instructions in impl/gcl/README. If you use cmucl17f, follow the instructions in impl/cmu/README, then recompile PCL and rebuild the world. If you use lucid, just compile and load defsys, then type (pcl::compile-pcl), or (pcl::load-pcl). gcl/pcl/gcl_pcl_boot.lisp0000644000175000017500000023412712240167764014356 0ustar cammcamm;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- ;;; ;;; ************************************************************************* ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. ;;; All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted. Any distribution of this ;;; software or derivative works must comply with all applicable United ;;; States export control laws. ;;; ;;; This software is made available AS IS, and Xerox Corporation makes no ;;; warranty about the software, its performance or its conformity to any ;;; specification. ;;; ;;; Any person obtaining a copy of this software is requested to send their ;;; name and post office or electronic mail address to: ;;; CommonLoops Coordinator ;;; Xerox PARC ;;; 3333 Coyote Hill Rd. ;;; Palo Alto, CA 94304 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) ;;; ;;; Suggestions, comments and requests for improvements are also welcome. ;;; ************************************************************************* ;;; (in-package :pcl) #| The CommonLoops evaluator is meta-circular. Most of the code in PCL is methods on generic functions, including most of the code that actually implements generic functions and method lookup. So, we have a classic bootstrapping problem. The solution to this is to first get a cheap implementation of generic functions running, these are called early generic functions. These early generic functions and the corresponding early methods and early method lookup are used to get enough of the system running that it is possible to create real generic functions and methods and implement real method lookup. At that point (done in the file FIXUP) the function fix-early-generic-functions is called to convert all the early generic functions to real generic functions. The cheap generic functions are built using the same funcallable-instance objects real generic-functions are made out of. This means that as PCL is being bootstrapped, the cheap generic function objects which are being created are the same objects which will later be real generic functions. This is good because: - we don't cons garbage structure - we can keep pointers to the cheap generic function objects during booting because those pointers will still point to the right object after the generic functions are all fixed up This file defines the defmethod macro and the mechanism used to expand it. This includes the mechanism for processing the body of a method. defmethod basically expands into a call to load-defmethod, which basically calls add-method to add the method to the generic-function. These expansions can be loaded either during bootstrapping or when PCL is fully up and running. An important effect of this structure is it means we can compile files with defmethod forms in them in a completely running PCL, but then load those files back in during bootstrapping. This makes development easier. It also means there is only one set of code for processing defmethod. Bootstrapping works by being sure to have load-method be careful to call only primitives which work during bootstrapping. |# (proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method remove-method )) (defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method) (add-named-method early-add-named-method real-add-named-method) )) ;;; ;;; For each of the early functions, arrange to have it point to its early ;;; definition. Do this in a way that makes sure that if we redefine one ;;; of the early definitions the redefinition will take effect. This makes ;;; development easier. ;;; ;;; The function which generates the redirection closure is pulled out into ;;; a separate piece of code because of a bug in ExCL which causes this not ;;; to work if it is inlined. ;;; (eval-when (load eval) (defun redirect-early-function-internal (real early) (setf (gdefinition real) (set-function-name #'(lambda (&rest args) (apply (the function (symbol-function early)) args)) real))) (dolist (fns *early-functions*) (let ((name (car fns)) (early-name (cadr fns))) (redirect-early-function-internal name early-name))) ) ;;; ;;; *generic-function-fixups* is used by fix-early-generic-functions to ;;; convert the few functions in the bootstrap which are supposed to be ;;; generic functions but can't be early on. ;;; (defvar *generic-function-fixups* '((add-method ((generic-function method) ;lambda-list (standard-generic-function method) ;specializers real-add-method)) ;method-function (remove-method ((generic-function method) (standard-generic-function method) real-remove-method)) (get-method ((generic-function qualifiers specializers &optional (errorp t)) (standard-generic-function t t) real-get-method)) (ensure-generic-function-using-class ((generic-function function-specifier &key generic-function-class environment &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) ((generic-function function-specifier &key generic-function-class environment &allow-other-keys) (null t) real-ensure-gf-using-class--null)) (make-method-lambda ((proto-generic-function proto-method lambda-expression environment) (standard-generic-function standard-method t t) real-make-method-lambda)) (make-method-initargs-form ((proto-generic-function proto-method lambda-expression lambda-list environment) (standard-generic-function standard-method t t t) real-make-method-initargs-form)) (compute-effective-method ((generic-function combin applicable-methods) (generic-function standard-method-combination t) standard-compute-effective-method)) )) ;;; ;;; ;;; (defmacro defgeneric (function-specifier lambda-list &body options) (expand-defgeneric function-specifier lambda-list options)) (defun expand-defgeneric (function-specifier lambda-list options) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) (let ((initargs ())) (flet ((duplicate-option (name) (error "The option ~S appears more than once." name))) ;; ;; INITARG takes this screwy new argument to get around a bad ;; interaction between lexical macros and setf in the Lucid ;; compiler. ;; (macrolet ((initarg (key &optional new) (if new `(setf (getf initargs ,key) ,new) `(getf initargs ,key)))) (dolist (option options) (ecase (car option) (:argument-precedence-order (if (initarg :argument-precedence-order) (duplicate-option :argument-precedence-order) (initarg :argument-precedence-order `',(cdr option)))) (declare (initarg :declarations (append (cdr option) (initarg :declarations)))) (:documentation (if (initarg :documentation) (duplicate-option :documentation) (initarg :documentation `',(cadr option)))) (:method-combination (if (initarg :method-combination) (duplicate-option :method-combination) (initarg :method-combination `',(cdr option)))) (:generic-function-class (if (initarg :generic-function-class) (duplicate-option :generic-function-class) (initarg :generic-function-class `',(cadr option)))) (:method-class (if (initarg :method-class) (duplicate-option :method-class) (initarg :method-class `',(cadr option)))) (:method (error "DEFGENERIC doesn't support the :METHOD option yet.")))) (let ((declarations (initarg :declarations))) (when declarations (initarg :declarations `',declarations))))) `(progn (proclaim-defgeneric ',function-specifier ',lambda-list) ,(make-top-level-form `(defgeneric ,function-specifier) *defgeneric-times* `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))) (defun load-defgeneric (function-specifier lambda-list &rest initargs) (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier))) (apply #'ensure-generic-function function-specifier :lambda-list lambda-list :definition-source `((defgeneric ,function-specifier) ,(load-truename)) initargs)) ;;; ;;; ;;; (defmacro DEFMETHOD (&rest args &environment env) #+(or (not :lucid) :lcl3.0) (declare (arglist name {method-qualifier}* specialized-lambda-list &body body)) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda name) (expand-defmethod name proto-gf proto-method qualifiers lambda-list body env)))) (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) (values nil nil) (let ((gf? (and (gboundp name) (gdefinition name)))) (if (or (null gf?) (not (generic-function-p gf?))) (values (class-prototype (find-class 'standard-generic-function)) (class-prototype (find-class 'standard-method))) (values gf? (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method)))))))) ;;; ;;; takes a name which is either a generic function name or a list specifying ;;; a setf generic function (like: (SETF )). Returns ;;; the prototype instance of the method-class for that generic function. ;;; ;;; If there is no generic function by that name, this returns the default ;;; value, the prototype instance of the class STANDARD-METHOD. This default ;;; value is also returned if the spec names an ordinary function or even a ;;; macro. In effect, this leaves the signalling of the appropriate error ;;; until load time. ;;; ;;; NOTE that during bootstrapping, this function is allowed to return NIL. ;;; (defun method-prototype-for-gf (name) (let ((gf? (and (gboundp name) (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) ((or (null gf?) (not (generic-function-p gf?))) ;Someone else MIGHT ;error at load time. (class-prototype (find-class 'standard-method))) (t (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) (defvar *optimize-asv-funcall-p* nil) (defvar *asv-readers*) (defvar *asv-writers*) (defvar *asv-boundps*) (defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) (when (listp name) (do-standard-defsetf-1 (cadr name))) (let ((*make-instance-function-keys* nil) (*optimize-asv-funcall-p* t) (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) (declare (special *make-instance-function-keys*)) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (multiple-value-bind (method-function-lambda initargs) (make-method-lambda proto-gf proto-method method-lambda env) (let ((initargs-form (make-method-initargs-form proto-gf proto-method method-function-lambda initargs env))) `(progn (proclaim-defgeneric ',name ',lambda-list) ,@(when *make-instance-function-keys* `((get-make-instance-functions ',*make-instance-function-keys*))) ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) `((initialize-internal-slot-gfs* ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) ,(make-defmethod-form name qualifiers specializers unspecialized-lambda-list (if proto-method (class-name (class-of proto-method)) 'standard-method) initargs-form (getf (getf initargs ':plist) ':pv-table-symbol)))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) (defun make-defmethod-form (name qualifiers specializers unspecialized-lambda-list method-class-name initargs-form &optional pv-table-symbol) (let (fn fn-lambda) (if (and (interned-symbol-p (if (consp name) (and (eq (car name) 'setf) (cadr name)) name)) (every #'interned-symbol-p qualifiers) (every #'(lambda (s) (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) (let ((sv (eval (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) (standard-char-p sv))))) (interned-symbol-p s))) specializers) (consp initargs-form) (eq (car initargs-form) 'list*) (memq (cadr initargs-form) '(:function :fast-function)) (consp (setq fn (caddr initargs-form))) (eq (car fn) 'function) (consp (setq fn-lambda (cadr fn))) (eq (car fn-lambda) 'lambda)) (let* ((specls (mapcar #'(lambda (specl) (if (consp specl) `(,(car specl) ,(eval (cadr specl))) specl)) specializers)) (mname `(,(if (eq (cadr initargs-form) ':function) 'method 'fast-method) ,name ,@qualifiers ,specls)) (mname-sym (intern (let ((*print-pretty* nil)) (format nil "~S" mname))))) `(eval-when ,*defmethod-times* (defun ,mname-sym ,(cadr fn-lambda) ,@(cddr fn-lambda)) ,(make-defmethod-form-internal name qualifiers `',specls unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form)) pv-table-symbol))) (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers) *defmethod-times* (make-defmethod-form-internal name qualifiers `(list ,@(mapcar #'(lambda (specializer) (if (consp specializer) ``(,',(car specializer) ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list method-class-name initargs-form pv-table-symbol))))) (defun make-defmethod-form-internal (name qualifiers specializers-form unspecialized-lambda-list method-class-name initargs-form &optional pv-table-symbol) `(load-defmethod ',method-class-name ',name ',qualifiers ,specializers-form ',unspecialized-lambda-list ,initargs-form ;;Paper over a bug in KCL by passing the cache-symbol ;;here in addition to in the list. ',pv-table-symbol)) (defmacro make-method-function (method-lambda &environment env) (make-method-function-internal method-lambda env)) (defun make-method-function-internal (method-lambda &optional env) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) (make-method-lambda proto-gf proto-method method-lambda env) (make-method-initargs-form proto-gf proto-method method-function-lambda initargs env)))) (defun add-method-declarations (name qualifiers lambda-list body env) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) (declare (ignore parameters)) (multiple-value-bind (documentation declarations real-body) (extract-declarations body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) (declare (method-name ,(list name qualifiers specializers))) (declare (method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) unspecialized-lambda-list specializers)))) (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The method-lambda argument to make-method-function, ~S,~ is not a lambda form" method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) (unless (fboundp 'make-method-initargs-form) (setf (gdefinition 'make-method-initargs-form) (symbol-function 'real-make-method-initargs-form))) (defun real-make-method-lambda (proto-gf proto-method method-lambda env) (declare (ignore proto-gf proto-method)) (make-method-lambda-internal method-lambda env)) (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The method-lambda argument to make-method-lambda, ~S,~ is not a lambda form" method-lambda)) (multiple-value-bind (documentation declarations real-body) (extract-declarations (cddr method-lambda) env) (let* ((name-decl (get-declaration 'method-name declarations)) (sll-decl (get-declaration 'method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) (generic-function-name (when method-name (car method-name))) (specialized-lambda-list (or sll-decl (cadr method-lambda)))) (multiple-value-bind (parameters lambda-list specializers) (parse-specialized-lambda-list specialized-lambda-list) (let* ((required-parameters (mapcar #'(lambda (r s) (declare (ignore s)) r) parameters specializers)) (slots (mapcar #'list required-parameters)) (calls (list nil)) (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters declarations method-name specializers)) (class-declarations `(declare ,@(remove nil (mapcar #'(lambda (a s) (and (symbolp s) (neq s 't) `(class ,a ,s))) parameters specializers)))) (method-lambda ;; Remove the documentation string and insert the ;; appropriate class declarations. The documentation ;; string is removed to make it easy for us to insert ;; new declarations later, they will just go after the ;; cadr of the method lambda. The class declarations ;; are inserted to communicate the class of the method's ;; arguments to the code walk. `(lambda ,lambda-list ,class-declarations ,@declarations (progn ,@parameters-to-reference) (block ,(if (listp generic-function-name) (cadr generic-function-name) generic-function-name) ,@real-body))) (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p (eval (car real-body)))) (plist (if (and constant-value-p (or (typep constant-value '(or number character)) (and (symbolp constant-value) (symbol-package constant-value)))) (list :constant-value constant-value) ())) (applyp (dolist (p lambda-list nil) (cond ((memq p '(&optional &rest &key)) (return t)) ((eq p '&aux) (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep next-method-p-p) (walk-method-lambda method-lambda required-parameters env slots calls) (multiple-value-bind (ignore walked-declarations walked-lambda-body) (extract-declarations (cddr walked-lambda)) (declare (ignore ignore)) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p 't plist))) (when (some #'cdr slots) (multiple-value-bind (slot-name-lists call-list) (slot-name-lists-from-slots slots calls) (let ((pv-table-symbol (make-symbol "pv-table"))) (setq plist `(,@(when slot-name-lists `(:slot-name-lists ,slot-name-lists)) ,@(when call-list `(:call-list ,call-list)) :pv-table-symbol ,pv-table-symbol ,@plist)) (setq walked-lambda-body `((pv-binding (,required-parameters ,slot-name-lists ,pv-table-symbol) ,@walked-lambda-body)))))) (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) (setq lambda-list (nconc (ldiff lambda-list aux) (list '&allow-other-keys) aux)))) (values `(lambda (.method-args. .next-methods.) (simple-lexical-method-functions (,lambda-list .method-args. .next-methods. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p :closurep ,closurep :applyp ,applyp) ,@walked-declarations ,@walked-lambda-body)) `(,@(when plist `(:plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) (symbol-function 'real-make-method-lambda))) (defmacro simple-lexical-method-functions ((lambda-list method-args next-methods &rest lmf-options) &body body) `(progn ,method-args ,next-methods (bind-simple-lexical-method-macros (,method-args ,next-methods) (bind-lexical-method-functions (,@lmf-options) (bind-args (,lambda-list ,method-args) ,@body))))) (defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg &rest lmf-options) &body body) `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) (bind-lexical-method-functions (,@lmf-options) (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) ,@body)))) (defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body) `(macrolet ((call-next-method-bind (&body body) `(let ((.next-method. (car ,',next-methods)) (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) (call-next-method-body (cnm-args) `(if .next-method. (funcall (the function (if (std-instance-p .next-method.) (method-function .next-method.) .next-method.)) ; for early methods (or ,cnm-args ,',method-args) ,',next-methods) (error "No next method."))) (next-method-p-body () `(not (null .next-method.)))) ,@body)) (defstruct method-call (function #'identity :type function) call-method-args) #+cmu (declaim (ext:freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) (.args. ,args) (.cm-args. ,cm-args)) (declare (type function .function.)) (if (and .cm-args. (null (cdr .cm-args.))) (funcall .function. .args. (car .cm-args.)) (apply .function. .args. .cm-args.)))) (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) `(invoke-method-call1 (method-call-function ,method-call) ,(if restp `(list* ,@required-args+rest-arg) `(list ,@required-args+rest-arg)) (method-call-call-method-args ,method-call))) (defstruct fast-method-call (function #'identity :type function) pv-cell next-method-call arg-info) #+cmu (declaim (ext:freeze-type fast-method-call)) #-akcl (defmacro fmc-funcall (fn pv-cell next-method-call &rest args) `(funcall (the function ,fn) ,pv-cell ,next-method-call ,@args)) (defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) `(fmc-funcall (fast-method-call-function ,method-call) (fast-method-call-pv-cell ,method-call) (fast-method-call-next-method-call ,method-call) ,@required-args+rest-arg)) (defstruct fast-instance-boundp (index 0 :type fixnum)) #+cmu (declaim (ext:freeze-type fast-instance-boundp)) (eval-when (compile load eval) (defvar *allow-emf-call-tracing-p* nil) (defvar *enable-emf-call-tracing-p* #-testing nil #+testing t) ) (defvar *emf-call-trace-size* 200) (defvar *emf-call-trace* nil) (defvar emf-call-trace-index 0) (defun show-emf-call-trace () (when *emf-call-trace* (let ((j emf-call-trace-index) (*enable-emf-call-tracing-p* nil)) (format t "~&(The oldest entries are printed first)~%") (dotimes (i *emf-call-trace-size*) (let ((ct (aref *emf-call-trace* j))) (when ct (print ct))) (incf j) (when (= j *emf-call-trace-size*) (setq j 0)))))) (defun trace-emf-call-internal (emf format args) (unless *emf-call-trace* (setq *emf-call-trace* (make-array *emf-call-trace-size*))) (setf (aref *emf-call-trace* emf-call-trace-index) (list* emf format args)) (incf emf-call-trace-index) (when (= emf-call-trace-index *emf-call-trace-size*) (setq emf-call-trace-index 0))) (defmacro trace-emf-call (emf format args) (when *allow-emf-call-tracing-p* `(when *enable-emf-call-tracing-p* (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast (emf restp &rest required-args+rest-arg) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (invoke-fast-method-call ,emf ,@required-args+rest-arg))) (defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg) (unless (constantp restp) (error "The restp argument to invoke-effective-method-function is not constant")) (setq restp (eval restp)) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond (#-(or lucid excl) (typep ,emf 'fast-method-call) #+(or lucid excl) (fast-method-call-p ,emf) (invoke-fast-method-call ,emf ,@required-args+rest-arg)) ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let* ((.slots. (get-slots-or-nil ,(car required-args+rest-arg))) (value (when .slots. (%instance-ref .slots. ,emf)))) (if (eq value ',*slot-unbound*) (slot-unbound-internal ,(car required-args+rest-arg) ,emf) value))))) ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) `(((typep ,emf 'fixnum) (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (when .slots. ; just to avoid compiler wranings (setf (%instance-ref .slots. ,emf) .new-value.)))))) #|| ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) `(((typep ,emf 'fast-instance-boundp) (let ((.slots. (get-slots-or-nil ,(car required-args+rest-arg)))) (and .slots. (not (eq (%instance-ref .slots. (fast-instance-boundp-index ,emf)) ',*slot-unbound*))))))) ||# (t (etypecase ,emf (method-call (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) (function ,(if restp `(apply (the function ,emf) ,@required-args+rest-arg) `(funcall (the function ,emf) ,@required-args+rest-arg)))))))) (defun invoke-emf (emf args) (trace-emf-call emf t args) (etypecase emf (fast-method-call (let* ((arg-info (fast-method-call-arg-info emf)) (restp (cdr arg-info)) (nreq (car arg-info))) (if restp (let* ((rest-args (nthcdr nreq args)) (req-args (ldiff args rest-args))) (apply (the function (fast-method-call-function emf)) (fast-method-call-pv-cell emf) (fast-method-call-next-method-call emf) (nconc req-args (list rest-args)))) (cond ((null args) (if (eql nreq 0) (invoke-fast-method-call emf) (error "wrong number of args"))) ((null (cdr args)) (if (eql nreq 1) (invoke-fast-method-call emf (car args)) (error "wrong number of args"))) ((null (cddr args)) (if (eql nreq 2) (invoke-fast-method-call emf (car args) (cadr args)) (error "wrong number of args"))) (t (apply (the function (fast-method-call-function emf)) (fast-method-call-pv-cell emf) (fast-method-call-next-method-call emf) args)))))) (method-call (apply (the function (method-call-function emf)) args (method-call-call-method-args emf))) (fixnum (cond ((null args) (error "1 or 2 args expected")) ((null (cdr args)) (let ((value (%instance-ref (get-slots (car args)) emf))) (if (eq value *slot-unbound*) (slot-unbound-internal (car args) emf) value))) ((null (cddr args)) (setf (%instance-ref (get-slots (cadr args)) emf) (car args))) (t (error "1 or 2 args expected")))) (fast-instance-boundp (if (or (null args) (cdr args)) (error "1 arg expected") (not (eq (%instance-ref (get-slots (car args)) (fast-instance-boundp-index emf)) *slot-unbound*)))) (function (apply (the function emf) args)))) ;; This can be improved alot. (defun gf-make-function-from-emf (gf emf) (etypecase emf (fast-method-call (let* ((arg-info (gf-arg-info gf)) (nreq (arg-info-number-required arg-info)) (restp (arg-info-applyp arg-info))) #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (trace-emf-call emf t args) (apply (fast-method-call-function emf) (fast-method-call-pv-cell emf) (fast-method-call-next-method-call emf) (if restp (let* ((rest-args (nthcdr nreq args)) (req-args (ldiff args rest-args))) (nconc req-args rest-args)) args))))) (method-call #'(lambda (&rest args) #+copy-&rest-arg (setq args (copy-list args)) (trace-emf-call emf t args) (apply (method-call-function emf) args (method-call-call-method-args emf)))) (function emf))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) `(macrolet ((call-next-method-bind (&body body) `(let () ,@body)) (call-next-method-body (cnm-args) `(if ,',next-method-call ,(if (and (null ',rest-arg) (consp cnm-args) (eq (car cnm-args) 'list)) `(invoke-effective-method-function ,',next-method-call nil ,@(cdr cnm-args)) (let ((call `(invoke-effective-method-function ,',next-method-call ,',(not (null rest-arg)) ,@',args ,@',(when rest-arg `(,rest-arg))))) `(if ,cnm-args (bind-args ((,@',args ,@',(when rest-arg `(&rest ,rest-arg))) ,cnm-args) ,call) ,call))) (error "No next method."))) (next-method-p-body () `(not (null ,',next-method-call)))) ,@body)) (defmacro bind-lexical-method-functions ((&key call-next-method-p next-method-p-p closurep applyp) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) (null closurep) (null applyp)) `(let () ,@body)) ((and (null closurep) (null applyp)) ;; OK to use MACROLET, and all args are mandatory ;; (else APPLYP would be true). `(call-next-method-bind (macrolet ((call-next-method (&rest cnm-args) `(call-next-method-body ,(when cnm-args `(list ,@cnm-args)))) (next-method-p () `(next-method-p-body))) ,@body))) (t `(call-next-method-bind (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args) #+Genera (declare (dbg:invisible-frame :clos-internal)) #+copy-&rest-arg (setq args (copy-list args)) (call-next-method-body cnm-args)))) ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) ,@body))))) (defmacro bind-args ((lambda-list args) &body body) #|| ; Lucid and Allegro don't compile the function inline `(apply #'(lambda ,lambda-list ,@body) ,args) ||# (let ((args-tail '.args-tail.) (key '.key.) (state 'required)) (flet ((process-var (var) (if (memq var lambda-list-keywords) (progn (case var (&optional (setq state 'optional)) (&key (setq state 'key)) (&allow-other-keys) (&rest (setq state 'rest)) (&aux (setq state 'aux)) (otherwise (error "Encountered the non-standard lambda list keyword ~S." var))) nil) (case state (required `((,var (pop ,args-tail)))) (optional (cond ((not (consp var)) `((,var (when ,args-tail (pop ,args-tail))))) ((null (cddr var)) `((,(car var) (if ,args-tail (pop ,args-tail) ,(cadr var))))) (t `((,(caddr var) ,args-tail) (,(car var) (if ,args-tail (pop ,args-tail) ,(cadr var))))))) (rest `((,var ,args-tail))) (key (cond ((not (consp var)) `((,var (get-key-arg ,(make-keyword var) ,args-tail)))) ((null (cddr var)) (multiple-value-bind (keyword variable) (if (consp (car var)) (values (caar var) (cadar var)) (values (make-keyword (car var)) (car var))) `((,key (get-key-arg1 ,keyword ,args-tail)) (,variable (if (consp ,key) (car ,key) ,(cadr var)))))) (t (multiple-value-bind (keyword variable) (if (consp (car var)) (values (caar var) (cadar var)) (values (make-keyword (car var)) (car var))) `((,key (get-key-arg1 ,keyword ,args-tail)) (,(caddr var) ,key) (,variable (if (consp ,key) (car ,key) ,(cadr var)))))))) (aux `(,var)))))) (let ((bindings (mapcan #'process-var lambda-list))) `(let* ((,args-tail ,args) ,@bindings) ,@(unless bindings `((declare (ignore ,args-tail)))) ,@body))))) (defun get-key-arg (keyword list) (loop (when (atom list) (return nil)) (when (eq (car list) keyword) (return (cadr list))) (setq list (cddr list)))) (defun get-key-arg1 (keyword list) (loop (when (atom list) (return nil)) (when (eq (car list) keyword) (return (cdr list))) (setq list (cddr list)))) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ;flag indicating that call-next-method ;should be in the method definition (closurep nil) ;flag indicating that #'call-next-method ;was seen in the body of a method (next-method-p-p nil)) ;flag indicating that next-method-p ;should be in the method definition (flet ((walk-function (form context env) (cond ((not (eq context ':eval)) form) ((not (listp form)) form) ((eq (car form) 'call-next-method) (setq call-next-method-p 't) form) ((eq (car form) 'next-method-p) (setq next-method-p-p 't) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p 't) (setq closurep t) form) ((eq (cadr form) 'next-method-p) (setq next-method-p-p 't) (setq closurep t) form) (t nil)))) ((and (or (eq (car form) 'slot-value) (eq (car form) 'set-slot-value) (eq (car form) 'slot-boundp)) (constantp (caddr form))) (let ((parameter (can-optimize-access form required-parameters env))) (ecase (car form) (slot-value (optimize-slot-value slots parameter form)) (set-slot-value (optimize-set-slot-value slots parameter form)) (slot-boundp (optimize-slot-boundp slots parameter form))))) ((and (eq (car form) 'apply) (consp (cadr form)) (eq (car (cadr form)) 'function) (generic-function-name-p (cadr (cadr form)))) (optimize-generic-function-call form required-parameters env slots calls)) ((and (or (symbolp (car form)) (and (consp (car form)) (eq (caar form) 'setf))) (generic-function-name-p (car form))) (optimize-generic-function-call form required-parameters env slots calls)) ((and (eq (car form) 'asv-funcall) *optimize-asv-funcall-p*) (case (fourth form) (reader (push (third form) *asv-readers*)) (writer (push (third form) *asv-writers*)) (boundp (push (third form) *asv-boundps*))) `(,(second form) ,@(cddddr form))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) (values walked-lambda call-next-method-p closurep next-method-p-p))))) (defun generic-function-name-p (name) (and (or (symbolp name) (and (consp name) (eq (car name) 'setf) (consp (cdr name)) (symbolp (cadr name)) (null (cddr name)))) (gboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) (defun make-parameter-references (specialized-lambda-list required-parameters declarations method-name specializers) (flet ((ignoredp (symbol) (dolist (decl (cdar declarations)) (when (and (eq (car decl) 'ignore) (memq symbol (cdr decl))) (return t))))) (gathering ((references (collecting))) (iterate ((s (list-elements specialized-lambda-list)) (p (list-elements required-parameters))) (progn p) (cond ((not (listp s))) ((ignoredp (car s)) (warn "In defmethod ~S, there is a~%~ redundant ignore declaration for the parameter ~S." method-name specializers (car s))) (t (gather (car s) references))))))) (defvar *method-function-plist* (make-hash-table :test #'eq)) (defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil) (defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil) (defun method-function-plist (method-function) (unless (eq method-function *mf1*) (rotatef *mf1* *mf2*) (rotatef *mf1p* *mf2p*) (rotatef *mf1cp* *mf2cp*)) (unless (or (eq method-function *mf1*) (null *mf1cp*)) (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (unless (eq method-function *mf1*) (setf *mf1* method-function *mf1cp* nil *mf1p* (gethash method-function *method-function-plist*))) *mf1p*) (defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist) (val method-function) (unless (eq method-function *mf1*) (rotatef *mf1* *mf2*) (rotatef *mf1cp* *mf2cp*) (rotatef *mf1p* *mf2p*)) (unless (or (eq method-function *mf1*) (null *mf1cp*)) (setf (gethash *mf1* *method-function-plist*) *mf1p*)) (setf *mf1* method-function *mf1cp* t *mf1p* val)) (defun method-function-get (method-function key &optional default) (getf (method-function-plist method-function) key default)) (defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get) (val method-function key) (setf (getf (method-function-plist method-function) key) val)) (defun method-function-pv-table (method-function) (method-function-get method-function :pv-table)) (defun method-function-method (method-function) (method-function-get method-function :method)) (defun method-function-needs-next-methods-p (method-function) (method-function-get method-function :needs-next-methods-p t)) (defmacro method-function-closure-generator (method-function) `(method-function-get ,method-function 'closure-generator)) (defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol) (when (listp name) (do-standard-defsetf-1 (cadr name))) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs ':method-spec) (make-method-spec name quals specls)))) (setf (getf initargs ':method-spec) method-spec) (record-definition 'method method-spec) (load-defmethod-internal class name quals specls ll initargs pv-table-symbol))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list initargs pv-table-symbol) (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec))) (when pv-table-symbol (setf (getf (getf initargs ':plist) :pv-table-symbol) pv-table-symbol)) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) ,(load-truename)) initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) (format *error-output* "~&At the time the method with qualifiers ~:S and~%~ specializers ~:S on the generic function ~S~%~ was compiled, the method-class for that generic function was~%~ ~S. But, the method class is now ~S, this~%~ may mean that this method was compiled improperly.~%" qualifiers specializers gf-spec method-class (class-name (class-of method)))) method)) (defun make-method-spec (gf-spec qualifiers unparsed-specializers) `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs ':function)) (method-spec (getf initargs ':method-spec)) (plist (getf initargs ':plist)) (pv-table-symbol (getf plist ':pv-table-symbol)) (pv-table nil) (mff (getf initargs ':fast-function))) (flet ((set-mf-property (p v) (when mf (setf (method-function-get mf p) v)) (when mff (setf (method-function-get mff p) v)))) (when method-spec (when mf (setq mf (set-function-name mf method-spec))) (when mff (let ((name `(,(or (get (car method-spec) 'fast-sym) (setf (get (car method-spec) 'fast-sym) (intern (format nil "FAST-~A" (car method-spec)) *the-pcl-package*))) ,@(cdr method-spec)))) (set-function-name mff name) (unless mf (set-mf-property :name name))))) (when plist (let ((snl (getf plist :slot-name-lists)) (cl (getf plist :call-list))) (when (or snl cl) (setq pv-table (intern-pv-table :slot-name-lists snl :call-list cl)) (when pv-table (set pv-table-symbol pv-table)) (set-mf-property :pv-table pv-table))) (loop (when (null plist) (return nil)) (set-mf-property (pop plist) (pop plist))) (when method (set-mf-property :method method)) (when return-function-p (or mf (method-function-from-fast-function mff))))))) (defun analyze-lambda-list (lambda-list) ;;(declare (values nrequired noptional keysp restp allow-other-keys-p ;; keywords keyword-parameters)) (flet ((parse-keyword-argument (arg) (if (listp arg) (if (listp (car arg)) (caar arg) (make-keyword (car arg))) (make-keyword arg)))) (let ((nrequired 0) (noptional 0) (keysp nil) (restp nil) (allow-other-keys-p nil) (keywords ()) (keyword-parameters ()) (state 'required)) (dolist (x lambda-list) (if (memq x lambda-list-keywords) (case x (&optional (setq state 'optional)) (&key (setq keysp 't state 'key)) (&allow-other-keys (setq allow-other-keys-p 't)) (&rest (setq restp 't state 'rest)) (&aux (return t)) (otherwise (error "Encountered the non-standard lambda list keyword ~S." x))) (ecase state (required (incf nrequired)) (optional (incf noptional)) (key (push (parse-keyword-argument x) keywords) (push x keyword-parameters)) (rest ())))) (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords) (reverse keyword-parameters))))) (defun keyword-spec-name (x) (let ((key (if (atom x) x (car x)))) (if (atom key) (intern (symbol-name key) (find-package "KEYWORD")) (car key)))) (defun ftype-declaration-from-lambda-list (lambda-list #+cmu name) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* (#+cmu (old (c::info function type name)) #+cmu (old-ftype (if (c::function-type-p old) old nil)) #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype))) #+cmu (old-keys (and old-ftype (mapcar #'c::key-info-name (c::function-type-keywords old-ftype)))) #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype))) #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype))) (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords)) #-cmu (mapcar #'keyword-spec-name keywords))) `(function ,(append (make-list nrequired :initial-element 't) (when (plusp noptional) (append '(&optional) (make-list noptional :initial-element 't))) (when (or restp #+cmu old-restp) '(&rest t)) (when (or keysp #+cmu old-keysp) (append '(&key) (mapcar #'(lambda (key) `(,key t)) keywords) (when (or allow-other-keys-p #+cmu old-allowp) '(&allow-other-keys))))) *)))) (defun proclaim-defgeneric (spec lambda-list) #-cmu (declare (ignore lambda-list)) (when (consp spec) (setq spec (get-setf-function-name (cadr spec)))) (let (#+cmu (decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec) ,spec))) #+cmu (proclaim decl) #+kcl (setf (get spec 'compiler::proclaimed-closure) t))) ;;;; Early generic-function support ;;; ;;; (defvar *early-generic-functions* ()) (defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys) (declare (ignore environment)) #+copy-&rest-arg (setq all-keys (copy-list all-keys)) (let ((existing (and (gboundp function-specifier) (gdefinition function-specifier)))) (if (and existing (eq *boot-state* 'complete) (null (generic-function-p existing))) (generic-clobbers-function function-specifier) (apply #'ensure-generic-function-using-class existing function-specifier all-keys)))) (defun generic-clobbers-function (function-specifier) #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier) #-Lispm (error "~S already names an ordinary function or a macro,~%~ you may want to replace it with a generic function, but doing so~%~ will require that you decide what to do with the existing function~%~ definition.~%~ The PCL-specific function MAKE-SPECIALIZABLE may be useful to you." function-specifier)) #+Lispm (zl:defflavor generic-clobbers-function (name) (si:error) :initable-instance-variables) #+Lispm (zl:defmethod #+Genera (dbg:report generic-clobbers-function) #+ti (generic-clobbers-function :report) (stream) (format stream "~S aready names a ~a" name (if (and (symbolp name) (macro-function name)) "macro" "function"))) #+Genera (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) () "Make it specializable anyway?" (make-specializable name)) #+ti (zl:defmethod (generic-clobbers-function :case :proceed-asking-user :specialize-it) (continuation ignore) "Make it specializable anyway?" (make-specializable name) (funcall continuation :specialize-it)) (defvar *sgf-wrapper* (#+cmu17 boot-make-wrapper #-cmu17 make-wrapper (early-class-size 'standard-generic-function) #+cmu17 'standard-generic-function)) (defvar *sgf-slots-init* (map 'vector #'(lambda (canonical-slot) (if (memq (getf canonical-slot :name) '(arg-info source)) *slot-unbound* (let ((initfunction (getf canonical-slot :initfunction))) (if initfunction (funcall initfunction) *slot-unbound*)))) (early-collect-inheritance 'standard-generic-function))) (defvar *sgf-method-class-index* (bootstrap-slot-index 'standard-generic-function 'method-class)) (defun early-gf-p (x) (and (fsc-instance-p x) (eq (instance-ref (get-slots x) *sgf-method-class-index*) *slot-unbound*))) (defvar *sgf-methods-index* (bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) `(instance-ref (get-slots ,gf) *sgf-methods-index*)) (defvar *sgf-arg-info-index* (bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) `(instance-ref (get-slots ,gf) *sgf-arg-info-index*)) (defvar *sgf-dfun-state-index* (bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info (:conc-name nil) (:constructor make-arg-info ())) (arg-info-lambda-list :no-lambda-list) arg-info-precedence arg-info-metatypes arg-info-number-optional arg-info-key/rest-p arg-info-keywords ;nil no keyword or rest allowed ;(k1 k2 ..) each method must accept these keyword arguments ;T must have &key or &rest gf-info-simple-accessor-type ; nil, reader, writer, boundp (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info gf-info-static-c-a-m-emf (gf-info-c-a-m-emf-std-p t) gf-info-fast-mf-p) #+cmu (declaim (ext:freeze-type arg-info)) (defun arg-info-valid-p (arg-info) (not (null (arg-info-number-optional arg-info)))) (defun arg-info-applyp (arg-info) (or (plusp (the fixnum (arg-info-number-optional arg-info))) (arg-info-key/rest-p arg-info))) (defun arg-info-number-required (arg-info) (length (arg-info-metatypes arg-info))) (defun arg-info-nkeys (arg-info) (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info))) ;;; Keep pages clean by not setting if the value is already the same. (defmacro esetf (pos val) (let ((valsym (gensym "value"))) `(let ((,valsym ,val)) (unless (equal ,pos ,valsym) (setf ,pos ,valsym))))) (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf))) (methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf))) (was-valid-p (integerp (arg-info-number-optional arg-info))) (first-p (and new-method (null (cdr methods))))) (when (and (not lambda-list-p) methods) (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list lambda-list) (when (and methods (not first-p)) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) (gf-key/rest-p (arg-info-key/rest-p arg-info))) (unless (and (= nreq gf-nreq) (= nopt gf-nopt) (eq (or keysp restp) gf-key/rest-p)) (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) (when lambda-list-p (esetf (arg-info-lambda-list arg-info) lambda-list)) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) (esetf (arg-info-precedence arg-info) (compute-precedence lambda-list nreq argument-precedence-order))) (esetf (arg-info-metatypes arg-info) (make-list nreq)) (esetf (arg-info-number-optional arg-info) nopt) (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) (esetf (arg-info-keywords arg-info) (if lambda-list-p (if allow-other-keys-p t keywords) (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) arg-info)) (defun check-method-arg-info (gf arg-info method) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) (flet ((lose (string &rest args) (error "Attempt to add the method ~S to the generic function ~S.~%~ But ~A" method gf (apply #'format nil string args))) (compare (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) (gf-nopt (arg-info-number-optional arg-info)) (gf-key/rest-p (arg-info-key/rest-p arg-info)) (gf-keywords (arg-info-keywords arg-info))) (unless (= nreq gf-nreq) (lose "the method has ~A required arguments than the generic function." (compare nreq gf-nreq))) (unless (= nopt gf-nopt) (lose "the method has ~S optional arguments than the generic function." (compare nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) (error "the method and generic function differ in whether they accept~%~ rest or keyword arguments.")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every #'(lambda (k) (memq k keywords)) gf-keywords)) (lose "the method does not accept each of the keyword arguments~%~ ~S." gf-keywords))))))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) (let* ((existing-p (and methods (cdr methods) new-method)) (nreq (length (arg-info-metatypes arg-info))) (metatypes (if existing-p (arg-info-metatypes arg-info) (make-list nreq))) (type (if existing-p (gf-info-simple-accessor-type arg-info) nil))) (when (arg-info-valid-p arg-info) (dolist (method (if new-method (list new-method) methods)) (let* ((specializers (if (or (eq *boot-state* 'complete) (not (consp method))) (method-specializers method) (early-method-specializers method t))) (class (if (or (eq *boot-state* 'complete) (not (consp method))) (class-of method) (early-method-class method))) (new-type (when (and class (or (not (eq *boot-state* 'complete)) (eq (generic-function-method-combination gf) *standard-method-combination*))) (cond ((eq class *the-class-standard-reader-method*) 'reader) ((eq class *the-class-standard-writer-method*) 'writer) ((eq class *the-class-standard-boundp-method*) 'boundp))))) (setq metatypes (mapcar #'raise-metatype metatypes specializers)) (setq type (cond ((null type) new-type) ((eq type new-type) type) (t nil))))) (esetf (arg-info-metatypes arg-info) metatypes) (esetf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) (if (early-gf-p gf) (values t t) (compute-applicable-methods-emf gf)) (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) (esetf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) (early-gf-name gf)))) (esetf (gf-precompute-dfun-and-emf-p arg-info) (let* ((sym (if (atom name) name (cadr name))) (pkg-list (cons *the-pcl-package* (package-use-list *the-pcl-package*)))) (and sym (symbolp sym) (not (null (memq (symbol-package sym) pkg-list))) (not (find #\space (symbol-name sym)))))))) (esetf (gf-info-fast-mf-p arg-info) (or (not (eq *boot-state* 'complete)) (let* ((method-class (generic-function-method-class gf)) (methods (compute-applicable-methods #'make-method-lambda (list gf (class-prototype method-class) '(lambda) nil)))) (and methods (null (cdr methods)) (let ((specls (method-specializers (car methods)))) (and (classp (car specls)) (eq 'standard-generic-function (class-name (car specls))) (classp (cadr specls)) (eq 'standard-method (class-name (cadr specls))))))))) arg-info) ;;; ;;; This is the early definition of ensure-generic-function-using-class. ;;; ;;; The static-slots field of the funcallable instances used as early generic ;;; functions is used to store the early methods and early discriminator code ;;; for the early generic function. The static slots field of the fins ;;; contains a list whose: ;;; CAR - a list of the early methods on this early gf ;;; CADR - the early discriminator code for this method ;;; (defun ensure-generic-function-using-class (existing spec &rest keys &key (lambda-list nil lambda-list-p) &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) existing) ((assoc spec *generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing) (error "The function ~S is not already defined" spec))) (existing (error "~S should be on the list ~S" spec '*generic-function-fixups*)) (t (pushnew spec *early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p function) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function (if (eq spec 'print-object) (fin-lambda-fn (instance stream) (printing-random-thing (instance stream) (format stream "std-instance"))) (fin-lambda-fn (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ has not been set" fin))))) (setf (gdefinition spec) fin) (bootstrap-set-slot 'standard-generic-function fin 'name spec) (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename)) (set-function-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p (proclaim-defgeneric spec lambda-list) (set-arg-info fin :lambda-list lambda-list))) fin)) (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) (setf (gf-dfun-state gf) new-state) (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) dfun) (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cadr state))))) (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) (gf-dfun-state gf) (instance-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) (cons (cddr state))))) (defvar *sgf-name-index* (bootstrap-slot-index 'standard-generic-function 'name)) (defun early-gf-name (gf) (instance-ref (get-slots gf) *sgf-name-index*)) (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) (if (eq ':no-lambda-list (arg-info-lambda-list arg-info)) (let ((methods (if (eq *boot-state* 'complete) (generic-function-methods gf) (early-gf-methods gf)))) (if (null methods) (progn (warn "No way to determine the lambda list for ~S." gf) nil) (let* ((method (car (last methods))) (ll (if (consp method) (early-method-lambda-list method) (method-lambda-list method))) (k (member '&key ll))) (if k (append (ldiff ll (cdr k)) '(&allow-other-keys)) ll)))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) `(progn (cond ((symbolp ,gf-class) (setq ,gf-class (find-class ,gf-class t ,env))) ((classp ,gf-class)) (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ class nor a symbol that names a class." ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) (unless (eq combin '.shes-not-there.) (setf (getf ,all-keys :method-combination) (find-method-combination (class-prototype ,gf-class) (car combin) (cdr combin))))) )) (defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function gf-class-p) &allow-other-keys) #+copy-&rest-arg (setq all-keys (copy-list all-keys)) (real-ensure-gf-internal generic-function-class all-keys environment) (unless (or (null gf-class-p) (eq (class-of existing) generic-function-class)) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) (when lambda-list-p (proclaim-defgeneric function-specifier lambda-list)))) (defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment (lambda-list nil lambda-list-p) (generic-function-class 'standard-generic-function) &allow-other-keys) (declare (ignore existing)) #+copy-&rest-arg (setq all-keys (copy-list all-keys)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 (setf (gdefinition function-specifier) (apply #'make-instance generic-function-class :name function-specifier all-keys)) (when lambda-list-p (proclaim-defgeneric function-specifier lambda-list)))) (defun get-generic-function-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) (gf-arg-info gf))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes arg-info)) (values (length metatypes) applyp metatypes (count-if #'(lambda (x) (neq x 't)) metatypes) arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc &optional slot-name) (initialize-method-function initargs) (let ((parsed ()) (unparsed ())) ;; Figure out whether we got class objects or class names as the ;; specializers and set parsed and unparsed appropriately. If we ;; got class objects, then we can compute unparsed, but if we got ;; class names we don't try to compute parsed. ;; ;; Note that the use of not symbolp in this call to every should be ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. (if (every #'(lambda (s) (not (symbolp s))) specializers) (setq parsed specializers unparsed (mapcar #'(lambda (s) (if (eq s 't) 't (class-name s))) specializers)) (setq unparsed specializers parsed ())) (list :early-method ;This is an early method dammit! (getf initargs ':function) (getf initargs ':fast-function) parsed ;The parsed specializers. This is used ;by early-method-specializers to cache ;the parse. Note that this only comes ;into play when there is more than one ;early method on an early gf. (list class ;A list to which real-make-a-method qualifiers ;can be applied to make a real method arglist ;corresponding to this early one. unparsed initargs doc slot-name) ))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc &optional slot-name) (setq specializers (parse-specializers specializers)) (apply #'make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers specializers :documentation doc :slot-name slot-name :allow-other-keys t initargs)) (defun early-method-function (early-method) (values (cadr early-method) (caddr early-method))) (defun early-method-class (early-method) (find-class (car (fifth early-method)))) (defun early-method-standard-accessor-p (early-method) (let ((class (first (fifth early-method)))) (or (eq class 'standard-reader-method) (eq class 'standard-writer-method) (eq class 'standard-boundp-method)))) (defun early-method-standard-accessor-slot-name (early-method) (seventh (fifth early-method))) ;;; ;;; Fetch the specializers of an early method. This is basically just a ;;; simple accessor except that when the second argument is t, this converts ;;; the specializers from symbols into class objects. The class objects ;;; are cached in the early method, this makes bootstrapping faster because ;;; the class objects only have to be computed once. ;;; NOTE: ;;; the second argument should only be passed as T by early-lookup-method. ;;; this is to implement the rule that only when there is more than one ;;; early method on a generic function is the conversion from class names ;;; to class objects done. ;;; the corresponds to the fact that we are only allowed to have one method ;;; on any generic function up until the time classes exist. ;;; (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) (eq (car early-method) :early-method)) (cond ((eq objectsp 't) (or (fourth early-method) (setf (fourth early-method) (mapcar #'find-class (cadddr (fifth early-method)))))) (t (cadddr (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) (cadr (fifth early-method))) (defun early-method-lambda-list (early-method) (caddr (fifth early-method))) (defun early-add-named-method (generic-function-name qualifiers specializers arglist &rest initargs) #+copy-&rest-arg (setq initargs (copy-list initargs)) (let* ((gf (ensure-generic-function generic-function-name)) (existing (dolist (m (early-gf-methods gf)) (when (and (equal (early-method-specializers m) specializers) (equal (early-method-qualifiers m) qualifiers)) (return m)))) (new (make-a-method 'standard-method qualifiers arglist specializers initargs ()))) (when existing (remove-method gf existing)) (add-method gf new))) ;;; ;;; This is the early version of add-method. Later this will become a ;;; generic function. See fix-early-generic-functions which has special ;;; knowledge about add-method. ;;; (defun add-method (generic-function method) (when (not (fsc-instance-p generic-function)) (error "Early add-method didn't get a funcallable instance.")) (when (not (and (listp method) (eq (car method) :early-method))) (error "Early add-method didn't get an early method.")) (push method (early-gf-methods generic-function)) (set-arg-info generic-function :new-method method) (unless (assoc (early-gf-name generic-function) *generic-function-fixups* :test #'equal) (update-dfun generic-function))) ;;; ;;; This is the early version of remove method. ;;; (defun remove-method (generic-function method) (when (not (fsc-instance-p generic-function)) (error "Early remove-method didn't get a funcallable instance.")) (when (not (and (listp method) (eq (car method) :early-method))) (error "Early remove-method didn't get an early method.")) (setf (early-gf-methods generic-function) (remove method (early-gf-methods generic-function))) (set-arg-info generic-function) (unless (assoc (early-gf-name generic-function) *generic-function-fixups* :test #'equal) (update-dfun generic-function))) ;;; ;;; And the early version of get-method. ;;; (defun get-method (generic-function qualifiers specializers &optional (errorp t)) (if (early-gf-p generic-function) (or (dolist (m (early-gf-methods generic-function)) (when (and (or (equal (early-method-specializers m nil) specializers) (equal (early-method-specializers m 't) specializers)) (equal (early-method-qualifiers m) qualifiers)) (return m))) (if errorp (error "Can't get early method.") nil)) (real-get-method generic-function qualifiers specializers errorp))) (defvar *fegf-debug-p* nil) (defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*)) (setq *fegf-started-p* t) (let ((accessors nil)) ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions. (dolist (early-gf-spec *early-generic-functions*) (when (every #'early-method-standard-accessor-p (early-gf-methods (gdefinition early-gf-spec))) (push early-gf-spec accessors))) (dolist (spec (nconc accessors '(accessor-method-slot-name generic-function-methods method-specializers specializerp specializer-type specializer-class slot-definition-location slot-definition-name class-slots gf-arg-info class-precedence-list slot-boundp-using-class (setf slot-value-using-class) slot-value-using-class structure-class-p standard-class-p funcallable-standard-class-p specializerp))) (setq *early-generic-functions* (cons spec (delete spec *early-generic-functions* :test #'equal)))) (dolist (early-gf-spec *early-generic-functions*) (when noisyp (format t "~&~S..." early-gf-spec)) (let* ((gf (gdefinition early-gf-spec)) (methods (mapcar #'(lambda (early-method) (let ((args (copy-list (fifth early-method)))) (setf (fourth args) (early-method-specializers early-method t)) (apply #'real-make-a-method args))) (early-gf-methods gf)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) (set-methods gf methods))) (dolist (fns *early-functions*) (setf (gdefinition (car fns)) (symbol-function (caddr fns)))) (dolist (fixup *generic-function-fixups*) (let* ((fspec (car fixup)) (gf (gdefinition fspec)) (methods (mapcar #'(lambda (method) (let* ((lambda-list (first method)) (specializers (second method)) (method-fn-name (third method)) (fn-name (or method-fn-name fspec)) (fn (symbol-function fn-name)) (initargs (list :function (set-function-name #'(lambda (args next-methods) (declare (ignore next-methods)) (apply fn args)) `(call ,fn-name))))) (declare (type function fn)) (make-a-method 'standard-method () lambda-list specializers initargs nil))) (cdr fixup)))) (setf (generic-function-method-class gf) *the-class-standard-method*) (setf (generic-function-method-combination gf) *standard-method-combination*) (set-methods gf methods))))) ;;; ;;; parse-defmethod is used by defmethod to parse the &rest argument into ;;; the 'real' arguments. This is where the syntax of defmethod is really ;;; implemented. ;;; (defun parse-defmethod (cdr-of-form) ;;(declare (values name qualifiers specialized-lambda-list body)) (let ((name (pop cdr-of-form)) (qualifiers ()) (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) (push (pop cdr-of-form) qualifiers) (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) (defun parse-specializers (specializers) (flet ((parse (spec) (let ((result (specializer-from-type spec))) (if (specializerp result) result (if (symbolp spec) (error "~S used as a specializer,~%~ but is not the name of a class." spec) (error "~S is not a legal specializer." spec)))))) (mapcar #'parse specializers))) (defun unparse-specializers (specializers-or-method) (if (listp specializers-or-method) (flet ((unparse (spec) (if (specializerp spec) (let ((type (specializer-type spec))) (if (and (consp type) (eq (car type) 'class)) (let* ((class (cadr type)) (class-name (class-name class))) (if (eq class (find-class class-name nil)) class-name type)) type)) (error "~S is not a legal specializer." spec)))) (mapcar #'unparse specializers-or-method)) (unparse-specializers (method-specializers specializers-or-method)))) (defun parse-method-or-spec (spec &optional (errorp t)) ;;(declare (values generic-function method method-name)) (let (gf method name temp) (if (method-p spec) (setq method spec gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp (intern-function-name (make-method-spec temp (method-qualifiers method) (unparse-specializers (method-specializers method)))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) (and (setq gf (and (or errorp (gboundp gf-spec)) (gdefinition gf-spec))) (let ((nreq (compute-discriminating-function-arglist-info gf))) (setq specls (append (parse-specializers specls) (make-list (- nreq (length specls)) :initial-element *the-class-t*))) (and (setq method (get-method gf quals specls errorp)) (setq name (intern-function-name (make-method-spec gf-spec quals specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list) (multiple-value-bind (parameters ignore1 ignore2) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) parameters)) (defun extract-lambda-list (specialized-lambda-list) (multiple-value-bind (ignore1 lambda-list ignore2) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) lambda-list)) (defun extract-specializer-names (specialized-lambda-list) (multiple-value-bind (ignore1 ignore2 specializers) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2)) specializers)) (defun extract-required-parameters (specialized-lambda-list) (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) (parse-specialized-lambda-list specialized-lambda-list) (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) (defun parse-specialized-lambda-list (arglist &optional post-keyword) ;;(declare (values parameters lambda-list specializers required-parameters)) (let ((arg (car arglist))) (cond ((null arglist) (values nil nil nil nil)) ((eq arg '&aux) (values nil arglist nil)) ((memq arg lambda-list-keywords) (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) ;; Warn about non-standard lambda-list-keywords, but then ;; go on to treat them like a standard lambda-list-keyword ;; what with the warning its probably ok. (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ Assuming that the symbols following it are parameters,~%~ and not allowing any parameter specializers to follow~%~ to follow it." arg)) ;; When we are at a lambda-list-keyword, the parameters don't ;; include the lambda-list-keyword; the lambda-list does include ;; the lambda-list-keyword; and no specializers are allowed to ;; follow the lambda-list-keywords (at least for now). (multiple-value-bind (parameters lambda-list) (parse-specialized-lambda-list (cdr arglist) t) (values parameters (cons arg lambda-list) () ()))) (post-keyword ;; After a lambda-list-keyword there can be no specializers. (multiple-value-bind (parameters lambda-list) (parse-specialized-lambda-list (cdr arglist) t) (values (cons (if (listp arg) (car arg) arg) parameters) (cons arg lambda-list) () ()))) (t (multiple-value-bind (parameters lambda-list specializers required) (parse-specialized-lambda-list (cdr arglist)) (values (cons (if (listp arg) (car arg) arg) parameters) (cons (if (listp arg) (car arg) arg) lambda-list) (cons (if (listp arg) (cadr arg) 't) specializers) (cons (if (listp arg) (car arg) arg) required))))))) (eval-when (load eval) (setq *boot-state* 'early)) #-cmu ;; CMUCL Has a real symbol-macrolet (progn (defmacro symbol-macrolet (bindings &body body &environment env) (let ((specs (mapcar #'(lambda (binding) (list (car binding) (variable-lexical-p (car binding) env) (cadr binding))) bindings))) (walk-form `(progn ,@body) env #'(lambda (f c e) (expand-symbol-macrolet-internal specs f c e))))) (defun expand-symbol-macrolet-internal (specs form context env) (let ((entry nil)) (cond ((not (eq context :eval)) form) ((symbolp form) (if (and (setq entry (assoc form specs)) (eq (cadr entry) (variable-lexical-p form env))) (caddr entry) form)) ((not (listp form)) form) ((member (car form) '(setq setf)) ;; Have to be careful. We must only convert the form to a SETF ;; form when we convert one of the 'logical' variables to a form ;; Otherwise we will get looping in implementations where setf ;; is a macro which expands into setq. (let ((kind (car form))) (labels ((scan-setf (tail) (if (null tail) nil (walker::relist* tail (if (and (setq entry (assoc (car tail) specs)) (eq (cadr entry) (variable-lexical-p (car tail) env))) (progn (setq kind 'setf) (caddr entry)) (car tail)) (cadr tail) (scan-setf (cddr tail)))))) (let (new-tail) (setq new-tail (scan-setf (cdr form))) (walker::recons form kind new-tail))))) ((eq (car form) 'multiple-value-setq) (let* ((vars (cadr form)) (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym)) vars))) `(multiple-value-bind ,gensyms ,(caddr form) .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g)) vars gensyms))))) (t form)))) ) (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) #+cmu (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) (let ((variable-name (if (symbolp slot-entry) slot-entry (car slot-entry))) (slot-name (if (symbolp slot-entry) slot-entry (cadr slot-entry)))) `(,variable-name (slot-value ,in ',slot-name)))) slots) ,@body)))) (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) #+cmu (declare (ignorable ,in)) ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) (third instance) instance))) (and (symbolp instance) `((declare (variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) (let ((variable-name (car slot-entry)) (accessor-name (cadr slot-entry))) `(,variable-name (,accessor-name ,in)))) slots) ,@body)))) gcl/pcl/notes/0000755000175000017500000000000012240167764012156 5ustar cammcammgcl/pcl/notes/4-29-87-notes.text0000644000175000017500000000514112240167764015042 0ustar cammcamm These notes correspond to *pcl-system-date* "4/29/87 prime April 29, 1987". The notes from the last release are stored as 4-21-notes.text This release runs in: ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) TI Common Lisp (Release 3) CMU Lisp (nee Spice) should be working soon, I will announce another release at that time. TI release 2 should also be working soon, I will announce that when it happens. Note once again, that Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. You must load PCL BEFORE loading pcl-env. MAJOR CHANGES IN THIS RELEASE: make has been renamed to make-instance make-instance has been renamed to allocate-instance for compatibility, make can continue to be used as a synonym for make-instance. unfortunately, code which used to call make-instance must be converted. I would actually suggest that you do both of these name changes right away. Two passes through the code using Query Replace seems to work quite well (changing make-instance to allocate-instance and then make to make-instance.) I was able to change all of PCL in about 10 minutes that way. --- all functions and generic functions whose name included the string "get-slot" have been renamed. Basically, get-slot was replaced everywhere it appeared with slot-value. get-slot itself still exists for compatibility, but you should start converting your code to use slot-value. OTHER CHANGES in this release: There is a new file called PKG which does the exports for PCL. PCL now exports fewer symbols than before. Specifically, PCL now exports only those symbols documented in the CLOS spec chapters 1 and 2. This means that some symbols which may be needed by some programs are not exported. A good example is print-instance. print-instance is not exported and since print-instance has not yet been renamed to print-object programs which define methods on print-instance may want to import that symbol. --- pcl should load faster in this release. In particular, the file fixup should load in less than half the time it did before. This release should load in something like 80% of the time it took in the last release. Remember, these numbers are only for comparison, your mileage may vary. --- This release of PCL, as well as the last one, has *pcl-system-date* which presents the date in both mm/dd/yy and Month day year format. gcl/pcl/notes/12-7-88-notes.text0000644000175000017500000000262112240167764015036 0ustar cammcammCopyright (c) Xerox Corporation 1988. All rights reserved. These notes correspond to the "12/7/88 Can't think of a cute name PCL" version of PCL. Please read this entire file carefully. You may also be interested in looking at previous versions of the notes.text file. These are called xxx-notes.text where xxx is the version of the PCL system the file corresponds to. At least the last two versions of this file contain useful information for any PCL user. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2 Coral 1.2 Lucid 3.0 KCL (October 15, 1987) Allegro 3.0.1 These three should work, but haven't been tested just yet. EnvOS Medley TI The notes file hasn't yet been fleshed out yet. The two major changes in this release are: - The generic function cache algorithm has been revised. In addition generic function caches now expand automatically. Programs that used to run into problems with lots of cache misses shouldn't run into those problems anymore. - the DEFCONSTRUCTOR hack now works. Please see the construct.lisp file for details. If you are consing lots of instances, you may be able to get a tremendous performance boost by using this hack. Another important change is that this version includes some KCL patches which dramatically improve PCL performance in KCL. See the kcl-mods.text file for more details. gcl/pcl/notes/5-22-87-notes.text0000644000175000017500000000665312240167764015045 0ustar cammcamm These notes correspond to *pcl-system-date* "5/22/87 May 22nd, 1987". The notes from the last release are stored as 4-29-notes.text This release runs in: CMU Lisp ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) TI Common Lisp (Release 3) TI release 2 should also be working soon, I will announce that when it happens. Note once again, that Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. You must load PCL BEFORE loading pcl-env. MAJOR CHANGES IN THIS RELEASE: --- it is possible to forward reference classes in a defclass (or add-named-class) form. This means it is possible to say: (defclass foo (bar) (i j k)) (defclass bar () (x y z)) Rather than having to put the in the "right" order. NOTE: the full-on error checking for this is not finished yet. don't try to break it by doing things like: (defclass foo (bar) (i j k)) (make-instance 'foo) (defclass bar () (x y z)) --- print-instance has been renamed to print-object --- the defclass and class-definition protocol has changed. some of the effects of this change are: * ADD-NAMED-CLASS is a true functional interface for defclass, so for example, (defclass foo () (x y z) (:accessor-prefix foo-)) is equivalent to: (add-named-class (class-prototype (class-named 'class)) 'foo () '(x y z) '((:accessor-prefix foo-))) * defclass (and add-named-class) now undefined accessor methods, reader methods and constructors which 'went away'. For example: (defclass foo () (x y z) (:reader-prefix foo-)) defines methods on the generic functions foo-x foo-y and foo-z. but if you then evaluated the defclass form: (defclass foo () (x y z)) those reader methods will be removed from the generic functions foo-x foo-y and foo-z. Similarly constructors which 'went away' will be undefined. --- writer methods generated by the :accessor and :accessor-prefix options now pay attention to the :type slot-option. So, (defclass foo () ((x :accessor foo-x :type symbol))) (defvar *foo-1* (make-instance 'foo)) (setf (foo-x *foo-1*) 'bar) ; is OK (setf (foo-x *foo-1*) 10) ; signals an error --- There are fewer built-in classes. Specifically, only the following Common Lisp types have classes: ARRAY BIT-VECTOR CHARACTER COMPLEX CONS FLOAT INTEGER LIST NULL NUMBER RATIO RATIONAL SEQUENCE STRING SYMBOL T VECTOR * In a future release the subtypes of FLOAT may have classes, that issue is still under discussion. * Some ports of PCL also define classes for: HASH-TABLE PACKAGE PATHNAME RANDOM-STATE READTABLE STREAM it depends on how the type is represented in that Lisp's type system. --- The with-slots option :use-slot-value is now obsolete. You should use the :use-accessors option as specified in the CLOS spec instead. with-slot forms which did not use the :use-slot-value option are OK, you don't have to touch them. with-slot forms which used :USE-SLOT-VALUE T should be changed to say :USE-ACCESSORS NIL. with-slot forms which used :USE-SLOT-VALUE NIL should be changed to use neither option, or if you insist :USE-ACCESSORS T gcl/pcl/notes/8-28-88-notes.text0000644000175000017500000005003012240167764015043 0ustar cammcammCopyright (c) Xerox Corporation 1988. All rights reserved. These notes correspond to the "8/24/88 (beta) AAAI PCL" version of PCL. Please read this entire document carefully. There have been a number of changes since the 8/2/88 version of PCL. As usual, these changes are part of our efforts to make PCL conform with the CLOS specicification (88-002R). This release contains the big changes which the 7/7 through 8/2 releases were really getting ready for. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2 Coral 1.2 Lucid 3.0 Franz ?? Xerox Lyric Xerox Medley (aka EnvOS Medley) KCL (October 15, 1987) Most of the changes in this version of PCL fall into one of two categories. The first major set of changes makes the order of arguments to setf generic functions and methods conform with the spec. In addition, these changes allow the first argument to defmethod to be of the form (SETF ). The second major set of changes have to do with slot access and instance structure. Importantly, PCL now checks to see if a slot is bound, and calls slot-unbound if the slot is unbound. This is a major change from previous releases in which slot access just returned NIL for slots which had not yet been set. These changes affect all the functions which access the slots of an instance. In addition, the generic functions which are called by the slot access functions in exceptional circumstances are affected. This set of changes also include the implemenentation of the real initialization protocol as specified by 88-002R. In addition, there are a number of other changes. The most significant of these has to do with the symbols which the PCL package exports by default. The rest of this document goes on to first describe the slot access changes, then describe the setf generic function changes, and finally describe some of the other minor changes. At the very end of this file is a new section which lists PCL features which are scheduled to disappear in future releases. Please read this section and take it to heart. This features will be disappearing. *** Changes to slot access and instance structure *** This release includes a number of changes to the way slot access works in PCL. Some of these changes are incompatible with old behavior. Code which was written with the actual CLOS spec in mind should not be affected by these incompatible changes, but some older code may be affected. The basic thrust of the changes to slot access is to bring the following functions and generic functions in line with the specification: slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound slot-value slot-boundp-using-class slot-exists-p-using-class slot-makunbound-using-class slot-value-using-class (setf slot-value) (setf slot-value-using-class) change-class make-instances-obsolete make-instance (temporarily called *make-instance) initialize-instance (temporarily called *initialize-instance) reinitialize-instance update-instance-for-different-class update-instance-for-redefined-class shared-initialize In this release, these functions accept the specified number of arguments, return the specified values, have the specified effects, and are called by the rest of PCL in the specified way at the specified times (with the exception that PCL does not yet call *make-instance to create its own metaobjects). Because PCL now checks for unbound slots, you may notice a slight performance degradation in certain applications. For complete information, you should of course see the CLOS specification. The rest of this note is a short summary of how this new behavior is different from the last release. - Dynamic slots are no longer supported. Various functions like slot-value-always and remove-slot no longer exist. Also, slot-value-using-class now only accepts the three arguments as described in the spec. The two extra arguments having to do with dynamic slots are no longer accepted. Shortly, we will release a metaclass which provides the now missing dynamic slot behavior. - slot-missing now receives and accepts different arguments. - slot-unbound is now implemented, and is called at the appropriate times. - the initialization protocol specified in 88-002R is now almost completely implemented. The only difference is that the current implementation does not currently check the validity of initargs. So, no errors are signalled in improper initargs are supplied. Because of name conflicts with the two other initialization protocols PCL currently supports, some of the specified initialization functions do not have their proper name. The mapping between names in the specification and names in this version of PCL is as follows: SPECIFIED IN PCL make-instance *make-instance initialize-instance *initialize-instance reinitialize-instance update-instance-for-different-class update-instance-for-redefined-class shared-initialize In a future release of PCL, these functions will have their proper names, and all the old, obsolete initialization protocols will disappear. Convert to using this new wonderful initialization protocol soon. Sometime soon we will release a version of PCL which does significant optimization of calls to make-instance. This should speed up instance creation dramatically, which should significantly improve the performance of some programs. - The function all-slots no longer exists. There is a new generic function called slots-to-inspect, which controls the default behavior of describe. It also controls the default behavior of the inspector in ports which have connected their inspectors to PCL. It specifies which slots of a given class should be inspected. See the definition in the file high.lisp for more. - the metaclass obsolete-class no longer exists. The mechanism by which instances are marked as being obsolete is now internal, as described in the spec. The generic-function make-instances-obsolete can be used to force the instances of a class to go through the obsolete instance update protocol (see update-instance-for-redefined-class). - all-std-class-readers-miss-1, a generic function which was part of the database interface code I sent out a few weeks ago, has a slightly different argument list. People using the code I sent out a few weeks ago should replace the definition there with: (defmethod all-std-class-readers-miss-1 ((class db-class) wrapper slot-name) (declare (ignore wrapper slot-name)) ()) - The implementation of the slot access generic functions have been considerably streamlined. The impenetrable macrology which used to be used is now gone. - Because the behavior of the underlying slot access generic functions has changed, it is possible that some user code which hacks the underlying instance structure may break. Most of this code shouldn't break though. There have been some questions on the mailing list about what is the right way to modify the structure of an instance. I am working on that section of chapter 3 right now, and will answer those questions sometime soon. *** Changes to SETF generic functions *** This release of PCL includes a significant change related to the order of arguments of setf generic functions. To most user programs, this change should be invisible. Your program should run just fine in the new version of PCL. Even so, there is some conversion you should do to your program, since DEFMETHOD-SETF is now obsolete and will be going away soon. Some programs may take some work to adapt to this change. This will be particularly true of programs which manipulated methods for setf generic-functions using make-instance, add-method and friends. Included here is a brief overview of this change to PCL. Most people will find that this is all they need to know about this change. The CLOS specification assumes a default behavior for SETF in the absence of any defsetf or define-modify-macro. The default behavior is to expand forms like: (SETF (FOO x y) a) into: (FUNCALL #'(SETF FOO) a x y) The key point is that by default, setf expands into a call to a function with a well-defined name, and that in that call, the new value argument comes before all the other arguments. This requires a change in PCL, because previously, PCL arranged for the new-value argument to be the last required argument. This change affects the way automatically generated writer methods work, and the way that defmethod with a first argument of the form (SETF ) works. An important point is that I cannot implement function names of the form (SETF ) portably in PCL. As a result, in PCL, I am using names of the form |SETF FOO|. Note that the symbol |SETF FOO| is interned in the home package of the symbol FOO. (See the description of the GET-SETF-FUNCTION and GET-SETF-FUNCTION-NAME). The user-visible changes are: - DEFMETHOD will accept lists of the form (SETF FOO) as a first argument. This will define methods on the generic function named by the symbol |SETF FOO|. As specified in the spec, these methods should expect to receive the new-value as their first argument. Calls to defmethod of this form will also arrange for SETF of FOO to expand into an appropriate call to |SETF FOO|. - Automatically generated writer methods will expect to receive the new value as their first argument. - DEFMETHOD-SETF will also place the new-value as the first argument. This is for backward compatibility, since defmethod-setf itself will be obsolete, and you should convert your code to stop using it. - GET-SETF-FUNCTION is a function which takes a function name and returns the setf function for that function if there is one. Note that it doesn't take an environment argument. Note that this function is not specified in Common Lisp or CLOS. PCL will continue to support it as an extra export indefinetely. - GET-SETF-FUNCTION-NAME is a function which takes a function name and returns the symbol which names the setf function for that function. Note that this function is not specified in Common Lisp or CLOS. PCL will continue to support it as an extra export indefinetely. - For convenience, PCL defines a macro called DO-STANDARD-DEFSETF which can be used to do the appropriate defsetf. This may be helpful for programs which have calls to setf of a generic-function before any of the generic function's method definitions. A use of this macro looks like: (do-standard-defsetf position-x) Afterwards, a form like (SETF (POSITION-X P) V) will expand into a form like (|SETF POSITION-X| V P). The reason you may have to use do-standard-defsetf is that I cannot portably change every implementations SETF to have the new default behavior. The proper way to use this is to take an early file in your system, and put a bunch of calls to do-standard-defsetf in it. Note that as soon as PCL sees a defmethod with a name argument of the form (SETF FOO), or it sees a :accessor in a defclass, it will do an appropriate do-standard-defsetf for you. In summary, the only things that will need to be changed in most programs is that uses of defmethod-setf should be converted to appropriate uses of defmethod. Here is an example of a typical user program which is affected by this change. (defclass position () ((x :initform 0 :accessor pos-x) (y :initform 0 :accessor pos-y))) (defclass monitored-position (position) ()) (defmethod-setf pos-x :before ((p monitored-position)) (new) (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) (defmethod-setf pos-y :before ((p monitored-position)) (new) (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) To bring this program up to date, you should convert the two defmethod-setf forms as follows: (defmethod (setf pos-x) :before (new (p monitored-position)) (format *trace-output* "~&Changing x coord of ~S to ~D." p new)) (defmethod (setf pos-y) :before (new (p monitored-position)) (format *trace-output* "~&Changing y coord of ~S to ~D." p new)) *** Other changes in this release *** * The symbols exported by the PCL package have now changed. The PCL package now exports the symbols listed in the table of contents of chapter 2 of the spec. This list of symbols is the value of the variable pcl::*exports*. Following is the list of symbols which were exported in the 8/2/88 version but which are not exported in the 8/18/88 version. DEFMETHOD-SETF DEFGENERIC-OPTIONS DEFGENERIC-OPTIONS-SETF CLASS-CHANGED CLASS-NAMED SYMBOL-CLASS CBOUNDP GET-METHOD GET-SETF-GENERIC-FUNCTION MAKE-METHOD-CALL Following is the list of symbols which are exported in the 8/18/88 version, but which were not exported in previous versions: CALL-METHOD CLASS-NAME COMPUTE-APPLICABLE-METHODS DEFGENERIC ENSURE-GENERIC-FUNCTION FIND-METHOD FUNCTION-KEYWORDS GENERIC-FLET GENERIC-LABELS INITIALIZE-INSTANCE MAKE-INSTANCES-OBSOLETE NO-APPLICABLE-METHOD NO-NEXT-METHOD REINITIALIZE-INSTANCE SHARED-INITIALIZE SLOT-BOUNDP SLOT-EXISTS-P SLOT-MAKUNBOUND SLOT-MISSING SLOT-UNBOUND SYMBOL-MACROLET UPDATE-INSTANCE-FOR-DIFFERENT-CLASS UPDATE-INSTANCE-FOR-REDEFINED-CLASS WITH-ADDED-METHODS It should be noted that not all of these newly exported symbols have been "implemented" yet. * Any program written using PCL will need to be completely recompiled to run with this release of PCL. * The generic-function generic-function-pretty-arglist now returns a nice arglist for any generic function. It combines all the keyword arguments accepted by the methods to get the combined set of keywords. In some ports, the environment specific ARGLIST function has been connected to this, and so the environments will print out nice arglists for generic functions. * Some bugs in trace-method have been fixed. Trace-method should now work in all ports of PCL. * NO-MATCHING-METHOD has been renamed to NO-APPLICABLE-METHOD. In addition, it now receives arguments as specified. * defmethod has been modified to allow macros which expand into declarations. * The :documentation slot option is now accepted in defclass forms. The documentation string put here cannot yet be retrieved using the documentation function. That will happen in a later release. * The :writer slot option is now implemented. * Some brain damage in high.lisp which caused method lookup to work incorrectly for built in classes. In addition, it caused the class-local-supers and class-direct-subclasses of the built in classes to be strange. People using CLOS browsers should notice this change dramatically, as it will make the browse of the built in part of the class lattice look right. *** Older Changes *** Following are changes which appeared in release of PCL from 7/7/88 to 8/2/88. Each change is marked with the release it appeared in. 8/2/88 Loading defclass forms should be much faster now. The bug which caused all the generic functions in the world to be invalidated whenever a class was defined has now been fixed. Loading defmethod forms should also be much faster. A bug which caused a tremendous amount of needles computation whenever a method was also fixed. 8/2/88 A bug which caused several slots of the classes T, OBJECT, CLASS and STANDARD-CLASS to be unbound has been fixed. 8/1/88 load-pcl now adds the symbols :PCL and :PORTABLE-COMMONLOOPS to *features*. PCL still doesn't do any sort of call to PROVIDE because of the total lack of uniformity in the behavior of require and provide in the various common lisp implementations. 8/1/88 This version of PCL finally fixes the horrible bug that prevented the initform for :class allocation slots from being evaluated when the class was defined. 7/20/88 PCL now converts the function describe into a generic function of one argument. This is to bring it into conformance with the spec as described in 88-002. In Symbolics Genera, it is actually a function of one required and one optional argument. This is because the 3600 sometimes calls describe with more than one argument. In Lucid Lisp, describe only takes an optional argument. This argument defaults to the value of *. PCL converts describe to a generic function of one required argument so it is not possible to call describe with only one argument. 7/7/88 class-named and symbol-class have been replaced by find-class. find-class is documented in 88-002R. 7/7/88 with-slots and with-accessors now conform to 88-002R. The old definition of with-slots is now called obsolete-with-slots. The same is true for with-accessors. with-slots ---> obsolete-with-slots with-accessors --> obsolete-with-accessors The temporary correct definition of with-slots, with-slots* is now called with-slots. The same is true for with-accessors*. with-slots* --> with-slots with-accessors* -> with-accessors 7/7/88 The class-precedence list of the class null now conforms to 88-002R. In previous releases of PCL, the class precedence-list of the class null was: (null list symbol sequence t). In this release the class precedence list of the class null is: (null symbol list sequence t). This change was made to bring PCL into conformance with the spec. 7/7/88 print-object now takes only two arguments. This changes was made to begin bringing print-object in conformance with 88-002R. print-object conforms to the spec to the extent that is is called at the approrpiate times for PCL instances. In most implementations, it is not called at the appropriate times for other instances. This is not under my control, encourage your vendor to provide the proper support for print-object. 7/7/88 This version of PCL now includes a beta test version of a new iteration package. This iteration package was designed by Pavel Curtis and implemented by Bill vanMelle. This iteration package is defined in the file iterate.lisp. Please feel free to experiment with it. We are all very interested in comments on its use. *** PCL Features that will be disappearing *** This section describes features in PCL that will be disappearing in future releases. For each change, I try to give a release date after which I will feel free to remove this feature. This list should not be considered complete. Certain other PCL features will disappear as well. The items on this list are the user-interface level items that it is possible to give a lot of warning about. Other changes will have more subtle effects, for example when the lambda-list congruence rules are implemented. - :accessor-prefix in defclass Can disappear anytime after 8/29. Warning that this is obsolete has been out for some time. You should use :accessor in each of the slot specifications of the defclass form. It is true that this is slightly more cumbersome, but the semantic difficulties associated with :accesor-prefix are even worse. - :constructor in defclass Can disappear anytime after 8/29. Warning that this is obsolete has been out for some time. It will be disappearing shortly because the intialization protocol which it goes with will be disappearing. A future release of PCL will support a special mechanism for defining functions of the form: (defun make-foo (x y &optional z) (make-instance 'foo 'x x :y y :z z)) In the case where there are only :after methods on initialize-instance and shared-initialize, these functions will run like the wind. We hope to release this facility by 9/15. - old definition of make-instance, intialize, initialize-from-defaults, initialize-from-init-plist Can disappear anytime after 8/29. Convert to using the new initialization protocol as described in the spec and above. - mki, old definition of initialize-instance Can disappear anytime after 8/29. Convert to using the new initialization protocol as described in the spec and above. - defmethod-setf Can disappear anytime after 9/15. Convert to using (defmethod (setf foo) ... gcl/pcl/notes/readme.text0000644000175000017500000000067512240167764014331 0ustar cammcammPlease read the file get-pcl.text carefully, it contains the most up to date version of the message you received when you first asked about PCL. You should read it when you get each new release because it will contain any new information about PCL distribution or documentation. Also whenever there is a new release, you should read the notes.text file carefully. To install PCL at your site, follow the instructions in the defsys.lisp file. gcl/pcl/notes/5-22-89-notes.text0000644000175000017500000001242212240167764015036 0ustar cammcammCopyright (c) Xerox Corporation 1989. All rights reserved. These notes correspond to the "5/22/89 Victoria PCL" version of PCL. Please read this entire file carefully. Failure to do so guarantees that you will have problems porting your code from the previous release of PCL. You may also be interested in looking at previous versions of the notes.text file. These are called xxx-notes.text where xxx is the version of the PCL system the file corresponds to. At least the last two versions of this file contain useful information for any PCL user. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2, 7.4 Coral 1.2 Lucid 3.0 IBCL (October 15, 1987) Allegro 3.0.1 Golden Common Lisp 3.1 EnvOS Medley These should work, but haven't been tested yet: TI This release is similar to Cinco de Mayo and Passover PCL. The major difference is that this release actually works. *** *other-exports* flushed. More exports now on *exports* The symbol STANDARD is now exported from the PCL package. standard-class standard-method standard-generic-function standard-object built-in-class structure-class scoping problem with *next-methods* method and generic function initialization protocol methods are immutable type-specifiers --> specializers load-truename etc. defgeneric ensure-generic-function define-method-combination metabraid changes file namings *** There are a number of minor and one major difference between this release and No Cute Name PCL. - In the last release there was an implementation of the specified CLOS initialization protocol. This implementation had the correct behavior, but some of the generic functions had temporary names (*make-instance, *initialize-instance and *default-initargs). This was done to give people time to convert their code to the behavior of the new initialization protocol. In this release, all generic functions in the specified initialization protocol have their proper names. The implementation of the old, obsolete initialization protocol has disappeared entirely. The following renamings have happened: 12/7/88 release this release *make-instance make-instance *initialize-instance initialize-instance *default-initargs default-initargs The functions shared-initialize and reinitialize-instance already had the proper names. The new initialization protocol is documented fully in the 88-002R specification. As part of this change, PCL now uses the new initialization protocol to create metaobjects internally. That is it calls make-instance to create these metaobjects. The actual initargs passed are not yet as specified, that will be in a later release. This is the largest change in this release. If you have not already started using the new initialization protocol (with the temporary *xxx names) you are going to have to do so now. In most cases, old methods on the generic functions INITIALIZE, INITIALIZE-FROM-DEFAULTS and INITIALIZE-FROM-INIT-PLIST must be substantially rewritten to convert them to methods on INITIALIZE and SHARED-INITIALIZE. - slots with :ALLOCATION, :CLASS now inherit properly. As part of this change, some slot description objects now return a class object as the result of SLOTD-ALLOCATION. - There is now a minimal implementation of the DEFGENERIC macro. This implementation supports no options, but it does allow you to define a generic function in one place and put some comments there with it. - The following functions and macros have disappeared. This table also show briefly what you use instead. DEFMETHOD-SETF (use DEFMETHOD) RUN-SUPER (use CALL-NEXT-METHOD) OBSOLETE-WITH-SLOTS (use WITH-SLOTS or WITH-ACCESSORS) SYMBOL-CLASS (use FIND-CLASS) CBOUNDP (use FIND-CLASS) CLASS-NAMED (use FIND-CLASS) GET-SETF-GENERIC-FUNCTION (use GDEFINITION) - In certain ports, method lookup will be faster because of a new scheme to deal with interrupts and the cache code. In other ports it will be slightly slower. In all ports, the cache code now interacts properly with interrupts. - DEFMETHOD should interact properly with TRACE, ADVISE etc. in most ports. two new port-specific functions (in defs.lisp) implement this. These are unencapsulated-fdefinition and fdefine-carefully. If this doesn't work properly in your port, fix the definition of these functions and send it back so it can be in the next release. - This release runs in Golden Common Lisp version 3.0. - Previously, the use of slot-value (or with-slots) in the body of a method which had an illegal specializer gave strange errors. Now it gives a more reasonable error message. - An annoying problem which caused KCL and friends to complain about *exports* being unbound has been fixed. - The walker has been modified to understand the ccl:%stack-block special form in Coral Common Lisp. - The use of defadvice in pre 3.0 releases has been fixed in Lucid Low. - multiple-value-setq inside of with-slots now returns the correct value. - A minor bug having to do with macroexpansion environments and the KCL walker has been fixed. - A bug in the parsing of defmethod which caused only symbols (rather than non-nil atoms) to be used as qualifiers. gcl/pcl/notes/4-21-87-notes.text0000644000175000017500000000313612240167764015034 0ustar cammcamm These notes correspond to *pcl-system-date* "4/21/87 April 21rst 1987". The notes from the last release are stored as 3-19-notes.text This release runs in: ExCL Lucid Symbolics Common Lisp (Genera) Vaxlisp (2.0) Xerox Common Lisp (Lyric Release) Kyoto Common Lisp (5.2) CMU Lisp (nee Spice) should be working soon, I will announce another release at that time. Xerox Lisp users should FTP all the source files from /pub/pcl/ as well as all the dfasl files from /pub/pcl/xerox/. Included in the xerox specific directory is a file called PCL-ENV, which provides some simple environment support for using PCL in Xerox Lisp. The major difference in this release is that defclass conforms to the CLOS specification (pretty much I hope). Previous warnings about what would happen when defclass became CLOS defclass now apply. Once major difference is that PCL currently does require that all a classes superclasses be defined when a defclass form is evaluated. This will change sometime soon. Other small changes include: Some more of the files have been renamed and restructured (as promised). the defclass parsing protocol has changed slotd datastructures are now instances of the class standard-slot-description. a performance bug in the ExCL port which causes method lookup and slot access to cons needlessly. a bug in the 3600 port which broke the printer for stack consed closures make-specializable a bug in Lucid lisp which made it impossible to say (compile-pcl) has been patched around, this is the bug that manifested itself as NAME being ubound. As usual, please enjoy and send comments. gcl/pcl/notes/may-day-notes.text0000644000175000017500000000644112240167764015560 0ustar cammcammCopyright (c) Xerox Corporation 1989, 1990. All rights reserved. These notes correspond to the "5/1/90 May Day PCL (REV 2)" version of PCL. This version is just Rainy Day PCL with the various patches people have mailed out included. Barring unforseen circumstances, this will be the last version of PCL. We are now working on the Metaobject Protocol. Please read this entire file carefully. Failure to do so guarantees that you will have problems porting your code from the previous release of PCL. You may also be interested in looking at previous versions of the notes.text file. These are called xxx-notes.text where xxx is the version of the PCL system the file corresponds to. At least the last two versions of this file contain useful information for any PCL user. This version of PCL has been tested at PARC in the following Common Lisps: Symbolics 7.2, 7.4 Coral 1.3 Lucid 3.0 Allegro 3.0.1 These should work, but haven't been tested yet: TI Golden Common Lisp 3.1 EnvOS Medley IBCL (October 15, 1987) This release of PCL is substantially different from previous releases. The architecture of the runtime system (method lookup and slot access) is different, and the metaobject protocol is different. Much of the code in this release is new or modified from the last release. When it stabilizes, this release should be much faster for all applications especially large ones. This beta version of the new release includes a number of known problems. These include: * Even less documentation than ever before. I haven't written much of a notes file for what is different yet. Please send me comments for what to include in this file. * Some known performance problems in development versions of compilers. At the very least, you want to compile PCL itself using the highest performance compiler settings you have. === Notes for this release (such as they are) === * There is one major incompatible change in this release. In this release compiling files with defmethod and defclass forms doesn't, by default, affect the running lisp image. The winning part of this is you can compile a file without `installing' the class and method definitions in the file. The losing part is that because PCL is a portable program, it can't both do this and let a class definition and a method which specializes to that class appear in the same file. So, you can't (by default) have: (defclass foo () ()) (defmethod bar ((f foo)) 'foo) in the same file. But you say you want to do this, almost everyone does. If you want to do this just evaluate the following form before after loading PCL but before working with it: (pushnew 'compile pcl::*defclass-times*) You may also want to do: (pushnew 'compile pcl::*defmethod-times*) * You probably also want to begin using a precom file for your system. Do this by having a file whose only contents is (pcl::precompile-random-code-segments ) don't quote for example, for the clim system, the precom file has the one line: (pcl::precompile-random-code-segments clim) compile this file after loading and running your system for a while. load it before loading your compiled system. A future version of this feature won't require you to have run your system for a while, it will only require that you have loaded it. gcl/pcl/notes/lap.text0000644000175000017500000006316512240167764013653 0ustar cammcamm-*- Mode: Text -*- Copyright (c) 1985, 1986, 1987, 1988, 1989 Xerox Corporation. All rights reserved. Use and copying of this document is permitted. Any distribution of this document must comply with all applicable United States export control laws. Last updated: 6/3/89 by Gregor 10/26/89 by Gregor -- added :RETURN, removed :ISHIFT This file contains documentation of the PCL abstract LAP code. Any port of PCL is required to implement the abstract LAP code interface. There is a portable, relatively good performance implementation in the file lap.lisp, port-specific implementations are in that file as well. The PCL abstract LAP code mechanism exists to provide PCL with a way to create high-performance method lookup functions. Using this mechanism, PCL can produce "LAP closures" which do the method lookup. By allowing PCL to specify these closures using abstract LAP code rather that Lisp code we hope to achieve the following: * Better runtime performance. By using abstract LAP code, we will get better machine instruction sequences than we would from compiling Lisp code. * Better load and update time performance. Because it should be possible to "assemble" the LAP code more quickly than compiling Lisp code, PCL will spend less time building the method lookup code. * Ability to use PCL without a compiler. The LAP assembler will still be required but this should be much smaller than the full lisp compiler. Of course, not all implementations of the LAP code mechanism will satisfy all of these goals. The first is the most important. In particular, many PCL ports will use the portable LAP implementation. KCL will use the portable implementation in all of its ports. Other Lisps may have custom LAP implementations for some ports and use the portable implementation for other ports. Some Lisps will have a custom LAP implementation but will nonetheless require the compiler to be loaded to generate LAP closure constructors. An important point is why we have chosen to take this route rather than have each implementation implement the method lookup codes itself. This was done because we are, at PARC, just beginning to study cache behavior for CLOS programs. As we learn more about this we will want to modify the caching strategy PCL uses. This architecture, because it leaves PCL to implement caching behavior makes it possible to do this. Once this study is complete, implementations may want to do their own, ultra high performance implementations of caching strategies. Production of LAP closures is a two step process. In the first step, a port-specific function is called to take abstract LAP code and produce a a "lap closure generator". Lap closure generators are functions which are called with a set of closure variable values and return a LAP closure. The intermediary of the lap closure generators provides an important optimization. Because it is assumed that producing the LAP closure generator can take much longer than producing a LAP closure from the generator, PCL attempts to make only one closure generator for each sequence of LAP code. Because of the way PCL generates the LAP code sequences, this is quite easy for it to do. The rest of this document is divided into six parts. * the metatypes std-instance and fsc-instance * an abstraction for simple vector indices * important optimizations * the port specific function for making lap closure generators * the actual abstract LAP code * examples *** The metatypes STD-INSTANCE and FSC-INSTANCE *** In PCL, instances with metaclass STANDARD-CLASS are represented using the metatype STD-INSTANCE. (Note that in Cinco de Mayo PCL, this metatype is called IWMC-CLASS.) Each port must implement this metatype. The metatype could be implemented by the following DEFSTRUCT. (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor %allocate-std-instance (wrapper slots)) (:constructor %allocate-std-instance-1 ()) (:print-function print-std-instance)) (wrapper nil) (slots nil)) PCL itself will guarantee correct access to this structure and the accessors and constructors. With this in mind, the following are important. * Being able to type test this structure quickly is critical. See the :STD-INSTANCE-P opcode. * The allocation functions should compile inline, do no argument checking and be as fast as possible. * The accessor functions should compile inline, do no checking of their arguments and be as fast as possible. SETF of the accessors should do the same. The port is also required to implement the metatype FSC-INSTANCE (called FUNCALLABLE-INSTANCE, or FIN for short, in Cinco de Mayo PCL). Objects with this metatype are used, among other things, to implement generic functions. These objects have field structure associated with them and are also functions that can be applied to arguments. The fields are the same as those for STD-INSTANCE, the FSC-INSTANCE metatype has predicates, print-functions, constructors and accessors as follows: fsc-instance-p print-fsc-instance %fsc-instance-wrapper %fsc-instance-slots %allocate-fsc-instance (wrapper slots) %allocate-fsc-instance-1 () In addition, objects of metatype FSC-INSTANCE have a property called the funcallable instance function. When an FSC-INSTANCE is applied to arguments, the funcallable instance function is what is actually called. The funcallable instance function of an FSC-INSTANCE can be changed using the function SET-FUNCALLABLE-INSTANCE-FUNCTION. There is no mechanism for obtaining the funcallable instance function of an FSC-INSTANCE. It is possible to implement the FSC-INSTANCE metatype in pure Common Lisp. A simple implementation which uses lexical closures as the instances and a hash table to record that the lexical closures are of metatype FSC-INSTANCE is easy to write. Unfortunately, this implementation adds significant overhead: to generic-function-invocation (1 function call) to slot-access (1 function call or one hash table lookup) to class-of a generic-function (1 hash-table lookup) In addition, it would prevent the FSC-INSTANCEs from being garbage collected. In short, the pure Common Lisp implementation really isn't practical. Note that previous implementations of FINS were always based on the lexical closure metatype. In some ports, that provides poor performance. Those ports may want to consider reimplementing to use the compiled code metatype. In that implementation strategy, LAP closure variables would become constants of the compiled code object. The following note from JonL is of interest when working on a FIN implementation: Date: Tue, 16 May 89 05:45:56 PDT From: Jon L White This isn't a bug in Lucid's compiler -- it's a lurking bug in PCL that will "bite" most implementations where different settings of the compiler optimization switches will produce morphologically different (but of course functionally equivalent) function objects. The difficulty is in how discriminator codes service cache misses. They "call out" to (potentially) random functions that will in some cases "smash" the function object that was actually running as the discriminator code. This is all right providing you don't return to that function frame, but alas ... I know this is a more extensive problem because the code in the port-independent function 'notice-methods-change' goes out of its way to do a tail-recursive call to the function that is going to smash the possibly-executing discriminator code. Here is the commentary from that code (sic): ;; In order to prevent this we take a simple measure: we just ;; make sure that it doesn't try to reference our its own closure ;; variables after it makes the dcode change. This is done by ;; having notice-methods-change-2 do the work of making the change ;; AND calling the actual generic function (a closure variable) ;; over. This means that at the time the dcode change is made, ;; there is a pointer to the generic function on the stack where ;; it won't be affected by the change to the closure variables. A similar thing should be done in the construction of standard-accessor, checking, and caching dcodes. In an experimental version here at Lucid, I rewrote dcode.lisp to do that, and there is no problem with it. Although that code is somewhat Lucid-specific, it could be of help to someone who wanted to rewrite the generic dcode.lisp (no pun intended). Contact me privately if you are interested. Doing a tail-recursive call out of dcodes when there is a cache miss is a good thing, regardless of other problems. I think one might as well do it. However, I should point out that in the presence of multiprocessing, there is another more serious problem that cannot be solved so simply. Think about what happens when one process decides to update a dcode while another process is still using it; no such stack-maintenance discipline will fix this case. A tail-recursive exit from the dcode will *immensely* reduce the likelihood that another process can sneak in during the interval in which the dcode requires consistency in its function; but it can't reduce that likelihood to zero. The more desirable thing to do is to put the whole "dcode" down one more level of indirection through the symbol-function cell of the generic function. This is effectively what PCL's 'make-trampoline' function does, but unfortunately that is not a very efficient approach when you consider how most compilers will compile it. Something akin to the "mattress-pads" in Steve Haflich's code (in the fin.lisp file) could probably be done for many other implementations as well. *** Index Operations *** Indexes are an abstraction for indexes into a simple vector. This abstraction is used to make it possible to generate more efficient code to access simple vectors. The idea being that this may make it possible to use alternate addressing modes to address these. The "index value" of an index is defined to be the fixnum of which that index is an alternate form. So, using the Lisp function SVREF with the index value of an index accesses the same element as using the index with the appropriate access function or operand. The format of an index is unspecified, but is assumed to be something like a fixnum with certain bits ignored. Accessing a vector using an index must be done using the appropriate special accessor function or opcode. Conversion from index values to indices and vice-versa can be done with the following functions: INDEX-VALUE->INDEX (index-value) INDEX->INDEX-VALUE (index) The following constant indicates the maximum index value an index can have in a given port. This must be at least 2^16. INDEX-VALUE-LIMIT - a fixnum, must be at least 2^16. MAKE-INDEX-MASK ( ) This function is used to make index masks. Because I am lazy, I show an implementation of it in the common case where indexes are just fixnums: (defun make-index-mask (cache-size line-size) (let ((cache-size-in-bits (floor (log cache-size 2))) (line-size-in-bits (floor (log line-size 2))) (mask 0)) (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask))) (dotimes (i line-size-in-bits) (setq mask (dpb 0 (byte 1 i) mask))) mask)) *** Optimizations *** This section discusses two important optimizations related to LAP closures. The first relates to calling LAP closures themselves, the second relates to calling other functions from LAP closures. The important point about calling LAP closures is that almost all of the time, LAP closures will be used as the funcallable-instance-function of funcallable instances. It is required that LAP closures be funcallable themselves, but usually they will be stored in a FIN and the fin will then be funcalled. This brings up several optimizations, including ones having to do with access to the closure variables of a LAP closure. When a LAP closure is used to do method lookup, the function the LAP closure ends up calling has the same number of required arguments as the LAP closure itself. Since the LAP closure must check its required arguments to do the lookup, it is redundant for the function called to do so as well. Since LAP closures do all calls in a tail recursive way, it should even be possible to optimize out certain parts of the normal stack frame initialization. A similar situation occurs between effective method functions and the individual method functions; the difference is that in effective method functions, the calls are not necessarily tail recursive. Consequently, it would be nice to have a way to call certain functions and inhibit the checking of required arguments. This is made possible by use of the PCL-FAST-APPLY and PCL-FAST-FUNCALL macros together with the PCL-FAST-CALL compiler declaration. The PCL-FAST-CALL compiler declaration declares that a function may be fast called. Not all callers of the function will necessarily fast call it, but most probably will. The :JMP opcode can only be used to call a function compiled with the PCL-FAST-CALL declaration. The PCL-FAST-APPLY and PCL-FAST-FUNCALL macros are used to fast call a function. The function argument must be a compiled function that has the PCL-FAST-CALL compiler declaration in its lambda declarations. The basic idea is that the PCL-FAST-CALL compiler declaration causes the compiler to set up an additional entrypoint to the function. This entrypoint comes after checking of required arguments but before processing of other arguments. Note: When FAST-APPLY is used, the required arguments will be given as separate arguments and all other arguments will appear as a single spread argument. For example: (let ((fn (compile () '(lambda (a b &optional (c 'z)) (declare (pcl-fast-call)) (list a b c))))) (pcl-fast-apply fn 'x 'y ()) ;legal (pcl-fast-apply fn 'x 'y '(foo)) ;legal (pcl-fast-apply fn '(a b c)) ;illegal ) *** Producing LAP Closure Generators *** Each implementation of the LAP code mechanism must provide a port specific function making lap closure generators. In the portable implementation, this function is called PLAP-CLOSURE-GENERATOR. In ExCL it should be called EXCL-LAP-CLOSURE-GENERATOR etc. At any time, the value of the variable *make-lap-closure-generator* is a symbol which names the function currently being used to make lap closure generators. The port specific function must accept arguments as follows: PLAP-CLOSURE-GENERATOR ( ) This returns a lap-closure generator. A lap-closure generator is a function which is called with a number of arguments equal to the length of . These arguments are the values of the closure variables for the lap closure. These values cannot be changed once the LAP closure is created. PCL takes care of keeping track of lap-closure-generators it already has on hand and reusing them. The function RESET-LAP-CLOSURE-GENERATORS can be called to force PCL to forget all the lap closure generators it has remembered. A list of symbols. This provides a way to name particular arguments to the LAP closure. Arguments which will not be referenced by name are given as NIL. All required arguments to the LAP closure are explicitly included (perhaps as NIL). If &REST appears at the end of arguments it means that non-required arguments are allowed, these will be processed by the methods. If &REST does not appear at the end of arguments, the lap closure should signal an error if more than the indicated number of arguments are supplied. Examples: - (obj-0 obj-1) Specifies a two argument lap closure. If more or less than two arguments are supplied an error is signalled. Within the actual lap code, both arguments can be referenced by name (see the :ARG operand). - (obj-0 nil &rest) Specifies a two or more argument lap closure. If less than two arguments are supplied an error is signalled. Within the actual lap code, the first argument can be referenced by name (see the :ARG operand). A list of symbols. The closure will have these as closure variables. Within the lap code these can be accessed using the :CVAR operand. The lap code cannot change these values. SET-FUNCALLABLE-INSTANCE-FUNCTION is permitted to have the special knowledge that there are at most ?? of these and to be prepared to do something special when the funcallable instance function of a funcallable instance is set to a lap closure. A list of register numbers. These registers will be used only to hold indexes. Other registers may be used to hold indexes as well, but the only values put into these registers will be indexes. A list of register numbers. These registers will be used only to hold simple-vectors. Other registers may be used to hold simple-vectors as well, but the only values put into these registers will be simple-vectors. The actual lap code for this closure. This is a list of LAP code opcodes. See the section "Abstract LAP Code" for more details. Each implementation must also supply a function named PRE-MAKE-xxx where xxx is the same as the name of its make-lap-closure-generator function. The macro doesn't evaluate its arguments, and when it appears in a file it should try to do some of the work at load time. It might appear in a file like this: (eval-when (load) (setq 1-arg-std-lap (pre-make-plap-closure-generator ...))) *** Abstract LAP Code *** Each lap code operand has the form: (opcode operand1 ... operandn). In some cases, the distinction between an operand and an opcode is somewhat arbitrary. In general, opcodes have a significant "action" component to their behavior. Operands select a piece of data to operate on. Some operands select their data in a more complex way, but they are operands anyways. All data must be in a register before it can be operated on. This requirement means that the only place a non-register operand can appear is as the first argument to the :move opcode. (Actually, there is one other exception, a :iref operand can be the target of a move as well.) Moreover, only register operands can appear as the second argument to the :move opcode and this register must not appear in the operand. >> The operands are: (:reg ) A pseudo register. is an integer in the range [0 , 31]. A particular implementation can map this to a real register, a memory location or the stack. The abstract LAP code itself does not include the notion of a stack. PCL will attempt to optimize register use in two ways. PCL itself will attempt to re-use registers whenever possible. That is, the port should not have to worry with doing live register analysis for the registers. In addition, PCL will consider lower numbered registers to be "faster" than higher numbered ones. (:cvar ) A closure variable of the lap-closure. is a symbol. (:arg ) An argument to the LAP closure. is a symbol. (:std-wrapper ) (:fsc-wrapper ) (:built-in-wrapper ) (:structure-wrapper ) (:other-wrapper ) Get the class wrapper of . For std-instances and fsc-instances this just fetches the wrapper field. The specific port is required to implement fast access to the wrappers of built-in, structure and other metatypes. A callback mechanism allows the port to ask PCL to generate a class and wrapper for objects for which no class and wrapper exists yet. This mechanism is <>. (:std-slots ) (:fsc-slots ) Fetch the slots field of a std-instance or a fsc-instance. (:constant ) This just allows inline constants. can be any Lisp object. The following operands operate on indexes. Each is patterned after a Lisp function which would have a corresponding effect on the index value of the index. (:i1+ ) (:i+ ) (:i- ) (:ilogand ) (:ilogxor ) Like the corresponding Lisp functions. (:iref ) Like the SVREF function. must be a simple vector. (:cref ) The :cref operand is for constant vector references. must be a fixnum. >> The opcodes are: (:move ) A full word move operation. (:eq