[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Revised proposed evaluator(s)
- To: common-lisp at SU-AI
- Subject: Revised proposed evaluator(s)
- From: STEELE at CMU-20C
- Date: Mon, 27 Sep 1982 04:27:00 -0000
In response to comments on the proposed sample Common LISP
evaluator, I have made these changes:
(1) Fixed an EVALHOOK bug; now the variable EVALHOOK is bound to NIL
over the invocation of the hook function.
(2) Fixed a bug in BLOCK; now the normal return values are properly returned.
(3) Fixed PROG to parse the declarations properly and put them in the LET
used to bind the variables.
(4) EVAL now calls *EVAL, not %EVAL, for parallelism with other versions.
Enclosed is the fixed version 1, and also version 2, which uses special
variables for VENV, FENV, BENV, and GENV to avoid parameter passing for
these slowly-changing variables. (Version 3, which is the bummed version
for Spice LISP, is about half-done and not enclosed here.)
--Guy
-----------------------------------------------------------
;;; This evaluator splits the lexical environment into four
;;; logically distinct entities:
;;; VENV = lexical variable environment
;;; FENV = lexical function and macro environment
;;; BENV = block name environment
;;; GENV = go tag environment
;;; Each environment is an a-list. It is never the case that
;;; one can grow and another shrink simultaneously; the four
;;; parts could be united into a single a-list. The four-part
;;; division saves consing and search time.
;;;
;;; Each entry in VENV has one of two forms: (VAR VALUE) or (VAR).
;;; The first indicates a lexical binding of VAR to VALUE, and the
;;; second indicates a special binding of VAR (implying that the
;;; special value should be used).
;;;
;;; Each entry in FENV looks like (NAME TYPE . FN), where NAME is the
;;; functional name, TYPE is either FUNCTION or MACRO, and FN is the
;;; function or macro-expansion function, respectively. Entries of
;;; type FUNCTION are made by FLET and LABELS; those of type MACRO
;;; are made by MACROLET.
;;;
;;; Each entry in BENV looks like (NAME NIL), where NAME is the name
;;; of the block. The NIL is there primarily so that two distinct
;;; conses will be present, namely the entry and the cdr of the entry.
;;; These are used internal as catch tags, the first for RETURN and the
;;; second for RESTART. If the NIL has been clobbered to be INVALID,
;;; then the block has been exited, and a return to that block is an error.
;;;
;;; Each entry in GENV looks like (TAG MARKER . BODY), where TAG is
;;; a go tag, MARKER is a unique cons used as a catch tag, and BODY
;;; is the statement sequence that follows the go tag. If the car of
;;; MARKER, normally NIL, has been clobbered to be INVALID, then
;;; the tag body has been exited, and a go to that tag is an error.
;;; An interpreted-lexical-closure contains a function (normally a
;;; lambda-expression) and the lexical environment.
(defstruct interpreted-lexical-closure function venv fenv benv genv)
;;; The EVALHOOK feature allows a user-supplied function to be called
;;; whenever a form is to be evaluated. The presence of the lexical
;;; environment requires an extension of the feature as it is defined
;;; in MacLISP. Here, the user hook function must accept not only
;;; the form to be evaluated, but also the components of the lexical
;;; environment; these must then be passed verbatim to EVALHOOK or
;;; *EVAL in order to perform the evaluation of the form correctly.
;;; The precise number of components should perhaps be allowed to be
;;; implementation-dependent, so it is probably best to require the
;;; user hook function to accept arguments as (FORM &REST ENV) and
;;; then to perform evaluation by (APPLY #'EVALHOOK FORM HOOKFN ENV),
;;; for example.
(defvar evalhook nil)
(defun evalhook (exp hookfn venv fenv benv genv)
(let ((evalhook hookfn)) (%eval exp venv fenv benv genv)))
(defun eval (exp)
(*eval exp nil nil nil nil))
;;; *EVAL looks useless here, but does more complex things
;;; in alternative implementations of this evaluator.
(defun *eval (exp venv fenv benv genv)
(%eval exp venv fenv benv genv))
!
;;; Function names beginning with "%" are intended to be internal
;;; and not defined in the Common LISP white pages.
;;; %EVAL is the main evaluation function.
(defun %eval (exp venv fenv benv genv)
(if (not (null evalhook))
(let ((hookfn evalhook) (evalhook nil))
(funcall hookfn exp venv fenv benv genv))
(typecase exp
;; A symbol is first looked up in the lexical variable environment.
(symbol (let ((slot (assoc exp venv)))
(cond ((and (not (null slot)) (not (null (cdr slot))))
(cadr slot))
((boundp exp) (symbol-value exp))
(t (cerror :unbound-variable
"The symbol ~S has no value"
exp)))))
;; Numbers, string, and characters self-evaluate.
((or number string character) exp)
;; Conses require elaborate treatment based on the car.
(cons (typecase (car exp)
;; A symbol is first looked up in the lexical function environment.
;; This lookup is cheap if the environment is empty, a common case.
(symbol
(let ((fn (car exp)))
(loop (let ((slot (assoc fn fenv)))
(unless (null slot)
(return (case (cadr slot)
(macro (%eval (%macroexpand
(cddr slot)
(if (eq fn (car exp))
exp
(cons fn (cdr exp))))))
(function (%apply (cddr slot)
(%evlis (cdr exp) venv fenv benv genv)))
(t <implementation-error>)))))
;; If not in lexical function environment,
;; try the definition cell of the symbol.
(when (fboundp fn)
(return (cond ((special-form-p fn)
(%invoke-special-form
fn (cdr exp) venv fenv benv genv))
((macro-p fn)
(%eval (%macroexpand
(get-macro-function (symbol-function fn))
(if (eq fn (car exp))
exp
(cons fn (cdr exp))))
venv fenv benv genv))
(t (%apply (symbol-function fn)
(%evlis (cdr exp) venv fenv benv genv))))))
(setq fn
(cerror :undefined-function
"The symbol ~S has no function definition"
fn))
(unless (symbolp fn)
(return (%apply fn (%evlis (cdr exp) venv fenv benv genv)))))))
;; A cons in function position must be a lambda-expression.
;; Note that the construction of a lexical closure is avoided here.
(cons (%lambda-apply (car exp) venv fenv benv genv
(%evlis (cdr exp) venv fenv benv genv)))
(t (%eval (cerror :invalid-form
"Cannot evaluate the form ~S: function position has invalid type ~S"
exp (type-of (car exp)))
venv fenv benv genv))))
(t (%eval (cerror :invalid-form
"Cannot evaluate the form ~S: invalid type ~S"
exp (type-of exp))
venv fenv benv genv)))))
!
;;; Given a list of forms, evaluate each and return a list of results.
(defun %evlis (forms venv fenv benv genv)
(mapcar #'(lambda (form) (%eval form venv fenv benv genv)) forms))
;;; Given a list of forms, evaluate each, discarding the results of
;;; all but the last, and returning all results from the last.
(defun %evprogn (body venv fenv benv genv)
(if (endp body) nil
(do ((b body (cdr b)))
((endp (cdr b))
(%eval (car b) venv fenv benv genv))
(%eval (car b) venv fenv benv genv))))
;;; APPLY takes a function, a number of single arguments, and finally
;;; a list of all remaining arguments. The following song and dance
;;; attempts to construct efficiently a list of all the arguments.
(defun apply (fn firstarg &rest args*)
(%apply fn
(cond ((null args*) firstarg)
((null (cdr args*)) (cons firstarg (car args*)))
(t (do ((x args* (cdr x))
(z (cddr args*) (cdr z)))
((null z)
(rplacd x (cadr x))
(cons firstarg (car args*))))))))
!
;;; %APPLY does the real work of applying a function to a list of arguments.
(defun %apply (fn args)
(typecase fn
;; For closures over dynamic variables, complex magic is required.
(closure (with-closure-bindings-in-effect fn
(%apply (closure-function fn) args)))
;; For a compiled function, an implementation-dependent "spread"
;; operation and invocation is required.
(compiled-function (%invoke-compiled-function fn args))
;; The same goes for a compiled closure over lexical variables.
(compiled-lexical-closure (%invoke-compiled-lexical-closure fn args))
;; The treatment of interpreted lexical closures is elucidated fully here.
(interpreted-lexical-closure
(%lambda-apply (interpreted-lexical-closure-function fn)
(interpreted-lexical-closure-venv fn)
(interpreted-lexical-closure-fenv fn)
(interpreted-lexical-closure-benv fn)
(interpreted-lexical-closure-genv fn)
args))
;; For a symbol, the function definition is used, if it is a function.
(symbol (%apply (cond ((not (fboundp fn))
(cerror :undefined-function
"The symbol ~S has no function definition"
fn))
((special-form-p fn)
(cerror :invalid-function
"The symbol ~S cannot be applied: it names a special form"
fn))
((macro-p fn)
(cerror :invalid-function
"The symbol ~S cannot be applied: it names a macro"
fn))
(t (symbol-function fn)))
args))
;; Applying a raw lambda-expression uses the null lexical environment.
(cons (if (eq (car fn) 'lambda)
(%lambda-apply fn nil nil nil nil args)
(%apply (cerror :invalid-function
"~S is not a valid function"
fn)
args)))
(t (%apply (cerror :invalid function
"~S has an invalid type ~S for a function"
fn (type-of fn))
args))))
!
;;; %LAMBDA-APPLY is the hairy part, that takes care of applying
;;; a lambda-expression in a given lexical environment to given
;;; arguments. The complexity arises primarily from the processing
;;; of the parameter list.
;;;
;;; If at any point the lambda-expression is found to be malformed
;;; (typically because of an invalid parameter list), or if the list
;;; of arguments is not suitable for the lambda-expression, a correctable
;;; error is signalled; correction causes a throw to be performed to
;;; the tag %LAMBDA-APPLY-RETRY, passing back a (possibly new)
;;; lambda-expression and a (possibly new) list of arguments.
;;; The application is then retried. If the new lambda-expression
;;; is not really a lambda-expression, then %APPLY is used instead of
;;; %LAMBDA-APPLY.
;;;
;;; In this evaluator, PROGV is used to instantiate variable bindings
;;; (though its use is embedded with a macro called %BIND-VAR).
;;; The throw that precedes a retry will cause special bindings to
;;; be popped before the retry.
(defun %lambda-apply (lexp venv fenv benv genv args)
(multiple-value-bind (newfn newargs)
(catch '%lambda-apply-retry
(return-from %lambda-apply
(%lambda-apply-1 lexp venv fenv benv genv args)))
(if (and (consp lexp) (eq (car lexp) 'lambda))
(%lambda-apply newfn venv fenv benv genv newargs)
(%apply newfn newargs))))
;;; Calling this function will unwind all special variables
;;; and cause FN to be applied to ARGS in the original lexical
;;; and dynamic environment in force when %LAMBDA-APPLY was called.
(defun %lambda-apply-retry (fn args)
(throw '%lambda-apply-retry (values fn args)))
;;; This function is convenient when the lambda expression is found
;;; to be malformed. REASON should be a string explaining the problem.
(defun %bad-lambda-exp (lexp oldargs reason)
(%lambda-apply-retry
(cerror :invalid-function
"Improperly formed lambda-expression ~S: ~A"
lexp reason)
oldargs))
;;; (%BIND-VAR VAR VALUE . BODY) evaluates VAR to produce a symbol name
;;; and VALUE to produce a value. If VAR is determined to have been
;;; declared special (as indicated by the current binding of the variable
;;; SPECIALS, which should be a list of symbols, or by a SPECIAL property),
;;; then a special binding is established using PROGV. Otherwise an
;;; entry is pushed onto the a-list presumed to be in the variable VENV.
(defmacro %bind-var (var value &body body)
`(let ((var ,var) (value ,value))
(let ((specp (or (member var specials) (get var 'special))))
(progv (and specp (list var)) (and specp (list value))
(push (if specp (list var) (list var value)) venv)
,@body))))
;;; %LAMBDA-KEYWORD-P is true iff X (which must be a symbol)
;;; has a name beginning with an ampersand.
(defun %lambda-keyword-p (x)
(char= #\& (char 0 (symbol-pname x))))
!
;;; %LAMBDA-APPLY-1 is responsible for verifying that LEXP is
;;; a lambda-expression, for extracting a list of all variables
;;; declared SPECIAL in DECLARE forms, and for finding the
;;; body that follows any DECLARE forms.
(defun %lambda-apply-1 (lexp venv fenv benv genv args)
(cond ((or (not (consp lexp))
(not (eq (car lexp) 'lambda))
(atom (cdr lexp))
(not (listp (cadr lexp))))
(%bad-lambda-exp lexp args "improper lambda or lambda-list"))
(t (do ((body (cddr lexp) (cdr body))
(specials '()))
((or (endp body)
(not (listp (car body)))
(not (eq (caar body) 'declare)))
(%bind-required lexp args (cadr lexp) venv fenv benv genv venv args specials body))
(dolist (decl (cdar body))
(when (eq (car decl) 'special)
(setq specials
(if (null specials) ;Avoid consing
(cdar decl)
(append (cdar decl) specials)))))))))
;;; %BIND-REQUIRED handles the pairing of arguments to required parameters.
;;; Error checking is performed for too few or too many arguments.
;;; If a lambda-list keyword is found, %TRY-OPTIONAL is called.
;;; Here, as elsewhere, if the binding process terminates satisfactorily
;;; then the body is evaluated using %EVPROGN in the newly constructed
;;; dynamic and lexical environment.
(defun %bind-required (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((endp varlist)
(if (null args)
(%evprogn body venv fenv benv genv)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args))))
((not (symbolp (car varlist)))
(%bad-lambda-exp lexp oldargs "required parameter name not a symbol"))
((%lambda-keyword-p (car varlist))
(%try-optional lexp oldargs varlist fenv benv genv venv args specials body))
((null args)
(%lambda-apply-retry lexp
(cerror :too-few-arguments
"Too few arguments for function ~S: ~S"
lexp oldargs)))
(t (%bind-var (car varlist) (car args)
(%bind-required lexp oldargs varlist fenv benv genv venv (cdr args) specials body)))))
!
;;; %TRY-OPTIONAL determines whether the lambda-list keyword &OPTIONAL
;;; has been found. If so, optional parameters are processed; if not,
;;; the buck is passed to %TRY-REST.
(defun %try-optional (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((eq (car varlist) '&optional)
(%bind-optional lexp oldargs (cdr varlist) fenv benv genv venv args specials body))
(t (%try-rest lexp oldargs varlist fenv benv genv venv args specials body))))
;;; %BIND-OPTIONAL determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-optional (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((endp varlist)
(if (null args)
(%evprogn body venv fenv benv genv)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args))))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%try-rest lexp oldargs varlist fenv benv genv venv args specials body)
(%process-optional lexp oldargs varlist fenv benv genv
venv args specials body varspec nil nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(or (endp (cddr varspec))
(and (symbolp (caddr varspec))
(not (endp (caddr varspec)))
(endp (cdddr varspec)))))
(%process-optional lexp oldargs varlist fenv benv genv
venv args specials body
(car varspec)
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed optional parameter specifier")))))))
;;; %PROCESS-OPTIONAL takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-optional (lexp oldargs varlist fenv benv genv venv args specials body var init varp)
(let ((value (if (null args) (%eval init venv fenv benv genv) (car args))))
(%bind-var var value
(if varp
(%bind-var varp (not (null args))
(%bind-optional lexp oldargs varlist fenv benv genv venv args specials body))
(%bind-optional lexp oldargs varlist fenv benv genv venv args specials body)))))
!
;;; %TRY-REST determines whether the lambda-list keyword &REST
;;; has been found. If so, the rest parameter is processed;
;;; if not, the buck is passed to %TRY-KEY, after a check for
;;; too many arguments.
(defun %try-rest (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((eq (car varlist) '&rest)
(%bind-rest lexp oldargs (cdr varlist) fenv benv genv venv args specials body))
((and (not (eq (car varlist) '&key))
(not (null args)))
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args)))
(t (%try-key lexp oldargs varlist fenv benv genv venv args specials body))))
;;; %BIND-REST ensures that there is a parameter specifier for
;;; the &REST parameter, binds it, and then evaluates the body or
;;; calls %TRY-KEY.
(defun %bind-rest (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((or (endp varlist)
(not (symbolp (car varlist))))
(%bad-lambda-exp lexp oldargs "missing rest parameter specifier"))
(t (%bind-var (car varlist) args
(cond ((endp (cdr varlist))
(%evprogn body venv fenv benv genv))
((and (symbolp (cadr varlist))
(%lambda-keyword-p (cadr varlist)))
(%try-key lexp oldargs varlist fenv benv genv venv args specials body))
(t (%bad-lambda-exp lexp oldargs "malformed after rest parameter specifier")))))))
!
;;; %TRY-KEY determines whether the lambda-list keyword &KEY
;;; has been found. If so, keyword parameters are processed;
;;; if not, the buck is passed to %TRY-AUX.
(defun %try-key (lexp oldargs varlist fenv benv genv venv args specials body)
(cond ((eq (car varlist) '&key)
(%bind-key lexp oldargs (cdr varlist) fenv benv genv venv args specials body nil))
(t (%try-aux lexp oldargs varlist fenv benv genv venv specials body))))
;;; %BIND-KEY determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-key (lexp oldargs varlist fenv benv genv venv args specials body keys)
(cond ((endp varlist)
;; Optional error check for bad keywords.
(do ((a args (cddr a)))
((endp args))
(unless (member (car a) keys)
(cerror :unexpected-keyword
"Keyword not expected by function ~S: ~S"
lexp (car a))))
(%evprogn body venv fenv benv genv))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(cond ((not (eq varspec '&allow-other-keywords))
(%try-aux lexp oldargs varlist fenv benv genv venv specials body))
((endp (cdr varlist))
(%evprogn body venv fenv benv genv))
((%lambda-keyword-p (cadr varlist))
(%try-aux lexp oldargs (cdr varlist) fenv benv genv venv specials body))
(t (%bad-lambda-exp lexp oldargs "invalid after &ALLOW-OTHER-KEYWORDS")))
(%process-key lexp oldargs varlist fenv benv genv
venv args specials body keys
(intern varspec keyword-package)
varspec nil nil)))
((and (consp varspec)
(or (symbolp (car varspec))
(and (consp (car varspec))
(consp (cdar varspec))
(symbolp (cadar varspec))
(endp (cddar varspec))))
(listp (cdr varspec))
(or (endp (cddr varspec))
(and (symbolp (caddr varspec))
(not (endp (caddr varspec)))
(endp (cdddr varspec)))))
(%process-key lexp oldargs varlist fenv benv genv
venv args specials body keys
(if (consp (car varspec))
(caar varspec)
(intern (car varspec) keyword-package))
(if (consp (car varspec))
(cadar varspec)
(car varspec))
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed keyword parameter specifier")))))))
;;; %PROCESS-KEY takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-key (lexp oldargs varlist fenv benv genv venv args specials body keys kwd var init varp)
(let ((value (do ((a args (cddr a)))
((endp a) (%eval init venv fenv benv genv))
(when (eq (car a) kwd)
(return (cadr a))))))
(%bind-var var value
(if varp
(%bind-var varp (not (null args))
(%bind-key lexp oldargs varlist fenv benv genv venv args specials body (cons kwd keys)))
(%bind-key lexp oldargs varlist fenv benv genv venv args specials body (cons kwd keys))))))
!
;;; %TRY-AUX determines whether the keyword &AUX
;;; has been found. If so, auxiliary variables are processed;
;;; if not, an error is signalled.
(defun %try-aux (lexp oldargs varlist fenv benv genv venv specials body)
(cond ((eq (car varlist) '&aux)
(%bind-aux lexp oldargs (cdr varlist) fenv benv genv venv specials body))
(t (%bad-lambda-exp lexp oldargs "unknown or misplaced lambda-list keyword"))))
;;; %BIND-AUX determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-aux (lexp oldargs varlist fenv benv genv venv specials body)
(cond ((endp varlist)
(%evprogn body venv fenv benv genv))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%bad-lambda-exp lexp oldargs "unknown or misplaced lambda-list keyword")
(%process-aux lexp oldargs varlist fenv benv genv
venv specials body varspec nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(endp (cddr varspec)))
(%process-aux lexp oldargs varlist fenv benv genv
venv specials body
(car varspec)
(cadr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed aux variable specifier")))))))
;;; %PROCESS-AUX takes care of binding the auxiliary variable.
(defun %process-aux (lexp oldargs varlist fenv benv genv venv specials body var init)
(%bind-var var (and init (%eval init venv fenv benv genv))
(%bind-aux lexp oldargs varlist fenv benv genv venv specials body)))
!
;;; Definitions for various special forms and macros.
(defspec quote (obj) (venv fenv benv genv) obj)
(defspec function (fn) (venv fenv benv genv)
(cond ((consp fn)
(cond ((eq (car fn) 'lambda)
(make-interpreted-closure :function fn :venv venv :fenv fenv :benv benv :genv genv))
(t (cerror ???))))
((symbolp fn)
(loop (let ((slot (assoc fn fenv)))
(unless (null slot)
(case (cadr slot)
(macro (cerror ???))
(function (return (cddr slot)))
(t <implementation-error>))))
(when (fboundp fn)
(cond ((or (special-form-p fn) (macro-p fn))
(cerror ???))
(t (return (symbol-function fn)))))
(setq fn (cerror :undefined-function
"The symbol ~S has no function definition"
fn))
(unless (symbolp fn) (return fn))))
(t (cerror ???))))
(defspec if (pred con &optional alt) (venv fenv benv genv)
(if (%eval pred venv fenv benv genv)
(%eval con venv fenv benv genv)
(%eval alt venv fenv benv genv)))
;;; The BLOCK construct provides a PROGN with a named contour around it.
;;; It is interpreted by first putting an entry onto BENV, consisting
;;; of a 2-list of the name and NIL. This provides two unique conses
;;; for use as catch tags. Then the body is executed.
;;; If a RETURN or RESTART is interpreted, a throw occurs. If the BLOCK
;;; construct is exited for any reason (including falling off the end, which
;;; retu rns the results of evaluating the last form in the body), the NIL in
;;; the entry is clobbered to be INVALID, to indicate that that particular
;;; entry is no longer valid for RETURN or RESTART.
(defspec block (name &body body) (venv fenv benv genv)
(let ((slot (list name nil))) ;Use slot for return, (cdr slot) for restart
(unwind-protect
(catch slot
(block exit
(loop (catch (cdr slot)
(return-from exit
(%evprogn body venv fenv (cons slot benv) genv))))))
(rplaca (cdr slot) 'invalid))))
(defspec return (form) (venv fenv benv genv)
(let ((slot (assoc nil benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form venv fenv benv genv))))))
(defspec return-from (name form) (venv fenv benv genv)
(let ((slot (assoc name benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form venv fenv benv genv))))))
(defspec restart (form) (venv fenv benv genv)
(let ((slot (assoc nil benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw (cdr slot) (%eval form venv fenv benv genv))))))
(defspec restart-from (name form) (venv fenv benv genv)
(let ((slot (assoc name benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw (cdr slot) (%eval form venv fenv benv genv))))))
!
(defmacro prog (vars &rest body)
(do ((b body (cdr b))
(decls '() (cons (car b) decls)))
((or (endp b)
(atom (car b))
(not (eq (caar b) 'declare)))
`(let ,vars ,@(nreverse decls) (block nil (tagbody ,@b))))))
;;; The TAGBODY construct provides a body with GO tags in it.
;;; It is interpreted by first putting one entry onto GENV for
;;; every tag in the body; doing this ahead of time saves searching
;;; at GO time. A unique cons whose car is NIL is constructed for
;;; use as a unique catch tag. Then the body is executed.
;;; If a GO is interpreted, a throw occurs, sending as the thrown
;;; value the point in the body after the relevant tag.
;;; If the TAGBODY construct is exited for any reason (including
;;; falling off the end, which produces the value NIL), the car of
;;; the unique marker is clobbered to be INVALID, to indicate that
;;; tags associated with that marker are no longer valid.
(defspec tagbody (&rest body) (venv fenv benv genv)
(do ((b body (cdr b))
(marker (list nil)))
((endp p)
(block exit
(unwind-protect
(loop (setq body
(catch marker
(do ((b body (cdr b)))
((endp b) (return-from exit nil))
(unless (atom (car b))
(%eval (car b) venv fenv benv genv))))))
(rplaca marker 'invalid))))
(when (atom (car b))
(push (list* (car b) marker (cdr b)) genv))))
(defspec go (tag) (venv fenv benv genv)
(let ((slot (assoc tag genv)))
(cond ((null slot) (ferror ???<unseen-go-tag>))
((eq (caadr slot) 'invalid) (ferror ???<go-tag-no-longer-valid>))
(t (throw (cadr slot) (cddr slot))))))
-----------------------------------------------------------
;;; This version uses some special variables to avoid passing stuff around.
;;; This evaluator splits the lexical environment into four
;;; logically distinct entities:
;;; VENV = lexical variable environment
;;; FENV = lexical function and macro environment
;;; BENV = block name environment
;;; GENV = go tag environment
;;; Each environment is an a-list. It is never the case that
;;; one can grow and another shrink simultaneously; the four
;;; parts could be united into a single a-list. The four-part
;;; division saves consing and search time.
;;;
;;; In this implementation, the four environment parts are normally
;;; kept in four special variables %VENV%, %FENV%, %BENV%, and %GENV%.
;;; (These are internal to the implementation, and are not meant to
;;; be user-accessible.)
(defvar %venv% nil)
(defvar %fenv% nil)
(defvar %benv% nil)
(defvar %genv% nil)
;;; Each entry in VENV has one of two forms: (VAR VALUE) or (VAR).
;;; The first indicates a lexical binding of VAR to VALUE, and the
;;; second indicates a special binding of VAR (implying that the
;;; special value should be used).
;;;
;;; Each entry in FENV looks like (NAME TYPE . FN), where NAME is the
;;; functional name, TYPE is either FUNCTION or MACRO, and FN is the
;;; function or macro-expansion function, respectively. Entries of
;;; type FUNCTION are made by FLET and LABELS; those of type MACRO
;;; are made by MACROLET.
;;;
;;; Each entry in BENV looks like (NAME NIL), where NAME is the name
;;; of the block. The NIL is there primarily so that two distinct
;;; conses will be present, namely the entry and the cdr of the entry.
;;; These are used internal as catch tags, the first for RETURN and the
;;; second for RESTART. If the NIL has been clobbered to be INVALID,
;;; then the block has been exited, and a return to that block is an error.
;;;
;;; Each entry in GENV looks like (TAG MARKER . BODY), where TAG is
;;; a go tag, MARKER is a unique cons used as a catch tag, and BODY
;;; is the statement sequence that follows the go tag. If the car of
;;; MARKER, normally NIL, has been clobbered to be INVALID, then
;;; the tag body has been exited, and a go to that tag is an error.
;;; An interpreted-lexical-closure contains a function (normally a
;;; lambda-expression) and the lexical environment.
(defstruct interpreted-lexical-closure function venv fenv benv genv)
;;; The EVALHOOK feature allows a user-supplied function to be called
;;; whenever a form is to be evaluated. The presence of the lexical
;;; environment requires an extension of the feature as it is defined
;;; in MacLISP. Here, the user hook function must accept not only
;;; the form to be evaluated, but also the components of the lexical
;;; environment; these must then be passed verbatim to EVALHOOK or
;;; *EVAL in order to perform the evaluation of the form correctly.
;;; The precise number of components should perhaps be allowed to be
;;; implementation-dependent, so it is probably best to require the
;;; user hook function to accept arguments as (FORM &REST ENV) and
;;; then to perform evaluation by (APPLY #'EVALHOOK FORM HOOKFN ENV),
;;; for example.
(defvar evalhook nil)
(defun evalhook (exp hookfn %venv% %fenv% %benv% %genv%)
(let ((evalhook hookfn))
(%eval exp)))
(defun eval (exp)
(*eval exp nil nil nil nil))
(defun *eval (exp %venv% %fenv% %benv% %genv%)
(%eval exp))
!
;;; Function names beginning with "%" are intended to be internal
;;; and not defined in the Common LISP white pages.
;;; %EVAL is the main evaluation function. It evaluates EXP in
;;; the current lexical environment, assumed to be in %VENV%, etc.
(defun %eval (exp)
(if (not (null evalhook))
(let ((hookfn evalhook) (evalhook nil))
(funcall hookfn exp %venv% %fenv% %benv% %genv%))
(typecase exp
;; A symbol is first looked up in the lexical variable environment.
(symbol (let ((slot (assoc exp %venv%)))
(cond ((and (not (null slot)) (not (null (cdr slot))))
(cadr slot))
((boundp exp) (symbol-value exp))
(t (cerror :unbound-variable
"The symbol ~S has no value"
exp)))))
;; Numbers, string, and characters self-evaluate.
((or number string character) exp)
;; Conses require elaborate treatment based on the car.
(cons (typecase (car exp)
;; A symbol is first looked up in the lexical function environment.
;; This lookup is cheap if the environment is empty, a common case.
(symbol
(let ((fn (car exp)))
(loop (let ((slot (assoc fn %fenv%)))
(unless (null slot)
(return (case (cadr slot)
(macro (%eval (%macroexpand
(cddr slot)
(if (eq fn (car exp))
exp
(cons fn (cdr exp))))))
(function (%apply (cddr slot)
(%evlis (cdr exp))))
(t <implementation-error>)))))
;; If not in lexical function environment,
;; try the definition cell of the symbol.
(when (fboundp fn)
(return (cond ((special-form-p fn)
(%invoke-special-form fn (cdr exp)))
((macro-p fn)
(%eval (%macroexpand
(get-macro-function (symbol-function fn))
(if (eq fn (car exp))
exp
(cons fn (cdr exp))))))
(t (%apply (symbol-function fn)
(%evlis (cdr exp)))))))
(setq fn
(cerror :undefined-function
"The symbol ~S has no function definition"
fn))
(unless (symbolp fn)
(return (%apply fn (%evlis (cdr exp))))))))
;; A cons in function position must be a lambda-expression.
;; Note that the construction of a lexical closure is avoided here.
(cons (%lambda-apply (car exp) (%evlis (cdr exp))))
(t (%eval (cerror :invalid-form
"Cannot evaluate the form ~S: function position has invalid type ~S"
exp (type-of (car exp)))))))
(t (%eval (cerror :invalid-form
"Cannot evaluate the form ~S: invalid type ~S"
exp (type-of exp)))))))
!
;;; Given a list of forms, evaluate each and return a list of results.
(defun %evlis (forms)
(mapcar #'(lambda (form) (%eval form)) forms))
;;; Given a list of forms, evaluate each, discarding the results of
;;; all but the last, and returning all results from the last.
(defun %evprogn (body)
(if (endp body) nil
(do ((b body (cdr b)))
((endp (cdr b))
(%eval (car b)))
(%eval (car b)))))
;;; APPLY takes a function, a number of single arguments, and finally
;;; a list of all remaining arguments. The following song and dance
;;; attempts to construct efficiently a list of all the arguments.
(defun apply (fn firstarg &rest args*)
(%apply fn
(cond ((null args*) firstarg)
((null (cdr args*)) (cons firstarg (car args*)))
(t (do ((x args* (cdr x))
(z (cddr args*) (cdr z)))
((null z)
(rplacd x (cadr x))
(cons firstarg (car args*))))))))
!
;;; %APPLY does the real work of applying a function to a list of arguments.
(defun %apply (fn args)
(typecase fn
;; For closures over dynamic variables, complex magic is required.
(closure (with-closure-bindings-in-effect fn
(%apply (closure-function fn) args)))
;; For a compiled function, an implementation-dependent "spread"
;; operation and invocation is required.
(compiled-function (%invoke-compiled-function fn args))
;; The same goes for a compiled closure over lexical variables.
(compiled-lexical-closure (%invoke-compiled-lexical-closure fn args))
;; The treatment of interpreted lexical closures is elucidated fully here.
(interpreted-lexical-closure
(let ((%venv% (interpreted-lexical-closure-venv fn))
(%fenv% (interpreted-lexical-closure-fenv fn))
(%benv% (interpreted-lexical-closure-benv fn))
(%genv% (interpreted-lexical-closure-genv fn)))
(%lambda-apply (interpreted-lexical-closure-function fn) args)))
;; For a symbol, the function definition is used, if it is a function.
(symbol (%apply (cond ((not (fboundp fn))
(cerror :undefined-function
"The symbol ~S has no function definition"
fn))
((special-form-p fn)
(cerror :invalid-function
"The symbol ~S cannot be applied: it names a special form"
fn))
((macro-p fn)
(cerror :invalid-function
"The symbol ~S cannot be applied: it names a macro"
fn))
(t (symbol-function fn)))
args))
;; Applying a raw lambda-expression uses the null lexical environment.
(cons (if (eq (car fn) 'lambda)
(let ((%venv% nil) (%fenv% nil) (%benv% nil) (%genv% nil))
(%lambda-apply fn args))
(%apply (cerror :invalid-function
"~S is not a valid function"
fn)
args)))
(t (%apply (cerror :invalid function
"~S has an invalid type ~S for a function"
fn (type-of fn))
args))))
!
;;; %LAMBDA-APPLY is the hairy part, that takes care of applying
;;; a lambda-expression in a given lexical environment to given
;;; arguments. The complexity arises primarily from the processing
;;; of the parameter list.
;;;
;;; If at any point the lambda-expression is found to be malformed
;;; (typically because of an invalid parameter list), or if the list
;;; of arguments is not suitable for the lambda-expression, a correctable
;;; error is signalled; correction causes a throw to be performed to
;;; the tag %LAMBDA-APPLY-RETRY, passing back a (possibly new)
;;; lambda-expression and a (possibly new) list of arguments.
;;; The application is then retried. If the new lambda-expression
;;; is not really a lambda-expression, then %APPLY is used instead of
;;; %LAMBDA-APPLY.
;;;
;;; In this evaluator, PROGV is used to instantiate variable bindings
;;; (though its use is embedded with a macro called %BIND-VAR).
;;; The throw that precedes a retry will cause special bindings to
;;; be popped before the retry.
(defun %lambda-apply (lexp args)
(multiple-value-bind (newfn newargs)
(catch '%lambda-apply-retry
(return-from %lambda-apply
(let ((%venv% %venv%))
(%lambda-apply-1 lexp args))))
(if (and (consp lexp) (eq (car lexp) 'lambda))
(%lambda-apply newfn newargs)
(%apply newfn newargs))))
;;; Calling this function will unwind all special variables
;;; and cause FN to be applied to ARGS in the original lexical
;;; and dynamic environment in force when %LAMBDA-APPLY was called.
(defun %lambda-apply-retry (fn args)
(throw '%lambda-apply-retry (values fn args)))
;;; This function is convenient when the lambda expression is found
;;; to be malformed. REASON should be a string explaining the problem.
(defun %bad-lambda-exp (lexp oldargs reason)
(%lambda-apply-retry
(cerror :invalid-function
"Improperly formed lambda-expression ~S: ~A"
lexp reason)
oldargs))
;;; (%BIND-VAR VAR VALUE . BODY) evaluates VAR to produce a symbol name
;;; and VALUE to produce a value. If VAR is determined to have been
;;; declared special (as indicated by the current binding of the variable
;;; SPECIALS, which should be a list of symbols, or by a SPECIAL property),
;;; then a special binding is established using PROGV. Otherwise an
;;; entry is pushed onto the a-list presumed to be in the variable VENV.
(defmacro %bind-var (var value &body body)
`(let ((var ,var) (value ,value))
(let ((specp (or (member var specials) (get var 'special))))
(progv (and specp (list var)) (and specp (list value))
(push (if specp (list var) (list var value)) %venv%)
,@body))))
;;; %LAMBDA-KEYWORD-P is true iff X (which must be a symbol)
;;; has a name beginning with an ampersand.
(defun %lambda-keyword-p (x)
(char= #\& (char 0 (symbol-pname x))))
!
;;; %LAMBDA-APPLY-1 is responsible for verifying that LEXP is
;;; a lambda-expression, for extracting a list of all variables
;;; declared SPECIAL in DECLARE forms, and for finding the
;;; body that follows any DECLARE forms.
(defun %lambda-apply-1 (lexp args)
(cond ((or (not (consp lexp))
(not (eq (car lexp) 'lambda))
(atom (cdr lexp))
(not (listp (cadr lexp))))
(%bad-lambda-exp lexp args "improper lambda or lambda-list"))
(t (do ((body (cddr lexp) (cdr body))
(specials '()))
((or (endp body)
(not (listp (car body)))
(not (eq (caar body) 'declare)))
(%bind-required lexp args (cadr lexp) args specials body))
(dolist (decl (cdar body))
(when (eq (car decl) 'special)
(setq specials
(if (null specials) ;Avoid consing
(cdar decl)
(append (cdar decl) specials)))))))))
;;; %BIND-REQUIRED handles the pairing of arguments to required parameters.
;;; Error checking is performed for too few or too many arguments.
;;; If a lambda-list keyword is found, %TRY-OPTIONAL is called.
;;; Here, as elsewhere, if the binding process terminates satisfactorily
;;; then the body is evaluated using %EVPROGN in the newly constructed
;;; dynamic and lexical environment.
(defun %bind-required (lexp oldargs varlist args specials body)
(cond ((endp varlist)
(if (null args)
(%evprogn body)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args))))
((not (symbolp (car varlist)))
(%bad-lambda-exp lexp oldargs "required parameter name not a symbol"))
((%lambda-keyword-p (car varlist))
(%try-optional lexp oldargs varlist args specials body))
((null args)
(%lambda-apply-retry lexp
(cerror :too-few-arguments
"Too few arguments for function ~S: ~S"
lexp oldargs)))
(t (%bind-var (car varlist) (car args)
(%bind-required lexp oldargs varlist (cdr args) specials body)))))
!
;;; %TRY-OPTIONAL determines whether the lambda-list keyword &OPTIONAL
;;; has been found. If so, optional parameters are processed; if not,
;;; the buck is passed to %TRY-REST.
(defun %try-optional (lexp oldargs varlist args specials body)
(cond ((eq (car varlist) '&optional)
(%bind-optional lexp oldargs (cdr varlist) args specials body))
(t (%try-rest lexp oldargs varlist args specials body))))
;;; %BIND-OPTIONAL determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-optional (lexp oldargs varlist args specials body)
(cond ((endp varlist)
(if (null args)
(%evprogn body)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args))))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%try-rest lexp oldargs varlist args specials body)
(%process-optional lexp oldargs varlist args specials body varspec nil nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(or (endp (cddr varspec))
(and (symbolp (caddr varspec))
(not (endp (caddr varspec)))
(endp (cdddr varspec)))))
(%process-optional lexp oldargs varlist args specials body
(car varspec)
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed optional parameter specifier")))))))
;;; %PROCESS-OPTIONAL takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-optional (lexp oldargs varlist args specials body var init varp)
(let ((value (if (null args) (%eval init) (car args))))
(%bind-var var value
(if varp
(%bind-var varp (not (null args))
(%bind-optional lexp oldargs varlist args specials body))
(%bind-optional lexp oldargs varlist args specials body)))))
!
;;; %TRY-REST determines whether the lambda-list keyword &REST
;;; has been found. If so, the rest parameter is processed;
;;; if not, the buck is passed to %TRY-KEY, after a check for
;;; too many arguments.
(defun %try-rest (lexp oldargs varlist args specials body)
(cond ((eq (car varlist) '&rest)
(%bind-rest lexp oldargs (cdr varlist) args specials body))
((and (not (eq (car varlist) '&key))
(not (null args)))
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp args)))
(t (%try-key lexp oldargs varlist args specials body))))
;;; %BIND-REST ensures that there is a parameter specifier for
;;; the &REST parameter, binds it, and then evaluates the body or
;;; calls %TRY-KEY.
(defun %bind-rest (lexp oldargs varlist args specials body)
(cond ((or (endp varlist)
(not (symbolp (car varlist))))
(%bad-lambda-exp lexp oldargs "missing rest parameter specifier"))
(t (%bind-var (car varlist) args
(cond ((endp (cdr varlist))
(%evprogn body))
((and (symbolp (cadr varlist))
(%lambda-keyword-p (cadr varlist)))
(%try-key lexp oldargs varlist args specials body))
(t (%bad-lambda-exp lexp oldargs "malformed after rest parameter specifier")))))))
!
;;; %TRY-KEY determines whether the lambda-list keyword &KEY
;;; has been found. If so, keyword parameters are processed;
;;; if not, the buck is passed to %TRY-AUX.
(defun %try-key (lexp oldargs varlist args specials body)
(cond ((eq (car varlist) '&key)
(%bind-key lexp oldargs (cdr varlist) args specials body nil))
(t (%try-aux lexp oldargs varlist specials body))))
;;; %BIND-KEY determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-key (lexp oldargs varlist args specials body keys)
(cond ((endp varlist)
;; Optional error check for bad keywords.
(do ((a args (cddr a)))
((endp args))
(unless (member (car a) keys)
(cerror :unexpected-keyword
"Keyword not expected by function ~S: ~S"
lexp (car a))))
(%evprogn body))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(cond ((not (eq varspec '&allow-other-keywords))
(%try-aux lexp oldargs varlist specials body))
((endp (cdr varlist))
(%evprogn body))
((%lambda-keyword-p (cadr varlist))
(%try-aux lexp oldargs (cdr varlist) specials body))
(t (%bad-lambda-exp lexp oldargs "invalid after &ALLOW-OTHER-KEYWORDS")))
(%process-key lexp oldargs varlist args specials body keys
(intern varspec keyword-package)
varspec nil nil)))
((and (consp varspec)
(or (symbolp (car varspec))
(and (consp (car varspec))
(consp (cdar varspec))
(symbolp (cadar varspec))
(endp (cddar varspec))))
(listp (cdr varspec))
(or (endp (cddr varspec))
(and (symbolp (caddr varspec))
(not (endp (caddr varspec)))
(endp (cdddr varspec)))))
(%process-key lexp oldargs varlist args specials body keys
(if (consp (car varspec))
(caar varspec)
(intern (car varspec) keyword-package))
(if (consp (car varspec))
(cadar varspec)
(car varspec))
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed keyword parameter specifier")))))))
;;; %PROCESS-KEY takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-key (lexp oldargs varlist args specials body keys kwd var init varp)
(let ((value (do ((a args (cddr a)))
((endp a) (%eval init))
(when (eq (car a) kwd)
(return (cadr a))))))
(%bind-var var value
(if varp
(%bind-var varp (not (null args))
(%bind-key lexp oldargs varlist args specials body (cons kwd keys)))
(%bind-key lexp oldargs varlist args specials body (cons kwd keys))))))
!
;;; %TRY-AUX determines whether the keyword &AUX
;;; has been found. If so, auxiliary variables are processed;
;;; if not, an error is signalled.
(defun %try-aux (lexp oldargs varlist specials body)
(cond ((eq (car varlist) '&aux)
(%bind-aux lexp oldargs (cdr varlist) specials body))
(t (%bad-lambda-exp lexp oldargs "unknown or misplaced lambda-list keyword"))))
;;; %BIND-AUX determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-aux (lexp oldargs varlist specials body)
(cond ((endp varlist)
(%evprogn body))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%bad-lambda-exp lexp oldargs "unknown or misplaced lambda-list keyword")
(%process-aux lexp oldargs varlist specials body varspec nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(endp (cddr varspec)))
(%process-aux lexp oldargs varlist specials body
(car varspec)
(cadr varspec)))
(t (%bad-lambda-exp lexp oldargs "malformed aux variable specifier")))))))
;;; %PROCESS-AUX takes care of binding the auxiliary variable.
(defun %process-aux (lexp oldargs varlist specials body var init)
(%bind-var var (and init (%eval init))
(%bind-aux lexp oldargs varlist specials body)))
!
;;; Definitions for various special forms and macros.
(defspec quote (obj) obj)
(defspec function (fn)
(cond ((consp fn)
(cond ((eq (car fn) 'lambda)
(make-interpreted-closure :function fn :venv %venv% :fenv %fenv% :benv %benv% :genv %genv%))
(t (cerror ???))))
((symbolp fn)
(loop (let ((slot (assoc fn %fenv%)))
(unless (null slot)
(case (cadr slot)
(macro (cerror ???))
(function (return (cddr slot)))
(t <implementation-error>))))
(when (fboundp fn)
(cond ((or (special-form-p fn) (macro-p fn))
(cerror ???))
(t (return (symbol-function fn)))))
(setq fn (cerror :undefined-function
"The symbol ~S has no function definition"
fn))
(unless (symbolp fn) (return fn))))
(t (cerror ???))))
(defspec if (pred con &optional alt)
(if (%eval pred) (%eval con) (%eval alt)))
;;; The BLOCK construct provides a PROGN with a named contour around it.
;;; It is interpreted by first putting an entry onto BENV, consisting
;;; of a 2-list of the name and NIL. This provides two unique conses
;;; for use as catch tags. Then the body is executed.
;;; If a RETURN or RESTART is interpreted, a throw occurs. If the BLOCK
;;; construct is exited for any reason (including falling off the end, which
;;; retu rns the results of evaluating the last form in the body), the NIL in
;;; the entry is clobbered to be INVALID, to indicate that that particular
;;; entry is no longer valid for RETURN or RESTART.
(defspec block (name &body body)
(let ((slot (list name nil))) ;Use slot for return, (cdr slot) for restart
(unwind-protect
(catch slot
(block exit
(loop (catch (cdr slot)
(return-from exit
(let ((%benv% (cons slot %benv%)))
(%evprogn body)))))))
(rplaca (cdr slot) 'invalid))))
(defspec return (form)
(let ((slot (assoc nil %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form))))))
(defspec return-from (name form)
(let ((slot (assoc name %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form))))))
(defspec restart (form)
(let ((slot (assoc nil %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw (cdr slot) (%eval form))))))
(defspec restart-from (name form)
(let ((slot (assoc name %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cadr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw (cdr slot) (%eval form))))))
!
(defmacro prog (vars &rest body)
(do ((b body (cdr b))
(decls '() (cons (car b) decls)))
((or (endp b)
(atom (car b))
(not (eq (caar b) 'declare)))
`(let ,vars ,@(nreverse decls) (block nil (tagbody ,@b))))))
;;; The TAGBODY construct provides a body with GO tags in it.
;;; It is interpreted by first putting one entry onto GENV for
;;; every tag in the body; doing this ahead of time saves searching
;;; at GO time. A unique cons whose car is NIL is constructed for
;;; use as a unique catch tag. Then the body is executed.
;;; If a GO is interpreted, a throw occurs, sending as the thrown
;;; value the point in the body after the relevant tag.
;;; If the TAGBODY construct is exited for any reason (including
;;; falling off the end, which produces the value NIL), the car of
;;; the unique marker is clobbered to be INVALID, to indicate that
;;; tags associated with that marker are no longer valid.
(defspec tagbody (&rest body)
(let ((%genv% %genv%))
(do ((b body (cdr b))
(marker (list nil)))
((endp p)
(block exit
(unwind-protect
(loop (setq body
(catch marker
(do ((b body (cdr b)))
((endp b) (return-from exit nil))
(unless (atom (car b))
(%eval (car b)))))))
(rplaca marker 'invalid))))
(when (atom (car b))
(push (list* (car b) marker (cdr b)) %genv%)))))
(defspec go (tag)
(let ((slot (assoc tag %genv%)))
(cond ((null slot) (ferror ???<unseen-go-tag>))
((eq (caadr slot) 'invalid) (ferror ???<go-tag-no-longer-valid>))
(t (throw (cadr slot) (cddr slot))))))
-------