(FILECREATED " 1-Aug-86 01:05:10" {ERIS}<LISPCORE>LIBRARY>CMLEVAL.;55 217534Q
changes to: (FUNCTIONS DEFINE-SPECIAL-FORM)
(VARS CMLEVALCOMS)
previous date: "31-Jul-86 17:33:05" {ERIS}<LISPCORE>LIBRARY>CMLEVAL.;53)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLEVALCOMS)
(RPAQQ CMLEVALCOMS [(COMS (* proclaim and friends - needs to come first because DEFVARs put it out)
(FUNCTIONS PROCLAIM)
(* used by the codewalker, too)
(MACROS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-GLOBAL-P))
(DEFINE-TYPES SPECIAL-FORMS)
(FUNCTIONS DEFINE-SPECIAL-FORM)
(COMS (SPECIAL-FORMS INTERLISP)
(PROP DMACRO INTERLISP COMMON-LISP)
(FNS COMMON-LISP))
(COMS (ADDVARS (LAMBDASPLST CL:LAMBDA))
(FNS \TRANSLATE-CL:LAMBDA)
(VARIABLES *CHECK-ARGUMENT-COUNTS*)
(PROP DMACRO COMMON-LISP))
(FUNCTIONS SPECIAL-FORM-P)
(VARIABLES LAMBDA-LIST-KEYWORDS CALL-ARGUMENTS-LIMIT LAMBDA-PARAMETERS-LIMIT)
(STRUCTURES CLOSURE)
(STRUCTURES ENVIRONMENT)
(COMS (FNS CL:EVAL EVAL-INVOKE-LAMBDA \INTERPRET-ARGUMENTS \INTERPRETER-LAMBDA
CHECK-BINDABLE CHECK-KEYWORDS)
(FUNCTIONS ARG-REF)
(PROP DMACRO .COMPILER-SPREAD-ARGUMENTS.))
(FNS DECLARED-SPECIAL EVALHOOK)
(COMS (* FUNCALL and APPLY, not quite same as Interlisp)
(FNS FUNCALL CL:APPLY)
(PROP DMACRO CL:APPLY FUNCALL))
(COMS (* COMPILER-LET needs to work differently compiled and interpreted)
(FNS COMPILER-LET COMP.COMPILER-LET)
(PROP DMACRO COMPILER-LET)
(SPECIAL-FORMS COMPILER-LET))
(SPECIAL-FORMS QUOTE)
(COMS (SPECIAL-FORMS THE)
(PROP DMACRO THE))
(COMS (PROP DMACRO EVAL-WHEN)
(FNS EVAL-WHEN)
(SPECIAL-FORMS EVAL-WHEN))
(COMS (FUNCTIONS CL:DECLARE)
(SPECIAL-FORMS DECLARE)
(FUNCTIONS LOCALLY))
(COMS (* Interlisp version on LLINTERP)
(SPECIAL-FORMS PROGN)
(FNS EVAL-PROGN))
(COMS (* confused because currently Interlisp special form, fixing MACRO-FUNCTION
is complex - Interlisp function is on LLINTERP)
(SPECIAL-FORMS PROG1)
(FUNCTIONS PROG1))
(COMS (SPECIAL-FORMS LET* LET)
(PROP MACRO LET LET*)
(FNS EVAL-LET*-RECURSION \LETtran))
(COMS (SPECIAL-FORMS COND)
(FUNCTIONS COND))
(COMS (* consider making CL:IF extended to have Interlisp's features)
(FNS CL:IF)
(SPECIAL-FORMS CL:IF)
(PROP DMACRO CL:IF))
(COMS (* Interlisp NLAMBDA definitions on LLINTERP - both special form and macro)
(FUNCTIONS AND OR)
(SPECIAL-FORMS AND OR))
(COMS (* BLOCK and RETURN go together)
(FNS CL:BLOCK)
(PROP DMACRO CL:BLOCK)
(SPECIAL-FORMS CL:BLOCK)
(FUNCTIONS RETURN)
(FNS RETURN-FROM)
(SPECIAL-FORMS RETURN-FROM))
(COMS (* eventually shouldn't be shadowed but currently *really* different)
(FNS CL:FUNCTION FUNCTION)
(PROP DMACRO CL:FUNCTION)
(SPECIAL-FORMS CL:FUNCTION FUNCTION))
(SPECIAL-FORMS MULTIPLE-VALUE-CALL)
(FNS COMP.CL-EVAL)
(VARIABLES *EVALHOOK* *APPLYHOOK*)
(INITVARS (*SKIP-EVALHOOK* NIL)
(*SKIP-APPLYHOOK* NIL))
(FNS CONSTANTP)
(COMS (* Interlisp SETQ for Common Lisp and vice versa)
(SPECIAL-FORMS CL:SETQ SETQ)
(PROP DMACRO CL:SETQ)
(PROP MACRO SETQ)
(FNS SET-SYMBOL)
(FUNCTIONS PSETQ))
(COMS (* "CommonLisp style CATCH and THROW")
(SPECIAL-FORMS CATCH THROW)
(FNS CATCH \CATCH-FUNCALL \CATCH-EVAL \CATCH-CL-EVAL THROW EVAL-THROW
\DO-THROW)
(PROP DMACRO CATCH THROW))
(COMS (FUNCTIONS PROG PROG*)
(SPECIAL-FORMS GO TAGBODY)
(FNS TAGBODY))
(COMS (SPECIAL-FORMS UNWIND-PROTECT)
(MACROS UNWIND-PROTECT))
(FILES CMLPROGV)
(COMS (* hack to get NLSETQs to work on common lisp interpreter)
(SPECIAL-FORMS .ERRSETQ.)
(FNS EVAL-ERRORSET))
(LOCALVARS . T)
(PROP FILETYPE CMLEVAL)
(P (for X in SYSSPECVARS do (SETF (VARIABLE-GLOBALLY-SPECIAL-P X)
T)))
(COMS (* "for macro caching")
(FNS CACHEMACRO)
(VARS *MACROEXPAND-HOOK* (*IN-COMPILER-LET* NIL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TAGBODY CATCH CL:BLOCK EVAL-WHEN COMPILER-LET COMMON-LISP)
(NLAML THROW FUNCTION CL:FUNCTION RETURN-FROM CL:IF)
(LAMA CL:APPLY FUNCALL EVALHOOK])
(* proclaim and friends - needs to come first because DEFVARs put it out)
(DEFUN PROCLAIM (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
((LISTP PROCLAMATION)
(SELECTQ (CAR PROCLAMATION)
(SPECIAL (for X in (CDR PROCLAMATION) do (SETF (VARIABLE-GLOBALLY-SPECIAL-P X)
T)))
(GLOBAL (for X in (CDR PROCLAMATION) do (SETF (VARIABLE-GLOBAL-P X)
T)))
NIL))))
(* used by the codewalker, too)
(DECLARE: EVAL@COMPILE
[PUTPROPS VARIABLE-GLOBALLY-SPECIAL-P MACRO ((VARIABLE)
(GET VARIABLE (QUOTE GLOBALLY-SPECIAL]
[PUTPROPS VARIABLE-GLOBAL-P MACRO ((VARIABLE)
(GET VARIABLE (QUOTE GLOBALVAR]
)
(DEF-DEFINE-TYPE SPECIAL-FORMS "Common Lisp special forms" )
(DEFDEFINER DEFINE-SPECIAL-FORM
SPECIAL-FORMS (NAME ARGS &REST BODY)
(COND
((NULL BODY)
(CL:ASSERT (SYMBOLP BODY))
(BQUOTE (PUTPROPS (\, NAME)
SPECIAL-FORM
(\, ARGS))))
(T (LET ((SF (PACK* "\interpret-" NAME)))
(MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOC)
(PARSE-DEFMACRO ARGS (QUOTE $$TAIL)
BODY NAME NIL :PATH (QUOTE $$TAIL)
:ENVIRONMENT
(QUOTE $$ENV))
(SETQ ARGS SF)
(BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (\, SF)))
(CL:FUNCTION (CL:LAMBDA ($$TAIL $$ENV)
(CL:BLOCK (\, NAME)
(\,@ DECLS)
(\, PARSED-BODY)))))
(PUTPROPS (\, NAME)
SPECIAL-FORM
(\, SF)))))))))
(DEFINE-SPECIAL-FORM INTERLISP PROGN)
(PUTPROPS INTERLISP DMACRO ((X . Y)
(PROGN X . Y)))
(PUTPROPS COMMON-LISP DMACRO ((X)
X))
(DEFINEQ
(COMMON-LISP
[NLAMBDA COMMON-LISP-FORMS (* lmm " 6-Jun-86 01:07")
(EVAL-PROGN COMMON-LISP-FORMS NIL])
)
(ADDTOVAR LAMBDASPLST CL:LAMBDA)
(DEFINEQ
(\TRANSLATE-CL:LAMBDA
[LAMBDA (EXPR) (* lmm "16-Jun-86 22:41")
(LET
(VRBLS KEYVARS OPTVARS AUXLIST RESTFORM VARTYP BODY KEYWORDS (CNT 1)
(MIN 0)
(MAX 0)
DECLS
(SIMPLEP T))
[for BINDING VAR in (CAR (CDR EXPR))
do
(SELECTQ BINDING
((&REST &BODY)
(SETQ VARTYP (QUOTE &REST)))
(&OPTIONAL (SETQ VARTYP BINDING))
(&AUX (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 "required" (push VRBLS BINDING)
(add CNT 1)
(add MIN 1)
(add MAX 1)
(AND *CHECK-ARGUMENT-COUNTS* (SETQ SIMPLEP NIL)))
(&REST [SETQ RESTFORM (BQUOTE (((\, BINDING)
(for I from (\, CNT) to -args-
collect (ARG -args- I]
(SETQ MAX NIL)
(SETQ SIMPLEP NIL))
(&AUX (push AUXLIST BINDING))
(&KEY [LET*
[SVAR [INIT (COND
((LISTP BINDING)
(PROG1 (CADR BINDING)
(SETQ SVAR (CADDR BINDING))
(SETQ BINDING (CAR BINDING]
(KEY (COND
[(LISTP BINDING)
(PROG1 (CAR BINDING)
(SETQ BINDING (CADR BINDING]
(T (MAKE-KEYWORD BINDING]
[COND
(SVAR (push KEYVARS (LIST SVAR T]
(push
KEYVARS
(LIST BINDING
(BQUOTE
(for \INDEX from (\, CNT) to -args- by 2
when (EQ (ARG -args- \INDEX)
(\, KEY)) do (RETURN (ARG -args- (ADD1 \INDEX)))
finally (RETURN (\, (COND
[SVAR (BQUOTE (PROGN (SETQ (\, SVAR)
NIL)
(\, INIT]
(T INIT]
(SETQ MAX NIL)
(SETQ SIMPLEP NIL))
(&OPTIONAL (OR (LISTP BINDING)
(SETQ BINDING (LIST BINDING)))
[LET ((SVAR (CADDR BINDING)))
(CL:WHEN SVAR (push OPTVARS SVAR)
(SETQ SIMPLEP NIL))
(CL:WHEN (CADR BINDING)
(SETQ SIMPLEP NIL))
(push OPTVARS
(BQUOTE ((\, (CAR BINDING))
(COND
((IGREATERP (\, CNT)
-args-)
(\, (CADR BINDING)))
(T [\,@ (COND
(SVAR (BQUOTE ((SETQ (\, SVAR)
T]
(ARG -args- (\, CNT]
(AND MAX (add MAX 1))
(add CNT 1))
(SHOULDNT]
(MULTIPLE-VALUE-SETQ (BODY DECLS)
(PARSE-BODY (CDR (CDR EXPR))
NIL))
(CL:IF SIMPLEP [BQUOTE (LAMBDA [(\,@ (REVERSE VRBLS))
(\,@ (MAPCAR (REVERSE OPTVARS)
(FUNCTION CAR]
(DECLARE (LOCALVARS . T))
(\,@ DECLS)
(LET* ((\,@ (REVERSE AUXLIST)))
(\,@ DECLS)
(\,@ BODY]
(BQUOTE (LAMBDA -args-
(DECLARE (LOCALVARS . T))
[\,@ (COND
((AND *CHECK-ARGUMENT-COUNTS* MIN (NEQ MIN 0))
(BQUOTE ((COND
((ILESSP (\, (QUOTE -args-))
(\, MIN))
(ERROR "Too few args" (\, (QUOTE -args-]
[\,@ (COND
((AND *CHECK-ARGUMENT-COUNTS* MAX)
(BQUOTE ((COND
((IGREATERP (\, (QUOTE -args-))
(\, MAX))
(ERROR "Too many args" (\, (QUOTE -args-]
(LET* ([\,@ (for VAR in (REVERSE VRBLS) as I from 1
collect (LIST VAR (BQUOTE (ARG -args- (\, I]
(\,@ (REVERSE OPTVARS))
(\,@ (REVERSE KEYVARS))
(\,@ RESTFORM)
(\,@ (REVERSE AUXLIST)))
(\,@ DECLS)
(\,@ BODY])
)
(DEFPARAMETER *CHECK-ARGUMENT-COUNTS* NIL)
(PUTPROPS COMMON-LISP DMACRO ((X)
X))
(DEFUN SPECIAL-FORM-P (X) (GET X (QUOTE SPECIAL-FORM)))
(DEFPARAMETER LAMBDA-LIST-KEYWORDS (QUOTE (&OPTIONAL &REST &KEY &AUX &BODY &WHOLE &ALLOW-OTHER-KEYS
&ENVIRONMENT)) )
(DEFPARAMETER CALL-ARGUMENTS-LIMIT 1000Q)
(DEFPARAMETER LAMBDA-PARAMETERS-LIMIT 1000Q)
(DEFSTRUCT CLOSURE "An interpreted lexical closure. Contains the function and an environment object"
FUNCTION ENVIRONMENT)
(DEFSTRUCT ENVIRONMENT "An environment used both by interpreter and macro expander" VARS FUNCTIONS
BLOCKS TAGS
PARENT
MACROS)
(DEFINEQ
(CL:EVAL
[LAMBDA (EXPRESSION ENVIRONMENT)
(DECLARE (LOCALVARS . T)) (* lmm "28-Jul-86 14:52")
(TYPECASE EXPRESSION [SYMBOL (COND
((NULL EXPRESSION)
NIL)
((EQ EXPRESSION T)
T)
((KEYWORDP EXPRESSION) (*
"wouldn't need this if keywords were set to themselves when generated")
EXPRESSION)
(T (while ENVIRONMENT bind LOC VAL
do (if (SETQ LOC (ASSOC EXPRESSION (ENVIRONMENT-VARS
ENVIRONMENT)))
then (RETURN (CDR LOC))
else (SETQ ENVIRONMENT (ENVIRONMENT-PARENT ENVIRONMENT
)))
finally (*
"copied from \EVALVAR in the Interlisp interpreter")
(SETQ LOC (\STKSCAN EXPRESSION))
(RETURN (COND
((AND (EQ (SETQ VAL (\GETBASEPTR LOC 0))
(QUOTE NOBIND))
(EQ (FLOOR (\HILOC LOC)
2)
(\HILOC \VALSPACE)))
(* Value is NOBIND and it was found as
the top-level value)
(CL:ERROR (QUOTE UNBOUND-VARIABLE)
:NAME EXPRESSION))
(T VAL]
[CONS (CL:IF (CONSP (CAR EXPRESSION))
[LET ((ARGCOUNT 1)) (* "This is a very very awful hack."
".COMPILER-SPREAD-ARGUMENTS. is handled specially by the compiler"
"it iterates over a list pushing things"
"secondly, the (OPCODES) directly calls"
EVAL-INVOKE-LAMBDA
"with more args than are given, blowing away the following APPLYFN")
(.COMPILER-SPREAD-ARGUMENTS. (CDR EXPRESSION)
ARGCOUNT
((OPCODES FN3 0 (FN . EVAL-INVOKE-LAMBDA)
RETURN)
(CAR EXPRESSION)
ENVIRONMENT)
((CL:EVAL ENVIRONMENT]
(CASE (ARGTYPE (CAR EXPRESSION))
[(0 2)
(LET ((ARGCOUNT 0))
(.COMPILER-SPREAD-ARGUMENTS. (CDR EXPRESSION)
ARGCOUNT
(CAR EXPRESSION)
((CL:EVAL ENVIRONMENT]
(T (LET [(TEMP (GET (CAR EXPRESSION)
(QUOTE SPECIAL-FORM]
(COND
(TEMP (FUNCALL TEMP (CDR EXPRESSION)
ENVIRONMENT))
((SETQ TEMP (MACRO-FUNCTION (CAR EXPRESSION)
ENVIRONMENT))
(CL:EVAL (MACROEXPAND-1 EXPRESSION ENVIRONMENT)
ENVIRONMENT))
(T (ERROR "Undefined car of form" EXPRESSION]
((OR NUMBER STRING CHARACTER)
EXPRESSION)
(OTHERWISE (CERROR "return the expression as its own value" "~s invalid form for EVAL."
EXPRESSION)
EXPRESSION])
(EVAL-INVOKE-LAMBDA
[LAMBDA (N LAM ENVIRONMENT) (* lmm "27-Jul-86 00:09")
(LET [(ARGBLOCK (ADDSTACKBASE (- (fetch (FX NEXTBLOCK) of (\MYALINK))
(+ (DECF N)
N]
(* First sub-form is a list of (variable initialization) pairs.
Initializes the variables, binding them to new values all at once, then
executes the remaining forms as in a PROGN.)
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY (CDR (CDR LAM))
ENVIRONMENT)
(\INTERPRET-ARGUMENTS (ECASE (CAR LAM)
[LAMBDA (QUOTE &INTERLISP]
(CL:LAMBDA (QUOTE &REQUIRED)))
(CADR LAM)
DECLS
(MAKE-ENVIRONMENT :PARENT ENVIRONMENT)
BODY ARGBLOCK N 0])
(\INTERPRET-ARGUMENTS
[LAMBDA (\ARGTYPE \ARGLIST \DECLARATIONS \ENVIRONMENT \BODY \ARGUMENT-BLOCK \LENGTH \INDEX)
(* lmm "27-Jul-86 00:09")
(* "Written in a somewhat arcane style to avoid recursive calls whenever possible, & keep code inline. RECUR does a recursive call if under a PROGV, but otherwise does a GO. ")
(MACROLET
[[RECUR (TAG)
(BQUOTE (GO (\, TAG]
(WITH-BINDING
(VAR VAL &REST FORMS)
(BQUOTE (PROGN (CHECK-BINDABLE (\, VAR))
(CL:IF (OR (DECLARED-SPECIAL (\, VAR)
\DECLARATIONS)
(VARIABLE-GLOBALLY-SPECIAL-P (\, VAR)))
(MACROLET
[(RECUR (TAG)
(BQUOTE (\INTERPRET-ARGUMENTS
[\, (CL:IF (EQ TAG (QUOTE IN-KEYWORDS))
(QUOTE \ARGTYPE)
(BQUOTE (QUOTE (\, TAG]
\ARGLIST \DECLARATIONS \ENVIRONMENT \BODY
\ARGUMENT-BLOCK \LENGTH \INDEX]
(PROGV (LIST (\, VAR))
(LIST (\, VAL))
(\,@ FORMS)))
(PROGN (CL:PUSH (CONS (\, VAR)
(\, VAL))
(ENVIRONMENT-VARS \ENVIRONMENT))
(\,@ FORMS]
(PROG (VAR VAL SVAR SP)
(* * "dispatch on input type. The in-keywords case is special, since it needs to pass down where the beginning of the keywords section is")
(CASE \ARGTYPE (&REQUIRED (GO &REQUIRED))
(&OPTIONAL (GO &OPTIONAL))
(&INTERLISP (GO &INTERLISP))
(&REST (GO &REST))
(&KEY (GO &KEY))
(&AUX (GO &AUX))
(&BODY (GO &BODY))
(T (GO IN-KEYWORDS)))
&REQUIRED
[RETURN (COND
((NULL \ARGLIST)
(CL:IF (< \INDEX \LENGTH)
(CL:ERROR (QUOTE TOO-MANY-ARGUMENTS)))
(RECUR &BODY))
(T (CASE (SETQ VAR (pop \ARGLIST))
(&OPTIONAL (RECUR &OPTIONAL))
(&REST (RECUR &REST))
(&AUX (RECUR &AUX))
(&KEY (RECUR &KEY))
(T [COND
((>= \INDEX \LENGTH)
(CL:ERROR (QUOTE TOO-FEW-ARGUMENTS]
[SETQ VAL (ARG-REF \ARGUMENT-BLOCK (PROG1 \INDEX (INCF \INDEX]
(WITH-BINDING VAR VAL (RECUR &REQUIRED]
&OPTIONAL
[RETURN (COND
((NULL \ARGLIST)
(CL:IF (< \INDEX \LENGTH)
(CL:ERROR (QUOTE TOO-MANY-ARGUMENTS)))
(RECUR &BODY))
(T (CASE (SETQ VAR (pop \ARGLIST))
(&REST (RECUR &REST))
(&AUX (RECUR &AUX))
(&KEY (RECUR &KEY))
(T (CL:IF (>= \INDEX \LENGTH)
(CL:IF (CONSP VAR)
(PROGN (SETQ VAL (CL:EVAL (CADR VAR)
\ENVIRONMENT))
(SETQ SVAR (CADDR VAR))
(SETQ VAR (CAR VAR))
(SETQ SP NIL))
(SETQ VAL NIL))
(PROGN [COND
((CONSP VAR)
(SETQ SVAR (CADDR VAR))
(SETQ SP T)
(SETQ VAR (CAR VAR]
(SETQ VAL (ARG-REF \ARGUMENT-BLOCK \INDEX))
(INCF \INDEX)))
(WITH-BINDING VAR VAL (CL:IF SVAR (WITH-BINDING SVAR SP
(RECUR &OPTIONAL))
(RECUR &OPTIONAL]
&INTERLISP
[RETURN (COND
((NULL \ARGLIST)
(RECUR &BODY))
(T (SETQ VAR (pop \ARGLIST))
(CL:IF (>= \INDEX \LENGTH)
(SETQ VAL NIL)
(PROGN (SETQ VAL (ARG-REF \ARGUMENT-BLOCK \INDEX))
(INCF \INDEX)))
(WITH-BINDING VAR VAL (RECUR &INTERLISP]
&REST
(SETQ VAR (pop \ARGLIST))
(SETQ VAL (for I from \INDEX while (< I \LENGTH) collect (ARG-REF \ARGUMENT-BLOCK I)))
[RETURN (WITH-BINDING VAR VAL (CL:IF (NULL \ARGLIST)
(RECUR &BODY)
(CASE (pop \ARGLIST)
(&AUX (RECUR &AUX))
(&KEY (RECUR &KEY))
(T (CL:ERROR (QUOTE INVALID-ARGUMENT-LIST]
&KEY
(OR (EVENP (- \LENGTH \INDEX))
(CL:ERROR "Not an even number of arguments for &KEY"))
(SETQ \ARGTYPE \ARGLIST) (*
"Type is now the beginning of the keyword arguments")
IN-KEYWORDS
[RETURN
(COND
((NULL \ARGLIST)
(CHECK-KEYWORDS \ARGTYPE \ARGUMENT-BLOCK \LENGTH \INDEX)
(RECUR &BODY))
(T (CASE (SETQ VAR (pop \ARGLIST))
(&AUX (CHECK-KEYWORDS \ARGTYPE \ARGUMENT-BLOCK \LENGTH \INDEX)
(RECUR &AUX))
[&ALLOW-OTHER-KEYS (CL:IF (NULL \ARGLIST)
(RECUR &BODY)
(CASE (pop \ARGLIST)
(&AUX (RECUR &AUX))
(T (CL:ERROR (QUOTE INVALID-ARGUMENT-LIST]
(T (COND
((CONSP VAR)
(SETQ VAL (CADR VAR))
(SETQ SVAR (CADDR VAR))
(SETQ VAR (CAR VAR)))
(T (SETQ SVAR NIL)
(SETQ VAL NIL)))
(LET [(KEY (CL:IF (CONSP VAR)
(PROG1 (CAR VAR)
(SETQ VAR (CADR VAR)))
(MAKE-KEYWORD VAR]
(for I from \INDEX while (< I \LENGTH) by 2
do [CL:IF (EQ (ARG-REF \ARGUMENT-BLOCK I)
KEY)
(RETURN (PROGN (SETQ VAL (ARG-REF \ARGUMENT-BLOCK
(+ I 1)))
(SETQ SP T]
finally (SETQ VAL (CL:EVAL VAL \ENVIRONMENT))
(SETQ SP NIL)))
(WITH-BINDING VAR VAL (CL:IF SVAR (WITH-BINDING SVAR SP (RECUR IN-KEYWORDS
))
(RECUR IN-KEYWORDS]
&AUX
[RETURN (COND
((NULL \ARGLIST)
(RECUR &BODY))
(T (SETQ VAR (pop \ARGLIST))
(CL:IF (CONSP VAR)
(PROGN (SETQ VAL (CL:EVAL (CADR VAR)
\ENVIRONMENT))
(SETQ VAR (CAR VAR)))
(SETQ VAL NIL))
(WITH-BINDING VAR VAL (RECUR &AUX]
&BODY
(RETURN (CL:IF (NULL (CDR \BODY))
(CL:IF (CONSP (SETQ \BODY (CAR \BODY)))
(CASE (CAR \BODY)
(CL:BLOCK (* "special case to handle BLOCK to avoid consing two environments just to enter a normal LAMBDA function")
(SETF (ENVIRONMENT-BLOCKS \ENVIRONMENT)
(SETQ \BODY (CDR \BODY)))
(CATCH \ENVIRONMENT (EVAL-PROGN (CDR \BODY)
\ENVIRONMENT)))
(T (CL:EVAL \BODY \ENVIRONMENT)))
(CL:EVAL \BODY \ENVIRONMENT))
(PROGN (CL:EVAL (pop \BODY)
\ENVIRONMENT)
(RECUR &BODY])
(\INTERPRETER-LAMBDA
[LAMBDA (N DEF ENV FN) (* lmm "27-Jul-86 00:10")
(LET [(ARGBLOCK (ADDSTACKBASE (fetch (BF IVAR) of (fetch (FX BLINK) of (\MYALINK]
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY (CDR (CDR DEF))
NIL)
(\INTERPRET-ARGUMENTS (QUOTE &REQUIRED)
(CAR (CDR DEF))
DECLS
(MAKE-ENVIRONMENT :PARENT ENV)
BODY ARGBLOCK (- N 1)
0])
(CHECK-BINDABLE
[LAMBDA (VAR) (* lmm "20-Jul-86 15:16")
(* "19-Jul-86 15:56")
(CL:UNLESS (SYMBOLP VAR)
(CL:ERROR "attempt to bind a non-symbol: ~A" VAR))
(CL:WHEN (OR (CONSTANTP VAR)
(FMEMB VAR LAMBDA-LIST-KEYWORDS))
(CL:ERROR (CL:IF (KEYWORDP VAR)
"attempt to bind a keyword: ~A" "attempt to bind a constant: ~A")
VAR))
(CL:WHEN (VARIABLE-GLOBAL-P VAR)
(CERROR "Go ahead and bind it anyway" "Attempt to bind a variable proclaimed global" VAR))
VAR])
(CHECK-KEYWORDS
[LAMBDA (KEY-ARGUMENTS ARGBLOCK LENGTH N) (* lmm "20-Jul-86 13:33")
(* "19-Jul-86 22:42")
(* "check to see if any keywords in ARGBLOCK are not in the keys - not called if &ALLOW-OTHER-KEYS was set")
(CL:BLOCK CHECK-KEYS (LET (BADKEYWORD)
[CL:DO ((I N (+ I 2)))
((>= I LENGTH))
(LET ((GIVEN-KEY (ARG-REF ARGBLOCK I)))
(CL:IF (EQ GIVEN-KEY :ALLOW-OTHER-KEYS)
(CL:IF (ARG-REF ARGBLOCK (1+ I))
(RETURN-FROM CHECK-KEYS NIL)
NIL)
(CL:DO ((KEYTAIL KEY-ARGUMENTS (CDR KEYTAIL)))
((OR (NULL KEYTAIL)
(EQ (CAR KEYTAIL)
(QUOTE &AUX)))
(* "got to end of keyword segment")
(SETQ BADKEYWORD GIVEN-KEY))
(LET ((WANTED-KEY (CAR KEYTAIL)))
[CL:WHEN (CONSP WANTED-KEY)
(SETQ WANTED-KEY (CAR WANTED-KEY)
)
(CL:WHEN (CONSP WANTED-KEY)
(SETQ WANTED-KEY
(CAR WANTED-KEY]
(CL:IF (EQ (MAKE-KEYWORD WANTED-KEY)
GIVEN-KEY)
(RETURN NIL]
(CL:IF BADKEYWORD (CL:ERROR
"Keyword argument doesn't match expected list of keywords: ~A"
BADKEYWORD])
)
(DEFMACRO ARG-REF (BLOCK N) (BQUOTE (\GETBASEPTR (\, BLOCK)
(LLSH (\, N)
1))))
(PUTPROPS .COMPILER-SPREAD-ARGUMENTS. DMACRO (APPLY COMP.SPREAD))
(DEFINEQ
(DECLARED-SPECIAL
[LAMBDA (VAR DECLS) (* lmm "24-May-86 22:27")
(AND DECLS (OR (AND (LISTP (CAR DECLS))
(EQ (CAAR DECLS)
(QUOTE DECLARE))
(for DEC in (CDAR DECLS) when (AND (EQ (CAR DEC)
(QUOTE SPECIAL))
(FMEMB VAR (CDR DEC)))
do (RETURN T)))
(DECLARED-SPECIAL VAR (CDR DECLS])
(EVALHOOK
(CL:LAMBDA (FORM EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV) (* lmm " 2-May-86 22:23")
(* Evaluates Form with *Evalhook*
bound to Evalhookfn and *Applyhook*
bound to applyhookfn.
Ignores these hooks once, for the
top-level evaluation of Form.
*)
(LET ((*EVALHOOK* EVALHOOKFN)
(*SKIP-EVALHOOK* T)
(*APPLYHOOK* APPLYHOOKFN)
(*SKIP-APPLYHOOK* NIL))
(HOOKED-EVAL FORM))))
)
(* FUNCALL and APPLY, not quite same as Interlisp)
(DEFINEQ
(FUNCALL
(CL:LAMBDA (FN &REST ARGS) (* lmm " 2-May-86 21:58")
(CL:APPLY FN ARGS)))
(CL:APPLY
[LAMBDA N (* lmm "29-Apr-86 21:26")
(DECLARE (LOCALVARS . T)) (* compiles "open")
(SELECTQ N
(0 (ERROR "TOO FEW ARGUMENTS TO APPLY"))
(SPREADAPPLY (ARG N 1)
(LET ((AV (ARG N N)))
(for I from (SUB1 N) to 2 by -1 do (push AV (ARG N I)))
AV])
)
(PUTPROPS CL:APPLY DMACRO (DEFMACRO (FN &REST ARGS) (BQUOTE
(LET ((FN (\, FN))
(CNT (\, (LENGTH (CDR ARGS)))))
(.SPREAD. ((OPCODES)
%,@ ARGS)
CNT FN))) )
)
(PUTPROPS FUNCALL DMACRO (DEFMACRO (FN &REST ARGS) (BQUOTE ((OPCODES APPLYFN)
(\,@ ARGS)
(\, (LENGTH ARGS))
(\, FN))) )
)
(* COMPILER-LET needs to work differently compiled and interpreted)
(DEFINEQ
(COMPILER-LET
[NLAMBDA TAIL (* lmm "27-May-86 11:19")
(PROGV (for X in (CAR TAIL) collect (COND
((CONSP X)
(CAR X))
(T X)))
[for X in (CAR TAIL) collect (COND
((CONSP X)
(\EVAL (CADR X]
(\EVPROGN (CDR TAIL])
(COMP.COMPILER-LET
[LAMBDA (A)
(DECLARE (LOCALVARS . T)) (* lmm "27-May-86 12:14")
(* ENTRY POINT INTO BYTECOMPILER)
(* lmm "27-May-86 11:17")
(PROGV (for X in (CAR A) collect (if (CONSP X)
then (CAR X)
else X))
[for X in (CAR A) collect (COND
((CONSP X)
(EVAL (CADR X]
(COMP.PROGN (CDR A])
)
(PUTPROPS COMPILER-LET DMACRO COMP.COMPILER-LET)
(DEFINE-SPECIAL-FORM COMPILER-LET (ARGS &REST BODY &ENVIRONMENT ENV)
(LET ((*IN-COMPILER-LET* T))
(DECLARE (SPECIAL *IN-COMPILER-LET*)) (*
"the *IN-COMPILER-LET* is for macro-caching. It says: don't cache macros under compiler lets")
(PROGV (for X in ARGS collect (if (CONSP X)
then (CAR X)
else X))
(for X in ARGS collect (if (CONSP X)
then (CL:EVAL (CADR X)
ENV)
else NIL))
(EVAL-PROGN BODY ENV))))
(DEFINE-SPECIAL-FORM QUOTE CAR)
(DEFINE-SPECIAL-FORM THE (TYPE-SPEC FORM &ENVIRONMENT ENV)
(CL:IF (EQ (CAR (LISTP TYPE-SPEC))
(QUOTE VALUES))
(LET ((VALUES (MULTIPLE-VALUE-LIST (CL:EVAL FORM ENV))))
(CL:IF (CL:NOTEVERY (CL:FUNCTION (CL:LAMBDA (VALUE SPEC)
(TYPEP VALUE SPEC)))
VALUES
(CDR TYPE-SPEC))
(CHECK-TYPE-FAIL T FORM VALUES TYPE-SPEC NIL)
(VALUES-LIST VALUES)))
(LET ((VALUE (CL:EVAL FORM ENV)))
(CL:IF (TYPEP VALUE TYPE-SPEC)
VALUE
(CHECK-TYPE-FAIL T FORM VALUE TYPE-SPEC NIL)))))
(PUTPROPS THE DMACRO ((SPEC FORM)
FORM))
(PUTPROPS EVAL-WHEN DMACRO (DEFMACRO (OPTIONS &BODY BODY) (AND (OR (FMEMB (QUOTE COMPILE)
OPTIONS)
(FMEMB (QUOTE CL:COMPILE)
OPTIONS))
(MAPC BODY (FUNCTION CL:EVAL)))
(AND (OR (FMEMB (QUOTE LOAD)
OPTIONS)
(FMEMB (QUOTE CL:LOAD)
OPTIONS))
(BQUOTE (PROGN (\,@ BODY)))))
)
(DEFINEQ
(EVAL-WHEN
[NLAMBDA OPTIONS.BODY (* lmm " 1-Jun-86 15:16")
(AND (OR (FMEMB (QUOTE CL:EVAL)
(CAR OPTIONS.BODY))
(FMEMB (QUOTE EVAL)
(CAR OPTIONS.BODY)))
(MAPC (CDR OPTIONS.BODY)
(FUNCTION \EVAL])
)
(DEFINE-SPECIAL-FORM EVAL-WHEN (TAGS &REST BODY &ENVIRONMENT ENV) (AND (OR (FMEMB (QUOTE CL:EVAL)
TAGS)
(FMEMB (QUOTE EVAL)
TAGS))
(EVAL-PROGN BODY ENV)))
(DEFMACRO CL:DECLARE (&REST DECLS) (BQUOTE (DECLARE (\,@ DECLS))))
(DEFINE-SPECIAL-FORM DECLARE FALSE)
(DEFMACRO LOCALLY (&BODY BODY) (BQUOTE (LET NIL (\,@ BODY))))
(* Interlisp version on LLINTERP)
(DEFINE-SPECIAL-FORM PROGN EVAL-PROGN)
(DEFINEQ
(EVAL-PROGN
[LAMBDA (BODY ENVIRONMENT) (* lmm "22-May-86 23:55")
(if (CDR BODY)
then (CL:EVAL (CAR BODY)
ENVIRONMENT)
(EVAL-PROGN (CDR BODY)
ENVIRONMENT)
else (CL:EVAL (CAR BODY)
ENVIRONMENT])
)
(* confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex -
Interlisp function is on LLINTERP)
(DEFINE-SPECIAL-FORM PROG1 (FIRST &REST REST &ENVIRONMENT ENV)
(LET ((VAL (CL:EVAL FIRST ENV)))
(TAGBODY PROG1 (CL:IF REST (PROGN (CL:EVAL (CAR REST)
ENV)
(SETQ REST (CDR REST)))
(RETURN-FROM PROG1 VAL))
(GO PROG1))))
(DEFMACRO PROG1 (FIRST &REST REST) (CONS (QUOTE (LAMBDA (X)
X))
(CONS FIRST REST)))
(DEFINE-SPECIAL-FORM LET* (VARS &REST BODY &ENVIRONMENT ENVIRONMENT)
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY BODY ENVIRONMENT)
(COND
(VARS (LET ((NEWENV (MAKE-ENVIRONMENT :PARENT ENVIRONMENT)))
(EVAL-LET*-RECURSION VARS DECLS NEWENV BODY)))
(T (EVAL-PROGN BODY ENVIRONMENT)))))
(DEFINE-SPECIAL-FORM LET (VARS &BODY BODY &ENVIRONMENT ENVIRONMENT)
(* Initializes the variables, binding
them to new values all at once, then
executes the remaining forms as in a
PROGN.)
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY BODY ENVIRONMENT)
(LET (LEXVARS SPECVARS SPECVALS)
(for VAR in VARS do (LET (VALUE)
(if (CONSP VAR)
then (SETQ VALUE (CL:EVAL (CADR VAR)
ENVIRONMENT))
(SETQ VAR (CAR VAR)))
(CHECK-BINDABLE VAR)
(if (OR (DECLARED-SPECIAL VAR DECLS)
(VARIABLE-GLOBALLY-SPECIAL-P VAR))
then (CL:PUSH VAR SPECVARS)
(CL:PUSH VALUE SPECVALS)
else (CL:PUSH (CONS VAR VALUE)
LEXVARS))))
(CL:IF SPECVARS (PROGV SPECVARS SPECVALS (EVAL-PROGN BODY
(CL:IF LEXVARS
(MAKE-ENVIRONMENT :VARS LEXVARS
:PARENT ENVIRONMENT)
ENVIRONMENT)))
(EVAL-PROGN BODY (CL:IF LEXVARS (MAKE-ENVIRONMENT :VARS LEXVARS :PARENT
ENVIRONMENT)
ENVIRONMENT))))))
(PUTPROPS LET MACRO (X (\LETtran X)))
(PUTPROPS LET* MACRO (X (\LETtran X T)))
(DEFINEQ
(EVAL-LET*-RECURSION
[LAMBDA (VARS DECLS ENV BODY)
(DECLARE (LOCALVARS . T)) (* lmm "20-Jul-86 15:10")
(* "19-Jul-86 15:56")
(PROG NIL
ITERATE
(CL:IF (NOT VARS)
(RETURN (EVAL-PROGN BODY ENV))
(LET ((VAR (pop VARS))
VALUE)
(CL:WHEN (CONSP VAR)
(SETQ VALUE (CL:EVAL (CADR VAR)
ENV))
(SETQ VAR (CAR VAR)))
(CHECK-BINDABLE VAR)
(CL:IF (OR (DECLARED-SPECIAL VAR DECLS)
(VARIABLE-GLOBALLY-SPECIAL-P VAR))
(RETURN (PROGV (LIST VAR)
(LIST VALUE)
(EVAL-LET*-RECURSION VARS DECLS ENV BODY)))
(PROGN (CL:PUSH (CONS VAR VALUE)
(ENVIRONMENT-VARS ENV))
(GO ITERATE])
(\LETtran
[LAMBDA (LETTAIL SEQUENTIALP) (* lmm "16-Jul-85 12:52")
(PROG ([VARS (MAPCAR (CAR LETTAIL)
(FUNCTION (LAMBDA (BINDENTRY)
(if (LISTP BINDENTRY)
then (CAR BINDENTRY)
ELSE BINDENTRY]
[VALS (MAPCAR (CAR LETTAIL)
(FUNCTION (LAMBDA (BINDENTRY)
(if (LISTP BINDENTRY)
then (if (CDDR BINDENTRY)
then (CONS (QUOTE PROG1)
(CDR BINDENTRY))
else (CADR BINDENTRY))
else NIL]
(BODY (CDR LETTAIL))
(DECLS NIL)
(COMNTS NIL))
(RETURN (if (NOT SEQUENTIALP)
then (LIST* (LIST* (QUOTE LAMBDA)
VARS BODY)
VALS)
elseif (NULL (CDR VARS))
then (SELECTQ SEQUENTIALP
(PROG* (CONS (QUOTE PROG)
LETTAIL))
(BQUOTE ([LAMBDA %, VARS %,@ BODY]
%,@ VALS)))
else (* in the sequential case, all
declarations must be "pulled up" to
the top)
[if (EQ SEQUENTIALP (QUOTE PROG*))
then (SETQ BODY (LIST (LIST* (QUOTE PROG)
NIL BODY]
[for VAR in (REVERSE (CDR VARS)) as VAL in (REVERSE (CDR VALS))
do (SETQ BODY (LIST (LIST (LIST* (QUOTE LAMBDA)
(LIST VAR)
BODY)
VAL]
(LIST (LIST* (QUOTE LAMBDA)
(LIST (CAR VARS))
BODY)
(CAR VALS])
)
(DEFINE-SPECIAL-FORM COND (&REST COND-CLAUSES &ENVIRONMENT ENVIRONMENT)
(PROG NIL
CONDLOOP
(COND
((NULL COND-CLAUSES)
(RETURN NIL))
((NULL (CDAR COND-CLAUSES))
(RETURN (OR (CL:EVAL (CAAR COND-CLAUSES)
ENVIRONMENT)
(PROGN (SETQ COND-CLAUSES (CDR COND-CLAUSES))
(GO CONDLOOP)))))
((CL:EVAL (CAAR COND-CLAUSES)
ENVIRONMENT)
(RETURN (EVAL-PROGN (CDAR COND-CLAUSES)
ENVIRONMENT)))
(T (SETQ COND-CLAUSES (CDR COND-CLAUSES))
(GO CONDLOOP)))))
(DEFMACRO COND (&REST TAIL)
(CL:IF TAIL (CL:IF (NULL (CDAR TAIL))
(CL:IF (CDR TAIL)
(LET ((VAR (GENTEMP)))
(BQUOTE (LET (((\, VAR)
(\, (CAAR TAIL))))
(CL:IF (\, VAR)
(\, VAR)
(COND
(\,@ (CDR TAIL)))))))
(BQUOTE (VALUES (\, (CAAR TAIL)))))
(BQUOTE (CL:IF (\, (CAAR TAIL))
(\, (MKPROGN (CDAR TAIL)))
(\,@ (CL:IF (CDR TAIL)
(LIST (CL:IF (EQ (CAADR TAIL)
T)
(MKPROGN (CDADR TAIL))
(BQUOTE (COND
(\,@ (CDR TAIL)))))))))))))
(* consider making CL:IF extended to have Interlisp's features)
(DEFINEQ
(CL:IF
[NLAMBDA (TEST THEN ELSE)
(DECLARE (LOCALVARS . T)) (* lmm " 1-Jun-86 16:15")
(COND
((\EVAL TEST)
(\EVAL THEN))
(T (\EVAL ELSE])
)
(DEFINE-SPECIAL-FORM CL:IF (TEST THEN &OPTIONAL ELSE &ENVIRONMENT ENVIRONMENT) (COND
((CL:EVAL TEST
ENVIRONMENT
)
(CL:EVAL THEN
ENVIRONMENT
))
(T (CL:EVAL ELSE
ENVIRONMENT
))))
(PUTPROPS CL:IF DMACRO COMP.IF)
(* Interlisp NLAMBDA definitions on LLINTERP - both special form and macro)
(DEFMACRO AND (&REST FORMS) (CL:IF (CDR FORMS)
(BQUOTE (CL:IF (\, (CAR FORMS))
(AND (\,@ (CDR FORMS)))))
(CL:IF FORMS (CAR FORMS)
T)))
(DEFMACRO OR (&REST FORMS) (CL:IF (NULL (CDR FORMS))
(CAR FORMS)
(LET ((VAR (GENTEMP "OR")))
(BQUOTE (LET (((\, VAR)
(\, (CAR FORMS))))
(CL:IF (\, VAR)
(\, VAR)
(OR (\,@ (CDR FORMS)))))))))
(DEFINE-SPECIAL-FORM AND (&REST AND-CLAUSES &ENVIRONMENT ENV)
(LOOP (COND
((NULL AND-CLAUSES)
(RETURN T))
((NULL (CDR AND-CLAUSES))
(RETURN (CL:EVAL (CAR AND-CLAUSES)
ENV)))
(T (CL:IF (CL:EVAL (CAR AND-CLAUSES)
ENV)
(SETQ AND-CLAUSES (CDR AND-CLAUSES))
(RETURN NIL))))))
(DEFINE-SPECIAL-FORM OR (&REST TAIL &ENVIRONMENT ENV) (PROG (VAL)
ORLOOP
(COND
((NULL TAIL)
(RETURN NIL))
((NULL (CDR TAIL))
(RETURN (CL:EVAL (CAR TAIL)
ENV)))
((SETQ VAL (CL:EVAL (CAR TAIL)
ENV))
(RETURN VAL))
(T (SETQ TAIL (CDR TAIL))
(GO ORLOOP)))))
(* BLOCK and RETURN go together)
(DEFINEQ
(CL:BLOCK
[NLAMBDA TAIL
(\EVPROGN (CDR TAIL])
)
(PUTPROPS CL:BLOCK DMACRO COMP.BLOCK)
(DEFINE-SPECIAL-FORM CL:BLOCK (&REST TAIL &ENVIRONMENT ENVIRONMENT)
(* Syntax is (CL:BLOCK name . body)%. The body is evaluated as a PROGN, but it
is possible to exit the block using (RETURN-FROM name value)%.
The RETURN-FROM must be lexically contained within the block.)
(* make RETURN and RETURN-FROM do the
work)
(CATCH (SETQ ENVIRONMENT (MAKE-ENVIRONMENT :BLOCKS TAIL :PARENT ENVIRONMENT))
(EVAL-PROGN (CDR TAIL)
ENVIRONMENT)))
(DEFMACRO RETURN (VALUE) (BQUOTE (RETURN-FROM NIL (\, VALUE))))
(DEFINEQ
(RETURN-FROM
[NLAMBDA (RETFROM-TAG RETFROM-VALUE)
(DECLARE (LOCALVARS . T)) (* amd " 2-Jun-86 18:30")
(LET [(RETVALUES (MULTIPLE-VALUE-LIST (\EVAL RETFROM-VALUE]
(LET ((FRAME (STKNTH 1)))
(while FRAME do (if (OR (AND (NULL RETFROM-TAG)
(EQ (STKNAME FRAME)
(QUOTE \PROG0)))
(AND (EQ (STKNAME FRAME)
(QUOTE CL:BLOCK))
(EQ (CAR (STKARG 1 FRAME))
RETFROM-TAG)))
then (RETVALUES FRAME RETVALUES T)
else (SETQ FRAME (STKNTH 1 FRAME FRAME)))
finally (CL:ERROR (QUOTE ILLEGAL-RETURN)
:TAG RETFROM-TAG])
)
(DEFINE-SPECIAL-FORM RETURN-FROM (TAG VALUE &ENVIRONMENT ENVIRONMENT)
(LET ((ENV ENVIRONMENT))
(while ENV do (if (AND (ENVIRONMENT-BLOCKS ENV)
(EQ (CAR (ENVIRONMENT-BLOCKS ENV))
TAG))
then (RETURN)
else (SETQ ENV (ENVIRONMENT-PARENT ENV))) finally (CL:ERROR (QUOTE
ILLEGAL-RETURN
)
:TAG TAG))
(THROW ENV (CL:EVAL VALUE ENVIRONMENT))))
(* eventually shouldn't be shadowed but currently *really* different)
(DEFINEQ
(CL:FUNCTION
[NLAMBDA (FN) (* lmm "24-May-86 21:15")
(* fake CL:FUNCTION for Interlisp -
no lexical closures)
(if (SYMBOLP FN)
then (SYMBOL-FUNCTION FN)
else FN])
(FUNCTION
[NLAMBDA (FN ENV) (* lmm "24-May-86 16:03")
(* wrong, but -- for now)
(COND
[ENV (LIST (QUOTE FUNARG)
FN
(STKNTH -1 (QUOTE FUNCTION]
(T FN])
)
(PUTPROPS CL:FUNCTION DMACRO (DEFMACRO (X ) (if (SYMBOLP X)
then
(BQUOTE (SYMBOL-FUNCTION (QUOTE (\, X))))
else
(BQUOTE (FUNCTION (\, X)))) )
)
(DEFINE-SPECIAL-FORM CL:FUNCTION (FN &ENVIRONMENT ENVIRONMENT)
(if (SYMBOLP FN)
then (SYMBOL-FUNCTION FN)
elseif (NULL ENVIRONMENT)
then FN
else (MAKE-CLOSURE :FUNCTION (COND
((EQ (CAR FN)
(QUOTE LAMBDA))
(BQUOTE (CL:LAMBDA (&OPTIONAL (\,@ (CADR FN))
&REST IGNORE)
(\,@ (CDDR FN)))))
(T FN))
:ENVIRONMENT ENVIRONMENT)))
(DEFINE-SPECIAL-FORM FUNCTION (FN &OPTIONAL FUNARGP &ENVIRONMENT ENVIRONMENT)
(* like CL:FUNCTION except that
(FUNCTION FOO) just returns FOO and
not its definition)
(COND
(FUNARGP (* go to the Interlisp definition)
(FUNCALL (FUNCTION FUNCTION)
FN FUNARGP))
((SYMBOLP FN)
FN)
((NULL ENVIRONMENT)
FN)
(T (MAKE-CLOSURE :FUNCTION (COND
((EQ (CAR FN)
(QUOTE LAMBDA))
(BQUOTE (CL:LAMBDA (&OPTIONAL (\,@ (CADR FN))
&REST IGNORE)
(\,@ (CDDR FN)))))
(T FN))
:ENVIRONMENT ENVIRONMENT))))
(DEFINE-SPECIAL-FORM MULTIPLE-VALUE-CALL (FN &REST ARGS &ENVIRONMENT ENV)
(* for interpreted calls only.
The macro inserts a \MVLIST call after
the computation of TAIL)
(CL:APPLY (CL:EVAL FN ENV)
(for X in ARGS join (\MVLIST (CL:EVAL X ENV)))))
(DEFINEQ
(COMP.CL-EVAL
[LAMBDA (EXP) (* lmm " 5-Jun-86 00:44")
(COMP.SPREAD (BQUOTE (CDR (\,@ EXP)))
(QUOTE *EVAL-ARGUMENT-COUNT*)
(BQUOTE (CAR (\,@ EXP)))
(QUOTE ((CL:EVAL ENVIRONMENT])
)
(DEFVAR *EVALHOOK* NIL)
(DEFVAR *APPLYHOOK* NIL)
(RPAQ? *SKIP-EVALHOOK* NIL)
(RPAQ? *SKIP-APPLYHOOK* NIL)
(DEFINEQ
(CONSTANTP
[LAMBDA (OBJECT ENVIRONMENT) (* lmm "29-May-86 14:58")
(TYPECASE OBJECT (NUMBER T)
(CHARACTER T)
(STRING T)
(BIT-VECTOR T)
[SYMBOL (OR (EQ OBJECT NIL)
(EQ OBJECT T)
(KEYWORDP OBJECT)
(AND COMPVARMACROHASH (SETQ OBJECT (GETHASH OBJECT COMPVARMACROHASH))
(CONSTANTP OBJECT]
(CONS (CASE (CAR OBJECT)
(QUOTE T)
(CONSTANT T)
(OTHERWISE (COND
((FMEMB (CAR OBJECT)
CONSTANTFOLDFNS)
(EVERY (CDR OBJECT)
(FUNCTION CONSTANTP)))
(T (MULTIPLE-VALUE-BIND (NEW-FORM EXPANDED)
(MACROEXPAND OBJECT ENVIRONMENT)
(AND EXPANDED (CONSTANTP NEW-FORM])
)
(* Interlisp SETQ for Common Lisp and vice versa)
(DEFINE-SPECIAL-FORM CL:SETQ (&REST TAIL &ENVIRONMENT ENV) (* lmm "24-May-86 21:38")
(LET (VALUE)
(while TAIL do (SETQ VALUE (SET-SYMBOL (pop TAIL)
(CL:EVAL (pop TAIL)
ENV)
ENV)))
VALUE))
(DEFINE-SPECIAL-FORM SETQ (VAR VALUE &ENVIRONMENT ENV) (SET-SYMBOL VAR (CL:EVAL VALUE ENV)
ENV))
(PUTPROPS CL:SETQ DMACRO (DEFMACRO (X Y &REST REST) (BQUOTE
(PROGN
(SETQ (\, X)
(\, Y))
(\,@ (AND REST (BQUOTE ((CL:SETQ (\,@ REST)))))
))) )
)
(PUTPROPS SETQ MACRO (DEFMACRO (X &REST REST) (CONS (QUOTE CL:SETQ)
(CONS X REST)) )
)
(DEFINEQ
(SET-SYMBOL
[LAMBDA (SYMBOL VALUE ENVIRONMENT) (* lmm "24-May-86 21:36")
(if (NULL ENVIRONMENT)
then (SET SYMBOL VALUE)
else (LET [(PAIR (ASSOC SYMBOL (ENVIRONMENT-VARS ENVIRONMENT]
(if PAIR
then (SETF (CDR PAIR)
VALUE)
else (SET-SYMBOL SYMBOL VALUE (ENVIRONMENT-PARENT ENVIRONMENT])
)
(DEFMACRO PSETQ (&REST TAIL) (AND TAIL
(BQUOTE (PROGN (SETQ (\, (pop TAIL))
(\, (CL:IF (CDR TAIL)
(BQUOTE (PROG1 (\, (POP TAIL))
(PSETQ (\,@ TAIL))))
(CAR TAIL))))
NIL))))
(* "CommonLisp style CATCH and THROW")
(DEFINE-SPECIAL-FORM CATCH (TAG &REST BODY &ENVIRONMENT ENV) (\CATCH-CL-EVAL (CL:EVAL TAG ENV)
BODY ENV))
(DEFINE-SPECIAL-FORM THROW (TAG VALUE &ENVIRONMENT ENV) (\DO-THROW (CL:EVAL TAG ENV)
(MULTIPLE-VALUE-LIST (CL:EVAL VALUE
ENV))))
(DEFINEQ
(CATCH
[NLAMBDA L (* lmm "23-May-86 14:49")
(\CATCH-EVAL (\EVAL (CAR L))
(CDR L])
(\CATCH-FUNCALL
[LAMBDA (TAG FN) (* lmm "23-May-86 14:52")
(\CALLME (QUOTE *CATCH*))
(FUNCALL FN])
(\CATCH-EVAL
[LAMBDA (TAG BODY) (* lmm "23-May-86 14:52")
(\CALLME (QUOTE *CATCH*))
(\EVPROGN BODY])
(\CATCH-CL-EVAL
[LAMBDA (TAG BODY ENV) (* lmm "23-May-86 14:53")
(\CALLME (QUOTE *CATCH*))
(EVAL-PROGN BODY ENV])
(THROW
[NLAMBDA (THROW-TAG THROW-VALUE)
(DECLARE (LOCALVARS . T)) (* lmm "30-May-86 00:09")
(\DO-THROW (\EVAL THROW-TAG)
(MULTIPLE-VALUE-LIST (\EVAL THROW-VALUE])
(EVAL-THROW
[LAMBDA (TAIL ENV)
(DECLARE (LOCALVARS . T)) (* lmm "30-May-86 00:09")
(\DO-THROW (CL:EVAL (CAR TAIL)
ENV)
(MULTIPLE-VALUE-LIST (CL:EVAL (CADR TAIL)
ENV])
(\DO-THROW
[LAMBDA (TAG VALS) (* amd " 2-Jun-86 18:33")
(LET ((FRAME (STKNTH 1)))
(while FRAME do (if (AND (EQ (STKNAME FRAME)
(QUOTE *CATCH*))
(EQ (STKARG 1 FRAME)
TAG))
then (RETVALUES FRAME VALS T)
else (SETQ FRAME (STKNTH 1 FRAME FRAME))) finally (CL:ERROR (QUOTE
ILLEGAL-THROW
)
:TAG TAG])
)
(PUTPROPS CATCH DMACRO (DEFMACRO (TAGFORM &BODY BODY) (BQUOTE (\CATCH-FUNCALL (\, TAGFORM)
(FUNCTION (LAMBDA NIL
(\,@ BODY)))))
)
)
(PUTPROPS THROW DMACRO ((TAG VALS)
(\DO-THROW TAG (MULTIPLE-VALUE-LIST VALS))))
(DEFMACRO PROG (VARS &BODY (BODY DECLS)) (BQUOTE (CL:BLOCK NIL (LET (\, VARS)
(\,@ DECLS)
(TAGBODY (\,@ BODY))))))
(DEFMACRO PROG* (VARS &BODY (BODY DECLS)) (BQUOTE (CL:BLOCK NIL (LET* (\, VARS)
(\,@ DECLS)
(TAGBODY (\,@ BODY))))))
(DEFINE-SPECIAL-FORM GO (TAG &ENVIRONMENT ENV) (LET (TAIL)
(while ENV
do (if (SETQ TAIL (FMEMB TAG (ENVIRONMENT-TAGS
ENV)))
then (THROW ENV TAIL)
else (SETQ ENV (ENVIRONMENT-PARENT ENV)))
finally (CL:ERROR (QUOTE ILLEGAL-GO)
:TAG TAG))))
(DEFINE-SPECIAL-FORM TAGBODY (&REST TAGBODY-TAIL &ENVIRONMENT ENV)
(SETQ ENV (MAKE-ENVIRONMENT :TAGS TAGBODY-TAIL :PARENT ENV))
(while (SETQ TAGBODY-TAIL (CATCH ENV (for X in TAGBODY-TAIL unless (SYMBOLP X)
do (CL:EVAL X ENV))))))
(DEFINEQ
(TAGBODY
[NLAMBDA TAIL (* lmm "23-May-86 16:05")
(* like PROG with no variables)
(LET ((TL (CONS NIL TAIL)))
(\PROG0 TL TL])
)
(DEFINE-SPECIAL-FORM UNWIND-PROTECT (FORM &REST CLEANUPS &ENVIRONMENT ENV) (UNWIND-PROTECT
(CL:EVAL FORM ENV)
(EVAL-PROGN CLEANUPS ENV)
))
(DECLARE: EVAL@COMPILE
(PUTPROPS UNWIND-PROTECT DMACRO ((FORM . CLEANUPS)
(RESETLST [RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL . CLEANUPS]
FORM)))
)
(FILESLOAD CMLPROGV)
(* hack to get NLSETQs to work on common lisp interpreter)
(DEFINE-SPECIAL-FORM .ERRSETQ. (U V W &ENVIRONMENT ENV) (EVAL-ERRORSET U V W ENV))
(DEFINEQ
(EVAL-ERRORSET
[LAMBDA (X Y Z ENV) (* lmm " 6-Jun-86 01:49")
(\CALLME (QUOTE ERRORSET))
(LIST (CL:EVAL X ENV])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS CMLEVAL FILETYPE COMPILE-FILE)
(for X in SYSSPECVARS do (SETF (VARIABLE-GLOBALLY-SPECIAL-P X)
T))
(* "for macro caching")
(DEFINEQ
(CACHEMACRO
[LAMBDA (FN BODY ENV) (* "lmm" "26-Jul-86 02:34")
(CL:IF ENV (FUNCALL FN BODY NIL)
(OR (GETHASH BODY CLISPARRAY)
(PUTHASH BODY (FUNCALL FN BODY ENV)
CLISPARRAY])
)
(RPAQQ *MACROEXPAND-HOOK* CACHEMACRO)
(RPAQQ *IN-COMPILER-LET* NIL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TAGBODY CATCH CL:BLOCK EVAL-WHEN COMPILER-LET COMMON-LISP)
(ADDTOVAR NLAML THROW FUNCTION CL:FUNCTION RETURN-FROM CL:IF)
(ADDTOVAR LAMA CL:APPLY FUNCALL EVALHOOK)
)
(PUTPROPS CMLEVAL COPYRIGHT ("Xerox Corporation" 3702Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (21471Q 21740Q (COMMON-LISP 21503Q . 21736Q)) (22007Q 35642Q (\TRANSLATE-CL:LAMBDA
22021Q . 35640Q)) (37572Q 106523Q (CL:EVAL 37604Q . 51131Q) (EVAL-INVOKE-LAMBDA 51133Q . 53135Q) (
\INTERPRET-ARGUMENTS 53137Q . 77065Q) (\INTERPRETER-LAMBDA 77067Q . 100205Q) (CHECK-BINDABLE 100207Q
. 101475Q) (CHECK-KEYWORDS 101477Q . 106521Q)) (107113Q 112001Q (DECLARED-SPECIAL 107125Q . 110253Q)
(EVALHOOK 110255Q . 111777Q)) (112075Q 113242Q (FUNCALL 112107Q . 112324Q) (CL:APPLY 112326Q . 113240Q
)) (114773Q 117326Q (COMPILER-LET 115005Q . 116032Q) (COMP.COMPILER-LET 116034Q . 117324Q)) (124067Q
124615Q (EVAL-WHEN 124101Q . 124613Q)) (126162Q 126735Q (EVAL-PROGN 126174Q . 126733Q)) (135234Q
144560Q (EVAL-LET*-RECURSION 135246Q . 137537Q) (\LETtran 137541Q . 144556Q)) (150454Q 151016Q (CL:IF
150466Q . 151014Q)) (157611Q 157714Q (CL:BLOCK 157623Q . 157712Q)) (161305Q 163243Q (RETURN-FROM
161317Q . 163241Q)) (164751Q 166270Q (CL:FUNCTION 164763Q . 165560Q) (FUNCTION 165562Q . 166266Q)) (
173274Q 173731Q (COMP.CL-EVAL 173306Q . 173727Q)) (174130Q 176302Q (CONSTANTP 174142Q . 176300Q)) (
200531Q 201451Q (SET-SYMBOL 200543Q . 201447Q)) (203461Q 207461Q (CATCH 203473Q . 203735Q) (
\CATCH-FUNCALL 203737Q . 204205Q) (\CATCH-EVAL 204207Q . 204451Q) (\CATCH-CL-EVAL 204453Q . 204732Q) (
THROW 204734Q . 205306Q) (EVAL-THROW 205310Q . 205773Q) (\DO-THROW 205775Q . 207457Q)) (213332Q
213753Q (TAGBODY 213344Q . 213751Q)) (215360Q 215653Q (EVAL-ERRORSET 215372Q . 215651Q)) (216221Q
216675Q (CACHEMACRO 216233Q . 216673Q)))))
STOP