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


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


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


(export '(SCHEMA
	  CREATE-INSTANCE CREATE-PROTOTYPE CREATE-RELATION CREATE-SCHEMA
	  FORMULA O-FORMULA
	  SCHEMA-P RELATION-P IS-A-P HAS-SLOT-P FORMULA-P
	  S-VALUE G-VALUE G-CACHED-VALUE G-LOCAL-VALUE GV GVL GV-LOCAL
	  GET-VALUE GET-LOCAL-VALUE
	  DOVALUES DOSLOTS
	  DEFINE-METHOD KR-SEND CALL-PROTOTYPE-METHOD APPLY-PROTOTYPE-METHOD
	  METHOD-TRACE
	  WITH-CONSTANTS-DISABLED
	  WITH-DEMONS-DISABLED WITH-DEMON-DISABLED WITH-DEMON-ENABLED
	  CHANGE-FORMULA MOVE-FORMULA RECOMPUTE-FORMULA COPY-FORMULA KR-PATH
	  MARK-AS-CHANGED MARK-AS-INVALID
	  PS NAME-FOR-SCHEMA DECLARE-CONSTANT DECLARE-LINK-CONSTANT
	  DESTROY-SLOT DESTROY-SCHEMA DESTROY-CONSTRAINT

	  ;; The following are obsolete - get rid of them in your code!
	  get-values get-local-values set-values
	  ))



;;; Enable debugging stuff
(eval-when (compile eval load)
  (pushnew :GARNET-DEBUG *features*))


;;; This enables the eager-evaluation version.
;;; 
#|
;;; Currently turned off.
(eval-when (eval load compile)
  (unless (find :lazy *features*)
    (pushnew :eager *features*)))
|#




;;; -------------------------------------------------- Internal structures.




;;; The internal representation of a schema is as a structure, where the
;;; <name> slot holds the name (or internal number) of the schema and the
;;; <slots> slot holds a p-list of slot names and slot values.
;;; 
(defstruct (schema (:predicate is-schema)
		   (:print-function print-the-schema))
  name      ; the schema name, or a number
  slots     ; array of slots
  )



;;; This structure is similar to a schema, but is used to store formulas.
;;; It prints out with an F instead of an S, and it uses the same positions for
;;; different functions.
;;; 
(defstruct (a-formula (:include schema) (:print-function print-the-schema))
  ;;; number	; valid/invalid bit, and sweep mark.  Actually stored in the
  		; structure slot "a-formula-slots", inherited from schema.
  depends-on	; list of schemata on which this function depends (or single
  		; schema if there is only one)
  schema	; schema on which this formula is installed
  slot		; slot on which this formula is installed
  cached-value	; the cached value
  path		; holds cached paths
  is-a		; parent formula, if any
  function	; executable formula function
  lambda	; the original lambda expression, if applicable
  is-a-inv
  #+EAGER
  priority      ; formula's position in topological order
  #+EAGER
  bits          ; contains the valid/invalid, visited/not-visited,
                ; renumbered/not-renumbered, eval-q/not-eval-q, and
                ; cycle/non-cycle bits, as well as a count of the number
                ; of times the formula has been evaluated
  #+EAGER
  valid
  #+EAGER
  dfnumber      ; number assigned by depth-first search
  #+EAGER
  lowlink       ; lowest dfnumber of a node that this formula is linked to
  )



;;; -------------------------------------------------- Variables, etc.


(defparameter *kr-version* "2.1.14")


(eval-when (compile load eval)
  (defvar *store-lambdas* T
    "If NIL, lambda expressions are not stored in formulas"))


