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

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

;emacs-indent is used with ilisp to control indentation but is
;not used in exported code.

(defmacro lambda (vars &body body)
  `#'(lambda ,vars ,@body))

(defmacro emacs-indent (x y)
  `'(,x ,y))

(defun emacs-eval (exp) exp)

(export 'defexport)

(eval-when (compile load eval)
  (defmacro defexport (name args &body body)
    `(progn (export ',name)
	    (defun ,name ,args ,@body))))

(export 'defexportmacro)
(emacs-indent defexportmacro 2)

(defmacro defexportmacro (name args &body body)
  `(progn (export ',name)
	  (defmacro ,name ,args ,@body)))

(defexportmacro definline (name vars &body body)
  `(progn (proclaim '(inline ,name))
	  (defun ,name ,vars ,@body)
	  ,@(when (null (rest body))
	      `((define-setf-method ,name ,vars
		  (multiple-value-bind
		      (temps vals stores store-form access-form)
		      (get-setf-method
		       (sublis (mapcar (lambda (var val)
					 (cons var val))
				       ',vars (list ,@vars))
			       ',@body))
		    (values temps vals
			    stores store-form access-form)))))))

;     (definline foo (x)  (car x))

;(define-setf-method foo (x)
;    (mul-val-bind (t v s st ac)
;	 (get-setf-method (sublis (mapcar (lambda (var)
;					    (cons var (symbol-value var)))
;					  '(x y z))
;				  'body)
;				  (list (cons 'x x))
;				  (values t v s st ac)))
;
;
;(setf (foo node) 5)

(defexportmacro defnotinline (name vars &body body)
  `(progn (proclaim '(notinline ,name))
	  (defun ,name ,vars ,@body)))

;;(defexportmacro property-macro (symbol)
;;  `(definline ,symbol (x) (get x ',symbol)))
;;	  (defsetf ,symbol (sym) (value)
;;	    `(setf (get ,sym ',',symbol) ,value))))

(defexportmacro property-macro (symbol)
  `(defmacro ,symbol (x)
     (list 'get x '',symbol)))

(defexportmacro hash-table-macro (symbol)
  (let ((hash-table-var (create-name symbol 'hash 'table)))
    `(eval-when (load eval compile)
      (defvar ,hash-table-var (make-hash-table))
      (defmacro ,symbol (x)
	`(gethash ,x ,',hash-table-var))
      (defun ,(create-name 'clear 'all symbol) ()
	(clrhash ,hash-table-var)))))

(defexportmacro equal-hash-table-macro (symbol)
  (let ((hash-table-var (create-name symbol 'hash 'table)))
    `(eval-when (load eval compile)
      (defvar ,hash-table-var (make-hash-table :test #'equal))
      (defmacro ,symbol (x)
	`(gethash ,x ,',hash-table-var))
      (defun ,(create-name 'clear 'all symbol) ()
	(clrhash ,hash-table-var)))))

(defexport the-one (list)
  (unless list
    (error "an empty set of possibilities given to the function THE"))
  (when (cdr list)
    (error "more than one value given to the function THE"))
  (first list))

(defexportmacro while (form &body body)
  `(loop
     (when (not ,form) (return nil))
     ,@body))

(defexportmacro do-from-to ((var min max) &body body)
  (let ((limit (gensym "LIMIT-")))
    `(let ((,var ,min)
	   (,limit ,max))
       (loop
         ,@body
	 (when (= ,var ,limit) (return))
	 (incf ,var)))))

(defexportmacro mvlet (bindings &body body)
  (cond ((null (cdr bindings))
	 `(multiple-value-bind ,(first (first bindings)) ,(second (first bindings))
	    ,@body))
	(t
	 `(multiple-value-bind ,(first (first bindings)) ,(second (first bindings))
	    (mvlet ,(rest bindings)
	      ,@body)))))

(emacs-indent mvlet 1)

(defexport fill-array (array value)
  (let ((d (array-dimensions array)))
    (cond ((= (length d) 1)
	   (dotimes (x (car d))
	     (setf (aref array x) value)))
	  ((= (length d) 2)
	   (dotimes (x (car d))
	     (dotimes (y (second d))
	       (setf (aref array x y) value))))
	  (t
	   (error "fill-array does not handle more than 2 diemensions")))))

(defexport assoc-value (item alist)
  (cdr (assoc item alist)))

(define-setf-method assoc-value (item alist)
  (mvlet (((temps vals stores store-form access-form)
	   (get-setf-method alist)))
    (let ((itemvar (gensym))
	  (listvar (gensym))
	  (store (gensym))
	  (celvar (gensym)))
      (values
	(append temps (list itemvar listvar celvar))
	(append vals (list item access-form `(assoc ,itemvar ,listvar)))
	(list store)
	`(progn (if (cdr ,celvar)
		    (if ,store
			(setf (cdr ,celvar) ,store)
			(let ((,(car stores) (remove ,itemvar ,listvar :key #'car)))
			  ,store-form
			  (setf (cdr ,celvar) nil)))
		    (when ,store
		      (if ,celvar
			  (setf (cdr ,celvar) ,store)
			  (progn
			    (setf ,celvar (cons ,itemvar ,store))
			    (push ,celvar ,listvar)))  ;;  I didn't write this -- rlg
		      (let ((,(car stores) ,listvar))
			,store-form)))
		,store)
	`(assoc-value ,itemvar ,access-form)))))


(defexportmacro dolists (specs &body body)
  (let ((new-vars (mapcar (lambda (spec) (gensym "VAR-")) specs)))
    `(do* ,(mapcan (lambda (spec new-var) `((,new-var ,(cadr spec) (cdr ,new-var))
					    (,(car spec) (car ,new-var) (car ,new-var))))
		   specs
		   new-vars)
	 ((null ,(caar specs)) t)
       ,@body)))

(defexportmacro do-tails ((var list) &body body)
  `(do ((,var ,list (cdr ,var)))
       ((null ,var))
     ,@body))

(defexportmacro dolist-with-prev ((var list prev-var) &body body)
  (let ((var-list (gensym "VAR-LIST-")))
    `(do ((,var-list ,list (cdr ,var-list))
	  (,prev-var nil ,var-list))
	 ((null ,var-list))
       (let ((,var (car ,var-list)))
	 ,@body))))

;iterate and ilabels are like labels except that only tail recursion is allowed
;and it compiles into an iteration.

(defexportmacro iterate (tag specs &body body)
  (let ((vars (mapcar #'car specs))
	(id (gensym)))
    `(block ,id
       (let ,specs
	 (tagbody
	   ,id (macrolet ((,tag ,vars
			   `(progn (psetq ,@(list ,@(mapcan #'(lambda (var)
								`(',var ,var))
							    vars)))
				   (go ,',id))))
		 (return-from ,id (progn ,@body))))))))

(defexport find-best (pred list)
  (when list
    (iterate loop ((best (car list))
		   (rest (cdr list)))
      (cond ((null rest)
	     best)
	    ((funcall pred best (car rest))
	     (loop best (cdr rest)))
	    (t
	     (loop (car rest) (cdr rest)))))))


(defexportmacro find-and-delete-best (pred list)
  (let ((list-var (gensym "LIST-VAR-"))
	(best-prev (gensym "BEST-PREV-"))
	(best (gensym "BEST-"))
	(item (gensym "ITEM-"))
	(prev (gensym "PREV-")))
    `(let* ((,list-var ,list)
	    (,best-prev nil)
	    (,best (car ,list-var)))
       (dolist-with-prev (,item ,list-var ,prev)
	 (when (funcall ,pred ,item ,best)
	   (setf ,best-prev ,prev)
	   (setf ,best ,item)))
       (if ,best-prev
	   (setf (rest ,best-prev) (rest (rest ,best-prev)))
	   (pop ,list))
       ,best)))

(export 'long-union)

(eval-when (compile eval load)

  (defun long-union (&rest lists)
    (iterate rec-union ((to-do lists)
			(result '()))
	     (if to-do
		 (rec-union (rest to-do) (union (first to-do) result))
		 result))))

(export 'long-union-equal)

(eval-when (compile eval load)

  (defun long-union-equal (&rest lists)
    (iterate rec-union ((to-do lists)
			(result '()))
	     (if to-do
		 (rec-union (rest to-do) (union (first to-do) result :test #'equal))
		 result))))

(defexportmacro ilabels (bindings &body body)
  `(macrolet ,(mapcar (lambda (definition)
			`(,(first definition) ,(second definition)
			  `(progn (psetq ,@(list ,@(mapcan #'(lambda (var)
							       `(',var ,var))
							   (second definition))))
				  (go ,',(first definition)))))
		      bindings)
     (prog ,(apply #'long-union (cons nil (mapcar 'cadr bindings)))
	   (tagbody
	     (return (progn ,@body))
	     ,@(mapcan #'(lambda (definition)
			   `(,(car definition)
			     (return (progn ,@(cddr definition)))))
		       bindings)))))



;system initialization is generally useful

(defexport combine-symbols (s1 s2 &optional (package *package*))
  (intern (concatenate 'string (string s1) "-" (string s2))
	  package))

(defexport combine-symbol-list (s-list &optional (package *package*))
  (cond ((null s-list) nil)
	((null (rest s-list)) (car s-list))
	(t (combine-symbols (car s-list)
			    (combine-symbol-list (cdr s-list) package)
			    package))))

(defexport create-name (&rest symbols)
  (combine-symbol-list symbols))

(defexport map-to-package (symbol &optional (package *package*))
  (intern (string symbol) package))

(defexportmacro initable (&optional (package *package*))
  (let ((system-init (map-to-package 'system-init package))
	(system-init-phase1 (map-to-package 'system-init-phase1 package))
	(system-init-phase2 (map-to-package 'system-init-phase2 package))
	(system-init-phase3 (map-to-package 'system-init-phase3 package))
	(system-init-phase4 (map-to-package 'system-init-phase4 package)))
    `(progn (defun ,system-init ()
	      (initialize-marking)
	      (initialize-contexts)
	      (,system-init-phase1)
	      (,system-init-phase2)
	      (,system-init-phase3)
	      (,system-init-phase4))
	    (defpiecefun ,system-init-phase1 ())
	    (defpiecefun ,system-init-phase2 ())
	    (defpiecefun ,system-init-phase3 ())
	    (defpiecefun ,system-init-phase4 ()))))

(defexportmacro def-inited-var (variable &optional value)
  `(progn (defvar ,variable ,value)
	  (defpiece (,(map-to-package 'system-init-phase1)
		     ,(combine-symbols 'init variable))
		    ()
	    (setq ,variable ,value))))


(defvar *free-increment* 1000)

(defvar *free-list* (list (list nil)))

(defun make-free-list (size)
  (cond ((= size 0) nil)
	(t  (cons (cons nil nil) (make-free-list (1- size))))))

(defun init-free-list (size)
  (setq *free-list* (make-free-list size)))

(defmacro free-list-cdr (free-list)
  `(or (cdr ,free-list)
       (setf (cdr ,free-list) (make-free-list *free-increment*))))


;(defmacro with-stack-maplist ((var fun list) &body body)
;  (let ((result (gensym)))
;    `(if ,list
;       (let ((,result (car *free-list*)))
;	 (setf (car ,result) (opt-funcall ,fun ,list))
;	 (let ((,var ,result))
;	   (let ((*free-list*
;		   (iterate mapper ((todo-list (cdr ,list))
;				    (last-cell ,result)
;				    (internal-free-list (free-list-cdr *free-list*)))
;		     (if todo-list
;			 (let ((new-cell (car internal-free-list)))
;		           (setf (car new-cell)
;				 (opt-funcall ,fun todo-list))
;			   (setf (cdr last-cell) new-cell)
;			   (mapper (cdr todo-list)
;				   new-cell
;				   (free-list-cdr internal-free-list)))
;			 (setf (cdr last-cell) nil)
;			 internal-free-list))))
;		,@body)))
;       (let ((,var nil))
;	    ,@body))))
;
;(defmacro without-stack-maplist ((var fun list) &body body)
;  `(let ((,var (iterate mapper ((to-do-list ,list)
;				(result nil))
;		 (if to-do-list
;		     (mapper (cdr to-do-list)
;			     (cons (opt-funcall ,fun to-do-list) result))
;		     result))))
;     ,@body))
;
;(defmacro opt-funcall (fun &rest args)
;  (if (and (listp fun)
;           (eq (car fun) 'function)
;	    (eq (car (second fun)) 'lambda)
;	    args
;	    (null (cdr args)))
;      (subst (car args) (car (second (second fun))) (third (second fun)))
;      `(funcall ,fun ,@args)))
;
;
;;; test cases for time consumed by free-list business
;;;
;(defun test-wsml nil (time (with-stack-maplist (x #'(lambda(x)(car x)) test-list) x)) t)
;(defun test-wosml nil(time (without-stack-maplist (x #'(lambda(x)(car x)) test-list) x)) t)
;(defun test-clml nil (time (maplist #'(lambda(x)(car x)) test-list)) t)
;
;(defmacro opt-funcall1 (fun &rest args)
;  `(funcall ,fun ,@args))
;

; The following stuff is apparently not used anywhere.  -JAR

(defmacro freeblock (&body body)
  `(let ((*free-list* *free-list*)) ,@body))

(defmacro fcons (arg1 arg2)
  `(let ((new-cell (car *free-list*)))
     (setf (car new-cell) ,arg1)
     (setf (cdr new-cell) ,arg2)
     (setf *free-list* (free-list-cdr *free-list*))))

(defun test-fcons (size)
  (time (freeblock (fconser size))))

(defun test-cons (size)
  (time (conser size)))

(defun conser (size)
  (if (= size 0)
      nil
      (cons nil (conser (1- size))))
  t)

(defun fconser (size)
  (if (= size 0)
      nil
      (fcons nil (fconser (1- size))))
  t)



(defexportmacro selectmatch (arg &body cases)
  (let ((arg-var '#:arg-var))
    `(block success
       (let ((,arg-var ,arg))
	  ,@(mapcar (lambda (case)
		      `(block fail
			 ,(unitest (car case)
				   arg-var
				   nil
				   (lambda (ignore) `(return-from success
						       (progn ,@(cdr case)))))))
		    cases)))))

(defmacro guarded-selectmatch (arg &body cases)
  (let ((arg-var '#:arg-var))
    `(block success
      (let ((,arg-var ,arg))
	,@(mapcar (lambda (case)
		    `(block fail
		      ,(unitest (first case)
			arg-var
			nil
			(lambda (ignore) `(if ,(second case)
					   (return-from success
					     (progn ,@(cddr case)))
					   (return-from fail nil))))))
		  cases)))))

(defexportmacro matches? (exp pattern)
  `(selectmatch ,exp (,pattern t)))

(eval-when (compile load eval)
  (defexport variable? (x)
    (and (symbolp x) (string= "?" (subseq (string x) 0 1)))))

(defexport constant? (x)
  (and (symbolp x)
       (not (variable? x))))

(defexport first-word (string)
  (subseq string 0 (position #\- string)))

(defexport copy-var (var)
  (let ((string (string var)))
    (let ((pos (position #\- string)))
      (if pos
	  (gensym (subseq string 0 (1+ pos)))
	  (gensym (concatenate 'string string "-"))))))

(defexport variables (exp)
  (cond ((and (consp exp)
	      (not (eq (car exp) 'quote)))
	 (union (variables (car exp))
		(variables (cdr exp))))
	((variable? exp)
	 (list exp))))

(eval-when (compile load eval)
  (defun unitest (pattern object bound-vars body-continuation)
    (cond ((null pattern)
	   `(if ,object
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))
	  ((listp pattern)
	   (let ((car-var (gensym))
		 (cdr-var (gensym)))
	     `(if (not (and ,object (listp ,object)))
		  (return-from fail nil)
		  ,(cond ((and (eq (car pattern) :anything)
			       (eq (cdr pattern) :anything))
			  (funcall body-continuation bound-vars))
			 ((eq (car pattern) :anything)
			  `(let ((,cdr-var (cdr ,object)))
			     ,(unitest (cdr pattern) cdr-var bound-vars body-continuation)))
			 ((eq (cdr pattern) :anything)
			  `(let ((,car-var (car ,object)))
			     ,(unitest (car pattern) car-var bound-vars body-continuation)))
			 (t
			  `(let ((,car-var (car ,object))
				 (,cdr-var (cdr ,object)))
			     ,(unitest (car pattern) car-var bound-vars
				       (lambda (bound-vars)
					 (unitest (cdr pattern)
						  cdr-var
						  bound-vars
						  body-continuation)))))))))
	  ((eq pattern :anything) (funcall body-continuation bound-vars))
	  ((not (variable? pattern))
	   `(if (not (eq ,object ',pattern))
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))

	  ((member pattern bound-vars)
	   `(if (not (equal ,object ,pattern))
		(return-from fail nil)
		,(funcall body-continuation bound-vars)))
	  (t
	   `(let ((,pattern ,object))
	      ,(funcall body-continuation (cons pattern bound-vars)))))))




(defexport internal-member (item s-exp)
  (or (eq item s-exp)
      (and s-exp
	   (consp s-exp)
	   (or (internal-member item (car s-exp))
	       (internal-member item (cdr s-exp))))))

(defexport opt-funcall (fun args)
  (if (and (listp fun)
	   (eq (car fun) 'lambda))
      (iterate loop ((expression (third fun))
		     (params (second fun))
		     (args args))
	(if (null params)
	    expression
	    (loop (subst (car args) (car params) expression)
		  (cdr params)
		  (cdr args))))
      `(funcall ,fun ,@args)))



;; Recursion unrolling optimization

;; (unroll n (defun ...) (defun ...))  unrolls each function call down to n levels.
;;  Warning -- the size of the code generated can be exponential in n.
;
;the following is a fast sum procedure.  The tenfold unrolling of the
;following list-sum procedure is 3 times faster than the simple (un-unrolled)
;recursive version.  This indicates the procedure is 2/3 recursion overhead.
;
;(unroll 10
;  (defun list-sum (list)
;    (if (null list) 0 (+ (car list) (list-sum (cdr list))))))

(defexportmacro unroll (n &body defuns)
  (when (< n 1)
    (error "unroll used with no expansions (expansion count less than 1)"))
  (let ((function-alist (mapcar #'cdr defuns)))
    (labels ((unroll-expression (exp n)
	       (if (atom exp)
		   exp
		   (let ((def (assoc (car exp) function-alist)))
		     (if def
			 (unroll-application def (cdr exp) n)
			 (mapcar (lambda (exp2) (unroll-expression exp2 n))
				 exp)))))
	     (unroll-application (def arglist n)
	       (if (= n 0)
		   (cons (car def) arglist)
		   (let* ((newarg-alist (mapcar (lambda (arg) (cons arg (copy-symbol arg)))
						(second def)))
			  (bindings (mapcar (lambda (newarg-pair arg)
					      (list (cdr newarg-pair)
						    (unroll-expression arg (1- n))))
					    newarg-alist
					    arglist)))
		     `(let ,bindings
			,@(mapcar (lambda (exp)
				    (unroll-expression (sublis newarg-alist exp) (1- n)))
				  (cddr def)))))))
    `(progn ,@(mapcar (lambda (def)
			`(defun ,(first def) ,(second def)
			   ,@(mapcar (lambda (exp) (unroll-expression exp n))
				     (cddr def))))
		      function-alist)))))



;Marks

;; The following structure is to be included in other structures.

(export 'markable-thing)
(export 'mark)

(defstruct (markable-thing (:conc-name nil))
  (mark 0))

(export 'simply-markable)
(export 'contents)

(defstruct (simply-markable (:include markable-thing))
  contents)

(export 'markabilize)

(definline markabilize (thing)
  (make-simply-markable :contents thing))

(export 'unmarkabilize)

(definline unmarkabilize (thing)
  (simply-markable-contents thing))

;The stack of marked objects is used for restoring previous marking states.

(defvar *mark-stack-pointer* 0)
(defvar *mark-stack-size* 5000)
(defvar *marked-objects* (make-array *mark-stack-size*))
(defvar *old-mark-array* (make-array *mark-stack-size*))

;Marks are numbers.

(defvar *smallest-mark* 0 "the smallest active mark")
(defvar *largest-mark* 0 "the largest active mark")

(defexport initialize-marking ()
  (setq *mark-stack-pointer* 0)
  (setq *smallest-mark* 0)
  (setq *largest-mark* 0))

(export 'active-mark?)

(definline active-mark? (mark)
  (not (< mark *smallest-mark*)))

(export 'earliest-active-mark?)

(definline earliest-active-mark? (mark)
  (= mark *smallest-mark*))

(export 'latest-active-mark?)

(definline latest-active-mark? (mark)
  (= mark *largest-mark*))

(export 'unmarked?)

(definline unmarked? (obj)
  (< (mark obj) *smallest-mark*))

(export 'marked?)

(definline marked? (obj)
  (not (unmarked? obj)))

(export 'most-recently-marked?)

(definline most-recently-marked? (obj)
  (= (mark obj) *largest-mark*))

(export 'push-mark)
(definline push-mark ()
  (incf *largest-mark*))

(export 'mark!)

(definline mark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) *largest-mark*))

(export 'unmark!)

(definline unmark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) 0))

(export 'mark-with-earliest-active-mark!)
(definline mark-with-earliest-active-mark! (obj)
  (incf *mark-stack-pointer*)
  (setf (aref *marked-objects* *mark-stack-pointer*) obj)
  (setf (aref *old-mark-array* *mark-stack-pointer*) (mark obj))
  (setf (mark obj) *smallest-mark*))

(defmacro marking-and-clearing (obj &body body)
  (let ((obj-var (gensym "OBJ-"))
	(old-mark (gensym "OLD-MARK-")))
    `(let* ((,obj-var ,obj)
	    (,old-mark (mark ,obj-var)))
       (setf (mark ,obj-var) *largest-mark*)
       (unwind-protect (progn ,@body)
	 (setf (mark ,obj-var) ,old-mark)))))

(defexportmacro with-mark-level (&body body)
  (let ((old-stack-pointer (gensym "OLD-POINTER-")))
    `(let* ((*smallest-mark* (1+ *largest-mark*))
	    (*largest-mark* *smallest-mark*)
	    (,old-stack-pointer *mark-stack-pointer*))
       (unwind-protect
	   (progn ,@body)
	 (while (not (= *mark-stack-pointer* ,old-stack-pointer))
	   (setf (mark (aref *marked-objects* *mark-stack-pointer*))
		 (aref *old-mark-array* *mark-stack-pointer*))
	   (decf *mark-stack-pointer*))))))



;Utilities built on marking

(defexport mark-all-members (s)
  (dolist (x s)
    (mark! x)))

(defexport append-unmarked (s2 s1)
  (iterate append-u-internal ((rest s2) (result s1))
    (cond ((null rest)
	   result)
	  ((marked? (car rest))
	   (append-u-internal (cdr rest) result))
	  (t
	   (append-u-internal (cdr rest) (cons (car rest) result))))))

(defexport marking-append-unmarked (s2 s1)
  (iterate append-u-internal ((rest s2) (result s1))
    (cond ((null rest)
	   result)
	  ((marked? (car rest))
	   (append-u-internal (cdr rest) result))
	  (t
	   (mark! (car rest))
	   (append-u-internal (cdr rest) (cons (car rest) result))))))

;
;;there must be no active marks in set1 when this is called
;
;(defun mark-union (set1 set2)
;  (push-mark)
;  (mark-all-members set1)
;  (let ((result (append-unmarked set2 set1)))
;    (clear-most-recent-mark)
;    result))


(defexport mark-union (&rest sets)
  (with-mark-level
    (mark-all-members (car sets))
    (iterate repeat-append-unmarked ((rest-sets (rest sets)) (result (car sets)))
      (if (null rest-sets)
	  result
	  (repeat-append-unmarked (rest rest-sets)
				  (marking-append-unmarked (car rest-sets) result))))))


(defexport collect-marked (set)
  (iterate continue-collect-marked ((rest set) (result nil))
    (cond ((null rest) result)
	  ((marked? (car rest))
	   (continue-collect-marked (cdr rest) (cons (car rest) result)))
	  (t
	   (continue-collect-marked (cdr rest) result)))))

(defexport delete-unmarked (set)
  (ilabels ((delete-prefix ()
	      (cond ((null set) nil)
		    ((marked? (car set))
		     (continue-delete-unmarked set (cdr set)))
		    (t (setq set (cdr set))
		       (delete-prefix))))
	    (continue-delete-unmarked (prev current)
	      (cond ((null current) set)
		    ((marked? (car current))
		     (continue-delete-unmarked current (cdr current)))
		    (t
		     (let ((rest (cdr current)))
		       (setf (cdr prev) rest)
		       (continue-delete-unmarked current rest))))))
    (delete-prefix)))

(defexport mark-intersection (set1 set2)
  (with-mark-level
    (mark-all-members set1)
    (collect-marked set2)))




;; Priority queueus.

(export '*max-pqueue-size*)

(defvar *max-pqueue-size* 100)

(export 'priority-queue)

(defstruct (priority-queue (:conc-name nil))
  (queue-array (make-array *max-pqueue-size*))
  (priority-array (make-array *max-pqueue-size*))
  (last-elt 0)
  (pq-size *max-pqueue-size*))

(defexport make-pqueue (size)
  (let ((*max-pqueue-size* size))
    (make-priority-queue)))

(definline car-index (i) (+ i i))
(definline cdr-index (i) (+ i i 1))

(definline parent-index (i) (floor (/ i 2)))

(defun insert-pqueue (value pri q)
  (let ((array (queue-array q))
	(p-array (priority-array q)))
    (macrolet ((move-to (val pri index)
		 `(progn (setf (aref array ,index) ,val)
			 (setf (aref p-array ,index) ,pri))))
      (let ((cur-index (incf (last-elt q))))
	(when (= cur-index (pq-size q))
	  (error "Priority queue grew beyond maximum alloted size"))
	(iterate continue-move-up ((cur-index (last-elt q)))
	  (if (eq cur-index 1)
	      (move-to value pri cur-index)
	      (let* ((p-index (parent-index cur-index))
		     (p-pri (aref p-array p-index)))
		(cond ((>= pri p-pri)
		       (move-to value pri cur-index))
		      (t
		       (move-to (aref array p-index) p-pri cur-index)
		       (continue-move-up p-index))))))))))

(export 'empty-queue)

(definline empty-queue (q) (= (last-elt q) 0))

;;; user must check empty-queue before calling---error not handled

(defexport pop-pqueue (q)
  (let* ((array (queue-array q))
	 (p-array (priority-array q))
	 (last (last-elt q))
	 (last-value (aref array last))
	 (last-pri (aref p-array last))
	 (first-value (aref array 1))
	 (first-pri (aref p-array 1)))
	(decf last)
	(setf (last-elt q) last)
	(move-down last-value last-pri array p-array last)
	(values first-value first-pri)))

(defun move-down (value pri array p-array last)
  (macrolet ((move-to (val pri index)
	       `(progn (setf (aref array ,index) ,val)
		       (setf (aref p-array ,index) ,pri))))
    (iterate continue-move-down ((cur-index 1))
      (if (= cur-index last)
	  (move-to value pri cur-index)
	  (let ((left-index (car-index cur-index)))
	    (if (> left-index last)
		(move-to value pri cur-index)
		(let ((left-pri (aref p-array left-index)))
		  (if (= left-index last)
		      (cond ((<= pri left-pri)
			     (move-to value pri cur-index))
			    (t
			     (move-to (aref array left-index) left-pri cur-index)
			     (move-to value pri left-index)))
		      (let* ((right-index (1+ left-index))
			     (right-pri (aref p-array right-index)))
			(cond ((<= pri left-pri)
			       (cond ((<= pri right-pri)
				      (move-to value pri cur-index))
				     (t
				      (move-to (aref array right-index) right-pri cur-index)
				      (continue-move-down right-index))))
			      ((< right-pri left-pri)
			       (move-to (aref array right-index) right-pri cur-index)
			       (continue-move-down right-index))
			      (t
			       (move-to (aref array left-index) left-pri cur-index)
			       (continue-move-down left-index))))))))))))

(export 'clear-pqueue)

(definline clear-pqueue (q)
  (setf (last-elt q) 0))

;the following is really just a test function

;(defun empty (q)
;  (when (not (= 0 (last-elt q)))
;    (cons (pop-pqueue q)
;	  (empty q))))
;
;(defun print-heap (q)
;  (let ((array (queue-array q))
;	(last (last-elt q)))
;    (ilabels ((print-from-index (index)
;		(when (<= index last)
;		  (list (aref array index)
;			(print-from-index (car-index index))
;			(print-from-index (cdr-index index))))))
;      (print-from-index 1))))


(defvar *context-stack* '())
(defvar *base-context*)
(proclaim '(special *base-context*))
(defvar *current-context*)
(defvar *context-counter* 0)
(defvar *assumption-stack* nil)
(defvar *contradictory-context* nil)

(defun initialize-contexts ()
  ;We must insure that control has
  ;returned to the top level, i.e., there are no clreanup
  ;forms currently on the Lisp stack.
  (when (and (boundp '*current-context*) (not (eq *current-context* *base-context*)))
    (error "Attempt to initialize Ontic when the context stack is not empty"))
  (setq *context-counter* 0)
  (setf *contradictory-context* nil)
  (init-context-stack)
  (setq *base-context* (first *context-stack*)))

(defstruct (context (:copier nil)
		    (:print-function print-context)
		    (:constructor make-context (level)))
  (id (incf *context-counter*))
  level
  (active? t))

;(definline context-active? (context)
;  (cdr context))
;
;(definline context-level (context)
;  (car context))

(defun print-context (context stream depth)
  (declare (ignore depth))
  (if (context-active? context)
      (format stream "C-~s" (context-level context))
      (format stream "inactive-C")))

;(definline make-context (level)
;  (cons level t))

(defun init-context-stack ()
  (setq *context-counter* 0)
  (setq *context-stack* '())
  (let ((new-context (make-context 0)))
    (push new-context *context-stack*)
    (setq *current-context* new-context)))

(defun push-context ()
  (let ((new-context (make-context (1+ (context-level *current-context*)))))
    (push new-context *context-stack*)
    (setq *current-context* new-context)))


;in-new-context returns as a value the set of assertions added to the sub-context

(defmacro in-new-context (&body body)
  `(unwind-protect (progn (push-context) ,@body)
     (pop-context)))

; The following occurs in a cleanup form in the above.  Thus, the following
; function can not call error (very
; horrible things happen if you call error from a cleanup form)

(defun pop-context ()
  (if (null (cdr *context-stack*))
      (format t "Warning: you are popping the base context")
      (let ((old-context (pop *context-stack*)))
	(setf (context-active? old-context) nil)
	(setq *current-context* (car *context-stack*)))))

(defun context-contradictory? (context)
  (and *contradictory-context*
       (context-active? *contradictory-context*)
       (context-less-or-equalp *contradictory-context* context)))

(defun assert-contradiction (context)
  (when (not (context-contradictory? context))
    (setf *contradictory-context* context))
    (format t "~%Contradiction in ~s" context))

(definline context-lessp (c1 c2)
  (< (context-level c1) (context-level c2)))

(definline context-less-or-equalp (c1 c2)
  (<= (context-level c1) (context-level c2)))


(definline context-maxer (c1 c2)
  (if (context-lessp c1 c2) c2 c1))

(defmacro context-max (c1 &rest c-list)
  (cond ((null c-list)
	 c1)
	((null (rest c-list))
	 `(context-maxer ,c1 ,(first c-list)))
	(t
	 `(context-maxer ,c1 (context-max ,@c-list)))))

(definline context-min-er (c1 c2)
  (if (context-lessp c1 c2) c1 c2))

(defmacro context-min (c1 &rest c-list)
  (cond ((null c-list)
	 c1)
	((null (rest c-list))
	 `(context-min-er ,c1 ,(first c-list)))
	(t
	 `(context-min-er ,c1 (context-min ,@c-list)))))

(definline parent-context ()
  (if (eq *current-context* *base-context*)
      *base-context*
      (second *context-stack*)))

;a bound is either nil or a context.  Nil represents the infinite bound.

(definline bound-min (b1 b2)
  (cond ((null b1) b2)
	((null b2) b1)
	((context-min b1 b2))))

(definline bound-max (b1 b2)
  (and b1 b2 (context-max b1 b2)))

(definline bound-lessp (b1 b2)
  (and b1
       (or (null b2)
	   (context-lessp b1 b2))))

(definline bound-less-or-equalp (b1 b2)
  (not (bound-lessp b2 b1)))

(definline bound-active? (bound)
  (or (null bound)
      (context-active? bound)))




(definline make-cpair (term context)
  (cons term context))

(definline cpair-item (cpair)
  (car cpair))

(definline cpair-context (cpair)
  (cdr cpair))

(definline cpair-active? (cpair)
  (context-active? (cpair-context cpair)))

; CP-SETF returns nil if the setf operation did not change the state of
; the generalized variable.  This can be used for testing if a cp-setf
; operation should propagate inferences.

(defmacro cp-setf (genvar item context)
  (let ((formval (gensym)))
    `(let ((,formval ,genvar))
       (when (or (null ,formval) (not (cpair-active? ,formval))
		 (context-lessp ,context (cpair-context ,formval)))
	 (setf ,genvar (make-cpair ,item ,context))))))

(defmacro cp-getf (genvar)
  (let ((formval (gensym)))
    `(let ((,formval ,genvar))
       (cond ((null ,formval)
	      (values :unknown *base-context*))
	     ((cpair-active? ,formval)
	      (values (cpair-item ,formval) (cpair-context ,formval)))
	     (t
	      (setf ,genvar nil)
	      (values :unknown *base-context*))))))


; The second kind of generalized variable holds a list of values.

(defmacro cp-push (item context cp-list)
  `(push (make-cpair ,item ,context) ,cp-list))

(defmacro do-cp-list ((itemvar contextvar cp-list-form) &body body)
  (let ((cp-list (gensym)))
    `(ilabels ((remove-obsolete-initials (,cp-list)
		(when ,cp-list
		  (cond
		    ((cpair-active? (car ,cp-list))	;active
		      (let ((,itemvar (cpair-item (car ,cp-list)))
			    (,contextvar (cpair-context (car ,cp-list))))
			,@body)
		      (process-cdr ,cp-list))
		    (t  ;;obsolete
		      (setf ,cp-list-form (cdr ,cp-list))
		      (remove-obsolete-initials (cdr ,cp-list))))))
	      (process-cdr (,cp-list)
		(when (cdr ,cp-list)
		  (cond
		    ((cpair-active? (second ,cp-list))	;active
		      (let ((,itemvar (cpair-item (second ,cp-list)))
			    (,contextvar (cpair-context (second ,cp-list))))
			,@body)
		      (process-cdr (cdr ,cp-list)))
		    (t ;;;obsolete
		      (setf (cdr ,cp-list) (cddr ,cp-list))
		      (process-cdr ,cp-list))))))
       (remove-obsolete-initials ,cp-list-form))))

(export 'call-debugger)

#+Symbolics
(defun call-debugger ()
  (dbg:dbg))

#-Symbolics
(defun call-debugger ()
  (break))

(defexportmacro guarantee (form)
  `(when (not ,form)
     (format t "~%Failed to guarantee the invariant ~s" ',form)
     (call-debugger)))

(definline xor (&rest truth-vals)
  (= (mod (count-if (lambda (truth-val) truth-val) truth-vals) 2) 1))

(defexport circular-p (sexp &optional (seen nil))
  (cond ((atom sexp) nil)
	((member sexp seen) t)
	(t (or (circular-p (car sexp) (cons sexp seen))
	       (circular-p (cdr sexp) (cons sexp seen))))))

(defexport negation (form)
  (selectmatch form
    ((not ?form2) ?form2)
    (:anything `(not ,form))))


(defexportmacro nmapcar (fun list)
  (let ((list-var (gensym "LIST-"))
	(remaining (gensym "REMAINING-")))
    `(let ((,list-var ,list) )
       (do ((,remaining ,list-var (rest ,remaining)))
	   ((null ,remaining) ,list-var)
	 (setf (car ,remaining)
	       (funcall ,fun (car ,remaining)))))))

(defexport apply-to-cross-product (fun lists)
  (labels ((build-tuple-and-apply-fun (remaining-lists tuple)
	     (if (null remaining-lists)
		 (list (apply fun tuple))
		 (mapcan (lambda (item)
			   (build-tuple-and-apply-fun (rest remaining-lists)
						      (cons item tuple)))
			 (first remaining-lists)))))
    (build-tuple-and-apply-fun (reverse lists) nil)))



(defexport some-intersection (list1 list2)
  (dolist (elt list1)
    (when (member elt list2)
      (return-from some-intersection t)))
  nil)


(defexport npartition (list fun)
  (let ((in nil)
	(out nil))
    (do* ((list list rest-list)
	  (rest-list (rest list) (rest rest-list)))
	 ((null list) (values in out))
      (if (funcall fun (first list))
	  (progn (setf (rest list) in)
		 (setf in list))
	  (progn (setf (rest list) out)
		 (setf out list))))))

(defexport set-equal (set1 set2)
  (and (subsetp set1 set2)
       (subsetp set2 set1)))

(defexportmacro apply-if (flag munger exp &rest other-args)
  `(if ,flag
       (apply ,munger ,exp (list ,@other-args))
       ,exp))

(defexportmacro apply-if-not (flag munger exp &rest other-args)
  `(if ,flag
       ,exp
       (apply ,munger ,exp (list ,@other-args))))

(defexport flatten (exp)
  (if (consp exp)
      (nconc (flatten (car exp)) (flatten (cdr exp)))
      (list exp)))

(defexport expose (val str &rest forms)
  (format t "~%~A~s " str val)
  (dolist (form forms) (format t "--- ~s" form))
  val)

(defexport expose-if (do-it? val str &rest forms)
  (when do-it?
    (format t "~%~A~s " str val)
    (dolist (form forms) (format t "--- ~s" form)))
  val)

(export 'equal-member)
(definline equal-member (x y)
  (member x y :test #'equal))

(defexportmacro re-bind ((&rest vars) &body body)
  `(let ,(mapcar (lambda (var) (list var var)) (remove-duplicates vars))
     ,@body))

(defexport ms-time-diff (t1 t2)
  (round (* (- t1 t2) 1000)
	 internal-time-units-per-second))


(defvar *bridge-min-wait* 100)
(export '*bridge-min-wait*)
(defvar *compile-noticer* #'(lambda (&rest args) args))
(export '*compile-noticer*)

;; kcz -- filtered non-defuns
;;
(defexport compile-defuns (defuns)
  (mapc (lambda (form)
	  (if (eq (car form) 'defun)
	      (compile (cadr form)
		       `(lambda ,(caddr form) ,@(cdddr form)))
	      (eval form)))
	defuns))


(defexportmacro ctime (form)
  `(funcall (compile nil '(lambda () (time ,form)))))

(defexport file-forms (filename)
  (let ((forms nil)
	(eof-marker (list 'eof)))
    (with-open-file (istream filename :direction :input)
      (iterate loop ()
	       (let ((form (read istream nil eof-marker)))
		 (unless (eq form eof-marker)
		   (push form forms)
		   (loop)))))
    (nreverse forms)))

(defexport write-forms (forms filename)
    (let ((*print-level* 1000)
	  (*print-length* 1000)
	  (*print-circle* t))
      (with-open-file (istream filename :direction :output :if-exists :overwrite
			       :if-does-not-exist :create)
	(dolist (form forms)
	  (format istream "~%~% ~s" form))))
  t)



;;;     A copy of file pieces.lisp:


;;
;;(defmacro defpiecefun (name args)
;;  (let ((piece (gensym)))
;;    `(defun ,name ,args				;
;;       (mapc #'(lambda (,piece) (funcall (cdr ,piece) ,@args))
;;	     (get ',name 'pieces)))))
;;
;;(defmacro defpiece ((fun piece-name) args &body body)
;;  `(pushnew (cons ',piece-name #'(lambda ,args ,@body))
;;	    (get ',fun 'pieces)
;;	    :key #'car))
;;


;;piece functions:
;;   (defpiecefun 'fun-name args) must be executed before any pieces are defined
;;   (defpiece (fun-name piece-name) args body) adds or replaces the piece named
;;      by piece-name.
;;   any piece of the form (when test body) will be consolidated with other
;;      pieces of that form with the same test.
;; piece-functions are compiled the first time they are used after being
;;    redefined.  at that time, the new compiled definition is saved and reused until
;;    another redefinition occurs.
;;


;; a "piece" is a cons of a test and a list of forms to run when that test is true

(defvar *the-piecefuns* nil)

(eval-when (compile eval load)
  (defun make-piece (test body-forms) (cons test body-forms)))
(defun body-part (piece) (rest piece))
(defun test-part (piece) (first piece))

(defun thing-type-test-p (test of-what)		;Kind of gross
  (and (consp test)
       (eq (car test) 'thing-typep)
       (consp (cdr test))
       (eq (cadr test) of-what)
       (consp (cddr test))
       (consp (caddr test))
       (eq (car (caddr test)) 'quote)))

(defun thing-type-test-type (test)
  (cadr (caddr test)))

(defun collate (pred list)
  (values (remove-if-not pred list)
	  (remove-if pred list)))

; Test this with e.g.
;  (let ((*print-level* 4)) (print (build-piece-fun 'do-is-rules)) (values))

(defun compute-piecefun-definitions ()
  (mapcar #'(lambda (fun)
	      (selectmatch (build-piece-fun fun)
		((lambda ?args . ?body)
		 `(defun ,fun ,?args . ,?body))))
	  (reverse *the-piecefuns*)))

(defexport build-piece-fun (fun)
  (insert-ignores (build-piece-fun-internal fun)))

(defun insert-ignores (procedure)
  (selectmatch procedure
    ((lambda ?args . ?body)
     `(lambda ,?args
       ,@(append (mapcan #'(lambda (arg) (when (not (internal-member arg ?body))
					   `((declare (ignore ,arg)))))
		  ?args)
	  ?body)))
    ((defun ?name ?args . ?body)
     `(defun ,?name ,?args
       ,@(append (mapcan #'(lambda (arg) (when (not (internal-member arg ?body))
					   `((declare (ignore ,arg)))))
		  ?args)
	  ?body)))    
    (:anything
     (error "insert-ignores applied to non-procedure"))))

(defun build-piece-fun-internal (fun)
  (let ((args (get fun 'piece-args))
	(pieces (mapcar #'(lambda (piece-name)
			    (get fun piece-name))
			(get fun 'pieces))))
    (mvlet (((dispatch-pieces other-pieces)
	     (collate #'(lambda (piece)
			  (thing-type-test-p (test-part piece) (car args)))
		      pieces)))
      `(lambda ,args
	 ,@(mapcan #'(lambda (piece)
		       (if (eq (test-part piece) t)
			   (copy-list (body-part piece))
			   (list `(when ,(test-part piece) ,@(body-part piece)))))
		   (collapse-same-tests other-pieces))
	 ,@(if (null dispatch-pieces)
	       `()
	       `((case (o-thing-type-tag ,(car args))
		   ,@(mapcar #'(lambda (piece)
				 `((,(thing-type-test-type (test-part piece)))
				   ,@(body-part piece)))
			     (collapse-same-tests dispatch-pieces)))))))))

(defun collapse-same-tests (pieces)
  (iterate collapse-same-tests
	   ((pieces (sort pieces #'compare-sexpr :key #'test-part))
	    (when-forms '()))
    (cond ((null pieces) when-forms)
	  ((and (rest pieces)
		(equal (test-part (first pieces))
		       (test-part (second pieces))))
	   (collapse-same-tests
	     (cons (make-piece (test-part (first pieces))
			       (append (body-part (second pieces))
				       (body-part (first pieces))))
		   (rest (rest pieces)))
	     when-forms))
	  (t (collapse-same-tests
	       (rest pieces)
	       (cons (first pieces) when-forms))))))

(defun compare-sexpr (s1 s2)
  (let ((s1-hash (sxhash s1))
	(s2-hash (sxhash s2)))
    (or (< s1-hash s2-hash)
	(and (= s1-hash s2-hash)
	     (not (equal s1 s2))
	     (string-lessp (format nil "~s" s1) (format nil "~s" s2))))))

(defun invalidate-piecefun-compilation (fun)
  (setf (symbol-function fun)
	(lambda (&rest args)
	  (redo-structures)
	  (compile fun (build-piece-fun fun))
	  (apply fun args)))
  fun)

(defun when-test (when-form) (second when-form))
(defun when-forms (when-form) (rest (rest when-form)))

(eval-when (compile load eval)
  (defun one-when-p (body)
    (and body
	 (null (rest body))
	 (consp (first body))
	 (eq (first (first body)) 'when))))

;; The pieces property is a list of the piece names.

(emacs-indent defpiece 2)
(defexportmacro defpiece ((fun piece-name) args &body body)
  `(defpiece-fun ',fun ',piece-name ',args ',body))

(defun defpiece-fun (fun piece-name args body)
  (unless (get fun 'piece-wise)
    (error "~s not defined as piecewise" fun))
  (unless (equal args (get fun 'piece-args))
    (error "illegal arguments for ~s" fun))
  (setf (get fun piece-name)
	(if (one-when-p body)
	    (make-piece (when-test (first body))
			(when-forms (first body)))
	    (make-piece t body)))
  (setf (get fun 'pieces)
	(adjoin piece-name (get fun 'pieces)))
  (invalidate-piecefun-compilation fun))

(defexportmacro defpiecefun (fun args)
  `(defpiecefun-fun ',fun ',args))

(defun defpiecefun-fun (fun args)
  (let ((new-fun (not (member fun *the-piecefuns*))))
    (pushnew fun *the-piecefuns*)
    (setf (get fun 'piece-wise) t)
    (let ((old-args (get fun 'piece-args)))
      (setf (get fun 'piece-args) args)
      (when (or new-fun (not (equal args old-args)))
	(setf (get fun 'pieces) '())
	(invalidate-piecefun-compilation fun)))))

(defmacro clear-local-pieces (&body pieces)
  `(progn
     ,@(mapcar (lambda (piece) (list (first piece) (second piece) (third piece)))
	       pieces)))

(defexport clear-pieces (piece-selector)
  (dolist (fun *the-piecefuns*)
    (setf (get fun 'pieces) (remove-if piece-selector (get fun 'pieces)))
    (invalidate-piecefun-compilation fun)))



;This is a block compilation system that integrates pieces of function
;definitions.
;
;A piece is a series of forms that represent parts of lisp
;code.  For example,
;
;
;(defmergefun function (args))
;
;(defmergepiece (function piece-name) (?x ?y)
; (let ?z (bar ?x ?y))
; (when (pred ?x ?y ?z))
; (dolist ?w (grith ?y ?z))
; (bar ?w ?y))
;
;;should be viewed as an abbreviation for
;
;(defpiece (function piece-name) (?x ?y)
;  (let ((?z (bar ?x ?y)))
;    (when (pred ?x ?y ?z)
;      (dolist (?w (gritch ?y ?z))
;	 (bar ?w ?y)))))
;
;The body of a mergepiece is a series of forms where each form
;other than the last form must be on of the following.

;(let var value)
;(dolist var list-value)
;(when test)

;Multiple pieces can be merged.  For example.

;(defmergepiece (foo part1) (?x ?y)
; (dolist ?w (gritch ?x ?y))
; (let ?z (bar ?x ?w))
; (when (pred ?x ?y ?z))
; (baz1?w ?y))

;and

;(defmergepiece (foo part2) (?x ?y)
; (dolist ?w (gritch ?x ?y))
; (let ?z (bar ?x ?w))
; (baz2 ?w ?y))

;we get

;(defun foo (?x ?y)
;  (dolist (?w (gritch ?x ?y))
;    (let ((?z (bar ?x ?w)))
;      (baz2 ?w ?y)
;      (when (pred ?x ?y ?z)
;	 (baz1 ?w ?y)))))


;;;;;;;  March 1992   -rlg
;;;
;;;  Added (definterpfun ....) same as (defmergfun ...) except that the resulting
;;;  code is not compiled but run by a low-level interpreter, which is included below.
;;;  This is for rules added at run-time.
;;;

;

(defvar *do-merging* t)

(emacs-indent defmergepiece 2)
(defexportmacro defmergepiece ((fun piece-name) args &body body)
  `(defmergepiece-fun ',fun ',piece-name ',args ',body))

(export '*do-merging*)

(property-macro external-pieces)

(property-macro internal-pieces)

(property-macro mergefun-demons)

(defun piece-control-flag (mergefun piecename)
  (create-name mergefun piecename 'flag))

(defun external-fun-name (mergefun piecename)
  (create-name mergefun piecename 'external 'fun))

(defun defmergepiece-fun (fun piece-name args body)
  (let ((funargs (get fun 'piece-args)))
    (unless (get fun 'merge-wise)
      (error "~s not defined as merge-wise" fun))
    (unless (= (length args) (length funargs))
      (error "~s does not match ~s, the arglist of ~s"
	     args
	     funargs
	     fun))
    (let ((rbody (rename-piece funargs args (tag-last-part body (piece-control-flag fun piece-name)))))
      (setf (get fun piece-name) rbody)
      (if *do-merging*
	  (progn (pushnew piece-name (internal-pieces fun))
		 (invalidate-mergefun-compilation fun)
		 (set (piece-control-flag fun piece-name) t)
		 (setf (mergefun-demons fun)
		       (remove (external-fun-name fun piece-name) (mergefun-demons fun)))
		 (setf (external-pieces fun)
		       (remove piece-name (external-pieces fun))))
	  (progn (pushnew piece-name (external-pieces fun))
		 (set (piece-control-flag fun piece-name) nil)
		 (setf (internal-pieces fun)
		       (remove piece-name (internal-pieces fun)))
		 (compile-defuns (external-defuns rbody (external-fun-name fun piece-name) funargs))
		 (pushnew (external-fun-name fun piece-name) (mergefun-demons fun))))
					;The following is for error detection at piece creation time.
      (when *visible-evaluation?*
	(compile-defuns
	 (external-defuns rbody (create-name fun '== piece-name) funargs))))))

(emacs-indent definterppiece 2)
(defexportmacro definterppiece ((fun piece-name) args &body body)
  `(definterppiece-fun ',fun ',piece-name ',args ',body))

(defun definterppiece-fun (fun piece-name args body)
  (let ((funargs (get fun 'piece-args)))
    (unless (get fun 'interp-wise)
      (error "~s not defined as interp-wise" fun))
    (unless (= (length args) (length funargs))
      (error "~s does not match ~s, the arglist of ~s"
	     args
	     funargs
	     fun))
    (let ((rbody (rename-piece funargs args (tag-last-part-simply body))))
      (setf (get fun piece-name) rbody)
      (pushnew piece-name (get fun 'pieces))
      (invalidate-interpfun-compilation fun))))

(eval-when (compile eval load) (defvar *the-mergefuns* '()))
(eval-when (compile eval load) (defvar *the-interpfuns* '()))

(defexport mergefun-p (fun-name) (member fun-name *the-mergefuns*))
(defexport interpfun-p (fun-name) (member fun-name *the-interpfuns*))

(defexportmacro defmergefun (fun args)
  `(eval-when (compile load eval) (defmergefun-fun ',fun ',args)))

(defun defmergefun-fun (fun args)
  (unless (= (length args) (length (remove-duplicates args)))
    (error "Duplicate formal parameter in arglist ~s to function ~s"
	   args fun))
  (unless (every 'variable? args)
    (error "Arguments to DEFMERGEFUN functions must begin with the character '?': ~s"
	    fun))
  (pushnew fun *the-mergefuns*)
  (when (or (not (get fun 'merge-wise))
	    (not (= (length (get fun 'piece-args)) (length args))))
    (setf (internal-pieces fun) nil)
    (setf (external-pieces fun) nil)
    (setf (mergefun-demons fun) nil)
    (setf (get fun 'piece-args) args)
    (setf (get fun 'merge-wise) t)
    (invalidate-mergefun-compilation fun)))

(defexportmacro definterpfun (fun args)
  `(eval-when (compile load eval) (definterpfun-fun ',fun ',args)))

(defun definterpfun-fun (fun args)
  (unless (= (length args) (length (remove-duplicates args)))
    (error "Duplicate formal parameter in arglist ~s to function ~s"
	   args fun))
  (unless (every 'variable? args)
    (error "Arguments to DEFINTERPFUN functions must begin with the character '?': ~s"
	    fun))
  (pushnew fun *the-interpfuns*)
  (when (or (not (get fun 'interp-wise))
	    (not (= (length (get fun 'piece-args)) (length args))))
    (setf (get fun 'pieces) nil)
    (setf (get fun 'piece-args) args)
    (setf (get fun 'interp-wise) t)
    (invalidate-interpfun-compilation fun)
    (setf (symbol-function fun) (lambda (&rest args)
				  (progv (get fun 'piece-args) args
				    (when (get fun 'needs-remerging)
				      (setf (get fun 'merged-body) (interpfun-definition fun))
				      (setf (get fun 'needs-remerging) nil))
				    (interpret (get fun 'merged-body)))))))

(defun invalidate-mergefun-compilation (fun)
  (setf (symbol-function fun)
	(lambda (&rest args)
	  (redo-structures)
	  (compile-defuns (mergefun-definitions fun))
	  (apply fun args)))
  fun)

(defun invalidate-interpfun-compilation (fun)
  (setf (get fun 'needs-remerging) t)
  fun)

(defexport clear-mergepieces (piece-selector)
  (dolist (fun *the-mergefuns*)
    (setf (internal-pieces fun)
	  (remove-if (lambda (piece)
		       (when (funcall piece-selector piece)
			 (if *do-merging*
			     (invalidate-mergefun-compilation fun)
			     (set (piece-control-flag fun piece) nil))
			 t))
		     (internal-pieces fun)))
    (setf (external-pieces fun)
	  (remove-if (lambda (piece)
		       (when (funcall piece-selector piece)
			 (setf (mergefun-demons fun)
			       (remove (external-fun-name fun piece)
				       (mergefun-demons fun)))
			 t))
		     (external-pieces fun)))))

(defexport clear-interppieces (piece-selector)
  (dolist (fun *the-interpfuns*)
    (setf (get fun 'pieces)
	  (remove-if (lambda (piece)
		       (when (funcall piece-selector piece)
			 (invalidate-interpfun-compilation fun)
			 t))
		     (get fun 'pieces)))))

(defexport show-mergepieces (piece-selector)
  (mapcan (lambda (fun)
	    (mapcan (lambda (piecename)
		      (if (funcall piece-selector piecename)
			  `((defmergepiece (,fun ,piecename) ,(get fun 'piece-args)
			      ,(get fun piecename)))
			  nil))
		    (append (internal-pieces fun) (external-pieces fun))))
	  *the-mergefuns*))

(defexport show-interppieces (piece-selector)
  (mapcan (lambda (fun)
	    (mapcan (lambda (piecename)
		      (if (funcall piece-selector piecename)
			  `((definterppiece (,fun ,piecename) ,(get fun 'piece-args)
			      ,(get fun piecename)))
			  nil))
		    (get fun 'pieces)))
	  *the-interpfuns*))


(defun tag-last-part (piece flag)
  (when piece
    (if (null (rest piece))
	`((:lisp ,(if *do-merging*
		      `(when ,flag ,(first piece))
		      (first piece))))
	(cons (first piece)
	      (tag-last-part (rest piece) flag)))))

(defun tag-last-part-simply (piece)
  (when piece
    (if (null (rest piece))
	`((:lisp ,(first piece)))
	(cons (first piece)
	      (tag-last-part-simply (rest piece))))))


(defun rename-piece (fun-args piece-args piece)
  (append (whens-for-equal-args piece-args fun-args)
	  (sublis (mapcar 'cons
			  piece-args
			  fun-args)
		  piece)))

(defun whens-for-equal-args (piece-args fun-args)
  (iterate do-rest ((a-list (mapcar #'cons piece-args fun-args)) (result nil))
    (if a-list
	(let* ((next-arg (car (first a-list)))
	       (equal-car-pairs (remove-if-not (lambda (pair) (eq (car pair) next-arg))
					       (rest a-list))))
	  (do-rest (remove-if (lambda (pair) (eq (car pair) next-arg))
			      (rest a-list))
		   (append (mapcar (lambda (equal-pair)
				     `(when (eq ,(cdr (first a-list))
						,(cdr equal-pair))))
				   equal-car-pairs)
			   result)))
	result)))

(defvar *residual-definitions* nil)

(defun all-mergepieces (name)
  (append (internal-pieces name) (external-pieces name)))

(defun mergefun-definitions (fun-name)
  (let ((body-pieces (mapcar (lambda (piece-name) (get fun-name piece-name))
			     (internal-pieces fun-name)))
	(args (get fun-name 'piece-args)))
    (append (mapcar (lambda (piece-name)
		      `(defvar ,(piece-control-flag fun-name piece-name)))
		    (internal-pieces fun-name))
	    (combine-internal-pieces-to-defuns body-pieces fun-name args))))

(defun interpfun-definition (fun-name)
  (let ((body-pieces (mapcar (lambda (piece-name) (get fun-name piece-name))
			     (get fun-name 'pieces)))
	(args (get fun-name 'piece-args)))
    (combine-pieces body-pieces args :make-code? nil)))

(defun compute-mergefun-definitions ()
  (mapcan 'mergefun-definitions
	  *the-mergefuns*))
  

;Piece combination.
;In the recursive case we have a set of pieces and a set of ``bound variables'',
;i.e., variables that will have values when the code in the pieces is run.

(defun combine-internal-pieces-to-defuns (pieces fun-name args)
  (let* ((*residual-definitions* nil)
	 (main-defun (insert-ignores
		      `(defun ,fun-name ,args
			(dolist (demon (mergefun-demons ',fun-name))
			  (funcall demon ,@args))
			,@(combine-pieces pieces args)))))
    (mapcan #'remember-body
	    (append (reverse *residual-definitions*)
		    (list main-defun)))))

(defun external-defuns (piece fun-name args)
  (let* ((*residual-definitions* nil)
	 (main-defun (insert-ignores
		      `(defun ,fun-name ,args
			,@(combine-pieces (list piece) args)))))
    (mapcan #'remember-body
	    (append (reverse *residual-definitions*)
		    (list main-defun)))))

;; kcz -- change remember-body to return a list of the defun and a setf form
;;
(defun remember-body (def)
  `((setf (get ',(second def) 'defun) ',def)
    ,def))

(defun combine-pieces (pieces bound-vars &key (make-code? t))
  (when pieces
    (let ((next-form (first (first pieces))))
      (unless next-form
	(error "no available next form"))
      (make-body next-form pieces bound-vars :make-code? make-code?))))

(defvar *dolist-count* 0)
(defvar *dolist-included-count* 0)

(defun make-body (head-form pieces bound-vars &key (make-code? t))
  (let ((new-head (alpha-rename-head head-form)))
    (let ((included-pieces nil)
	  (excluded-pieces nil))
      (dolist (piece pieces)
	(let ((first-form (first piece)))
	  (if (form-matches? first-form new-head)
	      (let ((rest-piece (sublis (form-match first-form new-head)
					(cdr piece))))
		(when rest-piece
		  (push rest-piece included-pieces)))
	      (push piece excluded-pieces))))
      (if make-code?
	  (selectmatch new-head
	    ((let ?var ?exp)
	     `((let ((,?var ,?exp))
		 ,@(combine-pieces (nconc included-pieces excluded-pieces)
				   (cons ?var bound-vars)))))
	    ((when ?exp)
	     (let* ((when-body (combine-pieces included-pieces bound-vars)))
	       `((when ,?exp
		   ,@(if (and (some #'cdddr included-pieces)
			      excluded-pieces) ;heuristic for breaking up definitions
			 (call-to-residual when-body bound-vars)
			 when-body))
		 ,@(combine-pieces excluded-pieces bound-vars))))
	    ((dolist ?var ?form)
	     (incf *dolist-count*)
	     (incf *dolist-included-count* (length included-pieces))
	     `((dolist (,?var ,?form)
		 ,@(let ((dolist-body (combine-pieces included-pieces (cons ?var bound-vars))))
		     (if (and (some #'cdddr included-pieces)
			      excluded-pieces)
			 (call-to-residual dolist-body (cons ?var bound-vars))
			 dolist-body)))
	       ,@(combine-pieces excluded-pieces bound-vars)))
	    ((:lisp ?form)
	     (when included-pieces
	       (error "A Lisp form must be the final form in a piece"))
	     `(,?form
	       ,@(combine-pieces excluded-pieces bound-vars)))
	    (:anything (error "unrecognized head in make-body")))
	  (progn
	    (when (and (consp new-head)
		       (eq (car new-head) :lisp)
		       included-pieces)
	      (error "A Lisp form must be the final form in a piece"))
	    (let ((new-bound-vars (append (vars-bound-in new-head) bound-vars)))
	      `(,new-head
		,(combine-pieces included-pieces new-bound-vars :make-code? nil)
		,(combine-pieces excluded-pieces new-bound-vars :make-code? nil))))))))

(defun vars-bound-in (head)
  (and (consp head)
       (when (member (car head) '(let dolist))
	 (let ((var (second head)))
	   (and var
		(list var))))))

(defun measure-sharing ()
  (setq *dolist-count* 0)
  (setq *dolist-included-count* 0)
  (mapc 'mergefun-definitions *the-mergefuns*)
  (format t "~% ~s dolists ~s average included pieces"
	  *dolist-count*
	  (/ (Float *dolist-included-count*) *dolist-count*)))

(defun call-to-residual (body bound-vars)
  (let* ((new-fun (gentemp "FUN-"))
	 (new-args (intersection bound-vars
				 (variables body)))
	 (defun-form `(defun ,new-fun ,new-args
		       ,@body)))
    (push defun-form
	  *residual-definitions*)
    (setf (get new-fun 'defun) defun-form)
    `((,new-fun ,@new-args))))

(defun alpha-rename-head (head)
  (if (member (car head) '(let dolist))
      `(,(car head) ,(copy-var (second head)) ,(third head))
      head))

(defun form-matches? (head form)
    (if (member (car head) '(let dolist))
	(and (eq (car head) (car form))
	     (equal (third head) (third form)))
	(equal head form)))

(defun form-match (new-head form)	;
  (when (member (car new-head) '(let dolist))
    (list (cons (second new-head) (second form)))))

(defun interpret (merged-body)
  (when (consp merged-body)
    (let* ((head (car merged-body))
	   (cdr-body (cdr merged-body))
	   (cddr-body (cdr cdr-body))
	   (included-body (car cdr-body))
	   (excluded-body (car cddr-body)))
      (when (consp head)
	(case (car head)
	  (:lisp (eval (second head)))
	  (let (let* ((cdr-head (cdr head))
		      (var-name (car cdr-head))
		      (cddr-head (cdr cdr-head))
		      (var-val (car cddr-head)))
		 (progv (list var-name) (list (eval var-val))
		   (interpret included-body))))
	  (dolist (let* ((cdr-head (cdr head))
			 (var-name (car cdr-head))
			 (cddr-head (cdr cdr-head))
			 (list-exp (car cddr-head)))
		    (dolist (i (eval list-exp))
		      (progv (list var-name) (list i)
			(interpret included-body)))))
	  (when (when (eval (cadr head))
		  (interpret included-body))))
	(interpret excluded-body)))))



;
;piecewise definition of structures.
;
;(defpiecestruct foo)
;
;(defslot foo slot1)
;
;(defpiecestruct bar :include foo)
;
;(defslot bar slot2)
;
;(piece-structure-definitions)
;
;piece structures are strictly monotonic --- removal of structure names
;or slots is not allowed.  This avoids a bunch of implementation problems
;and is not really much of an inconvenience (the non-removal of slots
;will make structures temporarilly space inefficient.)
;
;defslot defines the slot macro independent of the creation of the
;structure definition.  This allows the slot macro to be used
;as soon as the slot is defined.
;
;default values are not allowed in slots.
;
;no structor specifications are allowed in piece structures.
;there is no conc-name.
;the print function for structure foo is print-foo and must be user defined.
;
;No structure functions are defined until one evaluates or compiles
;(piece-structure-definitions).
;

(defvar *the-piecestructs* nil)

(defexport category-constructor-function (name)
  (combine-symbols 'make name (symbol-package name)))

(defexport category-predicate (name)
  (combine-symbols name 'p (symbol-package name)))

(defexport category-print-function (name)
  (combine-symbols 'print name (symbol-package name)))

(property-macro slot-names)
		
(property-macro byte-slot-names)

(property-macro bit-slot-names)

(property-macro parent-structure)

(defvar *redo-structures* nil)

(defun structure-functions (struct)
  (list* (category-constructor-function struct)
	 (category-predicate struct)
	 (mapcar #'car (slot-names struct))))

(defun invalidate-compilations ()
  (setq *redo-structures* t)
  (mapc (lambda (struct)
	  (setf (symbol-function (category-constructor-function struct))
		(lambda ()
		  (redo-structures)
		  (funcall (category-constructor-function struct)))))
	 *the-piecestructs*)
  (mapc 'invalidate-piecefun-compilation *the-piecefuns*)
  (mapc 'invalidate-mergefun-compilation *the-mergefuns*))

(defexportmacro defpiecestruct (name &key include)
  `(defpiecestruct-fun ',name ',include))

(defun defpiecestruct-fun (name parent)
  (when parent
    (when (and (parent-structure name)
	       (not (eq (parent-structure name) parent)))
      (error "attempt to change the parent structure of a piecestruct"))
    (setf (parent-structure name) (or parent (list 'no-parent))))
  (when (not (member name *the-piecestructs*))
    (push name *the-piecestructs*)
    (if *do-merging*
	(invalidate-compilations)
	(evaluate-properly
	 `(defstruct (,name
		      (:conc-name nil)
		      (:constructor ,(category-constructor-function name))
		      (:predicate ,(category-predicate name))
		      (:print-function (lambda (self stream &rest ignore)
					 (declare (ignore ignore))
					 (,(category-print-function name)
					   self stream)))
		      ,@(when (parent-structure name)
			  `((:include ,(parent-structure name))))))))))

(defun evaluate-properly (exp)
  (if (and (consp exp)
	   (eq (car exp) 'progn))
      (mapc 'evaluate-properly (cdr exp))
      (funcall
       (compile nil
		`(lambda () ,exp)))))


(defexportmacro defslot (struct-name slot-name &optional init-val)
  `(defslot-fun ',struct-name ',slot-name ',init-val))

(property-macro init-demons)

(property-macro calls-init-demons?)

(property-macro slot-owner)

(property-macro slot-type)

(defun defslot-fun (name slot init-val)
  (cond ((declare-slot slot name 'normal)
	 (setf (slot-names name)
	       (append (slot-names name) (list (list slot init-val))))
	 (if *do-merging*
	     (invalidate-compilations)
	     (define-external-slot name slot)))
	((not (equal (assoc-value slot (slot-names name))
		     (list init-val)))
	 (setf (assoc-value slot (slot-names name))
	       (list init-val))
	 (if *do-merging*
	     (invalidate-compilations)
	     (install-init-demon name slot)))))

(defun declare-slot (slot owner type)
  (unless (member owner *the-piecestructs*)
    (error "~s has not been properly declared" owner))
  (if (slot-owner slot)
      (progn (unless (and (equal (slot-owner slot) owner)
			  (equal (slot-type slot) type))
	       (error "attempt to change the owner or type of slot ~s" slot))
	     nil)
      (progn (setf (slot-owner slot) owner)
	     (setf (slot-type slot) type)
	     t)))

(defun define-external-slot (name slot)
  (evaluate-properly
   `(progn
     (defvar ,(create-name slot 'macro 'table) (make-hash-table))
     (defmacro ,slot (x)
       `(gethash ,x ,',(create-name slot 'macro 'table)))))
  (install-init-demon name slot))

(defun install-init-demon (name slot)
  (install-init-demons name)
  (evaluate-properly
   `(defun ,(create-name slot 'initializer) (object)
     (setf (,slot object) ,(car (assoc-value slot (slot-names name))))))
  (pushnew (create-name slot 'initializer)
	   (init-demons name)))

(defun install-init-demons (name)
  (unless (calls-init-demons? name)
    (setf (calls-init-demons? name) t)
    (let ((old-maker (symbol-function (create-name 'make name))))
      (setf (symbol-function (create-name 'make name))
	    (lambda ()
	      (let ((object (funcall old-maker)))
		(call-init-demons name object)
		object))))
    (dolist (name2 *the-piecestructs*)
      (when (eq (parent-structure name2) name)
	(install-init-demons name2)))))

(defun call-init-demons (name object)
  (when (parent-structure name)
    (call-init-demons (parent-structure name) object))
  (dolist (demon (init-demons name))
    (funcall demon object)))
	     

(defexportmacro defslot-byte (name slot len)
  `(defslot-byte-fun ',name ',slot ',len))

(defun defslot-byte-fun (name slot len)
  (cond ((declare-slot slot name 'byte)
	 (defslot-fun name (combine-symbols name 'byte-slots) 0)
	 (setf (byte-slot-names name)
	       (append (byte-slot-names name) (list (list slot len))))
	 (if *do-merging*
	     (invalidate-compilations)
	     (evaluate-properly
	      `(definline ,slot (struct)
		(ldb (byte ,len ,(byte-slot-position slot (byte-slot-names name) 0))
		 (,(combine-symbols name 'byte-slots) struct))))))
	((not (equal (assoc-value slot (byte-slot-names name))
		     (list len)))
	 (error "attempt to change the length of a byte slot"))))

(defun byte-slot-position (slot-name name-alist sum-so-far)
  (cond ((null name-alist)
	 (error "attempt to get the byst-slot-position of a non-byte-slot"))
	((eq (caar name-alist) slot-name)
	 sum-so-far)
	(t (byte-slot-position slot-name (cdr name-alist) (+ sum-so-far (second (car name-alist)))))))

(defexportmacro defslot-bit (name slot)
  `(defslot-bit-fun ',name ',slot))

(defun defslot-bit-fun (name slot)
  (when (declare-slot slot name 'bit)
    (setf (bit-slot-names name)
	  (append (bit-slot-names name) (list slot)))
    (defslot-fun name (combine-symbols name 'bit-slots)
      `(make-array '(,(length (bit-slot-names name)))
	:element-type 'bit :initial-element 0))
    (if *do-merging*
	(invalidate-compilations)
	(evaluate-properly
	 `(definline ,slot (struct)
	   (aref (the (simple-bit-vector ,(length (bit-slot-names name)))
		  (,(combine-symbols name 'bit-slots) struct))
	    ,(bit-slot-position slot (bit-slot-names name) 0)))))))

(defun bit-slot-position (slot names pos-sofar)
  (cond ((null names)
	 (error "attempt to find the bit-slot-position of a non-bit-slot"))
	((eq slot (car names))
	 pos-sofar)
	(t (bit-slot-position slot (cdr names) (1+ pos-sofar)))))


(defexport redo-structures ()
  
  ;;In lucid, when a defsruct is evaluated all the structure functions are compiled
  ;;except for the constructor function.  If we try to compile an already compiled
  ;;function then we get an error.  I don't know how to write a program to tell
  ;;if a function is compiled.  So I just compile the maker.  This is almost certainly
  ;;lucid-specific. -- dam

  (when *redo-structures*
    (mapc 'evaluate-properly (compute-structure-definitions))
    (setf *redo-structures* nil)))
  

(defexportmacro piece-structure-definitions ()
  `(progn
    ,@(compute-structure-definitions)
    (setf *redo-structures* nil)))

;The following does atopological sort of the structures so that the most
;general structure comes first.

(defun compute-structure-definitions ()
  (let ((done-so-far nil))
    (labels ((next-definition ()
	       (let ((next-invalid (find-if (lambda (name) (not (member name done-so-far)))
					    *the-piecestructs*)))
		 (when next-invalid
		   (let ((parent-invalid (find-invalid-parent next-invalid)))
		     (push parent-invalid done-so-far)
		     (structure-definition parent-invalid)))))
	     (find-invalid-parent (name)
	       (let ((parent (parent-structure name)))
		 (if (and parent
			  (member parent *the-piecestructs*)
			  (not (member parent done-so-far)))
		     (find-invalid-parent parent)
		     name)))
	     (all-definitions ()
	       (let ((next (next-definition)))
		 (when next
		   (cons next (all-definitions))))))
      #-cmu(all-definitions)
      ;; the following is necessary in CMU CL 15d,
      ;; to handle included structures with conc-name nil
      #+cmu(let ((defs (all-definitions)))
	     (append defs (reverse defs))))))

(defun structure-definition (name)
  `(progn
    (defstruct (,name
		 (:conc-name nil)
		 (:constructor ,(category-constructor-function name))
		 (:predicate ,(category-predicate name))
		 (:print-function (lambda (self stream &rest ignore)
				    (declare (ignore ignore))
				    (,(category-print-function name) self stream)))
		 ,@(when (parent-structure name)
		     `((:include ,(parent-structure name)))))
      ,@(slot-names name))
    ,@(do ((byte-slots (byte-slot-names name) (cdr byte-slots))
	   (pos 0 (+ pos (second (first byte-slots))))
	   (macro-defs nil (cons `(definline ,(first (first byte-slots)) (struct)
				   (ldb (byte ,(second (first byte-slots)) ,pos)
				    (,(combine-symbols name 'byte-slots) struct)))
				 macro-defs)))
	  ((null byte-slots) macro-defs))
    ,@(do ((bit-slots (bit-slot-names name) (cdr bit-slots))
	   (pos 0 (1+ pos))
	   (macro-defs nil (cons `(definline ,(first bit-slots) (struct)
				   (aref (the (simple-bit-vector ,(length (bit-slot-names name)))
					  (,(combine-symbols name 'bit-slots) struct))
				    ,pos))
				 macro-defs)))
	  ((null bit-slots) macro-defs))))


(defexport clear-structure-definitions ()
  (invalidate-compilations)
  (dolist (struct *the-piecestructs*)
    (setf (parent-structure struct) nil)
    (setf (calls-init-demons? struct) nil)
    (setf (init-demons struct) nil)
    (dolist (slot (append (mapcar 'car (slot-names struct))
			  (bit-slot-names struct)
			  (mapcar 'car (byte-slot-names struct))))
      (setf (slot-owner slot) nil))
    (setf (slot-names struct) nil)
    (setf (byte-slot-names struct) nil)
    (setf (bit-slot-names struct) nil))
  (setf *the-piecestructs* nil))




(defun avoid-redefun-error (defun-form)
  (selectmatch defun-form
    ((defun ?function-name ?args . ?body)
     `(;;Due to a Lucid bug, this is less efficient than the defun.
       ;;(setf (symbol-function ',?function-name) #'(lambda ,?args ,@?body))
       ,defun-form))
    (:anything `(,defun-form))))

(defexportmacro all-piecefuns ()
  `(progn
    (eval-when (compile load eval)
      (piece-structure-definitions))
    ,@(mapcan #'avoid-redefun-error (compute-piecefun-definitions))
    ,@(mapcan #'avoid-redefun-error (compute-mergefun-definitions))
    ,@(mapcan #'avoid-redefun-error (compute-selectfun-definitions))))


;The following is useful for making a function a piecefunction by default.
;It is also useful for functions which use slots defined by the incremental
;structure definition facility.

(defexportmacro defextendable (name args &rest body)
  `(eval-when (compile eval load)
    (defpiecefun ,name ,args)
    (defpiece (,name :primary-piece) ,args . ,body)))

;;; Select pieces
;; Here's yet another system for defining functions one piece
;; at a time.  Selectfuns are different from piecefuns and mergefuns,
;; though, in that selectfuns run only one of the pieces, instead
;; of all of them.  The piece to run is selected by pattern-matching
;; on the first argument of the function.

;; (defselectfun foo (what-to-do to-what)
;;   (error "I don't know how to do ~s to ~s." what-to-do to-what))
;;
;; (defselectpiece (foo add) (what-to-do to-what)
;;     (add ?n) (numberp ?n)
;;   (+ ?n to-what))
;;
;; (defselectpiece (foo acons) (what-to-do to-what)
;;     (cons ?foo ?bar) t
;;   (acons ?foo ?bar to-what))

(emacs-indent defselectpiece 4)

(defexportmacro defselectpiece ((fun piece-name) &optional args form condition
			  &rest body)
  `(defselectpiece-fun ',fun ',piece-name ',args ',form ',condition ',body))

(defun defselectpiece-fun (fun piece-name args form condition body)
  (let ((funargs (get fun 'piece-args)))
    (unless (get fun 'select-wise)
      (error "~s not defined as select-wise" fun))
    (unless (equal args funargs)
      (error "~s does not match ~s, the arglist of ~s" args funargs fun))
    (setf (get fun piece-name) (list* form condition body))
    (pushnew piece-name (get fun 'pieces))
    (invalidate-selectfun-compilation fun)))

(defvar *the-selectfuns* nil)

(defexportmacro defselectfun (fun args &rest default-body)
  `(defselectfun-fun ',fun ',args ',default-body))

(defun defselectfun-fun (fun args default-body)
  (pushnew fun *the-selectfuns*)
  (when (or (not (get fun 'select-wise))
	    (not (equal args (get fun 'piece-args)))
	    (not (equal default-body (get fun 'default-body))))
    (setf (get fun 'pieces) nil)
    (setf (get fun 'piece-args) args)
    (setf (get fun 'default-body) default-body)
    (setf (get fun 'select-wise) t)
    (invalidate-selectfun-compilation fun)))

(defun invalidate-selectfun-compilation (fun)
  (setf (symbol-function fun)
	(lambda (&rest args)
	  (redo-structures)
	  (compile-defuns (list (selectfun-definition fun)))
	  (apply fun args)))
  fun)

(defun selectfun-definition (fun)
  `(defun ,fun ,(get fun 'piece-args)
    (guarded-selectmatch ,(car (get fun 'piece-args))
     ,.(mapcar (lambda (piece)
		 (get fun piece))
	(get fun 'pieces))
     (:anything t ,@(get fun 'default-body)))))


(defun compute-selectfun-definitions ()
  (mapcar #'selectfun-definition *the-selectfuns*))