Path: utzoo!utgpu!jarvis.csri.toronto.edu!rutgers!tut.cis.ohio-state.edu!ucbvax!bloom-beacon!ai-lab!jba
From: jba@wheaties.ai.mit.edu (Jonathan Amsterdam)
Newsgroups: alt.sources
Subject: AAL sources (7 of 8)
Message-ID: <2918@wilde.ai.mit.edu>
Date: 10 Jun 89 21:33:16 GMT
Distribution: alt
Organization: MIT AI Lab, Cambridge, MA
Lines: 652


;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-

;;; Interpreter for AAL.
;;; Copyright 1988 by Jonathan Amsterdam.  All Rights Reserved.

(provide 'interp)
(require 'initial "initial.lisp")
(require 'streams "streams.lisp")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The main loop of the adventure system:
;;; 1. Run all expired BEFORE-TICK timers.
;;; 2. If between turns, run all expired BEFORE-TURN timers.
;;; 3. If between turns, prompt for command and parse input.
;;; 4. Do the requested command.
;;; 5. Increment TICK.
;;; 6. Run all expired AFTER-TICK timers.
;;; 7. If the command's duration has not expired, goto step 1.
;;; 8. Increment TURN.
;;; 9. Run all expired AFTER-TURN timers.

;;; Ticks measure time passage in the game.  Turns just measure the player's
;;; inputs; a turn may take 0, 1 or several ticks.  For zero-tick turns, the
;;; tick timers are not run, but the turn timers are. 

;;; NOTE: This whole turn/tick distinction and its implementation needs to be
;;; rethought.  It theory it's a nice idea to be able to have turns take longer
;;; than one time unit.  You might want to have a walk down a long hall to take
;;; longer than just going through a doorway, or have filling a gallon jug from
;;; a spigot take longer than filling a cup.  The problem is that it's hard to
;;; actually spread out the execution of a command over an extended amount of
;;; time.  Instead, it's modelled here by doing the action all at once, then
;;; counting off the time.  This can differ from the "right" way when timers go
;;; off during the time of the action.  Take the spigot case: say a timer goes
;;; off at some point, shutting off the supply to the spigot.  If the shutoff
;;; occurs in the middle of an action, the player should get an amount of
;;; liquid proportional to the portion of the action completed; but in this
;;; implementation, the player would get the full amount of liquid.
;;;    Another problem, easier to solve, is that in this implementation
;;; durations are numbers associated with commands; so the "n" command can only
;;; have one duration.  As the above examples make clear, the duration should
;;; be a function of all the things involved in the command.

(defun run ()
  (let ((action-duration 1)
	(tick-to-resume 0))
    (catch 'end-game
      (loop
        (unless (= action-duration 0)
	  (run-expired-timers :before :tick))
	(when (or *abort-action* (>= *tick* tick-to-resume))
	  (setq *abort-action* nil)
	  (run-expired-timers :before :turn)
	  (setq action-duration (input-and-act))
	  (setq tick-to-resume (+ action-duration *tick*)))
	(unless (= action-duration 0)
	  (inc-tick)
	  (run-expired-timers :after :tick)
	  (when (>= *tick* tick-to-resume)
	    (inc-turn)
	    (run-expired-timers :after :turn)))))))

(defun inc-tick ()
  ;; We keep the actual tick count (in lisp variable *tick*) separate from the
  ;; AAL global *tick so that the AAL program can't alter the real value.  (And
  ;; similarly for turn.)
  (incf *tick*)
  (set-global '*tick *tick*))

(defun inc-turn ()
  (incf *turn*)
  (set-global '*turn *turn*))

(defun input-and-act ()
  (if (not (prompt-and-parse))
      0
      (initiate-command (global-value '*command))))

(defun end-game ()
  (format t "~2%The game is over.~%")
  (display-score)
  (throw 'end-game nil))

;;; Scoring is simple: just ask every object for its maximum score and the
;;; current score.  The problem is that scores must be associated with objects
;;; (including locations); you can't easily arrange to get points for, say,
;;; surviving past the 30th turn.

(defun display-score ()
  (let ((score (compute-score))
	(max-score (compute-max-score)))
    (format t "Your score is ~d out of a possible ~d " score max-score)
    (format t "(that's ~d%).~%" 
	    (round (* (/ score (if (zerop max-score) 1 (float max-score)))
		      100)))
    (format t "You've taken ~d turns in ~d ticks.~%" *turn* *tick*)
    score))

(defun compute-score ()
  (sum-action-results 'score))

(defun compute-max-score ()
  (sum-action-results 'max-score))

(defun sum-action-results (prop)
  ;; For every object that has property prop, run the action, and accumulate
  ;; the results.
  (let ((sum 0))
    (dolist (obj *objects*)
      (let ((action (get obj prop)))
	(if action
	    (incf sum (or (execute-action-in-object obj action) 0)))))
    sum))

  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Timers.

(defun run-expired-timers (before-after turn-tick)
  (let ((timer-list (get-headed-timer-list before-after turn-tick))
	(time (if (eq turn-tick :turn) *turn* *tick*)))
    (dolist (ti (cdr timer-list))
      (if (> time (timer-time-to-run ti))
	  (error "time ~a > timer ~a time" time ti)
	  (when (= time (timer-time-to-run ti))
	    (report "~&Running timer ~a~%" ti)
	    (execute-action (timer-action ti) *globals*)
	    (if (> (timer-renew-time ti) 0)
		(setf (timer-time-to-run ti) (+ time (timer-renew-time ti)))))))
    ;; purge expired timers
    (setf (cdr timer-list)
	  (delete-if #'(lambda (ti) (= time (timer-time-to-run ti))) (cdr timer-list)))))

(defun get-headed-timer-list (before-after turn-tick)
  (assoc turn-tick (cdr (assoc before-after *timers*))))

(defun add-timer (timer)
  (push timer (cdr (get-headed-timer-list (timer-before-after timer)
					  (timer-turn-tick timer)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Global and local variables.

(defun global-value (var)
  (alist-var-value var *globals*))

(defun alist-var-value (var alist)
  ;; This is simpler than var-value: it doesn't have to deal with variables
  ;; bound to other variables.
  (let ((pair (assoc var alist)))
    (if pair
	(cdr pair)
	(error "The variable ~a is unbound" var))))

(defun set-global (var value) 
  (set-var var value *globals*))

(defun set-var (var value alist)
  ;; You can't set variables that don't exist.  That's why globals have to be
  ;; declared.
  (let ((pair (assoc var alist)))
    (if pair
	(setf (cdr pair) value)
	(error "Attempt to set unbound AAL variable ~a" var))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parsing the player's input.

;;; The syntax of a command is: [agent,] verb ...  where "..." is specified by
;;; the SYNTAX property of the verb.  There are several weaknesses in the
;;; parsing method: commands are tied too closely to their syntax (the first
;;; word of the command line must be the name of the command); commands can
;;; have only one syntax (so you can't have both "give the bone to the dog" and
;;; "give the dog the bone") and each thing (command or object) mentioned must
;;; be one word long.

(defun prompt-and-parse ()
  ;; Returns T if successful.
  (fresh-line)
  (format t "~d> " (1+ *turn*))
  (let* ((string-input (read-line))
	 (input (string->list string-input))
	 (comma-list (member :comma input))
	 (agent-list (ldiff input comma-list))
	 (verb-list (or (cdr comma-list) input)))
    (cond
      ((null comma-list)
       (set-global '*agent 'player))
      ((not (singleton? agent-list))
       (format t "~&Syntax is: <agent>, ...~%")
       (return-from prompt-and-parse nil))
      (t
       (set-global '*agent (car agent-list))))
    (let* ((verb (car verb-list))
	   (command (get-command-name verb))
	   (syntax  (get command 'syntax)))
      (when (null command)
	(format t "~&I don't know the word ~a.~%" verb)
	(return-from prompt-and-parse nil))
      (set-global '*verb verb)
      (set-global '*command command)
      (parse-by-syntax (cdr verb-list) syntax))))

(defun parse-by-syntax (input-list syntax-list)
  ;; Returns T iff successful.
  ;; This is basically like unification: the input list contains symbols, and
  ;; the syntax list contains symbols and possibly variables.  We set the
  ;; global values of the variables to what they match, and confirm that the
  ;; symbols match.
  ;;   If the input list is shorter, error.  Ideally, the program would figure
  ;; out reasonable values for the missing variables.  But not now.
  ;;   If the syntax list is shorter, that's OK.
  (cond
    ((null input-list)
     (cond
       ((null syntax-list)
	t)
       (t
	(format t  "~&I need more info~%")
	nil)))
    ((null syntax-list)
     t)
    ((var? (car syntax-list))
     (set-global (car syntax-list) (car input-list))
     (parse-by-syntax (cdr input-list) (cdr syntax-list)))
    ((eql (car input-list) (car syntax-list))
     (parse-by-syntax (cdr input-list) (cdr syntax-list)))
    (t
     (format t  "~&The word ~a should be ~a~%" (car input-list)
	     (car syntax-list))
     nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Reading a string into a list without character-by-character parsing: it's
;;; easy using read-from-string, except that we have to watch out for commas,
;;; which are the only legal punctuation.  Other punctuation might cause
;;; problems too, but this implementation doesn't worry about that.  (We have
;;; to watch out for commas because in Common Lisp, they're illegal outside a
;;; backquote.)


(defvar *hacked-readtable* (copy-readtable))

(defun comma-reader-func (stream char)
  (declare (ignore stream char))
  :comma)

(set-macro-character #\, #'comma-reader-func nil *hacked-readtable*)

(defun string->list (string)
  ;; Temporarily rebind the readtable to my own version, put parens around the
  ;; string, and read it.
  (let ((*readtable* *hacked-readtable*))
    (read-from-string (string-append "(" string ")"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Doing a command:

;;; 1. Check the REQUIRES conditions in the order specified by the
;;;    REQUIREMENTS-ORDER property of the command.  If one is not satisfied,
;;;    print a message and return 0 duration.
;;; 2. Begin executing the first of the actions found in the order specified by
;;;    the ACTIONS-ORDER property of the command.  If that action returns
;;;    :CONTINUE (by the use of the (continue) action) then keep going.

;;; This is a generalization of what was presented in the article; there, the
;;; requirements order was fixed as (*command *agent *obj *instr) and the
;;; actions order as (*agent *obj *instr *command).  Those are still basically
;;; the default, except that the location (*loc) has been added to allow rooms
;;; to have a say in what goes on.  It is also possible for a command to
;;; override the default order.  See the "command" macro in comp.lisp.

(defun initiate-command (command)
  ;;Returns the duration of the action in ticks.
  (cond
    ((not (satisfies-requirements command (get command 'requirements-order)))
       0)
    (t
     (execute-command command (get command 'actions-order))
     (or (get command 'duration) 1))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Requirements.

(defun satisfies-requirements (command req-order)
  (every #'(lambda (var) (check-requirements command var))
	 req-order))

(defun check-requirements (command case)
  (let* ((obj (global-value case))
	 (reqs (get-requirements obj command case)))
    (dolist (req reqs)
      (setf (requirement-succeeded? req) nil))
    (let ((result (call-function-in-object #'(lambda (bindings)
						(check-reqs reqs bindings))
					   obj)))
      (if (not (eq result t))
	  (execute-action-in-object obj result))
      (eq result t))))

;;; Checking requirements: the failure message is printed only if the pattern
;;; never succeeds.  Once a pattern succeeds, its message will not be printed.

(defun check-reqs (reqs bindings)
  ;; Returns either T if all requirements can be satisfied, or the action to
  ;; be done if they can't.
  (if (null reqs)
      t
      (let* ((req (car reqs))
	     (binding-stream (deduce (requirement-pattern req) bindings))
	     (f-action nil))
	(cond
	  ((stream-empty? binding-stream)
	   (return-from check-reqs (if (requirement-succeeded? req)
				       nil
				       (requirement-failure-action req))))
	  (t
	   (setf (requirement-succeeded? req) t)
	   (dostream (binds binding-stream)
	     (let ((result (check-reqs (cdr reqs) binds)))
	       (if (eq result t)
		   (return-from check-reqs t)
		   (if result
		       (setq f-action result)))))
	   f-action)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Executing user commands.

(defun execute-command (command actions-order)
  ;; The variables in actions-order are checked in order for actions pertaining
  ;; to this command.  When an action is found, it is executed.  If the rules
  ;; of the action actually fired, then execute-command returns, unless the
  ;; result of the rules was :continue.  If no rules fired, execute-command
  ;; continues looking.  The result of the action is returned, or NIL if no
  ;; action fired.
  (dolist (case actions-order)
    (let* ((obj (global-value case))
	    (action (get-action obj command case)))
      (if action
	  (let ((result (execute-action*-in-object obj action)))
	    (if (not (member result '(:did-not-fire :continue)))
		(return result)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Executing actions.

(defun execute-action (action bindings)
  ;; Returns two values.  The first is the result of the action, or NIL if no
  ;; rule in the action fired.  The second is the new bindings (this would only
  ;; be used internally.)  You can't distinguish between an action consisting
  ;; of rules returning NIL as a result of one of its rules firing, vs. having
  ;; none of its rules fire.
  (multiple-value-bind (result new-bindings)
      (execute-action* action bindings)
    (values (if (eq result :did-not-fire) nil result) new-bindings)))

(defun execute-action* (action bindings)
  ;; Differs from execute-action only in that it returns :DID-NOT-FIRE instead
  ;; of NIL when appropriate.
  (funcall (get (car action) 'action) action bindings))
  
(defun execute-action-in-object (obj action)
  ;; This makes sure that the object's local variables are accessible.
  (call-function-in-object #'(lambda (bindings) 
				(execute-action action bindings))
			   obj))

(defun execute-action*-in-object (obj action)
  (call-function-in-object #'(lambda (bindings) 
				(execute-action* action bindings))
			   obj))


(defunp (action block) (block bindings)
  ;; (block <action>*).  Does all the actions one after the other.
  ;; Returns the value of the last action, like PROGN.  Accumulates bindings.
  (let (result)
    (dolist (action (cdr block))
      (multiple-value-setq (result bindings) (execute-action action bindings)))
    (values result bindings)))

;;; A rule-list is a list of forward rules.  The first rule whose pattern is
;;; satisfied is executed, and the value of the action of that rule is
;;; returned.  :DID-NOT-FIRE is returned if no rules in the list match.  The
;;; bindings are consulted to obtain values for free variables in the rules.
;;; Bindings are not accumulated from rule to rule; the top-level bindings are
;;; used throughout.

(defunp (action rule-list) (rule-list bindings)
  (dolist (rule (cdr rule-list))
    (let ((result (action-rule-func rule bindings)))
      (if (not (eq result :did-not-fire))
	  (return-from action-rule-list-func (values result bindings)))))
  (values :did-not-fire bindings))

(defunp (action rule) (rule bindings)
  ;; (rule <pattern> <action>)
  (let ((bindings-stream (deduce (pattern-of rule) bindings)))
    (if (stream-empty? bindings-stream)
	(values :did-not-fire bindings)
	;; It's crucial here that execute-action does *not* return
	;; :did-not-fire; if it did, then the rule-list function might think
	;; this rule didn't fire, when at this point we know it did.
	(execute-action (action-of rule) (stream-car bindings-stream)))))

(defunp (action every) (every bindings)
  ;; (every <var> <pattern> <action>)
  ;; Get a list of bindings for the variable, using the pattern; then execute
  ;; the action for each binding.  Return the value of the last action; but do
  ;; not alter the bindings.  NOTE: we should really add the bindings of all
  ;; the variables in the pattern.
  (let* ((var (var-of every))
	 (action (action-of every))
	 (var-values (unique-values var (pattern-of every) bindings))
	 (new-bindings-list (mapcar #'(lambda (val) (add-binding var val bindings))
				    var-values))
	 (result))
    (dolist (new-bindings new-bindings-list)
      (setq result (execute-action action new-bindings)))
    (values result bindings)))

(defun unique-values (var pattern bindings)
  ;; Returns a list of values of var satisfying pattern, with no duplicate
  ;; values.
  (let* (;;get the stream of bindings satisfying pattern...
	 (bindings-stream (deduce pattern bindings))
	 ;;turn it into a list...
	 (bindings-list (stream->list bindings-stream))
	 ;;remove the values for var... 
	 (values-list (mapcar #'(lambda (b) (var-value var b))
				bindings-list)))
    ;; return the values with duplicates deleted.
    (delete-duplicates values-list)))
  
(defunp (action let) (let bindings)
  ;; (let <var> <action>)
  ;; Execute the action and bind the result to the variable; return the result
  ;; of the action, and the new bindings.
  (let ((result (execute-action (action-of let) bindings)))
    (values result (add-binding (var-of let) result bindings))))

(defunp (action choose) (choose bindings)
  ;; (choose <var> <pattern>)
  ;; This is like a let, except the value for the variable is chosen randomly
  ;; from those that match the pattern.  The result of choose is the value, and
  ;; it also augments the bindings.
  (let ((result (randomly-choose-from-list 
		  (unique-values (var-of choose)
				 (pattern-of choose) bindings))))
    (values result (add-binding (var-of choose) result bindings))))

(defun randomly-choose-from-list (list)
  (let ((n (random (length list))))
    (nth n list)))

(defunp (action lisp) (lisp-action bindings)
  ;; Returns the result of applying the car of lisp expression to its cdr, and
  ;; the same bindings.  (If the expression is an atom, it's just returned.) We
  ;; have to go through the expression replacing AAL variables with their
  ;; values.  Note that we are not evaluating the expression; the difference is
  ;; that our way, the arguments are not evaluated.
  (let ((expr (instantiate (expression-of lisp-action) bindings)))
    (if (atom (expression-of lisp-action))
	(values expr bindings)
	(values (apply (car expr) (cdr expr)) bindings))))

(defunp (action assert) (assert bindings)
  ;; Get the pattern and instantiate it.  It must be simple and contain no
  ;; unbound variables.
  (let ((pattern (second assert)))
    (if (not (simple-pattern? pattern))
	(error "Cannot assert the pattern ~a because it is not simple" 
	       pattern)
	(values (assert (instantiate pattern bindings)) 
		bindings))))

(defunp (action retract) (retract bindings)
  ;; This is similar to assert
  (let ((pattern (pattern-of retract)))
    (if (not (simple-pattern? pattern))
	(error "Cannot retract the pattern ~a because it is not simple" 
	       pattern)
	(values (retract (instantiate pattern bindings)) 
		bindings))))


;;; (query <pattern>)
(defunp (action query) (query bindings)
  ;; Calls the deducer on the pattern.  Returns what the deducer returns, and
  ;; augments the bindings by returning the first binding-list in the stream
  ;; returned by the deducer, if any.
  (let ((result (deduce (pattern-of query) bindings)))
    (values result (if (stream-empty? result)
		       bindings
		       (stream-car result)))))

;;; (continue)
(defunp (action continue) (continue bindings)
  (declare (ignore continue))
  (values :continue bindings))

;;; (end-game)
(defunp (action end-game) (form bindings)
  (declare (ignore form bindings))
  (end-game))

;;; (display-score)
(defunp (action display-score) (form bindings)
  (declare (ignore form))
  (values (display-score) bindings))

(defmacro with-instantiated-arg (&body body)
  ;; This simplifies the expression of simple actions that take only one
  ;; argument and instantiate it.
  `(let ((arg (instantiate (second form) bindings)))
     (values (progn ,@body) bindings)))

;;; (destroy <obj>)
(defunp (action destroy) (form bindings)
  ;; (destroy obj) removes all facts in the database that mention obj.
  ;; We can't use the deducer directly to do this because we have to handle
  ;; assertions of all arities.
  (with-instantiated-arg (destroy arg)))

(defun destroy (obj)
  (dolist (stmt *db*)
    (when (and (null (antecedent-of stmt))		;it's a fact
	       (member obj (consequent-of stmt)))
      (retract (consequent-of stmt))))
  t)

;;; (value <obj> <var>)  For local variables of an object that the code is not
;;; executing within.
(defunp (action value) (form bindings)
  (with-instantiated-arg
    (alist-var-value (third form) (get arg 'vars))))

;;; (set <var> <value>) sets globals.
;;; (set (<obj> <var>) <value>) sets locals.
(defunp (action set) (form bindings)
  (if (not (= (length form) 3))
      (error "In ~a: wrong number of args" form)
      (multiple-value-bind (obj var value)
	  (parse-modify-form form)
	(let ((alist (if obj (get (instantiate obj bindings) 'vars) bindings)))
	  (if (not (var? var))
	      (error "In ~a: ~a is not a variable" form var)
	      (values (set-var var (instantiate value bindings) alist)
		      bindings))))))

(defun parse-modify-form (form)
  ;; form is either (<name> (<obj> <var>) [<value>]) or (<name> <var>
  ;; [<value>]).  Return three values: obj, var, value.
  (let ((varspec (second form)))
    (if (listp varspec)
	(if (not (= (length varspec) 2))
	    (error "In ~a: illegal var: ~a" form (second form))
	    (values (first varspec) (second varspec) (third form)))
	(values nil varspec (third form)))))

;;; (inc <var> [<amount>]) for globals
;;; (inc (<obj> <var>) [<amount>]) for locals
(defunp (action inc) (form bindings)
  (values (modify-var form bindings #'+) bindings))

;;; Same as inc
(defunp (action dec) (form bindings)
  (values (modify-var form bindings #'-) bindings))

(defun modify-var (form bindings func)
  ;; Form should be (name (obj var) [amount]) or (name var [amount])
    (multiple-value-bind (obj var amount-form)
	(parse-modify-form form)
      (if (not (var? var))
	  (error "In ~a: ~a is not a variable" form var)
	  (let* ((alist (if obj (get (instantiate obj bindings) 'vars) bindings))
		 (amount (if amount-form (instantiate amount-form bindings) 1))
		 (value (var-value var alist)))
	    (cond
	      ((eq value :unbound)
	       (error "In ~a: variable ~a is unbound" form var))
	      ((not (numberp value))
	       (error "In ~a: variable ~a's value, ~a, is not a number" 
		      form var value))
	      ((not (numberp amount))
	       (error "In ~a: the argument, ~a, is not a number" 
		      form amount-form))
	      (t
	       (set-var var (funcall func value amount) alist)))))))


;;; (display <action>)
(defunp (action display) (form bindings)
  (with-instantiated-arg 
    (let ((pr (printed-rep arg)))
      (format t "~&~a~%" pr)
      pr)))

(defun printed-rep (thing)
  (if (symbolp thing)
      (or (get thing 'desc) (string-downcase thing))
      thing))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous.

(defun call-function-in-object (func obj)
  ;; The main thing here is handling the object's local variables correctly.
  ;; They must be added to the bindings so that their values will be found, and
  ;; we also have to handle setting them.  This is what we do: we nconc the
  ;; list of locals onto the bindings, first keeping the last cons of the
  ;; locals.  Accessing will work as usual.  Set will destructively modify the
  ;; binding--new ones can't be created.  When execution is done, we restore
  ;; the locals to their former state.
  ;;   This can only be called at top-level.  It doesn't return bindings,
  ;; just a result.  The function to be called must take one argument, the
  ;; bindings. 
  (let ((locals (get obj 'vars)))
    (if (null locals)
	;; This is the easy case.
	;; We use values to assure that we're only returning one value.
	(values (funcall func *globals*))
	(let* ((last-cons (last locals))
	       (*protected-vars* (nconc locals *globals*))
	       (result (funcall func *protected-vars*)))
	    (setf (cdr last-cons) nil)
	    result))))

(defun instantiate (pattern bindings)
  ;; Create a copy of the pattern with variables replaced by their values.  It
  ;; is an error if there is an unbound variable in the pattern.
  (labels ((instantiate-1 (pat bindings)
	     (cond
	       ((null pat)
		nil)
	       ((atom pat)
		(if (not (var? pat))
		    pat
		    (let ((value (var-value pat bindings)))
		      (if (eq value :unbound)
			  (error "Pattern ~a contains unbound variable ~a" 
				 pattern pat)
			  value))))
	       (t
		(cons (instantiate-1 (car pat) bindings)
		      (instantiate-1 (cdr pat) bindings))))))
    (instantiate-1 pattern bindings)))

;;; End interp.lisp.