[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Revised evaluators
- To: common-lisp at SU-AI
- Subject: Revised evaluators
- From: STEELE at CMU-20C
- Date: Sat, 13 Nov 1982 04:54:00 -0000
The enclosed two revised evaluators include changes for the following
bugs noted by Bawden:
(1) EVALHOOK was incorrectly hooking on the given form; it should only
hook on subforms. To this end %EVAL was split into two parts %EVAL
and %EVAL1.
(2) Two ocurrences of LEXP in%LAMBDA-APPLY-1 should have been NEWFN.
(3) The PROG macro was failing to call MACROEXPAND when looking for
declarations.
Also, %VARBIND and %LAMBDA-APPLY-1 were changed, and a new function
%ADD-SPECIALS introduced, to fix a bug in the handling of SPECIAL
declarations. One wants
(DEFUN BLAG (X)
(DECLARE (SPECIAL *BARF*))
...)
to cause *BARF* to be special in the body of BLAG even though BLAG does
not bind *BARF*. The new evaluators should fix this problem.
--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), where NAME is the name
;;; of the block. The cons cell that is the entry is used as a
;;; catch tag for implementing RETURN-FROM. If the entry has been
;;; clobbered to look like (NAME . 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)) (%eval1 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. It is split into two
;;; parts, with the main part called %EVAL1, for the benefit of EVALHOOK.
(defun %eval (exp venv fenv benv genv)
(if *evalhook*
(let ((hookfn *evalhook*) (*evalhook* nil))
(funcall hookfn exp venv fenv benv genv))
(t (%eval1 exp venv fenv benv genv))))
(defun %eval1 (exp venv fenv benv genv)
(typecase exp
;; A symbol is first looked up in the lexical variable environment.
(symbol (let ((slot (assq exp venv)))
(cond ((and slot (not (null (cdr slot))))
(cadr slot))
((boundp exp) (symbol-value exp))
(t (cerror :unbound-variable
"The symbol ~S has no value"
exp)))))
;; Numbers, strings, bit-vectors, and characters self-evaluate.
((or number string bit-vector 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 (assq 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)
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)
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)
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 (%apply (car exp)
(%evlis (cdr exp) venv fenv benv genv)
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*))))))
nil nil nil nil))
!
;;; %APPLY does the real work of applying a function to a list of arguments.
;;; The environment is passed in because it leads to more natural error
;;; recovery.
(defun %apply (fn args venv fenv benv genv)
(typecase fn
;; 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)
args
(interpreted-lexical-closure-venv fn)
(interpreted-lexical-closure-fenv fn)
(interpreted-lexical-closure-benv fn)
(interpreted-lexical-closure-genv fn)))
;; 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 venv fenv benv genv))
(cons (if (eq (car fn) 'lambda)
(%lambda-apply fn args venv fenv benv genv)
(%apply (cerror :invalid-function
"~S is not a valid function"
fn)
args venv fenv benv genv)))
(t (%apply (cerror :invalid function
"~S has an invalid type ~S for a function"
fn (type-of fn))
args venv fenv benv genv))))
!
;;; %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 %varbind).
;;; The throw that precedes a retry will cause special bindings to
;;; be popped before the retry.
(defun %lambda-apply (lexp args venv fenv benv genv)
(multiple-value-bind (newfn newargs)
(catch '%lambda-apply-retry
(return-from %lambda-apply
(%lambda-apply-1 lexp args venv fenv benv genv)))
(if (and (consp newfn) (eq (car newfn) 'lambda))
(%lambda-apply newfn newargs venv fenv benv genv)
(%apply newfn newargs venv fenv benv genv))))
;;; 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))
;;; (%varbind 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.
;;; The CONSTANTP test ideally is true for any constant symbol;
;;; it should at least check for T, NIL, and keywords.
(defmacro %varbind (var value &body body)
(let ((xvar (gensym)) (xvalue (gensym)))
`(let ((,xvar ,var) (,xvalue ,value))
(loop (when (not (constantp ,xvar)) (return))
(setq ,xvar (cerror :invalid-variable
"~S is a constant and may not be bound"
,xvar)))
(let ((specp (or (memq ,xvar specials) (get ,xvar 'special))))
(progv (and specp (list ,xvar)) (and specp (list ,xvalue))
(unless specp (push (list ,xvar ,xvalue) 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 venv fenv benv genv)
(cond ((or (not (consp lexp))
(not (eq (car lexp) 'lambda))
(atom (cdr lexp))
(not (listp (cadr lexp))))
(%bad-lambda-exp lexp args "improper lambda-expression"))
(t (do ((body (cddr lexp) (cdr body))
(specials '()))
((or (endp body) (not (consp (car body))))
(%bind-required lexp args (cadr lexp)
(%add-specials venv specials)
fenv benv genv args specials nil body))
(let ((form (macroexpand (car body))))
(cond ((or (not (consp form))
(not (eq (car form) 'declare)))
(return (%bind-required lexp args (cadr lexp)
(%add-specials venv specials)
fenv benv genv args specials form body)))
(t (dolist (decl (cdar form))
(when (eq (car decl) 'special)
(setq specials
(if (null specials) ;Avoid consing
(cdar decl)
(append (cdar decl) specials))))))))))))
;;; %ADD-SPECIALS adds entries to VENV to account for SPECIAL declarations.
(defun %add-specials (venv specials)
(do ((s specials (cdr s))
(v venv (cons (list (car s)) v)))
((endp s) v)))
;;; %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 venv fenv benv genv args specials form body)
(cond ((endp varlist)
(if (null args)
(%lambda-evprogn form body venv fenv benv genv)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp oldargs))))
((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 venv fenv benv genv args specials form body))
((null args)
(%lambda-apply-retry lexp
(cerror :too-few-arguments
"Too few arguments for function ~S: ~S"
lexp oldargs)))
(t (%varbind (car varlist) (car args)
(%bind-required lexp oldargs (cdr varlist) venv fenv benv genv (cdr args) specials form 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 venv fenv benv genv args specials form body)
(cond ((eq (car varlist) '&optional)
(%bind-optional lexp oldargs (cdr varlist) venv fenv benv genv args specials form body))
(t (%try-rest lexp oldargs varlist venv fenv benv genv args specials form body))))
;;; %BIND-OPTIONAL determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-optional (lexp oldargs varlist venv fenv benv genv args specials form body)
(cond ((endp varlist)
(if (null args)
(%lambda-evprogn form body venv fenv benv genv)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
lexp oldargs))))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%try-rest lexp oldargs varlist venv fenv benv genv args specials form body)
(%process-optional lexp oldargs varlist venv fenv benv
genv args specials form 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 venv fenv benv
genv args specials form 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 venv fenv benv genv args specials form body var init varp)
(let ((value (if (null args) (%eval init venv fenv benv genv) (car args))))
(%varbind var value
(if varp
(%varbind varp (not (null args))
(%bind-optional lexp oldargs (cdr varlist) venv fenv benv genv (cdr args) specials form body))
(%bind-optional lexp oldargs (cdr varlist) venv fenv benv genv (cdr args) specials form 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 venv fenv benv genv args specials form body)
(cond ((eq (car varlist) '&rest)
(%bind-rest lexp oldargs (cdr varlist) venv fenv benv genv args specials form 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 oldargs)))
(t (%try-key lexp oldargs varlist venv fenv benv genv args specials form 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 venv fenv benv genv args specials form body)
(cond ((or (endp varlist)
(not (symbolp (car varlist))))
(%bad-lambda-exp lexp oldargs "missing rest parameter specifier"))
(t (%varbind (car varlist) args
(cond ((endp (cdr varlist))
(%lambda-evprogn form body venv fenv benv genv))
((and (symbolp (cadr varlist))
(%lambda-keyword-p (cadr varlist)))
(%try-key lexp oldargs (cdr varlist) venv fenv benv genv args specials form 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 venv fenv benv genv args specials form body)
(cond ((eq (car varlist) '&key)
(%bind-key lexp oldargs (cdr varlist) venv fenv benv genv args specials form body nil))
(t (%try-aux lexp oldargs varlist venv fenv benv genv specials form body))))
;;; %BIND-KEY determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-key (lexp oldargs varlist venv fenv benv genv args specials form body keys)
(cond ((endp varlist)
(%check-for-bad-keywords lexp args keys)
(%lambda-evprogn form 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))
(%check-for-bad-keywords lexp args keys)
(%try-aux lexp oldargs varlist venv fenv benv genv specials form body))
((endp (cdr varlist))
(%lambda-evprogn form body venv fenv benv genv))
((%lambda-keyword-p (cadr varlist))
(%try-aux lexp oldargs (cdr varlist) venv fenv benv genv specials form body))
(t (%bad-lambda-exp lexp oldargs "invalid after &ALLOW-OTHER-KEYWORDS")))
(%process-key lexp oldargs varlist venv fenv benv
genv args specials form body keys
(intern (symbol-print-name 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 venv fenv benv
genv args specials form body keys
(if (consp (car varspec))
(caar varspec)
(intern (symbol-print-name (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")))))))
;;; Optional error check for bad keyword arguments.
(defun %check-for-bad-keywords (lexp args keys)
(do ((a args (cddr a)))
((endp args))
(unless (memq (car a) keys)
(cerror :unexpected-keyword
"Keyword not expected by function ~S: ~S"
lexp (car a)))))
;;; %PROCESS-KEY takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-key (lexp oldargs varlist venv fenv benv genv args specials form body keys kwd var init varp)
(do ((a args (cddr a)))
((endp a)
(%process-key-1 lexp oldargs varlist venv fenv benv genv args specials
form body keys kwd var init varp
(%eval init venv fenv benv genv) nil))
(when (eq (car a) kwd)
(return (%process-key-1 lexp oldargs varlist venv fenv benv genv args specials
form body keys kwd var init varp
(cadr a) t)))))
(defun %process-key-1 (lexp oldargs varlist venv fenv benv genv args specials form body keys kwd var init varp value suppliedp)
(%varbind var value
(if varp
(%varbind varp suppliedp
(%bind-key lexp oldargs varlist venv fenv benv genv args specials form body (cons kwd keys)))
(%bind-key lexp oldargs varlist venv fenv benv genv args specials form 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 venv fenv benv genv specials form body)
(cond ((eq (car varlist) '&aux)
(%bind-aux lexp oldargs (cdr varlist) venv fenv benv genv specials form 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 venv fenv benv genv specials form body)
(cond ((endp varlist)
(%lambda-evprogn form 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 venv fenv benv
genv specials form body varspec nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(endp (cddr varspec)))
(%process-aux lexp oldargs varlist venv fenv benv
genv specials form 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 venv fenv benv genv specials form body var init)
(%varbind var (and init (%eval init venv fenv benv genv))
(%bind-aux lexp oldargs varlist venv fenv benv genv specials form body)))
(defun %lambda-evprogn (form body venv fenv benv genv)
(unless (null form) (%eval form venv fenv benv genv))
(%evprogn body venv fenv benv genv))
!
;;; Definitions for various special forms and macros.
(defspec quote (obj) (venv fenv benv genv) obj)
(defspec function (fn) (venv fenv benv genv)
(loop (cond ((consp fn)
(cond ((eq (car fn) 'lambda)
(return (make-interpreted-closure :function fn
:venv venv
:fenv fenv
:benv benv
:genv genv)))
(t (setq fn (cerror :invalid-function
"~S is not a valid argument for FUNCTION"
fn)))))
((symbolp fn)
(let ((slot (assq fn fenv)))
(cond (slot
(case (cadr slot)
(macro (setq fn (cerror :invalid-function
"The name ~S is invalid for FUNCTION: it names a macro"
fn)))
(function (return (cddr slot)))
(t <implementation-error>)))
((fboundp fn)
(cond ((special-form-p fn)
(setq fn (cerror :invalid-function
"The symbol ~S is invalid for FUNCTION: it names a special form"
fn)))
((macro-p fn)
(setq fn (cerror :invalid-function
"The symbol ~S is invalid for FUNCTION: it names a macro"
fn)))
(t (setq fn (symbol-function fn)))))
(t (setq fn (cerror :invalid-function
"The symbol ~S has no function definition"
fn))))))
(t (setq fn (cerror :invalid-function
"~S is not a valid argument for FUNCTION"
fn))))))
(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 1-list of the name. This list cell serves as a catch tag.
;;; Then the body is executed.
;;; If a RETURN-FROM is interpreted, a throw occurs. If the BLOCK
;;; construct is exited for any reason (including falling off the end, which
;;; returns the results of evaluating the last form in the body), the cdr of
;;; the entry is clobbered to be INVALID, to indicate that that particular
;;; entry is no longer valid for RETURN-FROM.
(defspec block (name &body body) (venv fenv benv genv)
(let ((slot (list name)))
(unwind-protect (catch slot
(%evprogn body venv fenv (cons slot benv) genv))
(rplacd slot 'invalid))))
(defspec return (form) (venv fenv benv genv)
(let ((slot (assq nil benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cdr 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 (assq name benv)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cdr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw 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))
(let ((x (macroexpand (car b))))
(or (atom x) (not (eq (car x) '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 (assq 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), where NAME is the name
;;; of the block. The cons cell that is the entry is used as a
;;; catch tag for implementing RETURN-FROM. If the entry has been
;;; clobbered to look like (NAME . 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))
(%eval1 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 is split into two
;;; parts, with the main part called %EVAL1, for the benefit of EVALHOOK.
;;; It evaluates EXP in the current lexical environment, assumed to be
;;; in %VENV%, %FENV%, %BENV%, and %GENV%.
(defun %eval (exp)
(if *evalhook*
(let ((hookfn *evalhook*) (*evalhook* nil))
(funcall hookfn exp %venv% %fenv% %benv% %genv%))
(t (%eval1 exp))))
(defun %eval1 (exp)
(typecase exp
;; A symbol is first looked up in the lexical variable environment.
(symbol (let ((slot (assq exp %venv%)))
(cond ((and slot (not (null (cdr slot))))
(cadr slot))
((boundp exp) (symbol-value exp))
(t (cerror :unbound-variable
"The symbol ~S has no value"
exp)))))
;; Numbers, strings, bit-vectors, and characters self-evaluate.
((or number string bit-vector 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 (assq 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 (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*)
(let ((%venv% nil) (%fenv% nil) (%benv% nil) (%genv% nil))
(%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 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))
(cons (if (eq (car fn) 'lambda)
(%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 %varbind).
;;; 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 newfn) (eq (car newfn) '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)))
(defvar %lexp%)
(defvar %oldargs%)
;;; 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 (reason)
(%lambda-apply-retry
(cerror :invalid-function
"Improperly formed lambda-expression ~S: ~A"
%lexp% reason)
%oldargs%))
;;; (%varbind 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.
;;; The CONSTANTP test ideally is true for any constant symbol;
;;; it should at least check for T, NIL, and keywords.
(defmacro %varbind (var value &body body)
(let ((xvar (gensym)) (xvalue (gensym)))
`(let ((,xvar ,var) (,xvalue ,value))
(loop (when (not (constantp ,xvar)) (return))
(setq ,xvar (cerror :invalid-variable
"~S is a constant and may not be bound"
,xvar)))
(let ((specp (or (memq ,xvar %specials%) (get ,xvar 'special))))
(progv (and specp (list ,xvar)) (and specp (list ,xvalue))
(unless specp (push (list ,xvar ,xvalue) 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.
(defvar %specials%)
(defvar %form%)
(defvar %body%)
(defun %lambda-apply-1 (%lexp% %oldargs%)
(cond ((or (not (consp %lexp%))
(not (eq (car %lexp%) 'lambda))
(atom (cdr %lexp%))
(not (listp (cadr %lexp%))))
(%bad-lambda-exp "improper lambda-expression"))
(t (do ((%body% (cddr %lexp%) (cdr %body%))
(%specials% '()))
((or (endp %body%)
(not (listp (car %body%))))
(let ((%form% nil))
(%add-specials)
(%bind-required (cadr %lexp%) %oldargs%)))
(let ((%form% (macroexpand (car %body%))))
(cond ((or (not (consp %form%))
(not (eq (car %form%) 'declare)))
(%add-specials)
(return (%bind-required (cadr %lexp%) %oldargs%)))
(t (dolist (decl (cdr %form%))
(when (eq (car decl) 'special)
(setq %specials%
(if (null %specials%) ;Avoid consing
(cdar decl)
(append (cdar decl) %specials%))))))))))))
;;; %ADD-SPECIALS adds entries to VENV to account for SPECIAL declarations.
(defun %add-specials ()
(dolist (s %specials%)
(push (list s) %venv%)))
;;; %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 (varlist args)
(cond ((endp varlist)
(if (null args)
(%lambda-evprogn%)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
%lexp% %oldargs%))))
((not (symbolp (car varlist)))
(%bad-lambda-exp "required parameter name not a symbol"))
((%lambda-keyword-p (car varlist))
(%try-optional varlist args))
((null args)
(%lambda-apply-retry lexp
(cerror :too-few-arguments
"Too few arguments for function ~S: ~S"
%lexp% %oldargs%)))
(t (%varbind (car varlist) (car args)
(%bind-required (cdr varlist) (cdr args))))))
!
;;; %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 (varlist args)
(cond ((eq (car varlist) '&optional)
(%bind-optional (cdr varlist) args))
(t (%try-rest varlist args))))
;;; %BIND-OPTIONAL determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-optional (varlist args)
(cond ((endp varlist)
(if (null args)
(%lambda-evprogn%)
(%lambda-apply-retry lexp
(cerror :too-many-arguments
"Too many arguments for function ~S: ~S"
%lexp% %oldargs%))))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%try-rest varlist args)
(%process-optional varlist args 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 varlist args
(car varspec)
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp "malformed optional parameter specifier")))))))
;;; %PROCESS-OPTIONAL takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-optional (varlist args var init varp)
(let ((value (if (null args) (%eval init) (car args))))
(%varbind var value
(if varp
(%varbind varp (not (null args))
(%bind-optional (cdr varlist) (cdr args)))
(%bind-optional (cdr varlist) (cdr args))))))
!
;;; %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 (varlist args)
(cond ((eq (car varlist) '&rest)
(%bind-rest (cdr varlist) args))
((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% %oldargs%)))
(t (%try-key varlist args))))
;;; %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 (varlist args)
(cond ((or (endp varlist)
(not (symbolp (car varlist))))
(%bad-lambda-exp "missing rest parameter specifier"))
(t (%varbind (car varlist) args
(cond ((endp (cdr varlist))
(%lambda-evprogn%))
((and (symbolp (cadr varlist))
(%lambda-keyword-p (cadr varlist)))
(%try-key (cdr varlist) args))
(t (%bad-lambda-exp "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 (varlist args)
(cond ((eq (car varlist) '&key)
(%bind-key (cdr varlist) args nil))
(t (%try-aux varlist))))
;;; %BIND-KEY determines whether the parameter list is exhausted.
;;; If not, it parses the next specifier.
(defun %bind-key (varlist args keys)
(cond ((endp varlist)
(%check-for-bad-keywords args keys)
(%lambda-evprogn%))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(cond ((not (eq varspec '&allow-other-keywords))
(%check-for-bad-keywords args keys)
(%try-aux varlist))
((endp (cdr varlist))
(%lambda-evprogn%))
((%lambda-keyword-p (cadr varlist))
(%try-aux (cdr varlist)))
(t (%bad-lambda-exp "invalid after &ALLOW-OTHER-KEYWORDS")))
(%process-key varlist args keys
(intern (symbol-print-name 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 varlist args keys
(if (consp (car varspec))
(caar varspec)
(intern (symbol-print-name (car varspec)) keyword-package))
(if (consp (car varspec))
(cadar varspec)
(car varspec))
(cadr varspec)
(caddr varspec)))
(t (%bad-lambda-exp "malformed keyword parameter specifier")))))))
;;; Optional error check for bad keywords.
(defun %check-for-bad-keywords (args keys)
(do ((a args (cddr a)))
((endp args))
(unless (memq (car a) keys)
(cerror :unexpected-keyword
"Keyword not expected by function ~S: ~S"
%lexp% (car a)))))
;;; %PROCESS-KEY takes care of binding the parameter,
;;; and also the supplied-p variable, if any.
(defun %process-key (varlist args keys kwd var init varp)
(do ((a args (cddr a)))
((endp a)
(%process-key-1 varlist args keys kwd var init varp (%eval init) nil))
(when (eq (car a) kwd)
(return (%process-key-1 varlist args keys kwd var init varp (cadr a) t)))))
(defun %process-key-1 (varlist args keys kwd var init varp value suppliedp)
(%varbind var value
(if varp
(%varbind varp suppliedp
(%bind-key varlist args (cons kwd keys)))
(%bind-key varlist args (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 (varlist)
(cond ((eq (car varlist) '&aux)
(%bind-aux (cdr varlist)))
(t (%bad-lambda-exp "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 (varlist)
(cond ((endp varlist)
(%lambda-evprogn%))
(t (let ((varspec (car varlist)))
(cond ((symbolp varspec)
(if (%lambda-keyword-p varspec)
(%bad-lambda-exp "unknown or misplaced lambda-list keyword")
(%process-aux varlist varspec nil)))
((and (consp varspec)
(symbolp (car varspec))
(listp (cdr varspec))
(endp (cddr varspec)))
(%process-aux varlist (car varspec) (cadr varspec)))
(t (%bad-lambda-exp "malformed aux variable specifier")))))))
;;; %PROCESS-AUX takes care of binding the auxiliary variable.
(defun %process-aux (varlist var init)
(%varbind var (and init (%eval init))
(%bind-aux varlist)))
(defun %lambda-evprogn ()
(unless (null %form%) (%eval %form%))
(%evprogn %body%))
!
;;; Definitions for various special forms and macros.
(defspec quote (obj) obj)
(defspec function (fn)
(loop (cond ((consp fn)
(cond ((eq (car fn) 'lambda)
(return (make-interpreted-closure :function fn
:venv %venv%
:fenv %fenv%
:benv %benv%
:genv %genv%)))
(t (setq fn (cerror :invalid-function
"~S is not a valid argument for FUNCTION"
fn)))))
((symbolp fn)
(let ((slot (assq fn fenv)))
(cond (slot
(case (cadr slot)
(macro (setq fn (cerror :invalid-function
"The name ~S is invalid for FUNCTION: it names a macro"
fn)))
(function (return (cddr slot)))
(t <implementation-error>)))
((fboundp fn)
(cond ((special-form-p fn)
(setq fn (cerror :invalid-function
"The symbol ~S is invalid for FUNCTION: it names a special form"
fn)))
((macro-p fn)
(setq fn (cerror :invalid-function
"The symbol ~S is invalid for FUNCTION: it names a macro"
fn)))
(t (setq fn (symbol-function fn)))))
(t (setq fn (cerror :invalid-function
"The symbol ~S has no function definition"
fn))))))
(t (setq fn (cerror :invalid-function
"~S is not a valid argument for FUNCTION"
fn))))))
(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 1-list of the name. This list cell serves as a catch tag.
;;; Then the body is executed.
;;; If a RETURN-FROM is interpreted, a throw occurs. If the BLOCK
;;; construct is exited for any reason (including falling off the end, which
;;; returns the results of evaluating the last form in the body), the cdr of
;;; the entry is clobbered to be INVALID, to indicate that that particular
;;; entry is no longer valid for RETURN-FROM.
(defspec block (name &body body)
(let ((slot (list name)))
(unwind-protect (catch slot
(let ((%benv% (cons slot %benv%)))
(%evprogn body)))
(rplaca (cdr slot) 'invalid))))
(defspec return (form)
(let ((slot (assq nil %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cdr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form))))))
(defspec return-from (name form)
(let ((slot (assq name %benv%)))
(cond ((null slot) (ferror ???<unseen-block-name>))
((eq (cdr slot) 'invalid) (ferror ???<block-name-no-longer-valid>))
(t (throw slot (%eval form))))))
!
(defmacro prog (vars &rest body)
(do ((b body (cdr b))
(decls '() (cons (car b) decls)))
((or (endp b)
(atom (car b))
(let ((x (macroexpand (car b))))
(or (atom x) (not (eq (car x) '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 (assq 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))))))
-------