;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - NFS Share File - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'util :use '(lisp))

(eval-when (compile load eval)
  (in-package 'util :use '(lisp)))

(export '(value-from-undo-frame

	   setf-undo
	   push-undo
	   pop-undo
	   delete-undo
	   incf-undo
	   decf-undo

	   clear-undo-stack
	   base-frame?

	   undo-rep
	   clear-frame

	   goto-context
	   extend-frame
	   pop-extension
	   current-context
	   show-context
	   defextender))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities:                                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-when (compile load eval) 
  (defun symcat (&rest symbols)
    (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))
	    :util)))

(eval-when (compile load eval)
  (defun us-inline-store (array sindex vlist)
    (let ((code nil)
	  (offset 0))
      (dolist (v vlist)
	(setq code (cons `(setf (aref ,array (+ ,sindex ,offset)) ,v) code))
	(setq offset (1+ offset)))
      code)))

(eval-when (compile load eval)
  (defun us-inline-extract (array eindex num)
    (let ((body nil)
	  (offset 1))
      (dotimes (x num)
	(setq body (cons `(setq values (cons (aref ,array (- ,eindex ,offset))
					     values)) body))
	(setq offset (1+ offset)))
      body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Global Variables:                                                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *no-binding* (gensym))

(defvar *undo-array-dimension* 1000)
;; Must be a multiple of 4 (for lucid) and a multiple of 3 (for cmu)
(defvar *undo-struct-array-dimension* (* *undo-array-dimension* 12))
;; Must be a multiple of 3
(defvar *undo-aref-array-dimension* (* *undo-array-dimension* 9))
;; Must be a multiple of 2
(defvar *undo-car-array-dimension* (* *undo-array-dimension* 2))
;; Must be a multiple of 2
(defvar *undo-cdr-array-dimension* (* *undo-array-dimension* 2))
;; Must be a multiple of 2
(defvar *undo-ident-array-dimension* (* *undo-array-dimension* 2))
;; Must be a multiple of 3
(defvar *undo-hash-array-dimension* (* *undo-array-dimension* 3))
;; Must be a multiple of 3
(defvar *undo-prop-array-dimension* (* *undo-array-dimension* 3))

(defvar *undo-max-struct* -1)
(defvar *undo-max-aref* -1)
(defvar *undo-max-car* -1)
(defvar *undo-max-cdr* -1)
(defvar *undo-max-ident* -1)
(defvar *undo-max-hash* -1)
(defvar *undo-max-prop* -1)
(defvar *undo-struct-arrays* nil)
(defvar *undo-aref-arrays* nil)
(defvar *undo-car-arrays* nil)
(defvar *undo-cdr-arrays* nil)
(defvar *undo-ident-arrays* nil)
(defvar *undo-hash-arrays* nil)
(defvar *undo-prop-arrays* nil)
(defvar *undo-current-struct-array* nil)
(defvar *undo-current-aref-array* nil)
(defvar *undo-current-car-array* nil)
(defvar *undo-current-cdr-array* nil)
(defvar *undo-current-ident-array* nil)
(defvar *undo-current-hash-array* nil)
(defvar *undo-current-prop-array* nil)
(defvar *undo-struct-array* -1)
(defvar *undo-aref-array* -1)
(defvar *undo-car-array* -1)
(defvar *undo-cdr-array* -1)
(defvar *undo-ident-array* -1)
(defvar *undo-hash-array* -1)
(defvar *undo-prop-array* -1)
(defvar *undo-struct-element* *undo-struct-array-dimension*)
(defvar *undo-aref-element* *undo-aref-array-dimension*)
(defvar *undo-car-element* *undo-car-array-dimension*)
(defvar *undo-cdr-element* *undo-cdr-array-dimension*)
(defvar *undo-ident-element* *undo-ident-array-dimension*)
(defvar *undo-hash-element* *undo-hash-array-dimension*)
(defvar *undo-prop-element* *undo-prop-array-dimension*)
(defvar *undo-frame* 0)
(defvar *undo-struct-array-start* nil)
(defvar *undo-struct-element-start* nil)
(defvar *undo-aref-array-start* nil)
(defvar *undo-aref-element-start* nil)
(defvar *undo-car-array-start* nil)
(defvar *undo-car-element-start* nil)
(defvar *undo-cdr-array-start* nil)
(defvar *undo-cdr-element-start* nil)
(defvar *undo-ident-array-start* nil)
(defvar *undo-ident-element-start* nil)
(defvar *undo-hash-array-start* nil)
(defvar *undo-hash-element-start* nil)
(defvar *undo-prop-array-start* nil)
(defvar *undo-prop-element-start* nil)
(defvar *undo-stack* nil)

(defun clear-undo-stack ()
  (setq *undo-max-struct* -1)
  (setq *undo-max-aref* -1)
  (setq *undo-max-car* -1)
  (setq *undo-max-cdr* -1)
  (setq *undo-max-ident* -1)
  (setq *undo-max-hash* -1)
  (setq *undo-max-prop* -1)
  (setq *undo-struct-arrays* nil)
  (setq *undo-aref-arrays* nil)
  (setq *undo-car-arrays* nil)
  (setq *undo-cdr-arrays* nil)
  (setq *undo-ident-arrays* nil)
  (setq *undo-hash-arrays* nil)
  (setq *undo-prop-arrays* nil)
  (setq *undo-current-struct-array* nil)
  (setq *undo-current-aref-array* nil)
  (setq *undo-current-car-array* nil)
  (setq *undo-current-cdr-array* nil)
  (setq *undo-current-ident-array* nil)
  (setq *undo-current-hash-array* nil)
  (setq *undo-current-prop-array* nil)
  (setq *undo-struct-array* -1)
  (setq *undo-aref-array* -1)
  (setq *undo-car-array* -1)
  (setq *undo-cdr-array* -1)
  (setq *undo-ident-array* -1)
  (setq *undo-hash-array* -1)
  (setq *undo-prop-array* -1)
  (setq *undo-struct-element* *undo-struct-array-dimension*)
  (setq *undo-aref-element* *undo-aref-array-dimension*)
  (setq *undo-car-element* *undo-car-array-dimension*)
  (setq *undo-cdr-element* *undo-cdr-array-dimension*)
  (setq *undo-ident-element* *undo-ident-array-dimension*)
  (setq *undo-hash-element* *undo-hash-array-dimension*)
  (setq *undo-prop-element* *undo-prop-array-dimension*)
  (setq *undo-frame* 0)
  (setq *undo-struct-array-start* nil)
  (setq *undo-struct-element-start* nil)
  (setq *undo-aref-array-start* nil)
  (setq *undo-aref-element-start* nil)
  (setq *undo-car-array-start* nil)
  (setq *undo-car-element-start* nil)
  (setq *undo-cdr-array-start* nil)
  (setq *undo-cdr-element-start* nil)
  (setq *undo-ident-array-start* nil)
  (setq *undo-ident-element-start* nil)
  (setq *undo-hash-array-start* nil)
  (setq *undo-hash-element-start* nil)
  (setq *undo-prop-array-start* nil)
  (setq *undo-prop-element-start* nil)
  (setq *undo-stack* nil)
  (setq *context* nil))

(defmacro base-frame? ()
  `(= *undo-frame* 0))

(defmacro us-malloc (array)
  (let ((max (symcat '*undo-max- array '*))
	(arrays (symcat '*undo- array '-arrays*))
	(dim (symcat '*undo- array '-array-dimension*)))
    `(progn
       (setf ,arrays (nconc ,arrays (list (make-array ,dim))))
       (setf ,max (1+ ,max)))))

(defmacro us-store (type &rest values)
  (let ((uelement (symcat '*undo- type '-element*))
	(uarray (symcat '*undo- type '-array*))
	(arrays (symcat '*undo- type '-arrays*))
	(max (symcat '*undo-max- type '*))
	(carray (symcat '*undo-current- type '-array*))
	(dim (symcat '*undo- type '-array-dimension*))
	(astart (symcat '*undo- type '-array-start*))
	(estart (symcat '*undo- type '-element-start*))
	(lval (length values)))
    ;; Array Bounds Check
    `(if (= ,uelement ,dim)
	 (progn
	   ;; Possibly allocate more memory
	   (when (= ,uarray ,max)
	     (us-malloc ,type))
	   (setq ,uarray (1+ ,uarray))
	   (setq ,carray (nth ,uarray ,arrays))
	   (setq ,uelement 0)
	   ,@(us-inline-store carray uelement values)
	   ;; Update starts
	   (when (null ,astart)
	     (setq ,astart ,uarray)
	     (setq ,estart ,uelement))
	   (setq ,uelement (+ ,lval ,uelement)))
	 (progn
	   ,@(us-inline-store carray uelement values)
	   ;; Update starts
	   (when (null ,astart)
	     (setq ,astart ,uarray)
	     (setq ,estart ,uelement))
	   (setq ,uelement (+ ,lval ,uelement))))))

(defmacro us-extract (type num)
  (let ((uelement (symcat '*undo- type '-element*))
	(uarray (symcat '*undo- type '-array*))
	(arrays (symcat '*undo- type '-arrays*))
	(carray (symcat '*undo-current- type '-array*))
	(dim (symcat '*undo- type '-array-dimension*))
	(astart (symcat '*undo- type '-array-start*))
	(estart (symcat '*undo- type '-element-start*)))
    ;; Array bounds check
    `(let ((values nil))
       (if (= ,uelement 0)
	   (progn
	     (setq ,uelement ,dim)
	     (setq ,uarray (1- ,uarray))
	     (setq ,carray (nth ,uarray ,arrays))
	     ,@(us-inline-extract carray uelement num)
	     (setq ,uelement (- ,uelement ,num))
	     ;; Update starts
	     (when (and (= ,uelement ,estart) (= ,uarray ,astart))
	       (setq ,astart nil)
	       (setq ,estart nil))
	     (values-list values))
	   (progn
	     ,@(us-inline-extract carray uelement num)
	     (setq ,uelement (- ,uelement ,num))
	     ;; Update starts
	     (when (and (= ,uelement ,estart) (= ,uarray ,astart))
	       (setq ,astart nil)
	       (setq ,estart nil))
	     (values-list values))))))

(defun us-push ()
  (unless (base-frame?)
    (setq *undo-stack*
	  (cons (list (cons *undo-struct-array-start*
			    *undo-struct-element-start*)
		      (cons *undo-aref-array-start*
			    *undo-aref-element-start*)
		      (cons *undo-car-array-start*
			    *undo-car-element-start*)
		      (cons *undo-cdr-array-start*
			    *undo-cdr-element-start*)
		      (cons *undo-ident-array-start*
			    *undo-ident-element-start*)
		      (cons *undo-hash-array-start*
			    *undo-hash-element-start*)
		      (cons *undo-prop-array-start*
			    *undo-prop-element-start*)) *undo-stack*))
    (setq *undo-struct-array-start* nil)
    (setq *undo-struct-element-start* nil)
    (setq *undo-aref-array-start* nil)
    (setq *undo-aref-element-start* nil)
    (setq *undo-car-array-start* nil)
    (setq *undo-car-element-start* nil)
    (setq *undo-cdr-array-start* nil)
    (setq *undo-cdr-element-start* nil)
    (setq *undo-ident-array-start* nil)
    (setq *undo-ident-element-start* nil)
    (setq *undo-hash-array-start* nil)
    (setq *undo-hash-element-start* nil)
    (setq *undo-prop-array-start* nil)
    (setq *undo-prop-element-start* nil))
  (setq *undo-frame* (1+ *undo-frame*)))

(defun us-pop ()
  (if (base-frame?)
      (error "Undo frame pop in base context.")
      (progn
	;; Structures (Lucid)
	#+lucid(while *undo-struct-array-start*
		 (multiple-value-bind (value type index structure)
		     (us-extract struct 4)
		   (lrs:set-structure-ref structure index type value)))
	;; Structures (allegro)
	#+allegro(while *undo-struct-array-start*
		   (multiple-value-bind (value setter arg)
		       (us-extract struct 3)
		     (funcall setter arg value)))
	;; Structures (CMUlisp)
	#+cmu(while *undo-struct-array-start*
	       (multiple-value-bind (value setter args)
		   (us-extract struct 3)
		 (apply setter value args)))
	;; Vectors
	(while *undo-aref-array-start*
	  (multiple-value-bind (value index vector)
	      (us-extract aref 3)
	    (setf (aref vector index) value)))
	;; Cars
	(while *undo-car-array-start*
	  (multiple-value-bind (value ptr)
	      (us-extract car 2)
	    (rplaca ptr value)))
	;; Cdrs
	(while *undo-cdr-array-start*
	  (multiple-value-bind (value ptr)
	      (us-extract cdr 2)
	    (rplacd ptr value)))
	;; Identifiers
	(while *undo-ident-array-start*
	  (multiple-value-bind (value identifier)
	      (us-extract ident 2)
	    (if (eq value *no-binding*)
		(makunbound identifier)
		(set identifier value))))
	;; Hashtables
	(while *undo-hash-array-start*
	  (multiple-value-bind (value key table)
	      (us-extract hash 3)
	    (if (eq value *no-binding*)
		(remhash key table)
		(setf (gethash key table) value))))
	;; Properties
	(while *undo-prop-array-start*
	  (multiple-value-bind (value key symbol)
	      (us-extract prop 3)
	    (setf (get symbol key) value)))
	(setq *undo-frame* (1- *undo-frame*))
	(let ((bounds (car *undo-stack*)))
	  (setq *undo-struct-array-start* (caar bounds))
	  (setq *undo-struct-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-aref-array-start* (caar bounds))
	  (setq *undo-aref-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-car-array-start* (caar bounds))
	  (setq *undo-car-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-cdr-array-start* (caar bounds))
	  (setq *undo-cdr-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-ident-array-start* (caar bounds))
	  (setq *undo-ident-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-hash-array-start* (caar bounds))
	  (setq *undo-hash-element-start* (cdar bounds))
	  (setq bounds (cdr bounds))
	  (setq *undo-prop-array-start* (caar bounds))
	  (setq *undo-prop-element-start* (cdar bounds))
	  (setq *undo-stack* (cdr *undo-stack*))))))

