(FILECREATED "31-Aug-85 15:51:52" {ERIS}<LISPCORE>LIBRARY>CMLEVAL.;15 29899
changes to: (MACROS MULTIPLE-VALUE-BIND EXTRACT-SPECIALS DOLIST DOTIMES UNWIND-PROTECT
BIND-VAR)
(VARS CMLEVALCOMS)
(FNS SYMBOL-MACRO-LET CL:BLOCK MULTIPLE-VALUE-SETQ DO*)
previous date: "30-Aug-85 02:44:38" {ERIS}<LISPCORE>LIBRARY>CMLEVAL.;8)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLEVALCOMS)
(RPAQQ CMLEVALCOMS ((* * Mainly Chapter 5.0 DEFUN and CL:APPLY are here. Most of the Common Lisp
special forms like GO PROG PROGN QUOTE SETQ EVAL etc. would be defined here
except that they are already in Interlisp. *)
(* * CL:BLOCK TAGBODY should be here but it won't work or compile till JONL's CATCH is fixed.
*)
(* * That Common Lisp is lexically scoped is being ignored for the time being. Pretty much
every function in this file will have to be reexamined later to get interpreter hooks,
scoping, etc right. EVAL LET LET* PROG BIND-VAR should be using \VENV for lexical scoping
but aren't right now doing so. *)
(MACROS MAKE-LEXICAL-CLOSURE KEYWORDP-MACRO KEYWORDIFY-MACRO EXTRACT-SPECIALS \INVOKE
\INVOKE1 \INVOKE1* CHECK-KEYWORDS-MACRO)
(CONSTANTS (LAMBDA-LIST-KEYWORDS (QUOTE (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE
&ALLOW-OTHER-KEYS &ENVIRONMENT))))
(INITVARS (*MAXIMUM-INTERPRETER-ERROR-CHECKING* T)
(\LEXICAL-ENVIRONMENT\ NIL)
(\VENV\ NIL)
(\FENV\ NIL)
(\BENV\ NIL)
(\GENV\ NIL)
(*EVALHOOK* NIL)
(*APPLYHOOK* NIL)
(*SKIP-EVALHOOK* NIL)
(*SKIP-APPLYHOOK* NIL)
(/ NIL)
(// NIL)
(/// NIL)
(CL:* NIL)
(** NIL)
(*** NIL)
(+ NIL)
(++ NIL)
(+++ NIL)
(- NIL)
(*PROMPT* NIL)
(\TEMP\ NIL)
(*IN-TOP-LEVEL-CATCHER* NIL)
(*MACROEXPAND-HOOK* (QUOTE FUNCALL)))
(COMS (* DO loops *)
(FNS CL:DO DO* \DO.TRANSLATE)
(MACROS CL:DO DO* DOLIST DOTIMES))
(COMS (* CL:IF *)
(FNS CL:IF)
(MACROS CL:IF))
(COMS (* Multiple values. What a bad idea. *)
(FNS MULTIPLE-VALUE-CALL MULTIPLE-VALUE-SETQ)
(MACROS MULTIPLE-VALUE-BIND)
(P (MOVD (QUOTE PROG1)
(QUOTE MULTIPLE-VALUE-PROG1))
(MOVD (QUOTE IDENTITY)
(QUOTE MULTIPLE-VALUE-LIST))
(MOVD (QUOTE LIST)
(QUOTE VALUES))
(MOVD (QUOTE QUOTE)
(QUOTE VALUES-LIST))))
(MACROS PSETQ UNWIND-PROTECT)
(FNS EXTRACT-DOC-STRING EXTRACT-FN-NAME PARSE-BODY APPLYHOOK \TOP-LEVEL PROCLAIM UNPROCLAIM
EVAL-WHEN EVAL-AS-PROGN PROGV THE MACRO-FUNCTION SPECIAL-FORM-P FEXPRP MACROEXPAND-1
\MACROEXPAND-1 MACROEXPAND \MACROEXPAND \GET-KEY RETURN-FROM CL:APPLY MACRO FLET LABELS
MACROLET COMPILER-LET SYMBOL-MACRO-LET)
(P (MOVD (QUOTE SET)
(QUOTE BIND-VAR))
(MOVD (QUOTE CONSTANTEXPRESSIONP)
(QUOTE CONSTANTP))
(MOVD (QUOTE APPLY*)
(QUOTE FUNCALL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SYMBOL-MACRO-LET COMPILER-LET MACROLET LABELS FLET MACRO
RETURN-FROM THE PROGV EVAL-WHEN MULTIPLE-VALUE-SETQ
MULTIPLE-VALUE-CALL CL:IF DO* CL:DO)
(NLAML)
(LAMA CL:APPLY MACROEXPAND MACROEXPAND-1 APPLYHOOK)))))
(* * Mainly Chapter 5.0 DEFUN and CL:APPLY are here. Most of the Common Lisp special forms like
GO PROG PROGN QUOTE SETQ EVAL etc. would be defined here except that they are already in
Interlisp. *)
(* * CL:BLOCK TAGBODY should be here but it won't work or compile till JONL's CATCH is fixed. *
)
(* * That Common Lisp is lexically scoped is being ignored for the time being. Pretty much
every function in this file will have to be reexamined later to get interpreter hooks, scoping,
etc right. EVAL LET LET* PROG BIND-VAR should be using \VENV for lexical scoping but aren't
right now doing so. *)
(DECLARE: EVAL@COMPILE
(DEFMACRO MAKE-LEXICAL-CLOSURE (FN)
(BQUOTE (LIST (QUOTE \LEXICAL-CLOSURE\)
(\, FN)
\VENV\ \FENV\ \BENV\ \GENV\)))
(DEFMACRO KEYWORDP-MACRO (S)
(BQUOTE (EQ (CHCON1 (\, S))
(CHARCODE :))))
(DEFMACRO KEYWORDIFY-MACRO (SYMBOL)
(BQUOTE (INTERN (SYMBOL-NAME (\, SYMBOL))
*KEYWORD-PACKAGE*)))
(DEFMACRO EXTRACT-SPECIALS NIL (QUOTE (CL:DO ((B BODY (CDR B))
(SPECIALS NIL)
(FORM NIL))
((CL:ATOM B)
(SETQ BODY NIL)
(RETURN SPECIALS))
(SETQ FORM (CAR B))
(COND ((AND (STRINGP FORM)
(CDR B))
(GO SKIP))
((NOT (LISTP FORM))
(SETQ BODY B)
(RETURN SPECIALS))
((EQ (CAR FORM)
(QUOTE CL:DECLARE)))
((AND (SYMBOLP (CAR FORM))
(MACRO-FUNCTION (CAR FORM))
(SETQ FORM (\MACROEXPAND FORM)))
(CL:UNLESS (EQ (CAR FORM)
(QUOTE CL:DECLARE))
(SETQ BODY (CONS FORM (CDR B)))
(RETURN SPECIALS)))
(T (SETQ BODY B)
(RETURN SPECIALS)))
(CL:DO ((X (CDR FORM)
(CDR X)))
((CL:ATOM X))
(AND (LISTP (CAR X))
(EQ (CAAR X)
(QUOTE SPECIAL))
(CL:DO ((V (CDAR X)
(CDR V)))
((CL:ATOM V))
(push SPECIALS (CAR V)))))
SKIP)))
(DEFMACRO \INVOKE (FN ARGS)
(BQUOTE (CL:IF (AND *APPLYHOOK* (NOT (PROG1 *SKIP-APPLYHOOK* (SETQ *SKIP-APPLYHOOK* NIL))))
(CL:DO ((X (\, ARGS)
(CDR X))
(A NIL (CONS (\EVAL (CAR X))
A)))
((CL:ATOM X)
(LET ((HOOKFUN *APPLYHOOK*)
(*APPLYHOOK* NIL))
(FUNCALL HOOKFUN (\, FN)
(NREVERSE A)
(LIST \VENV\ \FENV\ \BENV\ \GENV\)))))
(PROGN (\SP-CALL (\, FN))
(CL:DO ((X (\, ARGS)
(CDR X)))
((CL:ATOM X))
(\SP-PUSH (\EVAL (CAR X))))
(\SP-START-CALL)))))
(DEFMACRO \INVOKE1 (FN ARG)
(BQUOTE (PROGN (\SP-CALL (\, FN))
(\SP-PUSH (\, ARG))
(\SP-START-CALL))))
(DEFMACRO \INVOKE1* (FN ARG)
(BQUOTE (PROGN (\SP-SINGLE-VALUE-CALL (\, FN))
(\SP-PUSH (\, ARG))
(\SP-START-CALL))))
(DEFMACRO CHECK-KEYWORDS-MACRO NIL
(BQUOTE (CL:DO ((N NEXT-ARG (+ N 2))
KEY)
((>= N NARGS))
(SETQ KEY (\PRIMITIVE ARG-IN-FRAME N FRAME))
(COND ((MEMQ KEY SEEN-KEYWORDS))
((EQ KEY :ALLOW-OTHER-KEYS))
((NOT (KEYWORDP-MACRO KEY))
(CERROR "Ignore it." "~S not a legal keyword arg." KEY))
(* " Before signalling error, look for :allow-other-keys." *)
((CL:DO ((I N (+ I 2)))
((>= I NARGS)
NIL)
(CL:IF (AND (EQ (\PRIMITIVE ARG-IN-FRAME I FRAME)
:ALLOW-OTHER-KEYS)
(NOT (NULL (\PRIMITIVE ARG-IN-FRAME (1+ I)
FRAME))))
(RETURN T)))
(* " We found it. Forget any further checking." *)
(RETURN NIL))
(T (CERROR "Ignore it." "~S does not recognize ~S as keyword."
(EXTRACT-FN-NAME EXP)
KEY))))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ LAMBDA-LIST-KEYWORDS (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS &ENVIRONMENT))
(CONSTANTS (LAMBDA-LIST-KEYWORDS (QUOTE (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS
&ENVIRONMENT))))
)
(RPAQ? *MAXIMUM-INTERPRETER-ERROR-CHECKING* T)
(RPAQ? \LEXICAL-ENVIRONMENT\ NIL)
(RPAQ? \VENV\ NIL)
(RPAQ? \FENV\ NIL)
(RPAQ? \BENV\ NIL)
(RPAQ? \GENV\ NIL)
(RPAQ? *EVALHOOK* NIL)
(RPAQ? *APPLYHOOK* NIL)
(RPAQ? *SKIP-EVALHOOK* NIL)
(RPAQ? *SKIP-APPLYHOOK* NIL)
(RPAQ? / NIL)
(RPAQ? // NIL)
(RPAQ? /// NIL)
(RPAQ? CL:* NIL)
(RPAQ? ** NIL)
(RPAQ? *** NIL)
(RPAQ? + NIL)
(RPAQ? ++ NIL)
(RPAQ? +++ NIL)
(RPAQ? - NIL)
(RPAQ? *PROMPT* NIL)
(RPAQ? \TEMP\ NIL)
(RPAQ? *IN-TOP-LEVEL-CATCHER* NIL)
(RPAQ? *MACROEXPAND-HOOK* (QUOTE FUNCALL))
(* DO loops *)
(DEFINEQ
(CL:DO
(NLAMBDA $FEXPR$ (* kbr: "29-Aug-85 22:37")
((LAMBDA (VARS END-TEST BODY)
(EVAL (\DO.TRANSLATE VARS END-TEST BODY NIL)))
(pop $FEXPR$)
(pop $FEXPR$)
$FEXPR$)))
(DO*
(NLAMBDA $FEXPR$ (* kbr: "31-Aug-85 13:05")
((LAMBDA (VARS END-TEST BODY)
(EVAL (\DO.TRANSLATE VARS END-TEST BODY T)))
(pop $FEXPR$)
(pop $FEXPR$)
$FEXPR$)))
(\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)))))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO CL:DO (VARS END-TEST &BODY BODY)
(\DO.TRANSLATE VARS END-TEST BODY NIL))
(DEFMACRO DO* (BINDS END-TEST &REST BODY)
(\DO.TRANSLATE BINDS END-TEST BODY T))
(DEFMACRO DOLIST (BINDING &BODY BODY)
(LET ((VAR (CAR BINDING))
(LIST (CADR BINDING))
(RESULT (CADDR BINDING)))
(BQUOTE (FOR (\, VAR)
IN
(\, LIST)
DO
(\,@ BODY)
FINALLY
(RETURN (\, RESULT))))))
(DEFMACRO DOTIMES (BINDING &BODY BODY)
(LET ((VAR (CAR BINDING))
(TIMES (CADR BINDING))
(RESULT (CADDR BINDING)))
(BQUOTE (FOR (\, VAR)
FROM 1 TO (\, TIMES)
DO
(\,@ BODY)
FINALLY
(RETURN (\, RESULT))))))
)
(* CL:IF *)
(DEFINEQ
(CL:IF
(NLAMBDA $FEXPR$ (* kbr: "29-Aug-85 22:48")
((LAMBDA (TEST THEN ELSE)
(COND
((EVAL TEST)
(EVAL THEN))
(T (EVAL ELSE))))
(pop $FEXPR$)
(pop $FEXPR$)
(pop $FEXPR$))))
)
(DECLARE: EVAL@COMPILE
(PROGN (PUTPROPS CL:IF DMACRO (X (BQUOTE (COND ((\, (CAR X))
(\, (CADR X)))
(T (\,@ (OR (CDDR X)
(LIST NIL))))))))
(PUTPROPS CL:IF MACRO (X (BQUOTE (COND ((\, (CAR X))
(\, (CADR X)))
(T (\,@ (OR (CDDR X)
(LIST NIL)))))))))
)
(* Multiple values. What a bad idea. *)
(DEFINEQ
(MULTIPLE-VALUE-CALL
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 00:46")
((LAMBDA (FUNCTION FORMS) (* Calls Function with the values of all of the Forms
as arguments. *)
(CL:DO ((FUNCTION (\EVAL FUNCTION))
(FORMS FORMS (CDR FORMS))
(ARGLIST NIL))
((CL:ATOM FORMS)
(CL:APPLY FUNCTION ARGLIST))
(SETQ ARGLIST (NCONC ARGLIST (MULTIPLE-VALUE-LIST (\EVAL (CAR FORMS)))))))
(pop $FEXPR$)
$FEXPR$)))
(MULTIPLE-VALUE-SETQ
(NLAMBDA $FEXPR$ (* kbr: "31-Aug-85 13:32")
((LAMBDA (VARIABLES FORM) (* Sets each variable in the list of Variables to the
corresponding value of the Form.
*)
(* NOTE: Should be using \VENV for lexical scoping.
*)
(PROG (VALUES)
(SETQ VALUES (\EVAL FORM))
(while (AND VARIABLES VALUES) do (SET (pop VARIABLES)
(pop VALUES)))
(while VARIABLES do (SET (pop VARIABLES)
(QUOTE NOBIND)))))
(pop $FEXPR$)
(pop $FEXPR$))))
)
(DECLARE: EVAL@COMPILE
(DEFMACRO MULTIPLE-VALUE-BIND (VAR-LIST VALUES-FORM &BODY BODY)
(BQUOTE (LET ((VALUES (\, VALUES-FORM)))
(LET (\, (for VAR in VAR-LIST collect (LIST VAR (QUOTE (pop VALUES)))))
(\,@ BODY)))))
)
(MOVD (QUOTE PROG1)
(QUOTE MULTIPLE-VALUE-PROG1))
(MOVD (QUOTE IDENTITY)
(QUOTE MULTIPLE-VALUE-LIST))
(MOVD (QUOTE LIST)
(QUOTE VALUES))
(MOVD (QUOTE QUOTE)
(QUOTE VALUES-LIST))
(DECLARE: EVAL@COMPILE
(DEFMACRO PSETQ (VAR VAL &REST TAIL)
(BQUOTE (PROGN (SETQ (\, VAR)
(\, (COND (TAIL (BQUOTE (PROG1 (\, VAL)
(PSETQ (\,. TAIL)))))
(T VAL))))
NIL)))
(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))))
)
(DEFINEQ
(EXTRACT-DOC-STRING
(CL:LAMBDA (BODY)
(CL:DO ((B BODY (CDR B)))
((NULL (CDR B))
NIL)
(COND
((STRINGP (CAR B))
(RETURN (CAR B)))
((AND (LISTP (CAR B))
(EQ (CAAR B)
(QUOTE CL:DECLARE))))
(T (RETURN NIL))))))
(EXTRACT-FN-NAME
(CL:LAMBDA (BODY)
(COND
((EQ (CAR BODY)
(QUOTE \LEXICAL-CLOSURE\))
(SETQ BODY (\LEXICAL-CLOSURE\-FN BODY)))
(T NIL))
(CL:DO ((B BODY (CDR B)))
((CL:ATOM B)
(QUOTE ANONYMOUS-LAMBDA))
(COND
((AND (LISTP (CAR B))
(EQ (CAAR B)
(QUOTE CL:BLOCK)))
(RETURN (CADAR B)))
(T NIL)))))
(PARSE-BODY
(CL:LAMBDA (BODY)
(CL:DO ((B BODY (CDR B))
(DECLS NIL)
(DOC NIL)
(TEMP NIL))
((NULL B)
(LIST (NREVERSE DECLS)
DOC NIL))
(COND
((AND (STRINGP (CAR B))
(CDR B)
(NULL DOC))
(SETQ DOC (CAR B)))
((NOT (LISTP (CAR B)))
(RETURN (LIST (NREVERSE DECLS)
DOC B)))
((EQ (CAAR B)
(QUOTE CL:DECLARE))
(PUSH (CAR B)
DECLS))
((AND (SYMBOLP (CAAR B))
(MACRO-FUNCTION (CAAR B))
(LISTP (SETQ TEMP (\MACROEXPAND (CAR B))))
(EQ (CAR TEMP)
(QUOTE CL:DECLARE)))
(PUSH (CAR B)
DECLS))
(T (RETURN (LIST (NREVERSE DECLS)
DOC B)))))))
(APPLYHOOK
(CL:LAMBDA (FUNCTION ARGS EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV)
"Applies Function to Args, with *Evalhook* bound to Evalhookfn and with
*Applyhook* bound to Applyhookfn. Ignores the hook function once, for the
top-level application of Function to Args."
(LET ((*EVALHOOK* EVALHOOKFN)
(*SKIP-EVALHOOK* NIL)
(*APPLYHOOK* APPLYHOOKFN)
(*SKIP-APPLYHOOK* T)
(\VENV\ (CL:FIRST ENV))
(\FENV\ (SECOND ENV))
(\BENV\ (THIRD ENV))
(\GENV\ (FOURTH ENV)))
(CL:APPLY FUNCTION ARGS))))
(\TOP-LEVEL
(CL:LAMBDA NIL "Top-level READ-EVAL-PRINT loop. Do not call this."
(LET ((THIS-EVAL NIL)
(CL:* NIL)
(** NIL)
(*** NIL)
(- NIL)
(+ NIL)
(++ NIL)
(+++ NIL)
(/// NIL)
(// NIL)
(/ NIL)
(\TEMP\ NIL))
(LOOP (CATCH (QUOTE TOP-LEVEL-CATCHER) (* "" *)
(*
" Prevent the user from irrevocably wedging the hooks."
*)
(SETQ *EVALHOOK* NIL)
(SETQ *APPLYHOOK* NIL)
(LET ((*IN-TOP-LEVEL-CATCHER* T))
(LOOP (TERPRI)
(PRINC *PROMPT*)
(SETQ +++ ++ ++ + + - - (READ))
(SETQ THIS-EVAL (MULTIPLE-VALUE-LIST (EVAL -)))
(DOLIST (X THIS-EVAL)
(PRINT X))
(SETQ /// // // / / THIS-EVAL)
(SETQ \TEMP\ (CAR THIS-EVAL))
(* "" *)
(* " Make sure nobody passes back an unbound marker."
*)
(COND
((NOT (BOUNDP (QUOTE \TEMP\)))
(SETQ \TEMP\ NIL)
(CERROR "Go on, but set * to NIL."
"Eval returned an unbound marker.")))
(SETQ *** ** ** CL:* CL:* \TEMP\))))))))
(PROCLAIM
(CL:LAMBDA (PROCLAMATION)
"PROCLAIM is a top-level form used to pass assorted information to the
compiler. This interpreter ignores proclamations except for those
declaring variables to be SPECIAL."
(COND
((AND (LISTP PROCLAMATION)
(EQ (CAR PROCLAMATION)
(QUOTE SPECIAL)))
(CL:DO ((VARS (CDR PROCLAMATION)
(CDR VARS)))
((CL:ATOM VARS))
(AND (SYMBOLP (CAR VARS))
(PUTPROP (CAR VARS)
(QUOTE GLOBALLY-SPECIAL)
T))))
(T NIL))))
(UNPROCLAIM
(CL:LAMBDA (PROCLAMATION)
"Undoes the effect of certain proclamations."
(COND
((AND (LISTP PROCLAMATION)
(EQ (CAR PROCLAMATION)
(QUOTE SPECIAL)))
(CL:DO ((VARS (CDR PROCLAMATION)
(CDR VARS)))
((CL:ATOM VARS))
(AND (SYMBOLP (CAR VARS))
(REMPROP (CAR VARS)
(QUOTE GLOBALLY-SPECIAL)))))
(T NIL))))
(EVAL-WHEN
(NLAMBDA $FEXPR$ (* kbr: "29-Aug-85 22:43")
((LAMBDA (CONTROL-LIST FORMS)
(COND
((NOT (MEMQ (QUOTE EVAL)
CONTROL-LIST))
NIL)
(T (EVAL-AS-PROGN FORMS))))
(pop $FEXPR$)
$FEXPR$)))
(EVAL-AS-PROGN
(CL:LAMBDA (X) (* kbr: "30-Aug-85 02:43")
(COND
((CL:ATOM X)
NIL)
(T (CL:DO ((FORMS X (CDR FORMS)))
((CL:ATOM (CDR FORMS))
(\EVAL (CAR FORMS)))
(\EVAL (CAR FORMS)))))))
(PROGV
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 01:02")
((LAMBDA (VARLIST ARGLIST FORMS)
(* First arg evaluates to a list of variables. Second arg evaluates to a list of initial values.
Everything after that is body. Evaluate the body with the variables bound (as specials) to the corresponding values.
*)
(LET ((\VENV\ \VENV\))
(CL:DO ((VARLIST (\EVAL VARLIST)
(CDR VARLIST))
(ARGLIST (\EVAL ARGLIST)
(CDR ARGLIST)))
((NULL VARLIST))
(PUSH \VENV\ (CONS (CAR VARLIST)
(QUOTE \INTERNAL-SPECIAL-MARKER\)))
(COND
(ARGLIST (\SP-BIND (CAR ARGLIST)
(CAR VARLIST)))
(T (PROGN (\SP-BIND NIL (CAR VARLIST))
(MAKUNBOUND (CAR VARLIST))))))
(EVAL-AS-PROGN (CDDR X))))
(pop $FEXPR$)
(pop $FEXPR$)
$FEXPR$)))
(THE
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 01:11")
((LAMBDA (VALUE-TYPE FORM) (* Declares that Object must be of specified Type,
complains if this is not the case.
*)
(PROG (OBJ)
(SETQ OBJ (\EVAL FORM))
RETRY
(COND
((TYPEP OBJ VALUE-TYPE)
(RETURN OBJ))
(T (CERROR "Prompt for a new object." "Object ~S is not of type ~S." OBJ
(CAR X))
(TERPRI)
(PRINC "New object of proper type: ")
(SETQ OBJ (READ))
(GO RETRY)))))
(pop $FEXPR$)
(pop $FEXPR$))))
(MACRO-FUNCTION
(CL:LAMBDA (SYMBOL)
"If the symbol globally names a macro, returns the expansion function,
else returns NIL."
(LET ((TEMP))
(AND (FBOUNDP SYMBOL)
(CONSP (SETQ TEMP (SYMBOL-FUNCTION SYMBOL)))
(EQ (CAR TEMP)
(QUOTE MACRO))
(CDR TEMP)))))
(SPECIAL-FORM-P
(CL:LAMBDA (SYMBOL)
"If the symbol globally names a special form, returns the definition in a
mysterious internal format (a FEXPR), else returns NIL."
(LET ((TEMP))
(COND
((NOT (FBOUNDP SYMBOL))
NIL)
((AND (COMPILED-FUNCTION-P (SETQ TEMP (SYMBOL-FUNCTION SYMBOL)))
(FEXPRP TEMP))
TEMP)
((AND (LISTP TEMP)
(EQ (CAR TEMP)
(QUOTE FEXPR)))
(CDR TEMP))
(T NIL)))))
(FEXPRP
(LAMBDA (FN) (* kbr: "30-Aug-85 01:36")
(ODDP (ARGTYPE FN))))
(MACROEXPAND-1
(CL:LAMBDA (FORM &OPTIONAL ENV)
"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\ (CL:FIRST ENV))
(\FENV\ (SECOND ENV))
(\BENV\ (THIRD ENV))
(\GENV\ (FOURTH ENV)))
(\MACROEXPAND-1 FORM))))
(\MACROEXPAND-1
(CL:LAMBDA (FORM)
"Does Macroexpand-1 in the current lexical environment."
(LET (TEMP)
(COND
((NOT (LISTP FORM))
(VALUES FORM NIL))
((NOT (SYMBOLP (CAR FORM)))
(VALUES FORM NIL))
((SETQ TEMP (MACRO-FUNCTION (CAR FORM)))
(VALUES (FUNCALL *MACROEXPAND-HOOK* TEMP FORM)
T))
(T (VALUES FORM NIL))))))
(MACROEXPAND
(CL:LAMBDA (FORM &OPTIONAL ENV)
"If form is a macro, expands it repeatedly until it is not a macro
any more. Returns two values: the expanded form and a T-or-NIL
flag that indicates whether the original form was a macro."
(LET ((\VENV\ (CL:FIRST ENV))
(\FENV\ (SECOND ENV))
(\BENV\ (THIRD ENV))
(\GENV\ (FOURTH ENV)))
(\MACROEXPAND FORM))))
(\MACROEXPAND
(CL:LAMBDA (FORM)
"Does a macroexpand in the current lexical environment."
(PROG (FLAG)
(MULTIPLE-VALUE-SETQ (FORM FLAG)
(\MACROEXPAND-1 FORM))
(OR FLAG (RETURN (VALUES FORM NIL)))
LOOP(MULTIPLE-VALUE-SETQ (FORM FLAG)
(\MACROEXPAND-1 FORM))
(COND
(FLAG (GO LOOP))
(T (RETURN (VALUES FORM T)))))))
(\GET-KEY
(CL:LAMBDA (LIST KEY)
"Called by compiled functions with keyword args. CDDR down List looking
for KEY. If it is found, return the list fragment following the keyword.
Else, return NIL."
(CL:DO ((L LIST (CDDR L)))
((NULL L)
NIL)
(COND
((NULL (CDR L))
(CERROR "Stick a NIL on the end and go on."
"Unpaired item in keyword portion of call.")
(RPLACD L (LIST NIL))
(RETURN NIL))
((EQ (CAR L)
KEY)
(RETURN (CDR L)))))))
(RETURN-FROM
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 01:07")
((LAMBDA (NAME RESULT)
(* The first argument names a lexically surrounding block, perhaps implicitly created by a defun.
The second argument is a form to be evaluated and returned as the value of this block. *)
(LET ((SLOT (ASSQ NAME \BENV\)))
(COND
((NULL SLOT)
(CL:ERROR "~S unseen block name in RETURN-FROM." NAME))
((EQ (CDR SLOT)
(QUOTE INVALID))
(CL:ERROR "No longer in block ~S, cannot return from it." NAME))
(T (THROW SLOT (\EVAL RESULT))))))
(pop $FEXPR$)
(pop $FEXPR$))))
(CL:APPLY
(LAMBDA N
(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))))
(MACRO
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 01:34")
((LAMBDA (NAME BODY)
(* Internal form used to define new macros. Syntax like DEFUN, but takes only one arg which is bound to the entire
calling form. For better style use DEFMACRO instead of MACRO. *)
(PUTDEF NAME (QUOTE MACRO)
(BQUOTE (MACRO CL:LAMBDA (\,@ BODY)))))
(pop $FEXPR$)
$FEXPR$)))
(FLET
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 00:42")
((LAMBDA (DEFS FORMS)
(* First arg is list of function definitions in form (name lambda-list . body). This list is followed any number of
additional forms to be evaluated as a Progn with the local function definitions in effect. The scope of the locally
defined functions does not include the function definitions themselves, so they can reference externally defined
functions of the same name. *)
(LET ((\FENV\ \FENV\))
(CL:DO ((DEFS DEFS (CDR DEFS))
(NEW-ENV \FENV\))
((CL:ATOM DEFS)
(SETQ \FENV\ NEW-ENV)
(EVAL-AS-PROGN FORMS))
(PUSH NEW-ENV (LIST* (CAAR DEFS)
(QUOTE FUNCTION)
(MAKE-LEXICAL-CLOSURE (CONS (QUOTE CL:LAMBDA)
(CDAR DEFS))))))))
(pop $FEXPR$)
$FEXPR$)))
(LABELS
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 00:41")
((LAMBDA (DEFS FORMS)
(* First arg is list of function definitions in form (name lambda-list . body). This list is followed any number of
additional forms to be evaluated as a Progn with the local function definitions in effect. The scope of the locally
defined functions includes the function definitions themselves, so they can reference one another.
*)
(LET ((\FENV\ \FENV\))
(DOLIST (DEF (CAR X))
(PUSH \FENV\ (CONS (CAR DEF)
NIL)))
(CL:DO ((DEFS (CAR X)
(CDR DEFS)))
((CL:ATOM DEFS)
(EVAL-AS-PROGN (CDR X)))
(SETF (CDR (CL:ASSOC (CAAR DEFS)
\FENV\))
(CONS (QUOTE FUNCTION)
(MAKE-LEXICAL-CLOSURE (CONS (QUOTE CL:LAMBDA)
(CDAR DEFS))))))))
(pop $FEXPR$)
$FEXPR$)))
(MACROLET
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 00:42")
((LAMBDA (DEFS FORMS)
(* First arg is list of function definitions in form (name lambda-list . body). This list is followed any number of
additional forms to be evaluated as a Progn with the local function definitions in effect. The scope of the locally
defined functions does not include the function definitions themselves, so they can reference externally defined
functions of the same name. *)
(LET ((\FENV\ \FENV\))
(CL:DO ((DEFS DEFS (CDR DEFS))
(NEW-ENV \FENV\))
((CL:ATOM DEFS)
(SETQ \FENV\ NEW-ENV)
(EVAL-AS-PROGN FORMS))
(PUSH NEW-ENV (LIST* (CAAR DEFS)
(QUOTE MACRO)
(CONS (QUOTE CL:LAMBDA)
(CDDR (\MACROEXPAND (CONS (QUOTE DEFMACRO)
(CAR DEFS))))))))))
(pop $FEXPR$)
$FEXPR$)))
(COMPILER-LET
(NLAMBDA $FEXPR$ (* kbr: "30-Aug-85 00:57")
((LAMBDA (VARLIST BODY)
(* In the interpreter, works just like a LET with all variables implicitly declared special.
In the compiler, processes the forms in the body with the variables rebound in the compiler environment.
No declarations are allowed. *)
(\EVAL (BQUOTE (LET (\, VARLIST)
(CL:DECLARE (SPECIAL (\,@ (CL:MAPCAR (FUNCTION (CL:LAMBDA (X)
(COND
((LISTP X)
(CAR X))
(T X))))
VARLIST))))
(\,@ BODY)))))
(pop $FEXPR$)
$FEXPR$)))
(SYMBOL-MACRO-LET
(NLAMBDA $FEXPR$ (* kbr: "31-Aug-85 14:20")
((LAMBDA (BINDINGS FORMS)
(* Better called a symbol replacement. The (QUOTE binding') is a form to be textually substituted for a free
reference to that symbol. This may be used in conjunction with macros, for more powerful uses.
Use wisely or not at all. *)
(CL:DO ((BINDINGS BINDINGS (CDR BINDINGS))
(VENV-BINDINGS \VENV\))
((CL:ATOM BINDINGS)
(LET ((\VENV\ VENV-BINDINGS))
(EVAL-AS-PROGN FORMS)))
(LET ((BINDING (CAR BINDINGS)))
(push VENV-BINDINGS (LIST* (CAR BINDING)
(QUOTE \SYM-MAC-BINDING\)
(CADR BINDING))))))
(pop $FEXPR$)
$FEXPR$)))
)
(MOVD (QUOTE SET)
(QUOTE BIND-VAR))
(MOVD (QUOTE CONSTANTEXPRESSIONP)
(QUOTE CONSTANTP))
(MOVD (QUOTE APPLY*)
(QUOTE FUNCALL))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SYMBOL-MACRO-LET COMPILER-LET MACROLET LABELS FLET MACRO RETURN-FROM THE PROGV
EVAL-WHEN MULTIPLE-VALUE-SETQ MULTIPLE-VALUE-CALL CL:IF DO* CL:DO)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CL:APPLY MACROEXPAND MACROEXPAND-1 APPLYHOOK)
)
(PUTPROPS CMLEVAL COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7814 9617 (CL:DO 7824 . 8085) (DO* 8087 . 8344) (\DO.TRANSLATE 8346 . 9615)) (10339
10636 (CL:IF 10349 . 10634)) (11001 12367 (MULTIPLE-VALUE-CALL 11011 . 11594) (MULTIPLE-VALUE-SETQ
11596 . 12365)) (13434 29350 (EXTRACT-DOC-STRING 13444 . 13776) (EXTRACT-FN-NAME 13778 . 14218) (
PARSE-BODY 14220 . 15076) (APPLYHOOK 15078 . 15621) (\TOP-LEVEL 15623 . 16996) (PROCLAIM 16998 . 17585
) (UNPROCLAIM 17587 . 18033) (EVAL-WHEN 18035 . 18335) (EVAL-AS-PROGN 18337 . 18638) (PROGV 18640 .
19623) (THE 19625 . 20303) (MACRO-FUNCTION 20305 . 20646) (SPECIAL-FORM-P 20648 . 21148) (FEXPRP 21150
. 21287) (MACROEXPAND-1 21289 . 21650) (\MACROEXPAND-1 21652 . 22088) (MACROEXPAND 22090 . 22489) (
\MACROEXPAND 22491 . 22929) (\GET-KEY 22931 . 23503) (RETURN-FROM 23505 . 24219) (CL:APPLY 24221 .
24418) (MACRO 24420 . 24879) (FLET 24881 . 25831) (LABELS 25833 . 26816) (MACROLET 26818 . 27816) (
COMPILER-LET 27818 . 28531) (SYMBOL-MACRO-LET 28533 . 29348)))))
STOP