(FILECREATED "23-Oct-85 11:50:15" {ERIS}<FISCHER>LIBRARY>CMLSPECIALFORMS.;6 40392
changes to: (FNS CMLRDTBL CONSP CL:APPLY CL:LENGTH)
(MACROS COPY-LIST CL:APPLY CL:MEMBER DOTIMES CL:PUSH)
(VARS CMLSPECIALFORMSCOMS)
previous date: " 8-Oct-85 14:38:03" {ERIS}<FISCHER>LIBRARY>CMLSPECIALFORMS.;1)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS [(COMS (* random vanilla functions)
(FNS CL:EQUAL CL:LENGTH FBOUNDP EQUALP MACROEXPAND-1 RAISEATS
CMLTRANSLATE SPECIAL-FORM-P DEFCONSTANT)
(P (MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE GETPROP)
(QUOTE GET))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR)))
(FNS EQL CL:MEMBER COPY-LIST IDENTITY CL:APPLY)
(MACROS CL:MEMBER CL:SETQ CL:IF CL:UNLESS CL:WHEN COPY-LIST
IDENTITY UNWIND-PROTECT EQL CL:APPLY)
(P (MOVD (QUOTE APPLY*)
(QUOTE FUNCALL)))
(PROP DMACRO FUNCALL)
(* INTEGERP = Interlisp's FIXP , SYMBOLP = Interlisp's LITATOM)
(* these may be obsoleted by CommonLoops)
(FNS INTEGERP SYMBOLP CONSP CL:LISTP)
(PROP DMACRO INTEGERP SYMBOLP CONSP CL:LISTP))
(COMS (* fake self-evaluating keywords)
(FNS DWIMKEYWORD)
[DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS (DWIMUSERFORMS (
DWIMKEYWORD]
(ADVISE COMP.USERFN)
(* must turn off "packed" version of CLISP infix)
(VARS CMLTRANSLATIONS [CLISPCHARS (LDIFFERENCE
CLISPCHARS
(QUOTE (: - *]
(CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(CLISPIFYPACKFLG NIL)))
(COMS (* DEFUN and lambda keywords)
(MACROS DEFUN DEFUN-INLINE DEFSUBST)
(FNS DEFUN.DECODE \LAMBDA.CL.TO.IL \DEFUN.DECODE.&KEYS
\CL-LAMBDA-FNTYP \SPECALIZEDP)
(VARS LAMBDA-LIST-KEYWORDS)
(MACROS \KEYSEARCH NEED.ARGVAR)
(FILES LAMBDATRAN)
(ADDVARS (LAMBDASPLST CL:LAMBDA))
(ALISTS (LAMBDATRANFNS CL:LAMBDA)
(PRETTYEQUIVLST CL:LAMBDA)))
(COMS (* * DO DO* and support.)
(MACROS CL:DO CL:DO*)
(FNS \DO.TRANSLATE))
[COMS (* attempt to build a commonlisp readtable. Not enough features
in readtables yet)
(FNS CMLRDTBL CMLREADVBAR)
(VARS (CMLRDTBL (CMLRDTBL]
(COMS (* odd definition of PROGV, don't know how well it works)
(MACROS PROGV))
(COMS (* "CommonLisp style CATCH and THROW")
(FNS CATCH \CATCH.AUX \CATCH.FINDFRAME \CATCH.TAG.INTERN THROW
\THROW.AUX)
(MACROS CATCH *CATCH \CATCHRUNFUN THROW *THROW UNWINDPROTECT)
(DECLARE: (*
"Crufty low-level stuff to help make \CATCH.TAG.INTERN more efficient")
[VARS (\THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
(RPLSTRING X 1
(QUOTE
\CATCH.TAG.))
(RETURN X]
(GLOBALVARS \THROW.STRBUFFER)))
(* well, SETF is pretty close to CHANGE)
(MACROS SETF DEFSETF)
(PROP SETFN \GETBASEPTR)
(COMS (* somewhat bogus definitions)
(FNS CL:MAPCAR)
(MACROS CL:PUSH DOLIST DOTIMES)
(FNS EXPAND-LOOP LOOP-EXPAND LOOP-EXPAND-BODY LOOP-EXPAND-FOR)
(MACROS CASE)
(FNS CASE-1)
(MACROS DESTRUCTURING-BIND DESETQ)
(FNS DESTRUCTURING-BIND-1 DESTRUCTURING-BIND-2
DESTRUCTURING-BIND-3))
(TEMPLATES CATCH)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA CATCH)
(NLAML DEFCONSTANT)
(LAMA CL:APPLY CL:MEMBER MACROEXPAND-1 CL:MAPCAR])
(* random vanilla functions)
(DEFINEQ
(CL:EQUAL
[LAMBDA (X Y) (* lmm "19-Jul-85 01:47")
(OR (EQ X Y)
(IF (CONSP X)
THEN (AND (CONSP Y)
(CL:EQUAL (CAR X)
(CAR Y))
(CL:EQUAL (CDR X)
(CDR Y)))
ELSE (OR (EQL X Y)
(AND (STRINGP X)
(STRINGP Y)
(STREQUAL X Y])
(CL:LENGTH
(CL:LAMBDA (SEQ)
(if (type? ARRAYP SEQ)
then (ARRAYSIZE SEQ)
elseif (LISTP SEQ)
then (LENGTH SEQ)
elseif (type? STRINGP SEQ)
then (NCHARS SEQ)
elseif (AND (type? ARRAY SEQ)
(IEQ 1 (ARRAY-RANK SEQ)))
then (ARRAY-DIMENSION SEQ 0)
else (ERROR "Not a sequence" SEQ))))
(FBOUNDP
[LAMBDA (X)
(AND (OR (GETD X)
(GETPROP X (QUOTE MACRO)))
T])
(EQUALP
[LAMBDA (X Y) (* lmm "19-Jul-85 01:50")
(OR (EQ X Y)
(IF (CONSP X)
THEN (AND (CONSP Y)
(EQUALP (CAR X)
(CAR Y))
(EQUALP (CDR X)
(CDR Y)))
ELSE (IF (NUMBERP X)
THEN (AND (NUMBERP Y)
(= X Y))
ELSE (OR (EQL X Y)
(AND (STRINGP X)
(STRINGP Y)
(STRING-EQUAL X Y])
(MACROEXPAND-1
(CL:LAMBDA (FORM &OPTIONAL (ENV NIL ENV-P)) (* lmm "31-Jul-85 04:30")
(if ENV-P
then (HELP "ENVIRONMENT??"))
(EXPANDMACRO FORM T)))
(RAISEATS
[LAMBDA (X) (* lmm "31-Jul-85 03:56")
(if (LITATOM X)
then (OR (CDR (ASSOC X CMLTRANSLATIONS))
(U-CASE X))
elseif (LISTP X)
then (CONS (RAISEATS (CAR X))
(RAISEATS (CDR X)))
else X])
(CMLTRANSLATE
[LAMBDA (X) (* lmm "31-Jul-85 03:56")
(if (LITATOM X)
then (OR (CDR (ASSOC X CMLTRANSLATIONS))
(U-CASE X))
elseif (LISTP X)
then (CONS (CMLTRANSLATE (CAR X))
(CMLTRANSLATE (CDR X)))
else X])
(SPECIAL-FORM-P
[LAMBDA (X)
(FMEMB (ARGTYPE X)
(QUOTE (1 3])
(DEFCONSTANT
[NLAMBDA (VAR VAL DOC)
(SET VAR (EVAL VAL))
(EVAL (LIST (QUOTE CONSTANTS)
VAR))
VAR])
)
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE GETPROP)
(QUOTE GET))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR))
(DEFINEQ
(EQL
[LAMBDA (X Y) (* lmm " 7-Jul-85 17:56")
(if (AND (FIXP X)
(FIXP Y))
then (IEQP X Y)
elseif (AND (FLOATP X)
(FLOATP Y))
then (FEQP X Y)
else (EQ X Y])
(CL:MEMBER
[LAMBDA \CL:MEMBER.ARGCNT
(PROGN (QUOTE DEFUN) (* ARGLIST = (ITEM LIST &KEY
(TEST (FUNCTION EQL) TESTSUPPLIED)
(TEST-NOT NIL TESTNOTSUPPLIED)
(KEY (FUNCTION IDENTITY))))
(DECLARE (LOCALVARS \CL:MEMBER.ARGCNT))
(LET ((ITEM (ARG \CL:MEMBER.ARGCNT 1))
(LIST (ARG \CL:MEMBER.ARGCNT 2)))
(LET* [(TESTSUPPLIED T)
[TEST (PROG NIL
(RETURN (ARG \CL:MEMBER.ARGCNT
(OR (\KEYSEARCH 3 :TEST \CL:MEMBER.ARGCNT)
(RETURN
(PROGN (SETQ TESTSUPPLIED NIL)
(FUNCTION EQL]
(TESTNOTSUPPLIED T)
[TEST-NOT (PROG NIL
(RETURN (ARG \CL:MEMBER.ARGCNT
(OR (\KEYSEARCH 3 :TEST-NOT
\CL:MEMBER.ARGCNT)
(RETURN (PROGN (SETQ
TESTNOTSUPPLIED NIL)
NIL]
(KEY (PROG NIL
(RETURN (ARG \CL:MEMBER.ARGCNT
(OR (\KEYSEARCH 3 :KEY \CL:MEMBER.ARGCNT)
(RETURN (FUNCTION IDENTITY]
(on old LIST when (if TESTSUPPLIED
then (FUNCALL TEST (FUNCALL KEY
(CAR LIST))
ITEM)
elseif TESTNOTSUPPLIED
then (NOT (FUNCALL TEST-NOT
(FUNCALL KEY
(CAR LIST))
ITEM))
else (EQL (FUNCALL KEY (CAR LIST))
ITEM))
do (RETURN LIST])
(COPY-LIST
[LAMBDA (L)
(APPEND L NIL])
(IDENTITY
[LAMBDA (X)
X])
(CL:APPLY
[LAMBDA N (* raf "19-Oct-85 22:26")
(APPLY (ARG N 1)
(LET ((AV (ARG N N)))
(for I from (SUB1 N) to 2 by -1 do (push AV (ARG N I)))
AV])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS CL:MEMBER DMACRO
(DEFMACRO [ITEM LIST &KEY (TEST (QUOTE (FUNCTION EQL))
TESTSUPPLIED)
(TEST-NOT NIL TESTNOTSUPPLIED)
(KEY (QUOTE (FUNCTION IDENTITY]
(* optimize simple cases)
[AND (EQ TEST (QUOTE EQL))
(LET ((CE (CONSTANTEXPRESSIONP LIST)))
(AND CE [EVERY CE (FUNCTION (LAMBDA (X)
(OR (SMALLP X)
(LITATOM X]
(SETQ TEST (QUOTE EQ]
(LET ((TESTC (CONSTANTEXPRESSIONP TEST))
(KEYC (CONSTANTEXPRESSIONP KEY))
(TESTNOTC (CONSTANTEXPRESSIONP TEST-NOT))
(LISTC (CONSTANTEXPRESSIONP LIST)))
[if [AND LISTC KEYC (EQUAL TESTC (QUOTE (EQL)))
(EVERY (CAR LISTC)
(FUNCTION (LAMBDA (X)
(NOT (NUMBERP (APPLY* (CAR KEYC)
X]
then
(SETQ TESTC (QUOTE (EQ]
(COND [(AND TESTC KEYC TESTNOTC)
(if (AND (EQ (CAR TESTC)
(QUOTE EQ))
(EQ (CAR KEYC)
(QUOTE IDENTITY))
(NOT TESTNOTSUPPLIED))
then
(LIST (QUOTE FMEMB)
ITEM LIST)
else
(LET ((ITERVAR (GENSYM "MEMBER"))
(ITEMVAR (GENSYM "MEMBER-ITEM")))
(BQUOTE (LET ((, ITEMVAR , ITEM))
(for , ITERVAR on , LIST , (if TESTNOTSUPPLIED
then
(QUOTE unless)
else
(QUOTE when))
(, (if TESTNOTSUPPLIED then (CAR TESTNOTC)
else
(CAR TESTC))
(, (CAR KEYC)
(CAR , ITERVAR))
, ITEMVAR)
do
(RETURN , ITERVAR]
(T (QUOTE IGNOREMACRO]
[PUTPROPS CL:SETQ DMACRO (DEFMACRO (&REST VARS-AND-FORMS)
(* like Interlisp's SETQ but allows multiple sets)
(OR (EVENP (LENGTH VARS-AND-FORMS))
(SHOULDNT "Must have an even number of arguments to SETQ."))
(BQUOTE (PROGN ,@ (for X on VARS-AND-FORMS by (CDDR X)
collect
(PROGN (OR (SYMBOLP (CAR X))
(SHOULDNT
"All the odd numbered arguments to SETQ must be symbols."))
(BQUOTE (SETQ , (CAR X)
,
(CADR X]
[PUTPROPS CL:IF DMACRO (X (BQUOTE (COND ((\, (CAR X))
(\, (CADR X)))
(T (\,@ (OR (CDDR X)
(LIST NIL]
[DEFMACRO CL:UNLESS (TEST &BODY BODY)
(BQUOTE (COND ((\, (NEGATE TEST))
(\,@ BODY]
[DEFMACRO CL:WHEN (TEST &BODY BODY)
(BQUOTE (COND ((\, TEST)
(\,@ BODY]
(PUTPROPS COPY-LIST DMACRO ((X)
(APPEND X NIL)))
(PUTPROPS IDENTITY DMACRO ((X)
X))
(DEFMACRO UNWIND-PROTECT (FORM &REST CLEANUPS)
(LET ((BADVARS (for X in (FREEVARS (CONS (QUOTE PROGN)
CLEANUPS))
unless
(OR (COMP.GLOBALVARP X)
(CONSTANTEXPRESSIONP X))
collect X)))
(AND BADVARS (PRINTOUT T "WARNING: UNWIND-PROTECT FREE VARIABLE: " BADVARS T)))
(BQUOTE (RESETLST [RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL ,@ CLEANUPS]
, FORM)))
(PUTPROPS EQL BYTEMACRO COMP.EQ)
[PUTPROPS CL:APPLY DMACRO (DEFMACRO (FN &REST ARGS)
(BQUOTE (LET [(FN (\, FN))
(CNT (\, (LENGTH (CDR ARGS]
(.SPREAD. ((OPCODES)
,@ ARGS)
CNT FN]
)
(MOVD (QUOTE APPLY*)
(QUOTE FUNCALL))
(PUTPROPS FUNCALL DMACRO COMP.APPLY*)
(* INTEGERP = Interlisp's FIXP , SYMBOLP = Interlisp's LITATOM)
(* these may be obsoleted by CommonLoops)
(DEFINEQ
(INTEGERP
[LAMBDA (X)
(AND (FIXP X)
T])
(SYMBOLP
[LAMBDA (X)
(LITATOM X])
(CONSP
[LAMBDA (X) (* raf "21-Oct-85 14:08")
(OR (NULL X)
(AND (LISTP X)
T])
(CL:LISTP
[LAMBDA (X)
(OR (NULL X)
(AND (LISTP X)
T])
)
(PUTPROPS INTEGERP DMACRO ((X)
(AND (FIXP X)
T)))
(PUTPROPS SYMBOLP DMACRO (= . LITATOM))
(PUTPROPS CONSP DMACRO (= . LISTP))
(PUTPROPS CL:LISTP DMACRO (OPENLAMBDA (X)
(OR (NULL X)
(AND (LISTP X)
T))))
(* fake self-evaluating keywords)
(DEFINEQ
(DWIMKEYWORD
[LAMBDA NIL (* lmm " 8-Jul-85 13:17")
(AND (NULL FAULTAPPLYFLG)
(LITATOM FAULTX)
(EQ (NTHCHARCODE FAULTX 1)
(CHARCODE ":"))
(\MAKE.KEYWORD FAULTX])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR DWIMUSERFORMS (DWIMKEYWORD))
)
(PUTPROPS COMP.USERFN READVICE [NIL (BEFORE NIL (if (\KEYWORDP X)
then
(RETURN (LIST (QUOTE QUOTE)
X])
(READVISE COMP.USERFN)
(* must turn off "packed" version of CLISP infix)
(RPAQQ CMLTRANSLATIONS ((position . CL:POSITION)
(listp . CL:LISTP)
(lambda . CL:LAMBDA)
(mapcar . CL:MAPCAR)
(do . CL:DO)
(do* . CL:DO*)
(if . CL:IF)
(length . CL:LENGTH)
(atom . CL:ATOM)
(member . CL:MEMBER)
(push . CL:PUSH)
(replace . CL:REPLACE)
(when . CL:WHEN)
(unless . CL:UNLESS)
(* . CL:*)))
(RPAQ CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (: - *))))
(RPAQ CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(RPAQQ CLISPIFYPACKFLG NIL)
(* DEFUN and lambda keywords)
(DECLARE: EVAL@COMPILE
(DEFMACRO DEFUN (NAME ARGS &REST BODY)
(DEFUN.DECODE NAME ARGS BODY))
[DEFMACRO DEFUN-INLINE (NAME ARGS &REST BODY)
(BQUOTE (PUTPROPS (\, NAME)
MACRO
(OPENLAMBDA (\, ARGS)
(\,@ BODY]
[DEFMACRO DEFSUBST (NAME ARGS &REST BODY)
(BQUOTE (PUTPROPS (\, NAME)
MACRO
(OPENLAMBDA (\, ARGS)
(\,@ BODY]
)
(DEFINEQ
(DEFUN.DECODE
[LAMBDA (NAME ARGS BODY REASON) (* lmm "16-Jul-85 16:00")
(if (OR (LISTP NAME)
(\SPECALIZEDP ARGS))
then [BQUOTE (define-method
[QUOTE (\, (COND
((LISTP NAME) (* OTHER OPTIONS IN LIST AFTER \NAME)
(CAR NAME))
(T NAME]
(QUOTE (\, ARGS))
[QUOTE (\, (AND (CDR BODY)
(OR (STRINGP (CAR BODY))
(EQ (CAR (LISTP (CAR BODY)))
COMMENTFLG))
(pop BODY]
(QUOTE (\, (MKPROGN BODY)))
NIL
(QUOTE (\, (CDR (LISTP NAME]
else (BQUOTE (FNS.PUTDEF (QUOTE , NAME)
(QUOTE FNS)
(QUOTE (CL:LAMBDA (\, ARGS)
(\,@ BODY])
(\LAMBDA.CL.TO.IL
[LAMBDA (EXPR) (* lmm "12-Jul-85 22:46")
(CONS (QUOTE LAMBDA)
(\DEFUN.DECODE.&KEYS (QUOTE CL:LAMBDA)
(CDR EXPR])
(\DEFUN.DECODE.&KEYS
[LAMBDA (NAME EXP) (* lmm "14-Sep-85 15:06")
(LET (VRBLS KEYVARS OPTVARS AUXLIST RESTFORM VARTYP ARGVAR BODY KEYWORDS (CNT 1)
(MIN 0)
(MAX 0))
[for BINDING VAR in (CAR EXP)
do
(SELECTQ
BINDING
((&REST &BODY)
(SETQ VARTYP (QUOTE &REST)))
((&AUX &OPTIONAL)
(SETQ VARTYP BINDING))
(&ALLOW-OTHER-KEYS (OR (EQ VARTYP (QUOTE &KEY))
(ERROR "&ALLOW-OTHER-KEYS not in &KEY")))
(&KEY (SETQ VARTYP (QUOTE &KEY)))
(SELECTQ
VARTYP
(NIL (* Regular default &REQUIRED variable)
(push VRBLS BINDING)
(add CNT 1)
(add MIN 1)
(add MAX 1))
(&REST (NEED.ARGVAR)
[SETQ RESTFORM
(BQUOTE ((, BINDING (for \Index from , CNT to , ARGVAR
collect (ARG , ARGVAR \Index]
(SETQ MAX NIL))
(&AUX (push AUXLIST BINDING))
[&KEY
(SETQ MAX NIL)
(NEED.ARGVAR)
(LET* [SVAR [INIT (if (LISTP BINDING)
then (PROG1 (CADR BINDING)
(SETQ SVAR (CADDR BINDING))
(SETQ BINDING (CAR BINDING]
(KEY (if (LISTP BINDING)
then (PROG1 (CAR BINDING)
(SETQ BINDING (CADR BINDING)))
else (\MAKE.KEYWORD BINDING]
(if SVAR
then (push KEYVARS (LIST SVAR T)))
(push
KEYVARS
(LIST
BINDING
(BQUOTE
(PROG NIL
(RETURN
(ARG , ARGVAR
(OR (\KEYSEARCH , CNT , KEY , ARGVAR)
(RETURN ,
(if SVAR
then (BQUOTE
(PROGN (SETQ , SVAR
NIL)
, INIT))
else INIT]
(&OPTIONAL (OR (LISTP BINDING)
(SETQ BINDING (LIST BINDING)))
[LET ((SVAR (CADDR BINDING)))
(NEED.ARGVAR)
(if SVAR
then (push OPTVARS SVAR))
(push OPTVARS
(BQUOTE (, (CAR BINDING)
(if (IGREATERP , CNT , ARGVAR)
then , (CADR BINDING)
else ,@ [if SVAR
then (BQUOTE ((SETQ ,
SVAR T]
(ARG , ARGVAR , CNT]
(AND MAX (add MAX 1))
(add CNT 1))
(SHOULDNT]
(SETQ BODY (CDR EXP))
[if AUXLIST
then (SETQ BODY (BQUOTE ((LET* (,@ (DREVERSE AUXLIST))
,@
BODY]
(if ARGVAR
then [BQUOTE (, ARGVAR (DECLARE (LOCALVARS , ARGVAR))
,.
[if (AND MIN (NEQ MIN 0))
then (BQUOTE ((if (ILESSP , ARGVAR , MIN)
then (ERROR "Too few args" , ARGVAR]
,.
[if MAX
then (BQUOTE ((if (IGREATERP , ARGVAR , MAX)
then (ERROR "Too many args" , ARGVAR]
(LET [,. (for VAR in (REVERSE VRBLS) as I from 1
collect (LIST VAR (BQUOTE (ARG , ARGVAR , I]
(LET* (,@ (REVERSE OPTVARS)
,@
(REVERSE KEYVARS)
,. RESTFORM)
,.
BODY]
else (BQUOTE (, (REVERSE VRBLS)
(DECLARE (LOCALVARS . T))
., BODY])
(\CL-LAMBDA-FNTYP
[LAMBDA (EXP) (* lmm "12-Jul-85 23:37")
(PROG NIL
(for BINDING VARTYP in (CADR EXP)
do (SELECTQ BINDING
((&REST &BODY)
(RETURN (QUOTE EXPR*)))
((&AUX &OPTIONAL)
(SETQ VARTYP BINDING))
(&KEY (RETURN (QUOTE EXPR*)))
(SELECTQ VARTYP
(NIL (* Regular default &REQUIRED variable))
(&AUX (RETURN (QUOTE EXPR)))
[&OPTIONAL (AND (LISTP BINDING)
(if (OR (CADR BINDING)
(CADDR BINDING))
then (RETURN (QUOTE EXPR*]
(SHOULDNT)))
finally (RETURN (QUOTE EXPR])
(\SPECALIZEDP
[LAMBDA (ARGS) (* lmm "16-Jul-85 15:59")
(while (LISTP ARGS) do (if (LISTP (CAR ARGS))
then (RETURN T)
else (SELECTQ (pop ARGS)
((&OPTIONAL &REST &KEY &AUX)
(RETURN))
NIL])
)
(RPAQQ LAMBDA-LIST-KEYWORDS (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT))
(DECLARE: EVAL@COMPILE
[PUTPROPS \KEYSEARCH MACRO ((CNT KEY ARGN)
(for \INDEX from CNT to ARGN by 2 when (EQ (ARG ARGN \INDEX)
(QUOTE KEY))
do
(RETURN (ADD1 \INDEX]
[PUTPROPS NEED.ARGVAR MACRO (NIL (OR ARGVAR (SETQ ARGVAR (PACK* "\" NAME ".ARGCNT"]
)
(FILESLOAD LAMBDATRAN)
(ADDTOVAR LAMBDASPLST CL:LAMBDA)
(ADDTOVAR LAMBDATRANFNS (CL:LAMBDA \LAMBDA.CL.TO.IL \CL-LAMBDA-FNTYP CADR))
(ADDTOVAR PRETTYEQUIVLST (CL:LAMBDA . LAMBDA))
(* * DO DO* and support.)
(DECLARE: EVAL@COMPILE
(DEFMACRO CL:DO (VARS END-TEST &BODY BODY)
(\DO.TRANSLATE VARS END-TEST BODY NIL))
(DEFMACRO CL:DO* (BINDS END-TEST &REST BODY)
(\DO.TRANSLATE BINDS END-TEST BODY T))
)
(DEFINEQ
(\DO.TRANSLATE
[LAMBDA (VARS END-TEST BODY SEQUENTIALP) (* lmm "31-Jul-85 04:01")
(* * This should run in the cold-load so it uses only basic stuff and explicitly doesn't use BQUOTE.)
(LET ([VARS-AND-INITIAL-VALUES (MAPCAR VARS (FUNCTION (LAMBDA (X)
(COND
((NLISTP X)
(LIST X NIL))
(T (LIST (CAR X)
(CADR X]
[SUBSEQUENT-VALUES (MAPCAR VARS (FUNCTION (LAMBDA (X)
(AND (LISTP X)
(CDDR X)
(LIST (CAR X)
(CADDR X]
(TAG (GENSYM)))
[AND (SETQ SUBSEQUENT-VALUES (REMOVE NIL SUBSEQUENT-VALUES))
(SETQ SUBSEQUENT-VALUES (CONS (COND
(SEQUENTIALP (QUOTE CL:SETQ))
(T (QUOTE PSETQ)))
(APPLY (FUNCTION APPEND)
SUBSEQUENT-VALUES]
(BQUOTE (, (COND
(SEQUENTIALP (QUOTE PROG*))
(T (QUOTE PROG)))
, VARS-AND-INITIAL-VALUES , TAG [COND
(, (CAR END-TEST)
(RETURN (PROGN ., (CDR END-TEST]
(PROGN ., BODY)
, SUBSEQUENT-VALUES (GO , TAG])
)
(* attempt to build a commonlisp readtable. Not enough features in readtables yet)
(DEFINEQ
(CMLRDTBL
[LAMBDA NIL (* raf "23-Oct-85 11:49")
(* attempt to set up common lisp read table)
(* Creates a copy of the "original" read-table.)
(PROG [(TBL (COPYREADTABLE (QUOTE ORIG] (* FIRST RESET THE TABLE)
(for I from 0 to 255 do (SETSYNTAX I (QUOTE OTHER)
TBL))
(SETSEPR (CHARCODE (SPACE CR ↑L LF TAB))
1 TBL)
(SETSYNTAX (CHARCODE "'")
[QUOTE (MACRO FIRST NONIMMEDIATE NOESCQUOTE (LAMBDA (STREAM RDTBL)
(LIST (QUOTE QUOTE)
(READ STREAM RDTBL]
TBL)
(SETSYNTAX (CHARCODE ";")
[QUOTE (SPLICE FIRST (LAMBDA (STREAM RDTBL)
(until (EQ (READCCODE STREAM)
(CHARCODE NEWLINE))
do NIL]
TBL)
(SETSYNTAX (CHARCODE %))
(QUOTE RIGHTPAREN)
TBL)
(SETSYNTAX (CHARCODE %()
(QUOTE LEFTPAREN)
TBL)
(SETSYNTAX (CHARCODE "\")
(QUOTE ESCAPE)
TBL)
(SETSYNTAX (CHARCODE "|")
(QUOTE (MACRO ALWAYS CMLREADVBAR))
TBL)
(SETSYNTAX (CHARCODE %")
(QUOTE STRINGDELIM)
TBL)
(SETSYNTAX (CHARCODE "`")
(QUOTE (MACRO FIRST READBQUOTE))
TBL)
(SETSYNTAX (CHARCODE "#")
(QUOTE (MACRO FIRST READHASHMACRO))
TBL)
(SETSYNTAX (CHARCODE ",")
(QUOTE (MACRO FIRST READBQUOTECOMMA))
TBL)
(SETSYNTAX (CHARCODE "%%")
(QUOTE OTHER)
TBL)
(RETURN TBL])
(CMLREADVBAR
[LAMBDA (STREAM RDTBL)
(HELP])
)
(RPAQ CMLRDTBL (CMLRDTBL))
(* odd definition of PROGV, don't know how well it works)
(DECLARE: EVAL@COMPILE
[PUTPROPS PROGV MACRO ((SYMS VALS . BODY)
(EVALA (LIST (FUNCTION [LAMBDA NIL . BODY]))
([LAMBDA (\Vars \Vals)
(DECLARE (LOCALVARS \Vars \Vals))
(while \Vars collect (CONS (pop \Vars)
(OR (pop \Vals)
(QUOTE NOBIND]
SYMS VALS]
)
(* "CommonLisp style CATCH and THROW")
(DEFINEQ
(CATCH
[NLAMBDA L (* raf "21-Jun-85 18:17")
(PROG ((TAG (CAR L))
(FORMS (LISPFORM.SIMPLIFY (CONS (QUOTE PROGN)
(CDR L))
T)))
(RETURN (\CATCH.AUX (EVAL TAG (QUOTE INTERNAL))
FORMS T])
(\CATCH.AUX
[LAMBDA (TAG FUN FORMP) (* JonL "25-SEP-83 23:08")
(DECLARE (USEDFREE \CATCH.1SHOT.OPOS)) (* WARNING! This function cannot be run
interpretively, due to the expectations for the STKNTH
call below)
(PROG ((STKPOSVARNAME (\CATCH.TAG.INTERN TAG))
(STKPOS (\CATCH.FINDFRAME))
(\CATCH.1SHOT.OPOS NIL))
(DECLARE (LOCALVARS STKPOSVARNAME STKPOS)
(SPECVARS \CATCH.1SHOT.OPOS \CATCHBODY))
(* Now do you see why Interlisp needs a PROGV like
MacLisp has?)
(RETURN (EVALA (if FORMP
then FUN
else (if (LITATOM FUN)
then (OR (AND FUN (NEQ FUN T))
(SHOULDNT "unacceptable function")))
(LIST FUN))
(LIST (CONS STKPOSVARNAME STKPOS])
(\CATCH.FINDFRAME
[LAMBDA (POS) (* JonL "25-SEP-83 23:18")
(STKNTH -1 (OR (STACKP (SETQ POS (STKPOS (QUOTE \CATCH.AUX)
NIL NIL POS)))
(SHOULDNT))
POS])
(\CATCH.TAG.INTERN
[LAMBDA (TAG) (* lmm "31-Jul-85 03:32")
(OR (AND (LITATOM TAG)
(NEQ TAG T))
(ERROR TAG "NIL and T not usable as CATCH tags"))
(OR (if (ILESSP (NCHARS TAG)
(CONSTANT (IDIFFERENCE 128 11)))
then (PACK* (QUOTE \CATCH.TAG.)
TAG))
(ERROR TAG "name too long to be CATCH tag"])
(THROW
[LAMBDA (TAG VAL) (* JonL "21-SEP-83 15:21")
(\THROW.AUX (EVALV (\CATCH.TAG.INTERN TAG))
TAG VAL])
(\THROW.AUX
[LAMBDA (POS TAG VAL) (* lmm "19-Jul-85 23:42")
(DECLARE (LOCALVARS POS TAG VAL FORMP)
(USEDFREE \THROW.1SHOT.OPOS))
(* Note that both TAG and VAL have been "evaluated" before the call to this SUBR, and hence before any of the
validity checking below.)
(PROG NIL
A (if (SMALLP POS)
then (UNINTERRUPTABLY
(\SMASHLINK NIL POS POS)
(RETURN VAL)))
(if (STACKP POS)
then (RETTO POS VAL T))
(SETQ TAG (ERROR TAG (QUOTE
Tag% to% THROW,% but% no% corresponding% tag% in% a% CATCH)))
(SETQ POS (EVALV (\CATCH.TAG.INTERN TAG)))
(GO A])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS CATCH DMACRO (DEFMACRO
(TAGFORM &REST FORMS)
(LET ((Y (LISPFORM.SIMPLIFY (MKPROGN FORMS)
T))
(CTAG (CONSTANTEXPRESSIONP TAGFORM)))
(RETURN (COND [CTAG (SETQ CTAG (\CATCH.TAG.INTERN (CAR CTAG)))
(SUBPAIR (QUOTE (X FORM))
(LIST TAGFORM Y)
(QUOTE (\CATCHRUNFUN (FUNCTION
(LAMBDA NIL
([LAMBDA
(X)
(DECLARE
(SPECVARS X))
FORM]
(\MYALINK]
(T (LIST (QUOTE \CATCH.AUX)
TAGFORM
(BQUOTE (FUNCTION (LAMBDA NIL , Y]
(PUTPROPS *CATCH MACRO (= . CATCH))
(PUTPROPS \CATCHRUNFUN DMACRO (= . SPREADAPPLY*))
[PUTPROPS THROW DMACRO (X (PROG ((Y (LISPFORM.SIMPLIFY (CONS (QUOTE PROGN)
X)
T))
TAGFORM)
(SETQ Y (CDR Y))
(RETURN (COND ((SETQ TAGFORM (CONSTANTEXPRESSIONP (CAR Y)))
(LIST (QUOTE \THROW.AUX)
(\CATCH.TAG.INTERN (CAR TAGFORM))
(KWOTE (CAR TAGFORM))
(CADR Y)))
(T (QUOTE IGNOREMACRO]
(PUTPROPS *THROW MACRO (= . THROW))
(DEFMACRO UNWINDPROTECT (FORM &REST CLEANUPS)
(LET ((BADVARS (for X in (FREEVARS (CONS (QUOTE PROGN)
CLEANUPS))
UNLESS
(OR (COMP.GLOBALVARP X)
(CONSTANTEXPRESSIONP X))
COLLECT X)))
(AND BADVARS (PRINTOUT T "WARNING: UNWIND-PROTECT FREE VARIABLE: " BADVARS T)))
(BQUOTE (RESETLST [RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL ,@ CLEANUPS]
, FORM)))
)
(DECLARE:
(RPAQ \THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
(RPLSTRING X 1 (QUOTE \CATCH.TAG.))
(RETURN X)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \THROW.STRBUFFER)
)
)
(* well, SETF is pretty close to CHANGE)
(DECLARE: EVAL@COMPILE
(DEFMACRO SETF (ACCESS-FORM VALUE-FORM)
(BQUOTE (CHANGE , ACCESS-FORM , VALUE-FORM)))
[DEFMACRO DEFSETF (NAME SETF-FUNCTION &REST MORE)
(if (OR MORE (NOT (LITATOM SETF-FUNCTION)))
then
(HELP "COMPLEX SETF NOT IMPLEMENTED"))
(BQUOTE (SAVEPUT (QUOTE (\, NAME))
(QUOTE SETFN)
(QUOTE (\, SETF-FUNCTION]
)
(PUTPROPS \GETBASEPTR SETFN \PUTBASEPTR)
(* somewhat bogus definitions)
(DEFINEQ
(CL:MAPCAR
[CL:LAMBDA (FUNCTION LIST &REST MORE-LISTS)
(COND
((NULL MORE-LISTS)
(MAPCAR LIST FUNCTION))
((NULL (CDR MORE-LISTS))
(MAP2CAR LIST (CAR MORE-LISTS)
FUNCTION))
(T (HELP "> 3 ARGS TO CL:MAPCAR"])
)
(DECLARE: EVAL@COMPILE
[DEFMACRO CL:PUSH (ITEM LIST)
(BQUOTE (push (\, LIST)
(\, ITEM]
[DEFMACRO DOLIST ((X L)
&BODY BODY)
(BQUOTE (FOR (\, X)
IN
(\, L)
DO
(PROGN (\,@ BODY]
[DEFMACRO DOTIMES (ITERFORM &BODY BODY)
(LET ((X (CAR ITERFORM))
(TIMES (CADR ITERFORM))
(RESULTFORM (CADDR ITERFORM)))
(BQUOTE (for (\, X)
from 0 to (SUB1 (\, TIMES))
do
(PROGN (\,@ BODY))
finally
(RETURN (\, (OR RESULTFORM NIL]
)
(DEFINEQ
(EXPAND-LOOP
[LAMBDA (LOOP-ARGS) (* Gregor: " 1-Jul-85 20:08")
(LET ((TAG (GENSYM))
(RESULT-VAR (GENSYM))
(PROLOGUE NIL)
(BODY NIL)
(EPILOGUE NIL))
[CL:DO ((REMAINING LOOP-ARGS))
((NULL REMAINING))
(COND
((SYMBOLP (CAR REMAINING))
(SETQ REMAINING (LOOP-EXPAND-BODY REMAINING]
(LIST (QUOTE PROG)
NIL TAG (CONS (QUOTE PROGN)
(REVERSE BODY))
(LIST (QUOTE GO)
TAG)
(CONS (QUOTE PROGN)
(REVERSE EPILOGUE))
(LIST (QUOTE RETURN)
RESULT-VAR])
(LOOP-EXPAND
[LAMBDA (LOOP-ARGS) (* Gregor: " 1-Jul-85 20:08")
(LET ((TAG (GENSYM))
(RESULT-VAR (GENSYM))
(PROLOGUE NIL)
(BODY NIL)
(EPILOGUE NIL))
[CL:DO ((REMAINING LOOP-ARGS))
((NULL REMAINING))
(COND
((SYMBOLP (CAR REMAINING))
(SETQ REMAINING (LOOP-EXPAND-BODY REMAINING]
(LIST (QUOTE PROG)
NIL TAG (CONS (QUOTE PROGN)
(REVERSE BODY))
(LIST (QUOTE GO)
TAG)
(CONS (QUOTE PROGN)
(REVERSE EPILOGUE))
(LIST (QUOTE RETURN)
RESULT-VAR])
(LOOP-EXPAND-BODY
[LAMBDA (REMAINING) (* kmk: " 3-Jul-85 19:57")
(LET ((KEYWORD (CAR REMAINING))
(ARG (CADR REMAINING))
(OPTION? (CADDR REMAINING))
(OPTION-ARG? (CADDDR REMAINING)))
(COND
((EQ KEYWORD (QUOTE DO))
(CL:PUSH ARG BODY)
(SETQ REMAINING (CDDR REMAINING)))
[(MEMBER KEYWORD (QUOTE (COLLECT APPEND NCONC SUM MAXIMIZE MINIMIZE)))
[COND
((EQ OPTION? (QUOTE INTO))
(SETQ RESULT-VAR OPTION-ARG?)
(SETQ REMAINING (CDDDDR REMAINING)))
(T (SETQ REMAINING (CDDR REMAINING]
(COND
((EQ KEYWORD (QUOTE COLLECT))
(CL:PUSH (LIST (QUOTE CL:PUSH)
ARG RESULT-VAR)
BODY)
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST (QUOTE REVERSE)
RESULT-VAR))
EPILOGUE))
((MEMBER KEYWORD (QUOTE (APPEND NCONC)))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST KEYWORD RESULT-VAR ARG))
BODY))
((EQ KEYWORD (QUOTE SUM))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST (QUOTE PLUS)
RESULT-VAR ARG))
BODY))
((MEMBER KEYWORD (QUOTE (MAXIMIZE MINIMIZE)))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST [CADR (MEMBER KEYWORD (QUOTE (MAXIMIZE MAX MINIMIZE
MIN]
RESULT-VAR ARG))
BODY]
(T (ERROR "Unrecognized LOOP keyword or implicit PROGN.")))
REMAINING])
(LOOP-EXPAND-FOR
[LAMBDA (REMAINING) (* Gregor: " 1-Jul-85 20:16")
(LET ((VAR (CADR REMAINING))
(PATH (CADDR REMAINING)))
(CL])
)
(DECLARE: EVAL@COMPILE
[DEFMACRO
CASE
(&WHOLE FORM)
(LET
((KV (GENSYM))
(CLAUSES NIL))
[CL:DO
((C (CDDR FORM)
(CDR C)))
((CL:ATOM C))
(COND
((CL:ATOM (CAR C))
(ERROR "~S -- Bad clause in CASE." (CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(CL:PUSH [BQUOTE (T (\,@ (CDAR C]
CLAUSES)
(RETURN NIL))
((NULL (CAAR C))
(CL:PUSH [BQUOTE ((NULL (\, KV))
(\,@ (CDAR C]
CLAUSES))
((NOT (CONSP (CAAR C)))
(CL:PUSH [BQUOTE ((EQL (QUOTE (\, (CAAR C)))
(\, KV))
(\,@ (CDAR C]
CLAUSES))
(T (CL:PUSH [BQUOTE ([OR (\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(REVERSE Y))
(CL:PUSH (BQUOTE (EQL (QUOTE (\, (CAR X)))
(\, KV)))
Y]
(\,@ (CDAR C]
CLAUSES]
(BQUOTE (LET [((\, KV)
(\, (CADR FORM]
(COND (\,@ (REVERSE CLAUSES]
)
(DEFINEQ
(CASE-1
[LAMBDA (FOR-WHO CLAUSES KEY-VARIABLE TEST-FN DEFAULT-T-CLAUSE-FORM ALLOW-NIL-P ALLOW-REPEATS-P
ALLOW-OTHERWISE-OR-T-P) (* Gregor: " 2-Jul-85 15:37")
(* * Note that the fact that we only take one TEST argument which looks for a key in a keylist means that the
compiler should have an optimizer for fmemb when the second argument is a constant list of length one
(or maybe even two))
(LET ((SAW-OTHERWISE-OR-T NIL)
(ALL-KEYS NIL)
(COND-CLAUSES NIL))
[for CLAUSE-LOC on CLAUSES
do (LET* [(KEYLIST (CAAR CLAUSE-LOC))
(BODY (CDAR CLAUSE-LOC))
(TEST (COND
((NULL KEYLIST)
(OR (NOT (NULL ALLOW-NIL-P))
(ERROR FOR-WHO "Can't have NIL as a keylist."))
NIL)
((MEMB KEYLIST (QUOTE (T OTHERWISE)))
(OR (NOT (NULL ALLOW-OTHERWISE-OR-T-P))
(ERROR FOR-WHO "Can't have an otherwise (or T) keylist."))
(SETQ SAW-OTHERWISE-OR-T T)
(AND (CDR CLAUSE-LOC)
(* When Compiling warn about clauses being ignored.)
)
T)
(T [COND
((NOT (LISTP KEYLIST))
(SETQ KEYLIST (LIST KEYLIST]
[for X on KEYLIST
do (COND
([AND (NOT (NULL (CDR X)))
(NOT (LISTP (CDR X]
(ERROR FOR-WHO (CONCAT "The Keylist " KEYLIST
" has a non-list cdr.")))
((NOT (SYMBOLP (CAR X)))
(ERROR FOR-WHO (CONCAT
"Not all the elements of the keylist "
KEYLIST " are symbols.")))
(T (AND (MEMB (CAR X)
ALL-KEYS)
(NOT (NULL ALLOW-REPEATS-P))
(ERROR FOR-WHO (CONCAT "The same key ("
(CAR X)
") can't appear in more that one keylist.")))
(CL:PUSH (CAR X)
ALL-KEYS]
(LIST TEST-FN KEY-VARIABLE (LIST (QUOTE QUOTE)
KEYLIST]
(AND TEST (SETQ COND-CLAUSES (NCONC COND-CLAUSES
(LIST (CONS TEST BODY]
[OR SAW-OTHERWISE-OR-T (SETQ COND-CLAUSES (NCONC COND-CLAUSES (LIST (LIST T
DEFAULT-T-CLAUSE-FORM]
(LIST COND-CLAUSES ALL-KEYS])
)
(DECLARE: EVAL@COMPILE
[DEFMACRO DESTRUCTURING-BIND (VARIABLE-PATTERN VALUE-PATTERN . BODY)
(DECLARE (SPECVARS D-B-BOUND-SYMBOLS D-B-SETQS))
(LET ((D-B-VALUE-SYMBOL (QUOTE D-B-VALUE))
(D-B-BOUND-SYMBOLS NIL)
(D-B-SETQS NIL))
(DESTRUCTURING-BIND-1 VARIABLE-PATTERN)
(BQUOTE (LET , D-B-BOUND-SYMBOLS (LET ((, D-B-VALUE-SYMBOL , VALUE-PATTERN))
,@ D-B-SETQS)
,@ BODY]
[DEFMACRO DESETQ (VARIABLE-PATTERN VALUE-PATTERN &REST L)
(COND [(NULL L)
(DECLARE (GLOBALVARS D-B-BOUND-SYMBOLS D-B-SETQS))
(LET ((D-B-VALUE-SYMBOL (QUOTE D-B-VALUE))
(D-B-BOUND-SYMBOLS NIL)
(D-B-SETQS NIL))
(DESTRUCTURING-BIND-1 VARIABLE-PATTERN)
(BQUOTE (LET ((, D-B-VALUE-SYMBOL , VALUE-PATTERN))
,@ D-B-SETQS]
(T (BQUOTE (PROGN (DESETQ , VARIABLE-PATTERN , VALUE-PATTERN)
(PROGN (DESETQ ,@ L]
)
(DEFINEQ
(DESTRUCTURING-BIND-1
[LAMBDA (VARIABLE-PATTERN) (* Gregor: " 5-Jul-85 12:27")
(DECLARE (SPECVARS D-B-VALUE-SYMBOL D-B-BOUND-SYMBOLS D-B-SETQS))
(* * This function is called by both destructuring-bind and desetq. That destructuring-bind does not expand
directly into a prog and a desetq is just an efficiency hack, it prevents two walks through the variable-pattern.)
(* * There is a little hair here to avoid having to gensym a symbol for the result of evaluating the value-pattern
unless the symbol we normally use is one of the symbols in the variable-pattern. This may be silly, but since its
done I am not going to take it out.)
[PROG NIL
REDO(SETQ D-B-BOUND-SYMBOLS NIL)
(SETQ D-B-SETQS NIL)
(DESTRUCTURING-BIND-2 VARIABLE-PATTERN)
(COND
((MEMB D-B-VALUE-SYMBOL D-B-BOUND-SYMBOLS)
(SETQ D-B-VALUE-SYMBOL (GENSYM))
(GO REDO]
(SETQ D-B-BOUND-SYMBOLS (REVERSE D-B-BOUND-SYMBOLS))
(SETQ D-B-SETQS (REVERSE D-B-SETQS])
(DESTRUCTURING-BIND-2
[LAMBDA (PATTERN CHAIN) (* Gregor: " 5-Jul-85 12:27")
(* * No optimization of (car (cdr x)) into (cadr x) is done and moreover, not optimization of
(cadr x) followed by (caddr x) is done, all of those optimizations should be done by the compiler.)
(DECLARE (SPECVARS D-B-BOUND-SYMBOLS D-B-SETQS))
(COND
((LISTP PATTERN)
(DESTRUCTURING-BIND-2 (CAR PATTERN)
(CONS (QUOTE CAR)
CHAIN))
(DESTRUCTURING-BIND-2 (CDR PATTERN)
(CONS (QUOTE CDR)
CHAIN)))
((NOT (NULL PATTERN))
(SETQ D-B-BOUND-SYMBOLS (CONS PATTERN D-B-BOUND-SYMBOLS))
(SETQ D-B-SETQS (CONS (LIST (QUOTE SETQ)
PATTERN
(DESTRUCTURING-BIND-3 CHAIN))
D-B-SETQS])
(DESTRUCTURING-BIND-3
[LAMBDA (CHAIN VALUE-PATTERN-VARIABLE) (* Gregor: " 1-Jul-85 17:10")
(DECLARE (GLOBALVARS D-B-VALUE-SYMBOL))
(COND
((NULL CHAIN)
D-B-VALUE-SYMBOL)
(T (LIST (CAR CHAIN)
(DESTRUCTURING-BIND-3 (CDR CHAIN])
)
(SETTEMPLATE (QUOTE CATCH)
(QUOTE (.. EVAL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA CATCH)
(ADDTOVAR NLAML DEFCONSTANT)
(ADDTOVAR LAMA CL:APPLY CL:MEMBER MACROEXPAND-1 CL:MAPCAR)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3798 6394 (CL:EQUAL 3808 . 4213) (CL:LENGTH 4215 . 4616) (FBOUNDP 4618 . 4724) (EQUALP
4726 . 5250) (MACROEXPAND-1 5252 . 5448) (RAISEATS 5450 . 5797) (CMLTRANSLATE 5799 . 6158) (
SPECIAL-FORM-P 6160 . 6248) (DEFCONSTANT 6250 . 6392)) (6562 8835 (EQL 6572 . 6866) (CL:MEMBER 6868 .
8464) (COPY-LIST 8466 . 8518) (IDENTITY 8520 . 8555) (CL:APPLY 8557 . 8833)) (12157 12527 (INTEGERP
12167 . 12228) (SYMBOLP 12230 . 12277) (CONSP 12279 . 12438) (CL:LISTP 12440 . 12525)) (12827 13103 (
DWIMKEYWORD 12837 . 13101)) (14334 20049 (DEFUN.DECODE 14344 . 15170) (\LAMBDA.CL.TO.IL 15172 . 15392)
(\DEFUN.DECODE.&KEYS 15394 . 18925) (\CL-LAMBDA-FNTYP 18927 . 19702) (\SPECALIZEDP 19704 . 20047)) (
20853 22068 (\DO.TRANSLATE 20863 . 22066)) (22160 23974 (CMLRDTBL 22170 . 23913) (CMLREADVBAR 23915 .
23972)) (24417 27402 (CATCH 24427 . 24743) (\CATCH.AUX 24745 . 25730) (\CATCH.FINDFRAME 25732 . 25999)
(\CATCH.TAG.INTERN 26001 . 26443) (THROW 26445 . 26621) (\THROW.AUX 26623 . 27400)) (29609 29897 (
CL:MAPCAR 29619 . 29895)) (30404 33517 (EXPAND-LOOP 30414 . 31054) (LOOP-EXPAND 31056 . 31696) (
LOOP-EXPAND-BODY 31698 . 33313) (LOOP-EXPAND-FOR 33315 . 33515)) (34427 36884 (CASE-1 34437 . 36882))
(37753 40054 (DESTRUCTURING-BIND-1 37763 . 38885) (DESTRUCTURING-BIND-2 38887 . 39740) (
DESTRUCTURING-BIND-3 39742 . 40052)))))
STOP