#+allegro
(defvar *allegro-structure-setters* '(excl::%set-0
				      excl::%set-1
				      excl::%set-2
				      excl::%set-3
				      excl::%set-4
				      excl::%set-5
				      excl::%set-6
				      excl::%set-7
				      excl::%set-8
				      excl::%set-9
				      excl::%set-10
				      excl::%set-11
				      excl::%set-12
				      excl::%set-13
				      excl::%set-14
				      excl::%set-15
				      excl::%set-16
				      excl::%set-17
				      excl::%set-18
				      excl::%set-19
				      excl::%set-20
				      excl::%set-21
				      excl::%set-22
				      excl::%set-23
				      excl::%set-24
				      excl::%set-25
				      excl::%set-26
				      excl::%set-27
				      excl::%set-28
				      excl::%set-29
				      excl::%set-30
				      excl::%set-31
				      excl::%set-32
				      excl::%set-33
				      excl::%set-34
				      excl::%set-35
				      excl::%set-36
				      excl::%set-37
				      excl::%set-38
				      excl::%set-39
				      excl::%set-40
				      excl::%set-41
				      excl::%set-42
				      excl::%set-43
				      excl::%set-44
				      excl::%set-45
				      excl::%set-46
				      excl::%set-47
				      excl::%set-48
				      excl::%set-49
				      excl::%set-50
				      excl::%set-51
				      excl::%set-52
				      excl::%set-53
				      excl::%set-54
				      excl::%set-55
				      excl::%set-56
				      excl::%set-57
				      excl::%set-58
				      excl::%set-59
				      excl::%set-60
				      excl::%set-61
				      excl::%set-62
				      excl::%set-63
				      excl::%set-64
				      excl::%set-65
				      excl::%set-66
				      excl::%set-67
				      excl::%set-68
				      excl::%set-69))

