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

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

(declaim (inline clear-one-slot))

(defun clear-one-slot (schema slot entry)
  "Completely clear a slot, including dependencies, inherited, etc...
   BUT... Leave around the declarations (constant, type, update,...)"
  (locally (declare #.*special-kr-optimization*)
    (let ((the-entry (or entry (slot-accessor schema slot))))
      (when the-entry
	(setf (sl-value the-entry) *no-value*
	      (sl-bits the-entry)  (logand (sl-bits the-entry)
					   *clear-slot-mask*))))))

(declaim (inline clear-schema-slots))
(defun clear-schema-slots (schema)
  "Completely clear ALL the slots in the <schema>."
  (locally (declare #.*special-kr-optimization*)
    (clrhash (schema-bins schema))))

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

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

(let ((list-of-one (list nil)))
  (defun get-dependents (schema slot)
    "RETURNS: the formulas which depend on the <slot> of the <schema>."
    (let ((value (slot-dependents (slot-accessor schema slot))))
      (if (listp value)
	  value
	  (progn
	    (setf (car list-of-one) value)
	    list-of-one)))))

(declaim (inline get-lambda))
(defun get-lambda (formula)
  "Returns the lambda expression in a formula, or NIL."
  (when (formula-p formula)
    (a-formula-lambda formula)))

(defun enable-a-demon (demon)
  "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."
  (cond ((eq *demons-disabled* T)
	 (list T demon))
	((eq *demons-disabled* 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*)))))


(defun demon-is-disabled (demon)
  "Is the <demon> currently enabled?"
  (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*)))


(defun g-value-inherit-values (schema slot is-leaf slot-structure)
  "Search up the tree for inherited slot.
RETURNS: the inherited value, or NIL."
  (declare (ftype (function (t &optional t) t) formula-fn))
  (let (has-parents)
    (when (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))
	    (when (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
	      (when (and is-leaf 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*)))
	      (when 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
;;
(declaim (inline 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)))


(defun g-value-no-copy (schema slot &optional skip-local)
  "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)."
  (unless skip-local
    ;; Is there a local value?
    (let ((value (slot-accessor schema slot)))
      (when 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)))
	  (when value
	    (return-from g-value-no-copy value)))))))


;;; PRINTING AND DEBUGGING

(declaim (fixnum *debug-names-length* *debug-index*))
(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.")

(defun cache-schema-name (schema name)
  "This 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."
  (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)))

;;
(defun make-new-schema-name (schema name)
  "Creates symbols for all automatic schema names that happen to
be printed out."
  (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)
				   (when (not-deleted-p schema)
				     (car (get-local-value schema :IS-A)))))
			 (let ((parent-name (when 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.
	   (when *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*)))
    (when 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 ">")
	  (when destroyed (format stream ")")))
	(progn
	  (format stream "~S" name)
	  (when destroyed (format stream ")"))))))


(defun name-for-schema (schema)
  "Given a schema, returns its printable name as a string.  The string
CANNOT be destructively modified.
Note that this returns the pure name, without the #k<> notation."
  (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.
      (when *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)))


(defun s (number)
  "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."
  (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

(defun unlink-one-value (schema slot value)	    ; e.g., child :is-a parent
  "Remove the inverse link from <value> to <schema>, following the inverse
of <slot>."
  (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)))))))))

(defun unlink-all-values (schema slot)
  "Same as above, but unlinks all schemata that are in <slot>."
  (let ((inverse (cadr (assocq slot *relations*))))
    (when 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)))))
	(when entry
	  (dolist (parent (sl-value entry))
	    (when (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)))))))))))))


(defun link-in-relation (schema slot 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."
  (let ((inverse (if (eq slot :is-a)
		     :is-a-inv
		     (cadr (assocq slot *relations*)))))
    (when 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 (when 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.
		  (if (eq (sl-value entry) *no-value*)
		      ;; There was no value after all!
		      (setf (sl-value entry) (list schema))
		      ;; There were real values.
		      (push schema (sl-value entry))))
	      ;; There was no inverse in the parent yet.
	      (set-slot-accessor value inverse (list schema) *local-mask* nil)))))))