(defvar *warning-on-create-schema* T
  "If nil, no warning is printed when create-schema is redefining an existing
  schema.")

(defvar *warning-on-circularity* nil
  "Set this to NIL to prevent warning when a circularity is detected.")

(defvar *warning-on-evaluation* nil
  "If non-NIL, a warning is printed every time a formula is reevaluated.
  This may be useful during debugging.")

(defvar *warning-on-null-link* NIL
  "If non-NIL, a warning is printed when a null link is evaluated inside a
  GV (or GVL) within a formula.  This is the case when the stale value of the
  formula is reused.")

(defvar *warning-on-disconnected-formula* T
  "If nil, no warning is printed when propagate-change sees a disconnected
  formula.")


(eval-when (compile load eval)
  (defvar *print-new-instances* T))

(eval-when (compile load eval)
  ;;; *LOCAL-SLOTS*
  (defvar *local-slots* '(:is-a-inv)
    "A list of all slots which should be treated as local only, i.e., should
    never be inherited"))


(defvar *setting-formula-p* nil
  "Set to T only when we are setting a slot with a formula")


(defvar *within-g-value* nil
  "Set to non-nil within a sub-formula evaluation")


(defvar *sweep-mark* 0
  "Used as a sweep mark to detect circularities")


(defvar *demons-disabled* nil
  "May be bound to T to cause demons NOT to be executed when a slot is set.
  If the value is a single value, or a list, ")


(defvar *constants-disabled* NIL
  "May be bound to NIL to cause constant declarations to be ignore in
  create-instance.")


(defvar *link-constants-disabled* T
  "May be bound to NIL to turn on :LINK-CONSTANTS.")


(defvar *redefine-ok* NIL
  "May be bound to T to allow create-instance to redefine slots that were
  declare constant in the prototype.")


(defvar *pre-set-demon* nil
  "May be bound to a function to be called as a slot is set in a schema
  with the slots new-value.")


(defvar *schema-self* nil
  "The schema being acted upon by the accessor functions.")

(defvar *schema-slot* nil
  "The slot in *schema-self* being acted upon by the accessor functions.")

(defvar *current-formula* nil
  "The formula being acted upon by the accessor functions.")

(defvar *last-formula* nil
  "Similar to *current-formula*, used for debugging only.")


(defvar *inheritance-relations* '()
  "All relations in this list perform inheritance.")

(defvar *inheritance-inverse-relations* '()
  "Inverses of all relations which perform inheritance.")

(defvar *relations* '()
  "An a-list of relations known to the system, with their inverse(s).
   Used for the creation of automatic reverse-links.")

(defparameter *reuse-formulas* (make-array 1 :adjustable t :fill-pointer 0)
  "A list of formulas that have been destroyed and can be reused.  This
   avoids the need to allocate and deallocate formulas all the time.")

(defparameter *reuse-slots* (make-array 1 :adjustable t :fill-pointer 0)
  "An array of slot arrays that have been destroyed and can be reused.  This
   avoids the need to allocate and deallocate arrays all the time.")


(defvar *schema-is-new* nil
  "If non-nil, we are inside the creation of a new schema.  This guarantees
  that we do not have to search for inverse links when creating relations,
  and avoids the need to scan long is-a-inv lists.")


(defvar *print-as-structure* T
  "If non-nil, schema names are printed as structure references.")

(defvar *print-structure-slots* nil
  "List of slots that should be printed when printing schemata as structures.")


(defvar *no-value* '(:no-value)
  "A cons cell which is used to mark the value of non-existent slots.")


(defvar *schema-counter* 0
  "This variable is used to generate schema numbers for schemata that
  are created with (create-schema NIL).")


(eval-when (eval compile load)

  (defparameter *schema-slots*
    (make-array 15 :initial-contents
		`(:is-a
		  :left
		  :top
		  :width
		  :height
		  :window
		  :visible
		  :parent
		  :update-info
		  :update-slots
		  :update-slots-values
		  :fast-redraw-p
		  :draw
		  :invalidate-demon
		  :constant
		  ))
    "Names of the special slots in a schema")

  (defparameter *slot-size* 4
    "Size of a slot entry, in words.  Includes: Slot-name, Value, Bits, and
     Dependent")

  (defparameter *special-slots-length* (length *schema-slots*))

  ;; Each slot has a certain number of bits associated with it.  These bits
  ;; (currently 5) are used to tell what kind of value is contained in the
  ;; slot.
  ;;
  (defparameter *bits-size* 5
    "How many bits are needed for a slot")

  (defparameter *minus-bits-size* (- *bits-size*)
    "How many bits are needed for a slot")

  (defparameter *first-slot* (* (1- *slot-size*) *special-slots-length*)
    "Position of the first non-special slot"))





(eval-when (eval compile load)
  ;; bit is 1 if slot contains inherited values, 0 for local values
  (defparameter *inherited-bit* 0)
  ;; bit is 1 if any other schema inherited the value from here
  (defparameter *is-parent-bit* 1)
  (defparameter *is-constant-bit* 2)
  (defparameter *is-link-constant-bit* 3))


(eval-when (eval compile load)
  (defparameter *local-mask* 0)
  (defparameter *constant-mask* (ash 1 *is-constant-bit*))
  (defparameter *link-constant-mask* (ash 1 *is-link-constant-bit*))
  (defparameter *inherited-mask* (ash 1 *inherited-bit*))
  (defparameter *is-parent-mask* (ash 1 *is-parent-bit*))
  (defparameter *inherited-parent-mask*
    (logior *inherited-mask* *is-parent-mask*))

  (defparameter *not-inherited-mask* (lognot *inherited-mask*))
  (defparameter *not-parent-mask* (lognot *is-parent-mask*)))


(defvar *check-constants* NIL
  "If T, first-time evaluation for the current formula.  Check whether it
   is a constant formula.")

(defvar *is-constant* T)

(defvar *accessed-slots* NIL
  "Tells whether any slot was accessed during formula evaluation")



(defvar *kr-send-self* nil
  "The current schema for kr-send.")

(defvar *kr-send-slot* nil
  "The current slot for kr-send.")

(defvar *kr-send-parent* nil
  "The schema from which the last prototype method was obtained.")




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


;;; This macro will output the <forms> only if GARNET-DEBUG is defined.
;;;
(defmacro when-debug (&rest forms)
  #+GARNET-DEBUG
  `(progn ,@forms)
  #-GARNET-DEBUG
  (declare (ignore forms))
  #-GARNET-DEBUG
  nil)



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



;;; We do not necessarily use the built-in structure predicate, because it
;;; seems to be terribly slow on Lisp machines.
;;; 

(defmacro formula-p (thing)
  `(a-formula-p ,thing))


(defmacro priority (formula)
  `(a-formula-priority ,formula))


(defmacro formula-count (formula)
  `(ash (a-formula-bits ,formula) *neg-count-bit*))



;;; -------------------------------------------------- EAGER EVALUATION


;;; -------------------- Definitions of value-information bits.

#+EAGER
(eval-when (eval compile load)
  ;; bit is 1 if formula is part of a cycle, 0 otherwise
  (defparameter *cycle-bit* 0)
  ;; bit is 1 if formula is on the evaluation queue, 0 otherwise
  (defparameter *eval-bit* 1)
  ;; bit is 1 if the formula has been visited during a depth-first
  ;; search, 0 otherwise
  (defparameter *visited-bit* 2)
  ;; bit is 1 if the formula's priority has been renumbered during the
  ;; renumbering of a cycle, 0 otherwise
  (defparameter *renumber-bit* 3)
  ;; count keeps track of how many times the formula has been evaluated and
  ;; is called the formula's timestamp
  (defparameter *fixed-bit* 4)
  ;; indicates if formula's value is fixed on this iteration of the constraint
  ;; solver and thus should not be reevaluated

  (defparameter *count-bit* 5)
  (defparameter *neg-count-bit* (- *count-bit*))

  ;;; Bits in a dependency structure.
  ;; bit is 1 if the dependency is part of a cycle, 0 otherwise
  (defparameter *cycle-edge-bit* 0)
  ;; the status of a dependency is indicated by a timestamp. if the
  ;; timestamp is greater than or equal to the timestamp in the dependency's
  ;; formula, the dependency is valid; otherwise the dependency is invalid
  (defparameter *status-bit* 1)
  (defparameter *neg-status-bit* (- *status-bit*)))



#+EAGER
(eval-when (eval compile load)
  (defparameter *cycle-mask* (ash 1 *cycle-bit*))
  (defparameter *eval-mask* (ash 1 *eval-bit*))
  (defparameter *visited-mask* (ash 1 *visited-bit*))
  (defparameter *renumber-mask* (ash 1 *renumber-bit*))
  (defparameter *fixed-mask* (ash 1 *fixed-bit*))
  (defparameter *count-mask* (ash 1 *count-bit*))
  (defparameter *status-mask* (ash 1 *status-bit*))
  (defparameter *cycle-edge-mask* (ash 1 *cycle-edge-bit*)))



#+EAGER
(defvar *eval-queue* nil
  "Contains formulas to be evaluated")


#+EAGER
(defvar *eval-count* 0
  "Number of times propagate has been called")


#+EAGER
(defvar *not-within-propagate* t
  "Set to nil within propagate")


#+EAGER
(defvar *do-not-eval-list* nil
  "Contains a list of formulas that should not be evaluated during an
  iteration of the constraint solver")


#+EAGER
;;; types of evaluation--normal, in a cycle, or evaluation of a new formula
;;; 
(defvar *eval-type* :normal)



#+EAGER
(defmacro set-cycle-bit (formula value)
  `(setf (a-formula-bits ,formula)
	 (if ,value
	     (logior (a-formula-bits ,formula) ,*cycle-mask*)
	     (logand (a-formula-bits ,formula) ,(lognot *cycle-mask*)))))


#+EAGER
(defmacro set-eval-bit (formula value)
  `(setf (a-formula-bits ,formula)
	 ,(if value
	      `(logior (a-formula-bits ,formula) ,*eval-mask*)
	      `(logand (a-formula-bits ,formula) ,(lognot *eval-mask*)))))



#+EAGER
(defmacro set-visited-bit (formula value)
  `(setf (a-formula-bits ,formula)
	 ,(if value
	      `(logior (a-formula-bits ,formula) ,*visited-mask*)
	      `(logand (a-formula-bits ,formula) ,(lognot *visited-mask*)))))



#+EAGER
(defmacro set-valid-bit (formula value)
  `(if ,value
       (setf (a-formula-valid ,formula) (1- *eval-count*))
       (setf (a-formula-valid ,formula) *eval-count*)))



#+EAGER
(defmacro set-renumber-bit (formula value)
  `(setf (a-formula-bits ,formula)
	 ,(if value
	      `(logior (a-formula-bits ,formula) ,*renumber-mask*)
	      `(logand (a-formula-bits ,formula) ,(lognot *renumber-mask*)))))



#+EAGER
(defmacro set-fixed-bit (formula value)
  `(setf (a-formula-bits ,formula)
	 ,(if value
	      `(logior (a-formula-bits ,formula) ,*fixed-mask*)
	      `(logand (a-formula-bits ,formula) ,(lognot *fixed-mask*)))))



#+EAGER
(defmacro prev-priority (index)
  `(aref *prev-priority-array* ,index))


#+EAGER
(defmacro succ-priority (index)
  `(aref *succ-priority-array* ,index))


#+EAGER
(defmacro priority-value (index)
  `(car (aref *priority-array* ,index)))


#+EAGER
(defmacro priority-<=-p (p1 p2)
  `(<= (priority-value ,p1) (priority-value ,p2)))


#+EAGER
(defmacro priority-<-p (p1 p2)
  `(< (priority-value ,p1) (priority-value ,p2)))


#+EAGER
(defmacro priority-=-p (p1 p2)
  `(= ,p1 ,p2))


#+EAGER
(defmacro priority->-p (p1 p2)
  `(> (priority-value ,p1) (priority-value ,p2)))


#+EAGER
(defmacro priority->=-p (p1 p2)
  `(>= (priority-value ,p1) (priority-value ,p2)))


#+EAGER
(defmacro min-priority (p1 p2)
  `(if (priority-<=-p ,p1 ,p2)
       ,p1
       ,p2))



#+EAGER
(defmacro max-priority (p1 p2)
  `(if (priority->=-p ,p1 ,p2)
       ,p1
       ,p2))



#+EAGER
(defmacro dolist-test-elim ((list-var list test) &body body)
  `(let ((dotest-prev ,list))
     (do ((list-vars ,list list-vars)) ; loop control handled in loop
	 ((null list-vars) ,list)
       (let ((,list-var (car list-vars)))
	 (if ,test
	     (progn
	       ,@body
	       ; update the loop variables
	       (setf dotest-prev list-vars)
	       (setf list-vars (cdr list-vars)))
	     ; if element does not meet test, remove it from the list
	     (if (eq list-vars ,list) ; if front of list
		 (progn
		   (pop list-vars)
		   (setf ,list list-vars)
		   (setf dotest-prev list-vars))
		 (progn
		   (pop (cdr dotest-prev))
		   (setf list-vars (cdr dotest-prev)))))))))



#+EAGER
(defmacro dolist-test ((list-var list test) &body body)
  `(do ((list-vars ,list (cdr list-vars)))
      ((null list-vars))
    (let ((,list-var (car list-vars)))
      (when ,test
	,@body))))




;;;  -------------------------------------------------- Low-level slot access


;;; Create special accessors for the various built-in slots.  Each
;;; accessor is called with the slots array and returns three values:
;;; - the slot value
;;; - the bits for the slot
;;; - the position of the value within the array
;;; 
(defmacro define-accessor (slot position)
  `(setf (get ,slot :KR-FAST-ACCESSOR) ,position))



;;; Define the start position of slot information in the special-slot part
;;; of the slots array.
;;;
(progn
  (define-accessor :IS-A		0)
  (define-accessor :LEFT 		3)
  (define-accessor :TOP 		6)
  (define-accessor :WIDTH		9)
  (define-accessor :HEIGHT 		12)
  (define-accessor :WINDOW 		15)
  (define-accessor :VISIBLE 		18)
  (define-accessor :PARENT 		21)
  (define-accessor :UPDATE-INFO 	24)
  (define-accessor :UPDATE-SLOTS 	27)
  (define-accessor :UPDATE-SLOTS-VALUES	30)
  (define-accessor :FAST-REDRAW-P	33)
  (define-accessor :DRAW		36)
  (define-accessor :INVALIDATE-DEMON	39)
  (define-accessor :CONSTANT		42)
  )

(defmacro is-inherited (thing)
  `(logbitp ,*inherited-bit* ,thing))


(defmacro is-parent (thing)
  `(logbitp ,*is-parent-bit* ,thing))


(defmacro is-constant (thing)
  `(logbitp ,*is-constant-bit* ,thing))

(defmacro is-link-constant (thing)
  `(logbitp ,*is-link-constant-bit* ,thing))


(defmacro dependent-formulas (slots position)
  `(aref ,slots (1+ ,position)))

(defsetf dependent-formulas (slots position) (value)
  `(setf (aref ,slots (1+ ,position)) ,value))




;;; -------------------------------------------------- List-or-variable code


;;; Execute the <body> on each element of the <list>, or only once if the
;;; <list> is a single value.
;;;
(defmacro do-one-or-list ((var list &optional use-continue) &body body)
  `(let* ((do-one-list ,list)
	  (,var (if (listp do-one-list) (car do-one-list) do-one-list)))
    (block nil
      (tagbody
       again
	 (if (null do-one-list)
	     (return-from nil nil))
	 ,@body
       ,@(if use-continue
	   '(endbody))
	 (if (not (listp do-one-list))
	     (return-from nil nil))
	 (setq do-one-list (cdr do-one-list)
	       ,var (car do-one-list))
	 (go again)))))



(defmacro push-one-or-list (item accessor-form &optional check-new-p)
  `(let ((current ,accessor-form))
    (if (null current)
      (setf ,accessor-form ,item)
      (if (listp current)
	,@(if check-new-p
	    `((if (not (member ,item current))
	      (setf ,accessor-form (cons ,item ,accessor-form))))
	    `((setf ,accessor-form (cons ,item ,accessor-form))))
	,@(if check-new-p
	    `((if (not (eq ,item current))
		(setf ,accessor-form (list ,item current))))
	    `((setf ,accessor-form (list ,item current))))))))



;;; Allow the current iteration of do-one-or-list to be terminated
;;; prematurely.
;;;
(defmacro continue-out ()
  `(go endbody))



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


;;; returns the formula in a dependency
;;; 
(defmacro get-dependent-formula (dependency)
  `(car ,dependency))


(defmacro last-slot-bits (slots position)
  (if (numberp position)
    `(aref ,slots ,(1+ position))
    `(aref ,slots (1+ ,position))))


(defmacro last-slot-dependents (slots position)
  (if (numberp position)
    `(aref ,slots ,(+ 2 position))
    `(aref ,slots (+ 2 ,position))))


(defmacro slot-accessor (schema sl)
  (if (keywordp sl)
    ;; Slot name is known at compile time.
    (if (get sl :KR-FAST-ACCESSOR)
      ;; Slot name is a special name
      `(values (aref (schema-slots ,schema) ,(get sl :KR-FAST-ACCESSOR))
	,(get sl :KR-FAST-ACCESSOR))
      ;; Slot name is not a special name.
      `(find-extra-slot ,schema ,sl))
    ;; Slot name is only known at runtime.
    `(find-slot-by-name ,schema ,sl)))



(defmacro set-slot-accessor (schema slot value bits)
  (if (keywordp slot)
    ;; Slot name is known at compile time.
    (let ((accessor (get slot :KR-FAST-ACCESSOR)))
      (if accessor
	;; special slot
	`(let ((slots (schema-slots ,schema)))
	  (setf (aref slots ,accessor) ,value)
	  (setf (aref slots ,(1+ accessor)) ,bits))
	;; extra slot
	`(set-extra-slot ,schema ,slot ,value ,bits)))
    ;; Slot name is unknown at compile time.
    `(let ((accessor (get ,slot :KR-FAST-ACCESSOR)))
      (if accessor
	(let ((slots (schema-slots ,schema)))
	  (setf (aref slots accessor) ,value
		(aref slots (1+ accessor)) ,bits))
	(set-extra-slot ,schema ,slot ,value ,bits)))))



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


;;; A few specialized accessors for formula slots.
;;;


;;; The "slots" structure slot, which is defined by the <schema> defstruct, is
;;; not used in formulas, so we reuse it to store the formula number.
;;;
(defmacro a-formula-number (formula)
  `(a-formula-slots ,formula))

(defmacro set-formula-number (formula value)
  `(setf (a-formula-slots ,formula) ,value))

(defmacro on-schema (formula)
  `(a-formula-schema ,formula))


(defmacro on-slot (formula)
  `(a-formula-slot ,formula))


;;; 
(defmacro cached-value (thing)
  `(a-formula-cached-value ,thing))

(defmacro cache-is-valid (thing)
  `(logbitp 0 (a-formula-number ,thing)))


(defmacro set-cache-is-valid (thing value)
  (if value
      `(set-formula-number ,thing (logior (a-formula-number ,thing) 1))
      `(set-formula-number ,thing
	(logand (a-formula-number ,thing) ,(lognot 1)))))


(defmacro cache-mark (thing)
  `(logand (a-formula-number ,thing) ,(lognot 1)))

(defmacro set-cache-mark (thing mark)
  `(set-formula-number ,thing
    (logior (logand (a-formula-number ,thing) 1) ,mark)))



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


;;; Iterate the <body> for all the slots in the <schema>, with the variable
;;; <slot> bound to each slot in turn.
;;; If <everything> is T, even slots which contain *no-value* (but with same
;;; bit set) are used.
;;; 
(defmacro iterate-accessor ((a-schema &optional (inherited T) (everything NIL))
			    &body body)
  `(unless (formula-p ,a-schema)
     (do* ((it-slots (schema-slots ,a-schema))
	   (length (length it-slots))
	   (i 0 (+ i *slot-size* -1))	; position of slot value
	   (n 0 (1+ n))
	   (slot-names *schema-slots*)	; where we get slot names from
	   slot)
	  ((>= i length))
       (if (= n *special-slots-length*)
	 (setf slot-names it-slots))	; slot names are in slot array
       ;; Get the name for this slot
       (if (eq slot-names it-slots)
	 (setf slot (aref slot-names i)
	       i (1+ i))
	 (setf slot (aref slot-names n)))
       ;; Does the slot exist?
       (when (or (not (eq (aref it-slots i) *no-value*))
		 ,(if everything
		      `(not (zerop (aref it-slots (1+ i))))   ; any bits?
		    NIL))		; any value?
	 ;; This slot exists
	 ,@(if inherited
	       ;; Either local or inherited will do.
	       body
	       ;; Make sure that the slot is not inherited.
	       `((unless (is-inherited (aref it-slots (1+ i)))
		   ,@body)))))))



;;; Similar, but sets both SLOT and VALUE.
;;;
(defmacro iterate-slot-value ((a-schema inherited everything check-formula-p)
			      &body body)
  `(,@(if check-formula-p `(if (not (formula-p ,a-schema))) '(progn))
    (do* ((array (schema-slots ,a-schema))
	  (length (length array))
	  (position 0 (+ position *slot-size* -1))   ; position of slot value
	  (n 0 (1+ n))
	  (slot-names *schema-slots*)	; where we get slot names from
	  slot value)
	 ((>= position length))
      (if (= n *special-slots-length*)
	(setf slot-names array))	; slot names are in slot array
      ;; Get the name for this slot
      (if (eq slot-names array)
	(setf slot (aref slot-names position)
	      position (1+ position))
	(setf slot (aref slot-names n)))
      ;; Does the slot exist?
      (when (or (not (eq (setf value (aref array position)) *no-value*))
		,(if everything
		   `(not (zerop (aref array (1+ position)))) ; any bits?
		   NIL))		; any value?
	;; This slot exists
	,@(if inherited
	    ;; Either local or inherited will do.
	    body
	    ;; Make sure that the slot is not inherited.
	    `((unless (is-inherited
		       (aref array (1+ position)))
		,@body)))))))



;;;; DOSLOTS
;;;
;;; Executes the <body> with <slot> bound in turn to each slot in the <schema>.
;;; 
(defmacro doslots ((slot-var a-schema &optional inherited) &body body)
  `(iterate-accessor (,a-schema ,inherited)
     (let ((,slot-var slot))
       ,@body)))



;;;; GET-LOCAL-VALUE
;;; 
(defmacro get-local-value (schema slot)
  (let ((accessors (if (keywordp slot) (get slot :kr-fast-accessor)))
	(schema-form (if (symbolp schema) schema 'schema)))
    (if accessors
	`(let* (,@(unless (symbolp schema) `((schema ,schema)))
		  (slots (schema-slots ,schema-form))
		  (value (aref slots ,accessors)))
	   (if (not (logbitp *inherited-bit*
			     ;; access directly the inherited bit
			     (aref slots ,(1+ accessors))))
	       (if (not (eq value *no-value*)) value)))
      `(let ((value (find-the-local-slot ,schema ,slot)))
	 (if (not (eq value *no-value*)) value)))))



;;; Compatibility only!
;;; 
(defmacro get-local-values (schema slot)
  `(get-local-value ,schema ,slot))



;;; This macro is used by macros such as GV or G-VALUE, which can
;;; be called with any number of slot names and expand into
;;; a nested chain of calls to <accessor-function>.
;;; 
(defmacro expand-accessor (accessor-function schema &rest slots)
  (if slots
      ;; At least one slot was specified.
      (let ((kernel schema))
	;; "Grow" the kernel by wrapping more gv-fn's around it
	(do ((slot slots (cdr slot)))
	    ((null slot))
	  (setf kernel
		`(,accessor-function ,kernel ,(car slot))))
	kernel)
      ;; No slots!
      (error "expand-accessor: at least one slot is required")))



;;;; WITH-CONSTANTS-DISABLED
;;; 
;;; Execute the <body> with constant processing disabled.
;;; 
(defmacro with-constants-disabled (&body body)
  `(let ((*constants-disabled* t))
     ,@body))


;;;; WITH-DEMONS-DISABLED
;;; 
;;; Execute the <body> with pre- and post-demons disabled.
;;; 
(defmacro with-demons-disabled (&body body)
  `(let ((*demons-disabled* t))
     ,@body))



;;;; WITH-DEMON-DISABLED
;;; 
;;; Execute the <body> with a specific demon disabled.
;;; 
(defmacro with-demon-disabled (demon &body body)
  `(let ((*demons-disabled* (disable-a-demon ,demon)))
    ,@body))




;;;; WITH-DEMON-ENABLED
;;; 
;;; Execute the <body> with a specific demon disabled.
;;; 
(defmacro with-demon-enabled (demon &body body)
  `(let ((*demons-disabled* (enable-a-demon ,demon)))
    ,@body))



;;;; RELATION-P
;;; 
(defmacro relation-p (slot)
  `(assoc ,slot *relations*))



;;;; GET-VALUE
;;; 
(defmacro get-value (schema slot)
  (let ((accessors (if (keywordp slot) (get slot :KR-FAST-ACCESSOR)))
	(schema-form (if (symbolp schema) schema 'schema)))
    `(let* (,@(unless (symbolp schema) `((schema ,schema)))
	    (value
	     ,@(cond
		 (accessors
		  ;; special slot
		  `(#+GARNET-DEBUG
		    (if (null ,schema-form)
		      (progn
			(format
			 t
			 "----  GET-VALUE on a null object (slot ~S)~%" ,slot)
			(break))
		      (aref (schema-slots ,schema-form) ,accessors))
		    #-GARNET-DEBUG
		    (aref (schema-slots ,schema-form) ,accessors)))
		 ((keywordp slot)
		  ;; not special
		  `((find-extra-slot ,schema-form ,slot)))
		 (t
		  `((find-slot-by-name ,schema-form ,slot))))))
      (if (eq value *no-value*)
	,@(if (member slot *local-slots*)
	    ;; slots such as :IS-A-INV should never be inherited!
	    `(NIL)
	    `((if (eq (setf value
			    (g-value-inherit-values ,schema-form ,slot T nil))
		      *no-value*)
		nil
		value)))
	;; we have a value
	value))))



;;; GET-VALUES
;;; 
(defmacro get-values (schema slot)
  `(let ((values (get-value ,schema ,slot)))
     (if (listp values)
	 values
	 (list values))))


;;; Does the actual work of G-VALUE
;;; 
(defmacro g-value-fn (schema slot)
  (let ((accessors (if (keywordp slot) (get slot :kr-fast-accessor))))
    `(value-fn ,schema ,slot
      ,@(cond (accessors `(,accessors))
	      ((keywordp slot) `(nil))
	      (t `(T))))))



;;;; G-VALUE
;;; This macro expands into nested calls to g-value-fn.  For example:
;;; (g-value schema :slot1 :slot2 :slot3 5) expands into
;;; (g-value-fn (g-value-fn (g-value-fn schema :slot1 0) :slot2 0) :slot3 5)
;;; 
(defmacro g-value (schema &rest slots)
  (if slots
      `(expand-accessor g-value-fn ,schema ,@slots)
    `(progn ,schema)))



;;; Similar to g-value-fn, but no inheritance.
;;;
(defmacro g-local-value-fn (schema slot)
  `(local-value-fn ,schema ,slot))



;;;; G-LOCAL-VALUE
;;;
(defmacro g-local-value (schema &rest slots)
  (if slots
      `(expand-accessor g-local-value-fn ,schema ,@slots)
      `(progn ,schema)))



;;; Looks in the :UPDATE-SLOTS of the <schema> to determine whether the <slot>
;;; has an associated demon.  This gives us the freedom to let different
;;; schemata have demons on possibly different slots.
;;; 
(defmacro slot-requires-demon (schema slot)
  `(let ((update (get-value ,schema, :UPDATE-SLOTS)))
    (or (eq (car update) T)
     (member ,slot update))))



;;; Execute the update demon associated with the <schema> and <slot>, if there
;;; is one.
;;; 
(defmacro run-invalidate-demons (schema slot)
  `(unless (eq *demons-disabled* T)
    (let ((demon (get-value ,schema :INVALIDATE-DEMON)))
      (if demon
	(unless (demon-is-disabled demon)
	  (if (slot-requires-demon ,schema ,slot)
	    (funcall demon ,schema ,slot nil)))))))



(defmacro run-pre-set-demons (schema slot new-value is-formula)
  `(unless (eq *demons-disabled* T)
    (if *pre-set-demon*
      (if (not (demon-is-disabled *pre-set-demon*))
	(if (slot-requires-demon ,schema ,slot)
	  (if ,@(if is-formula
		  `((not (equal
			  ,new-value
			  ,@(cond ((eq is-formula :CURRENT-FORMULA)
				   `((cached-value *current-formula*)))
				  ((eq is-formula T)
				   `((g-cached-value ,schema ,slot)))
				  (t
				   `(,is-formula))))))
		  `(T))
	      (funcall *pre-set-demon* ,schema ,slot ,new-value)))))))



;;;; S-VALUE
;;; The basic value-setting macro.
;;; 
;;; Inputs:
;;; - <schema>: the name of a schema
;;; - <slot>: name of the slot to be modified.
;;; - <value>: new value for the <slot>.
;;; 
(defmacro s-value (schema slot value)
  `(s-value-fn ,schema ,slot ,value
    ,(if (keywordp slot) (get slot :kr-fast-accessor))))



;;;; DOVALUES
;;; Executes <body> with <variable> bound to all the values of the <slot> in
;;; <schema>.
;;; 
(defmacro dovalues ((variable schema slot &key (local nil) (result nil)
			      (formulas T) (in-formula NIL))
		    &rest body)
  `(let* ((schema ,@(if (eq schema :SELF)
			`(*schema-self*)
			`(,schema)))
	  (values ,@(if local
		      (if formulas
			`((g-local-value schema ,slot))
			`((get-local-value schema ,slot)))
		      (if formulas
			(if in-formula
			    `((gv schema ,slot))
			    `((g-value schema ,slot)))
			(if in-formula
			  `((gv schema ,slot))
			  `((get-value schema ,slot)))))))
     ;; Now iterate
     (if values
       (progn
	 (unless (listp values)
	   (format t "(DOVALUES ~s ~s) does not contain a list of values!~%"
		   ,schema ,slot)
	   (setf values (list values)))
	 ;; Extra code for the case FORMULAS = T
	 (dolist (,variable values)
	   ,@(if formulas
	       ;; Generate test for formula-p, unless :FORMULAS is nil
	       `((when (formula-p ,variable)
		       #+EAGER
		       (propagate)
		       (setf ,variable
			     #+EAGER
			     (cached-value ,variable)
			     #-EAGER
			     (g-value-formula-value schema ,slot ,variable)))))
	   ,@body)))
     ,result))





;;;; CREATE-RELATION
;;;
;;; Defines a new relation with its inverses.  In <inheritance-p> is non-nil,
;;; classifies the relation as one that performs inheritance.
;;; Note that <relation> should be a slot name, not a schema.
;;; 
(defmacro create-relation (relation inheritance-p &rest inverses)
  `(let ((inverses ',inverses))
     (when ,inheritance-p
       (pushnew ,relation *inheritance-relations*)
       (dolist (inverse inverses)
	 (pushnew inverse *inheritance-inverse-relations*)))
     (unless (assoc ,relation *relations*)
       (push (cons ,relation inverses) *relations*))
     (dolist (inv inverses)
       (let ((entry (assoc inv *relations*)))
	 (if entry
	     (pushnew ,relation (cdr entry))
	     (progn
	       (push (list inv ,relation) *relations*)))))))



;;;; HAS-SLOT-P
;;; 
(defmacro has-slot-p (schema slot)
  `(multiple-value-bind (value position)
    (slot-accessor ,schema ,slot)
    (if (not (eq value *no-value*))
      (not (is-inherited (last-slot-bits (schema-slots ,schema) position))))))




;;;; SET-VALUES
;;;
;;; This is here for compatibility purposes.
;;;
(defmacro set-values (schema slot values)
  `(if (relation-p ,slot)
       (s-value ,schema ,slot (if (listp ,values) ,values (list ,values)))
       (s-value ,schema ,slot ,values)))




;;;; KR-SEND
;;; 
;;; 
(defmacro kr-send (schema slot &rest args)
  `(let* ((schema ,schema)
	  (*kr-send-parent* schema))
    ;; Do not use the name "function", which creates name conflicts because
    ;; it is already exported by the Common-Lisp package.
    (multiple-value-bind (the-function present)
	(g-local-value schema ,slot)
      (if (not present)
	(multiple-value-setq (the-function *kr-send-parent*)
	  (find-parent schema ,slot)))
      (if the-function
	;; Bind these in case call prototype method is used.
	(let ((*kr-send-self* schema)
	      (*kr-send-slot* ,slot))
	  (funcall the-function ,@args))))))



;;;; CALL-PROTOTYPE-METHOD
;;; 
(defmacro call-prototype-method (&rest args)
  `(multiple-value-bind (method *kr-send-parent*)
    (find-parent *kr-send-parent* *kr-send-slot*)
    (if method
      (let ((*kr-send-self* *kr-send-parent*))
	(funcall method ,@args)))))



;;;; APPLY-PROTOTYPE-METHOD
;;;
(defmacro apply-prototype-method (&rest args)
  `(multiple-value-bind (method the-parent)
    (find-parent *kr-send-parent* *kr-send-slot*)
    (if method
	(let ((*kr-send-self* the-parent))
	  (apply method ,@args)))))



;;;; DEFINE-METHOD
;;; 
(defmacro define-method (name class arg-list &rest body)
  (unless (keywordp name)
    (setf name (intern (symbol-name name) (find-package "KEYWORD")))
    (format t "DEFINE-METHOD takes a keyword as the method name - using ~S~%"
	    name))
  (let* ((function-name (intern (concatenate 'string
					     (symbol-name name)
					     "-METHOD-"
					     (symbol-name class)))))
    `(progn
       (defun ,function-name ,arg-list
	 ,@body)
       (s-value ,class ,name ',function-name))))



;;;; METHOD-TRACE
;;; 
(defmacro method-trace (class generic-fn)
  `(let ((fn (g-value ,class ,generic-fn))) 
    (eval `(trace ,fn))))



;;;; CREATE-SCHEMA
;;; 
;;; The keyword :OVERRIDE may be used to indicate that the schema should
;;; be kept, if it exists, and newly specified slots should simply override
;;; existing ones.  The default behavior is to wipe out the old schema.
;;; 
(defmacro create-schema (name &rest rest)
  (let ((prefix (member :NAME-PREFIX rest)))
    ;; Check that all elements of the list are well-formed, give warnings
    ;; otherwise
    (when (and prefix (null name))
      ;; We have an unnamed schema but a name prefix - use it.
      (setf name (second prefix))
      (setf prefix NIL))
    (when prefix
      (format
       t "Warning - you specified both a name and a :NAME-PREFIX option~:
       in (create-schema ~S).~%   Ignoring the :NAME-PREFIX.~%"
       name)
      (setf prefix nil))
    ;; Make the schema name known at compile time, so we do not issue
    ;; silly warnings.
    (if (and (listp name) (eq (car name) 'QUOTE))
      (proclaim `(special ,(eval name))))
    (let* ((override (not (null (member :OVERRIDE rest))))
	   (destroy (and name	     ; avoid trouble with (c-s NIL :override)
			 (not override)))
	   (slots (process-slots rest)))
      (creation-message name)
      `(do-schema-body
	,(if destroy
	   `(make-a-new-schema ,name)
	   (if (and (listp name)
		    (eq (car name) 'QUOTE)
		    (boundp (second name)))
	     (eval name)
	     `(make-a-new-schema ,name)))
	,(car slots)			; is-a
	,(not (null (member :generate-instance rest))) ; create instance
	,(null (member :delayed-processing rest)) ; process constant slots
	,override
	,@(cdr slots)))))		; slot specifiers



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


;;;; CREATE-PROTOTYPE
;;; 
(defmacro create-prototype (name &rest slots)
  `(create-schema ,name ,@slots))



;;;; CREATE-INSTANCE
;;; 
(defmacro create-instance (name class &body body)
  (dolist (element body)
    (when (and (listp element)
	       (eq (car element) :IS-A))
      (format
       t
       "CREATE-INSTANCE ~S ~S: do not specify the :IS-A slot!  Ignored.~%"
       name class)
      (setf body (remove (assoc :IS-A body) body))))
  `(create-schema ,name :GENERATE-INSTANCE
     ;; class might be nil, which means no IS-A slot
     ,@(if class `((:is-a ,class)))
     ,@body))



;;; BEGIN-CREATE-INSTANCE
;;;
;;; Processes the first half of a create-instance where constant-slot
;;; processing needs to be delayed.
;;; This should only be used for specialized applications, such as those
;;; found in aggrelists.
;;;
(defmacro begin-create-instance (name class &body body)
  (when (assoc :IS-A body)
    (format
     t
     "BEGIN-CREATE-INSTANCE ~S ~S: do not specify the :IS-A slot!  Ignored.~%"
     name class)
    (setf body (remove (assoc :IS-A body) body)))
  `(create-schema ,name :DELAYED-PROCESSING
     ;; class might be nil, which means no IS-A slot
     ,@(if class `((:is-a ,class)))
     ,@body))


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



;;; ---------------------------------------- Setf forms for several macros


(defsetf g-value s-value)

(defsetf get-values s-value)

(defsetf get-local-values s-value)



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

;;; Internal debugging function
;;; 
(defmacro with (schema slot &body form)
  `(let* ((*schema-self* (if (numberp ,schema) (s ,schema) ,schema))
	  (*schema-slot* ,slot)
	  (*current-formula* (get-value *schema-self* *schema-slot*))
	  (*warning-on-null-link* T))
     (catch 'no-link
       ,@form)))



