;;; -*- 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???
;;;
;;; - 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?
;;;


;;; Slot bits assignment:
;;; 0-9 types encoding
;;;   - inherited
;;;   - is-parent
;;;   - constant-slot
;;;   - is-update-slot
;;;   - local-only-slot    ; not implemented
;;;   - parameter-slot     ; not implemented



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


;;; Unless the user explicitly overrides this, set for maximum execution
;;; speed.
;;;
(eval-when (eval compile load)
  (proclaim '(special user::*default-garnet-proclaim*))
  (if (boundp 'user::*default-garnet-proclaim*)
      (if user::*default-garnet-proclaim*
        (proclaim user::*default-garnet-proclaim*))
      (proclaim '(optimize (safety 0) (space 0)
		  (speed #-LUCID 3 #+LUCID 2) #+ALLEGRO (debug 0)))))



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


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



;;; Completely clear a slot, including dependencies, inherited, etc...
;;; BUT... Leave around the declarations (constant,type,update,...)
;;;
(defun clear-one-slot (schema slot entry)
  (let ((the-entry (or entry (slot-accessor schema slot))))
    (if the-entry
      (setf (sl-value the-entry) *no-value*
	    (sl-bits the-entry)  (logand (sl-bits the-entry)
                                         *clear-slot-mask*)))))



;;; Completely clear ALL the slots in the <schema>.
;;;
(defun clear-schema-slots (schema)
  (let ((bins (schema-bins schema)))
    (dotimes (i *bins-length*)
      (setf (aref bins i) NIL))))



;;; Does the actual work of G-VALUE.
;;;
(defun value-fn (schema slot)
  (g-value-body schema slot T T))


;;; Similar to g-value-fn, but no inheritance.
;;;
(defun g-local-value-fn (schema slot)
  (g-value-body schema slot NIL T))



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

;;;; 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 ((value (slot-dependents (slot-accessor schema slot))))
      (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 (memberq demon (cdr *demons-disabled*))
	     *demons-disabled*		; nothing is needed
	     (cons T (cons demon (cdr *demons-disabled*))))
	   ;; Normal format
	   (if (memberq 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 (memberq 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 (memberq demon (cdr *demons-disabled*)))
      ;; Normal format
      (memberq 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 slot-structure)
  (declare (function formula-fn (t &optional t) t))
  (let (has-parents)
    (if (a-local-only-slot slot)	; 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)
	(let ((entry (slot-accessor parent slot))
	      (value *no-value*)
	      bits			; parent bits
	      (intermediate-constant NIL))
	  (when entry
	    (setf value (sl-value entry))
	    (if (is-constant (sl-bits entry))
	      (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 (sl-bits entry)))
	  (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.
	      (if entry
		;; Destructively set the bits.
		(setf (sl-bits entry) (logior bits *is-parent-mask*))
		(set-slot-accessor parent slot value
				   (logior bits *is-parent-mask*) nil)))
	    ;; 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-fn value (a-formula-cached-value value)))
		(setf (a-formula-schema value) schema)
		(setf (a-formula-slot value) slot)
		(set-cache-is-valid value NIL))
	      ;; Copy down, mark as inherited if inherited
	      (if is-leaf
		(if slot-structure	; slot had constant bit
		  (setf bits (logior bits (sl-bits slot-structure)))))
	      (setf bits (logior *inherited-mask* bits
				 #+TEST
				 (logand bits *not-parent-constant-mask*)))
	      (if intermediate-constant
		(setf bits (logior *constant-mask* bits)))
	      (set-slot-accessor schema slot value bits
				 (slot-dependents slot-structure)))
	    (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 slot-structure
				(logior *inherited-mask*
					(sl-bits slot-structure))
				*inherited-mask*))
			     (has-parents *inherited-parent-mask*)
			     (t		; top-level, no parents
			      *is-parent-mask*))
		       (slot-dependents slot-structure))
    *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)))



;;; 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)))
      (if value
	(return-from g-value-no-copy (sl-value 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 (not-deleted-p schema)
				     (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-slot (slot stream level)
  (declare (ignore level))
  (format stream "<slot ~S  value ~S, bits ~S"
	  (sl-name slot) (sl-value slot) (sl-bits slot))
  (if (full-sl-p slot)
    (format stream ",  dependents ~S>" (full-sl-dependents slot))
    (format stream ">")))



(defun print-the-schema (schema stream level)
  (declare (ignore level))
  (let ((name (schema-name schema))
	(destroyed (not (not-deleted-p 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 (cadr (assocq slot *relations*)))) ; e.g., is-a-inv
    (when inverse
      ;; If the relation has an INVERSE slot, remove <schema> from the
      ;; inverse slot.
      (let ((entry (slot-accessor value inverse))  ; e.g., A child B
	    values)
	(when entry
	  (setf values (sl-value entry))
	  (if (eq (car values) schema)
	      ;; <schema> is first in the inverse list
	      (set-slot-accessor value inverse (delete schema values)
				 (sl-bits entry) (slot-dependents entry))
	      ;; 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 (assocq slot *relations*))))
    (if inverse
      (let ((entry (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 entry
	  (dolist (parent (sl-value entry))
	    (if (not-deleted-p parent)	; parent is not destroyed
	      ;; If the terminal has an INVERSE slot, remove <schema> from the
	      ;; inverse slot.
	      (let ((entry (if (eq inverse :is-a-inv)
			     (slot-accessor parent :is-a-inv) ; e.g., A child B
			     (slot-accessor parent inverse)))
		    values)
		(when entry
		  (setf values (sl-value entry))
		  (if (eq (car values) schema)
		    (pop (sl-value entry))
		    (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 (assocq slot *relations*)))))
    (if inverse
      ;; <values> is a list: cycle through them all
      (dolist (value values)
	(let* ((entry (if (eq slot :is-a)
			(slot-accessor value :is-a-inv)
			(slot-accessor value inverse)))
	       (previous-values (if entry (sl-value entry))))
	  (if entry
	    ;; Create the back-link.  We use primitives here to avoid looping.
	    (if (or *schema-is-new*
		    (not (memberq schema previous-values)))
	      ;; Handle an important special case efficiently.
	      (push schema (sl-value entry)))
	    ;; There was no inverse in the parent yet.
	    (set-slot-accessor value inverse (list schema) *local-mask*
			       nil)))))))



;;; 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 (memberq (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)
  (let ((entry (slot-accessor schema slot)))
    (if entry
      (or (is-inherited (sl-bits entry))
	  (and (formula-p (sl-value entry))
	       (formula-p (a-formula-is-a (sl-value entry))))))))



;;; -------------------------------------------------- ENCODE TYPES

(defparameter types-table (make-hash-table :test #'equal)
  "Hash table used to look up a Lisp type and returns its code")


(defparameter *types-array-inc* 255) ;; allocate in blocks of this size

(defparameter *next-type-code*  0)   ;; next code to allocate

(defparameter types-array NIL
  "Array used to decode a number into its corresponding Lisp type.")

(defparameter type-fns-array NIL
  "Array used to decode a number into its corresponding type-fn.")

(defparameter type-docs-array NIL
  "Array used to decode a number into its corresponding documentation string.")



;;; Given simple type ('NULL, 'KEYWORD, etc...), returns the name of
;;; the lisp predicate to test this ('NULL, 'KEYWORDP, etc....)
;;;
(defun find-lisp-predicate (simple-type)
  (let ((p-name (concatenate 'string (symbol-name simple-type) "P"))
	(-p-name (concatenate 'string (symbol-name simple-type) "-P")))
    (cond ((memberq simple-type '(NULL ATOM)) simple-type)
	  (T (or (find-symbol p-name 'lisp)
		 (find-symbol -p-name 'lisp)
		 (find-symbol p-name)
		 (find-symbol -p-name)
		 (error "Could not find predicate for simple-type ~S~%"
			simple-type))))))



(defun make-lambda-body (complex-type)
  (let (code)
    (cond ((consp complex-type);; complex type (a list)
	   (let ((fn   (first complex-type))
		 (args (rest  complex-type)))
	     (case fn
	       ((OR AND NOT)
		(cons fn (mapcar #'make-lambda-body args)))
	       (MEMBER
		`(memberq value ',args))
	       ((IS-A-P IS-A)
		`(is-a-p value ,(second complex-type)))
	       (SATISFIES
		`(,(second complex-type) value))
	       ((INTEGER REAL)
		(let* ((pred (find-lisp-predicate fn))
		       (lo (first args))
		       (lo-expr (if (and lo (not (eq lo '*)))
				  (if (listp lo)
				    `((< ,(car lo) value))
				    `((<= ,lo value)))))
		       (hi (second args))
		       (hi-expr (if (and hi (not (eq hi '*)))
				  (if (listp hi)
				    `((> ,(car hi) value))
				    `((>= ,hi value))))))
		  (if (or lo-expr hi-expr)
		    `(and (,pred value) ,@lo-expr ,@hi-expr)
		    `(,pred value))))
	       (T  (error "Unknown complex-type specifier: ~S~%" fn)))))
	  ((setq code (gethash (symbol-name complex-type) types-table))
	   ;; is this a def-kr-type?
	   (make-lambda-body (code-to-type code)))
	  (T;; simple-type
	   (list (find-lisp-predicate complex-type) 'value)))))



;;; Given the Lisp type, construct the lambda expr, or return the
;;; built-in function
;;;
(defun type-to-fn (type)
 (let (code)
  (cond ((consp type)			; complex type
	  (if (eq (car type) 'SATISFIES)
	   (let ((fn-name (second type)))
	     `',fn-name) ;; koz
	   `(function (lambda (value)
	      (declare (optimize (safety 0) (space 0)
				 (speed #-LUCID 3 #+LUCID 2)
                                 #+ALLEGRO (debug 0)))
	      ,(make-lambda-body type)))))
	((setq code (gethash (symbol-name type) types-table))
	 ;; is this a def-kr-type?
	 (code-to-type-fn code))
	(T
	 `',(find-lisp-predicate type)))))



(defun copy-extend-array (oldarray oldlen newlen)
  (let ((result (make-array newlen)))
    (dotimes (i oldlen)
      (setf (svref result i) (svref oldarray i)))
    result))



;;; Return the next available type-code, and extend the type arrays
;;; if necessary.
;;;
(defun get-next-type-code ()
  (let ((curlen (length types-array)))
   (when (>= *next-type-code* curlen)
    ;; out of room, allocate more space
    (let ((newlen (+ curlen *types-array-inc*)))
     (setf types-array     (copy-extend-array types-array     curlen newlen)
           type-fns-array  (copy-extend-array type-fns-array  curlen newlen)
           type-docs-array (copy-extend-array type-docs-array curlen newlen))))   ;; in any case, return current code, then add one to it
   (prog1
     *next-type-code*
     (incf *next-type-code*))))



;;; This adds a new type, if necessary
;;; Always returns the CODE of the resulting type (whether new or not)
;;;
(defun add-new-type (typename type-body type-fn &optional type-doc)
  (let ((code (gethash (or typename type-body) types-table)))
    (if code
      ;; redefining same name
      (if (equal (code-to-type code) type-body)
        ;; redefining same name, same type
        (progn
          (format t "Ignoring redundant def-kr-type of ~S to ~S~%"
		  typename type-body)
          (return-from add-new-type code))
        ;; redefining same name, new type --> replace it!
        (format t "def-kr-type redefining ~S from ~S to ~S~%"
                typename (code-to-type code) type-body))

      ;; defining a new name, establish new code
      (progn
        (setq code (or (gethash type-body types-table)
		       (get-next-type-code)))
        (setf (gethash typename types-table) code)))

    (unless (gethash type-body types-table)
      (setf (gethash type-body types-table) code))
    (setf (svref types-array code)
	  (if typename
	    (if (stringp typename)
	      (intern typename (find-package "KR"))
	      typename)
	    type-body))
    (setf (svref type-docs-array code) (or type-doc NIL))
    (setf (svref type-fns-array  code)
	  (if (and (symbolp type-fn)  ;; koz
		   (fboundp type-fn))
	      (symbol-function type-fn)
 	      type-fn))
    code))



(defun kr-type-error (type)
 (error "Type ~S not defined; use~%     (def-kr-type ... () '~S)~%" type type))



;;; Given a LISP type, returns its encoding.
;;;
(defun encode-type (type)
  (cond ((gethash type types-table)) ;; if there, just return it!
	((and (listp type) (eq (car type) 'SATISFIES))
	 ;; add new satisfies type
	   (add-new-type NIL type (type-to-fn type)))
	((symbolp type)
	   (or (gethash (symbol-name type) types-table)
	       (let ((predicate (find-lisp-predicate type)))
		  (if predicate
	            (add-new-type NIL type predicate)))
	       (kr-type-error type)))
	(T (kr-type-error type))))



;;; Add a human-readable description to a Lisp type.
;;;
(defun set-type-documentation (type string)
   (setf (aref type-docs-array (encode-type type)) string))


;;; RETURNS: the documentation string for the internal number <type>.
;;;
(defun get-type-documentation (type)
  (aref type-docs-array (encode-type type)))




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



;;; 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*))
  (let ((entry (slot-accessor *schema-self* *schema-slot*)))
    (if entry
      (setf (sl-bits entry)
	    (logior *constant-mask* (sl-bits entry))))))


(defparameter *warning-level* 0)


(defun slot-is-constant (schema slot)
  (let ((entry (slot-accessor schema slot)))
    (is-constant (sl-bits entry))))



;;; Helper function
;;; 
(defun re-evaluate-formula (*schema-self* *schema-slot* *current-formula*
					  entry
					  #+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*
			      (if (or entry
				      (setf entry (slot-accessor
						   *schema-self*
						   *schema-slot*)))
				(is-constant (sl-bits entry))))))
    (if declared-constant		; save work, since we know the answer
      (setf *check-constants* nil))
    (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*))))
	       (if (and *types-enabled*
			(multiple-value-bind (value result)
			    (check-slot-type *schema-self* *schema-slot* new-v
					     T entry)
			  (cond ((eq result :REPLACE)
				 (setf new-v value)
				 NIL)
				((eq result T) T)
				(T NIL))))
		 ;; A type error
		 (setf new-v NIL)
		 ;; OK
		 (if (not (eq new-v (cached-value *current-formula*)))
		   ;; Do nothing if value has not changed.
		   (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 :FORMULA-EVALUATION)
		     #+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 entry)
  (if (cache-is-valid formula)
    (a-formula-cached-value formula)
    (progn
      (unless *within-g-value*
	;; 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 entry)))))



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


;;; Forces the <value> to be physically copied to the <a-slot> of all
;;; instances of the <schema>, even though local values were defined.
;;; However, if there was a local formula, do nothing.
;;;
(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
		      (let ((entry (slot-accessor schema :IS-A-INV)))
			(if entry (sl-value entry)))
		      (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 entry)
  (let ((old-value (sl-value entry)))
    (unless (eq old-value *no-value*)
      (let ((child-bits (sl-bits entry)))
	(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.
	  ;; Force the children to re-inherit.
	  (if (formula-p old-value)
	    (delete-formula old-value T))
	  (clear-one-slot child a-slot entry)
	  ;; Recursively change children.
	  (update-inherited-values child a-slot *no-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 :INHERITANCE-PROPAGATION)
      (run-invalidate-demons schema a-slot NIL)
      (propagate-change schema a-slot))
    (dolist (inverse *inheritance-inverse-relations*)
      (let ((children (if (eq inverse :IS-A-INV) ; for efficiency
			(let ((entry (slot-accessor schema :IS-A-INV)))
			  (if entry (sl-value entry)))
			(get-local-value schema inverse))))
	(if (not (eq children *no-value*))
	  (dolist (child children)
	    (let ((entry (slot-accessor child a-slot)))
	      (when entry
		;; If child had no value, no need to propagate down
		(setf is-first NIL)
		; force new inheritance
		(update-inherited-internal child a-slot entry)))))))))



;;;; 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."
  (let ((entry (slot-accessor schema slot)))
    (run-invalidate-demons schema slot entry)
    (if entry
	(if (is-parent (sl-bits entry))
	    (update-inherited-values schema slot (sl-value entry) T))))
  (propagate-change 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)
  (let* ((entry (slot-accessor schema slot))
	 (formula (if entry (sl-value entry))))      
    (if (formula-p formula)
      (let ((bits (sl-bits entry)))
	(unless *within-g-value*
	  (incf *sweep-mark* 2))
	(re-evaluate-formula schema slot formula entry #+EAGER *eval-type*)
	(run-invalidate-demons schema slot entry)
	(if (is-parent bits)
	  (update-inherited-values schema slot formula T))
	#-EAGER
	(propagate-change schema slot)
	#+EAGER
	(propagate)))))



;;; 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)
  (let ((entry (slot-accessor schema slot)))
    ;; access the dependent formulas.
    (do-one-or-list (formula (slot-dependents entry) T)
      ;; Stop propagating if this dependent formula was already marked dirty.
      (if (and (not-deleted-p formula) (cache-is-valid formula))
	(let* ((new-schema (on-schema formula))
	       (new-slot (on-slot formula))
	       (schema-ok (schema-p new-schema))
	       (new-entry  NIL))
	  (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
	    (progn
	      (setf new-entry (slot-accessor new-schema new-slot))
	      (run-invalidate-demons new-schema new-slot new-entry))
	    #+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 (and schema-ok new-entry)
	    (if (slot-dependents new-entry)
	      (propagate-change new-schema new-slot))))))))
#|
(defun propagate-change (schema slot)
  (let ((entry (slot-accessor schema slot)))
    ;; access the dependent formulas.
    (do-one-or-list (formula (slot-dependents entry) T)
      ;; Stop propagating if this dependent formula was already marked dirty.
      (if (and (not-deleted-p formula) (cache-is-valid formula))
	(let* ((new-schema (on-schema formula))
	       (new-slot (on-slot formula))
	       (schema-ok (schema-p new-schema))
	       (new-entry  NIL))
	  (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
	    (progn
	      (setf new-entry (slot-accessor new-schema new-slot))
	      (run-invalidate-demons new-schema new-slot new-entry))
	    #+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 (and schema-ok new-entry)
	    (let ((new-value (sl-value new-entry))
		  (new-bits  (sl-bits new-entry))
		  (dependents (slot-dependents new-entry)))
	      (if (and (is-parent new-bits)
		       entry
		       (not (eq (sl-value entry) *no-value*))
		       ;; Notify only if the VALUE of the formula was
		       ;; inherited, not if the formula itself was!
		       (not (eq (sl-value new-entry) formula)))
		(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)))))))))
|#




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



;;; 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* ((entry (slot-accessor schema a-slot))
	 (parent-entry (if entry (sl-value entry))))
    (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)))
	(let* ((entry (slot-accessor child a-slot))
	       (value (if entry (sl-value entry))))
	  (when (and value
		     (is-inherited (sl-bits entry))
		     (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 entry)
  (run-invalidate-demons schema slot entry)
  ;; 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)
	 ;; 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 entry
	     ;; This is a special slot - just set it
	     (setf (sl-value entry) new-value
		   (sl-bits entry) new-bits)
	     ;; This is not a special slot.
	     (set-slot-accessor schema slot new-value new-bits nil)))))
  ;; 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))))



(defun constant-slot-error (schema slot)
  (cerror "Set the slot anyway"
	  "Schema ~S - trying to set slot ~S, which is constant."
	  schema slot))



;;; Signals an error if the <slot> of the <schema> is not constant.
;;;
(defmacro check-not-constant (schema slot entry)
  (let ((entry-sym (gensym)))
  `(let ((,entry-sym ,entry))
    (and (not *constants-disabled*)
     ,entry-sym
     (is-constant (sl-bits ,entry-sym))
     (constant-slot-error ,schema ,slot)))))



;;; SLOT-CONSTANT-P
;;; RETURN: T if the <slot> in the <schema> is constant, nil otherwise
;;;
(defun slot-constant-p (schema slot)
  (let ((entry (slot-accessor schema slot)))
    (if entry
      (is-constant (sl-bits entry)))))



;;; 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))
  formula)



;;; Does all the work of the macro S-VALUE.
;;;
(defun s-value-fn (schema slot value)
  (unless (schema-p schema)
    #+GARNET-DEBUG
    (if schema
      (error "S-VALUE called with the non-object  ~S  (slot ~S, value ~S)."
	     schema slot value)
      (error "S-VALUE called with a null schema:  (slot ~S, value ~S)."
	     slot value))
    (return-from s-value-fn value))
  (let* ((entry (slot-accessor schema slot))
	 (old-value (if entry
		      ;; Slot position is known at compile time
		      (sl-value entry)))
	 the-bits is-depended)
    ;; give error if setting constant slot
    (check-not-constant schema slot entry)

    (if entry
      (setf the-bits (sl-bits entry)
	    is-depended (slot-dependents entry))
      (setf the-bits 0))

    (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))

    (if *types-enabled*
      (if (not (formula-p value))
	(multiple-value-bind (result error-p)
	    (check-slot-type schema slot value T entry)
	  (cond ((not error-p)
		 ;; Everything is OK
		 )
		((eq error-p T)
		 ;; A type error - user wants to do nothing
		 (return-from s-value-fn NIL))
		(T
		 ;; A type error - user supplied new value
		 (setf value result))))))

    (let ((is-formula nil) (is-relation nil)
	  (was-formula (formula-p old-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 :S-VALUE))

      ;; Now we can set the new value.
      (setf the-bits (logand the-bits *not-inherited-mask*))
      (run-invalidate-demons schema slot entry)
      ;; Now set the value in the slot to be <value>.
      (cond
        ((and was-formula (not is-formula))
	 (if (zerop (a-formula-number old-value))
	   (format t "*** Warning: you are setting the value of slot ~S of
 object ~S.  This slot contains a formula which was never evaluated.
 The formula is now valid, but its dependencies are not set up properly.  As
 a result, the formula will never be evaluated.
 In order for this formula to work properly, you should have used
 (g-value ~S ~S) before using S-VALUE.  If you want to fix things now,
 re-install the formula using s-value.~%"
		   slot schema schema slot))
	 ;; This is the case when we allow temporary overwriting
	 (setf (cached-value old-value) value)
	 ;; 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 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 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 value))
	 (let ((new-bits (or the-bits *local-mask*)))
	   (if entry
	     ;; This is a special slot - just set it
	     (setf (sl-value entry) value
		   (sl-bits entry) new-bits)
	     ;; This is not a special slot.
	     (setf entry (set-slot-accessor schema
					    slot value new-bits nil))))))
      ;; 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 value T)))
      
      ;; Notify all dependents that the value changed.
      (if is-depended
	(let ((*warning-on-disconnected-formula* nil))
	  (propagate-change schema slot)))
      (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 T))

      (if 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 ((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))

    (set-slot-accessor schema slot value *local-mask* nil)

    ;; Take care of relations.
    (if is-relation
      (link-in-relation schema slot value))
    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
  (set-slot-accessor schema :IS-A value *local-mask* NIL)
  (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)
		(deleted-p schema))	; schema is destroyed
      (iterate-slot-value (schema T T T)
	slot value				; suppress warning
	(let ((formulas (slot-dependents iterate-slot-value-entry)))
	  (if (listp formulas)
	    ;; Several dependents
	    (if (memberq formula formulas)
	      (setf (full-sl-dependents iterate-slot-value-entry)
		    (delete formula formulas)))
	    ;; One dependent
	    (if (eq formula formulas)
	      (setf (full-sl-dependents iterate-slot-value-entry) 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 remove-from-parent)
  (when (a-formula-number formula)
    (eliminate-formula-dependencies formula NIL)
    (if remove-from-parent
      ;; Eliminate the <formula> from its parent's list of children.
      (let ((parent (a-formula-is-a formula)))
	(if parent
	  (delete-one-or-list formula (a-formula-is-a-inv parent)))))
    ;; Formula was not destroyed yet
    (setf (a-formula-bins formula) nil) ; mark as destroyed.
    (setf (a-formula-schema formula) nil)
    (setf (a-formula-slot formula) nil)
    (setf (a-formula-lambda formula) nil)
    (setf (a-formula-depends-on formula) nil)
    (let ((meta (a-formula-meta formula)))
      (when meta
	(setf (a-formula-meta formula) NIL)
	(destroy-schema meta)))
    (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.
  (clear-one-slot x slot NIL))


(defparameter *in-destroy-slot* 0)
(defparameter *invalid-destroy-slot* 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.
  (let ((entry (slot-accessor schema slot))
	old-value)
    (when entry
      (setf old-value (sl-value entry))
      (check-not-constant schema slot entry)
      (let ((bits (sl-bits entry))
	    (dependents (slot-dependents entry))
	    new-value)
	(run-invalidate-demons schema slot entry)
	(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))
	    (incf *in-destroy-slot*)
	    (unless (cache-is-valid formula)
	      (incf *invalid-destroy-slot*))
	    ;; If this value is depended on by others, replace their value
	    ;; by the current value.
	    (let ((the-schema (on-schema formula))
		  (the-slot (on-slot formula)))
	      (if (and the-schema
		       (schema-name the-schema)	; not destroyed
		       (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 T))

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

	(setf new-value (g-value-inherit-values schema slot T entry))
	;; 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 :DESTROY-SLOT)

	#+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.
      (clear-one-slot schema slot NIL)
      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 (not-deleted-p 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-slot-value (schema NIL NIL NIL)
	      value			;; eliminate warning
	      (if (relation-p slot)
		(unlink-all-values schema slot))))
	  (iterate-slot-value (schema NIL NIL NIL)
	    slot value			; eliminate warning
	    ;; Delete any formula value.
	    (when (formula-p value)
	      ;; This is a formula.  Get rid of it.
	      (delete-formula value (not recursive-p))
	      (delete-schema value recursive-p)))
	  ;; Physically delete all the slots
	  (clear-schema-slots schema)))
    ;; Now wipe out the symbol value as well.
    (if (symbolp (schema-name schema))
	(makunbound (schema-name schema)))
    ;; This is used as a marker for deleted schemas.
    (setf (schema-bins 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*)
	;; Look at all formulas which depend on this slot.
	(do-one-or-list (formula (slot-dependents iterate-slot-value-entry))
	  (unless (or (null formula)	; defensive programming
		      (memberq 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 (not recursive-p))))))
	;; 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 T))))
    (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 (or (formula-p schema)		; safety check
	      (deleted-p schema))
    (let* ((entry (slot-accessor schema :IS-A-INV))
	   (children (if entry (sl-value entry))))
      (if (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 (zerop level)
     ;; if this is a top-level schema which has no prototype, use an
     ;; indiscriminate destroy.
     (null (slot-accessor schema :is-a))
     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 (sl-bits iterate-slot-value-entry))
	  (destroy-slot schema slot))))))



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


;;; 
(defun print-one-value (value type)
  (let ((string (cond ((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))))
		      ((eq value *no-value*)
		       "")
		      (t
		       (format nil "~S" value)))))
    (if type
      (setf string (concatenate 'simple-string string
				(format nil "  ~([~S]~)" type))))
    (write-string string)
    (length string)))



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



;;; Print the meta-information associated with a formula.
;;;
(defun print-meta (formula)
  (let ((meta (a-formula-meta formula)))
    (when (and meta (schema-p meta))
      (format t "  ---- meta information (~A):~%" meta)
      (call-on-ps-slots meta 'SLOT-PRINTER))))


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



(defun force-down-helper (schema original-slots slots)
  (iterate-slot-value (schema T T NIL)
    value				;; eliminate warning
    (unless (memberq 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-slot-value (schema T NIL NIL)
      value				;; eliminate warning
      (push slot original-slots))
    (dolist (slot (force-down-helper schema original-slots nil))
      (get-value schema slot))))



;;; Helper function for the following.
;;; The <function> is called with:
;;; (schema slot formula inherited valid real-value types-p indent limits)
;;;
(defun call-func-on-one-slot (schema slot inherited-ok function
				     types-p indent limits)
  (let* ((entry (slot-accessor schema slot))
	 (values (if entry (sl-value entry)))
	 (bits (if entry (sl-bits entry)))
	 form valid real-value)
    (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)
	  (unless (eq values *no-value*)
	    (if (formula-p values)
	      (let ((cached (cached-value values))
		    (is-valid (cache-is-valid values)))
		(setq form values)
		(setq valid is-valid)
		(setq real-value cached))
	      ;; else not a formula
	      (setq real-value values))
	    (funcall function
		     schema slot form are-inherited valid real-value
		     types-p bits indent limits)))
	;; Indicate that the function was called.
	T))))



;;; Apply the <function> to slots, the way PS would.
;;;
(defun call-on-ps-slots (schema function &key (control t) inherit (indent NIL)
				types-p all-p)  
  (declare (special print-schema-control))
  (let ((is-ps (eq function 'SLOT-PRINTER)));; true if inside PS
    (if (null indent)
      (setf indent 0))
    (if (numberp schema)
      (setf schema (s schema)))
    (unless (or (schema-p schema) (formula-p schema))
      (if is-ps
	(format t "~S~%" schema))
      (return-from call-on-ps-slots nil))
    (if is-ps
      (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))))
      (if is-ps
	(format t "{~S~%" schema))
      ;; Print out all the sorted slots, first.
      (dolist (o sorted)
	(call-func-on-one-slot schema o inherit function types-p indent
	 (or (second (assocq o limit-values)) global-limit)))
      ;; Now print the remaining slots.
      (unless (listp slots-ignored)
	(setf slots-ignored (list slots-ignored)))
      ;; Pre-inherit all slots that are inheritable.
      (unless (a-formula-p schema)
	(if inherit
	  (force-down-all-inheritance schema))
	(if all-p
	  (iterate-slot-value (schema T T NIL)
	    (unless (or (memberq slot slots-ignored) (memberq slot sorted)
			(eq value *no-value*))
	      (call-func-on-one-slot
	       schema slot inherit function types-p indent
	       (or (second (assocq slot limit-values)) global-limit))))
	  (iterate-slot-value (schema T NIL NIL)
	    (unless (or (memberq slot slots-ignored) (memberq slot sorted)
			(eq value *no-value*))
	      (call-func-on-one-slot
	       schema slot inherit function types-p indent
	       (or (second (assocq slot limit-values)) global-limit))))))
      (when (and slots-ignored is-ps)
	(indent-by indent)
	(format t "  List of ignored slots:  ~{ ~A~}~%" slots-ignored))
      ;; special formula slots?
      (when (a-formula-p schema)
	(if is-ps
	  (progn
	    (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))
	  (dolist (name '(:lambda :cached-value-valid :cached-value
			   :schema :slot))
	    (funcall function schema name nil nil T ; valid
		     (g-formula-value schema name) nil 0 indent nil)))))
    (if is-ps
      (format t "  }~%"))))



;;; Similar to CALL-ON-PS-SLOTS, but works on one slot only.
;;;
(defun call-on-one-slot (schema slot function)
  (call-func-on-one-slot schema slot T function NIL 0 NIL))




;;; Used by PS to print out one slot.
;;;
(defun slot-printer (schema name formula are-inherited valid values
			    type-p bits indent limit-values)
  (declare (ignore schema))
  (let ((number 0)
	(printed nil)
	(column (+ 20 (indent-by indent)))
	(*print-length* 10)		; do not print out very long arrays!
	type)
    (if are-inherited
      (format t "  ~(~S~) (inherited): " name)
      (format t "  ~S = " name))
    (if type-p
      (setf type (code-to-type (extract-type-code bits))))
    (if formula
      (format t "~S(" formula))
    (cond ((eq values *no-value*)
	   (if type-p
	     (setf column (print-one-slot-helper ; print types
			   *no-value* column indent T type)))
	   (setf printed T))
	  ((and values (listp values) (listp (cdr values)))
	   (format t "(")
	   (dolist (value values)
	     (setf printed t)
	     (setf column (print-one-slot-helper value column indent
						 (> number 0) nil))
	     (incf number)
	     (when (and limit-values (> number limit-values))
	       ;; Too many values: use ellipsis form.
	       (format t " ...")
	       (return nil)))
	   (format t ")")
	   (if formula
	     (format t " . ~S)" valid))
	   (if type
	     (print-one-slot-helper	; print out type
	      *no-value* column indent nil type)))
	  ((null values)
	   (if formula
	     (format t "nil . ~S)" valid)
	     (format t " NIL"))
	   (setf printed T)
	   (if type
	     (print-one-slot-helper	; print out type
	      *no-value* column indent nil type)))
	  (t
	   (setf printed t)
	   (setf column
		 (print-one-slot-helper values column indent (not formula) type))
	   (if formula
	     (format t " . ~S)" valid))))
    (if printed
      (terpri)
      (format t " NIL~%"))))



;;;; 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) types-p all-p
		  (stream *standard-output*))
  "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."
  
  (let ((*standard-output* stream))
    (call-on-ps-slots schema 'SLOT-PRINTER
		      :control control :inherit inherit :indent indent
		      :types-p types-p :all-p all-p)
    (if (formula-p schema)
      (print-meta schema)))
  schema)



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


(defun the-bits (bits)
  (if (integerp bits)
    ;; The normal case
    (let ((type (extract-type-code bits)))
      (format t "~:[-~;p~]~:[-~;l~]~:[-~;C~]~:[-~;P~]~:[-~;u~]~:[-~;i~] "
	      (is-parameter bits) (is-local-only bits)
	      (is-constant bits) (is-parent bits)
	      (is-update-slot bits) (is-inherited bits))
      (unless (zerop type)
	(format t "[~(~S~)]   " (code-to-type type))))
    ;; A special case for formula slots which are stored in a special way
    (format t "---- ")))



;;; Helper function for FULL.
;;;
(defun full-normal-slot (schema slot)
  (format t "~(~24S~) " slot)
  (let* ((entry (slot-accessor schema slot))
	 (values (if entry (sl-value entry)))
	 (bits (if entry (sl-bits entry)))
	 (dependents (slot-dependents entry)))
    (the-bits bits)
    (if entry
      ;; Slot is there
      (let ((first t))
	(if (eq values *no-value*)
	  (setf values NIL))
	(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 NIL))
	    (format t ")"))
	  (progn
	    (write-string " ")
	    (print-one-value values NIL)))
	;; Show dependent formulas, if any
	(when dependents
	  (format t "   ****--> ")
	  (do-one-or-list (f dependents)
	    (format t " ~s" f)))
	(terpri))
      ;; No slot???
      (terpri)))
  (values))



;;; 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 iterators 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)))
	  (print-meta schema))
	;; This is a normal slot
	(progn
	  (format
	   t "---------------------------------------------- schema ~S~%"
	   schema)
	  (iterate-slot-value (schema T T nil)
	    value			;; eliminate warning
	    (full-normal-slot schema slot))))))
  (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)
	    (*kr-send-parent* NIL)
	    (*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)
            (*kr-send-parent* NIL)
	    #+COMMENT (*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)
	      (*kr-send-parent* NIL))
	  (apply function- args))))))



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



(defparameter *min-size* 0
  "Initial size for a new array of slots")



;;; Find a resource (a slots array, or a directory array) from the
;;; garbage heap, which is kept in the <array>.  The resource must have
;;; at least <how-many> entries.
;;; RETURNS: the resource, or NIL if none can be found.
;;;
(defun find-unused-resource (array how-many)
  (dotimes (i (length array))
    (let* ((slots (aref array i))
	   (current-length (array-dimension slots 0)))
      (when (>= current-length how-many)
	(if (/= current-length how-many)
	  (adjust-array slots how-many))
	(let ((l (1- (length array))))
	  (if (> l i)
	    ;; Move in the last element of the array.
	    (rotatef (aref array i) (aref array l)))
	  ;; Array contains one fewer element.
	  (decf (fill-pointer array)))
	(return slots)))))



(defun allocate-schema-slots (schema)
  (setf (schema-bins schema)
	(or (find-unused-resource *reuse-slots* *bins-length*)
	    (make-array *bins-length* :initial-element NIL)))
  schema)



;;; Creates a schema with the given <name>, making sure to destroy the old
;;; one by that name if it exists.  The initial number of slots is
;;; <needed-slots>.
;;; 
(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 constant.
;;;
(defun process-one-constant (schema slot)
  ;; set slot information
  (let ((entry (slot-accessor schema slot)))
    (if (null entry)
      ;; Slot is not present - create it, mark constant.
      (set-slot-accessor schema slot *no-value* *constant-mask* nil)
      ;; Slot is present
      (setf (sl-bits entry) (logior *constant-mask* (sl-bits entry))))))



;;;; 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))))))))



;;; Process declarations such as ":declare (:parameters T :except :width)",
;;; which modify the prototype's specification of a declaration by adding or
;;; removing new slot names.
;;;
(defun merge-prototype-values (object slot parents values)
  (unless values
    (setf values (if parents (g-value (car parents) slot))))
  (let ((exceptions nil)
	(add-prototype nil)
	(results nil))
    ;; process declarations
    (when (and values (not (eq values :NONE)))
      (if (listp values)
	(progn
	  (if (eq (car values) 'QUOTE)
	    (format
	     t "The ~S list for schema ~S is specified incorrectly - too many quotes:~%   ~S~%" slot object values))
	  ;; Normal case - a list
	  (do ((c values (cdr c)))
	      ((null c))
	    (cond ((eq (car c) T)
		   (setf add-prototype T))
		  ((eq (car c) :EXCEPT) ; following is list of exceptions.
		   (setf exceptions (cdr c))
		   (return))
		  (t
		   (if (eq slot :CONSTANT)
		     (process-one-constant object (car c))
		     (pushnew (car c) results))))))
	;; For the case (:CONSTANT T), for example - single value
	(if (eq values T)
	  (setf add-prototype T)
	  (if (eq slot :CONSTANT)
	    (process-one-constant object values)
	    (setf results (list values)))))
      (if add-prototype			; Add slots declared in prototype
	(let ((maybe-constant
	       (if (eq slot :CONSTANT)
		 (g-value-no-copy object :MAYBE-CONSTANT)
		 (g-value (car parents) slot))))
	  (do-one-or-list (c maybe-constant)
	    (unless (memberq c exceptions)
	      (if (eq slot :CONSTANT)
		(process-one-constant object c)
		(pushnew c results))))))
      (unless (eq slot :CONSTANT)
	(setf results (nreverse results))
	(unless (equal results values)
	  (s-value object slot results))))))



;;; Process local-only and constant declarations.
;;; 
(defun process-constant-slots (the-schema parents constants do-types)
  ;; Install all update-slots entries, and set their is-update-slot bits
  (dolist (slot (g-value-no-copy the-schema :UPDATE-SLOTS))
    (let ((entry (slot-accessor the-schema slot)))
      (if entry
          (setf (sl-bits entry) (set-is-update-slot (sl-bits entry)))
          (set-slot-accessor the-schema slot *no-value*
                             (set-is-update-slot *local-mask*)
                             NIL))))
  ;; Mark the local-only slots.
  (dolist (parent parents)
    (dolist (local (g-value-no-copy parent :LOCAL-ONLY-SLOTS))
      (unless (listp local)
	(cerror "Ignore the declaration"
		"create-instance (object ~S, parent ~S):  :local-only-slots
 declarations should consist of lists of the form (:slot T-or-NIL).  Found
 the expression ~S instead."
		the-schema parent local)
	(return))
      ;; Set the slots marked as local-only
      (let ((slot (car local)))
	(if (null (slot-accessor the-schema slot))
	  (if (second local)
	    ;; Copy down the parent value, once and for all.
	    (let* ((entry (slot-accessor parent slot))
		   (value (if entry (sl-value entry))))
	      (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*
    (merge-prototype-values the-schema :CONSTANT parents constants))
  ;; Now process type declarations
  (when (and do-types *types-enabled*)
    ;; Copy type declarations down from the parent(s), unless overridden
    ;; locally.
    (dolist (parent parents)
      (iterate-slot-value (parent T T nil)
	value				;; suppress warning
	(let ((bits (sl-bits iterate-slot-value-entry))) ; get parent's bits
	  ;; keep only the type information
	  (setf bits (logand bits *type-mask*))
	  (unless (zerop bits)
	    (let ((the-entry (slot-accessor the-schema slot)))
	      (if the-entry
		(let ((schema-bits (sl-bits the-entry)))
		  (if (zerop (extract-type-code schema-bits))
		    ;; Leave type alone, if one was declared locally.
		    (setf (sl-bits the-entry)
			  (logior (logand schema-bits *all-bits-mask*)
				  bits))))
		(set-slot-accessor the-schema slot *no-value* bits NIL)))))))
    ;; Typecheck
    (iterate-slot-value (the-schema T T nil)
      (unless (eq value *no-value*)
	(if (not (formula-p value))	; don't bother with formulas.
	  (multiple-value-bind (new-value result)
	      (check-slot-type the-schema slot value)
	    (if (eq result :REPLACE)
	      (s-value the-schema slot new-value))))))))




;;; Turn the <slot> of the <schema> into an :update-slot; add the <slot> to
;;; the contents of :update-slots, and turn on the internal bit.  If
;;; <turn-off> is T, make the <slot> be no longer an update slot.
;;;
(defun add-update-slot (schema slot &optional turn-off)
  (let ((entry (slot-accessor schema slot)))
    (if entry
      ;; There is an entry - manipulate the bits directly
      (if turn-off
	;; Turn bit off
	(setf (sl-bits entry) (logand (sl-bits entry)
				      (lognot *is-update-slot-mask*)))
	;; Turn bit on
	(setf (sl-bits entry) (set-is-update-slot (sl-bits entry))))
      ;; There is no entry
      (unless turn-off
	(set-slot-accessor schema slot *no-value*
			   (set-is-update-slot *local-mask*)
			   NIL))))
  (if turn-off
    (setf (g-value schema :UPDATE-SLOTS)
	  (delete slot (g-value schema :UPDATE-SLOTS)))
    (pushnew slot (g-value schema :UPDATE-SLOTS))))




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



(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)))



(defun merge-declarations (declaration keyword output)
  (let ((old (find keyword output :key #'second)))
    (if old
      (setf (cadr (third old)) (union (cdr declaration)
				      (cadr (third old))))
      (push `(cons ,keyword ',(cdr declaration)) output)))
  output)



;;; This function processes all the parameters of CREATE-INSTANCE and returns
;;; an argument list suitable for do-schema-body.  It is called at compile
;;; time.
;;; RETURNS: a list, with elements as follows:
;;; - FIRST: the prototype (or list of prototypes), or NIL;
;;; - SECOND: the list of type declarations, in the form (type slot slot ...)
;;;   or NIL (if there were no type declarations) or :NONE (if the declaration
;;;   (type) was used, which explicitly turns off all types declared in the
;;;   prototype(s).
;;; - REST OF THE LIST: all slot specifiers, with :IS-A removed (because that
;;;   information is moved to the prototype list).
;;;
(eval-when (eval compile load)
  (defun process-slots (slots)
    (let ((output nil)
	  (is-a nil))
      (do ((head slots (cdr head))
	   (types nil)
	   (had-types nil)		; true if there is a declaration
	   slot)
	  ((null head)
	   (if types
	     (push `(quote ,types) output)
	     (if had-types
	       (push :NONE output)
	       (push NIL output))))
	(setf slot (car head))
	(cond ((null slot)
	       ;; This is an error.
	       (cerror
		"Ignore the specification"
		"Error in CREATE-SCHEMA: NIL is not a valid slot ~
		 specifier; ignored.~%~
	         Object ~S, slot specifiers are ~S~%"
		kr::*create-schema-schema* head))
	      ((keywordp slot)
	       ;; Process declarations and the like.
	       (case slot
		 (:NAME-PREFIX
		  (pop head))
		 (:DECLARE
		  (pop head)
		  (dolist (declaration (if (listp (caar head))
					 (car head)
					 (list (car head))))
		    (case (car declaration)
		      (:TYPE
		       (setf had-types T)
		       (dolist (spec (cdr declaration))
			 (push spec types)))
		      ((:CONSTANT :IGNORED-SLOTS :LOCAL-ONLY-SLOTS
				  :MAYBE-CONSTANT :PARAMETERS :OUTPUT
				  :SORTED-SLOTS :UPDATE-SLOTS)
		       (setf output (merge-declarations declaration
							(car declaration)
							output)))
		      (t
		       (cerror
			"Ignore the declaration"
			"Unknown declaration (~S) in object creation:~%~S~%"
			(car declaration)
			declaration)))))))
	      ((listp slot)
	       ;; Process slot descriptors.
	       (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))))
	      (T
	       (cerror
		"Ignore the specification"
		"A slot specification should be of the form ~
		 (:name [values]*) ;~%found ~S instead.  Object ~S, slots ~S."
		slot kr::*create-schema-schema* slots))))
      (cons is-a output))))



(defun handle-is-a (schema is-a generate-instance override)
  (if (or (eq schema is-a)
	  (memberq 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))))



;;;; Create-schema and friends expand into a call to this function.
;;;
(defun do-schema-body (schema is-a generate-instance do-constants override
			      types &rest slot-specifiers)
  (if (not (listp is-a))
    (setf is-a (list is-a)))
  (if is-a
    (let ((*schema-is-new* T))		; Bind to prevent search on insertion
					; of :is-a-inv in parent schemata.
      ;; Check for immediate is-a loop, and set the :IS-A slot.
      (handle-is-a schema is-a generate-instance override)))

  (do* ((slots slot-specifiers (cdr slots))
	(slot (car slots) (car slots))
	(initialize-method NIL)
	(constants NIL)
	(had-constants NIL)		; true if declared, including NIL
	(cancel-constants (find '(:constant) slot-specifiers :test #'equal))
	(parent (car is-a))
	(slot-counter (if is-a 1 0)))

       ((null slots)
	;; Process the type declarations.
	(unless (eq types :NONE)
	  (dolist (type types)
	    (if (cdr type)
	      (let ((n (encode-type (car type))))
		(dolist (slot (cdr type))
		  (set-slot-type schema slot n)))
	      (format t "*** ERROR - empty list of slots in type declaration for object ~S:~%  ~S~%" schema (car type)))))
	;; Process the constant declarations, and check the types.
	(when do-constants
	  (process-constant-slots
	   schema is-a
	   (if had-constants
	     ;; There WAS a constant declaration, perhaps NIL.
	     (if constants
	       (if (formula-p constants)
		 (g-value-formula-value schema :CONSTANT constants NIL)
		 constants)
	       :NONE)
	     ;; There was no constant declaration.
	     NIL)
	   (not (eq types :NONE))))
	;; Merge prototype and local declarations.
	(dolist (slot slot-specifiers)
	  (if (and (listp slot)
		   (memberq (car slot) '(:IGNORED-SLOTS :LOCAL-ONLY-SLOTS
					:MAYBE-CONSTANT :PARAMETERS :OUTPUT
					:SORTED-SLOTS :UPDATE-SLOTS)))
	    (merge-prototype-values schema (car slot) is-a (cdr slot))))
	(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)))
	     (case slot-name		; handle a few special slots.
	       (:INITIALIZE
		(if slot-value
		  ;; A local :INITIALIZE method was provided
		  (setf initialize-method slot-value)))
	       (:CONSTANT
		(setf constants (cdr slot))
		(setf had-constants T)))
	     ;; Check that the slot is not declared constant in the parent.
	     (if (and (not cancel-constants) (not *constants-disabled*)
		      (not *redefine-ok*))
	       (if (and parent (slot-constant-p parent slot-name))
		 (cerror
		  "If continued, the value of the slot will change anyway"
		  "Slot ~S in ~S was declared constant in prototype ~S!~%"
		  slot-name schema (car is-a))))
	     (if override
	       ;; This is more costly - check whether the slot already exists,
	       ;; dependencies, etc.
	       (s-value schema slot-name slot-value)
	       ;; No check needed in this case.
	       (setf slot-counter
		     (internal-s-value schema slot-name slot-value)))))
	  (T
	   (format t "Incorrect slot specification: object ~S ~S~%"
		   schema slot)))))



(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))))))


;;; Processes the second half of a create-instance.  Begin-create-instance must
;;; have been called on the <schema>.
;;;
(defun end-create-instance (schema)
  (process-constant-slots schema (get-local-value schema :IS-A)
			  (get-local-value schema :CONSTANT)
			  nil)
  (kr-init-method schema (get-local-value schema :INITIALIZE)))



;;; -------------------------------------------------- TYPE CHECKING


(defmacro get-slot-type-code (object slot)
  (let ((entry (gensym)))
    `(let ((,entry (slot-accessor ,object ,slot)))
      (and ,entry
       (get-entry-type-code ,entry)))))



;;;; G-TYPE
;;;
(defun g-type (object slot)
  (let ((type (get-slot-type-code object slot)))
    (if type
      (code-to-type type))))



;;;; CHECK-SLOT-TYPE
;;; Check whether <value> has the right type for the <slot> in the <object>.
;;;
;;; RETURNS:
;;; if error-p is non-nil: multiple values:
;;; - a replacement value, if the user chose to continue and supply a
;;;   replacement;  T if no error;  NIL otherwise;
;;; - T (if type error and the user did not supply a value), or
;;;   NIL (if there was no type error), or
;;;   :REPLACE, if a replacement value was supplied by the user.
;;; if error-p is nil:
;;; an error string describing what error condition was found.
;;;
(defun check-slot-type (object slot value &optional (error-p T) entry)
  (let ((type-code (if entry
			(get-entry-type-code entry)
			(get-slot-type-code object slot))))
    (or (null type-code)
        (zerop type-code)
	(check-kr-type value type-code)
	(let* ((type (code-to-type type-code))
	       (readable-type (get-type-documentation type))
	       (message
		  (format
		   nil
		   "bad KR type: value ~S~:[~*~;, a ~S,~] is not valid for slot ~S in~%  object ~S.  The slot is declared of type ~S~@[,~%  i.e., ~A~].~@[~%  The value was computed by a formula.~]~%"
		   value value (type-of value)
		   slot object type
		   readable-type
		   (formula-p (get-local-value object slot)))))
	     (if error-p
	       (progn
		(cerror "Retain old value in the slot" message)
		(values T T))
	      message)))))


#|
;;; This version allows multiple restart actions.  However, it is extremely
;;; slow and sets up a ton of garbage (Cons space and Other space).  It should
;;; not be used for common operations, such as s-value.
;;;
(defun check-slot-type (object slot value &optional (error-p T))
  (loop
   (restart-case
    (return
      (let ((type (get-slot-type-code object slot)))
	(if type
	  (if (zerop type)
	    (values T NIL)		; no type specified
	    (if (check-kr-type value type)
	      (values T NIL)
	      (let* ((readable-type (get-type-documentation type))
		     (message
		      (format
		       nil
		       "bad KR type: value ~S~:[~*~;, a ~S,~] is not valid for slot ~S in~%  object ~S.  The slot is declared of type ~S~@[,~%  i.e., ~A~].~@[~%  The value was computed by a formula.~]~%"
		       value value (type-of value) slot object
		       (code-to-type type)
		       readable-type
		       (formula-p (get-value object slot)))))
		(if error-p
		  (error message)
		  message))))
	  (values T NIL))))
    ;; Allow the user to specify different continuation strategies if we
    ;; get an error and enter the debugger.
    (nil (arg)
	 :report "Retain old value in the slot"
	 :interactive (lambda ()
			(list value))
	 arg
	 (return (values NIL T)))
    (nil (arg)
	 :report "Enter replacement value for the slot"
	 :interactive (lambda ()
			(format t "New value for ~S slot ~S: " object slot)
			(force-output)
			(list (read)))
	 (multiple-value-bind (new-value result)
	     (check-slot-type object slot arg T)
	   (cond ((null result)
		  ;; no error in replacement value
		  (return (values arg :REPLACE)))
		 ((eq result :REPLACE)
		  (return (values new-value :REPLACE)))))))))
|#



(defun set-slot-type (object slot type)
  (let ((entry (or (slot-accessor object slot)
		   (set-slot-accessor object slot *no-value* type NIL))))
    (setf (sl-bits entry)
	  (logior (logand (sl-bits entry) *all-bits-mask*) type))))



;;;; S-TYPE
;;; Adds a type declaration to the given <slot>, eliminating any previous
;;; type declarations.  If <check-p> is true, checks whether the value
;;; already in the <slot> satisfies the new type declaration.
;;;
(defun s-type (object slot type &optional (check-p T))
  (set-slot-type object slot (if type
			       (encode-type type)
			       ;; 0 means "no type declarations"
			       0))
  (if check-p
    (let* ((entry (slot-accessor object slot))
	   (value (if entry (sl-value entry))))
      (unless (or (eq value *no-value*)
		  (formula-p value))
	(multiple-value-bind (new-value result)
	    (check-slot-type object slot value T entry)
	  (cond ((eq result :REPLACE)
		 (s-value object slot new-value)))))))
  type)



;;; -------------------------------------------------- DECLARATION ACCESSORS


;;;; GET-DECLARATIONS
;;; RETURNS: a list of all slots in the <schema> which are declared as
;;; <declaration>.
;;; Example: (get-declarations A :type)
;;;
(defun get-declarations (schema declaration)
  (let ((slots nil))
    (case declaration
      (:CONSTANT nil)
      (:TYPE nil)
      ((:IGNORED-SLOTS :SORTED-SLOTS :MAYBE-CONSTANT
		       :PARAMETERS :OUTPUT :UPDATE-SLOTS)
       (return-from get-declarations (g-value schema declaration)))
      (:LOCAL-ONLY-SLOTS
       (return-from get-declarations (g-local-value schema declaration)))
      (t
       (return-from get-declarations NIL)))
    ;; Visit all slots, construct information
    (iterate-slot-value (schema T T NIL)
      value				;; suppress warning
      (let ((bits (sl-bits iterate-slot-value-entry)))
	(case declaration
	  (:CONSTANT
	   (if (is-constant bits)
	       (push slot slots)))
	  (:TYPE
	   (let ((type (extract-type-code bits)))
	     (if (not (zerop type))
		 (push (list slot (code-to-type type)) slots)))))))
    slots))



;;;; GET-SLOT-DECLARATIONS
;;;
(defun get-slot-declarations (schema slot)
  (let* ((entry (slot-accessor schema slot))
	 (bits (if entry (sl-bits entry) 0))
	 (declarations nil))
    (if (is-constant bits)
      (push :CONSTANT declarations))
    (if (memberq slot (g-value schema :update-slots))
      (push :UPDATE-SLOTS declarations))
    (if (memberq slot (g-value schema :local-only-slots))
      (push :LOCAL-ONLY-SLOTS declarations))
    (if (memberq slot (g-value schema :maybe-constant))
      (push :MAYBE-CONSTANT declarations))
    (let ((type (extract-type-code bits)))
      (unless (zerop type)
	(push (list :type (code-to-type type)) declarations)))
    ;; Now process all declarations that are not stored in the slot bits.
    (dolist (s-slot '(:IGNORED-SLOTS :PARAMETERS :OUTPUT :SORTED-SLOTS))
      (let ((values (g-value schema s-slot)))
	(if (memberq slot values)
	  (push s-slot declarations))))
    declarations))



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

;;; Define support fns for basic builtin types.  These definitions must come
;;; before the file CONSTRAINTS.LISP is compiled.


(defun T-P (value)
  (declare (optimize (speed 3) (safety 0) (compilation-speed 0) (space 0))
	   (ignore value))
  T)


#+(or LUCID ALLEGRO-V3.1)
;;; REALP seems to be undefined on these lisps.
;;;
(let ((realp-symbol (find-symbol "REALP" 'lisp)))
  (unless (and realp-symbol (fboundp realp-symbol))
    (setf (symbol-function (intern "REALP" 'lisp))
          (symbol-function 'numberp))))


(defun no-type-error-p (value)
  (cerror "Return T"
          "KR typechecking called on value ~S with no type"
          value)
  T)



;;; Given the symbol which names a KR type (e.g., 'KR-BOOLEAN), this function
;;; returns the type expression that was used to define the type.
;;; Example:
;;; (base-type-for 'bitmap-or-nil) ==>
;;; (OR NULL (IS-A-P OPAL:BITMAP))
;;;
(defun get-type-definition (type-descriptor)
  (let* ((name (if (symbolp type-descriptor) (symbol-name type-descriptor)))
	 (code (gethash name kr::types-table)))
    (if name
      (maphash #'(lambda (key value)
		   (if (and (eq value code)
			    (not (stringp key)))
		     (return-from get-type-definition key)))
	       kr::types-table))))



;;; -------------------------------------------------- FORMULA META-SLOTS


;;; Returns, or inherits, the meta-schema associated with the <formula>, or
;;; NIL if none exists.
;;;
(defun find-meta (formula)
  (let ((meta (a-formula-meta formula)))
    (unless meta
      ;; Try to inherit the meta-information from the formula's parent(s).
      (do ((f (a-formula-is-a formula) (a-formula-is-a f)))
	  ((null f))
	(if (setf meta (a-formula-meta f))
	    ;; Do not copy down the meta-schema, to reduce storage.
	    (return))))
    meta))



;;;; G-FORMULA-VALUE
;;; RETURNS:
;;; the value of the meta-slot <slot> in the <formula>, or NIL if none
;;; exists.  The value may be inherited from the <formula>'s parent(s), but
;;; no new meta-schema is created as a result of this operation.
;;;
(defun g-formula-value (formula slot)
  (when (formula-p formula)
    (case slot
      (:NUMBER (a-formula-number formula))
      (:VALID (cache-is-valid formula))
      (:DEPENDS-ON (a-formula-depends-on formula))
      (:SCHEMA (a-formula-schema formula))
      (:SLOT (a-formula-slot formula))
      (:CACHED-VALUE (a-formula-cached-value formula))
      (:PATH (a-formula-path formula))
      (:IS-A (a-formula-is-a formula))
      (:FUNCTION (a-formula-function formula))
      (:LAMBDA (a-formula-lambda formula))
      (:IS-A-INV (a-formula-is-a-inv formula))
      (:META (a-formula-meta formula))
      (T
       ;; Normal case: this is not a built-in formula slot.  Use meta-slots.
       (let ((meta (find-meta formula)))
	 (if meta
	     (g-value meta slot)))))))



;;;; S-FORMULA-VALUE
;;; Sets the value of the meta-slot <slot> in the <formula> to be <value>.
;;; If no meta-schema exists for the <formula>, creates one.
;;;
(defun s-formula-value (formula slot value)
  (when (formula-p formula)
    (let ((meta (a-formula-meta formula)))
      (unless meta
	(setf meta (find-meta formula))
	(if meta
	    ;; We do have a meta-schema that can be inherited.
	    (let ((new (create-schema nil)))
	      (s-value new :is-a (list meta))
	      (setf meta new))
	    ;; Create a brand new, non-inheriting meta-schema.
	    (setf meta (create-schema nil)))
	;; Install the new meta-schema.
	(setf (a-formula-meta formula) meta))
      (s-value meta slot value))))



;;; -------------------------------------------------- READER MACROS


;;; Modify the readtable so #k<NAME> is read as the KR object NAME, if
;;; defined.  This allows objects written with the *print-as-structure*
;;; notation to be read back in.
;;;
(eval-when (eval compile load)
  (defun k-reader (stream subchar arg)
    (declare (ignore subchar arg))
    (let ((next-char (read-char stream)))
      (if (char= next-char #\<)
	;; This is a KR #k<...> object name
	(let ((string ""))
	  (do ((c (read-char stream) (read-char stream)))
	      ((char= c #\>))
	    (setf string (format nil "~A~C" string c)))
	  (setf string (read-from-string string))
	  (if (and (boundp string)
		   (or (schema-p (symbol-value string))
		       (formula-p (symbol-value string))))
	    (symbol-value string)
	    (cerror "Ignore the object"
		    "Non-existing KR object: ~S" string)))
	;; This is something else
	(cerror
	 "Ignore the token"
	 "  Illegal character ~S after reader macro #k (expecting \"<\")"
	 next-char)))))


;;; Install this reader macro in the standard readtable.  Push the keyword
;;; :NO-K-READER onto the *features* list to disable this feature.
;;;
#-NO-K-READER
(eval-when (eval compile load)
  (set-dispatch-macro-character #\# #\k (function k-reader)))



;;; Modify the readtable to #f(...) is read as (o-formula ...).  For example,
;;; this allows you to write
;;; (s-value a :left #f(gvl :top))
;;;
(defun o-formula-reader (stream subchar arg)
  (declare (ignore subchar arg))
  `(o-formula ,(read stream t nil t)))
(set-dispatch-macro-character #\# #\f #'o-formula-reader)