(defun check-relation-slot (schema slot values)
  "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."
  (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)


(declaim (inline inherited-p))
(defun inherited-p (schema slot)
  "Similar to HAS-SLOT-P, but when there is a formula checks whether this is
an inherited formula."
  (let ((entry (slot-accessor schema slot)))
    (when entry
      (or (is-inherited (sl-bits entry))
	  (and (formula-p (sl-value entry))
	       (formula-p (a-formula-is-a (sl-value entry))))))))

(defun formula-push (f)
  (bordeaux-threads:with-lock-held  (*formula-lock*)
    (push f *formula-pool*)))

;;; 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-table-lock* (bordeaux-threads:make-recursive-lock)
  "Lock to synchonize access to *types-table*")

(defmacro with-types-table-lock-held ((table) &body body)
  `(let ((,table *types-table*))
     (bordeaux-threads:with-recursive-lock-held (*types-table-lock*)
     ,@body)))

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

(declaim (fixnum *next-type-code*))
(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.")

(declaim (inline code-to-type code-to-type-fn code-to-type-doc check-kr-type))

(defun code-to-type (type-code)
  (svref types-array type-code))

(defun code-to-type-fn (type-code)
  (svref type-fns-array type-code))

(defun code-to-type-doc (type-code)
  (svref type-docs-array type-code))

(defun check-kr-type (value code)
  (funcall (code-to-type-fn code) value))


(declaim (inline find-lisp-predicate))
(defun find-lisp-predicate (simple-type)
  "Given simple type ('NULL, 'KEYWORD, etc...), returns the name of
the lisp predicate to test this ('NULL, 'KEYWORDP, etc....)"
  (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 'common-lisp)
		 (find-symbol -p-name 'common-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)
  (with-types-table-lock-held (types-table)
    (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 (when (and lo (not (eq lo '*)))
				    (if (listp lo)
					`((< ,(car lo) value))
					`((<= ,lo value)))))
			 (hi (second args))
			 (hi-expr (when (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))))))

(defun type-to-fn (type)
  "Given the Lisp type, construct the lambda expr, or return the
   built-in function"
  (with-types-table-lock-held (types-table)
    (let (code)
      (cond ((consp type)			; complex type
	     (if (eq (car type) 'SATISFIES)
		 (let ((fn-name (second type)))
		   `',fn-name) ;; koz
		 `(function (lambda (value)
		    (declare #.*special-kr-optimization*)
		    ,(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))))))

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


(defun get-next-type-code ()
  "Return the next available type-code, and extend the type arrays
if necessary."
  (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*))))


(defun add-new-type (typename type-body type-fn &optional type-doc)
  "This adds a new type, if necessary
Always returns the CODE of the resulting type (whether new or not)"
  (with-types-table-lock-held (types-table)
    (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))

(eval-when (:execute :compile-toplevel :load-toplevel)
  (defun encode-type (type)
    "Given a LISP type, returns its encoding."
    (with-types-table-lock-held (types-table)
      ;; if there, just return it!
      (cond ((gethash type types-table))
	    ((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)))
		   (when predicate
		     (add-new-type NIL type predicate)))
		 (kr-type-error type)))
	    (T (kr-type-error type))))))

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


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



;;; Formula and slot code.

;; Helper function
;;
(defun eliminate-constant-formula ()
  (declare (ftype (function (t t) t) destroy-constraint))
  ;; This was a constant formula!  Commit suicide.
  (with-demons-disabled
    (destroy-constraint *schema-self* *schema-slot*))
  (when *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))))))

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


(declaim (fixnum *warning-level*))
(defparameter *warning-level* 0)

;; Helper function
;;
(defun re-evaluate-formula (schema-self schema-slot current-formula entry #+EAGER eval-type)
  (let ((*schema-self* schema-self)
	(*schema-slot* schema-slot)
	(*current-formula* current-formula)
	#+EAGER (*eval-type* 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!
	    (unless *constants-disabled*
	      (zerop (the fixnum (a-formula-number *current-formula*)))))
	   (*accessed-slots* NIL)
	   (*is-constant* T)
	   (declared-constant (when *check-constants*
				(when (or entry
					  (setf entry (slot-accessor
						       *schema-self*
						       *schema-slot*)))
				  (is-constant (sl-bits entry))))))
      (when 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 (coerce (a-formula-function *current-formula*) 'function))))
		 (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
		     (unless (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)))
	(when *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)
  (let ((*schema-self* schema-self))
    (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
		(when *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))))))


;;; Inheritance

(defun copy-to-all-instances (schema a-slot value &optional (is-first T))
  "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."
  (s-value schema a-slot value)
  ;; Do not create copies of formulas, but set things up for inheritance
  (when (and is-first (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)))
			  (when entry (sl-value entry)))
			(get-local-value schema inverse))))
      (unless (eq children *no-value*)
	(dolist (child children)
	  ;; force new inheritance
	  (unless (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.
	  (when (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))))))

(defun update-inherited-values (schema a-slot value is-first)
  "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.
"
  (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)))
			    (when entry (sl-value entry)))
			  (get-local-value schema inverse))))
	(unless (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)))))))))


;;; Slot and formula change  code.


(declaim (inline mark-as-changed))
(defun mark-as-changed (schema slot)
  "Forces formulas which depend on the <slot> in the <schema> to be
invalidated.  Mostly used for internal implementation.
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."
  (let ((entry (slot-accessor schema slot)))
    (run-invalidate-demons schema slot entry)
    (when (and entry (is-parent (sl-bits entry)))
      (update-inherited-values schema slot (sl-value entry) T)))
  (propagate-change schema slot))


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


(defun recompute-formula (schema slot)
  "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."
  (let* ((entry (slot-accessor schema slot))
	 (formula (when entry (sl-value entry))))
    (when (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)
	(when (is-parent bits)
	  (update-inherited-values schema slot formula T))
	#-EAGER
	(propagate-change schema slot)
	#+EAGER
	(propagate)))))


(defun propagate-change (schema slot)
  "Since the <slot> of the <schema> was modified, we need to propagate the
change to all the formulas which depended on the old value."
  (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 visit-inherited-values (schema a-slot function)
  "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."
  (let* ((entry (slot-accessor schema a-slot))
	 (parent-entry (when 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 (when 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)))))))


(defun run-demons-and-set-value (schema slot new-value old-value is-relation
				 is-formula was-formula the-bits entry)
  "Internal function which runs demons as appropriate (before changing the
value) and then physically sets the <slot> in the <schema> to be
<new-value>."
  (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
	 (when (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
	   (when 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.
  (when (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))


(declaim (inline check-not-constant))
(defun check-not-constant (schema slot entry)
  "Signals an error if the <slot> of the <schema> is not constant."
  (and (not *constants-disabled*)
       entry
       (is-constant (sl-bits entry))
       (constant-slot-error schema slot)))


(declaim (inline slot-constant-p))
(defun slot-constant-p (schema slot)
  "RETURN: T if the <slot> in the <schema> is constant, nil otherwise"
  (let ((entry (slot-accessor schema slot)))
    (when entry
      (is-constant (sl-bits entry)))))


(defun set-formula-error (schema slot formula)
  "Called to give error message on multiply-installed formulas."
  ;; 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)


(defun s-value-fn (schema slot value)
  "Does all the work of the macro S-VALUE.

RGA --- no, returns two values: the value function set to and t if there
was an error.  Note that in the case of a type error, it returns the
current value of the slot."
  (locally (declare #.*special-kr-optimization*)
    (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))
      ;; RGA added t for error return.
      (return-from s-value-fn (values value t)))
    (let* ((entry (slot-accessor schema slot))
	   (old-value (when 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.
	;; RGA --- Error return function
	(return-from s-value-fn (values value nil)))

      (when (and *types-enabled* (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
		 ;; RGA --should return old-value, added a second
		 ;; value indicating error.
		 (return-from s-value-fn (values old-value t)))
		(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.
	(when (and (setf is-relation (relation-p slot))
		   (eq (setf value (check-relation-slot schema slot value)) *no-value*))
	  ;; RGA --- added no-error return code
	  (return-from s-value-fn (values old-value nil)))

	;; If we are installing a formula, make sure that the formula
	;; points to the schema and slot.
	(when (formula-p value)
	  (when (on-schema value)
	    ;; RGA --- added error return code.
	    (return-from s-value-fn
	      (values (set-formula-error schema slot value) T)))
	  (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
	(unless 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))
	   (when (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
	   (when (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
	     (when 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.
	(when (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.
	(when is-depended
	  (let ((*warning-on-disconnected-formula* nil))
	    (propagate-change schema slot)))
	(when (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))

	(when is-relation
	  ;; A relation slot is being changed.  We may need to invalidate all
	  ;; inherited values.
	  (reset-inherited-values schema))
	;; RGA added nil error return flag.
	(values value nil)))))


(defun internal-s-value (schema slot 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."
  (let ((is-formula (formula-p value))
	(is-relation (relation-p slot)))
    (when is-relation
      (unless (listp value)
	(setf value (list value)))
      ;; Check for special cases in relation slots.
      (when (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
      (when (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.
    (when is-relation
      (link-in-relation schema slot value))
    value))


(defun set-is-a (schema value)
  "A specialized version of internal-s-value"
  ;; Check for special cases in relation slots.
  (when (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)


(defun eliminate-formula-dependencies (formula except-schema)
  "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."
  (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
	      (when (memberq formula formulas)
		(setf (full-sl-dependents iterate-slot-value-entry)
		      (delete formula formulas)))
	      ;; One dependent
	      (when (eq formula formulas)
		(setf (full-sl-dependents iterate-slot-value-entry) NIL))))))))


(defun delete-formula (formula remove-from-parent)
  "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."
  (when (a-formula-number formula)
    (eliminate-formula-dependencies formula NIL)
    (when remove-from-parent
      ;; Eliminate the <formula> from its parent's list of children.
      (let ((parent (a-formula-is-a formula)))
	(when 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.
	  (a-formula-schema formula) nil
	  (a-formula-slot formula) nil
	  (a-formula-lambda formula) nil
	  (a-formula-depends-on formula) nil)
    (let ((meta (a-formula-meta formula)))
      (when meta
	(setf (a-formula-meta formula) NIL)
	(destroy-schema meta)))
    (formula-push formula)))


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


(defun destroy-slot (schema slot)
  "Eliminates the <slot>, and all the values it contains, from the <schema>,
taking care of possible constraints."
  ;; 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)))
	      (when (and the-schema
			 (schema-p 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.
	(when (formula-p old-value)
	  (delete-formula old-value T))

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


(defun delete-schema (schema recursive-p)
  "Internal function.  If <recursive-p>, this is being called from within
recursive-destroy-schema, so there is no need to maintain upwards
relations properly."
  (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
	  (unless recursive-p
	    (iterate-slot-value (schema NIL NIL NIL)
	      value                     ; eliminate warning
	      (when (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.
    (when (symbolp (schema-name schema))
      (makunbound (schema-name schema)))
    ;; This is used as a marker for deleted schemas.
    (setf (schema-bins schema) nil)))


(defun find-direct-dependency (expression target)
  "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."
  (when (listp expression)
    (or (and (eq (car expression) 'GV)
	     (eq (cadr expression) target))
	(dolist (thing expression)
	  (when (find-direct-dependency thing target)
	    (return T))))))


(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))
	  (when (and formula		; defensive programming
		     (not (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.
	(when (formula-p value)
	  (delete-formula value T))))
    (when send-destroy-message
      ;; Call the :DESTROY method.
      (kr-call-initialize-method schema :DESTROY))
    ;; Physically delete the schema.
    (delete-schema schema recursive-p)))


(defun recursive-destroy-schema (schema level)
  "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)."
  (unless (or (formula-p schema)	; safety check
	      (deleted-p schema))
    (let* ((entry (slot-accessor schema :IS-A-INV))
	   (children (if entry (sl-value entry))))
      (unless (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)))


(defun reset-inherited-values (schema)
  "Since the <relation> slot was changed, all children of the <schema> may
have to inherit different values."
  (iterate-slot-value (schema T NIL T)	; use inheritance!
    (unless (relation-p slot)
      (unless (eq value *no-value*)
	(when (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)))))
    (when 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)))
  (when space-p
    (write-string " "))
  (incf column (print-one-value value type))
  column)


(defun print-meta (formula)
  "Print the meta-information associated with a 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)


(defun force-down-all-inheritance (schema)
  "A potentially VERY expensive operation.  It is done by PS when it wants
to print out all inherited and inheritable slots of an object."
  (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))))


(defun call-func-on-one-slot (schema slot inherited-ok function
				     types-p indent limits)
  "Helper function for the following.
The <function> is called with:
(schema slot formula inherited valid real-value types-p indent limits)"
  (let* ((entry (slot-accessor schema slot))
	 (values (when entry (sl-value entry)))
	 (bits (when entry (sl-bits entry)))
	 form valid real-value)
    (when 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))))


(defun call-on-ps-slots (schema function
			 &key (control t)
			      inherit
			      (indent NIL)
			      types-p
			      all-p)
  "Apply the <function> to slots, the way PS would."
  (declare (special print-schema-control))
  (let ((is-ps (eq function 'SLOT-PRINTER))) ; true if inside PS
    (when (null indent)
      (setf indent 0))
    (when (numberp schema)
      (setf schema (s schema)))
    (unless (or (schema-p schema) (formula-p schema))
      (when is-ps
	(format t "~S~%" schema))
      (return-from call-on-ps-slots nil))
    (when 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 (when control (g-value-no-copy control :IGNORED-SLOTS)))
	  (sorted (when control (g-value-no-copy control :SORTED-SLOTS)))
	  (limit-values (when 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*
	   (when control (g-value-no-copy control :print-slots))))
      (when 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)
	(when 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)))))
    (when is-ps
      (format t "  }~%"))))


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


(defun slot-printer (schema name formula are-inherited valid values
			    type-p bits indent limit-values)
  "Used by PS to print out one slot."
  (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))
    (when type-p
      (setf type (code-to-type (extract-type-code bits))))
    (when 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 ")")
	   (when formula
	     (format t " . ~S)" valid))
	   (when 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)
	   (when 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))
	   (when formula
	     (format t " . ~S)" valid))))
    (if printed
      (terpri)
      (format t " NIL~%"))))


(defun ps (schema &key (control t) inherit (indent 0) types-p all-p
		  (stream *standard-output*))
  "PS prints the <schema>.  The optional arguments allow fancy control of
  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:
 -  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.
 -  NIL, which means that the <schema> is printed in its entirety (i.e. no
    schema control.)

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


(defun full-normal-slot (schema slot)
  "Helper function for FULL."
  (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))
	  (when (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))


(defun full (&rest schemata)
  "Internal debugging - print out schemata in gory detail."
  (dolist (schema schemata)
    (when (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))
	    (when (a-formula-is-a schema)
	      (format t
		      "parent formula:         ~S~%"
		      (a-formula-is-a schema)))
	    (when (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


(defun find-parent (schema slot)
  "Find a parent of <schema> from which the <slot> can be inherited."
  (dolist (relation *inheritance-relations*)
    (dolist (a-parent (if (eq relation :is-a)
			  (get-local-value schema :IS-A)
			  (get-local-value schema relation)))
      (when 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)
		(when value
		  (return-from find-parent (values value the-parent))))))))))


(defun old-kr-send-function (schema slot &rest args)
  "Same as KR-SEND, but as a function."
  (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)))))


(defun kr-call-initialize-method (schema slot)
  "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."
  (let ((the-function (g-value-no-copy schema slot)))
    (when 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)))))


(defun kr-init-method (schema the-function)
  "Similar, but even more specialized.  It is only called by create-schema
and friends, which know whether an :initialize method was specified locally."
  (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)))
    (when the-function
      ;; Bind these in case call prototype method is used.
      (let ((*kr-send-self* schema)
	    (*kr-send-slot* :INITIALIZE)
            (*kr-send-parent* NIL)
	    #-(and) (*demons-disabled* T))
	(funcall the-function schema)))))


(defun call-prototype-function (&rest args)
  "Functional version of CALL-PROTOTYPE-METHOD."
  (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))))))

;;; Schemas

(defun allocate-schema-slots (schema)
  (locally (declare #.*special-kr-optimization*)
    (setf (schema-bins schema)
	  (make-hash-table :test #'eq #+sbcl :synchronized #+sbcl t)))
  schema)


(defun make-a-new-schema (name)
  "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>."
  (locally (declare #.*special-kr-optimization*)
    (when (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)))))


;;; Constant slots


(defun process-one-constant (schema slot)
  "The <slot> in <schema> was declared constant."
  ;; 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))))))


(defun declare-constant (schema slot)
  "Declare slot constants AFTER instance creation time."
  (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
		 (when (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))))))))


(defun merge-prototype-values (object slot parents values)
  "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."
  (unless values
    (setf values (when 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)))))
      (when 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))))))


(defun process-constant-slots (the-schema parents constants do-types)
  "Process local-only and constant declarations."
  (locally (declare #.*special-kr-optimization*)
    ;; 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)))
	  (unless (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))))
		  (unless (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)))
		      (when (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*)
	  (unless (formula-p value)	; don't bother with formulas.
	    (multiple-value-bind (new-value result)
		(check-slot-type the-schema slot value)
	      (when (eq result :REPLACE)
		(s-value the-schema slot new-value)))))))))


(defun add-update-slot (schema slot &optional turn-off)
  "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."
  (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 (:execute :compile-toplevel :load-toplevel)
  (defun cannot-be-quoted (value)
    (or (listp value)
	(and (symbolp value)
	     (not (keywordp value))))))

(eval-when (:execute :compile-toplevel :load-toplevel)
  (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)


(eval-when (:execute :compile-toplevel :load-toplevel)
  (defun process-slots (slots)
    "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)."
    (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))))


(defun do-schema-body (schema is-a generate-instance do-constants override
		       types &rest slot-specifiers)
  "Create-schema and friends expand into a call to this function."
  (when (equal is-a '(nil))
    (format
     t
     "*** (create-instance ~S) called with an illegal (unbound?) class name.~%"
     schema)
    (setf is-a NIL))
  (unless (listp is-a)
    (setf is-a (list is-a)))
  (when 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)
	  (when (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))))
	(when 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
		(when 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.
	     (when (and (not cancel-constants) (not *constants-disabled*)
			(not *redefine-ok*))
	       (when (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 (:execute :compile-toplevel :load-toplevel)
  (defun creation-message (name)
    (when *print-new-instances*
      (when (and (listp name)
		 (eq (car name) 'QUOTE))
	(format *standard-output* "~&Object ~S~%" (eval name))))))


(defun end-create-instance (schema)
  "Processes the second half of a create-instance.  Begin-create-instance must
have been called on the <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

(declaim (inline get-slot-type-code))
(defun get-slot-type-code (object slot)
  (let ((entry (slot-accessor object slot)))
    (and entry
	 (get-entry-type-code entry))))


(declaim (inline g-type))
(defun g-type (object slot)
  (let ((type (get-slot-type-code object slot)))
    (and type
	 (code-to-type type))))


(defun check-slot-type (object slot value &optional (error-p T) entry)
  "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.
"
  (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))))


(defun s-type (object slot type &optional (check-p T))
  "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."
  (set-slot-type object slot (if type
			       (encode-type type)
			       ;; 0 means "no type declarations"
			       0))
  (when 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


(defun get-declarations (schema declaration)
  "RETURNS: a list of all slots in the <schema> which are declared as
<declaration>.

Example: (get-declarations A :type)"
  (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
	   (when (is-constant bits)
	     (push slot slots)))
	  (:TYPE
	   (let ((type (extract-type-code bits)))
	     (unless (zerop type)
	       (push (list slot (code-to-type type)) slots)))))))
    slots))


(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 #.*special-kr-optimization*
	   (ignore value))
  T)

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


(defun get-type-definition (type-descriptor)
  "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))
"
  (let* ((name (if (symbolp type-descriptor) (symbol-name type-descriptor)))
	 (code (gethash name kr::types-table)))
    (when name
      (maphash #'(lambda (key value)
		   (when (and (eq value code)
			    (not (stringp key)))
		       (return-from get-type-definition key)))
	       kr::types-table))))



;;; FORMULA META-SLOTS

(defun find-meta (formula)
  "Returns, or inherits, the meta-schema associated with the <formula>, or
NIL if none exists."
  (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))


(defun g-formula-value (formula slot)
  "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."
  (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)))))))


(defun s-formula-value (formula slot 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."
  (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


(eval-when (:execute :compile-toplevel :load-toplevel)
  (defun k-reader (stream subchar arg)
    "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."
    (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.
(eval-when (:execute :compile-toplevel :load-toplevel)
  (set-dispatch-macro-character #\# #\k (function k-reader)))

(defun o-formula-reader (stream subchar arg)
  "Modify the readtable to #f(...) is read as (o-formula ...).  For example,
this allows you to write
(S-VALUE A :LEFT #F(GVL :TOP))"
  (declare (ignore subchar arg))
  `(o-formula ,(read stream t nil t)))

(set-dispatch-macro-character #\# #\f #'o-formula-reader)