(defmacro setf-undo (reference value)
  ;; Expand away annoying macros
  (cond ((and (listp reference) (macro-function (car reference)))
	 (let ((exp (macroexpand reference)))
	   `(setf-undo ,exp ,value)))
	;; Identifiers.
	((symbolp reference)
	 `(progn
	    (unless (base-frame?)
	      (us-store ident ',reference (if (boundp ',reference)
					      ,reference
					      *no-binding*)))
	    (setq ,reference ,value)))
	;; Cdrs.
	((and (listp reference) (eq (car reference) 'cdr))
	 `(let* ((ptr ,(second reference)))
	    (if (consp ptr)
		(progn
		  (unless (base-frame?)
		    (us-store cdr ptr (cdr ptr)))
		  (rplacd ptr ,value))
		(error "Setf-undo cdr of non cons."))))
	;; Cars.
	((and (listp reference) (eq (car reference) 'car))
	 `(let ((ptr ,(second reference)))
	    (if (consp ptr)
		(progn
		  (unless (base-frame?)
		    (us-store car ptr (car ptr)))
		  (rplaca ptr ,value))
		(error "Setf-undo car of non cons."))))
	;; Vectors.
	((and (listp reference)
	      (eq (car reference) 'aref)
	      (null (cdddr reference)))
	 `(let ((ptr ,(second reference))
		(index ,(third reference)))
	    (if (vectorp ptr)
		(progn
		  (unless (base-frame?)
		    (us-store aref ptr index (aref ptr index)))
		  (setf (aref ptr index) ,value))
		(error "Setf-undo aref of non vector."))))
	;; Assoc-values.
	((and (listp reference)
	      (eq (car reference) 'assoc-value))
	 `(let* ((item ,(second reference))
		 (alist ,(third reference))
		 (member (assoc item alist)))
	    (if (and (listp alist) (every #'consp alist))
		(cond ((null alist)
		       (setf-undo ,(third reference)
				  (list (cons item ,value))))
		      (member (setf-undo (cdr member) ,value))
		      (t
			(setf-undo ,(third reference)
				   (cons (cons item ,value) alist))))
		(error "Setf-undo assoc-value of non alist."))))
	;; Hash tables.
	((and (listp reference)
	      (eq (car reference) 'gethash))
	 `(let ((key ,(second reference))
		(table ,(third reference)))
	    (if (hash-table-p table)
		(progn
		  (unless (base-frame?)
		    (us-store hash table key
			      (multiple-value-bind (entry entry?)
				  (gethash key table)
				(if entry? entry *no-binding*))))
		  (setf (gethash key table) ,value))
		(error "Setf-undo gethash of non hash table."))))
	((and (listp reference) (eq (car reference) 'get))
	 `(let ((symbol ,(second reference))
		(key ,(third reference)))
	    (if (symbolp symbol)
		(progn
		  (unless (base-frame?)
		    (us-store prop symbol key (get symbol key)))
		  (setf (get symbol key) ,value))
		(error "Setf-undo property of non symbol."))))
	;; Structures and whatever else needs to be hacked thru
	;; setf methods.
	#+lucid
	(t
	  (multiple-value-bind (vars vals stores store-form access-form)
	      (get-setf-method reference)
	    (declare (ignore vars stores store-form))
	    ;; Ack-barf - really lucid dependent.
	    (cond ((eq (car access-form) 'system:structure-ref)
		   `(let ((str ,(first vals))
			  (index ,(second vals))
			  (type ,(third vals)))
		      (if (subtypep (type-of str) type)
			  (progn
			    (unless (base-frame?)
			      (us-store struct str index type
					(system:structure-ref str index type)))
			    (lrs:set-structure-ref str index type ,value))
			  (error "Setf-undo structure of wrong type."))))
		  ((eq (car access-form) 'aref)
		   `(setf-undo (aref ,(first vals) ,(second vals)) ,value))
		  (t
		    (error "Setf-undo on an unknown type: ~a" reference)))))
	#+allegro
	(t
	  (multiple-value-bind (vars vals stores store-form access-form)
	      (get-setf-method reference)
	    (cond ((member (car store-form) *allegro-structure-setters*)
		   `(let* ,(mapcar #'list
			    (append vars stores)
			    (append vals (list value)))
		     (unless (base-frame?)
		       (us-store struct ,(first vars) #',(car store-form)
				 ,access-form))
		     ,store-form))
		  ((eq (car access-form) 'aref)
		   `(setf-undo (aref ,(first vals) ,(second vals)) ,value))
		  (t
		    (error "Setf-undo on an unknown type: ~a" reference)))))
	#+cmu
	(t
	 (multiple-value-bind (vars vals stores store-form access-form)
	     (get-setf-method reference)
	   (cond ((and (eq (car store-form) 'funcall)
		       (equal (cddr store-form)
			      (append stores vars)))
		  `(let* ,(mapcar #'list
			   (append vars stores)
			   (append vals (list value)))
		    (unless (base-frame?)
		      (us-store struct (list ,@vars) ,(second store-form)
				,access-form))
		    ,store-form))
		 ((eq (car access-form) 'aref)
		  `(setf-undo (aref ,(first vals) ,(second vals)) ,value))
		 (t
		  (error "Setf-undo on an unknown type: ~a" reference)))))
	#-(or allegro cmu lucid)
	(t
	 (error "Setf-undo not supported for this system"))))

(defmacro prev-undo-frame ()
  '(1- *undo-frame*))

(defmacro push-undo (new-member reference)
  `(setf-undo ,reference (cons ,new-member ,reference)))

(defmacro pop-undo (reference)
  `(let* ((ref ,reference)
	  (fst (car ref)))
     (setf-undo ,reference (cdr ref))
     fst))

(defmacro delete-undo (itm lst)
  `(let ((list ,lst)
	 (item ,itm))
     (iterate loop ((current-cell list)
		    (next-cell (cdr list)))
       (when next-cell
	 (cond ((eq (car next-cell) item)
		(setf-undo (cdr current-cell) (cdr next-cell))
		(loop current-cell (cdr next-cell)))
	       (t
		 (loop next-cell (cdr next-cell))))))
     (if (eq (car list) item)
	 (setf-undo ,lst (cdr list))
	 list)))

(defmacro incf-undo (reference)
  `(setf-undo ,reference (1+ ,reference)))

(defmacro decf-undo (reference)
  `(setf-undo ,reference (1- ,reference)))

(defvar *push-deamons* nil)

(defexport push-undo-frame ()
  (us-push))

;We must allow for many pops in a row followed by a single restart.

(defexport pop-undo-frame ()
  (us-pop))

(defexportmacro value-from-undo-frame (&body forms)
  `(value-from-undo-thunk (lambda () ,@forms)))

(defexport value-from-undo-thunk (thunk)
  (push-undo-frame)
  (unwind-protect (funcall thunk)
    (pop-undo-frame)))

(defexport undo-push ()
  (catch 'abort
    (value-from-undo-frame (read-eval-print t))))

(defun undo-rep ()
  (value-from-undo-frame (read-eval-print t)))

(defun clear-frame ()
  (pop-undo-frame)
  (push-undo-frame))


;========================================================================
;;;goto-context
;;
;;; A CONTEXT-EXTENSION is something executed for effect where the effect
;;; is undone when the current undo frame is popped.
;;;
;;  The interface functions for this module are clear-context,
;;  goto-context, extend-frame, pop-extension, current-context, show-context
;;  and defextender
;========================================================================

(lisp:defvar *context* nil)

(defun current-context ()
  (reverse *context*))

(defun pop-extension ()
  (util::pop-undo-frame)
  (pop *context*))

(defun show-context ()
  (rprint (current-context)))

(defvar *attempt-token* (list 'attempt))

(defun extend-frame (extension)
  (util::push-undo-frame)
  (unwind-protect (progn
		    (push `(,*attempt-token* ,extension) *context*)
		    (execute-extension extension)
		    (pop *context*)
		    (push extension *context*))
    (when (eq (car (first *context*))
	      *attempt-token*)
      (pop-extension))))

(defun execute-extension (extension)
  (unless (and (consp extension)
	       (symbolp (car extension)))
    (error "illegal context assumption ~s" extension))
  (let ((fun (get (car extension) 'execution-function)))
    (when fun
      (apply fun (cdr extension)))))

(defun goto-context (new-context)
  (unless (equal new-context (current-context))
    (if (null new-context)
	(dotimes (n (length (current-context)))
	  (pop-extension))
	(let ((tail (current-context)))
	  (dolist (extension new-context)
	    (cond ((and tail
			(equal extension (car tail)))
		   (pop tail))
		  (tail
		    (dotimes (n (length tail))
		      (pop-extension))
		    (setq tail nil)
		    (extend-frame extension))
		  (t
		    (extend-frame extension))))
	  (when tail
	    (dotimes (n (length tail))
	      (pop-extension)))))))

(defmacro defextender (extender-name arguments &rest body)
  `(eval-when (eval load compile)
    (setf (get ',extender-name 'execution-function) ',(create-name extender-name 'extender-fun))
    (defun ,(create-name extender-name 'extender-fun) ,arguments
      ,@body)))