GARNET SOURCE CODE EXCERPTS
`
`src/kr/kr.lisp
`
`src/opal/aggregates.lisp
`
`src/opal/basics.lisp
`
`src/opal/new-defs.lisp
`
`src/opal/update.lisp
`
`src/opal/update-window.lisp
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`APPLE 1006.0001
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: KR; Base: 10 -*-
`
`
`;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
`;;; The Garnet User Interface Development Environment
`;;; Copyright (c) 1989, 1990 Carnegie Mellon University
`;;; All rights reserved. The CMU software License Agreement specifies
`;;; the terms and conditions for use and redistribution.
`;;;
`;;; If you want to use this code or anything developed as part of the
`;;; Garnet project, please contact Brad Myers (Brad.Myers@CS.CMU.EDU).
`;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
`
`
`
`
`;;; TO DO:
`;;; - G-CACHED-VALUE: multiple values!
`;;; - DESTROY-CONSTRAINT: code to set the value after formula is
`destroyed
`;;; (for multiple-value case)
`;;; - fix up APPEND-VALUE to be more efficient.
`;;; - DESTROY-SLOT and DELETE-VALUE-N : do the appropriate thing when the
`;;; slot/value being destroyed is being depended upon by others. In
`;;; particular:
`;;; - destroy-slot does NOT work for multi-formula slots;
`;;; - delete-value-n does not work at all for formula values.
`;;; - SET-VALUES must deal with demons properly!
`;;; - SET-VALUES must deal with formulas properly!
`;;; - Replace DELETE-FORMULA by DE-INSTALL-FORMULA ??
`;;; - check out the "Are we installing a formula ...?" part in s-value-n;
`is
`;;; it ever used?
`;;; - fix COPY-DOWN-FORMULAS to deal with multiple values!
`;;; - dependencies should be on a schema/slot/value basis, instead of
`simply
`;;; schema/slot. Use a 3-slot structure, which is cheaper than both an
`;;; array and a list of 3 elements.
`;;; - PROPAGATE-CHANGE: FIX FOR MULTIPLE VALUES !!!!!
`;;; - delete-value-n (check inheritance)
`;;; - set relation slots, have inheritance propagated
`;;; - check all places where formulas are assumed to be in first position
`only.
`;;; - DESTROY-SCHEMA: change last part, which says ";; Destroy formulas
`that
`;;; used to hang off slots of this schema". Check it out thoroughly.
`;;;
`
`
`;;; The KR-DEBUG package is used to intern automatically-created names
`for
`;;; unnamed schemata.
`;;;
`(in-package "KR-DEBUG")
`
`kr.lisp
`
`APPLE 1006.0002
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
` ;; the object programming interface
` DEFINE-METHOD METHOD-TRACE KR-SEND CALL-PROTOTYPE-METHOD
` CREATE-INSTANCE CREATE-PROTOTYPE
`
` *ALLOW-CHANGE-TO-CACHED-VALUE*
` WITH-DEMONS-DISABLED
` FORMULA-P
` GV GVL GV-LOCAL G-VALUE G-CACHED-VALUE
` MARK-AS-CHANGED MARK-AS-INVALID
` FORMULA O-FORMULA CHANGE-FORMULA))
`
`
`
`;;; The KR package contains the whole system and exports the functional
`;;; interface.
`;;;
`(in-package "KR")
`
`
`
`(export '(PS S NAME-FOR-SCHEMA
`
` CREATE-SCHEMA CREATE-RELATION
`
` SCHEMA-P RELATION-P IS-A-P HAS-SLOT-P
`
` GET-VALUE GET-VALUES
`
` G-LOCAL-VALUE GET-LOCAL-VALUES GET-LOCAL-VALUE
`
` DOVALUES DOSLOTS DO-PRINTABLE-SLOTS S-VALUE S-VALUE-N
`
` SET-VALUES APPEND-VALUE DELETE-VALUE-N
`
` DESTROY-SLOT DESTROY-SCHEMA DESTROY-CONSTRAINT
`
`
`
`
`
`
`
`
`
`
`
`
`
`
`(defparameter *kr-version* "1.1.27")
`
`
`;;; -------------------------------------------------- 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 (:print-function print-the-schema))
` name ; the schema name, or a number
` slots ; area for overflow slots (a plist)
` is-a ; this and the following are special slots in all schemata
` update-slots
` )
`
`
`;;; The basis KR schema (most schemata are of this type).
`;;;
`
`kr.lisp
`
`APPLE 1006.0003
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`(defstruct (a-schema (:include schema) (:print-function print-the-
`schema))
` left
` top
` width
` height
` )
`
`
`;;; 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))
`; the expression which gets evaluated to yield the value
` kr-function
` kr-depends-on ; list of schemata on which this function depends
` kr-form
`; symbolic form of the "function" (for compiled
`formulas)
` kr-schema ; schema on which this formula is installed
` kr-slot
`; slot on which this formula is installed
` cached-value
`; the cached value
` cached-number ; valid/invalid bit, and sweep mark
` kr-path ; holds cached paths
` )
`
`
`
`;;; 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))
`
`
`
`
`;;; -------------------------------------------------- Low-level slot
`access
`
`
`
`(defvar *schema-counter* 0
` "This variable is simply used to generate schema numbers for schemata
`that
` are created with (create-schema NIL).")
`
`
`
`(eval-when (eval compile load)
` (defparameter *schema-slots*
`
`kr.lisp
`
`APPLE 1006.0004
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
` '((:is-a . schema-is-a)
` (:update-slots . schema-update-slots)
` (:left . a-schema-left)
` (:top . a-schema-top)
` (:width . a-schema-width)
` (:height . a-schema-height))
` "Names and slot accessorss in a schema structure"))
`
`;;; Removed :is-a and :update-slots from *formula-slots* -- ECP 4/3/90
`(eval-when (eval compile load)
` (defparameter *formula-slots*
` '((:kr-function . a-formula-kr-function)
` (:kr-depends-on . a-formula-kr-depends-on)
` (:kr-form . a-formula-kr-form)
` (:kr-schema . a-formula-kr-schema)
` (:kr-slot . a-formula-kr-slot)
` (:cached-value . a-formula-cached-value)
` (:cached-number . a-formula-cached-number))))
`
`(eval-when (eval compile load)
` (defparameter *formula-safe-slots*
` '((:is-a . schema-is-a)
` (:update-slots . schema-update-slots)
` (:kr-function . a-formula-kr-function)
` (:kr-form . a-formula-kr-form))))
`
`
`
`(eval-when (eval compile load)
` ;; Associate the slot reference number to the slot names for special
`slots
` ;; (which are simply keywords, of course).
` (dolist (l *schema-slots*)
` (setf (get (car l) :KR-SLOT-NUMBER) (cdr l)))
` (dolist (l *formula-slots*)
` (setf (get (car l) :KR-SLOT-NUMBER) (cdr l))))
`
`
`
`;;; --------------------------------------------------
`
`
`(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 re-evaluated.
` This may be useful during debugging.")
`
`
`kr.lisp
`
`APPLE 1006.0005
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`(eval-when (compile load eval)
` (defvar *print-new-instances* T))
`
`
`(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.")
`
`
`(defvar *count-formulas* T
` "If nil, we are setting a relation slot with objects which are
`formulas,
` but should NOT be considered as such (for instance, this happens in
` inherited formulas). The relation should then be followed as is,
`rather
` than getting the value of each formula!")
`
`
`
`(defvar *use-formulas-for-inheritance* t
` "If this is NIL, formulas on relation links are NOT expanded when
`performing
` inheritance. This is needed when inside inherited formulas, which are
`all
` of the form (:IS-A another-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.")
`
`
`(defvar *allow-change-to-cached-value* T
` "If non-nil, changes to a constrained slot (i.e., a slot which contains
`a
` formula) will be reflected immediately in the formula's cached value,
`without
`
`kr.lisp
`
`APPLE 1006.0006
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
` of course modifying the formula.")
`
`
`(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 *invalidate-demon* 'invalidate-demon
` "The demon that gets called when a slot on the :update-slots of a
`schema
` is changed.")
`
`
`(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.")
`
`
`(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 printed schemata as
`structures.")
`
`
`kr.lisp
`
`APPLE 1006.0007
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`
`
`;;; --------------------------------------------------
`
`
`(defmacro slot-accessor (schema sl)
` (if (keywordp sl)
` ;; Slot name is known at compile time.
` (let ((function (get sl :KR-SLOT-NUMBER)))
`
`(if function
`
` ;; Slot name is a special name
`
` `(,function ,schema)
`
` ;; Slot name is not a special name.
`
` `(getf (schema-slots ,schema) ,sl)))
` ;; Slot name is only known at runtime, so do the right thing (this
` ;; CASE is executed at runtime, unlike the first one). This is
` ;; here mostly for safety reasons, and is not used at the user
`level.
` `(let ((function (get ,sl :KR-SLOT-NUMBER)))
`
` (if function
`
` (funcall function ,schema)
`
` (getf (schema-slots ,schema) ,sl)))))
`
`
`
`
`(defun accessor-constructor-fn (x)
` `(,(car x) (setf (,(cdr x) schema) value)))
`
`
`;;; This function's definition is computed from the current contents of
`the
`;;; list of special schema slots.
`;;; The (generated) body function is essentially a big CASE statement
`which
`;;; sets the appropriate slot.
`;;;
`(eval `(defun set-any-slot (schema the-slot value)
`
` ,(append '(case the-slot)
`
`
` (mapcar #'accessor-constructor-fn *schema-slots*)
`
`
` (mapcar #'accessor-constructor-fn *formula-slots*)
`
`
` '((t (setf (getf (schema-slots schema) the-slot)
`value))))))
`
`;;; Now compile the thingie
`(compile 'set-any-slot)
`
`
`
`;;; <value> must be a complete value descriptor.
`;;;
`(defmacro set-slot-accessor (schema sl value)
` (let ((function (get sl :KR-SLOT-NUMBER)))
`
`kr.lisp
`
`APPLE 1006.0008
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
` (if function
`
``(setf (,function ,schema) ,value)
`
`(if (keywordp sl)
`
` ;; Slot name is known at compile time, but not a special name.
`
` `(setf (getf (schema-slots ,schema) ,sl) ,value)
`
` ;; Slot name is only known at runtime, so do the right thing
`(this
`
` ;; CASE is executed at runtime, unlike the first one). This is
`
` ;; here mostly for safety reasons, and is not used at the user
`level.
`
` `(set-any-slot ,schema ,sl ,value)))))
`
`
`;;; A couple of specialized accessors for formula slots.
`;;;
`(defmacro on-schema (formula)
` `(a-formula-kr-schema ,formula))
`
`
`(defmacro on-slot (formula)
` `(a-formula-kr-slot ,formula))
`
`
`
`
`
`
`;;; Iterate the <body> for all the slots in the <schema>, with the
`variable
`;;; <slot> bound to each slot in turn.
`;;;
`(defmacro iterate-accessors ((a-schema &optional (inherited T))
`
`
`
` &body body)
` `(do* ((schema ,a-schema)
`
` (the-slot (slots-accessor schema) (cddr the-slot))
`
` (slot (car the-slot) (car the-slot)))
`
`((null the-slot)
`
` ;; Now apply to special slots as well (if they have a value, of
`course).
`
` (dolist (entry (if (a-schema-p schema)
`
`
`
` *schema-slots*
`
`
`
` *formula-safe-slots*))
`
` ,@(if inherited
`
`
` ;; simpler expression: any slot will do
`
`
` `((when (funcall (cdr entry) schema)
`
`
` (setf slot (car entry))
`
`
` ,@body))
`
`
` ;; more complex: only local slots will do
`
`
` `((let ((values (funcall (cdr entry) schema)))
`
`
` (when (and values
`
`
`
`
`(not (is-inherited values)))
`
`
` (setf slot (car entry))
`
`
` ,@body))))))
` ,@(if inherited
`
`kr.lisp
`
`APPLE 1006.0009
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`
` body
` `((let ((values (slot-accessor schema slot)))
` (when (and values
`
`
` (not (is-inherited values))
`
`
` (not (null (cdr values))))
`
` ,@body))))))
`
`
`
`
`
`
`
`
`
`
`
`
`;;; -------------------- Definitions of value-information bits.
`
`
`
`(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)
` ;; bit is 1 if any formula depends on this slot
` (defparameter *depended-bit* 2)
` ;; bit is 1 if slot contains at least one formula, 0 otherwise. It
`should
` ;; be last, since formulas can be a multi-bit field.
` (defparameter *formula-bit* 3))
`
`
`(eval-when (eval compile load)
` (defparameter *local-mask* 0)
` (defparameter *inherited-mask* (ash 1 *inherited-bit*))
` (defparameter *is-parent-mask* (ash 1 *is-parent-bit*))
` (defparameter *depended-mask* (ash 1 *depended-bit*))
` (defparameter *formula-mask* (ash 1 *formula-bit*))
` (defparameter *all-but-inherited-mask* (lognot *inherited-mask*))
` (defparameter *all-but-parent-mask* (lognot *is-parent-mask*)))
`
`(defparameter *middle-mask*
` (logior *inherited-mask* *is-parent-mask* *depended-mask*)
` "All bits but 'has formulas'")
`
`(defparameter *all-but-formula*
`
` (logior *inherited-mask* *is-parent-mask* *depended-mask*))
`
`(defparameter *no-value* (list *inherited-mask*)
` "When no value is found, use this descriptor (inherited)")
`
`(defmacro descriptor-is-inherited (thing)
` `(logbitp ,*inherited-bit* ,thing))
`
`(defmacro is-inherited (thing)
` `(logbitp ,*inherited-bit* (car ,thing)))
`
`
`kr.lisp
`
`APPLE 1006.0010
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`;;; Bind <entry> if it is a complex expression, since this macro expands
`it
`;;; twice.
`;;;
`(defmacro set-is-inherited (entry new-value)
` (if new-value
` `(setf (car ,entry) (logior (car ,entry) ,*inherited-mask*))
` `(setf (car ,entry) (logand (car ,entry) ,(lognot *inherited-
`mask*)))))
`
`
`(defmacro not-inherited (thing)
` ;; This relies on the fact the *inherited-bit* is bit 0.
` `(evenp (car ,thing)))
`
`(defmacro is-parent (thing)
` `(logbitp ,*is-parent-bit* (car ,thing)))
`
`(defmacro descriptor-is-parent (thing)
` `(logbitp ,*is-parent-bit* ,thing))
`
`(defmacro is-depended (thing)
` `(and ,thing (logbitp ,*depended-bit* (car ,thing))))
`
`(defmacro has-formulas (thing)
` `(logbitp ,*formula-bit* (car ,thing)))
`
`(defmacro set-has-formulas (thing value)
` `(if ,value
` (setf (car ,thing) (logior (car ,thing) ,*formula-mask*))
` (setf (car ,thing) (logand (car ,thing) ,(lognot *formula-
`mask*)))))
`
`
`(defmacro get-local-value (schema slot)
` `(let ((values (slot-accessor ,schema ,slot)))
` (when (and values (not (is-inherited values)))
` (cadr values))))
`
`
`(defmacro get-local-values (schema slot)
` `(let ((values (slot-accessor ,schema ,slot)))
` (and values (not-inherited values)
`
` (cdr values))))
`
`
`(defmacro slots-accessor (thing)
` `(schema-slots ,thing))
`
`(defmacro name-accessor (thing)
` `(schema-name ,thing))
`
`
`
`
`kr.lisp
`
`APPLE 1006.0011
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`
`;;; --------------------------------------------------
`
`;;; 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 (= (length slots) 1)
` ;; Supply default position (0).
` (setf slots (list (car slots) 0)))
` (if slots
` ;; At least one slot was specified.
` (let* ((last-thing (car (last slots)))
`
` (position
`
` ;; ASSUMPTION: the last of the <slots> should be either an
`
` ;; actual slot, known at compile time, or else a position
`number.
`
` ;; In other words, the last slot CANNOT be specified by an
`
` ;; expression or a variable.
`
` (cond ((keywordp last-thing)
`
`
` 0)
`
`
` (t
`
`
` (prog1
`
`
`
` (car (last slots))
`
`
` ;; Eliminate position number from list of slots.
`
`
` (setf (cdr (nthcdr (- (length slots) 2) slots))
`
`
`
` NIL)))))
`
` (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)
`
`
`
`
`
` ,(if (null (cdr slot)) position 0))))
`
`kernel)
` ;; No slots!
` (error "expand-accessor: at least one slot is required")))
`
`
`
`;;; ---------------------------------------------- CACHED VALUES
`(CONSTRAINTS)
`
`
`;;; The following macros are used to reference particular slots from the
`;;; cached value of formulas.
`
`(defmacro cached-value (thing)
` `(a-formula-cached-value ,thing))
`
`(defmacro cache-is-valid (thing)
` `(logbitp 0 (a-formula-cached-number ,thing)))
`
`
`kr.lisp
`
`APPLE 1006.0012
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`(defmacro set-cache-is-valid (thing value)
` (if value
` `(setf (a-formula-cached-number ,thing)
`
` (logior (a-formula-cached-number ,thing) 1))
` `(setf (a-formula-cached-number ,thing)
`
` (logand (a-formula-cached-number ,thing) ,(lognot 1)))))
`
`
`(defmacro cache-mark (thing)
` `(logand (a-formula-cached-number ,thing) ,(lognot 1)))
`
`(defmacro set-cache-mark (thing mark)
` `(setf (a-formula-cached-number ,thing)
`
` (logior (logand (a-formula-cached-number ,thing) 1) ,mark)))
`
`
`
`;;; --------------------------------------------------
`
`
`
`;;; Execute the <body> with pre- and post-demons disabled.
`;;;
`(defmacro with-demons-disabled (&body body)
` `(let ((*demons-disabled* t))
` ,@body))
`
`
`
`;;;; RELATION-P
`;;;
`(defmacro relation-p (slot)
` `(assoc ,slot *relations*))
`
`
`
`;;; -------------------------------------------------- MACROS
`
`
`
`;;;; DOSLOTS
`;;;
`;;; Executes the <body> with <slot> bound in turn to each slot in the
`<schema>.
`;;;
`(defmacro doslots ((slot-var a-schema) &body body)
` `(iterate-accessors (,a-schema NIL)
` (let ((,slot-var slot))
` ,@body)))
`
`
`
`;;;
`
`kr.lisp
`
`APPLE 1006.0013
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`;;;
`(defmacro get-value (schema slot)
` `(let ((value (or (slot-accessor ,schema ,slot)
`
`
` (g-value-inherit-values ,schema ,slot))))
` (cadr value)))
`
`
`;;;
`(defmacro g-value-fn (*schema-self* slot the-position)
` `(let* ((*schema-self* ,*schema-self*)
`
` (values (or (slot-accessor *schema-self* ,slot)
`
`
` (g-value-inherit-values *schema-self* ,slot)))
`
` (value ,(cond ((not (numberp the-position))
`
`
`
` `(if (zerop ,the-position)
`
`
`
` (cadr values)
`
`
`
` (nth (1+ ,the-position) values)))
`
`
`
`((zerop the-position)
`
`
`
` `(cadr values))
`
`
`
`(t
`
`
`
` `(nth ,(1+ the-position) values)))))
` (if (formula-p value)
`
` (g-value-formula-value *schema-self* ,slot value)
`
` ;; We are working with an ordinary value.
`
` value)))
`
`;;;
`(defmacro g-local-value-fn (*schema-self* slot position)
` `(let ((values (slot-accessor ,*schema-self* ,slot)))
` (when (and values
`
`
`(not (is-inherited values)))
` (let ((value (nth ,(if (numberp position)
`
`
`
` (1+ position)
`
`
`
` `(1+ ,position)) values)))
`
` (if (formula-p value)
`
` (g-value-formula-value ,*schema-self* ,slot value)
`
` ;; We are working with an ordinary value.
`
` value)))))
`
`
`
`;;;; 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)))
`
`
`
`;;;; G-LOCAL-VALUE
`
`kr.lisp
`
`APPLE 1006.0014
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`;;;
`(defmacro g-local-value (schema &rest slots)
` (if slots
` `(expand-accessor g-local-value-fn ,schema ,@slots)
` `(progn ,schema)))
`
`
`
`;;;; S-VALUE
`;;; The basic value-setting function.
`;;; NOTE:
`;;; if *allow-change-to-cached-value* is nil (the default), a slot which
`;;; contains a formula cannot be overwritten with a value, but just with
`;;; another formula.
`;;;
`(defmacro s-value (schema slot value)
` `(s-value-n ,schema ,slot 0 ,value))
`
`
`
`
`;;;; GET-VALUES
`;;;
`(defmacro get-values (schema slot)
` `(let ((values (or (slot-accessor ,schema ,slot)
`
`
` (g-value-inherit-values ,schema ,slot))))
` (when values
` (cdr values))))
`
`
`
`;;;; DOVALUES
`;;; Executes <body> with <var> bound to all the values of <slot> in
`<schema>.
`;;; Note that the values are as per get-values.
`;;;
`(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
`
`
` `(slot-accessor schema ,slot)
`
`
` `(or (slot-accessor schema ,slot)
`
`
`
` (inherit-slot-accessor schema ,slot)))))
` ;; If :IN-FORMULA is non-nil, do extra work to set up the
`dependencies.
` ,@(if in-formula
`
` `((pushnew schema (slot-accessor *current-formula* :KR-DEPENDS-
`ON))))
` ,@(if in-formula
`
` `((let ((entry (assoc ,slot
`
`
`
`
` (get-local-values schema :DEPENDED-SLOTS))))
`
`kr.lisp
`
`APPLE 1006.0015
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
` (unless entry
`
`
` ;; This slot was not yet depended on by anybody.
`
`
` (push (setf entry (list ,slot))
`
`
` (get-local-values schema :DEPENDED-SLOTS))
`
`
` (let ((the-entry (slot-accessor schema ,slot)))
`
`
` (unless the-entry
`
`
` (format t "DOVALUES: Entry is nil~%"))
`
`
` ;; Mark this value as being depended on by someone.
`
`
` (setf (car the-entry)
`
`
`
` (logior (car the-entry) *depended-mask*))))
`
` (pushnew *current-formula* (cdr entry)))))
`
` ;; Now iterate
` (cond ((null values)
`
` nil)
`
` ,@(cond ((eq local T)
`
`
` `(((is-inherited values)
`
`
` NIL)))
`
`
` ((null local)
`
`
` NIL)
`
`
` (t
`
`
` `(((and ,local
`
`
`
` (is-inherited values))
`
`
` NIL))))
`
` #+COMMENT
`
` ,@(if local
`
`
` `(((is-inherited values)
`
`
` NIL)))
`
` (t
`
` ,@(when formulas
`
`
`;; Extra code for the case FORMULAS = T
`
`
``((let ((has-f (has-formulas values)))
`
`
` (dolist (,variable (cdr values))
`
`
` ;; Generate test for formula-p, unless :FORMULAS is nil
`
`
` (if (and has-f (formula-p ,variable))
`
`
`
` (setf ,variable
`
`
`
`
`(g-value-formula-value schema ,slot ,variable)))
`
`
` ,@body))))
`
` ,@(unless formulas
`
`
`;; Less code for the case FORMULAS = NIL
`
`
``((dolist (,variable (cdr values))
`
`
` ,@body)))))
` ,result))
`
`
`
`
`;;; 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)
` `(member ,slot (get-value ,schema, :UPDATE-SLOTS)))
`
`
`kr.lisp
`
`APPLE 1006.0016
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`
`
`
`;;; ---------------------------------------- Setf forms for several
`macros
`
`(defsetf slot-accessor set-slot-accessor)
`
`(defsetf g-value s-value)
`
`(defsetf get-values set-values)
`
`(defsetf get-local-values set-values)
`
`
`
`
`;;; -------------------------------------------------- INTERNALS
`
`
`;;; This is for internal use only.
`(defun get-value-function (schema slot)
` (let* ((value (or (slot-accessor schema slot)
`
`
` (g-value-inherit-values schema slot))))
` (cadr value)))
`
`
`
`
`(defun get-values-function (schema slot)
` (cdr (or (slot-accessor schema slot)
`
` (g-value-inherit-values schema slot))))
`
`
`
`
`;;; Internal function. Like GET-VALUE, but takes a position parameter.
`;;;
`(defun get-value-n (schema slot position)
` (elt (or (slot-accessor schema slot)
`
` (g-value-inherit-values schema slot)) (1+ position)))
`
`
`
`;;; -------------------------------------------------- PRINTING AND
`DEBUGGING
`
`
`(defparameter *debug-names-length* 500)
`
`(defvar *debug-names* (make-array *debug-names-length*))
`(defvar *debug-index* -1)
`
`
`kr.lisp
`
`APPLE 1006.0017
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`54
`
`
`(defvar *intern-unnamed-schemata* T
` "This variable may be set to NIL to prevent PS from automatically
`creating
` any unnamed schemata it prints out.")
`
`
`
`;;; This version does not cause any creation of symbol. It simply
`records
`;;; the schema in an array, thus creating a semi-permanent way to refer
`;;; to a schema.
`;;;
`(defun cache-schema-name (schema name)
` (unless (find-if #'(lambda (x)
`
`
` (and x (eql (name-accessor x) name)))
`
`
` *debug-names*)
` ;; A new schema. Store it in the next position (cycle if
` ;; we reach the end of the array).
` (setf (aref *debug-names*
`
`
`(setf *debug-index*
`
`
` (mod (incf *debug-index*) *debug-names-length*)))
`
` schema)))
`
`
`
`;;; This version creates symbols for all automatic schema names that
`happen to
`;;; be printed out.
`;;;
`(defun make-new-schema-name (schema name)
` (let* ((debug-package (find-package "KR-DEBUG"))
`
` parent
`
` (symbol (intern (cond ((stringp name)
`
`
`
`
`;; a name-prefix schema
`
`
`
`
`(format nil "~A-~D"
`
`
`
`
`
`name (incf *schema-counter*)))
`
`
`
` ((setf parent (get-value schema :is-a))
`
`
`
`
`(let ((parent-name (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)))
`
`kr.lisp
`
`APPLE 1006.0018
`
`

`

`1
`2
`3
`4
`5
`6
`7
`8
`9
`10
`11
`12
`13
`14
`15
`16
`17
`18
`19
`20
`21
`22
`23
`24
`25
`26
`27
`28
`29
`30
`31
`32
`33
`34
`35
`36
`37
`38
`39
`40
`41
`42
`43
`44
`45
`46
`47
`48
`49
`50
`51
`52
`53
`
`
`
`
`(defun print-the-schema (schema stream level)
` (declare (ignore level))
` (let ((name (schema-name schema)))
` ;; This version is for debugging. Record the latest schemata in the
` ;; array.
` (cond ((or (integerp name) (stringp name))
`
` ;; This is a nameless schema. Print it out, and record it in
`the
` ;; debugging array.
`
` (if *intern-unnamed-schemata*
`
` (make-new-schema-name schema name))
`
` (cache-schema-name schema name)
`
` ;; This gives control over whether unnamed schemata are
`
`interned.
`
` (setf name (schema-name schema)))
`
` ((null name)
`
` ;; This was a deleted schema
`
` (setf name '*DESTROYED*)))
` (if *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 ">"))
`
`(format stream "~S" name))))
`
`
`
`;;;; NAME-FOR-SCHEMA
`;;; Given a schema, returns its string name.
`;;; Note that this returns the pure name, without the #k<> notation.
`;;;
`(defun name-for-schema (schema)
` "Given a schema, returns its printable name as a string. The string
` CANNOT be destructively modified."
` (let ((name (schema-name schema)))
` (when (or (integerp name) (stringp name))
` ;; This is a nameless schema. Print it out, and record it in the
` ;; debugging array.
` (if *intern-unnamed-schemata*
`
` (make-new-schema-name schema name))
` (cache-schema-name schema name)
` ;; This gives control over whether unnamed s