;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: KR; Base: 10 -*-


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;; TO DO:
;;;
;;; - *setting-formula-p* - does this still make sense???
;;;
;;; - use special GV which only sets up dependencies the FIRST time.
;;; - eliminate redundant slot-accessor from setup-dependency (done?)
;;; - check out direct dependency stuff (in DESTROY-CONSTRAINT).  Is it still
;;;   needed?
;;;
;;; - put inverse on slot keyword itself?
;;; - code in DELETE-SCHEMA for a formula: what to do with children formulas?
;;;
;;; - have the eager code in g-value-formula-value do the stuff of the
;;;   +EAGER switch:
;;;   (if (and *eval-queue* *not-within-propagate*) (propagate))
;;;   (if (valid-p value)
;;;	  (cached-value value)
;;;       (if (fixed-p value)
;;;		(progn
;;;		  (set-valid-bit value t)
;;;		  (cached-value value))
;;;	      (g-value-formula-value (on-schema value) (on-slot value) value)))


;;; future slot bits assignment:
;;; - inherited
;;; - is-parent
;;; - constant-slot
;;; - is-update-slot
;;; - local-only-slot




(in-package "KR")
(use-package '("LISP" "KR-DEBUG"))


;;; --------------------------------------------------


;;;; SCHEMA-P
;;;
;;; Returns T if the <obj> is a schema which was not destroyed.
;;;
(defun schema-p (obj)
  (if (is-schema obj)
    (if (not (formula-p obj))
      (if (schema-slots obj) T))))



;;; This function is called when the slot name is unknown at compile time.
;;; 
(defun find-slot-by-name (schema slot)
  #+GARNET-DEBUG
  (unless schema
    (cerror "Return NIL" "  Attempting to access slot ~S on a null object.~%"
	    slot)
    (return-from find-slot-by-name NIL))
  (let ((array (schema-slots schema))
	position)
    (if (setf position (get slot :KR-FAST-ACCESSOR))
      ;; This is a special slot
      (values (aref array position) position)
      ;; This is an extra slot.
      (progn
	(setf position *first-slot*)
	(do* ((length (length array)))
	     ((>= position length)
	      *no-value*)
	  (declare (fixnum length))
	  (when (eq slot (aref array position))
	    (incf position)
	    (return (values (aref array position) position)))
	  (setf position (+ position *slot-size*)))))))



;;; similar to find-slot-by-name, used when the slot is known not to
;;; be special.
;;;
(defun find-extra-slot (schema slot)
  (declare (optimize (speed 3) (safety 0)))
  #+GARNET-DEBUG
  (unless schema
    (cerror "Return NIL" "  Attempting to access slot ~S on a null object.~%"
	    slot)
    (return-from find-extra-slot NIL))
  (let ((array (schema-slots schema))
	(position *first-slot*))
    (declare (fixnum position))
    (do ((length (length array)))
	((>= position length)
	 *no-value*)
      (declare (fixnum length))
      (if (eq slot (aref array position))
	(return (values (aref array (incf position)) position)))
      (incf position *slot-size*))))



;;; RETURNS:
;;; the value of <slot> in the <schema>, if it is local or a formula;
;;; nil, otherwise.
;;;
(defun find-the-local-slot (schema slot)
  #+GARNET-DEBUG
  (unless schema
    (cerror "Return NIL" "  Attempting to access slot ~S on a null object.~%"
	    slot)
    (return-from find-the-local-slot NIL))
  (let ((array (schema-slots schema))
	position)
    (if (setf position (get slot :KR-FAST-ACCESSOR))
      ;; This is a special slot
      (if (logbitp *inherited-bit* (aref array (1+ position)))
	*no-value*
	(values (aref array position) position))
      ;; This is an extra slot.
      (progn
	(setf position *first-slot*)
	(do* ((length (length array)))
	     ((>= position length)
	      NIL)
	  (if (eq slot (aref array position))
	    (if (logbitp *inherited-bit* (aref array (+ position 2)))
	      (return NIL)
	      (let ((value (aref array (1+ position))))
		(if (eq value *no-value*)
		  (return NIL)
		  (return (values value position))))))
	  (setf position (+ position *slot-size*)))))))



;;;; FIND-DEPENDENTS
;;; RETURNS: the list of slots which depend on the <slot> in the <schema>.
;;;
;;; Used by functions which only need to access the dependents list of a
;;; slot (as opposed to its value or bits).
;;; RETURNS: the index of the dependents list for the <slot> in the <schema>,
;;; or NIL.
;;;
(defun find-dependents (schema slot)
  (let ((accessor (get slot :KR-FAST-ACCESSOR)))
    (if accessor
      ;; This is a special slot
      (+ accessor 2)
      ;; This is not a special slot; use longer method.
      (progn
	(setf accessor *first-slot*)
	(do* ((array (schema-slots schema))
	      (length (length array)))
	     ((>= accessor length)
	      NIL)
	  (if (eq slot (aref array accessor))
	    (return (+ accessor 3)))
	  (incf accessor *slot-size*))))))



;;; This function is used to set non-special slots.
;;; 
(defun set-extra-slot (schema slot value bits)
  (let* ((slots (schema-slots schema))
	 (length (length slots)))
    ;; If slot is present, go ahead and set it
    (do* ((i *first-slot* (+ i *slot-size*)))
	 ((>= i length)
	  ;; We get here if slot is not present.  Allocate it and set it.
	  (vector-push-extend slot slots)
	  (vector-push-extend value slots)
	  (vector-push-extend bits slots)
	  (vector-push-extend NIL slots)	; depended slots
	  )
      ;; Check where slot name matches, and set if appropriate.
      (when (eq slot (aref slots i))
	(setf (aref slots (incf i)) value)
	(setf (aref slots (incf i)) bits)
	;; leave dependents slot alone!
	(return-from set-extra-slot value)))))



(defun clear-schema-slots (schema)
  (let ((slots (schema-slots schema))
	(position -1))
    ;; Clear all special slots.
    (dotimes (i (length *schema-slots*))
      (setf (aref slots (incf position)) *NO-VALUE*)
      (setf (aref slots (incf position)) 0)
      (setf (aref slots (incf position)) NIL))
    (setf (fill-pointer slots) *first-slot*)))



;;; --------------------------------------------------

;;;; GET-DEPENDENTS
;;;
;;; RETURNS: the formulas which depend on the <slot> of the <schema>.
;;;
(let ((list-of-one (list nil)))
  
  (defun get-dependents (schema slot)
    (let ((position (find-dependents schema slot)))
      (if position
	(let ((value (aref (schema-slots schema) position)))
	  (if (listp value)
	    value
	    (progn
	      (setf (car list-of-one) value)
	      list-of-one)))))))



;;; RETURNS:
;;; the lambda expression in a formula, or NIL
;;;
(defun get-lambda (formula)
  (if (formula-p formula)
    (a-formula-lambda formula)))




;;; Turns ON a demon if it was turned off.  If all demons are currently
;;; disabled, the variable *demons-disabled* is made of the form
;;; (T demon), where the names following the T are, in fact, enabled.
;;;
(defun enable-a-demon (demon)
  (cond ((eq *demons-disabled* T)
	 (list T demon))
	((eq *demons-disabled* NIL)
	 NIL				; nothing is disabled
	 )
	((listp *demons-disabled*)
	 ;; A list
	 (if (eq (car *demons-disabled*) T)
	   ;; Special format
	   (if (member demon (cdr *demons-disabled*))
	     *demons-disabled*		; nothing is needed
	     (cons T (cons demon (cdr *demons-disabled*))))
	   ;; Normal format
	   (if (member demon *demons-disabled*)
	     (remove demon *demons-disabled*)
	     *demons-disabled*)))
	((eq demon *demons-disabled*)
	 NIL)
	(t
	 *demons-disabled*)))


(defun disable-a-demon (demon)
  (if (eq *demons-disabled* T)
    T					; everything is already turned off
    (if (eq *demons-disabled* NIL)
      demon
      (if (listp *demons-disabled*)
	;; A list
	(if (eq (car *demons-disabled*) T)
	  ;; Special format used by with-demon-enable
	  (if (member demon *demons-disabled*)
	    (let ((new-value (delete demon *demons-disabled*)))
	      (if (null (cdr new-value))
		T
		new-value))
	    ;; Already disabled
	    *demons-disabled*)
	  ;; Normal format
	  (cons demon *demons-disabled*))
	;; A single value - make a list.
	(list demon *demons-disabled*)))))



;;; Is the <demon> currently enabled?
;;;
(defun demon-is-disabled (demon)
  (if (listp *demons-disabled*)
    (if (eq (car *demons-disabled*) T)
      ;; Special format
      (not (member demon (cdr *demons-disabled*)))
      ;; Normal format
      (member demon *demons-disabled*))
    (eq demon *demons-disabled*)))



;;; search up the tree for inherited slot.
;;; RETURNS: the inherited value, or NIL.
;;; 
(defun g-value-inherit-values (schema slot is-leaf the-position)
  (declare (function formula (t &optional t) t))
  (let ((slots (schema-slots schema))
	has-parents)
    (if (member slot *local-slots*)	; These CANNOT be inherited.
      (return-from g-value-inherit-values NIL))
    (dolist (relation *inheritance-relations*)
      (dolist (parent (if (eq relation :IS-A)
			(get-local-value schema :is-a)
			(get-local-value schema relation)))
	(setf has-parents T)
	(multiple-value-bind (value position)
	    (slot-accessor parent slot)
	  (let (bits			; parent bits
		(intermediate-constant NIL))
	    (if position
	      (if (is-constant (last-slot-bits (schema-slots parent)
					       position))
		(setf intermediate-constant T)))
	    (if (eq value *no-value*)
	      ;; Attempt to inherit from its ancestors.
	      (multiple-value-setq (value bits)
		(g-value-inherit-values parent slot NIL nil))
	      ;; If value, just set bits.
	      (setf bits (last-slot-bits (schema-slots parent) position)))
	    (unless (eq value *no-value*)
	      (if (and bits (is-parent bits))
		;; Clear the parent bit, since we will set the child.
		(setf bits (logand bits *not-parent-mask*))
		;; Set the bit in the parent which says that the value was
		;; inherited by someone.
		(set-slot-accessor parent slot value
				   (logior bits *is-parent-mask*)))
	      ;; Copy the value down to the inheriting slot, unless the value
	      ;; contains a formula.
	      (let ((was-formula (formula-p value)))
		(when was-formula
		  ;; Inherit the formula, making a copy of it.
		  (setf value (formula value (a-formula-cached-value value)))
		  (setf (a-formula-schema value) schema)
		  (setf (a-formula-slot value) slot)
		  (set-cache-is-valid value NIL)
		  #+EAGER
		  (setf *eval-queue* (insert-pq value *eval-queue*)))
		;; Copy down, mark as inherited if inherited
		(if is-leaf
		  (if the-position	; slot had constant bit
		    (setf bits (logior bits (aref slots (1+ the-position))))))
		(setf bits (logior *inherited-mask* bits))
		(if intermediate-constant
		  (setf bits (logior *constant-mask* bits)))
		(set-slot-accessor schema slot value bits))
	      (return-from g-value-inherit-values (values value bits)))))))
    ;; We didn't find anything, so return an appropriate null value and set
    ;; the local cache (even though we have no value) to avoid further
    ;; inheritance search.
    (set-slot-accessor schema slot
		       (if has-parents NIL *no-value*)
		       (cond (is-leaf
			      (if the-position
				(logior *inherited-mask*
					(aref slots (1+ the-position)))
				*inherited-mask*))
			     (has-parents *inherited-parent-mask*)
			     (t	; top-level, no parents
			      *is-parent-mask*)))
    *no-value*))



;;;; G-CACHED-VALUE
;;; 
(defun g-cached-value (schema slot)
  "Returns the value of the <slot> in the <schema>.  If this is a formula, it
  returns the cached value of the formula, without ever recomputing the
  formula."
  ;; Note use of GET-VALUE
  (let ((g-cached-value-val (get-value schema slot)))
    (if (formula-p g-cached-value-val)
	(cached-value g-cached-value-val)
	g-cached-value-val)))



;;; Process the value in a G-VALUE
;;;
(defun value-fn (schema slot position)
  #+GARNET-DEBUG
  (unless schema
    (cerror "Return NIL" "  G-VALUE attempted on a null object (slot ~S)."
	    slot)
    (return-from value-fn NIL))
  (let (value)
    (if (null position)
      (multiple-value-setq (value position)
	(find-extra-slot schema slot))
      (if (eq position T)
	(multiple-value-setq (value position)
	  (find-slot-by-name schema slot))
	(setf value (aref (schema-slots schema) position))))
    (when (eq value *no-value*)
      (setf value (g-value-inherit-values schema slot T position))
      (if (eq value *no-value*)
	(return-from value-fn NIL)))
    (if (a-formula-p value)
      ;; we are working with a formula
      #-EAGER
      (g-value-formula-value schema slot value)
      #+EAGER
      (progn
	(when (and *eval-queue* *not-within-propagate*)
	  (propagate))
	(if (valid-p value)
	  (cached-value value)
	  ;; even if a formula is marked invalid, do not evaluate 
	  ;; the formula if its value is fixed on this iteration of
	  ;; the constraint solver
	  (if (fixed-p value)
	    (progn
	      (set-valid-bit value t)
	      (cached-value value))
	    (g-value-formula-value (on-schema value) (on-slot value) value))))
      ;; We are working with an ordinary value.
      value)))



;;; Does the actual work of G-LOCAL-VALUE
;;; RETURNS: multiple values:
;;; - the value of the slot;
;;; - T if a value was found, NIL otherwise.  This allows to distinguish
;;    between a missing value and a NIL value.
;;; 
(defun local-value-fn (schema slot)
  #+GARNET-DEBUG
  (unless schema
    (cerror "Return NIL" "  G-LOCAL-VALUE attempted on a null object (slot ~S)"
	    slot)
    (return-from local-value-fn NIL))
  (let ((array (schema-slots schema))
	(position (get slot :KR-FAST-ACCESSOR)))
    (if position
      ;; This is a special slot
      (let ((value (aref array position)))
	(if (eq value *no-value*)
	  ;; Try to inherit - it might be a formula
	  (if (formula-p (setf value (g-value-inherit-values
				      schema slot T position)))
	    (g-value-formula-value schema slot value))
	  ;; Must be local.
	  (if (formula-p value)
	    (values (g-value-formula-value schema slot value) T)
	    (if (not (logbitp *inherited-bit* (aref array (1+ position))))
	      (values value T)))))
      ;; This is an extra slot.
      (let (value)
	(setf position *first-slot*)
	(do* ((length (length array)))
	     ((>= position length)
	      ;; Value is not present.  Try to inherit it.
	      (setf value (g-value-inherit-values schema slot T NIL))
	      (if (formula-p value)
		(values (g-value-formula-value schema slot value) T)))
	  (when (eq slot (aref array position))
	    (incf position)
	    (setf value (aref array position))
	    (return
	      (if (eq value *no-value*)
		;; Try to inherit - it might be a formula
		(if (formula-p (setf value (g-value-inherit-values
					    schema slot T position)))
		  (g-value-formula-value schema slot value))
		;; Must be local
		(if (formula-p value)
		  (values (g-value-formula-value schema slot value) T)
		  (if (not (logbitp *inherited-bit*
				    (aref array (1+ position))))
		    ;; Indicate we have a (possibly NIL) value.
		    (values value T))))))
	  (setf position (+ position *slot-size*)))))))

;;; This is a specialized function which does inheritance but does NOT copy
;;; values down.  It is used by the :INITIALIZE method, which is called exactly
;;; once per object and should NOT copy down anything (since the method will
;;; never be used again).
;;; 
;;; 
(defun g-value-no-copy (schema slot &optional skip-local)
  (if (not skip-local)
    ;; Is there a local value?
    (let ((value (slot-accessor schema slot)))
      (unless (eq value *no-value*)
	(return-from g-value-no-copy value))))
  ;; Now try inherited values.
  (dolist (relation *inheritance-relations*)
    (dolist (*schema-self* (if (eq relation :IS-A)
			     (get-local-value schema :is-a)
			     (get-local-value schema relation)))
      (unless (eq *schema-self* schema)		; avoid infinite loops!
	(let ((value (g-value-no-copy *schema-self* slot)))
	  (if value
	      (return-from g-value-no-copy value)))))))



;;; --------------------------------------------------


;;; -------------------------------------------------- PRINTING AND DEBUGGING


(defparameter *debug-names-length* 500)

(defvar *debug-names* (make-array *debug-names-length* :initial-element nil))
(defvar *debug-index* -1)


(defvar *intern-unnamed-schemata* T
  "This variable may be set to NIL to prevent PS from automatically creating
  any unnamed schemata it prints out.")



;;; This version does not cause any creation of symbols.  It simply records
;;; the schema in an array, thus creating a semi-permanent way to refer
;;; to a schema.
;;;
(defun cache-schema-name (schema name)
  (unless (find-if #'(lambda (x)
		       (and x (eql (schema-name x) name)))
		   *debug-names*)
    ;; A new schema.  Store it in the next position (cycle if
    ;; we reach the end of the array).
    (setf (aref *debug-names*
		(setf *debug-index*
		      (mod (incf *debug-index*) *debug-names-length*)))
	  schema)))



;;; This version creates symbols for all automatic schema names that happen to
;;; be printed out.
;;; 
(defun make-new-schema-name (schema name)
  (let* ((debug-package (find-package "KR-DEBUG"))
	 parent
	 (symbol
	  (intern (cond ((stringp name)
			 ;; a name-prefix schema
			 (format nil "~A-~D"
				 name (incf *schema-counter*)))
			((setf parent
			       (if (formula-p schema)
				   (a-formula-is-a schema)
				   (if (null (schema-slots schema))
				       NIL
				       (car (get-local-value schema :is-a)))))
			 (let ((parent-name (if parent (schema-name parent))))
			   (when (or (integerp parent-name)
				     (stringp parent-name))
			     ;; Parent is unnamed yet - force a name.
			     (with-output-to-string
				 (bit-bucket)
			       (print-the-schema parent bit-bucket 0))
			     (setf parent-name (schema-name parent)))
			   (format nil "~A-~D" parent-name name)))
			(t
			 (format nil "~C~D"
				 (if (formula-p schema) #\F #\S)
				 name)))
		  debug-package)))
    (set symbol schema)
    (setf (schema-name schema) symbol)
    (export symbol debug-package)))



(defun print-the-schema (schema stream level)
  (declare (ignore level))
  (let ((name (schema-name schema))
	(destroyed (null (schema-slots schema))))
    ;; This version is for debugging.  Record the latest schemata in the
    ;; array.
    (cond ((or (integerp name) (stringp name))
	   ;; This is a nameless schema.  Print it out, and record it in the
	   ;; debugging array.
	   (if *intern-unnamed-schemata*
	       (make-new-schema-name schema name))
	   (cache-schema-name schema name)
	   ;; This gives control over whether unnamed schemata are interned.
	   (setf name (schema-name schema)))
	  ((null name)
	   ;; This was a deleted schema
	   (setf name '*DESTROYED*)))
    (if destroyed (format stream "*DESTROYED*(was "))
    (if *print-as-structure*
	(progn
	  (format stream "#k<~S" name)
	  (dolist (slot *print-structure-slots*)
	    (let ((value (g-value schema slot)))
	      (when value
		(format stream " (~S ~S)" slot value))))
	  (format stream ">")
	  (if destroyed (format stream ")")))
	(progn
	  (format stream "~S" name)
	  (if destroyed	(format stream ")"))))))



;;;; NAME-FOR-SCHEMA
;;; Given a schema, returns its string name.
;;; Note that this returns the pure name, without the #k<> notation.
;;; 
(defun name-for-schema (schema)
  "Given a schema, returns its printable name as a string.  The string
  CANNOT be destructively modified."
  (let ((name (schema-name schema)))
    (when (or (integerp name) (stringp name))
      ;; This is a nameless schema.  Print it out, and record it in the
      ;; debugging array.
      (if *intern-unnamed-schemata*
	  (make-new-schema-name schema name))
      (cache-schema-name schema name)
      ;; This gives control over whether unnamed schemata are interned.
      (setf name (schema-name schema)))
    (symbol-name name)))



;;; This is a debugging function which returns a schema, given its internal
;;; number.  It only works if the schema was printed out rather recently,
;;; i.e., if it is contained in the temporary array of names.
;;; 
(defun s (number)
  (setf number (format nil "~D" number))
  (find-if #'(lambda (x)
	       (and x
		    (symbolp (schema-name x))
		    (do* ((name (symbol-name (schema-name x)))
			  (i (1- (length name)) (1- i))
			  (j (1- (length number)) (1- j)))
			 ((minusp j)
			  (unless (digit-char-p (schar name i))
			    x))
		      (unless (char= (schar name i) (schar number j))
			(return nil)))))
	   *debug-names*))



;;; -------------------------------------------------- RELATIONS
;;; Remove the inverse link from <value> to <schema>, following the inverse
;;; of <slot>.
;;; 
(defun unlink-one-value (schema slot value)     ; e.g., child :is-a parent
  (let ((inverse (first (cdr (assoc slot *relations*))))) ; e.g., is-a-inv
    (when inverse
      ;; If the relation has an INVERSE slot, remove <schema> from the
      ;; inverse slot.
      (multiple-value-bind (values position)
	  (slot-accessor value inverse)  ; e.g., A child B
	(when values
	  (if (eq (car values) schema)
	      ;; <schema> is first in the inverse list
	      (set-slot-accessor value inverse (delete schema values)
				 (last-slot-bits (schema-slots schema)
						 position))
	      ;; just do a destructive operation
	      (setf (cdr values) (delete schema (cdr values)))))))))



;;; Same as before, but unlinks all schemata that are in <slot>.
;;; 
(defun unlink-all-values (schema slot)
  (let ((inverse (cadr (assoc slot *relations*))))
    (if inverse
      (dolist (parent (if (eq slot :IS-A)
			(slot-accessor schema :IS-A)
			(if (eq slot :IS-A-INV)
			  (slot-accessor schema :IS-A-INV)
			  (slot-accessor schema slot))))
	(if (schema-slots parent)	; parent is not destroyed
	  ;; If the terminal has an INVERSE slot, remove <schema> from the
	  ;; inverse slot.
	  (multiple-value-bind (values position)
	      (if (eq inverse :is-a-inv)
		(slot-accessor parent :is-a-inv) ; e.g., A child B
		(slot-accessor parent inverse))
	    (if values
	      (if (eq (car values) schema)
		(setf (aref (schema-slots parent) position) (cdr values))
		(setf (cdr values) (delete schema (cdr values)))))))))))



;;; Since the <values> are being added to <slot>, see if we need to put in an
;;; inverse link to <schema> from each of the <values>.
;;; This happens when <slot> is a relation with an inverse.
;;; 
(defun link-in-relation (schema slot values)
  (let ((inverse (if (eq slot :is-a)
		   :is-a-inv
		   (cadr (assoc slot *relations*)))))
    (if inverse
      ;; <values> is a list: cycle through them all
      (dolist (value values)
	(multiple-value-bind (previous-values position)
	    (slot-accessor value inverse)
	  (if (eq previous-values *no-value*)
	    ;; There was no inverse in the parent yet.
	    (if (eq inverse :is-a-inv)
	      (if position
		(set-slot-accessor value :is-a-inv (list schema) *local-mask*)
		;; Efficient special-case handling
		(let ((array (schema-slots value)))
		  (vector-push-extend :is-a-inv array)
		  (vector-push-extend (list schema) array)
		  (vector-push-extend *local-mask* array)
		  (vector-push-extend NIL array)))
	      (set-slot-accessor value inverse (list schema) *local-mask*))
	    ;; Create the back-link.  We use primitives here to avoid looping.
	    (if (or *schema-is-new*
		    (not (member schema previous-values)))
	      ;; Handle an important special case efficiently.
	      (if previous-values
		;; Just add the schema in the middle.
		(push schema (cdr previous-values))
		;; Create the slot.
		(set-slot-accessor value inverse (list schema)
				   *local-mask*)))))))))



;;; We are setting the <slot> (a relation) to <values>.  Check that the
;;; latter contains valid relation entries.
;;; RETURNS: <values> (or a list of a single value, if <values> is not a list)
;;; if success; *no-value* if failure.
;;; 
(defun check-relation-slot (schema slot values)
  (unless (listp values)
    (format
     t "S-VALUE: relation ~s in schema ~S should be given a list of values!~%"
     slot schema)
    (if (schema-p values)
      (setf values (list values))	; go ahead, use anyway.
      (return-from check-relation-slot *no-value*)))
  (dolist (value values)
    (unless (is-schema value)
      (when-debug
       (format
	t
	"S-VALUE: value ~s for relation ~s in ~s is not a schema!  Ignored.~%"
	value slot schema))
      (return-from check-relation-slot *no-value*)))
  (do ((value values (cdr value)))
      ((null value))
    (when (member (car value) (cdr value))
      (format
       t
       "Trying to set relation slot ~S in schema ~S with duplicate value ~S!~%"
       slot schema (car value))
      (format t "  The slot was not set.~%")
      (return-from check-relation-slot *no-value*)))
  values)



;;;; INHERITED-P
;;;
;;; Similar to HAS-SLOT-P, but when there is a formula checks whether this is
;;; an inherited formula.
;;; 
(defun inherited-p (schema slot)
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (if (not (eq value *no-value*))
	(or (is-inherited (last-slot-bits (schema-slots schema) position))
	    (and (formula-p value)
		 (formula-p (a-formula-is-a value)))))))



;;; --------------------------------------------------



;;; Helper function
;;;
(defun eliminate-constant-formula ()
  (declare (function destroy-constraint (t t) t))
  ;; This was a constant formula!  Commit suicide.
  (with-demons-disabled
      (destroy-constraint *schema-self* *schema-slot*))
  (if *warning-on-evaluation*
    (format t "formula (~S ~S) is constant - eliminated~%"
	    *schema-self* *schema-slot*))
  (multiple-value-bind (value position)
      (slot-accessor *schema-self* *schema-slot*)
    (declare (ignore value))
    (let ((slots (schema-slots *schema-self*)))
      (setf (aref slots (1+ position))
	    (logior *constant-mask* (last-slot-bits slots position))))))


(defparameter *warning-level* 0)



#+EAGER
(defun do-eager-reeval (new-value)
  ;; increment the number of times the formula has been 
  ;; successfully evaluated by 1
  (incf (a-formula-bits *current-formula*) *count-mask*)
  #+EAGER
  ;; determine if the value of the formula has changed, and if so,
  ;; add its dependents to the evaluation queue
  (when (not (equal new-value (cached-value *current-formula*)))
    (add-to-reeval *schema-self* *schema-slot* t))
  #+EAGER
  ;; do post-processing on the formula. 
  (when (and (eq *eval-type* :CYCLE-EVAL)
	     (eval-bit-set *current-formula*))
    ;; the formula might still be on the eval queue; get it off
    (setf *eval-queue* (delete *current-formula* *eval-queue*))
    (set-eval-bit *current-formula* nil)))




;;; Helper function
;;; 
(defun re-evaluate-formula (*schema-self* *schema-slot* *current-formula*
					  #+EAGER *eval-type*)
  (when *warning-on-evaluation*
    (dotimes (i *warning-level*) (write-string " "))
    (format t "evaluating ~S (on ~S, slot ~S)~%"
	    *current-formula* *schema-self* *schema-slot*)
    (incf *warning-level* 2))
  (let* ((*within-g-value* T)
	 (*check-constants*		; only for the first evaluation!
	  (if (not *constants-disabled*)
	    (zerop (a-formula-number *current-formula*))))
	 (*accessed-slots* NIL)
	 (*is-constant* T)
	 (declared-constant (if *check-constants*
			      (slot-is-constant *schema-self* *schema-slot*))))
    (if declared-constant		; save work, since we know the answer
      (setf *check-constants* nil))
    #-EAGER
    (set-cache-mark *current-formula* *sweep-mark*)
    (let ((the-result
	   (catch 'no-link
	     ;; If no-link, return cached-value anyway.
	     ;; Evaluate the formula.
	     (let ((new-v (funcall (a-formula-function *current-formula*))))
	       #+TEST
	       (if declared-constant	; if declared, certainly constant.
		 (setf *is-constant* T
		       *check-constants* T))
	       ;; Do nothing if value has not changed.
	       (if (not (eq new-v (cached-value *current-formula*)))
		 (let ((*check-constants* *check-constants*))
		   ;; Call the pre-set-demon function on this schema if
		   ;; this slot is an interesting slot.
		   (run-pre-set-demons *schema-self* *schema-slot* new-v
				       :CURRENT-FORMULA)
		   #+EAGER
		   (do-eager-reeval new-v)
		   ;; Set the cache to the new value
		   (setf (cached-value *current-formula*) new-v)))
	       new-v))))
      (if (or declared-constant
	      (and *check-constants* *is-constant* *accessed-slots*))
	;; Eliminate constant formulas, if needed.
	(eliminate-constant-formula)
	;; Mark formula as valid here.
	(unless *setting-formula-p*
	  (set-cache-is-valid *current-formula* t)))
      (if *warning-on-evaluation* (decf *warning-level* 2))
      the-result)))



;;; We are working with a formula.  Note that broken links leave
;;; the formula valid.
;;; 
(defun g-value-formula-value (*schema-self* slot formula)
  #+EAGER
  (let ((*eval-type* :NORMAL-EVAL))
    ;; decide what kind of evaluation is required (cycle evaluation
    ;; or normal evaluation)
    (when (cycle-p formula)
      (set-valid-bit formula t) ; so formula isn't evaluated more than once
      (setf *eval-type* :CYCLE-EVAL))    
    (re-evaluate-formula *schema-self* slot formula *eval-type*))

  #-EAGER
  (if (cache-is-valid formula)
    (a-formula-cached-value formula)
    (progn
      (unless *within-g-value*
	#+EAGER
	(when (fixed-p formula)
	  ;; even if a formula is marked invalid, do not evaluate 
	  ;; the formula if its value is fixed on this iteration of
	  ;; the constraint solver
	  (set-valid-bit formula t)
	  (cached-value formula))
	;; Bump the sweep mark only at the beginning of a chain of formula
	;; accesses.  Increment by 2 since lower bit is "valid" flag.
	(incf *sweep-mark* 2))
      (if (= (cache-mark formula) *sweep-mark*)
	  ;; If the sweep mark is the same as the current one, WE ARE IN THE
	  ;; MIDDLE OF A CIRCULARITY.  Just use the old value, and mark it
	  ;; valid.
	  (progn
	    (if *warning-on-circularity*
		(format t "Warning - circularity detected on ~S, slot ~S~%"
			*schema-self* slot))
	    (unless *setting-formula-p*
	      (set-cache-is-valid formula T))
	    (a-formula-cached-value formula))
	  ;; Compute, cache and return the new value.
	  (re-evaluate-formula *schema-self* slot formula
			       #+EAGER *eval-type*)))))



;;; --------------------------------------------------


(defun copy-to-all-instances (schema a-slot value &optional (is-first T))
  (s-value schema a-slot value)
  ;; Do not create copies of formulas, but set things up for inheritance
  (if is-first
    (if (formula-p value)
      (setf value *no-value*)))
  (dolist (inverse *inheritance-inverse-relations*)
    (let ((children (if (eq inverse :IS-A-INV) ; for efficiency
		      (slot-accessor schema :IS-A-INV)
		      (get-local-value schema inverse))))
      (if (not (eq children *no-value*))
	(dolist (child children)
	  ;; force new inheritance
	  (if (not (formula-p (get-value child a-slot)))
	    ;; Do not override if the user has specified a local formula!
	    (copy-to-all-instances child a-slot value NIL)))))))



(defun update-inherited-internal (child a-slot new-value bits)
  (multiple-value-bind (old-value position)
      (slot-accessor child a-slot)
    (unless (or (eq old-value *no-value*)
		(equal old-value new-value))
      (let ((child-bits (last-slot-bits (schema-slots child) position)))
	(when (is-inherited child-bits)
	  ;; NOTE: we erase the inherited value in all cases, even if it might
	  ;; have been inherited from somewhere else (in the case of multiple
	  ;; inheritance).  In any case, this is correct; at worst, it may
	  ;; cause the value to be needlessly inherited again.
	  (if new-value
	    ;; Keep the inheritance bit, etc.
	    (set-slot-accessor child a-slot new-value
			       (logior bits (logand child-bits
						    *not-inherited-mask*)))
	    ;; Set the new values for the children.
	    (set-slot-accessor child a-slot new-value bits))
	  ;; Recursively change children.
	  (update-inherited-values child a-slot new-value NIL))))))



;;; This function is used when a value is changed in a prototype.  It makes
;;; sure that any child schema which inherited the previous value is updated
;;; with the new value.
;;; INPUTS:
;;; - <value>: the new (i.e., current) value for the <schema>
;;; - <old-bits>: the setting of the slot bits for the <schema>, before the
;;;   current value-setting operation.
;;; - <is-first>: if non-nil, this is the top-level call.
;;; 
(defun update-inherited-values (schema a-slot value is-first)
  (let ((*schema-self* schema))
    (unless is-first
      ;; Invoke demons and propagate change around.
      (run-pre-set-demons schema a-slot value NIL)
      (run-invalidate-demons schema a-slot)
      #+EAGER
      ;; add the slot's dependents to the evaluation queue
      (add-to-reeval schema a-slot)
      #-EAGER
      (propagate-change schema a-slot))
    (dolist (inverse *inheritance-inverse-relations*)
      (let ((children (if (eq inverse :IS-A-INV)	; for efficiency
			  (slot-accessor schema :IS-A-INV)
			  (get-local-value schema inverse))))
	(if (not (eq children *no-value*))
	    (dolist (child children)
	      (unless (eq (slot-accessor child a-slot) *no-value*)
		;; If child had no value, no need to propagate down
		(setf is-first NIL)
		(update-inherited-internal child a-slot ; force new inheritance
					   *no-value* 0))))))))
#|
(defun temp (schema a-slot value)
  (run-pre-set-demons schema a-slot value NIL))
|#



;;;; MARK-AS-CHANGED
;;;
;;; This function can be used when manually changing a slot (without using
;;; s-value).  It will run the demons and propagate the invalidate wave
;;; to all the ordinary places.
;;;
(defun mark-as-changed (schema slot)
  "Forces formulas which depend on the <slot> in the <schema> to be
  invalidated.  Mostly used for internal implementation."
  (run-invalidate-demons schema slot)
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (if (not (eq value *no-value*))
	(if (is-parent (last-slot-bits (schema-slots schema) position))
	    (update-inherited-values schema slot value T))))
  #-EAGER
  (propagate-change schema slot)
  #+EAGER
  (add-to-reeval schema slot))



;;;; MARK-AS-INVALID
;;; 
(defun mark-as-invalid (schema slot)
  "Invalidates the value of the formula at <position> in the <slot> of the
  <schema>.  If the value is not a formula, nothing happens."
  (let ((value (get-value schema slot)))
    (when (formula-p value)
      (set-cache-is-valid value NIL))))



;;;; RECOMPUTE-FORMULA
;;;
;;; Forces the formula installed on the <slot> of the <schema> to be
;;; recomputed, propagating the change as needed.
;;; This may be used for implementation of formulas which depend on some
;;; non-KR value.
;;; 
(defun recompute-formula (schema slot)
  (multiple-value-bind (formula position)
      (slot-accessor schema slot)
    (if (formula-p formula)
      (let ((bits (last-slot-bits (schema-slots schema) position)))
	(unless *within-g-value*
	  (incf *sweep-mark* 2))
	(re-evaluate-formula schema slot formula #+EAGER *eval-type*)
	(run-invalidate-demons schema slot)
	(if (is-parent bits)
	  (update-inherited-values schema slot formula T))
	#-EAGER
	(propagate-change schema slot)
	#+EAGER
	(propagate)))))



#-EAGER
;;; Since the <slot> of the <schema> was modified, we need to propagate the
;;; change to all the formulas which depended on the old value.
;;; 
(defun propagate-change (schema slot)
  (declare (optimize (speed 3)))
  (multiple-value-bind (value position)
      (slot-accessor schema slot)	; set accessors
    (declare (ignore value))
    ;; access the dependent formulas.
    (let ((slots (schema-slots schema)))
      (do-one-or-list (formula (last-slot-dependents slots position) T)
	;; Stop propagating if this dependent formula was already marked dirty.
	(if (cache-is-valid formula)
	  (let* ((new-schema (on-schema formula))
		 (new-slot (on-slot formula))
		 (schema-ok (schema-p new-schema)))
	    (unless (and new-schema new-slot)
	      (when *warning-on-disconnected-formula*
		(format
		 t
		 "Warning: disconnected formula ~S in propagate-change ~S ~S~%"
		 formula schema slot))
	      (continue-out))
	    (if schema-ok
	      (run-invalidate-demons new-schema new-slot)
	      #+GARNET-DEBUG
	      (progn
		(format
		 t
		 "propagate-change: formula ~S on destroyed object ~S ~S~%    ~
	from change in schema ~S, slot ~S.~%"
		 formula new-schema new-slot schema slot)))
	    ;; The formula gets invalidated here.
	    (set-cache-is-valid formula nil)
	    ;; Notify all children who used to inherit the old value of the
	    ;; formula.
	    (if schema-ok
	      (multiple-value-bind (new-value position)
		  (slot-accessor new-schema new-slot)
		(unless (eq new-value *no-value*)
		  (let* ((slots (schema-slots new-schema)) 
			 (new-bits (last-slot-bits slots position))
			 (dependents (last-slot-dependents slots position)))
		    (if (is-parent new-bits)
		      (let ((value (slot-accessor schema slot)))
			(if (not (eq value *no-value*))
			  (update-inherited-values
			   new-schema new-slot new-value T))))
		    ;; Now recurse, following the slot in the schema on which
		    ;; the formula sits.
		    (if dependents
		      (propagate-change new-schema new-slot))))))))))))



#+EAGER
;;; 
;;; PROPAGATE
;;; bring all slots up to date.
;;; 
(defun propagate ()
  (let ((*not-within-propagate* nil)
	formula)
    (incf *eval-count*)
    (loop
      (when (null *eval-queue*) 
	;; turn off the eval bits in the formulas on the fixed values
	;; list so that the will be evaluated again
	(dolist (formula *do-not-eval-list*)
	  (set-eval-bit formula nil)
	  (set-fixed-bit formula nil))
	(setf *do-not-eval-list* nil)
	(return)) 
      (setf formula (pop-pq *eval-queue*))
      (when (and (schema-name formula) (eval-bit-set formula))
	; only evaluate formula if its being evaluated in order--when
	; priorities of formula's are updated, they are not removed
	; from the priority queue so they may have to be reinserted
	(if (priority-<=-p (priority formula) (eval-q-priority))
	    (catch 'out-of-order
	      ;; get out and do nothing if the formula is evaluated out of
	      ;; order; otherwise compute, cache and return the new value.
	      (set-eval-bit formula nil)
	      (if (and (cycle-p formula) (valid-p formula))
		  (progn
		    (reorder-formulas formula (priority formula))
		    ; only evaluate if reorder-formulas hasn't made the
		    ; formula's priority greater than priority of
		    ; the first element in the evaluation queue
		    (if (priority->-p (priority formula) (eval-q-priority))
			(setf *eval-queue* (insert-pq formula *eval-queue*))
			(g-value-formula-value (on-schema formula)
					       (on-slot formula) formula)))
		  (g-value-formula-value (on-schema formula)
					 (on-slot formula) formula)))
	    ;; else formula is out of order so put it back in the priority queue
	    (setf *eval-queue* (insert-pq formula *eval-queue*)))))))



;;; --------------------------------------------------



;;; Similar to update-inherited-values, but used when the hierarchy is
;;; modified or when an inheritable slot is destroyed.
;;; SIDE EFFECTS:
;;; - the <function> is called on all children which actually inherit the
;;;   values in the <a-slot> of the <schema>.  This is determined by a fast
;;;   check (the list of values should be EQ to that of the parent).
;;; Note that the <function> is called after all children have been visited..
;;; This allows it to be a destructive function.
;;; 
(defun visit-inherited-values (schema a-slot function)
  (let ((parent-entry (slot-accessor schema a-slot)))
    (dolist (inverse *inheritance-inverse-relations*)
      (dolist (child (if (eq inverse :IS-A-INV)
			 (get-local-value schema :IS-A-INV)
		       (get-local-value schema inverse)))
        (multiple-value-bind (value position)
	    (slot-accessor child a-slot)
	  (when (and value (not (eq value *no-value*))
		     (is-inherited (last-slot-bits (schema-slots schema)
						   position))
		     (eq value parent-entry))
	    (visit-inherited-values child a-slot function)
	    (funcall function child a-slot)))))))



;;; Internal function which runs demons as appropriate (before changing the
;;; value) and then physically sets the <slot> in the <schema> to be
;;; <new-value>.
;;; 
(defun run-demons-and-set-value (schema slot new-value old-value is-relation
				 is-formula was-formula the-bits position)
  (run-invalidate-demons schema slot)
  ;; Now set the value in the slot to be new-value.
  (cond ((and was-formula (not is-formula))
	 ;; This is the case when we allow temporary overwriting
	 (setf (cached-value old-value) new-value)
	 #+EAGER
	 ;; get the formula off the evaluation queue if it is already there,
	 ;; then turn its eval bit on. This will prevent the constraint solver
	 ;; from adding the formula to the queue during the next iteration
	 ;; of the constraint solver, and thus the formula cannot be evaluated
	 (set-eval-bit old-value t)
	 #+EAGER
	 ;; set the formula's fixed bit to t to indicate it should not
	 ;; be evaluated during this iteration of the constraint solver
	 (set-fixed-bit old-value t)
	 #+EAGER
	 ;; place the formula on a list so that its eval bit will be
	 ;; turned off when the constraint solver finishes this iteration
	 (push old-value *do-not-eval-list*)
	 #-EAGER
	 ;; Set this to NIL, temporarily, in order to cause propagation
	 ;; to leave the value alone.  It will be validated by s-value.
	 (set-cache-is-valid old-value NIL))
	(t
	 ;; All other cases
	 (if (and is-formula (null (cached-value new-value)))
	   ;; place old value in the cache only if an initial value
	   ;; was not provided for the new formula
	   ;; Set value, but keep formula invalid.
	   (setf (cached-value new-value)
		 (if was-formula (cached-value old-value) old-value)))
	 ;; Take care of relations.
	 (when is-relation
	   (if old-value (unlink-all-values schema slot))
	   (link-in-relation schema slot new-value))
	 (let ((new-bits (or the-bits *local-mask*)))
	   (if (and position (< position *first-slot*))
	     ;; This is a special slot - just set it
	     (let ((slots (schema-slots schema)))
	       (setf (aref slots position) new-value)
	       (setf (aref slots (1+ position)) new-bits))
	     ;; This is not a special slot.
	     (set-slot-accessor schema slot new-value new-bits)))))
  ;; Now propagate the change to all the children which used to
  ;; inherit the previous value of this slot from the schema.
  (if (and the-bits (is-parent the-bits))
    (let ((*setting-formula-p* T))
      (update-inherited-values schema slot new-value T))))



;;; Signals an error if the <slot> of the <schema> is not constant.
;;; Assumes that the slot indicators are set properly.
;;; INPUTS:
;;; - if <access-p> is non-nil, the slot is accessed to make sure the
;;;   slot indicators are set.
;;;
(defun check-not-constant (schema slot position)
  (if (not *constants-disabled*)
    (if position
      (when (is-constant (last-slot-bits (schema-slots schema) position))
	(cerror "Continue as if nothing happened"
		"Schema ~S - trying to set slot ~S, which is constant."
		schema slot)))))



;;; SLOT-CONSTANT-P
;;; RETURN: T if the <slot> in the <schema> is constant, nil otherwise
;;;
(defun slot-constant-p (schema slot)
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (declare (ignore value))
    (if position
      (is-constant (last-slot-bits (schema-slots schema) position)))))



;;; Called to give error message on multiply-installed formulas.
;;;
(defun set-formula-error (schema slot formula)
  ;; Formulas can only be installed on one slot!
  (format t "(s-value ~S ~S): formula ~S is already installed on~%~
	schema ~S, slot ~S.  Ignored.~%"
	  schema slot formula (on-schema formula) (on-slot formula))
  (when-debug
   (break))
  formula)



(defun s-value-fn (schema slot value position)
  (unless schema
    #+GARNET-DEBUG
    (format t "S-VALUE called with a null schema: slot ~S, value ~S.~%"
	    slot value)
    (return-from s-value-fn value))
  (let* ((slots (schema-slots schema))
	 (old-value (if position
		     ;; Slot position is known at compile time
		     (aref slots position)
		     ;; Unknown at compile time
		     (multiple-value-bind (v pos)
			 (find-slot-by-name schema slot)
		       (setf position pos)
		       v)))
	the-bits #-EAGER is-depended)
    ;; give error if setting constant slot
    (check-not-constant schema slot position)
    (if position
      (progn
	(if (eq old-value *no-value*)
	  (setf old-value NIL))
	(setf the-bits (last-slot-bits slots position)
	      is-depended (last-slot-dependents slots position)))
      (setf old-value nil
	    the-bits 0))
    (let ((is-formula nil) (is-relation nil)
	  (was-formula (formula-p old-value)))
      (when (and the-bits
		 (not (is-inherited the-bits))
		 (eq old-value value)
		 value)
	;; We are setting to the same value as the old one!  Do nothing.
	(return-from s-value-fn value))
      ;; Check for special cases in relation slots.
      (if (setf is-relation (relation-p slot))
	(if (eq (setf value (check-relation-slot schema slot value))
		*no-value*)
	  (return-from s-value-fn old-value)))
    
      ;; If we are installing a formula, make sure that the formula
      ;; points to the schema and slot.
      (when (formula-p value)
	(if (on-schema value)
	  (return-from s-value-fn (set-formula-error schema slot value)))
	(setf is-formula T)
	(setf (on-schema value) schema)
	(setf (on-slot value) slot)
	(unless (schema-name value)
	  ;; This is an obscure case.  It may happen if somebody stores a
	  ;; formula away, deletes the formula from its original slot, and
	  ;; then restores the formula.  This is generally bad practice, but
	  ;; there are cases when it may be necessary.
	  (incf *schema-counter*)
	  (setf (schema-name value) *schema-counter*)))

      ;; Now we call a demon to perform redisplay activities if the new
      ;; value is not a formula. If the new value is a formula, it has
      ;; not been evaluated yet so we do not know what its result is.
      ;; Since the display demon needs to know the new result to determine
      ;; if the object's bounding box should be merged with a clip region,
      ;; it does not make sense to call the display demon until the new
      ;; result is known
      (if (not is-formula)
	(run-pre-set-demons schema slot value NIL))
    
      ;; Now we can set the new value.
      (run-demons-and-set-value schema slot value old-value is-relation
				is-formula was-formula
				(logand the-bits *not-inherited-mask*)
				position)
    
      #-EAGER
      ;; Notify all dependents that the value changed.
      (if is-depended
	(let ((*warning-on-disconnected-formula* nil))
	  (propagate-change schema slot)))
      #-EAGER
      (if (and was-formula (not is-formula))
	;; We validate now, rather than earlier, because of a technicality
	;; in demons-and-old-values.
	(set-cache-is-valid old-value T))

      ;; Was the old value a formula?
      (when (and was-formula is-formula)
	;; This is replacing a formula with another.  Eliminate the dependency
	;; to the old one.
	(delete-formula old-value)
	#+EAGER
	;; give the new formula the priority. however, we do not give
	;; it the bits of the old formula because there are no dependencies
	;; to this formula, and so it cannot be part of a cycle
	(setf (a-formula-priority value) (priority old-value))
	#+EAGER
	;; convert cycle-edge dependencies to normal dependencies because
	;; this formula does not belong to a cycle
	(when (cycle-p old-value)
	  (dolist-test (dependent (find-dependents schema slot)
				  (and (cycle-edge-p dependent)
				       (valid-dependency-p dependent)))
		       (set-cycle-edge-bit dependent nil))))

      #+EAGER
      ;; add the schema-slot pair (or its dependents) to the to-be-reevaluated
      ;; list
      (if (formula-p value)
	(setf *eval-queue* (insert-pq value *eval-queue*))
	(add-to-reeval schema slot))
    
      (when is-relation
	;; A relation slot is being changed.  We may need to invalidate all
	;; inherited values.
	(reset-inherited-values schema))
      value)))



;;; This is a stripped-down version of s-value-fn which is used by
;;; create-schema and friends.  It skips a lot of the stuff that is
;;; unnecessary at schema creation time.
;;; 
(defun internal-s-value (schema slot value)
  (let* ((position (get slot :KR-FAST-ACCESSOR))
	 (is-formula (formula-p value))
	 (is-relation (relation-p slot)))
    (when is-relation
      (if (not (listp value))
	(setf value (list value)))
      ;; Check for special cases in relation slots.
      (if (eq (setf value (check-relation-slot schema slot value)) *no-value*)
	(return-from internal-s-value NIL)))

    ;; If we are installing a formula, make sure that the formula
    ;; points to the schema and slot.
    (when is-formula
      (if (on-schema value)
	(return-from internal-s-value (set-formula-error schema slot value)))
      (setf (on-schema value) schema)
      (setf (on-slot value) slot))

    (let ((new-bits *local-mask*))
      (if (and position (< position *first-slot*))
	;; This is a special slot - just set it
	(let ((slots (schema-slots schema)))
	  (setf (aref slots position) value)
	  (setf (aref slots (1+ position)) new-bits))
	;; This is not a special slot.
	(set-slot-accessor schema slot value new-bits)))

    ;; Take care of relations.
    (if is-relation
      (link-in-relation schema slot value))
    
    #+EAGER
    ;; add the schema-slot pair (or its dependents) to the to-be-reevaluated
    ;; list
    (if (formula-p value)
      (setf *eval-queue* (insert-pq value *eval-queue*))
      (add-to-reeval schema slot))
    value))



;;; Like the above, but this is used ONLY by create-schema.  The main
;;; difference is that non-special slots are appended to the end, without
;;; searching whether the slot is already present.
;;;
(defun internal-add-value (schema slot value)
  (let ((position (get slot :KR-FAST-ACCESSOR))
	(is-formula (formula-p value))
	(is-relation (relation-p slot)))
    (when is-relation
      (if (not (listp value))
	(setf value (list value)))
      ;; Check for special cases in relation slots.
      (if (eq (setf value (check-relation-slot schema slot value)) *no-value*)
	(return-from internal-add-value NIL)))

    ;; If we are installing a formula, make sure that the formula
    ;; points to the schema and slot.
    (when is-formula
      (if (on-schema value)
	(return-from internal-add-value (set-formula-error schema slot value)))
      (setf (on-schema value) schema)
      (setf (on-slot value) slot))

    (let ((new-bits *local-mask*)
	  (slots (schema-slots schema)))
      (if position
	;; This is a special slot - just set it
	(progn
	  (setf (aref slots position) value)
	  (setf (aref slots (1+ position)) new-bits)
	  (setf (aref slots (+ position 2)) NIL))
	;; This is an extra slot.  Add after the end.
	(progn
	  (vector-push-extend slot slots)
	  (vector-push-extend value slots)
	  (vector-push-extend new-bits slots)
	  (vector-push-extend NIL slots))))	; depended slots

    ;; Take care of relations.
    (if is-relation
      (link-in-relation schema slot value))
    
    #+EAGER
    ;; add the schema-slot pair (or its dependents) to the to-be-reevaluated
    ;; list
    (if (formula-p value)
      (setf *eval-queue* (insert-pq value *eval-queue*))
      (add-to-reeval schema slot))
    value))



;;; A specialized version of internal-s-value
;;;
(defun set-is-a (schema value)
  ;; Check for special cases in relation slots.
  (if (eq (setf value (check-relation-slot schema :is-a value)) *no-value*)
    (return-from set-is-a NIL))
  ;; Set slot
  (let ((slots (schema-slots schema))
	(position (get :IS-A :KR-FAST-ACCESSOR)))
    (setf (aref slots position) value)
    (setf (aref slots (1+ position)) *local-mask*))
  (link-in-relation schema :IS-A value)
  value)




;;; --------------------------------------------------


;;; If <except-schema> is non-nil, it indicates that a schema is in the
;;; process of being destroyed, and hence dependencies to THAT schema should
;;; not be tracked down.
;;;
(defun eliminate-formula-dependencies (formula except-schema)
  (do-one-or-list (schema (a-formula-depends-on formula))
    (unless (or (eq schema except-schema)
		(null (schema-slots schema)))	; schema is destroyed
      (let ((slots (schema-slots schema)))
	(iterate-slot-value (schema T T T)
	  slot				; suppress warning
	  (if (not (eq value *no-value*))
	    (let ((formulas (last-slot-dependents slots position)))
	      (if (listp formulas)
		;; Several dependents
		(if (member formula formulas)
		  (setf (aref slots (+ 2 position)) (delete formula formulas)))
		;; One dependent
		(if (eq formula formulas)
		  (setf (aref slots (+ 2 position)) NIL))))))))))



;;; Eliminate all dependency pointers from the <formula>, since it is no
;;; longer installed on a slot.
;;;
;;; INPUTS:
;;; - <formula>: the formula to get rid of
;;; - <hard-p>: if T, do a more thorough job of deleting everything, and
;;;   destroy the <formula> schema itself.
;;;
(defun delete-formula (formula)
  (when (a-formula-slots formula)
    #+EAGER
    (progn
      (setf *eval-queue* (delete formula *eval-queue*))
      ;; now set the evaluation bit of the old formula to true so that
      ;; the dependencies that still include it will not add it to the
      ;; evaluation queue
      (set-eval-bit formula nil)
      ;; increment the formula count so that all dependencies that
      ;; include it will go away (they will find that they are invalid)
      (incf (a-formula-bits formula) (* *count-mask* 2)))
    #-EAGER
    (eliminate-formula-dependencies formula NIL)
    ;; Formula was not destroyed yet
    (setf (a-formula-slots formula) nil) ; mark as destroyed.
    (setf (a-formula-schema formula) nil)
    (setf (a-formula-slot formula) nil)
    (setf (a-formula-depends-on formula) nil)
    (vector-push-extend formula *reuse-formulas*)))



(defun destroy-slot-helper (x slot)
  ;; Make sure formulas are updated properly
  (mark-as-changed x slot)
  ;; Physically remove the slot in the child.
  (set-slot-accessor x slot *NO-VALUE* 0))


;;;; DESTROY-SLOT
;;; 
;;; Destroy a slot in a schema, taking care of possible constraints.
;;; 
(defun destroy-slot (schema slot)
  "Eliminates the <slot>, and all the values it contains, from the <schema>."
  ;; Take care of all formulas which used to depend on this slot.
  (multiple-value-bind (old-value position)
      (slot-accessor schema slot)
    (unless (eq old-value *no-value*)
      (check-not-constant schema slot position)
      (let* ((slots (schema-slots schema))
	     (bits (last-slot-bits slots position))
	     (dependents (last-slot-dependents slots position))
	     new-value
	     #+EAGER
	     in-pq)
	(run-invalidate-demons schema slot)
	(when dependents
	  ;; Access all dependent formulas.
	  (do-one-or-list (formula dependents)
	    #+EAGER
	    (setf formula (car formula))
	    #+EAGER
	    (setf in-pq (eval-bit-set formula))
	    ;; If this value is depended on by others, replace their value
	    ;; by the current value.
	    (if (schema-name (on-schema formula))
	      (let ((the-schema (on-schema formula))
		    (the-slot (on-slot formula)))
		(if (not (formula-p (g-value the-schema the-slot)))
		  ;; Avoid complications with shared formulas.
		  (s-value the-schema the-slot
			   (g-value the-schema the-slot)))))
	    ;; The formula is then marked invalid.
	    #-EAGER
	    (set-cache-is-valid formula NIL)
	    #+EAGER
	    (progn
	      ;; set the formula's fixed bit back to nil to indicate it should 
	      ;; be evaluated during this iteration of the constraint solver
	      (set-fixed-bit formula nil)
	      (when (not in-pq)
		(setf *eval-queue* (insert-pq formula *eval-queue*))))))

	;; Destroy the formula, if this was a constrained slot.
	(if (formula-p old-value)
	  (delete-formula old-value))

	(if (relation-p slot)
	  (unlink-all-values schema slot))

	(setf new-value (g-value-inherit-values schema slot T position))
	;; Call the pre-set-demon function on this schema if
	;; this slot is an interesting slot and the value it is
	;; now inheriting is different from its previous value
	(run-pre-set-demons schema slot new-value old-value)

	#+EAGER
	;; Add this slot's dependents to the evaluation queue if its
	;; new inherited value is different from its old value.
	(unless (equal old-value new-value)
	  (add-to-reeval schema slot))
      
	(let ((was-parent (and bits (is-parent bits))))
	  (when was-parent
	    ;; Was this slot inherited by other schemata?  If so, make sure
	    ;; they will inherit the right value afterwards.
	    (update-inherited-values schema slot new-value T)
	    (visit-inherited-values schema slot #'destroy-slot-helper))))
      ;; Now go ahead and physically destroy the slot.
      (set-slot-accessor schema slot *NO-VALUE* 0)
      NIL)))



;;; Internal function.  If <recursive-p>, this is being called from within
;;; recursive-destroy-schema, so there is no need to maintain upwards
;;; relations properly.
;;; 
(defun delete-schema (schema recursive-p)
  (when (schema-slots schema)	; do nothing if schema is already destroyed
    ;; Remove all inverse links.
    (if (formula-p schema)
	;; Formulas do not use regular relations.
	(let ((parent (a-formula-is-a schema))
	      children)
	  (when parent
	    (setf children (a-formula-is-a-inv parent))
	    (setf (a-formula-is-a-inv parent)
		  (if (listp children)
		    (delete schema children)
		    (if (eq schema children)
		      NIL
		      children))))
	  (do-one-or-list (child (a-formula-is-a-inv schema))
	    ;; ? What exactly should happen here ?
	    (setf (a-formula-is-a child) NIL)))
	;; A normal schema
	(progn
	  (if (not recursive-p)
	    (iterate-accessor (schema NIL)
	      (if (relation-p slot)
		(unlink-all-values schema slot))))
	  (iterate-slot-value (schema NIL NIL NIL)
	    slot			; eliminate warning
	    ;; Delete any formula value.
	    (when (formula-p value)
	      ;; This is a formula.  Get rid of it.
	      (delete-formula value)
	      (delete-schema value recursive-p)))
	  ;; Physically delete all the slots
	  (clear-schema-slots schema)
	  (when (schema-slots schema)
	    (vector-push-extend (schema-slots schema) *reuse-slots*)
	    (setf (schema-slots schema) nil))))
    ;; Now wipe out the symbol value as well.
    (if (symbolp (schema-name schema))
	(makunbound (schema-name schema)))
    (setf (schema-slots schema) nil)))



;;; RETURNS: T if the given <expression>, or one of its subexpressions,
;;; directly depends on the <target>.  This must be a direct dependency,
;;; i.e., one which does not use a link.
;;; 
(defun find-direct-dependency (expression target)
  (when (listp expression)
    (or (and (eq (car expression) 'GV)
	     (eq (cadr expression) target))
	(dolist (thing expression)
	  (if (find-direct-dependency thing target)
	      (return T))))))



;;;; DESTROY-SCHEMA
;;; 
;;; Delete a schema, taking care not to leave around dangling constraint
;;; references.
;;;
(defun destroy-schema (schema &optional (send-destroy-message NIL) recursive-p)
  "Destroys the <schema>, eliminates all dependencies to and from it."
  (unless (schema-p schema)
    ;; If schema is already destroyed, do nothing.
    (return-from destroy-schema))
  (let ((done nil)
	bizarre)
    (iterate-slot-value (schema T T NIL)
      slot				; eliminate warning
      (unless (eq value *no-value*)
	#+COMMENT (mark-as-changed schema slot)
	;; Look at all formulas which depend on this slot.
	(do-one-or-list (formula (last-slot-dependents array position))
	  #+EAGER
	  (setf formula (car formula))	; get formula from dependency
	  (unless (or (null formula)	; defensive programming
		      (member formula done))
	    ;; If this is a value depended on by others, replace their
	    ;; value by the current value.  Do this, however, only if the
	    ;; dependency is a DIRECT one, i.e., if the name of the
	    ;; schema we are destroying is wired into the formula.  If
	    ;; this is a link, leave things as they are.
	    (let ((the-form 
		   (or (a-formula-lambda formula);; for o-formulas
		       (and (setf bizarre
				  ;; This should always be a
				  ;; list, but be prudent just
				  ;; in case.
				  (a-formula-function formula))
			    (listp bizarre)
			    (cddr bizarre)))))
	      (when (find-direct-dependency the-form schema)
		;; This is indeed a direct-dependency formula.  Install the
		;; appropriate value.
		(s-value (on-schema formula) (on-slot formula)
			 (g-value (on-schema formula) (on-slot formula)))
		(push formula done)
		;; The formula now commits suicide.
		(delete-formula formula)))))
	;; If this is a formula, eliminate dependencies to it, so we
	;; do not get warnings in propagate-change.
	(if (formula-p value)
	  (delete-formula value))))
    (if send-destroy-message
      ;; Call the :DESTROY method.
      (kr-call-initialize-method schema :DESTROY))
    ;; Physically delete the schema.
    (delete-schema schema recursive-p)))



;;; This is an internal function used by CREATE-INSTANCE.  The purpose is to
;;; destroy not only the <schema> itself, but also its instances (and so on,
;;; recursively).
;;; 
(defun recursive-destroy-schema (schema level)
  (unless (formula-p schema)		; safety check
    (let ((children (slot-accessor schema :IS-A-INV)))
      (when (and children (not (eq children *no-value*)))
	(dolist (child children)
	  (unless (eq child schema)
	    (recursive-destroy-schema child (1+ level)))))
      (when *warning-on-create-schema*
	(if (zerop level)
	  (format t "Warning - create-schema is destroying the old ~S.~%"
		  schema)
	  (format t "Warning - create-schema is recursively destroying ~S.~%"
		  schema)))))
  (destroy-schema
   schema
   NIL
   ;; if this is a top-level schema which has no prototype, use indiscriminate
   ;; destroy.
   (if (zerop level)
     (let ((value (slot-accessor schema :is-a)))
       (or (null value)
	   (eq value *no-value*)))
     T)))



;;; Since the <relation> slot was changed, all children of the <schema> may
;;; have to inherit different values.
;;; 
(defun reset-inherited-values (schema)
  (iterate-slot-value (schema T NIL T)	; use inheritance!
    (unless (relation-p slot)
      (unless (eq value *no-value*)
	(if (is-inherited (last-slot-bits array position))
	  (destroy-slot schema slot))))))



;;; -------------------------------------------------- SCHEMA PRINTING


;;; 
(defun print-one-value (value)
  (let ((string (if (formula-p value)
		    (let ((cached (cached-value value))
			  (valid (cache-is-valid value)))
		      (if (or valid cached)
			  (format nil "~S(~S . ~D)"
				  value
				  cached
				  valid)
			  (format nil "~S(nil . NIL)" value)))
		    (format nil "~S" value))))
    (write-string string)
    (length string)))



(defun print-one-slot-helper (value column indent space-p)
  (when (> column 78)
    (format t "~%    ")
    (setf column (indent-by indent)))
  (if space-p
    (write-string " "))
  (incf column (print-one-value value))
  column)



(defun print-one-slot (schema name limit-values inherited-ok indent)
  (multiple-value-bind (values position)
      (slot-accessor schema name)
    (let (bits)
      (unless (eq values *no-value*)
	(setf bits (last-slot-bits (schema-slots schema) position)))
      (if bits
	(let ((are-inherited (and (is-inherited bits)
				  ;; Inherited formulas are printed anyway.
				  (not (formula-p values)))))
	  (unless (and (not inherited-ok) are-inherited)
	    (let ((number 0)
		  (printed nil)
		  (column (+ 20 (indent-by indent))))
	      (if are-inherited
		(format t "  ~(~S~) (inherited): " name)
		(format t "  ~S = " name))
	      (if (and values (listp values) (listp (cdr values)))
		(progn
		  (format t "(")
		  (dolist (value values)
		    (setf printed t)
		    (setf column (print-one-slot-helper value column indent
							(> number 0)))
		    (incf number)
		    (when (and limit-values (> number limit-values))
		      ;; Too many values: use ellipsis form.
		      (format t " ...)~%")
		      (return-from print-one-slot nil)))
		  (format t ")"))
		(progn
		  (setf printed t)
		  (setf column
			(print-one-slot-helper values column indent T))))
	      (if printed
		(terpri)
		(format t " NIL~%")))))))))


(defun indent-by (indent)
  (dotimes (i indent)
    (write-string "   "))
  (* indent 3))



(defun force-down-helper (schema original-slots slots)
  (iterate-accessor (schema T)
    (unless (member slot original-slots)
      (pushnew slot slots)))
  (dolist (parent (get-local-value schema :is-a))
    (setf slots (force-down-helper parent original-slots slots)))
  slots)



;;; A potentially VERY expensive operation.  It is done by PS when it wants
;;; to print out all inherited and inheritable slots of an object.
;;;
(defun force-down-all-inheritance (schema)
  (let ((original-slots nil))
    (iterate-accessor (schema T)
      (push slot original-slots))
    (dolist (slot (force-down-helper schema original-slots nil))
      (g-value schema slot))))



;;;; PS
;;;
;;; PS allows fancy control of what gets printed and how.
;;; <control> is one of:
;;; - T, which means that the <schema> itself is used
;;;   as the controlling schema.
;;; - :default, which means that PRINT-SCHEMA-CONTROL is used as the
;;;   controlling schema;
;;; - a schema, which is used as the controlling schema; or
;;; - NIL or nothing, which means no schema control.
;;; <inherit> controls whether inherited slots are printed.  If non-nil,
;;; all slots that have been inherited are printed out.
;;; 
;;;
(defun ps (schema &key (control t) inherit (indent 0))
  "PS prints the <schema>.  The optional arguments control what is printed.
  A control schema may be used to determine which options are printed, which
  ones are ignored, etc.  See the manual for details.
  
  <control> can be one of the following:
  NIL, which means that the <schema> is printed in its entirety;
  T, which means that the <schema> itself is used as the control schema;
  :DEFAULT, which means that the schema KR:PRINT-SCHEMA-CONTROL is used;
  any schema, which is used as the control schema.
  
  If <inherit> is non-nil, slots that have been inherited are also printed.
  <indent> is used for debugging and should not be set by the user."
  
  (declare (special print-schema-control))
  (if (numberp schema)
      (setf schema (s schema)))
  (unless (or (schema-p schema) (formula-p schema))
    (format t "~S~%" schema)
    (return-from ps nil))
  (indent-by indent)
  (cond ((formula-p schema)
	 (setf control NIL))
	((eq control :default)
	 ;; use default control schema
	 (setf control PRINT-SCHEMA-CONTROL))
	((eq control T)
	 ;; use schema itself as the control schema (i.e., use hierarchy)
	 (setf control schema)))
  (let ((slots-ignored (if control (g-value-no-copy control :IGNORED-SLOTS)))
	(sorted (if control (g-value-no-copy control :SORTED-SLOTS)))
	(limit-values (if control (g-value-no-copy control :LIMIT-VALUES)))
	(global-limit (if control
			  (g-value-no-copy control :GLOBAL-LIMIT-VALUES)
			  most-positive-fixnum))
	(*print-as-structure*
	 (if (and control
		  (g-value-no-copy control :print-as-structure))
					; value is defined
	     (g-value-no-copy control :print-as-structure)
					; value is undefined
	     *print-as-structure*))
	(*print-structure-slots* (if control
				     (g-value-no-copy control :print-slots)))
	name)
    (format t "{~S~%" schema)
    ;; Print out all the sorted slots, first.
    (dolist (o sorted)
      (print-one-slot schema o
		      (or (second (assoc name limit-values))
			  global-limit)
		      inherit indent))
    ;; Now print the remaining slots.
    (unless (listp slots-ignored)
      (setf slots-ignored (list slots-ignored)))
    (if inherit
      ;; Pre-inherit all slots that are inheritable.
      (force-down-all-inheritance schema))
    (iterate-accessor (schema)
      (unless (or (member slot slots-ignored) (member slot sorted))
	(print-one-slot schema slot
			(or (second (assoc slot limit-values)) global-limit)
			inherit indent)))
    (when slots-ignored
      (indent-by indent)
      (format t "  List of ignored slots:  ~{ ~A~}~%" slots-ignored))
    ;; special formula slots?
    (when (a-formula-p schema)
      (indent-by indent)
      (format t "  lambda:        ~(~S~)~%" (a-formula-lambda schema))
      (format t "  cached value:  (~S . ~S)~%"
	      (cached-value schema) (cache-is-valid schema))
      (format t "  on schema ~S, slot ~S~%"
	      (on-schema schema) (on-slot schema)))
    (indent-by indent)
    (format t "  }~%")))



;;; --------------------------------------------------


(defun the-bits (entry)
  (if (integerp entry)
      ;; The normal case
      (format t "~:[-~;L~]~:[-~;C~]~:[-~;P~]~:[-~;i~] "
	      (is-link-constant entry) (is-constant entry)
	      (is-parent entry) (is-inherited entry))
      ;; A special case for formula slots which are stored in a special way
      (format t "---- ")))



;;; Internal debugging - print out schemata in gory detail.
;;;
(defun full (&rest schemata)
  (dolist (schema schemata)
    (if (numberp schema)
      (setf schema (s schema)))
    (let ((is-formula (a-formula-p schema)))
      ;; use iterate-accessors to get inherited slots as well
      (if is-formula
	;; This is a formula
        (progn
	  (format
	   t "---------------------------------------------- formula ~S~%"
	   schema)
	  ;; print special formula slots.
	  (format t "Schema, slot:           ~S  ~S~%"
		  (on-schema schema) (on-slot schema))
	  (format t "Cached value:           (~S . ~S)~%"
		  (cached-value schema) (a-formula-number schema))
	  (format t "Depends on:             ~S~%"
		  (a-formula-depends-on schema))
	  (format t "Lambda:                 ~(~S~)~%"
		  (a-formula-lambda schema))
	  (if (a-formula-is-a schema)
	      (format t
		  "parent formula:         ~S~%"
		  (a-formula-is-a schema)))
	  (if (a-formula-is-a-inv schema)
	      (format t "children:               ~S~%"
		      (a-formula-is-a-inv schema))))
	;; This is a normal slot
	(progn
	  (format
	   t "---------------------------------------------- schema ~S~%"
	   schema)
	  (iterate-accessor (schema T T)
	   (format t "~(~24S~) " slot)
	   (multiple-value-bind (values position)
	       (slot-accessor schema slot)
	     (let* ((slots (schema-slots schema))
		    (bits (last-slot-bits slots position))
		    (dependents (last-slot-dependents slots position)))
	       (the-bits bits)
	       (if (eq values *no-value*)
		 ;; No slot???
		 (terpri)
		 ;; Slot is there
		 (let ((first t))
		   (if (and (listp values) (listp (cdr values)))
		     (when values
		       (format t "(")
		       (dolist (value values)
			 (if first
			   (setf first nil)
			   (write-string " "))
			 (print-one-value value))
		       (format t ")"))
		     (print-one-value values))
		   ;; Show dependent formulas, if any
		   (when dependents
		     (format t "   ****--> ")
		     (do-one-or-list (f dependents)
		       (format t " ~s" f)))
		   (terpri))))))))))
  (values))



;;; -------------------------------------------------- O-O PROGRAMMING



;;; Find a parent of <schema> from which the <slot> can be inherited.
;;; 
(defun find-parent (schema slot)
  (dolist (relation *inheritance-relations*)
    (dolist (a-parent (if (eq relation :is-a)
			(get-local-value schema :IS-A)
			(get-local-value schema relation)))
      (if a-parent
	(let ((value (g-local-value a-parent slot)))
	  (if value
	      (return-from find-parent (values value a-parent))
	      (multiple-value-bind (value the-parent)
				   (find-parent a-parent slot)
		(if value
		    (return-from find-parent (values value the-parent))))))))))






;;; Same as KR-SEND, but as a function.
;;; 
(defun old-kr-send-function (schema slot &rest args)
  (let ((the-function (g-value schema slot)))
    (when the-function
      ;; Bind these in case call prototype method is used.
      (let ((*kr-send-self* schema)
	    (*kr-send-slot* slot)
	    (*demons-disabled* T))
	(apply the-function args)))))



;;; This is similar to kr-send-function, except that it is careful NOT to
;;; inherit the method, which is only used once.  This is to reduce unnecessary
;;; storage in every object.
;;; 
(defun kr-call-initialize-method (schema slot)
  (let ((the-function (g-value-no-copy schema slot)))
    (if the-function
      ;; Bind these in case call prototype method is used.
      (let ((*kr-send-self* schema)
	    (*kr-send-slot* slot)
	    (*demons-disabled* T))
	(funcall the-function schema)))))



;;; Similar, but even more specialized.  It is only called by create-schema
;;; and friends, which know whether an :initialize method was specified
;;; locally.
;;;
(defun kr-init-method (schema the-function)
  (let ((*kr-send-parent* nil))
    (if the-function
      (setf *kr-send-parent* schema)
      (multiple-value-setq (the-function *kr-send-parent*)
	(find-parent schema :INITIALIZE)))
    (if the-function
      ;; Bind these in case call prototype method is used.
      (let ((*kr-send-self* schema)
	    (*kr-send-slot* :INITIALIZE)
	    (*demons-disabled* T))
	(funcall the-function schema)))))



;;;; CALL-PROTOTYPE-FUNCTION
;;; Same, as a function
;;;
(defun call-prototype-function (&rest args)
  (let (parent)
    (if (get-local-value *kr-send-self* *kr-send-slot*)
	(setf parent *kr-send-self*)
	(multiple-value-bind (method real-parent)
			     (find-parent *kr-send-self* *kr-send-slot*)
	  (declare (ignore method))
	  (setf parent real-parent)))
    (multiple-value-bind (function- the-parent)
			 (find-parent parent *kr-send-slot*)
      (when function-
	(let ((*kr-send-self* the-parent))
	  (funcall function- args))))))



;;; --------------------------------------------------



(defparameter *min-size*
  (+ (* (1- *slot-size*) (length *schema-slots*))	; special slots
     (* *slot-size* 2))			; extra slots
  "Initial size for a new array of slots")



(defun allocate-schema-slots (schema)
  (let (slots)
    (dotimes (i (length *reuse-slots*))
      (when (>= (array-dimension (aref *reuse-slots* i) 0) *min-size*)
	(setf slots (aref *reuse-slots* i))
	(let ((l (1- (length *reuse-slots*))))
	  (if (> l i)
	    (rotatef (aref *reuse-slots* i) (aref *reuse-slots* l)))
	  (decf (fill-pointer *reuse-slots*)))
	(return)))
    (if slots
      (setf (schema-slots schema) slots)
      ;; Need to create a new array.
      (progn
	(setf slots (make-array *min-size* :adjustable t :fill-pointer t))
	(setf (fill-pointer slots) *first-slot*)
	(setf (schema-slots schema) slots)
	(clear-schema-slots schema))))
  schema)



;;; Creates a schema with the given <name>, making sure to destroy the old
;;; one by that name if it exists.
;;; 
(defun make-a-new-schema (name)
  (if (keywordp name)
    (setf name (symbol-name name)))
  (cond ((null name)
	 ;; An unnamed schema.
	 (let ((schema (make-schema)))
	   (setf *schema-counter* (1+ *schema-counter*))
	   (setf (schema-name schema) *schema-counter*)
	   (allocate-schema-slots schema)
	   schema))

	((stringp name)
	 ;; This clause must precede the next!
	 (let ((schema (make-schema)))
	   (allocate-schema-slots schema)
	   (setf (schema-name schema) name)
	   schema))

	;; Is this an existing schema?  If so, destroy the old one and its
	;; children.
	((and (boundp name)
	      (symbolp name))
	 (let ((schema (symbol-value name)))
	   (if (is-schema schema)
	     (progn
	       (recursive-destroy-schema schema 0)
	       (allocate-schema-slots schema))
	     (progn
	       (setf schema (make-schema))
	       (allocate-schema-slots schema)
	       (eval `(defvar ,name))))
	   ;; Assign the new schema as the value of the variable <name>.
	   (setf (schema-name schema) name)
	   (set name schema)))

	((symbolp name)
	 (eval `(defvar ,name))
	 (let ((schema (make-schema)))
	   (allocate-schema-slots schema)
	   (setf (schema-name schema) name)
	   (set name schema)))
	(t
	 (format t "Error in CREATE-SCHEMA - ~S is not a valid schema name.~%"
		 name))))




;;; --------------------------------------------------


;;; The <slot> in <schema> was declared a link-constant.
;;;
(defun process-one-link-constant (schema slot)
  ;; set slot information
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (if (and (eq value *no-value*)
	     (null position))
      ;; Slot is not present - create it, mark constant.
      (set-slot-accessor schema slot *no-value* *link-constant-mask*)
      ;; Slot is present.
      (let ((slots (schema-slots schema)))
	(setf (aref slots (1+ position))
	      (logior *link-constant-mask*
		      (last-slot-bits slots position)))))))


;;; The <slot> in <schema> was declared constant.
;;;
(defun process-one-constant (schema slot)
  ;; set slot information
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (if (and (eq value *no-value*)
	     (null position))
      ;; Slot is not present - create it, mark constant.
      (set-slot-accessor schema slot *no-value* *constant-mask*)
      ;; Slot is present
      (let ((slots (schema-slots schema)))
	(setf (aref slots (1+ position))
	      (logior *constant-mask* (last-slot-bits slots position)))))))



;;;; DECLARE-CONSTANT
;;;
;;; This function can be used to declare slot constants AFTER instance creation
;;; time.
;;;
(defun declare-constant (schema slot)
  (unless *constants-disabled*
    (if (eq slot T)
      ;; This means that all constants declared in :MAYBE-CONSTANT should be
      ;; made constant
      (let ((maybe (g-value-no-copy schema :MAYBE-CONSTANT)))
	(dolist (m maybe)
	  (declare-constant schema m)))
      ;; This is the normal case - only 1 slot.
      (let ((constant-list (g-value schema :CONSTANT))
	    (positive T))
	(do ((list constant-list (if (listp list) (cdr list) NIL))
	     (prev nil list)
	     c)
	    ((null list)
	     (setf constant-list (cons slot (if (listp constant-list)
					      constant-list
					      (list constant-list))))
	     (s-value schema :CONSTANT constant-list)
	     (process-one-constant schema slot))
	  (setf c (if (listp list) (car list) list))
	  (cond ((eq c :EXCEPT)
		 (setf positive NIL))
		((eq c slot)
		 (when positive
		   ;; Slot is already marked constant, so there's nothing
		   ;; to do.
		   (process-one-constant schema slot)
		   (return nil))
		 ;; Slot was explicitly excepted from constant list.
		 (setf (cdr prev) (cddr prev)) ; remove from :EXCEPT
		 (if (and (null (cdr prev))
			  (eq (car prev) :EXCEPT))
		   ;; We are removing the last exception to the constant list
		   (let ((end (nthcdr (- (length constant-list) 2)
				      constant-list)))
		     (setf (cdr end) nil)))
		 (setf constant-list (cons c constant-list))
		 (s-value schema :CONSTANT constant-list)
		 (process-one-constant schema slot)
		 (return))))))))



;;;; DECLARE-LINK-CONSTANT
;;;
;;; This function can be used to declare link constants AFTER instance creation
;;; time.
;;;
(defun declare-link-constant (schema slot)
  (let ((constant-list (g-value schema :LINK-CONSTANT)))
    (do-one-or-list (l constant-list)
      (if (eq l slot)
	;; Alread a link constant.
	(return-from declare-link-constant NIL)))
    (setf constant-list (cons slot (if (listp constant-list)
				     constant-list
				     (list constant-list))))
    (s-value schema :LINK-CONSTANT constant-list)
    (process-one-link-constant schema slot)))



;;; Process local-only and constant declarations.
;;; 
(defun process-constant-slots (the-schema parents constants link-constants)
  (dolist (parent parents)
    (dolist (local (g-value-no-copy parent :LOCAL-ONLY-SLOTS))
      ;; Set the slots marked as local-only
      (let ((slot (car local)))
	(if (eq (slot-accessor the-schema slot) *no-value*)
	  (if (second local)
	    ;; Copy down the parent value, once and for all.
	    (let ((value (slot-accessor parent slot)))
	      (if (not (formula-p value))
		;; Prevent inheritance from ever happening
		(internal-s-value the-schema slot (g-value parent slot))))
	    ;; Avoid inheritance and set the slot to NIL.
	    (internal-s-value the-schema slot NIL))))))
  ;; Now process constant declarations.
  (unless *constants-disabled*
    (let ((constant (or constants
			(if parents (g-value (car parents) :CONSTANT))))
	  (link-constant (or link-constants
			     (if parents
			       (g-value (car parents) :LINK-CONSTANT))))
	  (not-constant nil)
	  (add-prototype nil))
      (when constant			; process constant declarations
	(if (listp constant)
	  (progn
	    (if (eq (car constant) 'QUOTE)
	      (format t "The :CONSTANT list for schema ~S is specified incorrectly - too many quotes:~%   ~S~%" the-schema constant))
	    ;; Normal case - a list
	    (do ((c constant (cdr c)))
		((null c))
	      (cond ((eq (car c) T)
		     (setf add-prototype T))
		    ((eq (car c) :EXCEPT) ; following is list of non-constants
		     (setf not-constant (cdr c))
		     (return))
		    (t
		     (process-one-constant the-schema (car c))))))
	  ;; For the case (:CONSTANT T), for example - single value
	  (if (eq constant T)
	    (setf add-prototype T)
	    (process-one-constant the-schema constant)))
	(if add-prototype		; Add slots declared in prototype
	  (let ((maybe-constant (g-value-no-copy the-schema :MAYBE-CONSTANT)))
	    (if (listp maybe-constant)
	      (dolist (c maybe-constant)
		(unless (member c not-constant)
		  (process-one-constant the-schema c)))
	      (process-one-constant the-schema maybe-constant)))))
      (if link-constant		; process link constants
	(if (not *link-constants-disabled*)
	  (do-one-or-list (l link-constant)
	    (process-one-link-constant the-schema l)))))))


;;; --------------------------------------------------



(eval-when (eval compile load)
  (defun cannot-be-quoted (value)
    (or (listp value)
	(and (symbolp value)
	     (not (keywordp value))))))


(eval-when (eval compile load)
 (defun process-slot-descriptor (x)
   (if (listp x)
       (if (find-if #'cannot-be-quoted (cdr x))
	   (cons 'list x)
	 `',x)
     x)))



(eval-when (eval compile load)
  (defun process-slots (slots)
    (let ((output nil)
	  (is-a nil))
      (do ((head slots (cdr head))
	   slot)
	  ((null head))
	(setf slot (car head))
	(if (keywordp slot)
	  (if (eq slot :NAME-PREFIX)
	    (pop head))
	  (if (eq (car slot) :IS-A)
	    (setf is-a (if (cddr slot)
			 `(list ,@(cdr slot))
			 (cadr slot)))
	    (if (listp (cdr slot))
	      (if (find-if #'cannot-be-quoted (cdr slot))
		(if (cddr slot)
		  (push `(list ,(car slot) . ,(cdr slot)) output)
		  (push `(cons ,(car slot) . ,(cdr slot)) output))
		(if (cddr slot)
		  (push `'(,(car slot) . ,(cdr slot)) output)
		  (push `'(,(car slot) . ,(cadr slot)) output)))
	      (push (cdr slot) output)))))
      (cons is-a output))))



;;;; Create-schema and friends expand into a call to this function.
;;;
(defun do-schema-body (schema is-a generate-instance do-constants override
			      &rest slot-specifiers)
  (if (not (listp is-a))
    (setf is-a (list is-a)))
  (do* ((*schema-is-new* T)		; Bind to prevent search on insertion
					; of :is-a-inv in parent schemata.
	(slots slot-specifiers (cdr slots))
	(slot (car slots) (car slots))
	(initialize-method NIL)
	(constants NIL)
	(link-constants NIL)
	(parent-constants (if (car is-a)
			    (let ((c (g-value (car is-a) :CONSTANT)))
			      (if (eq c T)
				(setf c (g-value (car is-a) :MAYBE-CONSTANT)))
			      c))))
       ((null slots)
	;; Check for immediate is-a loop
	(if is-a (if (or (eq schema is-a)
			 (member schema is-a))
		   (format t "~A: cannot make ~S an instance of itself!  ~
    			Using NIL instead.~%"
			   (if generate-instance
			     "CREATE-INSTANCE" "CREATE-SCHEMA")
			   schema)
		   ;; Make sure :override does not duplicate is-a-inv contents.
		   (let ((*schema-is-new* (not override)))
		     (set-is-a schema is-a))))
	(when do-constants
	  (process-constant-slots
	   schema is-a
	   (if constants
	     (if (formula-p constants)
	       (g-value-formula-value schema :CONSTANT constants)
	       constants))
	   (if link-constants
	     (if (formula-p link-constants)
	       (g-value-formula-value schema :LINK-CONSTANT link-constants)
	       link-constants))))
	(if generate-instance
	  ;; We are generating code for a CREATE-INSTANCE, really.
	  (kr-init-method schema initialize-method))
	schema)
    (cond ((eq slot :NAME-PREFIX)
	   ;; Skip this and the following argument
	   (pop slots))
	  ((consp slot)
	   (let ((slot-name (car slot))
		 (slot-value (cdr slot)))
	     (if (eq slot-name :INITIALIZE)
	       (if slot-value
		 ;; A local :INITIALIZE method was provided
		 (setf initialize-method slot-value))
	       (cond ((eq slot-name :CONSTANT)
		      (setf constants (cdr slot)))
		     ((eq slot-name :LINK-CONSTANT)
		      (setf link-constants (cdr slot)))))
	     ;; Test code - check that slot is not constant in parent.
	     (if (and (not *constants-disabled*)
		      (not *redefine-ok*))
	       (do-one-or-list (constant parent-constants)
		 (when (eq slot-name constant)
		   (format
		    t "Slot ~S in ~S was declared constant in prototype ~S!~%"
		    slot-name schema (car is-a))
		   (break))))
	     (if override
	       ;; This is more costly - check whether the slot already exists,
	       ;; dependencies, etc.
	       (s-value schema slot-name slot-value)
	       #+COMMENT (internal-s-value schema slot-name slot-value)
	       ;; No check needed in this case.
	       (internal-add-value schema slot-name slot-value)))))))




(eval-when (eval compile load)
  (defun creation-message (name)
    (when *print-new-instances*
	  (if (and (listp name)
		   (eq (car name) 'QUOTE))
	      (format *standard-output* "Object ~S~%" (eval name))))))



