(FILECREATED " 5-Feb-86 15:14:46" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;90 48684
changes to: (MACROS DOLIST CL:PUSHNEW SHIFTF)
(VARS CMLSPECIALFORMSCOMS)
previous date: " 3-Feb-86 22:52:16" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;88)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS [(COMS (* random vanilla functions)
(FNS %%MACROEXPAND-1 CL:EQUAL CL:LENGTH CLISPEXPANSION EQUALP
EVAL-WHEN MACRO-FUNCTION MACROEXPAND-1 RAISEATS RETURN-FROM
SPECIAL-FORM-P DEFCONSTANT)
(MACROS CL:DECLARE CL:PUSHNEW DEFPARAMETER LABELS LOOP SHIFTF)
(P (MOVD (QUOTE ERROR)
(QUOTE CL:ERROR))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE DREVERSE)
(QUOTE NREVERSE)))
(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 * CODEWALKCOMS)
(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 (*MACROEXPAND-HOOK* (QUOTE FUNCALL))
(*MACROS*))
(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 (* 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 GET SYMBOL-PLIST SYMBOL-VALUE SYMBOL-FUNCTION)
(COMS (* somewhat bogus definitions)
(MACROS CL:PUSH DOLIST DOTIMES)
(FNS EXPAND-LOOP LOOP-EXPAND LOOP-EXPAND-BODY LOOP-EXPAND-FOR)
(MACROS CASE ECASE)
(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 EVAL-WHEN)
(NLAML DEFCONSTANT RETURN-FROM)
(LAMA MACROEXPAND-1 CL:APPLY CL:MEMBER MACROEXPAND-1])
(* random vanilla functions)
(DEFINEQ
(%%MACROEXPAND-1
[CL:LAMBDA (FORM) (* lmm " 6-Jan-86 17:44")
(COND
((NOT (CONSP FORM))
FORM)
((NOT (SYMBOLP (CAR FORM)))
FORM)
(T (LET [(TEMP (MACRO-FUNCTION (CAR FORM]
(COND
(TEMP (FUNCALL *MACROEXPAND-HOOK* TEMP FORM))
(T FORM])
(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))))
(CLISPEXPANSION
[LAMBDA (X) (* lmm " 6-Jan-86 18:08")
(AND (GETPROP (CAR X)
(QUOTE CLISPWORD))
(OR (GETHASH X CLISPARRAY)
(PROGN (RESETVARS ((NOSPELLFLG T))
(DWIMIFY0? X X X NIL NIL NIL (QUOTE VARSBOUND)))
(GETHASH X CLISPARRAY])
(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])
(EVAL-WHEN
[NLAMBDA L (* raf
"25-Jan-86 00:56")
(LET ((SITUATIONS (CAR L))
(FORMS (CDR L)))
(CL:IF (CL:MEMBER (QUOTE EVAL)
SITUATIONS)
(CL:MAP NIL (FUNCTION EVAL)
FORMS])
(MACRO-FUNCTION
[LAMBDA (X) (* lmm " 6-Jan-86 18:23")
"If the symbol globally names a macro, returns the expansion function, else returns NIL."
(LET (MD)
(COND
[(SETQ MD (CDR (ASSOC X *MACROS*)))
(BQUOTE (LAMBDA (FORM ENV)
(MACROEXPANSION FORM (QUOTE (DEFMACRO (\,@ MD]
[(AND [NOT (FMEMB (ARGTYPE X)
(QUOTE (0 2]
(SETQ MD (GETMACROPROP X COMPILERMACROPROPS)))
(BQUOTE (LAMBDA (FORM ENV)
(MACROEXPANSION FORM (QUOTE (\, MD]
(T (AND (NOT (GETD X))
(GETPROP X (QUOTE CLISPWORD))
(FUNCTION CLISPEXPANSION])
(MACROEXPAND-1
(CL:LAMBDA (FORM &OPTIONAL (ENV NIL ENVP)) (* lmm " 6-Jan-86 18:04")
(* * If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating
whether the form was, in fact, a macro.)
(* LET ((%%VENV%% (FIRST ENV)) (%%FENV%% (SECOND ENV)) (%%BENV%% (THIRD ENV)) (%%GENV%% (FOURTH ENV)))
(%%MACROEXPAND-1 FORM))
(if ENVP
then (HELP "environment to MACROEXPAND-1"))
(%%MACROEXPAND-1 FORM)))
(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])
(RETURN-FROM
[NLAMBDA (NAME RESULT) (* raf " 5-Dec-85 17:17")
(RETFROM NAME (EVAL RESULT])
(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])
)
(DECLARE: EVAL@COMPILE
(DEFMACRO CL:DECLARE (&REST DECLS)
"This temporarily removes any effect that declarations might have"
(BQUOTE NIL))
[DEFMACRO CL:PUSHNEW (ITEM PLACE &KEY (TEST (QUOTE (FUNCTION EQL)))
TEST-NOT)
(CL:IF TEST-NOT [BQUOTE (CL:IF (CL:APPLY (\, TEST-NOT)
(\, ITEM)
(\, PLACE))
(CL:PUSH (\, ITEM)
(\, PLACE]
(BQUOTE (CL:IF (NOT (CL:APPLY (\, TEST)
(\, ITEM)
(\, PLACE)))
(CL:PUSH (\, ITEM)
(\, PLACE]
[DEFMACRO DEFPARAMETER (NAME INITIAL-VALUE &OPTIONAL (DOCUMENTATION NIL))
(BQUOTE (PROG1 (SETQ (\, NAME)
(\, INITIAL-VALUE))
(SETF (GET (QUOTE (\, NAME))
(QUOTE PARAMETER))
(QUOTE (\, (OR DOCUMENTATION INITIAL-VALUE]
[DEFMACRO LABELS (THEM &BODY BODY)
(BQUOTE (PROGN [\,@ (for TH in THEM collect
(BQUOTE (PUTD (QUOTE (\, (CAR TH)))
(LET [(DEF (FUNCTION (CL:LAMBDA (\, (CADR TH))
(\,@ (CDDR TH]
(CL:IF (SYMBOLP DEF)
(GETD DEF)
DEF]
(\,@ BODY]
[DEFMACRO LOOP (&REST FORMS)
(LET ((TAG (GENSYM "LOOPTAG")))
(BQUOTE (PROG NIL (\, TAG)
(\,@ FORMS)
(GO (\, TAG]
[DEFMACRO SHIFTF (&REST PLACESANDVALUE)
(LET [(SYMS (FOR I FROM 1 TO (1- (CL:LENGTH PLACESANDVALUE))
COLLECT
(LIST (GENSYM)
(CL:NTH I PLACESANDVALUE]
(BQUOTE (LET (\, SYMS)
[\,@ (for I from 0 to (- (LENGTH PLACESANDVALUE)
2)
collect
(BQUOTE (SETF (\, (CL:NTH I PLACESANDVALUE))
(\, (CAR (CL:NTH I SYMS]
(\, (CAAR SYMS]
)
(MOVD (QUOTE ERROR)
(QUOTE CL:ERROR))
(MOVD (QUOTE FMEMB)
(QUOTE MEMQ))
(MOVD (QUOTE NLISTP)
(QUOTE CL:ATOM))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE DREVERSE)
(QUOTE NREVERSE))
(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
(CL:LAMBDA (THING)
"Returns what was passed to it. Default for :key options." THING))
(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)
(LET ((TESTC (CONSTANTEXPRESSIONP TEST))
(KEYC (CONSTANTEXPRESSIONP KEY))
(TESTNOTC (CONSTANTEXPRESSIONP TEST-NOT))
(LISTC (CONSTANTEXPRESSIONP LIST)))
[if [AND LISTC KEYC (EQ (CAR 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 " 4-Nov-85 19:02")
(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))))
(RPAQQ CODEWALKCOMS ((FNS RECURSIVE-CODE-WALK CODE-WALK-TEMPLATE CODE-WALK-TEMPLATE-1
CODE-WALK-TEMPLATE-TAIL CODEWALK GET-CODE-WALK-TEMPLATE MACROEXPAND-1
MERGE-TEMPLATES RECONS)
(MACROS COMPILER-LET MACROLET FLET)
(PROP CODE-WALK-TEMPLATE DECLARE)))
(DEFINEQ
(RECURSIVE-CODE-WALK
[LAMBDA (FRM CONTEXT) (* lmm " 6-Jan-86 18:03")
(if (NEQ FRM (SETQ FRM (APPLY* FN FRM CONTEXT)))
then FRM
else (if (NLISTP FRM)
then FRM
elseif (SELECTQ (SYSTEMTYPE)
[D (NEQ FRM (SETQ FRM (MACROEXPAND-1 FRM]
(HELP))
then (RECURSIVE-CODE-WALK FRM CONTEXT)
else (LET [(TEMPLATE (GET-CODE-WALK-TEMPLATE (CAR FRM]
(if TEMPLATE
then (CODE-WALK-TEMPLATE FRM TEMPLATE)
else FRM])
(CODE-WALK-TEMPLATE
[LAMBDA (FORM TEMPLATE) (* lmm " 3-Jan-86 22:16")
(LET ((VARS VARS))
(CODE-WALK-TEMPLATE-1 FORM TEMPLATE])
(CODE-WALK-TEMPLATE-1
[LAMBDA (FORM TEMPLATE) (* lmm " 6-Jan-86 16:14")
(COND
[TEMPLATE
(COND
[(LISTP TEMPLATE)
(SELECTQ (CAR TEMPLATE)
[IF (LET ((EXPR FORM))
(DECLARE (SPECVARS EXPR))
(CODE-WALK-TEMPLATE-1 FORM (COND
((COND
((LISTP (CADR TEMPLATE))
(EVAL (CADR TEMPLATE)))
(T (APPLY* (CADR TEMPLATE)
FORM)))
(CADDR TEMPLATE))
(T (CADDDR TEMPLATE]
[.. (CODE-WALK-TEMPLATE-TAIL (CDR TEMPLATE)
FORM
(NLEFT FORM (LENGTH (CDDR TEMPLATE]
(MACRO (HELP)
(ADDTO (QUOTE CALL)
(CAR FORM)
PARENT)
(MSPRGMACRO FORM (CDR TEMPLATE)))
[BOTH (if NOCOPY
then (CODE-WALK-TEMPLATE-1 FORM (CADR TEMPLATE))
(CODE-WALK-TEMPLATE-1 FORM (CADDR TEMPLATE))
else (CODE-WALK-TEMPLATE-1 FORM (MERGE-TEMPLATES (CADR
TEMPLATE)
(CADDR
TEMPLATE]
[@ (HELP)
(PROG ((EXPR FORM))
(DECLARE (SPECVARS EXPR))
(MSPRGTEMPLATE1 (EVAL (CADR TEMPLATE))
(EVAL (CADDR TEMPLATE]
(REMOTE (CODE-WALK-TEMPLATE-1 FORM (CADR TEMPLATE)))
(COND
((NLISTP FORM)
FORM)
(T (RECONS FORM (CODE-WALK-TEMPLATE-1 (CAR FORM)
(CAR TEMPLATE))
(CODE-WALK-TEMPLATE-1 (CDR FORM)
(CDR TEMPLATE]
(T
(SELECTQ
TEMPLATE
(CALL FORM)
((EVAL EVALQT RETURN FUNCTION FUNCTIONAL SMASH TEST EFFECT STACK PROP RETURN
TESTRETURN)
(RECURSIVE-CODE-WALK FORM (QUOTE EVAL)))
((NIL PPE)
FORM)
[LAMBDA
(SELECTQ
(CAR (LISTP FORM))
[[LAMBDA NLAMBDA]
(CODE-WALK-TEMPLATE FORM (QUOTE (NIL (IF LISTP (.. BIND)
(IF (PROGN FORM) BIND))
.. EFFECT RETURN]
[CL:LAMBDA (CODE-WALK-TEMPLATE
FORM
(QUOTE (NIL (IF LISTP (BOTH (NIL EVAL)
(BIND))
(IF [NOT (FMEMB FORM
(QUOTE (&OPTIONAL &REST
&KEY
&AUX]
BIND))
.. EFFECT RETURN]
FORM]
(BIND (push VARS FORM)
FORM)
((SET)
(RECURSIVE-CODE-WALK FORM (QUOTE SET)))
(SHOULDNT TEMPLATE]
(T FORM])
(CODE-WALK-TEMPLATE-TAIL
[LAMBDA (REST FORM TAIL) (* lmm " 3-Jan-86 22:17")
(if (EQ FORM TAIL)
then (CODE-WALK-TEMPLATE-1 FORM (CDR REST))
else (RECONS FORM (CODE-WALK-TEMPLATE-1 (CAR FORM)
(CAR REST))
(CODE-WALK-TEMPLATE-TAIL REST (CDR FORM)
TAIL])
(CODEWALK
[LAMBDA (X FN CONTEXT NOCOPY) (* lmm " 4-Jan-86 00:00")
(OR FN (SETQ FN (QUOTE EVQ)))
(LET (VARS)
(CODE-WALK-TEMPLATE X (OR CONTEXT (QUOTE EVAL])
(GET-CODE-WALK-TEMPLATE
[LAMBDA (X) (* lmm " 4-Jan-86 00:01")
(if (LISTP X)
then (QUOTE [LAMBDA .. EVAL])
else (OR (GETPROP X (QUOTE CODE-WALK-TEMPLATE))
(GETHASH X MSTEMPLATES)
(if (NLAMBDAFNP X)
then (QUOTE (CALL))
else (QUOTE (CALL .. EVAL])
(MACROEXPAND-1
(CL:LAMBDA (FORM &OPTIONAL (ENV NIL ENVP)) (* lmm " 6-Jan-86 18:04")
(* * If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating
whether the form was, in fact, a macro.)
(* LET ((%%VENV%% (FIRST ENV)) (%%FENV%% (SECOND ENV)) (%%BENV%% (THIRD ENV)) (%%GENV%% (FOURTH ENV)))
(%%MACROEXPAND-1 FORM))
(if ENVP
then (HELP "environment to MACROEXPAND-1"))
(%%MACROEXPAND-1 FORM)))
(MERGE-TEMPLATES
[LAMBDA (X Y) (* lmm " 3-Jan-86 21:58")
(COND
((NULL X)
Y)
((NULL Y)
X)
[(LISTP X)
(SELECTQ (CAR X)
[IF (COND
[(AND (EQ (CAR Y)
(QUOTE IF))
(EQ (CADR Y)
(CADR X)))
(LIST (QUOTE IF)
(CADR Y)
(MERGE-TEMPLATES (CADDR X)
(CADDR Y))
(MERGE-TEMPLATES (CADDDR X)
(CADDDR Y]
(T (HELP]
[.. (OR (EQLENGTH (CDR X)
(LENGTH (CDR Y)))
(HELP))
(CONS (CAR X)
(MERGE-TEMPLATES (CDR X)
(CDR Y]
((MACRO BOTH @ REMOTE)
(HELP))
(if (NLISTP Y)
then (HELP)
else (CONS (MERGE-TEMPLATES (CAR X)
(CAR Y))
(MERGE-TEMPLATES (CDR X)
(CDR Y]
(T (HELP])
(RECONS
[LAMBDA (X CAR CDR) (* lmm " 3-Jan-86 22:08")
(if (AND (OR (NEQ (CAR X)
CAR)
(NEQ (CDR X)
CDR))
(NOT NOCOPY))
then (CONS CAR CDR)
else X])
)
(DECLARE: EVAL@COMPILE
[DEFMACRO COMPILER-LET (VARS . FORMS)
(MKPROGN (EVAL (BQUOTE (LET , VARS (CODEWALK (QUOTE , FORMS)
(FUNCTION IDENTITY)
(QUOTE (.. EVAL]
[DEFMACRO MACROLET (MACRODEFS . FORMS)
(LET ((*MACROS* (APPEND MACRODEFS *MACROS*)))
(MKPROGN (CODEWALK FORMS (FUNCTION IDENTITY)
(QUOTE (.. EVAL]
[DEFMACRO FLET (FNBINDINGS . FORMS)
(LET [(FNS (MAPCAR FNBINDINGS (FUNCTION (LAMBDA (X)
(GENSYM]
(BQUOTE (LET , [for X in FNBINDINGS as Y in FNS collect
(BQUOTE ((\, Y)
(FUNCTION (LAMBDA (\,@ (CDR X]
(MACROLET , [for X in FNBINDINGS as Y in FNS collect
(BQUOTE ((\, (CAR X))
(&REST BODY)
(LIST* (QUOTE APPLY*)
(QUOTE , Y)
BODY]
., FORMS]
)
(PUTPROPS DECLARE CODE-WALK-TEMPLATE (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))
(RPAQQ *MACROEXPAND-HOOK* FUNCALL)
(RPAQQ *MACROS* NIL)
(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])
)
(* 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 ((BODY (LISPFORM.SIMPLIFY (MKPROGN FORMS)
T))
(CTAG (CONSTANTEXPRESSIONP TAGFORM)))
(COND [CTAG (SETQ CTAG (\CATCH.TAG.INTERN (CAR CTAG)))
(BQUOTE (\CATCHRUNFUN
(FUNCTION
(LAMBDA NIL
([LAMBDA
((\, CTAG))
(DECLARE
(SPECVARS (\, CTAG)))
(\, BODY]
(\MYALINK]
(T (BQUOTE (\CATCH.AUX (\, TAGFORM)
(FUNCTION (LAMBDA NIL
(\, BODY]
(PUTPROPS *CATCH MACRO (= . CATCH))
(PUTPROPS \CATCHRUNFUN DMACRO (= . SPREADAPPLY*))
[PUTPROPS THROW DMACRO (DEFMACRO (TAGFORM &REST FORMS)
(LET ((BODY (LISPFORM.SIMPLIFY (MKPROGN FORMS)
T))
(CTAG (CONSTANTEXPRESSIONP TAGFORM)))
(COND (CTAG (LIST (QUOTE \THROW.AUX)
(\CATCH.TAG.INTERN (CAR CTAG))
(KWOTE (CAR CTAG))
(CADR BODY)))
(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)
(PUTPROPS GET SETFN PUTPROP)
(PUTPROPS SYMBOL-PLIST SETFN SETPROPLIST)
(PUTPROPS SYMBOL-VALUE SETFN SET)
(PUTPROPS SYMBOL-FUNCTION SETFN PUTD)
(* somewhat bogus definitions)
(DECLARE: EVAL@COMPILE
[DEFMACRO CL:PUSH (ITEM LIST)
(BQUOTE (push (\, LIST)
(\, ITEM]
[DEFMACRO DOLIST (HEADER &BODY BODY)
(LET ((X (CAR HEADER))
(L (CADR HEADER))
(R (CADDR HEADER)))
(BQUOTE (for (\, X)
in
(\, L)
do
(\,@ BODY)
finally
(RETURN (\, R]
[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]
[DEFMACRO
ECASE
(&WHOLE FORM)
(LET
((KV (GENSYM))
(CLAUSES NIL))
[CL:DO
((C (CDDR FORM)
(CDR C))
(KEYS NIL (APPEND (COND ((CL:ATOM (CAAR C))
(LIST (CAAR C)))
(T (CAAR C)))
KEYS)))
((CL:ATOM C)
(CL:PUSH [BQUOTE (T (CL:ERROR "Ecase key must be one of ~S" (QUOTE (\, KEYS]
CLAUSES))
(COND
((CL:ATOM (CAR C))
(CL:ERROR (QUOTE :BAD-MACRO-FORMAT)
"~S -- Bad clause in ECASE."
(CAR C)))
((MEMQ (CAAR C)
(QUOTE (T OTHERWISE)))
(CL:ERROR "T or Otherwise clause is not permitted in ECASE."))
((CL:ATOM (CAAR C))
(CL:PUSH [BQUOTE ([EQL (\, KV)
(QUOTE (\, (CAAR C]
(\,@ (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 (\, KV)
(QUOTE (\, (CAR X]
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) (* raf " 7-Nov-85 17:42")
(DECLARE (SPECVARS D-B-VALUE-SYMBOL))
(COND
((NULL CHAIN)
D-B-VALUE-SYMBOL)
(T (LIST (CAR CHAIN)
(DESTRUCTURING-BIND-3 (CDR CHAIN])
)
(SETTEMPLATE (QUOTE CATCH)
(QUOTE (CALL CALL .. EVAL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA CATCH EVAL-WHEN)
(ADDTOVAR NLAML DEFCONSTANT RETURN-FROM)
(ADDTOVAR LAMA MACROEXPAND-1 CL:APPLY CL:MEMBER MACROEXPAND-1)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3283 7759 (%%MACROEXPAND-1 3293 . 3649) (CL:EQUAL 3651 . 4056) (CL:LENGTH 4058 . 4459)
(CLISPEXPANSION 4461 . 4826) (EQUALP 4828 . 5352) (EVAL-WHEN 5354 . 5749) (MACRO-FUNCTION 5751 . 6481)
(MACROEXPAND-1 6483 . 7024) (RAISEATS 7026 . 7373) (RETURN-FROM 7375 . 7523) (SPECIAL-FORM-P 7525 .
7613) (DEFCONSTANT 7615 . 7757)) (9568 11912 (EQL 9578 . 9872) (CL:MEMBER 9874 . 11470) (COPY-LIST
11472 . 11524) (IDENTITY 11526 . 11632) (CL:APPLY 11634 . 11910)) (15037 15384 (INTEGERP 15047 . 15108
) (SYMBOLP 15110 . 15157) (CONSP 15159 . 15295) (CL:LISTP 15297 . 15382)) (15933 22270 (
RECURSIVE-CODE-WALK 15943 . 16561) (CODE-WALK-TEMPLATE 16563 . 16755) (CODE-WALK-TEMPLATE-1 16757 .
19394) (CODE-WALK-TEMPLATE-TAIL 19396 . 19775) (CODEWALK 19777 . 20016) (GET-CODE-WALK-TEMPLATE 20018
. 20416) (MACROEXPAND-1 20418 . 20959) (MERGE-TEMPLATES 20961 . 21986) (RECONS 21988 . 22268)) (23527
29242 (DEFUN.DECODE 23537 . 24363) (\LAMBDA.CL.TO.IL 24365 . 24585) (\DEFUN.DECODE.&KEYS 24587 .
28118) (\CL-LAMBDA-FNTYP 28120 . 28895) (\SPECALIZEDP 28897 . 29240)) (30112 31327 (\DO.TRANSLATE
30122 . 31325)) (31738 34723 (CATCH 31748 . 32064) (\CATCH.AUX 32066 . 33051) (\CATCH.FINDFRAME 33053
. 33320) (\CATCH.TAG.INTERN 33322 . 33764) (THROW 33766 . 33942) (\THROW.AUX 33944 . 34721)) (37631
40744 (EXPAND-LOOP 37641 . 38281) (LOOP-EXPAND 38283 . 38923) (LOOP-EXPAND-BODY 38925 . 40540) (
LOOP-EXPAND-FOR 40542 . 40742)) (42684 45141 (CASE-1 42694 . 45139)) (46010 48305 (
DESTRUCTURING-BIND-1 46020 . 47142) (DESTRUCTURING-BIND-2 47144 . 47997) (DESTRUCTURING-BIND-3 47999
. 48303)))))
STOP