(FILECREATED " 1-Aug-85 16:40:38" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;52 32929
changes to: (VARS CMLTRANSLATIONS CMLSPECIALFORMSCOMS) (FNS MACROEXPAND-1 RAISEATS CMLTRANSLATE
\DO.TRANSLATE CATCH \CATCH.AUX \CATCH.TAG.INTERN EXPAND-LOOP LOOP-EXPAND LOOP-EXPAND-BODY
LOOP-EXPAND-FOR CASE-1 DESTRUCTURING-BIND-1 DESTRUCTURING-BIND-2) (MACROS CL:MEMBER CASE \KEYSEARCH
CATCH CL:DO* UNWIND-PROTECT) (TEMPLATES CATCH)
previous date: "28-Jul-85 11:50:15" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;48)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS ((COMS (* random vanilla functions) (FNS CL:EQUAL FBOUNDP EQUALP
MACROEXPAND-1 RAISEATS CMLTRANSLATE SPECIAL-FORM-P) (P (MOVD (QUOTE FMEMB) (QUOTE MEMQ)) (MOVD (QUOTE
NLISTP) (QUOTE CL:ATOM)) (MOVD (QUOTE GETPROP) (QUOTE GET)) (MOVD (QUOTE RPAQ) (QUOTE DEFVAR)) (MOVD (
QUOTE RPAQ) (QUOTE DEFCONSTANT))) (FNS EQL CL:MEMBER COPY-LIST IDENTITY) (MACROS CL:MEMBER CL:SETQ
CL:IF CL:UNLESS CL:WHEN COPY-LIST IDENTITY UNWIND-PROTECT) (* treat FUNCALL like SPREADAPPLY*, i.e.,
result is random on special-forms) (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) (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) (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) (LAMA CL:MEMBER
MACROEXPAND-1)))))
(* 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])
(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])
)
(MOVD (QUOTE FMEMB) (QUOTE MEMQ))
(MOVD (QUOTE NLISTP) (QUOTE CL:ATOM))
(MOVD (QUOTE GETPROP) (QUOTE GET))
(MOVD (QUOTE RPAQ) (QUOTE DEFVAR))
(MOVD (QUOTE RPAQ) (QUOTE DEFCONSTANT))
(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])
)
(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) (\EQL-IS-EQ
(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 N)))
(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)))
)
(* treat FUNCALL like SPREADAPPLY*, i.e., result is random on special-forms)
(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)
(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) (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) (* . 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))
)
(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 "12-Jul-85 23:25")
(LET (VRBLS OPTVARS AUXLIST RESTFORM VARTYP ARGVAR BODY KEYWORDS (CNT 1))
[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))
[&REST (NEED.ARGVAR)
(SETQ RESTFORM (BQUOTE ((, BINDING
(for \Index from , CNT to , ARGVAR
collect (ARG , ARGVAR \Index]
(&AUX (push AUXLIST BINDING))
[&KEY
(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 OPTVARS (LIST SVAR T)))
(push
OPTVARS
(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)))
(if (AND (NULL OPTVARS)
(NULL (CADR BINDING))
(NULL SVAR))
then (* simple all args optional)
(push VRBLS (CAR BINDING))
else (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]
(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))
(LET [,. (for VAR in (REVERSE VRBLS) as I from 1
collect (LIST VAR (BQUOTE (ARG , ARGVAR , I]
(LET* (,@ (REVERSE OPTVARS)
,. 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 (* edited: "22-Jul-85 23:29")
(* 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 (MACRO FIRST (LAMBDA (STREAM RDTBL)
(UNTIL (EQ (READCCODE STREAM)
(CHARCODE NEWLINE)))
(READ STREAM RDTBL]
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)
(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)
(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 ((X TIMES) &BODY BODY) (BQUOTE (FOR (\, X) FROM 1 TO (\, TIMES) DO (PROGN (\,@ BODY)
))))
)
(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) (NREVERSE Y)) (CL:PUSH (BQUOTE (EQL (QUOTE (\, (CAR X))) (\,
KV))) Y)))) (\,@ (CDAR C)))) CLAUSES)))) (BQUOTE (LET (((\, KV) (\, (CADR FORM)))) (COND (\,@ (
NREVERSE 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 )
(ADDTOVAR LAMA CL:MEMBER MACROEXPAND-1)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3351 5025 (CL:EQUAL 3361 . 3751) (FBOUNDP 3753 . 3860) (EQUALP 3862 . 4370) (
MACROEXPAND-1 4372 . 4523) (RAISEATS 4525 . 4723) (CMLTRANSLATE 4725 . 4935) (SPECIAL-FORM-P 4937 .
5023)) (5208 7120 (EQL 5218 . 5511) (CL:MEMBER 5513 . 7027) (COPY-LIST 7029 . 7081) (IDENTITY 7083 .
7118)) (9744 10011 (INTEGERP 9754 . 9813) (SYMBOLP 9815 . 9862) (CONSP 9864 . 9921) (CL:LISTP 9923 .
10009)) (10276 10549 (DWIMKEYWORD 10286 . 10547)) (11347 16760 (DEFUN.DECODE 11357 . 12242) (
\LAMBDA.CL.TO.IL 12244 . 12465) (\DEFUN.DECODE.&KEYS 12467 . 15659) (\CL-LAMBDA-FNTYP 15661 . 16420) (
\SPECALIZEDP 16422 . 16758)) (17547 18410 (\DO.TRANSLATE 17557 . 18408)) (18502 20383 (CMLRDTBL 18512
. 20322) (CMLREADVBAR 20324 . 20381)) (20789 23170 (CATCH 20799 . 20989) (\CATCH.AUX 20991 . 21634) (
\CATCH.FINDFRAME 21636 . 21894) (\CATCH.TAG.INTERN 21896 . 22193) (THROW 22195 . 22369) (\THROW.AUX
22371 . 23168)) (25334 27525 (EXPAND-LOOP 25344 . 25793) (LOOP-EXPAND 25795 . 26244) (LOOP-EXPAND-BODY
26246 . 27387) (LOOP-EXPAND-FOR 27389 . 27523)) (28282 30001 (CASE-1 28292 . 29999)) (30787 32627 (
DESTRUCTURING-BIND-1 30797 . 31735) (DESTRUCTURING-BIND-2 31737 . 32388) (DESTRUCTURING-BIND-3 32390
. 32625)))))
STOP