;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10; Lowercase:T -*- ;;; ;;; ;;; VANILLA-INTERPRETER.LISP ;;; ;;; This is a generic bargain-basement Common Lisp interpreter. ;;; ;;; -- Jim Rauen ;;; Functions called from other files: ;;; ;;; EXPAND-DEFMACRO (from K-SYS:K.WARM;DEFMACRO.LISP) ;;; PARSE-LAMBDA-LIST (from K-SYS:K;LAMBDA-LIST.LISP) ;;; PARSE-KEY-PARAMETER " ;;; PARSE-AUX-PARAMETER " ;;; PARSE-LET-BINDING " ;;; Contents: ;;; ;;; [1] Interpreter global variables ;;; [2] Functions for the outside world ;;; [3] Frames and environments ;;; [4] Closures ;;; [5] Parsing special forms ;;; [6] Eval ;;; [7] Apply ;;; Problems: ;;; applyhook ;;;---------------------------------------------------------------------------- ;;; {1} INTERPRETER GLOBAL VARIABLES ;;;---------------------------------------------------------------------------- (defvar *vanilla-evalhook-first-position-functions?* t "Use 'eval' to evaluate the function in a function application. If NIL, the function is evaluated without using 'eval'. This determines whether or not evaluating the function will be evalhooked.") (defvar *vanilla-allow-free-variables?* NIL "Bound to T while EVAL-SPECIAL-OK is running. When NIL, free variable references cause an error.") (defvar foo-*evalhook* NIL) (defvar foo-*applyhook* NIL) (defvar foo-*macroexpand-hook* 'FUNCALL) ;;;---------------------------------------------------------------------------- ;;; {2} FOR THE OUTSIDE WORLD ;;;---------------------------------------------------------------------------- ;;; ;;; EVAL and EVAL-SPECIAL-OK both bind *vanilla-allow-free-variables?* and then ;;; call MAIN-EVAL, which does the real work. ;;; ;;; The read-eval-print loop is primitive and stupid, and it doesn't know about ;;; * and ** and all that stuff. It's useful for debugging and probably little ;;; else. ;;;---------------------------------------------------------------------------- (defun eval (exp &optional nohook) "Evaluate a Lisp form." (let ((*vanilla-allow-free-variables?* NIL)) (main-eval exp (make-empty-environment) nohook))) (defun eval-special-ok (exp) "Evaluate a Lisp form, treating free variable references as special variables. This is typically used at the top level of read-eval-print loops so that the user can type the more convenient (+ x 3) instead of the strictly correct \(locally (declare (special x)) (+ x 3))" (let ((*vanilla-allow-free-variables?* T)) (main-eval exp (make-empty-environment)))) #+not-used ;;||| --wkf 10/3/88 (defun rep () (loop (fresh-line) (princ " ") (fresh-line) (princ "==> ") (let ((expr (read))) (print (eval-special-ok expr))))) ;;;---------------------------------------------------------------------------- ;;; {3} FRAMES AND ENVIRONMENTS ;;;---------------------------------------------------------------------------- ;;; ;;; A FRAME has three slots: ;;; (1) PARENT - the parent environment of the frame ;;; (2) TYPE - one of :VARIABLE, :FUNMAC, :BLOCK, or :GOTAG ;;; (3) BINDING - a list of bindings ;;; ;;; A BINDING contains lexical information about a variable identifier. It has ;;; three slots: ;;; (1) IDENTIFIER - the symbol which names the variable ;;; (2) TYPE - explained below ;;; (3) VALUE - the value to which the variable is bound ;;; ;;; In a variable frame, the TYPE is either :SPECIAL or NIL. If the TYPE is ;;; :SPECIAL then the VALUE field is meaningless; the variable's value is its ;;; special value. In a function/macro frame, the TYPE is either :FUNCTION or ;;; :MACRO. In gotag and block frames, the TYPE field is not used. ;;;---------------------------------------------------------------------------- (defstruct (nframe (:constructor make-nframe (parent type))) parent type (bindings nil)) (defstruct (binding (:constructor make-binding (identifier type value))) identifier type value) (defun make-empty-environment () NIL) (defsubst adjoin-variable-frame (parent-env) "Return a new environment created by adjoining an empty variable frame onto PARENT-ENV." (make-nframe parent-env :variable)) (defsubst adjoin-funmac-frame (parent-env) "Return a new environment created by adjoining an empty function/macro frame onto PARENT-ENV." (make-nframe parent-env :funmac)) (defsubst adjoin-block-frame (parent-env) "Return a new environment created by adjoining an empty block frame onto PARENT-ENV." (make-nframe parent-env :block)) (defsubst adjoin-gotag-frame (parent-env) "Return a new environment created by adjoining an empty gotag frame onto PARENT-ENV." (make-nframe parent-env :gotag)) (defsubst adjoin-junk-frame (parent-env) "Return a new environment created by adjoining an empty junk frame onto PARENT-ENV." (make-nframe parent-env :placeholder)) (defun bind-in-frame (id type value frame &optional frame-type) (when (and frame-type (not (eq (nframe-type frame) frame-type))) (ferror "internal: Tried to make ~S binding in ~S frame." type (nframe-type frame))) (push (make-binding id type value) (nframe-bindings frame))) ;(defun declare-special-variable-within-frame (id frame) ; (when (not (eq (nframe-type frame) :variable)) ; (ferror "internal: Tried to declare special variable in ~S frame." (nframe-type frame))) ; (push (make-binding id T NIL) (nframe-bindings frame))) (defun lookup-binding-in-environment (id env type) (cond ((null env) NIL) ((not (eq type (nframe-type env))) (lookup-binding-in-environment id (nframe-parent env) type)) (t (let ((binding (lookup-binding-in-list id (nframe-bindings env)))) (if binding binding (lookup-binding-in-environment id (nframe-parent env) type)))))) (defun lookup-binding-in-list (id list) (if (null list) NIL (let ((binding (car list))) (if (eq (binding-identifier binding) id) binding (lookup-binding-in-list id (cdr list)))))) (defun print-nframe (nframe stream depth) (declare (ignore depth)) (si::printing-random-object (nframe stream) (format stream "FRAME ~S" (nframe-type nframe)))) ;;; True, this gives more info, but it clutters up the screen. ; (format stream ; "#" ; (nframe-type nframe) ; (mapcar #'car (nframe-bindings nframe)) ; (if (nframe-parent nframe) (nframe-type (nframe-parent nframe)) NIL))) ;;;---------------------------------------------------------------------------- ;;; {4} CLOSURES ;;;---------------------------------------------------------------------------- ;;; ;;; There are three essential components of an interpreter closure: a lambda ;;; list, the body forms, and an environment. There are also two optional ;;; slots for a name and an optimized body. ;;; ;;; Slots in the closure: ;;; name ;;; lambda-list ;;; body ;;; environment ;;; optimized-body ;;;---------------------------------------------------------------------------- (defun make-i-closure (lambda-list body environment &optional (name :UNNAMED) (optimized-body :UNOPTIMIZED)) "Make an interpreter closure. This is a slightly friendlier interface to MAKE-INTERPRETER-CLOSURE" (make-interpreter-closure name lambda-list body environment optimized-body)) ;;;---------------------------------------------------------------------------- ;;; Closures for the K (This is ultimately destined for LISP-INTERNALS) ;;;---------------------------------------------------------------------------- (defun make-interpreter-closure (name lambda-list body environment optimized-body) (let ((closure (array:make-vector 5))) (cons:store-contents-offset closure 1 name) (cons:store-contents-offset closure 2 lambda-list) (cons:store-contents-offset closure 3 body) (cons:store-contents-offset closure 4 environment) (cons:store-contents-offset closure 5 optimized-body) (cons:make-pointer vinc:$$dtp-interpreter-closure closure))) (defun interpreter-closure-name (closure) (if (interpreter-closure-p closure) (cons:contents-offset closure 1) (error "That's not an interpreter closure!"))) (defun interpreter-closure-lambda-list (closure) (if (interpreter-closure-p closure) (cons:contents-offset closure 2) (error "That's not an interpreter closure!"))) (defun interpreter-closure-body (closure) (if (interpreter-closure-p closure) (cons:contents-offset closure 3) (error "That's not an interpreter closure!"))) (defun interpreter-closure-environment (closure) (if (interpreter-closure-p closure) (cons:contents-offset closure 4) (error "That's not an interpreter closure!"))) (defun interpreter-closure-optimized-body (closure) (if (interpreter-closure-p closure) (cons:contents-offset closure 5) (error "That's not an interpreter closure!"))) (defun interpreter-closure-p (thing) (vinc:data-type= thing (hw:dpb-unboxed vinc:$$dtp-interpreter-closure vinc:%%data-type (hw:unboxed-constant 0)))) ;;;---------------------------------------------------------------------------- ;;; Closures for the lambda ;;;---------------------------------------------------------------------------- #| (defstruct (interpreter-closure (:constructor make-interpreter-closure-object (name lambda-list body environment optimized-body))) name lambda-list body environment optimized-body) (defun make-interpreter-closure (name lambda-list body environment optimized-body) (let ((closure (make-interpreter-closure-object name lambda-list body environment optimized-body))) #'(lambda (&rest args) (apply-interpreter-closure closure args)))) |# ;;;---------------------------------------------------------------------------- ;;; {5} PARSING SPECIAL FORMS ;;;---------------------------------------------------------------------------- (defsubst block-name (block-expr) (cadr block-expr)) (defsubst block-body (block-expr) (cddr block-expr)) (defsubst catch-tag (catch-expr) (cadr catch-expr)) (defsubst catch-forms (catch-expr) (cddr catch-expr)) (defsubst eval-when-situation-list (eval-when-expr) (cadr eval-when-expr)) (defsubst eval-when-forms (eval-when-expr) (cddr eval-when-expr)) (defsubst function-fn (function-expr) (cadr function-expr)) (defsubst go-gotag (go-expr) (cadr go-expr)) (defsubst if-predicate (if-expr) (cadr if-expr)) (defsubst if-consequent (if-expr) (caddr if-expr)) (defsubst if-alternate (if-expr) (if (> (length if-expr) 3) (cadddr if-expr))) (defsubst let-bindings (let-expr) (cadr let-expr)) (defsubst let-body (let-expr) (cddr let-expr)) (defsubst multiple-value-call-function (multiple-value-call-expr) (cadr multiple-value-call-expr)) (defsubst multiple-value-call-forms (multiple-value-call-expr) (cddr multiple-value-call-expr)) (defsubst multiple-value-prog1-first-form (multiple-value-prog1-expr) (cadr multiple-value-prog1-expr)) (defsubst multiple-value-prog1-other-forms (multiple-value-prog1-expr) (cddr multiple-value-prog1-expr)) (defsubst progn-forms (progn-expr) (cdr progn-expr)) (defsubst progv-symbols (progv-expr) (cadr progv-expr)) (defsubst progv-values (progv-expr) (caddr progv-expr)) (defsubst progv-forms (progv-expr) (cdddr progv-expr)) (defsubst quote-object (quote-expr) (cadr quote-expr)) (defsubst return-from-name (return-from-expr) (cadr return-from-expr)) (defsubst return-from-result (return-from-expr) (if (> (length return-from-expr) 2) (caddr return-from-expr) nil)) (defsubst setq-args (setq-expr) (cdr setq-expr)) (defsubst tagbody-body (tagbody-expr) (cdr tagbody-expr)) (defsubst the-value-type (the-expr) (cadr the-expr)) (defsubst the-form (the-expr) (caddr the-expr)) (defsubst throw-tag (throw-expr) (cadr throw-expr)) (defsubst throw-result (throw-expr) (caddr throw-expr)) (defsubst unwind-protect-protected-form (unwind-protect-expr) (cadr unwind-protect-expr)) (defsubst unwind-protect-cleanup-forms (unwind-protect-expr) (cddr unwind-protect-expr)) ;;;---------------------------------------------------------------------------- ;;; {6} EVAL ;;;---------------------------------------------------------------------------- (defun main-eval (exp env &optional nohook) (if (and foo-*evalhook* (not nohook)) (relinquish-to-evalhook exp env) (cond ((self-evaluating? exp) exp) ((symbolp exp) (eval-variable exp env)) ((not (listp exp)) (error "Eval can't handle this expression." exp)) ((special-form-p (car exp)) (eval-special-form exp env)) ;; This is to forestall lambda lossage... ;;This is handled above by special-form-p, removed by --wkf ;; temporary hack to try to get the interpreter up even when LISP:IF is not eq to LISP:IF ...-pfc ;; ((and (symbolp (car exp)) ;; (string= (symbol-name (car exp)) "IF")) ;;+++ This used to be 'global:if ;; (eval-special-form `(if ,@(cdr exp)) env)) ;; ||| Removed 9/27/88 --wkf ((symbolp (car exp)) (eval-named-function-application-or-macro exp env)) ((lambda-expression-p (car exp)) (eval-lambda-expression-application exp env)) (t (tail-error "CAR of form is not valid" exp))))) (defun eval-sequence (exps env) "Evaluate EXPS, a list of expressions, in sequence and return the result of evaluating the last one." (cond ((null exps) NIL) ((null (cdr exps)) (main-eval (car exps) env)) (t (main-eval (car exps) env) (eval-sequence (cdr exps) env)))) (defun self-evaluating? (exp) "Return true if EXP should evaluate to itself, NIL otherwise." (or (numberp exp) (characterp exp) (stringp exp) (keywordp exp) (member exp '(t nil)) (arrayp exp))) ;;;---------------------------------------------------------------------------- ;;; Evaluating a variable. ;;;---------------------------------------------------------------------------- ;;; ;;; A variable can be lexical, special, or free; this is ;;; determined by applying the following four rules in order: ;;; ;;; 1. If the variable has been proclaimed special, it is special. ;;; 2. If the lexical environment doesn't know about the variable, it is free. ;;; 3. If the variable has been lexically declared special, it is special. ;;; 4. Otherwise, the variable is lexical. ;;;---------------------------------------------------------------------------- (defun eval-variable (sym env) (let ((lexical-binding (lookup-binding-in-environment sym env :variable))) (cond ((proclaimed-special-p sym) (safe-symbol-value sym)) ((null lexical-binding) (eval-free-variable sym)) ((eq (binding-type lexical-binding) :SPECIAL) (safe-symbol-value sym)) (t (binding-value lexical-binding))))) (defun eval-free-variable (sym) (if *vanilla-allow-free-variables?* (safe-symbol-value sym) (error "Free reference made to symbol ~S, attempting to evaluate it." sym))) (defun safe-symbol-value (sym) (if (boundp sym) (symbol-value sym) (error "The value cell of symbol ~S is unbound" sym))) ;;;---------------------------------------------------------------------------- ;;; Evaluating a named function application or macro. ;;;---------------------------------------------------------------------------- ;;; ;;; When the expression in the first position of a form is a symbol, and it ;;; doesn't name a special form, this function is called. ;;; ;;; The environment is searched for a lexical function/macro binding of the ;;; symbol. If none is found, the symbol is checked for a global macro ;;; definition. If no global macro definition is found, the form is assumed ;;; to be a regular function application. ;;; ;;; If the expression turns out to be a macro, it is expanded and re-evaluated. ;;; If it turns out to be a function application, it is evaluated as such. ;;;---------------------------------------------------------------------------- (defun eval-named-function-application-or-macro (exp env) (let* ((name (car exp)) (lexical-binding (lookup-binding-in-environment name env :FUNMAC))) (cond (lexical-binding (eval-named-function-application-or-macro-lexically exp env lexical-binding)) ((macro-function name) (main-eval (funcall (macro-function name) exp NIL) env)) ((and (fboundp name) (symbol-function name)) (apply (symbol-function name) (mapcar #'(lambda (arg) (main-eval arg env)) (cdr exp)))) (t (error "CAR of form has no function definition" name))))) (defun eval-named-function-application-or-macro-lexically (exp env lexical-binding) (case (binding-type lexical-binding) (:FUNCTION (apply (binding-value lexical-binding) (mapcar #'(lambda (arg) (main-eval arg env)) (cdr exp)))) (:MACRO (let* ((expander-fn (binding-value lexical-binding)) (expanded-macro (funcall expander-fn exp NIL))) (main-eval expanded-macro env))) (t (tail-error "internal: unrecognized funmac type in eval-funmac")))) ;;;---------------------------------------------------------------------------- ;;; Evaluating a lambda-expression application ;;;---------------------------------------------------------------------------- ;;; ;;; When the expression in the first position of a form is a lambda expression, ;;; this function is called. ;;;---------------------------------------------------------------------------- (defun eval-lambda-expression-application (exp env) (let* ((lambda-expression (car exp)) (function (main-eval (list 'FUNCTION lambda-expression) env)) (arguments (mapcar #'(lambda (foo) (main-eval foo env)) (cdr exp)))) (apply function arguments))) ;;;---------------------------------------------------------------------------- ;;; Evaluating special forms -- dispatch table ;;;---------------------------------------------------------------------------- (defun eval-special-form (exp env) (funcall (case (car exp) (block #'eval-block) (catch #'eval-catch) (compiler-let #'eval-compiler-let) (declare #'eval-declare) (eval-when #'eval-eval-when) (flet #'eval-flet) (function #'eval-function) (go #'eval-go) (if #'eval-if) (labels #'eval-labels) (let #'eval-let) (let* #'eval-let*) (macrolet #'eval-macrolet) (multiple-value-call #'eval-multiple-value-call) (multiple-value-prog1 #'eval-multiple-value-prog1) (progn #'eval-progn) (progv #'eval-progv) (quote #'eval-quote) (return-from #'eval-return-from) (setq #'eval-setq) (tagbody #'eval-tagbody) (the #'eval-the) (throw #'eval-throw) (unwind-protect #'eval-unwind-protect) (cond #'eval-cond) (or #'eval-or) (and #'eval-and) (t #'eval-bogus-special-form)) exp env)) ;;;---------------------------------------------------------------------------- ;;; Evaluating BLOCK and RETURN-FROM ;;;---------------------------------------------------------------------------- ;;; ;;; BLOCK adjoins a block frame to the environment. In this frame, it binds ;;; the block's name to a closure with one argument. During the dynamic extent ;;; of the block, funcalling this closure exits the block and returns its ;;; argument. After the block's time is up, this function is changed to a new ;;; one which raises an error. ;;; ;;; RETURN-FROM looks up the block's exit function and funcalls it. ;;;---------------------------------------------------------------------------- (defun eval-block (exp env) (require-n-arguments exp 1) (let* ((block-name (block-name exp)) (block-body (block-body exp)) (tag (prog1 (gensym 'block-) (gensym 'g))) (return-fn #'(lambda (value) (throw tag value))) (expired-fn #'(lambda (value) (declare (ignore value)) (ferror "The dynamic extent of block ~S has expired." block-name))) (inner-frame (adjoin-block-frame env))) (unless (symbolp block-name) (ferror "The BLOCK id ~S is not a symbol." block-name)) (bind-in-frame block-name NIL return-fn inner-frame :BLOCK) (unwind-protect (catch tag (eval-sequence block-body inner-frame)) (let ((binding (lookup-binding-in-environment block-name inner-frame :BLOCK))) (setf (binding-value binding) expired-fn))))) (defun eval-return-from (exp env) (require-n-arguments exp 1 2) (let* ((name (return-from-name exp)) (result (return-from-result exp)) (binding (lookup-binding-in-environment name env :BLOCK))) (if binding (funcall (binding-value binding) result) (ferror nil "~S is not a lexically visible BLOCK tag." name)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating CATCH, THROW, and UNWIND-PROTECT ;;;---------------------------------------------------------------------------- ;;; ;;; Note: THROW would be nicer if its error had a proceed type that let one ;;; give it a different tag to throw to. ;;;---------------------------------------------------------------------------- (defun eval-catch (exp env) (require-n-arguments exp 1) (let* ((tag (catch-tag exp)) (forms (catch-forms exp)) (evaluated-tag (main-eval tag env))) (if (symbolp evaluated-tag) (catch evaluated-tag (eval-sequence forms env)) (error "CATCH tag does not evaluate to a symbol.")))) (defun eval-throw (exp env) (require-n-arguments exp 2 2) (let* ((tag (throw-tag exp)) (result (throw-result exp)) (evaluated-tag (main-eval tag env))) (if (symbolp evaluated-tag) (throw evaluated-tag (main-eval result env)) (error "THROW tag does not evaluate to a symbol.")))) (defun eval-unwind-protect (exp env) (require-n-arguments exp 1) (let ((protected-form (unwind-protect-protected-form exp)) (cleanup-forms (unwind-protect-cleanup-forms exp))) (unwind-protect (main-eval protected-form env) (eval-sequence cleanup-forms env)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating COMPILER-LET, LET, and LET* ;;;---------------------------------------------------------------------------- ;;; ;;; The variables which the form declares special are identified. (In the case ;;; of COMPILER-LET, this includes all the variables that are bound). A ;;; variable frame F1 is adjoined to ENV; this frame contains entries for each ;;; of the special variables. The let bindings are then evaluated; bindings ;;; for special variables are handled by progv and bindings for lexical ;;; variables are made in the environment. (The values to which variables ;;; are bound are evaluated in F1). Finally, the let body is evaluated in the ;;; resulting environment. ;;;---------------------------------------------------------------------------- (defun eval-let (exp env) (multiple-value-bind (specials body) (examine-declarations (let-body exp) env) (eval-parallel-let (let-bindings exp) body specials env))) (defun eval-let* (exp env) (multiple-value-bind (specials body) (examine-declarations (let-body exp) env) (eval-sequential-let (let-bindings exp) body specials env))) (defun eval-compiler-let (exp env) (let ((specials (mapcar #'let-binding-variable (let-bindings exp)))) (eval-parallel-let (let-bindings exp) (let-body exp) specials env))) ;; recompile with correct version of PROGV (in THROW.LISP] 27sept88 pfc (defun eval-parallel-let (let-bindings body specials env) (let ((f1 (adjoin-variable-frame env))) (dolist (special specials) (bind-in-frame special :SPECIAL NIL f1 :VARIABLE)) (let ((inner-frame (adjoin-variable-frame f1)) (specials-to-bind NIL) (values-of-specials-to-bind NIL)) (dolist (let-binding let-bindings) (let ((identifier (require-bindable-symbol (let-binding-variable let-binding))) (value (main-eval (let-binding-value let-binding) f1))) (if (or (member identifier specials) (proclaimed-special-p identifier)) (progn (push identifier specials-to-bind) (push value values-of-specials-to-bind)) (bind-in-frame identifier NIL value inner-frame :VARIABLE)))) (progv specials-to-bind values-of-specials-to-bind (eval-sequence body inner-frame))))) (defun eval-sequential-let (let-bindings body specials env) (let ((f1 (adjoin-variable-frame env))) (dolist (special specials) (bind-in-frame special :SPECIAL NIL f1 :VARIABLE)) (let ((inner-frame (adjoin-variable-frame f1))) (labels ((esl-loop () (if (null let-bindings) (eval-sequence body inner-frame) (let* ((let-binding (car let-bindings)) (identifier (require-bindable-symbol (let-binding-variable let-binding))) (value (main-eval (let-binding-value let-binding) inner-frame))) (setq let-bindings (cdr let-bindings)) (if (or (member identifier specials) (proclaimed-special-p identifier)) (progv (list identifier) (list value) (esl-loop)) (progn (bind-in-frame identifier NIL value inner-frame :VARIABLE) (esl-loop))))))) (esl-loop))))) (defun let-binding-variable (let-binding) (cond ((symbolp let-binding) let-binding) ((and (listp let-binding) (<= (length let-binding) 2)) (car let-binding)) (t (error "~S is bad syntax for a LET binding" let-binding)))) (defun let-binding-value (let-binding) (cond ((symbolp let-binding) NIL) ((and (listp let-binding) (<= (length let-binding) 2)) (cadr let-binding)) (t (error "~S is bad syntax for a LET binding" let-binding)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating DECLARE ;;;---------------------------------------------------------------------------- ;;; ;;; "Declarations may occur only at the beginning of the bodies of certain ;;; special forms; ... It is an error to attempt to evaluate a declaration." ;;; (CLtL, p. 154) ;;;---------------------------------------------------------------------------- (defun eval-declare (exp env) (declare (ignore env)) (format *error-output* "~&>>WARNING: Attempt to evaluate declaration ~S." exp) "DECLARATION. Tsk-tsk, you shouldn't have evaluated this.") ;;;---------------------------------------------------------------------------- ;;; Evaluating EVAL-WHEN ;;;---------------------------------------------------------------------------- (defun eval-eval-when (exp env) (require-n-arguments exp 1) (let* ((situation-list (eval-when-situation-list exp)) (keyword-situation-list (mapcar #'(lambda (symbol) (intern (symbol-name symbol) (find-package "KEYWORD"))) situation-list)) (forms (eval-when-forms exp)) (losers (member-if-not #'(lambda (situation) (member situation '(:compile :load :eval))) keyword-situation-list))) (cond (losers (error "Unrecognized symbol ~S in times-list of ~S" (first losers) exp)) ((member :eval situation-list) (eval-sequence forms env)) (t NIL)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating FLET, LABELS, and MACROLET ;;;---------------------------------------------------------------------------- (defun eval-flet (exp env) (let ((flet-bindings (let-bindings exp)) (flet-body (let-body exp)) (inner-frame (adjoin-funmac-frame env))) (dolist (binding flet-bindings) (let ((name (flet-binding-name binding)) (lambda-list (flet-binding-lambda-list binding)) (function-body (flet-binding-function-body binding))) (bind-in-frame name :FUNCTION (make-i-closure lambda-list function-body env name) inner-frame :FUNMAC))) (eval-sequence flet-body inner-frame))) (defun eval-labels (exp env) (let ((labels-bindings (let-bindings exp)) (labels-body (let-body exp)) (inner-frame (adjoin-funmac-frame env))) (dolist (binding labels-bindings) (let ((name (flet-binding-name binding)) (lambda-list (flet-binding-lambda-list binding)) (function-body (flet-binding-function-body binding))) (bind-in-frame name :FUNCTION (make-i-closure lambda-list function-body inner-frame name) inner-frame :FUNMAC))) (eval-sequence labels-body inner-frame))) (defun eval-macrolet (exp env) (let ((macrolet-bindings (let-bindings exp)) (macrolet-body (let-body exp)) (inner-frame (adjoin-funmac-frame env))) (dolist (binding macrolet-bindings) (bind-in-frame (flet-binding-name binding) :MACRO (expand-defmacro binding env) inner-frame :FUNMAC)) (eval-sequence macrolet-body inner-frame))) (defun flet-binding-name (flet-binding) (car flet-binding)) (defun flet-binding-lambda-list (flet-binding) (cadr flet-binding)) (defun flet-binding-function-body (flet-binding) (cddr flet-binding)) ;;;---------------------------------------------------------------------------- ;;; Evaluating FUNCTION ;;;---------------------------------------------------------------------------- ;;; ;;; ?? What happens to declarations in the lambda expressions? ;;;---------------------------------------------------------------------------- (defun eval-function (exp env) (require-n-arguments exp 1 1) (let ((fn (function-fn exp))) (cond ((symbolp fn) (eval-function-symbol fn env)) ((lambda-expression-p fn) (eval-function-lambda fn env)) ((named-lambda-expression-p fn) (eval-function-named-lambda fn env)) (t (error "Argument to FUNCTION is not valid."))))) (defun eval-function-symbol (sym env) (let ((lexical-binding (lookup-binding-in-environment sym env :FUNMAC))) (cond (lexical-binding (case (binding-type lexical-binding) (:FUNCTION (binding-value lexical-binding)) (:MACRO (error "It has a lexical macro definition.")))) ((common-lisp-special-form-p sym) (error "It is a special form.")) ((macro-function sym) (error "It has a global macro definition.")) (t (if (fboundp sym) (symbol-function sym) (error "The function cell of symbol ~S is unbound." sym)))))) (defun eval-function-lambda (lambda-expr env) (let ((lambda-list (cadr lambda-expr)) (body (cddr lambda-expr))) (make-i-closure lambda-list body env))) (defun eval-function-named-lambda (named-lambda-expr env) (let ((name (cadr named-lambda-expr)) (lambda-list (caddr named-lambda-expr)) (body (cdddr named-lambda-expr))) (make-i-closure lambda-list body env name))) ;;;---------------------------------------------------------------------------- ;;; Evaluating IF ;;;---------------------------------------------------------------------------- (defun eval-if (exp env) (require-n-arguments exp 2 3) (let ((predicate (if-predicate exp)) (consequent (if-consequent exp)) (alternate (if-alternate exp))) (if (main-eval predicate env) (main-eval consequent env) (main-eval alternate env)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating COND ;;;---------------------------------------------------------------------------- ;; Cond Added by --wkf 9/27/88 ||| (defun eval-cond (exp env) (dolist (sub-exp (cdr exp) nil) (let* ((predicate (car sub-exp)) (eval-pred (main-eval predicate env))) (when eval-pred (return (let ((consequents (cdr sub-exp))) (if consequents (eval-sequence consequents env) eval-pred))))))) ;;;---------------------------------------------------------------------------- ;;; Evaluating AND + OR ;;;---------------------------------------------------------------------------- ;;||| Added AND + OR 9/27/88 --wkf (defun eval-or (exp env) (let ((args (cdr exp))) (when args (do ((sub-exp (car args) (car rest-exp)) (rest-exp (cdr args) (cdr rest-exp))) ((null rest-exp) (main-eval sub-exp env)) (let ((eval-sub (main-eval sub-exp env))) (when eval-sub (return eval-sub))))))) (defun eval-and (exp env) (let ((args (cdr exp))) (if args (do ((sub-exp (car args) (car rest-exp)) (rest-exp (cdr args) (cdr rest-exp))) ((null rest-exp) (main-eval sub-exp env)) (unless (main-eval sub-exp env) (return))) t))) ;;;---------------------------------------------------------------------------- ;;; Evaluating MULTIPLE-VALUE-CALL ;;;---------------------------------------------------------------------------- (defun eval-multiple-value-call (exp env) (require-n-arguments exp 1) (let* ((function (multiple-value-call-function exp)) (forms (multiple-value-call-forms exp)) (evaluated-function (main-eval function env))) (unless (functionp evaluated-function) (error "First argument to MULTIPLE-VALUE-CALL not a function")) (apply evaluated-function (eval-multiple-value-call-args forms env)))) (defun eval-multiple-value-call-args (forms env) (when forms (append (multiple-value-list (eval-subproblem (car forms) env)) (eval-multiple-value-call-args (cdr forms) env)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating MULTIPLE-VALUE-PROG1 ;;;---------------------------------------------------------------------------- (defun eval-multiple-value-prog1 (exp env) (require-n-arguments exp 1) (let* ((first-form (multiple-value-prog1-first-form exp)) (other-forms (multiple-value-prog1-other-forms exp)) (evaluated-first-form (multiple-value-list (main-eval first-form env)))) (eval-sequence other-forms env) (values-list evaluated-first-form))) ;;;---------------------------------------------------------------------------- ;;; Evaluating PROGN ;;;---------------------------------------------------------------------------- (defun eval-progn (exp env) (eval-sequence (progn-forms exp) env)) ;;;---------------------------------------------------------------------------- ;;; Evaluating PROGV ;;;---------------------------------------------------------------------------- (defun eval-progv (exp env) (require-n-arguments exp 2) (let* ((symbols (progv-symbols exp)) (values (progv-values exp)) (forms (progv-forms exp)) (evaluated-symbols (mapcar #'require-bindable-symbol (main-eval symbols env))) (evaluated-values (main-eval values env))) (unless (listp evaluated-symbols) (error "PROGV symbols not a list")) (unless (listp evaluated-values) (error "PROGV values not a list")) (progv evaluated-symbols evaluated-values (eval-sequence forms env)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating QUOTE ;;;---------------------------------------------------------------------------- (defun eval-quote (exp env) (declare (ignore env)) (require-n-arguments exp 1 1) (quote-object exp)) ;;;---------------------------------------------------------------------------- ;;; Evaluating SETQ ;;;---------------------------------------------------------------------------- (defun eval-setq (exp env) (let ((args (setq-args exp)) (setq-result NIL)) (if (not (zerop (mod (length args) 2))) (error "Odd number of arguments to SETQ") (do ((variable (first args) (first args)) (form (second args) (second args))) ((null args) setq-result) (setq setq-result (main-eval form env)) (setq args (cddr args)) (let ((lexical-binding (lookup-binding-in-environment variable env :VARIABLE))) (cond ((proclaimed-special-p variable) ; (setf (symbol-value variable) setq-result)) (set variable setq-result)) ((null lexical-binding) (if *vanilla-allow-free-variables?* ; (setf (symbol-value variable) setq-result) (set variable setq-result) (error "Free reference made to symbol ~S, attempting to set it." variable))) ((eq (binding-type lexical-binding) :SPECIAL) (set variable setq-result)) (t (setf (binding-value lexical-binding) setq-result)))))))) ;;;---------------------------------------------------------------------------- ;;; Evaluating TAGBODY and GO ;;;---------------------------------------------------------------------------- (defun eval-tagbody (exp env) (let ((gotag-frame (adjoin-gotag-frame env)) (body (tagbody-body exp))) (bind-gotags body gotag-frame) (unwind-protect (eval-sequence body gotag-frame) (rebind-gotags body gotag-frame)))) (defun bind-gotags (tagbody-list frame) (do ((l tagbody-list (cdr tagbody-list))) ((null l)) (let ((element (car l))) (when (or (symbolp element) (numberp element)) (bind-in-frame element NIL #'(lambda () (eval-sequence (cdr l) frame)) frame :GOTAG))))) (defun rebind-gotags (tagbody-list frame) (do ((l tagbody-list (cdr tagbody-list))) ((null l)) (let ((element (car l))) (when (or (symbolp element) (numberp element)) (let ((binding (lookup-binding-in-environment element frame :GOTAG))) (setf (binding-value binding) #'(lambda () (error "The dynamic extent of GO tag ~S has expired." element)))))))) (defun eval-go (exp env) (require-n-arguments exp 1 1) (let ((tag (go-gotag exp))) (if (or (symbolp tag) (numberp tag)) (let ((binding (lookup-binding-in-environment tag env :GOTAG))) (if binding (funcall (binding-value binding)) (error "There is no lexically visible GO tag named ~S." tag))) (error "GO tag ~S is neither a number nor a symbol.")))) ;;;---------------------------------------------------------------------------- ;;; Evaluating THE ;;;---------------------------------------------------------------------------- (defun eval-the (exp env) (require-n-arguments exp 2 2) (let ((value-type (the-value-type exp)) (evaluated-form (main-eval (the-form exp) env))) (if (typep evaluated-form value-type) evaluated-form (error "(THE) Object ~S is not of type ~S" evaluated-form value-type)))) ;;;---------------------------------------------------------------------------- ;;; Evaluating bogus special forms ;;;---------------------------------------------------------------------------- ;;; ;;; There's probably a bug in the interpreter if this function is ever called. ;;;---------------------------------------------------------------------------- (defun eval-bogus-special-form (exp env) (declare (ignore env)) (error "~S appears to be a bogus special form.")) ;;;---------------------------------------------------------------------------- ;;; {7} APPLY INTERPRETER CLOSURE ;;;---------------------------------------------------------------------------- ;;; ;;; This is the interpreter's apply procedure. It is called with two ;;; arguments: an interpreter closure and a list of arguments which have ;;; already been evaluated. Here's how it works: ;;; ;;; First of all, apply creates a new variable frame F1 and adjoins it to the ;;; closure's environment. In this frame are entries for each of the variables ;;; that the closure's body declares special. Then apply creates an inner ;;; variable frame adjoined to F1; this is the frame used for binding the ;;; closure's formal parameters to its arguments. ;;; ;;; Next, the binding process takes place. Apply steps through the lambda ;;; list, binding one variable at a time. Special variables are bound using ;;; progv; lexical variables are bound by adding a binding to the inner frame. ;;; ;;; Finally, the body of the closure is evaluated in the inner frame. ;;;---------------------------------------------------------------------------- (defun apply-interpreter-closure (closure arglist) (multiple-value-bind (specials body) (examine-declarations (interpreter-closure-body closure) NIL) ;; <- FIX THIS! (let ((lambda-list (interpreter-closure-lambda-list closure)) (f1 (adjoin-variable-frame (interpreter-closure-environment closure)))) (dolist (special specials) (bind-in-frame special :SPECIAL NIL f1 :VARIABLE)) (let ((inner-frame (adjoin-variable-frame f1))) (bind-required-parameters lambda-list arglist body specials inner-frame))))) (defun bind-required-parameters (lambda-list arglist body specials env) (let ((next-parameter (car lambda-list)) (next-argument (car arglist))) (cond ((and (null lambda-list) arglist) (error "Too many arguments in APPLY-INTERPRETER-CLOSURE")) ((and (null arglist) lambda-list) (error "Too few arguments in APPLY-INTERPRETER-CLOSURE")) ((and (null lambda-list) (null arglist)) (execute-closure-body-code body env)) ((eq next-parameter '&OPTIONAL) (bind-optional-parameters (cdr lambda-list) arglist body specials env)) ((eq next-parameter '&REST) (bind-rest-parameter (cdr lambda-list) arglist body specials env)) ((eq next-parameter '&KEY) (bind-key-parameters (cdr lambda-list) arglist body specials env)) ((eq next-parameter '&AUX) (bind-aux-parameters (cdr lambda-list) arglist body specials env)) ((looks-like-lambda-list-keyword? next-parameter) (error "Lambda list keyword ~A is bogus in this position." next-parameter)) (t (bind-variable next-parameter ;(require-bindable-symbol next-parameter) next-argument env specials #'(lambda () (bind-required-parameters (cdr lambda-list) (cdr arglist) body specials env))))))) (defun bind-optional-parameters (lambda-list arglist body specials env) (let ((next-parameter (car lambda-list)) (next-argument (car arglist))) (cond ((and (null lambda-list) arglist) (error "Too many arguments in APPLY-INTERPRETER-CLOSURE")) ((and (null lambda-list) (null arglist)) (execute-closure-body-code body env)) ((eq next-parameter '&REST) (bind-rest-parameter (cdr lambda-list) arglist body specials env)) ((eq next-parameter '&KEY) (bind-key-parameters (cdr lambda-list) arglist body specials env)) ((eq next-parameter '&AUX) (bind-aux-parameters (cdr lambda-list) arglist body specials env)) ((looks-like-lambda-list-keyword? next-parameter) (error "Lambda list keyword ~A is bogus in this position." next-parameter)) (t (multiple-value-bind (var initform svar) (parse-optional-parameter next-parameter) (let ((supplied-p (if (null arglist) NIL T)) (continuation #'(lambda () (bind-optional-parameters (cdr lambda-list) (cdr arglist) body specials env)))) (bind-variable (require-bindable-symbol var) (if supplied-p next-argument (main-eval initform env)) env specials #'(lambda () (if svar (bind-variable (require-bindable-symbol svar) supplied-p env specials continuation) (funcall continuation)))))))))) (defun bind-rest-parameter (lambda-list arglist body specials env) (declare (ignore lambda-list arglist body specials env)) (error "BIND-REST-PARAMETER not yet implemented")) (defun bind-key-parameters (lambda-list arglist body specials env) (declare (ignore lambda-list arglist body specials env)) (error "BIND-KEY-PARAMETERS not yet implemented")) (defun bind-aux-parameters (lambda-list arglist body specials env) (declare (ignore lambda-list arglist body specials env)) (error "BIND-AUX-PARAMETERS not yet implemented")) (defun bind-variable (variable value frame specials continuation) "If VARIABLE has been proclaimed special, or if it is a member of the SPECIALS list, then this function binds the dynamic value of VARIABLE to VALUE using PROGV. If VARIABLE is not special, then this function lexically binds VARIABLE to VALUE in FRAME. In either case, after this function has bound VARIABLE, it funcalls CONTINUATION to proceed." (if (or (proclaimed-special-p variable) (member variable specials)) (progv (list variable) (list value) (funcall continuation)) (progn (bind-in-frame variable NIL value frame :VARIABLE) (funcall continuation)))) (defun execute-closure-body-code (closure-body-code env) (eval-sequence closure-body-code env)) ;; Bind all &key parameters. ;; ;; 1. The list of arguments is converted to an a-list matching keywords to values. ;; 2. If &allow-other-keys appeared in the lambda list, or the a-list contains ;; a pair matching the keyword :allow-other-keys to a true value, the variable ;; a-o-k is bound to true; otherwise it is bound to nil. ;; 3. Each parameter is processed in sequence. ;; (a) The keyword for the parameter is looked up in the a-list of arguments ;; (b) If an argument pair is found, ;; 1. The parameter variable is bound to the corresponding argument value. ;; 2. All argument pairs in the a-list with that particular keyword are ;; removed from the a-list. It is assumed that there are no repeated ;; keywords in the parameter list. ;; 3. The parameter's svar, if present, is bound to T. ;; (c) If an argument pair is not found, ;; 1. The parameter's initform is evaluated. ;; 2. The parameter's variable is bound to the resulting value. ;; 3. The parameter's svar, if present, is bound to NIL. ;; 4. If a-o-k is nil, and there are argument pairs remaining on the a-list, an ;; error is raised. ;; ;;;---------------------------------------------------------------------------- ;;; {9} INSURANCE ;;;---------------------------------------------------------------------------- (defvar *allow-losing-&-symbols?* t "If NIL, any symbol beginning with & is not legal to bind. If non-nil, only real lambda-list keywords are illegal.") (defun require-bindable-symbol (var &optional (verb "bind")) (cond ((not (symbolp var)) (ferror "Attempt to ~A ~S; a symbol is required" verb var)) ((lambda-list-keyword-p var) (ferror "Attempt to ~A the lambda-list-keyword ~S" verb var)) ((and (not *allow-losing-&-symbols?*) (looks-like-lambda-list-keyword? var)) (cerror "Do it anyway." "Attempt to ~A what appears to be a lambda-list-keyword ~s." verb var) var) ((eq var 'nil) (ferror "Nihil ex nihil: Don't ~A ~S" verb var)) ((eq var 't) (ferror "Veritas aeternae: Don't ~A ~S" verb var)) ((keywordp var) (ferror "Attempt to ~A the keyword ~S" verb var)) ((constantp var) (ferror "Attempt to ~A the constant ~S" verb var)) (t var))) (defun require-n-arguments (expr min &optional (max nil max-specified)) (let* ((name (car expr)) (arguments (cdr expr)) (length (length arguments))) (cond ((< length min) (ferror "~S expression requires at least ~S argument~:P." name min)) ((and max-specified (> length max)) (ferror "Too many arguments in ~S expression." name)) (t "okay")))) ;;;---------------------------------------------------------------------------- ;;; {10} DECLARATIONS ;;;---------------------------------------------------------------------------- ;;; ;;; "Declarations may occur only at the beginning of the bodies of certain ;;; special forms; ... It is an error to attempt to evaluate a declaration." ;;; (CLtL, p. 154) ;;; ;;; The following procedure examines all declarations and documentation strings ;;; at the top of a list of expressions. It returns two values: ;;; ;;; specials - list of variables declared "special" ;;; body - the expressions following the declarations/documentation ;;;---------------------------------------------------------------------------- (defun examine-declarations (exprs env) (multiple-value-bind (body declarations) (GOBBLE-DECLARATIONS exprs NIL env) (values (extract-special-variable-list declarations) body))) (defun extract-special-variable-list (declarations) (when declarations (append (extract-special-variables (car declarations)) (extract-special-variable-list (cdr declarations))))) (defun extract-special-variables (declaration) (let ((special-variables nil)) (mapcar #'(lambda (decl-spec) (if (special-decl-spec-p decl-spec) (setq special-variables (append special-variables (special-vars-in-decl-spec decl-spec))))) declaration) special-variables)) (defun special-vars-in-decl-spec (decl-spec) (mapcar #'(lambda (element) (if (symbolp element) element (error "element of special decl-spec not a symbol"))) (cdr decl-spec))) (defun special-decl-spec-p (decl-spec) (and (listp decl-spec) (eq (car decl-spec) 'special))) ;;; Takes two arguments: ;;; List of forms to gobble ;;; Flag indicating whether or not to gobble documentation strings too ;;; ;;; Returns three values: ;;; Body (forms after declarations and documentation strings) ;;; List of declarations ;;; Documentation string (if applicable) ;;; ;;; Weird cases, if gobble-doc-strings-too: ;;; If there is more than one string in the forms, the second string and ;;; everything following it (including declarations) are part of the body. ;;; If the body is null, and a documentation string is present, a list ;;; containing the documentation string is the body. ;;; These cases follow from a strict interpretation of decl-spec/doc-string ;;; syntax described in Common Lisp. ;;; ;;; Macroexpand is used to handle the obnoxious case of macros which expand into ;;; declarations or documentation strings. (defun gobble-declarations (list-of-forms &optional gobble-doc-strings-too env) (let ((declarations '()) (doc-string nil) (body nil)) (loop (let ((form (MACROEXPAND (car list-of-forms) env))) (cond ((and (listp form) (eq (car form) 'declare)) (push form declarations)) ((and (stringp form) gobble-doc-strings-too (not doc-string)) (setq doc-string form)) (t (setq body list-of-forms) (return)))) (pop list-of-forms)) (when (and (null body) doc-string) (setq body (list doc-string))) (values body (reverse declarations) doc-string))) ;;;---------------------------------------------------------------------------- ;;; {11} MACRO EXPANDERS ;;;---------------------------------------------------------------------------- ;;; ;;; These both assume that NIL = null environment. This could be fixed, though. ;;; Also, macroexpand-1 technically should make no lexical lookup if env is ;;; not supplied. ;;;---------------------------------------------------------------------------- (defun macroexpand (form &optional env) (multiple-value-bind (expanded-form expanded-p) (macroexpand-1 form env) (if expanded-p (values (macroexpand expanded-form env) T) (values expanded-form NIL)))) (defun macroexpand-1 (form &optional env) (if (not (listp form)) (values form NIL) (let ((lexical-binding (lookup-binding-in-environment (car form) env :FUNMAC))) (if lexical-binding (if (eq (binding-type lexical-binding) :MACRO) (values (funcall foo-*macroexpand-hook* (binding-value lexical-binding) form env) T) (values form NIL)) (if (AND (symbolp (car form)) (macro-function (car form)) (NOT (COMMON-LISP-SPECIAL-FORM-P (CAR FORM)))) (values (funcall foo-*macroexpand-hook* (macro-function (car form)) form env) T) (values form NIL)))))) ;;;---------------------------------------------------------------------------- ;;; {12} SPECIAL FORM LISTS ;;;---------------------------------------------------------------------------- ;;; ;;; The first predicate determines whether or not a symbol names a Common Lisp ;;; special form. Taken from CLtL, Table 5-1, p. 57. ;;; ;;; The second predicate determines whether or not a symbol names a nonstandard ;;; special form. ;;;---------------------------------------------------------------------------- (defun special-form-p (sym) ;;||| Added 9/27/88 --wkf (or (common-lisp-special-form-p sym) (if (member sym '(cond and or)) t nil))) (defun common-lisp-special-form-p (sym) (if (member sym '(block catch compiler-let declare eval-when flet function go if labels let let* macrolet multiple-value-call multiple-value-prog1 progn progv quote return-from setq tagbody the throw unwind-protect)) t nil)) #+Not-used ;;||| Removed 9/27/88 --wkf (defun implementation-special-form-p (sym) (if (member sym '(describe-frame describe-pp)) t nil)) ;;;---------------------------------------------------------------------------- ;;; {13} EVALHOOK and APPLYHOOK ;;;---------------------------------------------------------------------------- ;;; ;;; If the variable foo-*evalhook* is not nil, then it should be bound to a function of ;;; two arguments. This function is called whenever main-eval is called, and is ;;; responsible for evaluating the expression passed to the evaluator. ;;; ;;; The first argument that foo-*evalhook* is called with is a Lisp form. ;;; ;;; The second argument that foo-*evalhook* is called with is an "environment". This is ;;; actually a lexical closure, a function of one argument (a Lisp form), which evaluates ;;; the Lisp form in the lexical environment containing the foo-*evalhook* call. ;;; (Implementing this requires a bit of kludgery; the form must be preprocessed in ;;; the appropriate preprocessor environment before it can be evaluated. Hence there ;;; must be a handle on the preprocessor environment at the time foo-*evalhook* is called.) ;;;---------------------------------------------------------------------------- ;; Relinquish-to-evalhook is called by main-eval. ;; (defun relinquish-to-evalhook (exp env) (let ((hook-fn foo-*evalhook*) ; (foo-*evalhook* nil) (foo-*applyhook* nil)) (flet ((eval-fn (lisp-form) (let* ((pass-1-result (preprocess lisp-form (intermediate-expression-preprocessor-env exp))) (pass-2-result (multiple-value-list (main-eval pass-1-result env t)))) (values-list pass-2-result)))) (funcall hook-fn (intermediate-expression-original-form exp) #'eval-fn)))) (defun relinquish-to-applyhook (fun args ppenv env) (let ((hook-fn foo-*applyhook*) (foo-*evalhook* nil) (foo-*applyhook* nil)) (flet ((eval-fn (lisp-form) (let* ((pass-1-result (preprocess lisp-form ppenv)) (pass-2-result (multiple-value-list (main-eval pass-1-result env t)))) (values-list pass-2-result)))) (funcall hook-fn fun args #'eval-fn)))) (defun foo-evalhook (form evalhookfn applyhookfn &optional env) (let ((foo-*evalhook* evalhookfn) (foo-*applyhook* applyhookfn)) (if env (funcall env form) (eval form)))) (defun foo-applyhook (fn args evalhookfn applyhookfn &optional env) (declare (ignore env)) (let ((foo-*evalhook* evalhookfn) (foo-*applyhook* applyhookfn)) (apply fn args))) ;;;---------------------------------------------------------------------------- ;;; {14} MISCELLANEOUS USEFUL FUNCTIONS ;;;---------------------------------------------------------------------------- (defun proclaimed-special-p (symbol) (global:get symbol 'LI::SPECIAL)) (defun lambda-expression-p (expr) (and (listp expr) (eq (car expr) 'lambda))) (defun named-lambda-expression-p (expr) (and (listp expr) (member (car expr) '(nc:named-lambda interpreter-named-lambda)))) (defun lambda-list-keyword-p (symbol) (member symbol '(&optional &rest &key &allow-other-keys &aux &body &environment &whole))) (defun looks-like-lambda-list-keyword? (symbol) NIL)