;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

;;; EVAL and other key interpreter functions for Spice Lisp.

;;; Written by Scott Fahlman and Skef Wholey.
;;; Parts of the interpreter are based on code by Guy Steele.
;;; Currently maintained by Scott Fahlman.

;;; Note: This file MUST be compiled.  These functions cannot be run under
;;; interpreter, since they ARE the interpreter.

;;; Style note: Certain things in this file can only be done at top-level
;;; and must be done as efficiently as possible, so a lot of random
;;; GO's are used here, where normally one would use function calls or
;;; macros.  This should not be done in normal code.

;;; *******************************************************************

;;; This is set up in the PACKAGE file.
(defvar *keyword-package*)

;;; We have to choose whether to do maximum error testing in the interpreter
;;; in cases where this slows us down significantly.

(defvar *maximum-interpreter-error-checking* t
  "If null, eliminates some of the more expensive runtime error testing
  in the interpreter.")

(defvar %lexical-environment% nil
  "Holds the lexical environment sturcture during execution of a compiled
  lexical closure.")

;;; The lexical environment is represented by four a-lists, stored in four
;;; internal special variables.  (The user should never mess with these.)

;;; %VENV% is the current lexical environment for variables.  An entry
;;; of the form (var . value) indicates a lexical variable and its value.
;;; An entry whose value is %INTERNAL-SPECIAL-MARKER% says to use the
;;; symbol's special value instead.

(defvar %venv% nil
  "The interpreter's lexical environment for variables -- hands off!")


;;; %FENV% is the current lexical environment for functions and macros.
;;; The format of each entry is (name type . fn), where type is either
;;; FUNCTION or MACRO and fn is the actual definition to be used.
;;; Entries of type function are created by FLET and LABELS.  Entries of
;;; type macro are created by MACROLET.

(defvar %fenv% nil
  "The interpreter's lexical environment for functions -- hands off!")


;;; %BENV% is the current lexical environment for block names.  Each entry
;;; is (name).  The cons cell is used as a catch tag by return-from.  If
;;; the entry has been clobbered to look like (NAME . INVALID), then the
;;; block has been exited and a return from that block is in error.

(defvar %benv% nil
  "The interpreter's lexical environment for block names -- hands off!")


;;; %GENV% is the current lexical environment for Go-tags.  Each entry 
;;; looks like (tag marker . body) where tag is the Go tag, marker is a
;;; unique cons cell used as a catch tag, and body is the statement sequence
;;; that follows the GO tag.

(defvar %genv% nil
  "The interpreter's lexical environment for go tags -- hands off!")


;;; An interpreted lexical closure object contains a function and the four
;;; a-lists comprising the lexical environment at the time of closing.

(defstruct (%lexical-closure%
	    (:type list)
	    :named)
  fn venv fenv benv genv)

(defmacro make-lexical-closure (fn)    
  `(list '%lexical-closure% ,fn %venv% %fenv% %benv% %genv%)) 


;;; Used to signal a symbol macro.  
(defstruct %sym-mac-binding%
  function)



;;;; Assorted Utilities

;;; FEXPRP determines whether a function-object is a FEXPR.
;;; This depends on the exact format of function objects, which may 
;;; vary from one implementaiton to another.  This is a macro for speed.
;;; Since in the Spice implementation the FEXPR bit is the sign bit of the
;;; word in question, the minusp test is quicker than LDB-TEST.

(defmacro fexprp (fn-obj)
  `(minusp (%primitive header-ref ,fn-obj %function-fexpr-slot)))


;;; Macro to test whether a symbol is a keyword.

(defmacro keywordp-macro (s)
  `(eq (symbol-package ,s) *keyword-package*))

;;; Keywordify takes a symbol and returns the corresponding keyword symbol.

(defmacro keywordify-macro (symbol)
  `(intern (symbol-name ,symbol) *keyword-package*))


;;; EXTRACT-SPECIALS is a macro that works on a variable named BODY,
;;; which must hold the body of a lambda-expression -- everything
;;; after the arglist.  It returns a list of all symbols declared
;;; special by local declarations, and as a side effect sets BODY
;;; to the remainder of the form after any declarations or doc
;;; strings.  Macros are expanded to see if they turn into
;;; declarations, and if one does not, the expansion is returned
;;; to the head of the BODY list.  Despite its size, we make this
;;; a macro because it occurs on several time-critical paths in the
;;; interpreter.

(defmacro extract-specials ()
  '(do ((b body (cdr b))
	(specials nil)
	(form nil))
       ((atom b)
	(setq body nil)
	(return specials))
     (setq form (car b))
     (cond ((and (stringp form) (cdr b))
	    (go skip))
	   ((not (listp form))
	    (setq body b)
	    (return specials))
	   ((eq (car form) 'declare))
	   ((and (symbolp (car form))
		 (macro-function (car form))
		 (setq form (%macroexpand form)))
	    (unless (eq (car form) 'declare)
		    (setq body (cons form (cdr b)))
		    (return specials)))
	   (t (setq body b) (return specials)))
     (do ((x (cdr form) (cdr x)))
	 ((atom x))
       (and (listp (car x))
	    (eq (caar x) 'special)
	    (do ((v (cdar x) (cdr v)))
		((atom v))
	      (push (car v) specials))))
     skip))


;;; EXTRACT-DOC-STRING dives down into the body of a LAMBDA (everything
;;; after the varlist) and returns with any legal documentation string
;;; or with NIL.  Skip over declarations and stop when we hit anything else.

(defun extract-doc-string (body)
  (do ((b body (cdr b)))
      ((null (cdr b)) nil)
    (cond ((stringp (car b))
	   (return b))
	  ((and (listp (car b)) (eq (caar b) 'declare)))
	  (t (return nil)))))
    

;;; EXTRACT-FN-NAME digs down into a lambda to find the name of the
;;; function in question.  If the function was created by DEFUN, this
;;; will be the block name in the first top-level BLOCK statement
;;; encountered.  If we don't find such a thing, return ANONYMOUS-LAMBDA.
;;; Also handles interpreted lexical closures.

(defun extract-fn-name (body)
  (if (eq (car body) '%lexical-closure%)
      (setq body (%lexical-closure%-fn body)))
  (do ((b body (cdr b)))
      ((atom b) 'anonymous-lambda)
    (if (and (listp (car b)) (eq (caar b) 'block))
	(return (cadar b)))))


;;; PARSE-BODY takes the body of a defun-like form (everything after the
;;; varlist) and takes it apart.  Returns a list of three elements: all the
;;; declarations, in order, then the documentation string, if any, then
;;; the rest of the body.  Macros that may be declarations are expanded
;;; and looked at, but are returned unexpanded.

(defun parse-body (body)
  (do ((b body (cdr b))
       (decls nil)
       (doc nil)
       (temp nil))
      ((null b) (list (nreverse decls) doc nil))
    (cond ((and (stringp (car b)) (cdr b) (null doc))
	   (setq doc (car b)))
	  ((not (listp (car b)))
	   (return (list (nreverse decls) doc b)))
	  ((eq (caar b) 'declare)
	   (push (car b) decls))
	  ((and (symbolp (caar b))
		(macro-function (caar b))
		(listp (setq temp (%macroexpand (car b))))
		(eq (car temp) 'declare))
	   (push (car b) decls))
	  (t (return (list (nreverse decls) doc b))))))


;;; BIND-VAR is a macro used by various binding forms.  Takes a variable
;;; name and a value.  If the variable is illegal, complain.  If it is
;;; special, do an %sp-bind and note on %venv% that this var is special.
;;; If it is local, just put a binding on %venv%.  Assumes that SPECIALS
;;; is bound in the caller's environment.

(defmacro bind-var (variable value)
  `(prog ((var ,variable) (val ,value))
    RETRY
     (cond ((not *maximum-interpreter-error-checking*))
	   ((not (typep var 'symbol))
	    (cerror "Prompt for a new variable name."
		    "Cannot bind ~S -- not a symbol." var)
	    (go prompt))
	   ((or (eq var t) (eq var nil) (get var '%constant))
	    (cerror "Prompt for a new variable name."
		    "Cannot bind ~S -- it is a constant." var)
	    (go prompt))
	   ((keywordp-macro var)
	    (cerror "Prompt for a new variable name."
		    "Cannot bind ~S -- it is a keyword." var)
	    (go prompt)))
     (cond ((or (memq var specials)
		(get var 'globally-special))
	    (push (cons var '%internal-special-marker%) %venv%)
	    (%sp-bind val var)
	    (return nil))
	   (t (push (cons var val) %venv%)
	      (return nil)))
    PROMPT
     (terpri)
     (princ "New variable name: ")
     (setq var (read))
     (go retry)))


;;; %INVOKE is a macro that evals the ARGS and applies FN to them.
;;; Drops into microcode, but if FN is not compiled, pops out again
;;; at %SP-INTERNAL-APPLY.  Check for applyhook before doing this.

(defmacro %invoke (fn args)
  `(if (and *applyhook*
	    (not (prog1 *skip-applyhook*
			(setq *skip-applyhook* nil))))
       (do ((x ,args (cdr x))
	    (a nil (cons (%eval (car x)) a)))
	   ((atom x)
	    (let ((hookfun *applyhook*) (*applyhook* nil))
	      (funcall hookfun ,fn (nreverse a) %venv% %fenv% %benv% %genv%))))
       (progn (%sp-call ,fn)
	      (do ((x ,args (cdr x)))
		  ((atom x))
		(%sp-push (%eval (car x))))
	      (%sp-start-call))))


;;; %INVOKE1 is similar to %INVOKE, but pushes only one arg without evaluating
;;; it (like a fexpr), and doesn't bother with applyhook hackery.

(defmacro %invoke1 (fn arg)
  `(progn (%sp-call ,fn)
	  (%sp-push ,arg)
	  (%sp-start-call)))


;;; Used within %sp-internal-apply to make sure that the user did not
;;; supply unexpected keywords.

(defmacro check-keywords-macro ()
  `(do ((n next-arg (+ n 2))
	key)
       ((>= n nargs))
     (setq key (%primitive arg-in-frame n frame))
     (cond ((memq key seen-keywords))
	   ((eq key :allow-other-keys))
	   ((not (keywordp-macro key))
	    (cerror "Ignore it."
		    "~S not a legal keyword arg." key))
	   ;; Before signalling error, look for :allow-other-keys.
	   ((do ((i n (+ i 2)))
		((>= i nargs) nil)
	      (if (and (eq (%primitive arg-in-frame i frame) :allow-other-keys)
		       (not (null (%primitive arg-in-frame (1+ i) frame))))
		  (return t)))
	    ;; We found it.  Forget any further checking.
	    (return nil))
	   (t (cerror "Ignore it."
		      "~S does not recognize ~S as keyword."
		      (extract-fn-name exp) key)))))



;;;; %SP-INTERNAL-APPLY

;;; %SP-INTERNAL-APPLY is called when the CALL macro-instruction
;;; runs into a function that is a CONS rather than a function object.
;;; This will normally be a lambda expression, but may also be a
;;; lexical closure structure.  Takes three arguments:
;;;   FUNCTION is the function that is to be evaluated.  This is
;;;       known to be a list, but may not be a legal lambda or closure.
;;;   NARGS is the number of arguments pushed on the calling frame.
;;;   FRAME is a pointer to the start of the frame where the arguments
;;;       are stashed.

(defun %sp-internal-apply (function nargs frame)
  (prog ((%venv% nil) (%fenv% nil) (%benv% nil) (%genv% nil)
	 (specials nil) (exp function) (next-arg 0)
	 body rest-of-varlist)
   RETRY
    ;; Make sure EXP is a Lambda, lexical closure, or Fexpr.
    ;; Strip off any FEXPR marker.
    (case (car exp)
      (lambda)
      ;; *** Inefficient. Eventually handle this in PUSH-LAST microcode. ***
      (%compiled-closure%
       (%sp-bind (cadr exp) '%lexical-environment%)
       (%sp-return-from
	(progn (%sp-call (caddr exp))
	       (dotimes (n nargs) (%sp-push (%primitive arg-in-frame n frame)))
	       (%sp-start-call))
	frame))
      (%lexical-closure%
       (setq %venv% (%lexical-closure%-venv exp))
       (setq %fenv% (%lexical-closure%-fenv exp))
       (setq %benv% (%lexical-closure%-benv exp))
       (setq %genv% (%lexical-closure%-genv exp))
       (setq exp (%lexical-closure%-fn exp))
       (go retry))
      (t (error "Illegal function object: ~S." exp)))
    (if (atom (cdr exp))
	(error "Ill-formed lambda expression: ~S." exp))
    ;; EXP is now a LAMBDA expression.  Do the variable binding.
    (setq body (cddr exp))
    (setq specials (extract-specials))
    ;; The following DO* handles required and optional args.  If
    ;; &rest, &key, or &aux are seen, break out of the loop.
    (do* ((varlist (cadr exp) (cdr varlist))
	  (optionalp nil)
	  var)
	((atom varlist)
	 ;; No more varlist, complain if there are unused args.
	 (cond ((= next-arg nargs) nil)
	       (t (cerror "Ignore the extra args."
			  "~S got ~S args, wanted at most ~S."
			  (extract-fn-name body) nargs next-arg))))
      (setq var (car varlist))
      (cond ((eq var '&optional)
	     (setq optionalp t))
	    ((eq var '&rest)
	     (setq rest-of-varlist (cdr varlist))
	     (go process-rest))
	    ((eq var '&aux)
	     (setq rest-of-varlist (cdr varlist))
	     ;; Make sure all args used up, then bind the auxen.
	     (if (not (= next-arg nargs))
		 (cerror "Ignore the extra args."
			 "~S got ~S args, wanted at most ~S."
			 (extract-fn-name body) nargs next-arg))
	     (go process-aux))
	    ((eq var '&key)
	     (setq rest-of-varlist (cdr varlist))
	     (go process-keys))
	    ((eq var '&allow-other-keys)
	     (error "Misplaced &ALLOW-OTHER-KEYS in function ~S."
		    (extract-fn-name body)))
	    ((symbolp var)
	     (cond ((< next-arg nargs)
		    (bind-var var (%primitive arg-in-frame next-arg frame))
		    (setq next-arg (1+ next-arg)))
		   (optionalp
		    (bind-var var nil))
		   (t (error "~S got ~S args, wanted at least ~S."
			     (extract-fn-name body) nargs
			     (do ((v varlist (cdr v))
				  (n next-arg (1+ n)))
				 ((or (atom v)
				      (memq (car v)
					    '(&optional &rest &key &aux)))
				  n))))))
	    ((atom var)
	     (error "Non-symbol used as a variable name in function ~S."
		    (extract-fn-name body)))
	    ((not optionalp)
	     (error "Non-symbol used as variable name in function ~S."
		    (extract-fn-name body)))
	    ((not (symbolp (car var)))
	     (error "Non-symbol used as variable name in function ~S."
		    (extract-fn-name body)))
	    ;; Variable is an optional list.  If we have an arg, use it.
	    ;; Then bind supplied-p variable, if any, to T.
	    ((< next-arg nargs)
	     (bind-var (car var) (%primitive arg-in-frame next-arg frame))
	     (setq next-arg (1+ next-arg))
	     (cond ((and (consp (cdr var)) (consp (cddr var)))
		    (unless (symbolp (caddr var))
			    (error
			     "Supplied-p variable not a symbol in function ~S."
			     (extract-fn-name body)))
		    (bind-var (caddr var) t))))
	    ;;; No arg, no default, just bind variable to nil.
	    ((atom (cdr var))
	     (bind-var (car var) nil))
	    ;;; Use default and bind supplied-p, if any, to nil.
	    (t (bind-var (car var)
			 (%eval (cadr var)))
	     (cond ((and (consp (cdr var)) (consp (cddr var)))
		    (unless (symbolp (caddr var))
			    (error
			     "Supplied-p variable not a symbol in function ~S."
			     (extract-fn-name body)))
		    (bind-var (caddr var) nil))))))
   PROCESS-BODY
    ;; Now process the body as a progn and return from caller's frame.
    (if (atom body) (%sp-return-from nil frame))
    (do ((bl body (cdr bl)))
	((atom (cdr bl))
	 (%sp-return-from (%eval (car bl)) frame))
      (%eval (car bl)))
   PROCESS-REST
    ;; Jump in here when we hit &rest.
    (when (or (atom rest-of-varlist)
	      (not (symbolp (car rest-of-varlist))))
	  (error "Ill-formed &rest arg in function ~S."
		 (extract-fn-name body)))
    ;; Listify the remaining args, but don't change Next-Arg count.
    (do ((rlist nil)
	 (n next-arg (1+ n)))
	((= n nargs)
	 (bind-var (car rest-of-varlist) (nreverse rlist)))
      (setq rlist (cons (%primitive arg-in-frame n frame) rlist)))
    ;; Figure out where to go next and jump there.
    (cond ((atom (cdr rest-of-varlist)) (go process-body))
	  ((eq (cadr rest-of-varlist) '&key)
	   (setq rest-of-varlist (cddr rest-of-varlist))
	   (go process-keys))
	  ((eq (cadr rest-of-varlist) '&aux)
	   (setq rest-of-varlist (cddr rest-of-varlist))
	   (go process-aux))
	  (t (error "Something illegal after &rest arg in function ~S."
		    (extract-fn-name body))))
   PROCESS-AUX
    ;; Jump here to process the &aux variables.
    (do ((vl rest-of-varlist (cdr vl)))
	((atom vl))
      (cond ((memq (car vl) '(&optional &rest &aux &key &allow-other-keys))
	     (error "~S misplaced keyword in ~S."
		    (car vl) (extract-fn-name body)))
	    ((atom (car vl))
	     (bind-var (car vl) nil))
	    ((atom (cdar vl))
	     (bind-var (caar vl) nil))
	    (t (bind-var (caar vl)
			 (%eval (cadar vl))))))
    (go process-body)
   PROCESS-KEYS
    ;; Jump here to process keywords.
    (when (oddp (- nargs next-arg))
	  (error "Unpaired keyword argument passed to ~S"
		 (extract-fn-name body)))
    ;; Step through remainder of varlist.  For each entry scan args on
    ;;  stack looking for a match.
    (do ((vl rest-of-varlist (cdr vl))
	 (check-keywords *maximum-interpreter-error-checking*)
	 (seen-keywords nil)
	 item var key init svar)
	((atom vl)
	 (if check-keywords (check-keywords-macro))
	 (go process-body))
      (setq item (car vl))
      (cond ((eq item '&aux)
	     (if check-keywords (check-keywords-macro))
	     (setq rest-of-varlist (cdr vl))
	     (go process-aux))
	    ((eq item '&allow-other-keys)
	     (setq check-keywords nil)
 	     (go skip))
	    ((memq item '(&optional &rest &key))
	     (error "~S misplaced keyword in ~S."
		    item (extract-fn-name body)))
	    ((symbolp item)
	     (setq var item key (keywordify-macro var)
		   init nil svar nil))
	    ((atom item)
	     (error "Non-symbol used as variable name in function ~S."
		    (extract-fn-name body)))
	    ((symbolp (car item))
	     (setq var (car item) key (keywordify-macro var))
	     (cond ((atom (cdr item))
		    (setq init nil svar nil))
		   ((atom (cddr item))
		    (setq init (cadr item) svar nil))
		   (t (setq init (cadr item) svar (caddr item)))))
	    ((and (consp (car item))
		  (symbolp (caar item))
		  (consp (cdar item))
		  (symbolp (cadar item)))
	     (setq key (caar item) var (cadar item))
	     (cond ((atom (cdr item))
		    (setq init nil svar nil))
		   ((atom (cddr item))
		    (setq init (cadr item) svar nil))
		   (t (setq init (cadr item) svar (caddr item)))))
	    (t (error "Ill-formed keyword specifier in function ~S."
		      (extract-fn-name body))))
      ;; Skip this cons if not checking keywords.
      (if check-keywords (push key seen-keywords))
      ;; Now see if this key is present among the args and bind it.
      (do ((n next-arg (+ n 2)))
	  ((= n nargs)
	   (bind-var var (%eval init))
	   (when svar (bind-var svar nil)))
	(when (eq key (%primitive arg-in-frame n frame))
	      (bind-var var (%primitive arg-in-frame (1+ n) frame))
	      (when svar (bind-var svar t))
	      (return nil)))
      SKIP)))



;;;; EVAL and friends.

(defun eval (exp)
  "Evaluates its single arg in a null lexical environment, returns the
  result or results."
  (let ((%venv% nil) (%fenv% nil) (%benv% nil) (%genv% nil))
    (%eval exp)))

(defun *eval (exp %venv% %fenv% %benv% %genv%)
  "Evaluates EXP and returns the result or results.  The additional
  arguments supply the lexical environment for the evaluation."
  (%eval exp))

(defvar *evalhook* nil
  "Used to substitute another function for EVAL, for use by STEP, etc.
  If *EVALHOOK* is not NIL, its value must be a function of the same
  form as *EVAL.  This function does the evaluation instead of EVAL.")

(defvar *applyhook* nil
  "Used to substitute another function for the implicit APPLY normally done
  within EVAL.  If *APPLYHOOK* is not NIL, its value must be a function 
  which takes as arguments the function to be applied, the list of arguments
  it is to be applied to, and additional environment arguments suitable for
  passing to *EVAL.  This function does the application instead of EVAL.")

(defvar *skip-evalhook* nil
  "Used with non-null *EVALHOOK* to suppress the use of the hook-function
  for one level of eval.")

(defvar *skip-applyhook* nil
  "Used with non-null *APPLYHOOK* to suppress the use of the hook function
  for one level of eval.")

(defun evalhook (form evalhookfn applyhookfn
		 %venv% %fenv% %benv% %genv%)
  "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound
  to applyhookfn.  Ignores these hooks once, for the top-level evaluation
  of Form."
  (let ((*evalhook* evalhookfn) (*skip-evalhook* t)
	(*applyhook* applyhookfn) (*skip-applyhook* nil))
    (%eval form)))

(defun applyhook (function args evalhookfn applyhookfn
		  %venv% %fenv% %benv% %genv%)
  "Applies Function to Args, with *Evalhook* bound to Evalhookfn and with
  *Applyhook* bound to Applyhookfn.  Ignores the hook function once, for the
  top-level application of Function to Args."
  (let ((*evalhook* evalhookfn) (*skip-evalhook* nil)
	(*applyhook* applyhookfn) (*skip-applyhook* t))
    (apply function args)))



(defun %eval (exp)
  "Internal evaluation routine.  Gets its lexical environment from the
  special variables %VENV%, etc.  Evaluates its single arg and returns
  the result or results."
  (cond ((and *evalhook*
	      (not (prog1 *skip-evalhook* (setq *skip-evalhook* nil))))
	 (let ((hookfn *evalhook*) (*evalhook* nil))
	   (funcall hookfn exp %venv% %fenv% %benv% %genv%)))
	((symbolp exp)
	 (let ((slot (assq exp %venv%)))
	   (cond ((or (null slot)
		      (eq (cdr slot) '%internal-special-marker%))
		  (symbol-value exp))
		 ;; Just like a macro, below.
		 ((%sym-mac-binding%-p (cdr slot))
		  (%eval (%sym-mac-binding%-function (cdr slot))))
		 (t (cdr slot)))))
	((or (numberp exp) (stringp exp)
	     (characterp exp) (bit-vector-p exp))
	 exp)
	((not (consp exp))
	 (error "~S -- invalid form for EVAL." exp))
	((symbolp (car exp))
	 (let ((slot (assq (car exp) %fenv%)))
	   (cond (slot
		  (cond ((eq (cadr slot) 'function)
			 (%invoke (cddr slot) (cdr exp)))
			;; It must be a macro.
			(t (%eval (%invoke1 (cddr slot) exp)))))
		 ((compiled-function-p
		   (setq slot (symbol-function (car exp))))
		  (cond ((not (fexprp slot))
			 (%invoke slot (cdr exp)))
			(t (%invoke1 slot (cdr exp)))))
		 ((not (consp slot))
		  (error "~S has illegal function definition." (car exp)))
		 ((eq (car slot) 'lambda)
		  (%invoke slot (cdr exp)))
		 ((eq (car slot) 'macro)
		  (%eval (%macroexpand exp)))
		 (t (%invoke slot (cdr exp))))))
	;; Turn car-position lambda into lexical closure.
	((eq (caar exp) 'lambda)
	 (%invoke (make-lexical-closure (car exp)) (cdr exp)))
	;; Car of expression is a list of some other sort.
	;; Let %sp-internal-apply deal with it.
	(t (%invoke (car exp) (cdr exp)))))


;;;; TOP-LEVEL loop.

(defvar / nil
  "Holds a list of all the values returned by the most recent top-level EVAL.")
(defvar // nil "Gets the previous value of / when a new value is computed.")
(defvar /// nil "Gets the previous value of // when a new value is computed.")
(defvar * nil "Holds the value of the most recent top-level EVAL.")
(defvar ** nil "Gets the previous value of * when a new value is computed.")
(defvar *** nil "Gets the previous value of ** when a new value is computed.")
(defvar + nil "Holds the value of the most recent top-level READ.")
(defvar ++ nil "Gets the previous value of + when a new value is read.")
(defvar +++ nil "Gets the previous value of ++ when a new value is read.")
(defvar - nil "Holds the form curently being evaluated.")
(defvar *prompt* nil "The top-level prompt string.")
(defvar %temp% nil "Random temporary, clobbered by top level loop.")

(defun %top-level ()
  "Top-level READ-EVAL-PRINT loop.  Do not call this."
  (let  ((this-eval nil) (* nil) (** nil) (*** nil)
	 (- nil) (+ nil) (++ nil) (+++ nil)
	 (/// nil) (// nil) (/ nil) (%temp% nil))
    (prog ()
      OUTER-LOOP
      (catch 'top-level-catcher
	(progn
	 ;; Prevent the user from irrevocably wedging the hooks.
	 (setq *evalhook* nil)
	 (setq *applyhook* nil)
	   (prog ()
	    INNER-LOOP
	    (terpri)
	    (princ *prompt*)
	    (setq +++ ++ ++ + + - - (read))
	    (setq this-eval (multiple-value-list (eval -)))
	    (dolist (x this-eval)
	      (print x))
	    (setq /// // // / / this-eval)
	    (setq %temp% (car this-eval))
	    ;; Make sure nobody passes back an unbound marker.
	    (unless (boundp '%temp%)
		    (setq %temp% nil)
		    (cerror "Go on, but set * to NIL."
			    "Eval returned an unbound marker."))
	    (setq *** ** ** * * %temp%)
	    (go inner-loop))))
      (go outer-loop))))


;;;; Random special forms.

;;; Assorted functions open-coded by the compiler but needed by the
;;; interpreter. 

(defun quote fexpr (x)
  "Returns its single argument without evaluating it."
  (car x))


(defun comment fexpr (ignore)
  "The arguments are not evaluated and are ignored."
  (declare (ignore ignore))
  nil)


(defun proclaim (proclamation)
  "PROCLAIM is a top-level form used to pass assorted information to the
  compiler.  This interpreter ignores proclamations except for those
  declaring variables to be SPECIAL."
  (if (and (listp proclamation) (eq (car proclamation) 'special))
      (do ((vars (cdr proclamation) (cdr vars)))
	  ((atom vars))
	  (and (symbolp (car vars))
	       (%put (car vars) 'globally-special t)))))

(defun unproclaim (proclamation)
  "Undoes the effect of certain proclamations."
  (if (and (listp proclamation) (eq (car proclamation) 'special))
      (do ((vars (cdr proclamation) (cdr vars)))
	  ((atom vars))
	  (and (symbolp (car vars))
	       (remprop (car vars) 'globally-special)))))


(defun eval-when fexpr (x)
  "Syntax is (EVAL-WHEN control-list forms).  If the control list contains
  the symbol EVAL, the forms are evaluated by the interpreter.  If the
  control list contains COMPILE, the forms are evaluated within the compiler.
  If the control list contains LOAD, the compiler arranges for the forms to
  be evaluated when the compiled file is loaded."
  (cond ((not (memq 'eval (car x))) nil)
	(t (eval-as-progn (cdr x)))))


(defun eval-as-progn (x)
  (cond ((atom x) nil)
	(t (do ((forms x (cdr forms)))
	       ((atom (cdr forms))
		(%eval (car forms)))
	     (%eval (car forms))))))


(defun progn fexpr (x)
  "Evaluates the forms in order, returning the value(s) of the last one."
  (cond ((atom x) nil)
	(t (do ((forms x (cdr forms)))
	       ((atom (cdr forms))
		(%eval (car forms)))
	     (%eval (car forms))))))


(defun prog1 fexpr (x)
  "Evlautes the forms in order, returning the value(s) of the first one."
  (cond ((atom x)
	 (cerror "Return NIL from this form."
		 "Prog1 with no forms."))
	(t (do ((value (%eval (car x)))
		(forms (cdr x) (cdr forms)))
	       ((atom forms) value)
	     (%eval (car forms))))))


(defun prog2 fexpr (x)
  "Evaluates the forms in order, returning the value(s) of the second one."
  (cond ((or (atom x) (atom (cdr x)))
	 (cerror "Return NIL from this form."
		 "Prog2 with 0 or 1 form."))
	(t (%eval (car x))
	   (do ((value (%eval (cadr x)))
		(forms (cddr x) (cdr forms)))
	       ((atom forms) value)
	     (%eval (car forms))))))


(defun let* fexpr (x)
  "First sub-form is a list of (variable initialization) pairs.
  Initializes the variables left to right, then executes the
  remaining forms as in a PROGN."
  (let ((%venv% %venv%) (body (cdr x)))
    (do* ((specials (extract-specials))
	  (let-list (car x) (cdr let-list)))
	 ((atom let-list))
       (cond ((and (consp (car let-list)) (symbolp (caar let-list)))
	      (bind-var (caar let-list) (%eval (cadar let-list))))
	     ((symbolp (car let-list))
	      (bind-var (car let-list) nil))
	     (t (error "Ill formed variable list in LET*."))))
    (eval-as-progn body)))


(defun let fexpr (x)
  "First sub-form is a list of (variable initialization) pairs.
  Initializes the variables, binding them to new values all at once,
  then executes the remaining forms as in a PROGN."
  (let* ((%venv% %venv%)
	 (body (cdr x))
	 (specials (extract-specials)))
    ;; Compute values and push them with the variables that get them.
    ;; Push a marker first so we know when to stop.
    (%sp-push '%let-marker%)
    (do ((let-list (car x) (cdr let-list)))
	((atom let-list))
      (cond ((and (consp (car let-list)) (symbolp (caar let-list)))
	     (%sp-push (%eval (cadar let-list)))
	     (%sp-push (caar let-list)))
	    ((symbolp (car let-list))
	     (%sp-push nil)
	     (%sp-push (car let-list)))
	    (t (error "~S -- Non-symbol being used as a LET variable."
		      (car let-list)))))
    ;; Now pop and bind the pairs.
    (do ((symbol (%sp-pop) (%sp-pop))
	 (value))
	((eq symbol '%let-marker%))
      (setq value (%sp-pop))
      (bind-var symbol value))
  ;; Evaluate the body forms.
  (eval-as-progn body)))


(defun progv fexpr (x)
  "First arg evaluates to a list of variables.  Second arg evaluates to a
  list of initial values.  Everything after that is body.  Evaluate the
  body with the variables bound (as specials) to the corresponding values."
  (let ((%venv% %venv%))
    (do ((varlist (%eval (car x)) (cdr varlist))
	 (arglist (%eval (cadr x)) (cdr arglist)))
	((null varlist))
      (push (cons (car varlist) '%internal-special-marker%) %venv%)
      (if arglist
	  (%sp-bind (car arglist) (car varlist))
	  (progn (%sp-bind nil (car varlist))
		 (makunbound (car varlist)))))
    (eval-as-progn (cddr x))))


(defun and fexpr (x)
  "Evaluate the sub-forms in order, left to right.  If any eval to nil, quit
  and return nil.  Else, return the value(s) of the last sub-form."
  (if (atom x) t
      (do ((clauses x (cdr clauses)))
	  ((atom (cdr clauses)) (%eval (car clauses)))
	(if (null (%eval (car clauses)))
	    (return nil)))))


(defun or fexpr (x)
  "Evaluate the sub-forms in order, left to right.  If any eval to
  non-nil, quit and return that (single) value.  If the last form
  is reached, return whatever value(s) it returns."
  (if (atom x) nil
      (do ((clauses x (cdr clauses))
	   value)
	  ((atom (cdr clauses))
	   (%eval (car clauses)))
	(if (setq value (%eval (car clauses)))
	    (return value)))))


(defun cond fexpr (x)
  "Syntax is (COND (pred1 forms) (pred2 forms) ...)
  Evaluate each predicate in order until one evaluates to non-nil.
  Then evaluate the associated forms in order returning the value
  of the last one.  If no predicate wins, return nil."
  (do ((clauses x (cdr clauses))
       value)
      ((atom clauses) nil)
    (cond ((atom (car clauses))
	   (error "~S -- Illegal atomic clause in COND." (car clauses)))
	  ((setq value (%eval (caar clauses)))
	   (cond ((atom (cdar clauses)) (return value))
		 (t (return (eval-as-progn (cdar clauses)))))))))


(defun if fexpr (x)
  "Syntax is (IF predicate then [else]).  If the predicate
  evaluates to non-null, eval the Then clause and return the result.
  If not, eval and return the Else clause, which defaults to Nil."
  (if (%eval (car x))
      (%eval (cadr x))
      (and (caddr x) (%eval (caddr x)))))


(defun the fexpr (x)
  "Declares that Object must be of specified Type, complains if this is not
  the case."
  (prog ((obj (%eval (cadr x))))
    RETRY
    (cond ((typep obj (car x))
	   (return obj))
	  (t (cerror
	      "Prompt for a new object."
	      "Object ~S is not of type ~S."
	      obj (car x))
	     (terpri)
	     (princ "New object of proper type: ")
	     (setq obj (read))
	     (go retry)))))


(defun macro-function (symbol)
  "If the symbol globally names a macro, returns the expansion function,
  else returns NIL."
  (let ((temp))
    (and (fboundp symbol)
	 (consp (setq temp (symbol-function symbol)))
	 (eq (car temp) 'macro)
	 (cdr temp))))

;;; The following two should be ripped out at some future time.

(defun macro-p (symbol)
  "Obsolete form kept around until conversion to Macro-Function is complete."
  (macro-function symbol))

(defun macrop (symbol)
  "Obsolete form kept around until conversion to Macro-Function is complete."
  (macro-function symbol))

(defun special-form-p (symbol)
  "If the symbol globally names a special form, returns the definition in a
  mysterious internal format (a FEXPR), else returns NIL."
  (let ((temp))
    (cond ((not (fboundp symbol)) nil)
	  ((and (compiled-function-p (setq temp (symbol-function symbol)))
		(fexprp temp))
	   temp)
	  ((and (listp temp) (eq (car temp) 'fexpr))
	   (cdr temp))
	  (t nil))))


(defvar *macroexpand-hook* 'funcall
  "The value of this variable must be a function that can take two
  arguments, a macro expander function and the macro form to be expanded,
  returning the expanded form.  This function is called by MACROEXPAND-1
  whenever a runtime expansion is needed.  Initially this is set to
  FUNCALL.  To turn memoization on, set it to MEMOIZE-MACRO-CALL.")


(defun macroexpand-1 (form &optional %venv% %fenv% %benv% %genv%)
  "If form is a macro, expands it once.  Returns two values, the
  expanded form and a T-or-NIL flag indicating whether the form was,
  in fact, a macro."
  (%macroexpand-1 form))

(defun %macroexpand-1 (form)
  "Does Macroexpand-1 in the current lexical environment."
  (let (temp)
    (cond ((not (listp form)) (values form nil))
	  ((not (symbolp (car form))) (values form nil))
	  ((setq temp (macro-function (car form)))
	   (values (funcall *macroexpand-hook* temp form) t))
	  (t (values form nil)))))


(defun macroexpand (form &optional %venv% %fenv% %benv% %genv%)
  "If form is a macro, expands it repeatedly until it is not a macro
  any more.  Returns two values: the expanded form and a T-or-NIL
  flag that indicates whether the original form was a macro."
  (%macroexpand form))

(defun %macroexpand (form)
  "Does a macroexpand in the current lexical environment."
  (prog (flag)
    (multiple-value-setq (form flag) (%macroexpand-1 form))
    (or flag (return (values form nil)))
    loop
    (multiple-value-setq (form flag) (%macroexpand-1 form))
    (if flag (go loop) (return (values form t)))))


(defun constantp (object)
  "True of any Lisp object that has a constant value: types that eval to
  themselves, keywords, constants, and list whose car is QUOTE."
  (typecase object
    (number t)
    (character t)
    (string t)
    (bit-vector t)
    (symbol (or (eq object nil)
		(eq object t)
		(get object '%constant)
		(keywordp-macro object)))
    (list (eq (car object) 'quote))))


(defun %get-key (list key)
  "Called by compiled functions with keyword args.  CDDR down List looking
  for KEY.  If it is found, return the list fragment following the keyword.
  Else, return NIL."
  (do ((l list (cddr l)))
      ((null l) nil)
    (cond ((null (cdr l))
	   (cerror "Stick a NIL on the end and go on."
		   "Unpaired item in keyword portion of call.")
	   (rplacd l (list nil))
	   (return nil))
	  ((eq (car l) key)
	   (return (cdr l))))))


;;;; Block, Tagbody, and friends.

(defun block fexpr (body)
  "Syntax is (BLOCK name . body).  The body is evaluated as a PROGN, but
  it is possible to exit the block using (RETURN-FROM name value).  The
  RETURN-FROM must be lexically contained within the block."
  (let ((slot (list (car body))))
    (unwind-protect
     (catch slot
	    (let ((%benv% (cons slot %benv%)))
	      (eval-as-progn (cdr body))))
     (rplacd slot 'invalid))))


(defun return-from fexpr (args)
  "The first argument names a lexically surrounding block, perhaps
  implicitly created by a defun.  The second argument is a form to
  be evaluated and returned as the value of this block."
  (let ((slot (assq (car args) %benv%)))
    (cond ((null slot)
	   (error "~S unseen block name in RETURN-FROM." (car args)))
	  ((eq (cdr slot) 'invalid)
	   (error "No longer in block ~S, cannot return from it." (car args)))
	  ((atom (cdr args)) (throw slot nil))
	  (t (throw slot (%eval (cadr args)))))))


(defun return fexpr (val)
  "Equivalent to RETURN-FROM with a block-name of NIL."
  (let ((slot (assq nil %benv%)))
    (cond ((null slot)
	   (error "Not inside a block named NIL."))
	  ((eq (cdr slot) 'invalid)
	   (error "No longer in block NIL, cannot return from it."))
	  ((atom val) (throw slot nil))
	  (t (throw slot (%eval (car val)))))))


(defun tagbody fexpr (body)
  "The body is executed and returns NIL if it falls off the end."
  (let* ((%genv% %genv%) (marker (list nil)))
    ;; Pre-scan to find all the tags.  Saves time in loops.
    (do ((b body (cdr b)))
	((atom b))
      (if (atom (car b))
	  (push (list* (car b) marker (cdr b)) %genv%)))
    ;; Now execute the body.
    (unwind-protect
     (prog ()
      LOOP
      (setq body (catch marker
		   (do ((b body (cdr b)))
		       ((atom b) nil)
		     (or (atom (car b))
			 (%eval (car b))))))
       (when body (go loop)))
     (rplaca marker 'invalid))))


(defun go fexpr (tag)
  "Go to the specified tag in the lexically surrounding tagbody."
  (let ((slot (assq (car tag) %genv%)))
    (cond ((null slot)
	   (error "~S unseen GO tag." (car tag)))
	  ((eq (caadr slot) 'invalid)
	   (error "Cannot go to ~S, its body has been exited." (car tag)))
	  (t (throw (cadr slot) (cddr slot))))))


(defun prog fexpr (stuff)
  "Prog binds local variables in parallel, creates a block with name NIL,
  and then evaluates the body as in a tagbody.  Therefore, GO and RETURN
  work within a PROG."
  (let* ((%venv% %venv%)
	 (body (cdr stuff))
	 (slot (list nil))
	 (marker (list nil))
	 (specials (extract-specials)))
    ;; Bind vars as for a LET.
    (%sp-push nil)
    (do ((let-list (car stuff) (cdr let-list)))
	((atom let-list))
      (cond ((and (consp (car let-list)) (symbolp (caar let-list)))
	     (%sp-push (%eval (cadar let-list)))
	     (%sp-push (caar let-list)))
	    ((symbolp (car let-list))
	     (%sp-push nil)
	     (%sp-push (car let-list)))
	    (t (error "~S -- Bad object in PROG variable list."
		      (car let-list)))))
    (do ((symbol (%sp-pop) (%sp-pop))
	 (value))
	((null symbol))
      (setq value (%sp-pop))
      (bind-var symbol value))
    ;; Now set up BLOCK and TAGBODY.
    (unwind-protect
     (catch slot
       (prog ((%benv% (cons slot %benv%))
	      (%genv% %genv%))
	 ;; Pre-scan for tags.
	 (do ((b body (cdr b)))
	     ((atom b))
	   (if (atom (car b))
	       (push (list* (car b) marker (cdr b)) %genv%)))
	 ;; Now do body forms.
	 LOOP
	 (setq body (catch marker
		      (do ((b body (cdr b)))
			  ((atom b) nil)
			(or (atom (car b))
			    (%eval (car b))))))
	 (when body (go loop))))
     (rplacd slot 'invalid)
     (rplaca marker 'invalid))))


(defun prog* fexpr (stuff)
  "Prog* is like Prog, but binds its variables sequentially."
  (let* ((%venv% %venv%)
	 (body (cdr stuff))
	 (slot (list nil))
	 (marker (list nil))
	 (specials (extract-specials)))
    ;; Bind vars as for a LET*.
    (do ((let-list (car stuff) (cdr let-list)))
	((atom let-list))
      (cond ((and (consp (car let-list)) (symbolp (caar let-list)))
	     (bind-var (caar let-list) (%eval (cadar let-list))))
	    ((symbolp (car let-list))
	     (bind-var (car let-list) nil))
	    (t (error "Ill formed variable list in PROG*."))))
    ;; Now set up BLOCK and TAGBODY.
    (unwind-protect
     (catch slot
       (prog ((%benv% (cons slot %benv%))
	      (%genv% %genv%))
	 ;; Pre-scan for tags.
	 (do ((b body (cdr b)))
	     ((atom b))
	   (if (atom (car b))
	       (push (list* (car b) marker (cdr b)) %genv%)))
	 ;; Now do body forms.
	 LOOP
	 (setq body (catch marker
		      (do ((b body (cdr b)))
			  ((atom b) nil)
			(or (atom (car b))
			    (%eval (car b))))))
	 (when body (go loop))))
     (rplacd slot 'invalid)
     (rplaca marker 'invalid))))


;;; Catch and friends.

(defun catch fexpr (stuff)
  "Used to set up dynamic gotos.  See manual for details."
  (catch (%eval (car stuff))
    (eval-as-progn (cdr stuff))))


(defun unwind-protect fexpr (stuff)
  (unwind-protect
    (%eval (car stuff))
    (eval-as-progn (cdr stuff))))


(defun throw fexpr (stuff)
  "Initiates a non-local goto.  See manual for details."
  (throw (%eval (car stuff)) (%eval (cadr stuff))))

;;; Function invocation:

(defun apply (function arg &rest args)
  "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
  the manner of LIST*.  That is, a list is made of the values of all but the
  last argument, appended to the value of the last argument, which must be a
  list."
  (cond ((atom args)
	 (apply function arg))
	((atom (cdr args))
	 (apply function (cons arg (car args))))
	(t (do* ((a1 args a2)
		 (a2 (cdr args) (cdr a2)))
		((atom (cdr a2))
		 (rplacd a1 (car a2))
		 (apply function (cons arg args)))))))


(defun funcall (function &rest arguments)
  "Calls Function with the given Arguments."
  (apply function arguments))



;;; Multiple-Value forms:

(defun values (&rest values)
  "Returns all of its arguments, in order, as values."
  (values-list values))

(defun values-list (list)
  "Returns all of the elements of List, in order, as values."
  (values-list list))

(defun multiple-value-list fexpr (form)
  "Evaluates Form, and returns a list of multiple values it returned."
  (multiple-value-list (%eval (car form))))


(defun multiple-value-call fexpr (stuff)
  "Calls Function with the values of all of the Forms as arguments."
  (do ((function (%eval (car stuff)))		; in case of side effects
       (forms (cdr stuff) (cdr forms))
       (arglist ()))
      ((atom forms)
       (apply function arglist))
    (setq arglist
	  (nconc arglist (multiple-value-list (%eval (car forms)))))))


(defun multiple-value-prog1 fexpr (stuff)
  "Evaluates the first Form, saves the values returned, then evaluates the
   rest of the forms, discarding their values.  Returns the results of the
   first form."
   (multiple-value-prog1 (%eval (car stuff))
			 (eval-as-progn (cdr stuff))))


(defun multiple-value-bind fexpr (x)
  "Form is (MULTIPLE-VALUE-BIND var-list values-form . body).
  Binds the variables in Var-List to the results of the Values-Form,
  in order (defaulting to nil) and evaluates each form in the Body."
  (let ((%venv% %venv%)
	(body (cddr x)))
    (do* ((vals (multiple-value-list (%eval (cadr x))) (cdr vals))
	  (specials (extract-specials))
	  (let-list (car x) (cdr let-list)))
	 ((atom let-list))
       (bind-var (car let-list) (car vals)))
    (eval-as-progn body)))



;;;; DEFUN and friends.

(defun function fexpr (x)
  "If argument is a lambda expression, create a closure of it in the
  current lexical environment.  If it is a symbol that names a function,
  return that function."
  (let ((fn (car x)))
    (cond ((and (consp fn) (eq (car fn) 'lambda))
	   (if (or %venv% %fenv% %benv% %genv%)
	       (make-lexical-closure fn)
	       fn))
	  ((symbolp fn)
	   (let ((slot (assq fn %fenv%)))
	     (cond (slot
		    (if (eq (cadr slot) 'function)
			(cddr slot)
			(error "~S names a macro -- bad arg for FUNCTION."
			       fn)))
		   ((not (fboundp fn))
		    (error "~S is unbound -- bad arg for FUNCTION." fn))
		   ((macro-function fn)
		    (error "~S names a macro -- bad arg for FUNCTION." fn))
		   ((special-form-p fn)
		    (error "~S names a special form -- bad arg for FUNCTION."
			   fn))
		   (t (symbol-function fn)))))
	  (t (error "~S is not a valid argument for FUNCTION." fn)))))
	

;;; Note: (DEFUN foo FEXPR ...) not supported in the interpreter.

(defun defun fexpr (x)
  "Used to create a new function as the global functional definition of
  some symbol.  Format is (DEFUN name varlist . body)."
  (let* ((name (car x))
	 (varlist (cadr x))
	 (parse (parse-body (cddr x)))
	 (decls (car parse))
	 (doc (cadr parse))
	 (body (caddr parse)))
    (if doc (%put name '%fun-documentation doc))
    (setq body `(lambda ,varlist ,@decls (block ,name ,@body)))
    (if (or %venv% %fenv% %benv% %genv%)
	(setq body (make-lexical-closure body)))
    (remprop name 'macro-in-compiler)
    (setf (symbol-function name) body)
    name))


(defun macro fexpr (x)
  "Internal form used to define new macros.  Syntax like DEFUN, but takes
  only one arg which is bound to the entire calling form.  For better style
  use DEFMACRO instead of MACRO."
  (let* ((name (car x))
	 (body (cdr x))
	 (doc (extract-doc-string (cdr body))))
    (if doc (%put name '%fun-documentation doc))
    (remprop name 'macro-in-compiler)
    (setf (symbol-function name) `(macro lambda ,@body))
    name))


;;;; Labels and friends.

(defun flet fexpr (x)
  "First arg is list of function definitions in form (name lambda-list . body).
  This list is followed any number of additional forms to be evaluated as a
  Progn with the local function definitions in effect.  The scope of
  the locally defined functions does not include the function definitions
  themselves, so they can reference externally defined functions of the same
  name."
  (let ((%fenv% %fenv%))
    (do ((defs (car x) (cdr defs))
	 (new-env %fenv%))
	((atom defs)
	 (setq %fenv% new-env)
	 (eval-as-progn (cdr x)))
      (push (list* (caar defs)
		   'function
		   (make-lexical-closure (cons 'lambda (cdar defs))))
	    new-env))))

;;; For labels, we push null definitions on temporarily, then fill in the
;;; actual functions.

(defun labels fexpr (x)
  "First arg is list of function definitions in form (name lambda-list . body).
  This list is followed any number of additional forms to be evaluated as a
  Progn with the local function definitions in effect.  The scope of
  the locally defined functions includes the function definitions
  themselves, so they can reference one another."
  (let ((%fenv% %fenv%))
    (dolist (def (car x))
      (push (cons (car def) nil) %fenv%))
    (do ((defs (car x) (cdr defs)))
	((atom defs)
	 (eval-as-progn (cdr x)))
      (setf (cdr (Assoc (caar defs) %fenv%))
	    (cons 'function
		  (make-lexical-closure (cons 'lambda (cdar defs))))))))


(defun macrolet fexpr (x)
  "First arg is list of macro definitions in form (name varlist . body),
  analogous to the varlist and body of a defmacro.  This list of definitions
  is followed by the Macrolet form's body.  This is evaluated as a
  progn, but with the local macro definitions in effect."
  (let ((%fenv% %fenv%))
    (do ((defs (car x) (cdr defs))
	 (new-env %fenv%))
	((atom defs)
	 (setq %fenv% new-env)
	 (eval-as-progn (cdr x)))
      (push (list* (caar defs)
		   'macro
		   (cons 'lambda (cddr (%macroexpand
					(cons 'defmacro (car defs))))))
	    new-env))))


(defun compiler-let fexpr (x)
  "In the interpreter, works just like a LET with all variables implicitly
  declared special.  In the compiler, processes the forms in the body
  with the variables rebound in the compiler environment. No declarations
  are allowed."
  (let ((varlist (car x))
	(body (cdr x)))
   (%eval
    `(let ,varlist
       (declare (special
	         ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) varlist)))
       ,@body))))



;;;; Setq and friends.

(defun setq fexpr (x)
  "The first arg is not evaluated and must be a symbol.  The second arg is
  an expression which is evaluated to get a new value for that symbol.
  Additional alternating symbols and values may be present.  These are
  evaluated left-to-right.  The final value is returned from the SETQ."
  (do ((pairs x (cddr pairs))
       (var nil)
       (value nil))
      ((atom pairs) value)
    (setq var (car pairs))
    (cond ((atom (cdr pairs))
	   (error "Setq with odd number of args."))
	  ((not *maximum-interpreter-error-checking*))
	  ((not (typep var 'symbol))
	   (error "Cannot setq ~S -- not a symbol." var))
	  ((keywordp-macro var)
	   (error "Cannot setq ~S -- it is a keyword." var))
	  ((or (eq var t) (eq var nil))
	   (error "Cannot setq ~S -- it is a constant." var))
	  ((get var '%constant)
	   (cerror "Set it anyway."
		   "Cannot setq ~S -- it is a constant."  var)))
    (setq value (%eval (cadr pairs)))
    (let ((slot (assq var %venv%)))
      (cond ((or (null slot) (eq (cdr slot) '%internal-special-marker%))
	     (set var value))
	    ((%sym-mac-binding%-p (cdr slot))
	     (%eval `(setf ,(%sym-mac-binding%-function (cdr slot))
			   ',value)))
	    (t (rplacd slot value))))))

(defun psetq fexpr (x)
  "Parallel SETQ.  Takes any number of symbols and values like a SETQ,
  but evaluates all the values first, then sets all of the symbols to new
  values at once.  Returns NIL."
  (%sp-push nil)
  ;; The NIL marks the end of symbol value pairs on the stack.
  (do ((pair-list x (cddr pair-list))
       (var nil))
      ((atom pair-list))
    (setq var (car pair-list))
    (cond ((atom (cdr pair-list))
	   (error "Psetq with odd number of args."))
	  ((not *maximum-interpreter-error-checking*))
	  ((not (typep var 'symbol))
	   (error "Cannot setq ~S -- not a symbol." var))
	  ((or (eq var t) (eq var nil) (get var '%constant))
	   (error "Cannot setq ~S -- it is a constant." var))
	  ((keywordp-macro var)
	   (error "Cannot setq ~S -- it is a keyword." var)))
    (%sp-push (%eval (cadr pair-list)))
    (%sp-push (car pair-list)))
  (do ((symbol (%sp-pop) (%sp-pop))
       (value))
      ((null symbol) nil)
    (setq value (%sp-pop))
    (let ((slot (assq symbol %venv%)))
      (cond ((or (null slot) (eq (cdr slot) '%internal-special-marker%))
	     (set symbol value))
	    ((%sym-mac-binding%-p (cdr slot))
	     (%eval `(setf ,(%sym-mac-binding%-function (cdr slot))
			   ',value)))
	    (t (rplacd slot value))))))


(defun multiple-value-setq fexpr (stuff)
  "Sets each variable in the list of Variables to the corresponding value of
   the Form."
  (do* ((values (multiple-value-list (%eval (cadr stuff))) (cdr values))
	(first-value (car values))
	(variables (car stuff) (cdr variables))
	var value)
       ((atom variables) first-value)
    (setq var (car variables))
    (cond ((not *maximum-interpreter-error-checking*))
	  ((not (typep var 'symbol))
	   (error "Cannot setq ~S -- not a symbol." var))
	  ((or (eq var t) (eq var nil) (get var '%constant))
	   (error "Cannot setq ~S -- it is a constant." var))
	  ((keywordp-macro var)
	   (error "Cannot setq ~S -- it is a keyword." var)))
    (setq value (car values))
    (let ((slot (assq var %venv%)))
      (cond ((or (null slot) (eq (cdr slot) '%internal-special-marker%))
	     (set var value))
	    ((%sym-mac-binding%-p (cdr slot))
	     (%eval `(setf ,(%sym-mac-binding%-function (cdr slot))
			   ',value)))
	    (t (rplacd slot value))))))    



;;; Symbol macros.  There are minor additions to functions above, including
;;; %eval, setq, psetq, and multiple-value-setq.  


(Defun symbol-macro-let fexpr (form)
  "Better called a symbol replacement.  The 'binding' is a form to be textually
  substituted for a free reference to that symbol.  This may be used in
  conjunction with macros, for more powerful uses.  Use wisely or not at all."
  (do ((bindings (car form) (cdr bindings))
       (venv-bindings %venv%))
      ((atom bindings)
       (let ((%venv% venv-bindings))
	 (eval-as-progn (cdr form))))
    (let ((binding (car bindings)))
      (push (cons (car binding)
		  (make-%sym-mac-binding% :function (cadr binding)))
	    venv-bindings))))