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