git.fiddlerwoaroof.com
Browse code

(init)

Ed Langley authored on 10/11/2019 08:50:56
Showing 12 changed files
kr.asd
History View file @ 6e35003
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,20 @@
1 
+(in-package :asdf-user)
2 
+
3 
+(asdf:defsystem :org.kr
4 
+  :depends-on (:cl-fad)
5 
+  :license "MIT-ish (also public domain, see LICENSE)"
6 
+  :author "CMU Garnet Team (plus various others, see LICENSE)"
7 
+  :description " GUI toolkit (c. 1990 look/feel)"
8 
+  :components ((:file "package")
9 
+               (:module utils
10 
+                :pathname "utils"
11 
+                :components ((:file "general")
12 
+                             (:file "global")))
13 
+               (:module kr
14 
+                :pathname "kr"
15 
+                :depends-on (utils)
16 
+                :components ((:file "kr-macros")
17 
+                             (:file "kr-doc")
18 
+                             (:file "kr")
19 
+                             (:file "constraints" :depends-on (kr))))))
20 
+
kr/constraints.lisp
History View file @ 6e35003
0 21 
new file mode 100644
... ... 
@@ -0,0 +1,741 @@
1 
+;;; -*- Mode: LISP; Package: KR; Base: 10; Syntax: Common-Lisp -*-
2 
+
3 
+;;*******************************************************************;;
4 
+;;          The Garnet User Interface Development Environment.       ;;
5 
+;;*******************************************************************;;
6 
+;;  This code was written as part of the Garnet project at           ;;
7 
+;;  Carnegie Mellon University, and has been placed in the public    ;;
8 
+;;  domain.                                                          ;;
9 
+;;*******************************************************************;;
10 
+
11 
+;;; $Id::                                                             $
12 
+;;;
13 
+
14 
+(in-package :kr)
15 
+
16 
+(defvar *setup-dependencies* T
17 
+  "If T (the default), dependencies are set up whenever GV and GVL are
18 
+   evaluated inside formulas.  If nil, no dependencies are set up.")
19 
+
20 
+;;; Fixed-path code.
21 
+;;
22 
+
23 
+(defun fixed-path-accessor (schema slots path-number)
24 
+  (let* ((current (a-formula-path *current-formula*))
25 
+	 (length (length current)))
26 
+    (or (and (< path-number length)
27 
+	     (elt current path-number))
28 
+	(progn
29 
+	  (dolist (slot slots)
30 
+	    (setf schema (g-value schema slot))
31 
+	    (when (listp schema)
32 
+	      ;; This handles relation slots, which are ALWAYS stored as
33 
+	      ;; a list.
34 
+	      (setf schema (first schema))))
35 
+	  (unless (> length path-number)
36 
+	    ;; create more storage
37 
+	    (setf current
38 
+		  (setf (a-formula-path *current-formula*)
39 
+			(append current
40 
+				(make-list (- path-number length -1))))))
41 
+	  (setf (elt current path-number) schema)
42 
+	  schema))))
43 
+
44 
+(defmacro kr-path (path-number &rest slots)
45 
+  `(fixed-path-accessor *schema-self* ',slots ,path-number))
46 
+
47 
+
48 
+;;; FORMULAS
49 
+;;
50 
+
51 
+;; Reuses one of the destroyed formulas, or allocates one if none exist.
52 
+;; FMG Note: *reuse-formulas* is set to nil to defeat this.
53 
+(defun make-new-formula ()
54 
+  (let ((f (formula-pop)))
55 
+    (if f
56 
+	;; Reuse a formula
57 
+	(progn
58 
+	  (setf (a-formula-depends-on f) nil)
59 
+	  (setf (a-formula-cached-value f) nil)
60 
+	  (setf (a-formula-path f) nil)
61 
+	  (setf (a-formula-is-a f) nil)
62 
+	  (setf (a-formula-function f) nil)
63 
+	  (setf (a-formula-lambda f) nil)
64 
+	  (setf (a-formula-is-a-inv f) nil))
65 
+	;; No formulas to reuse
66 
+	(setf f (make-a-formula))
67 
+	)
68 
+    (set-formula-number f 0)
69 
+    f))
70 
+
71 
+(defun formula-fn (form &optional (initial-value nil) meta)
72 
+  "Creates an interpreted formula.  The <form> can be either a Lisp expression
73 
+ (which is used as the body of the formula), or another formula.  In the
74 
+ latter case, the other formula is made the parent, and this function
75 
+ creates an inherited formula.  The <initial-value>, which defaults to nil,
76 
+ is used as the initial cached value before the formula is evaluated."
77 
+  (locally (declare #.*special-kr-optimization*)
78 
+    (let ((formula (make-new-formula)))
79 
+      (setf (schema-name formula) (incf *schema-counter*))
80 
+      (setf (cached-value formula) initial-value)
81 
+      (setf (a-formula-meta formula) meta)
82 
+      (if (formula-p form)
83 
+	  ;; We were passed an object which is already a formula.  Link to it.
84 
+	  (progn
85 
+	    ;; See if we need to make the meta-schema inherit from the formula's
86 
+	    ;; parent.
87 
+	    (when meta
88 
+	      (let ((parent-meta (find-meta form)))
89 
+		(when parent-meta
90 
+		  (s-value meta :is-a (list parent-meta)))))
91 
+	    (setf (a-formula-is-a formula) form)
92 
+	    (setf (a-formula-function formula) (a-formula-function form))
93 
+	    (setf (a-formula-lambda formula) (a-formula-lambda form))
94 
+	    (push-one-or-list formula (a-formula-is-a-inv form)))
95 
+	  ;; Normal case: we were given a Lisp expression
96 
+	  (progn
97 
+	    (setf (a-formula-function formula)
98 
+		  ;; This version does not work with CL version 2.  It is,
99 
+		  ;; however, much more efficient than calling the compiler.
100 
+		  #-(or CMU ANSI-CL)
101 
+		  `(lambda () ,form)
102 
+		  ;; This version works with CL version 2.
103 
+		  #+(or CMU ANSI-CL)
104 
+		  (compile nil `(lambda () ,form))
105 
+		  )
106 
+	    (setf (a-formula-lambda formula) form)))
107 
+      formula)))
108 
+
109 
+
110 
+;; FORMULA
111 
+;; This version stores the formula as an INTERPRETED lambda.
112 
+;; If <initial-value> is supplied, it is stored as the cached value for the
113 
+;; formula; the formula, however, is still marked invalid.
114 
+;;
115 
+(defmacro formula (form &optional (initial-value nil) &rest slots)
116 
+  (if slots
117 
+      `(formula-fn ,form ,initial-value (create-schema nil ,@slots))
118 
+      `(formula-fn ,form ,initial-value NIL)))
119 
+
120 
+(declaim (inline prepare-formula))
121 
+(defun prepare-formula (initial-value)
122 
+  (locally (declare #.*special-kr-optimization*)
123 
+    (let ((formula (make-new-formula)))
124 
+      (setf (schema-name formula) (incf *schema-counter*)
125 
+	    (cached-value formula) initial-value)
126 
+      #+EAGER
127 
+      (setf (a-formula-bits formula) 0
128 
+	    (a-formula-priority formula) *min-priority*)
129 
+      formula)))
130 
+
131 
+(declaim (inline prepare-formula))
132 
+(defun o-formula-fn (function lambda initial-value meta)
133 
+  (let ((formula (prepare-formula initial-value)))
134 
+    (setf (a-formula-function formula) function
135 
+	  (a-formula-lambda formula) lambda
136 
+	  (a-formula-meta formula) meta)
137 
+    formula))
138 
+
139 
+
140 
+(defmacro o-formula (form &optional (initial-value nil) &rest slots)
141 
+  "Creates compilable formulas but does not, by itself, actually
142 
+compile them."
143 
+  (let ((meta NIL))
144 
+    (when slots
145 
+      (setf meta `(create-schema nil ,@slots)))
146 
+    (cond ((listp form)
147 
+	   `(o-formula-fn
148 
+	     (function
149 
+	      (lambda ()
150 
+	       (declare #.*special-kr-optimization*)
151 
+	       ,form))
152 
+	     ,(if *store-lambdas* `(quote ,form) nil)
153 
+	     ,initial-value
154 
+	     ,meta))
155 
+	  (meta
156 
+	   `(let ((meta ,meta))
157 
+	      (if (formula-p ',form)
158 
+		  ;; Just create an inherited formula
159 
+		  (formula ',form ,initial-value meta)
160 
+		  ;; This is a real o-formula
161 
+		  (let ((formula (prepare-formula ,initial-value)))
162 
+		    (setf (a-formula-function formula)
163 
+			  (function (lambda () ,form)))
164 
+		    (setf (a-formula-lambda formula) ',form)
165 
+		    (setf (a-formula-meta formula) meta)
166 
+		    formula))))
167 
+	  (T
168 
+	   `(if (formula-p ',form)
169 
+		;; Just create an inherited formula
170 
+		(formula-fn ',form ,initial-value NIL)
171 
+		;; This is a real o-formula
172 
+		(progn
173 
+		  (let ((formula (prepare-formula ,initial-value)))
174 
+		    (setf (a-formula-function formula)
175 
+			  (function (lambda () ,form)))
176 
+		    (setf (a-formula-lambda formula) ',form)
177 
+		    formula)))))))
178 
+
179 
+
180 
+(defun make-into-o-formula (formula &optional compile-p)
181 
+  "This function can be used to change a formula that was created using
182 
+FORMULA into one that looks like it was created using O-FORMULA.  If
183 
+<compile-p> is non-nil, the lambda expression of the formula is compiled.
184 
+
185 
+RETURNS:  the <formula>
186 
+"
187 
+  (let ((form (when (listp (kr::a-formula-function formula))
188 
+		(kr::a-formula-lambda formula))))
189 
+    (when form
190 
+      (setf (kr::a-formula-function formula)
191 
+	    (if compile-p
192 
+		(compile nil `(lambda () ,form))
193 
+		(eval `(function (lambda () ,form))))))
194 
+    formula))
195 
+
196 
+
197 
+;; CHANGE-FORMULA
198 
+;;
199 
+;; Modify the function associated with a formula.  Several possible
200 
+;; combinations exist:
201 
+;; - If the function is local and there are no children, just go ahead and
202 
+;;   invalidate the formula.
203 
+;; - if the function is local and there are children, invalidate all the
204 
+;;   children formulas as well.
205 
+;; - if the function used to be inherited, replace it and eliminate the
206 
+;;   link with the parent formula.
207 
+;;
208 
+(defun change-formula (schema slot form)
209 
+  "Modifies the formula at position 0 in the <slot> of the <schema> to have
210 
+  <form> as its new function.  Inherited formulas are treated appropriately."
211 
+  (let ((formula (get-value schema slot)))
212 
+    (when (formula-p formula)
213 
+      (when (a-formula-is-a formula)
214 
+	;; This function was inherited.  Cut the IS-A link.
215 
+	(let* ((parent (a-formula-is-a formula))
216 
+	       (inv (a-formula-is-a-inv parent)))
217 
+	  (setf (a-formula-is-a-inv parent)
218 
+		(if (listp inv)
219 
+		    (delete formula inv)
220 
+		    (if (eq inv formula) NIL inv))))
221 
+	(setf (a-formula-is-a formula) NIL))
222 
+
223 
+      ;; If this formula has children, we need to invalidate them as well.
224 
+      (do-one-or-list (f-child (a-formula-is-a-inv formula))
225 
+	#-EAGER
226 
+	(set-cache-is-valid f-child nil)
227 
+	#-EAGER
228 
+	(mark-as-changed (on-schema f-child) (on-slot f-child))
229 
+	#+EAGER
230 
+	;; If this formula has children, we need to place them on the
231 
+	;; evaluation queue
232 
+	(setf *eval-queue* (insert-pq f-child *eval-queue*)))
233 
+      #-EAGER
234 
+      ;; Invalidate the formula itself.
235 
+      (set-cache-is-valid formula nil)
236 
+      #-EAGER
237 
+      (mark-as-changed schema slot)
238 
+      #+EAGER
239 
+      ;; Add the formula itself to the evaluation queue
240 
+      (setf *eval-queue* (insert-pq formula *eval-queue*))
241 
+
242 
+      ;; Record the new function.
243 
+      (setf (a-formula-function formula) `(lambda () ,form))
244 
+      ;; store the new form in the lambda slot of the formula
245 
+      (setf (a-formula-lambda formula) form))))
246 
+
247 
+
248 
+(defun move-formula (from-schema from-slot to-schema to-slot)
249 
+  "This function is used to move a formula from a slot to another.  It is
250 
+not safe to simply do (s-value new :slot (get-value old :slot)),
251 
+because this creates a formula which sits on two slots, and this is
252 
+definitely a no-no.
253 
+Any formula in to-schema.to-slot is destroyed, even if
254 
+from-schema.from-slot contains a regular value (as opposed to a formula)."
255 
+  (let ((formula (get-value from-schema from-slot)))
256 
+    (if (formula-p formula)
257 
+	(let ((value (g-value-formula-value from-schema
258 
+					    from-slot formula NIL)))
259 
+	  (eliminate-formula-dependencies formula NIL)
260 
+	  ;; Invalidate the formula.
261 
+	  (set-cache-is-valid formula nil)
262 
+	  (setf (a-formula-schema formula) NIL)
263 
+	  (setf (a-formula-slot formula) NIL)
264 
+	  (setf (a-formula-depends-on formula) NIL)
265 
+	  (set-slot-accessor from-schema from-slot value *local-mask* NIL)
266 
+	  (s-value to-schema to-slot formula))
267 
+	;; This is just a regular value, not a formula.
268 
+	(let* ((entry (slot-accessor to-schema to-slot))
269 
+	       (value (when entry (sl-value entry))))
270 
+	  (when (formula-p value)
271 
+	    (destroy-constraint to-schema to-slot))
272 
+	  (s-value to-schema to-slot formula)))))
273 
+
274 
+
275 
+(defun copy-formula (formula)
276 
+  "Makes and returns a copy of the <formula>, keeping the same initial value
277 
+and the same parent (if any)."
278 
+  (let* ((parent (a-formula-is-a formula))
279 
+	 (value (a-formula-cached-value formula))
280 
+	 (new (formula parent value)))
281 
+    (unless parent
282 
+      ;; Copy lambda expression and compiled lambda.
283 
+      (setf (a-formula-function new) (a-formula-function formula))
284 
+      (setf (a-formula-lambda new) (a-formula-lambda formula)))
285 
+    (let ((meta (a-formula-meta formula)))
286 
+      (when meta
287 
+	(let ((new-meta (create-schema nil)))
288 
+	  (setf (a-formula-meta new) new-meta)
289 
+	  (doslots (slot meta)
290 
+	    (s-value new-meta slot (g-value meta slot))))))
291 
+    new))
292 
+
293 
+(defun broken-link-throw (schema slot)
294 
+  (declare (ignore schema))
295 
+  (when *current-formula*
296 
+    ;; 1. eliminate the dependencies from the formula, since they are no
297 
+    ;; longer accurate
298 
+    #+TEST (setf (a-formula-depends-on *current-formula*) nil)
299 
+    (setf *last-formula* *current-formula*)
300 
+    ;; 2. give warning if so desired.
301 
+    (when *warning-on-null-link*
302 
+      (format
303 
+       t
304 
+       "Warning: broken link in schema ~S (last slot ~S);~%~:
305 
+	 reusing stale value in formula ~S.~%"
306 
+       *schema-self* slot *current-formula*))
307 
+    ;; 3. throw to the top level
308 
+    (throw 'no-link (a-formula-cached-value *current-formula*)))
309 
+
310 
+  ;; We get here if a GV expression was used outside a formula
311 
+  (format
312 
+   t
313 
+   "*** Current formula seems to be missing.   You may have used GV or~%~:
314 
+   ~4TGVL in an expression outside a formula.  Last slot was ~s.~%"
315 
+   slot))
316 
+
317 
+;;; Slot code
318 
+;;
319 
+
320 
+(declaim (inline slot-is-not-constant))
321 
+(defun slot-is-not-constant (schema slot)
322 
+  "RETURNS:
323 
+     T if the slot is not constant, i.e., it was not declared constant and we
324 
+     are not in the middle of a gv chain where the slot is declared a link
325 
+     constant.
326 
+"
327 
+  (let ((entry (slot-accessor schema slot)))
328 
+    (when entry
329 
+      (not (is-constant (sl-bits entry))))))
330 
+
331 
+
332 
+;; This is similar to g-value-fn, but does a few things needed for constant
333 
+;; formula checking before it does anything else.  Also, sets up
334 
+;; dependencies at the end.
335 
+;;
336 
+(defun gv-value-fn (schema slot)
337 
+  (locally (declare #.*special-kr-optimization*)
338 
+    #+GARNET-DEBUG
339 
+    (unless (or *current-formula* (schema-p schema))
340 
+      (cerror "Return NIL" "  GV attempted on the non-object ~S (slot ~S)."
341 
+	      schema slot)
342 
+      (return-from gv-value-fn NIL))
343 
+    (when (or (null schema) (deleted-p schema))
344 
+      ;; Schema was destroyed
345 
+      (broken-link-throw schema slot))
346 
+    (let* ((setup T)
347 
+	   (entry (slot-accessor schema slot))
348 
+	   (value (if entry (sl-value entry) *no-value*)))
349 
+      (when (eq value *no-value*)
350 
+	(g-value-inherit-values schema slot T entry)
351 
+	(setf entry (slot-accessor schema slot))
352 
+	(when entry (setf value (sl-value entry))))
353 
+      (when (a-formula-p value)
354 
+	;; we are working with a formula
355 
+	(setf value (g-value-formula-value schema slot value entry)
356 
+	      ;; This is necessary, because G-VALUE-FORMULA-VALUE may change
357 
+	      ;; the entry.
358 
+	      entry (slot-accessor schema slot)))
359 
+      (when *check-constants*
360 
+	(if (and entry (is-constant (sl-bits entry)))
361 
+	    ;; Constant, so do NOT set up dependencies.
362 
+	    (setf setup NIL)
363 
+	    ;; Not constant
364 
+	    (setf *is-constant* NIL))
365 
+	(setf *accessed-slots* T))
366 
+      ;; Now set up the dependencies.
367 
+      (when (and setup *current-formula*) ; do we need to set up dependencies?
368 
+	(unless entry
369 
+	  (setf entry (set-slot-accessor schema slot *no-value* 0 NIL)))
370 
+	(unless (full-sl-p entry)
371 
+	  ;; We did have an entry, but it was too small.
372 
+	  (let ((full-entry (make-full-sl)))
373 
+	    (setf (gethash slot (schema-bins schema)) full-entry)
374 
+	    (setf (sl-name full-entry) slot)
375 
+	    (if entry
376 
+		(setf (sl-value full-entry) (sl-value entry)
377 
+		      (sl-bits full-entry) (sl-bits entry))
378 
+		(setf (sl-value full-entry) value
379 
+		      (sl-bits full-entry) *local-mask*))
380 
+	    (setf entry full-entry)))
381 
+	(setup-dependency schema slot value entry))
382 
+      (unless (eq value *no-value*) value))))
383 
+
384 
+
385 
+(defmacro gv-fn-body (accessor-function)
386 
+  "Generates the body of gv-local-fn.  The only
387 
+difference is what accessor function to use."
388 
+  (let ((entry (gensym))
389 
+	(value (gensym))
390 
+	(the-value (gensym)))
391 
+    `(locally (declare ,*special-kr-optimization*)
392 
+       (when (eq schema :self)
393 
+	 (setf schema *schema-self*))
394 
+       ;; Handle special relation slots which return a list of values.  In this
395 
+       ;; case, use the first value.  This code is for backward compatibility.
396 
+       (when (listp schema)
397 
+	 (setf schema (car schema)))
398 
+       (if (schema-p schema)
399 
+	   ;; Schema is OK
400 
+	   (if (if schema (not-deleted-p schema))
401 
+	       ;; Normal case
402 
+	       (let* ((,value (,accessor-function schema slot))
403 
+		      (,entry (slot-accessor schema slot))
404 
+		      (setup T))
405 
+		 (when *check-constants*
406 
+		   (if (and ,entry (is-constant (sl-bits ,entry)))
407 
+		       ;; If slot is constant, never set up a dependency.
408 
+		       (setf setup NIL)
409 
+		       (setf *is-constant* NIL))
410 
+		   (setf *accessed-slots* T)) ; indicate we have done something
411 
+		 ;; Record the link dependency for this parent and formula
412 
+		 (when (and setup *current-formula*)
413 
+		   (let ((,the-value (if ,entry (sl-value ,entry))))
414 
+		     (setup-dependency schema slot (if (eq ,the-value *no-value*)
415 
+						       *no-value* ,value)
416 
+				       ,entry)))
417 
+		 ,value)
418 
+	       ;; A link is broken.  Get out of here!
419 
+	       (broken-link-throw schema slot))
420 
+	   ;; Error!
421 
+	   (if *current-formula*
422 
+	       ;; This happened inside a formula - broken link.
423 
+	       (progn
424 
+		 #+COMMENT ;; amickish - 6/24/93
425 
+		 (format
426 
+		  t
427 
+		  "~%****~% ~S was found in a GV or GVL expression as an object name,
428 
+but is not a valid object.  This happened in the formula
429 
+in slot ~S of ~S.~%~%"
430 
+		  schema *schema-slot* *schema-self*)
431 
+		 (broken-link-throw schema slot))
432 
+	       ;; This happened at the top level.
433 
+	       #+GARNET-DEBUG
434 
+	       (cerror "Return NIL"
435 
+		       "GV or GVL on the non-schema ~S, slot ~S (not
436 
+inside a formula)"
437 
+		       schema slot))))))
438 
+
439 
+
440 
+;;; This function is for use in formulas.  It represents a direct (i.e.,
441 
+;;; no-link) dependency.  If the <slot> of the <schema> changes, the formula
442 
+;;; will be re-evaluated.
443 
+;;;
444 
+(defun gv-fn (schema slot)
445 
+  (gv-fn-body g-value))
446 
+
447 
+
448 
+(defun setup-dependency (schema slot value entry)
449 
+  "Set up a dependency: the *current-formula* depends on the <slot> of the
450 
+<schema>."
451 
+  (when *setup-dependencies*
452 
+    (unless (formula-p *current-formula*)
453 
+      (when (eq *current-formula* :IGNORE)
454 
+	;; This is used when evaluating expressions OUTSIDE formulas (by
455 
+	;; Gilt, for example) - just do nothing.
456 
+	(return-from setup-dependency schema))
457 
+      (cerror "Return NIL"
458 
+	      " (in setup-dependency) ~S is not a formula!~%"
459 
+	      *current-formula*)
460 
+      (return-from setup-dependency NIL))
461 
+    (unless schema
462 
+      ;; A link is broken.  Get out of here!
463 
+      (broken-link-throw schema slot))
464 
+    ;; Record the link dependency for this parent and formula
465 
+    (let ((dependents (slot-dependents entry)))
466 
+      (cond ((null dependents)
467 
+	     ;; No dependents yet.
468 
+	     (if (full-sl-p entry)
469 
+		 (setf (full-sl-dependents entry) *current-formula*)
470 
+		 ;; make sure we have a place on which to hang the dependency!
471 
+		 (let ((value (if entry (sl-value entry) value))
472 
+		       (bits  (if entry (sl-bits entry) 0)))
473 
+		   (setf entry (set-slot-accessor
474 
+				schema slot value bits *current-formula*)))))
475 
+            ((listp dependents)
476 
+	     ;; List of dependents, make sure we're not there, then push
477 
+	     (if (memberq *current-formula* dependents)
478 
+		 (return-from setup-dependency NIL)
479 
+		 (setf (full-sl-dependents entry)
480 
+		       (cons *current-formula* dependents))))
481 
+            (T
482 
+	     ;; Just one dependent, make sure not the same, then make a list
483 
+	     (if (eq *current-formula* dependents)
484 
+		 (return-from setup-dependency NIL)
485 
+		 (setf (full-sl-dependents entry)
486 
+		       (list *current-formula* dependents))))))
487 
+
488 
+    ;; We reach this point only if *current-formula* was not already one
489 
+    ;; of the dependents of <schema> <slot>.
490 
+    (let ((depended (a-formula-depends-on *current-formula*)))
491 
+      (cond ((null depended)
492 
+	     (setf (a-formula-depends-on *current-formula*) schema))
493 
+	    ((listp depended)
494 
+	     (unless (memberq schema depended)
495 
+	       (setf (a-formula-depends-on *current-formula*)
496 
+		     (cons schema depended))))
497 
+	    (T
498 
+	     (unless (eq schema depended)
499 
+	       (setf (a-formula-depends-on *current-formula*)
500 
+		     (list schema depended))))))))
501 
+
502 
+;;
503 
+(defun gv-chain (schema slot-descriptors)
504 
+  "Used for chains of slots (i.e., links) in GV/GVL.  It keeps
505 
+accessing slots until the end of the link."
506 
+  (do* ((s slot-descriptors (cdr s)))
507 
+       ((null s))
508 
+    (if (setf schema (gv-value-fn
509 
+		      ;; for backwards compatibility.
510 
+		      (if (listp schema) (car schema) schema)
511 
+		      (car s)))
512 
+	;; We did get a schema.
513 
+	(when (eq schema :SELF)
514 
+	  (setf schema *schema-self*))
515 
+	;; There was no schema.  If we are in the middle, this is a broken link.
516 
+	(when (cdr s)
517 
+
518 
+	  (return (broken-link-throw schema (car s))))))
519 
+  schema)
520 
+
521 
+(defmacro gv (schema &rest slots)
522 
+  "Used in formulas. Expands into a chain of value accesses,
523 
+or a single call to gv-value-fn."
524 
+  (cond
525 
+    (slots
526 
+     (if (and (keywordp schema) (not (eq schema :SELF)))
527 
+	 ;; Missing object name!
528 
+	 (cerror
529 
+	  "Return NIL"
530 
+	  "The first argument to GV must be an object.
531 
+Found in the expression   (gv ~S~{ ~S~}) ,~:[
532 
+  which appeared at the top level (i.e., not inside any formula)~;
533 
+  in the formula on slot ~S of object ~S~]."
534 
+	  schema slots *current-formula*
535 
+	  *schema-slot* *schema-self*)
536 
+	 ;; No error
537 
+	 (if (null (cdr slots))
538 
+	     ;; This is a GV with a single slot.
539 
+	     `(gv-value-fn ,(if (eq schema :self)
540 
+				(setf schema '*schema-self*)
541 
+				schema)
542 
+			   ,(car slots))
543 
+	     ;; this is the more general case
544 
+	     `(gv-chain ,(if (eq schema :self) '*schema-self* schema)
545 
+			,@(if (find-if-not #'keywordp slots)
546 
+			      ;; Some slot is not a keyword - use list.
547 
+			      `((list ,@slots))
548 
+			      ;; All slots are keywords - use literal.
549 
+			      `((quote ,slots)))))))
550 
+    ((eq schema :self)
551 
+     `(progn *schema-self*))
552 
+    (t
553 
+     `(progn ,schema))))
554 
+
555 
+
556 
+(declaim (inline gv-local-fn))
557 
+(defun gv-local-fn (schema slot)
558 
+  "Similar to GV-VALUE-FN, but only gets local values."
559 
+  (gv-fn-body g-local-value))
560 
+
561 
+(defmacro gv-local (schema &rest slots)
562 
+  "Used in formulas. Expands into a chain of nested calls to gv-local-fn,
563 
+which creates a dependency point in a formula."
564 
+  (cond (slots
565 
+	 `(expand-accessor gv-local-fn ,schema ,@slots))
566 
+	((eq schema :self)
567 
+	 `(progn *schema-self*))
568 
+	(t
569 
+	 `(progn ,schema))))
570 
+
571 
+(defmacro gvl (name &rest names)
572 
+  "Used in formulas. Equivalent to a call to GV
573 
+with a :SELF added as the first parameter."
574 
+  `(gv *schema-self* ,name ,@names))
575 
+
576 
+(declaim (inline invalidate-demon))
577 
+(defun invalidate-demon (schema slot save)
578 
+  "This is the default invalidate demon."
579 
+  (kr-send schema :UPDATE-DEMON schema slot save))
580 
+
581 
+
582 
+(defun destroy-constraint (schema slot)
583 
+  "If the value in the <slot> of the <schema> is a formula, replace it with
584 
+  the current value of the formula and eliminate the formula.  This
585 
+  effectively eliminates the constraint on the value."
586 
+  (let* ((entry (slot-accessor schema slot))
587 
+	 (formula (if entry
588 
+		      (sl-value entry)
589 
+		      (g-value-inherit-values schema slot T entry))))
590 
+    (when (and (formula-p formula)
591 
+	       (not-deleted-p formula))	; not already deleted
592 
+      (let ((value (g-cached-value schema slot)))
593 
+	;; All children formulas are eliminated as well.
594 
+	(do-one-or-list (child (a-formula-is-a-inv formula))
595 
+	  (when (not-deleted-p child)			; do nothing if already deleted.
596 
+	    (g-value (on-schema child) (on-slot child))	; get value
597 
+	    (destroy-constraint (on-schema child) (on-slot child))))
598 
+	;; Inform dependents, even if value does not change.  This is
599 
+	;; for applications (such as C32) which need to know whether a
600 
+	;; formula is present.
601 
+	(mark-as-changed schema slot)
602 
+	(delete-formula formula T)
603 
+	;; Replace formula with its cached value.
604 
+	(set-slot-accessor schema slot value
605 
+			   ;; Keep the update-slot bit
606 
+			   (logior *local-mask* (logand (sl-bits entry)
607 
+							*is-update-slot-mask*))
608 
+			   NIL)
609 
+	NIL))))
610 
+
611 
+
612 
+
613 
+;;; INITIALIZE THE WHOLE THING
614 
+;;
615 
+
616 
+(defun initialize-kr ()
617 
+  "Called once at the 'beginning.'"
618 
+  (setf *relations* nil)
619 
+  (setf *inheritance-relations* nil)
620 
+  #+EAGER
621 
+  ;; set up the priority list
622 
+  (init-priority-list)
623 
+
624 
+  ;; Create the IS-A relation, which should come first in the list.
625 
+  (create-relation :IS-A T :IS-A-INV)
626 
+  ;; Create the default schema which controls the behavior of PS
627 
+  ;;
628 
+  (create-schema 'PRINT-SCHEMA-CONTROL
629 
+    ;; Names of slots which should be printed out first, in the right order.
630 
+    (:sorted-slots :left :top :width :height)
631 
+    ;; A list of slots and maximum numbers.  If the number of values in a slot
632 
+    ;; exceed the limit, ellipsis will be printed.
633 
+    (:limit-values '(:IS-A-INV 5) '(:COMPONENTS 20))
634 
+    ;; Maximum limit for number of values (global).
635 
+    (:global-limit-values 10)))
636 
+
637 
+
638 
+(initialize-kr)
639 
+
640 
+
641 
+(defun is-a-p (schema type)
642 
+  "Tests whether the <schema> is linked via :IS-A to schema <type>, either
643 
+  directly or through several links.  Note that (is-a-p <schema> T) returns
644 
+  true if <schema> is a schema. FMG Check that it actually is a schema, otherwise
645 
+  return NIL. This seems not to break anything but changes the behavior of this
646 
+  function."
647 
+  (locally (declare #.*special-kr-optimization*)
648 
+    ;; Profiling indicated that this function is expensive, so I tried to
649 
+    ;; avoid unnecessary repetition of tests and exit as early as possible.
650 
+
651 
+    (unless (and schema (schema-p schema))
652 
+      (return-from is-a-p nil))
653 
+
654 
+    ;; We know we've got something, and it's a schema. So if type is T
655 
+    ;; or if the schema is eq to the type, return T.
656 
+    (when (or (eq type T)
657 
+	      (eq schema type))		; (is-a-p foo foo) is true
658 
+      (return-from is-a-p T))
659 
+
660 
+    ;; The schema itself is not eq to TYPE so we have to check
661 
+    ;; the parents (inheritance).
662 
+    (if (formula-p schema)
663 
+	;; A formula (a formula is a schema).
664 
+	(if (eq (a-formula-is-a schema) type)
665 
+	    T
666 
+	    ;; No multiple inheritance, so there's only
667 
+	    ;; one parent.
668 
+	    (is-a-p (a-formula-is-a schema) type))
669 
+	;; A schema.
670 
+
671 
+	;; This seems to implement a breadth-first search. I'm not sure how much
672 
+	;; it matters but it seems like the IS-A tree would be bushy downward,
673 
+	;; not upward, so it's better to just iterate through the IS-A list
674 
+	;; once, calling is-a-p on the parents if they aren't eq to TYPE.
675 
+	#-(and)
676 
+	(or (dolist (parent (g-value schema :IS-A))
677 
+	      (when (eq parent type)
678 
+		(return T)))
679 
+	    ;; Not directly in the list: how about the parents?
680 
+	    (dolist (parent (g-value schema :IS-A))
681 
+	      (when (is-a-p parent type)
682 
+		(return t))))
683 
+
684 
+	(dolist (parent (g-value schema :IS-A))
685 
+	  (when (or (eq parent type)
686 
+		    ;; Not directly in the IS-A list: how about the parents?
687 
+		    (is-a-p parent type))
688 
+	    (return T))))))
689 
+
690 
+
691 
+(defun i-depend-on (object slot)
692 
+  "Given an object and a slot, if the <slot> contains a formula it returns
693 
+all the slots upon which the formula depends.  The result is a list of
694 
+dotted pairs, where each pair consists of a schema and a slot."
695 
+  (locally (declare #.*special-kr-optimization*)
696 
+    (if (schema-p object)
697 
+	(let ((formula (get-value object slot))
698 
+	      (dependencies nil))
699 
+	  (when (formula-p formula)
700 
+	    (do-one-or-list (schema (a-formula-depends-on formula))
701 
+	      (iterate-slot-value (schema T T T)
702 
+		(unless (eq value *no-value*)
703 
+		  (do-one-or-list (f (slot-dependents
704 
+				      kr::iterate-slot-value-entry))
705 
+		    (when (eq f formula)
706 
+		      (push (cons schema slot) dependencies)))))))
707 
+	  dependencies)
708 
+	;; An error
709 
+	(cerror
710 
+	 "Return NIL"
711 
+	 "I-DEPEND-ON called on the ~:[non-~;destroyed ~]object ~S."
712 
+	 (is-schema object) object))))
713 
+
714 
+
715 
+(declaim (inline self-old-value))
716 
+(defun self-old-value ()
717 
+  "Returns the cached value of a formula."
718 
+  (when *current-formula*
719 
+    (let ((value (a-formula-cached-value *current-formula*)))
720 
+      (if (eq value *no-value*)
721 
+	  NIL
722 
+	  value))))
723 
+
724 
+
725 
+
726 
+;;; Define basic builtin types.  These definitions must come after the
727 
+;; file KR.LISP is loaded. Note that ORDER IS CRUCIAL HERE.
728 
+;;
729 
+
730 
+(def-kr-type kr-no-type () '(satisfies no-type-error-p)
731 
+	     "No type defined for this slot")
732 
+
733 
+;; We want 0 to mean "no type".
734 
+(setf (aref types-array 0) NIL)
735 
+
736 
+;; Make this the first type
737 
+(def-kr-type kr-boolean () T
738 
+	     "Any value is legal")
739 
+
740 
+(dolist (type '(null string keyword integer number list cons schema))
741 
+  (encode-type type))
kr/kr-doc.lisp
History View file @ 6e35003
0 742 
new file mode 100644
... ... 
@@ -0,0 +1,87 @@
1 
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: :Kr -*-
2 
+;;*******************************************************************;;
3 
+;;          The Garnet User Interface Development Environment.       ;;
4 
+;;*******************************************************************;;
5 
+;;  This code was written by Russell Almond at Statistical Sciences  ;;
6 
+;;  as an independent contribution to the Garnet project at          ;;
7 
+;;  Carnegie Mellon University, and has been placed in the public    ;;
8 
+;;  domain.                                                          ;;
9 
+;;                                                                   ;;
10 
+;;  The authors of the code make no warentee expressed or implied    ;;
11 
+;;  about its utility, rather we hope that someone may find a use    ;;
12 
+;;  for it.                                                          ;;
13 
+;;*******************************************************************;;
14 
+
15 
+;;; $Id$
16 
+;;
17 
+
18 
+
19 
+;;; This package introduces a documentation convention for KR objects
20 
+;;  and provides some simple functions to read that documentation.
21 
+;;
22 
+;; The first half of the convention is easy.  Each schema can have a
23 
+;; slot called :documentation which contains information for the
24 
+;; programmer about the schema.
25 
+
26 
+;; The second half of the convention provides information about
27 
+;; slots.  This is done through the :slot-doc slot of the schema.
28 
+;; This is a paired list of the form slot-name, doc-string.
29 
+
30 
+;; The function kr:get-slot-doc (<schema> <slot>) accesses the
31 
+;; doc-string for a schema. It will search first the local slot and
32 
+;; then back through the inheritence chain to find the documentation
33 
+;; for a slot.  The function kr:set-slot-doc  (<schema> <slot>
34 
+;; <value>) will set the documentation associated with the slot.
35 
+
36 
+;; In order to prevent documentation strings from adding volume to
37 
+;; images where they are not wanted, I've added a feature switch
38 
+;; kr-doc.  This should be used to protect documentation when it is
39 
+;; not wanted (i.e., when this file has not been loaded first.)
40 
+;; Example:
41 
+;;  (kr:create-instance 'verbose-rectangle opal:rectangle
42 
+;;    #+kr-doc (:documentation "Opal:rectangle with documentation strings.")
43 
+;;    #+kr-doc (:slot-doc :left "Horizontal Co-ordinate for Rectangle."
44 
+;;		          :top "Vertical Co-ordinate for Rectangle."
45 
+;;		          :height "Vertical Extent of Rectangle."
46 
+;;		          :width "Horizontal Extent of Rectangle."
47 
+;;		          :line-style "The color, width and dashing of the border."
48 
+;;		          :filling-style "The color and shading of the interior."
49 
+;;		          :draw-function "How does drawing interact with
50 
+;;                                        objects underneath."
51 
+;;		          :visible "Is the object to be drawn?"))
52 
+
53 
+
54 
+;;; KR part of garnet must be loaded.
55 
+(in-package :kr)
56 
+
57 
+
58 
+
59 
+(defun get-slot-doc (schema slot)
60 
+  "Returns the documentation string associated with <slot> in <schema>."
61 
+  (declare (type (or Schema List) schema)
62 
+	   (type (or Keyword Symbol) slot))
63 
+  (cond ((null schema) nil)
64 
+	((consp schema)
65 
+	 (let ((doc-string (get-slot-doc (car schema) slot)))
66 
+	   (declare (type (or String Null) doc-string))
67 
+	   (if (equal nil doc-string)
68 
+	       (get-slot-doc (cdr schema) slot)
69 
+	     doc-string)))
70 
+	((schema-p schema)
71 
+	 (let ((doc-string (getf (get-local-value schema :slot-doc) slot)))
72 
+	   (if (stringp doc-string) doc-string
73 
+	     (get-slot-doc (get-local-value schema :is-a) slot))))
74 
+	(t (error "~S is not a schema or list of schemas."
75 
+		  schema))))
76 
+
77 
+
78 
+(defun set-slot-doc (schema slot doc-string)
79 
+  "Sets the documentation string associated with <slot> in <schema>."
80 
+  (declare (type Schema  schema)
81 
+	   (type (or Keyword Symbol) slot)
82 
+	   (type String doc-string))
83 
+  (let ((doc-plist (get-local-value schema :slot-doc)))
84 
+    (setf (getf doc-plist slot) doc-string)
85 
+    (s-value schema :slot-doc  doc-plist)))
86 
+
87 
+(pushnew :KR-DOC *Features*)
kr/kr-loader.lisp
History View file @ 6e35003
0 88 
new file mode 100644
... ... 
@@ -0,0 +1,38 @@
1 
+;;; -*- Mode: COMMON-LISP; Package: COMMON-LISP-USER -*-
2 
+;;
3 
+;; ______________________________________________________________________
4 
+;;
5 
+;; The Garnet User Interface Development Environment
6 
+;; Copyright (c) 1989, 1990 Carnegie Mellon University
7 
+;; All rights reserved.  The CMU software License Agreement specifies
8 
+;; the terms and conditions for use and redistribution.
9 
+;;
10 
+;; ______________________________________________________________________
11 
+
12 
+;;; $Id::                                                                $
13 
+;;
14 
+
15 
+
16 
+(in-package "COMMON-LISP-USER")
17 
+
18 
+(defparameter KR-Version-Number "2.3.4")
19 
+
20 
+(format t "Loading KR...~%")
21 
+
22 
+;; check first to see if pathname variable is set
23 
+;; (unless (boundp 'Garnet-Kr-PathName)
24 
+;;   (error
25 
+;;    "Load 'Garnet-Loader' first to set Garnet-Kr-PathName before loading KR."))
26 
+
27 
+(Defparameter Garnet-Kr-Files
28 
+  '(;; "kr-macros"
29 
+;;    "kr-doc"
30 
+;;    "kr"
31 
+    ;; "constraints"
32 
+    ))
33 
+
34 
+(dolist (file Garnet-Kr-Files)
35 
+  (garnet-load (concatenate 'string "kr:" file)))
36 
+
37 
+(setf (get :garnet-modules :kr)  t)
38 
+(format t "...Done Kr.~%")
kr/kr-macros.lisp
History View file @ 6e35003
0 39 
new file mode 100644
... ... 
@@ -0,0 +1,1454 @@
1 
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: KR; Base: 10 -*-
2 
+
3 
+;;*******************************************************************;;
4 
+;;          The Garnet User Interface Development Environment.       ;;
5 
+;;*******************************************************************;;
6 
+;;  This code was written as part of the Garnet project at           ;;
7 
+;;  Carnegie Mellon University, and has been placed in the public    ;;
8 
+;;  domain.                                                          ;;
9 
+;;*******************************************************************;;
10 
+
11 
+;;; $Id::                                                             $
12 
+;;
13 
+
14 
+(in-package "COMMON-LISP-USER")
15 
+
16 
+(defvar *debug-kr-mode* t)
17 
+
18 
+
19 
+(in-package :kr)
20 
+
21 
+(defparameter *kr-version* "2.3.4")
22 
+
23 
+(eval-when (:compile-toplevel :load-toplevel :execute)
24 
+  (defvar *special-kr-optimization*
25 
+    '(optimize
26 
+      (speed 3)
27 
+      #-allegro (safety 0) #+allegro (safety 1)
28 
+      (space 0)
29 
+      #-cmu (debug 0)
30 
+      #+cmu (debug 0.5)
31 
+      )))
32 
+
33 
+;; This enables the eager-evaluation version.
34 
+;;  Currently turned off.
35 
+
36 
+;;;     (eval-when (:execute :load-toplevel :compile-toplevel)
37 
+;;;       (unless (find :lazy *features*)
38 
+;;;         (pushnew :eager *features*)))
39 
+
40 
+
41 
+;;; Internal structures.
42 
+
43 
+;; The internal representation of a schema is as a structure, where the
44 
+;; <name> slot holds the name (or internal number) of the schema and the
45 
+;; <slots> slot holds a p-list of slot names and slot values.
46 
+;;
47 
+(defstruct (schema (:predicate is-schema)
48 
+                   (:print-function print-the-schema))
49 
+  name      ; the schema name, or a number
50 
+  bins      ; bins of lists of slots
51 
+  )
52 
+
53 
+;;;    (ts (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
54 
+;;;      (schema-bins a)) 100000)
55 
+
56 
+;;;     (defun foo (object)
57 
+;;;        (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
58 
+;;;        (schema-bins object)))
59 
+
60 
+;; SCHEMA-P
61 
+;;
62 
+;; Returns T if the <obj> is a schema which was not destroyed.
63 
+;;
64 
+(declaim (inline schema-p))
65 
+(defun schema-p (obj)
66 
+  (locally (declare #.*special-kr-optimization*)
67 
+    (and (is-schema obj)
68 
+	 ;; make sure it's not a formula, and it's not deleted.
69 
+	 (hash-table-p (schema-bins obj))
70 
+	 T)))
71 
+
72 
+;; This structure is similar to a schema, but is used to store formulas.
73 
+;; It prints out with an F instead of an S, and it uses the same positions for
74 
+;; different functions.
75 
+;;
76 
+(defstruct (a-formula (:include schema) (:print-function print-the-schema))
77 
+  #-(and)
78 
+  number			   ; valid/invalid bit, and sweep mark.  Actually stored in the
79 
+				   ; structure slot "a-formula-bins", inherited from schema.
80 
+  depends-on			   ; list of schemata on which this function depends (or single
81 
+				   ; schema if there is only one)
82 
+  schema			   ; schema on which this formula is installed
83 
+  slot				   ; slot on which this formula is installed
84 
+  cached-value			   ; the cached value
85 
+  path				   ; holds cached paths
86 
+  is-a				   ; parent formula, if any
87 
+  function			   ; executable formula function
88 
+  lambda			   ; the original lambda expression, if applicable
89 
+  is-a-inv			   ; list of formulas that inherit from this one
90 
+  meta				   ; NIL, or a KR schema that contains meta-information
91 
+  #+EAGER
92 
+  priority			   ; formula's position in topological order
93 
+  #+EAGER
94 
+  bits				   ; contains the valid/invalid, visited/not-visited,
95 
+				   ; renumbered/not-renumbered, eval-q/not-eval-q, and
96 
+				   ; cycle/non-cycle bits, as well as a count of the number
97 
+				   ; of times the formula has been evaluated
98 
+  #+EAGER
99 
+  valid
100 
+  #+EAGER
101 
+  dfnumber			   ; number assigned by depth-first search
102 
+  #+EAGER
103 
+  lowlink			   ; lowest dfnumber of a node that this formula is linked to
104 
+  )
105 
+
106 
+
107 
+;; The value in a slot is represented as a structure of this type.
108 
+;;
109 
+(defstruct (sl (:print-function print-the-slot))
110 
+  name
111 
+  value
112 
+  (bits 0 :type fixnum))
113 
+
114 
+
115 
+;; This is similar; it includes room to store dependent formulas.
116 
+;;
117 
+(defstruct (full-sl (:include sl))
118 
+  dependents
119 
+  ;; demons
120 
+  )
121 
+
122 
+
123 
+;;; Variables, etc.
124 
+
125 
+(eval-when (:compile-toplevel :load-toplevel :execute)
126 
+  (defvar *store-lambdas* T
127 
+    "If NIL, lambda expressions are not stored in formulas"))
128 
+
129 
+(defvar *types-enabled* T
130 
+  "Set to T to enable type checking on s-value and formula reevaluation")
131 
+
132 
+(defvar *warning-on-create-schema* T
133 
+  "If nil, no warning is printed when create-schema is redefining an existing
134 
+  schema.")
135 
+
136 
+(defvar *warning-on-circularity* nil
137 
+  "Set this to NIL to prevent warning when a circularity is detected.")
138 
+
139 
+(defvar *warning-on-evaluation* nil
140 
+  "If non-NIL, a warning is printed every time a formula is reevaluated.
141 
+  This may be useful during debugging.")
142 
+
143 
+(defvar *warning-on-null-link* NIL
144 
+  "If non-NIL, a warning is printed when a null link is evaluated inside a
145 
+  GV (or GVL) within a formula.  This is the case when the stale value of the
146 
+  formula is reused.")
147 
+
148 
+(defvar *warning-on-disconnected-formula* T
149 
+  "If nil, no warning is printed when propagate-change sees a disconnected
150 
+  formula.")
151 
+
152 
+(eval-when (:compile-toplevel :load-toplevel :execute)
153 
+  (defvar *print-new-instances* T))
154 
+
155 
+(eval-when (:compile-toplevel :load-toplevel :execute)
156 
+  (defmacro a-local-only-slot (slot)
157 
+    `(eq ,slot :is-a-inv)))
158 
+
159 
+(defvar *setting-formula-p* nil
160 
+  "Set to T only when we are setting a slot with a formula")
161 
+
162 
+(defvar *within-g-value* nil
163 
+  "Set to non-nil within a sub-formula evaluation")
164 
+
165 
+(declaim (fixnum *sweep-mark*))
166 
+(defvar *sweep-mark* 0
167 
+  "Used as a sweep mark to detect circularities")
168 
+
169 
+(defvar *demons-disabled* nil
170 
+  "May be bound to T to cause demons NOT to be executed when a slot is set.
171 
+  If the value is a single value, or a list, ")
172 
+
173 
+(defvar *constants-disabled* NIL
174 
+  "May be bound to NIL to cause constant declarations to be ignore in
175 
+  create-instance.")
176 
+
177 
+(defvar *redefine-ok* NIL
178 
+  "May be bound to T to allow create-instance to redefine slots that were
179 
+  declare constant in the prototype.")
180 
+
181 
+(defvar *pre-set-demon* nil
182 
+  "May be bound to a function to be called as a slot is set in a schema
183 
+  with the slots new-value.")
184 
+
185 
+(defvar *slot-setter-debug* nil
186 
+  "May be bound to a function of three arguments for debugging situations
187 
+   in which it is important to know when a slot is being set, either
188 
+   indirectly of via formula re-evaluation.  The function is called with
189 
+   the object, the slot name, and the new value.")
190 
+
191 
+(defvar *schema-self* nil
192 
+  "The schema being acted upon by the accessor functions.")
193 
+
194 
+(defvar *schema-slot* nil
195 
+  "The slot in *schema-self* being acted upon by the accessor functions.")
196 
+
197 
+(defvar *current-formula* nil
198 
+  "The formula being acted upon by the accessor functions.")
199 
+
200 
+(defvar *last-formula* nil
201 
+  "Similar to *current-formula*, used for debugging only.")
202 
+
203 
+(defvar *inheritance-relations* '()
204 
+  "All relations in this list perform inheritance.")
205 
+
206 
+(defvar *inheritance-inverse-relations* '()
207 
+  "Inverses of all relations which perform inheritance.")
208 
+
209 
+(defvar *relations* '()
210 
+  "An a-list of relations known to the system, with their inverse(s).
211 
+   Used for the creation of automatic reverse-links.")
212 
+
213 
+;;;
214 
+;; FMG Make formula-reuse SMP safe. Don't like the heavy
215 
+;; conditionalization here, but where else to put it?
216 
+;;
217 
+
218 
+(defvar *formula-pool* nil)
219 
+
220 
+(defvar *formula-lock* (bordeaux-threads:make-lock))
221 
+
222 
+(defun formula-push (f)
223 
+  (bordeaux-threads:with-lock-held  (*formula-lock*)
224 
+    (push f *formula-pool*)))
225 
+
226 
+(defun formula-pop ()
227 
+  (bordeaux-threads:with-lock-held (*formula-lock*)
228 
+    (and *formula-pool* (pop *formula-pool*))))
229 
+
230 
+(defvar *schema-is-new* nil
231 
+  "If non-nil, we are inside the creation of a new schema.  This guarantees
232 
+  that we do not have to search for inverse links when creating relations,
233 
+  and avoids the need to scan long is-a-inv lists.")
234 
+
235 
+(defvar *print-as-structure* T
236 
+  "If non-nil, schema names are printed as structure references.")
237 
+
238 
+(defvar *print-structure-slots* nil
239 
+  "List of slots that should be printed when printing schemata as structures.")
240 
+
241 
+(defparameter *no-value* '(:no-value)
242 
+  "A cons cell which is used to mark the value of non-existent slots.")
243 
+
244 
+(declaim (fixnum *schema-counter*))
245 
+(defvar *schema-counter* 0
246 
+  "This variable is used to generate schema numbers for schemata that
247 
+  are created with (create-schema NIL).")
248 
+
249 
+
250 
+(declaim (fixnum *type-bits* *type-mask* *inherited-bit*
251 
+		 *is-parent-bit* *is-constant-bit* *is-update-slot-bit*
252 
+		 *is-local-only-slot-bit* *is-parameter-slot-bit*))
253 
+(eval-when (:execute :compile-toplevel :load-toplevel)
254 
+  (defparameter *type-bits* 10)  ;; # of bits for encoding type
255 
+
256 
+  (defparameter *type-mask* (1- (expt 2 *type-bits*))) ;; to extract type
257 
+
258 
+  ;; bit is 1 if slot contains inherited values, 0 for local values
259 
+  (defparameter *inherited-bit*          *type-bits*)
260 
+  ;; bit is 1 if any other schema inherited the value from here
261 
+  (defparameter *is-parent-bit*          (1+ *inherited-bit*))
262 
+  (defparameter *is-constant-bit*        (1+ *is-parent-bit*))
263 
+  (defparameter *is-update-slot-bit*     (1+ *is-constant-bit*))
264 
+  (defparameter *is-local-only-slot-bit* (1+ *is-update-slot-bit*))
265 
+  (defparameter *is-parameter-slot-bit*  (1+ *is-local-only-slot-bit*)))
266 
+
267 
+
268 
+(declaim (fixnum *local-mask* *constant-mask* *is-update-slot-mask*
269 
+		 *inherited-mask* *is-parent-mask* *clear-slot-mask*
270 
+		 *inherited-parent-mask* *not-inherited-mask*
271 
+		 *not-parent-mask* *not-parent-constant-mask*
272 
+		 *all-bits-mask*))
273 
+(eval-when (:execute :compile-toplevel :load-toplevel)
274 
+  (defparameter *local-mask* 0)
275 
+  (defparameter *constant-mask* (ash 1 *is-constant-bit*))
276 
+  (defparameter *is-update-slot-mask* (ash 1 *is-update-slot-bit*))
277 
+  (defparameter *inherited-mask* (ash 1 *inherited-bit*))
278 
+  (defparameter *is-parent-mask* (ash 1 *is-parent-bit*))
279 
+
280 
+  (defparameter *clear-slot-mask*
281 
+    (logior *local-mask* *type-mask* *constant-mask* *is-update-slot-mask*))
282 
+
283 
+  (defparameter *inherited-parent-mask*
284 
+    (logior *inherited-mask* *is-parent-mask*))
285 
+  (defparameter *not-inherited-mask* (lognot *inherited-mask*))
286 
+  (defparameter *not-parent-mask* (lognot *is-parent-mask*))
287 
+  (defparameter *not-parent-constant-mask*
288 
+    (lognot (logior *is-parent-mask* *constant-mask*)))
289 
+
290 
+  (defparameter *all-bits-mask* (lognot *type-mask*)))
291 
+
292 
+(defvar *check-constants* NIL
293 
+  "If T, first-time evaluation for the current formula.  Check whether it
294 
+   is a constant formula.")
295 
+
296 
+(defvar *is-constant* T)
297 
+
298 
+(defvar *accessed-slots* NIL
299 
+  "Tells whether any slot was accessed during formula evaluation")
300 
+
301 
+(defvar *kr-send-self* nil
302 
+  "The current schema for kr-send.")
303 
+
304 
+(defvar *kr-send-slot* nil
305 
+  "The current slot for kr-send.")
306 
+
307 
+(defvar *kr-send-parent* nil
308 
+  "The schema from which the last prototype method was obtained.")
309 
+
310 
+(defvar *create-schema-schema* nil
311 
+  "Name of the current object being defined by Create-Instance.  Used for
312 
+   debugging only.")
313 
+
314 
+
315 
+
316 
+;;; EAGER EVALUATION
317 
+
318 
+;;  Definitions of value-information bits.
319 
+
320 
+#+EAGER
321 
+(eval-when (:execute :compile-toplevel :load-toplevel)
322 
+  ;; bit is 1 if formula is part of a cycle, 0 otherwise
323 
+  (defparameter *cycle-bit* 0)
324 
+  ;; bit is 1 if formula is on the evaluation queue, 0 otherwise
325 
+  (defparameter *eval-bit* 1)
326 
+  ;; bit is 1 if the formula has been visited during a depth-first
327 
+  ;; search, 0 otherwise
328 
+  (defparameter *visited-bit* 2)
329 
+  ;; bit is 1 if the formula's priority has been renumbered during the
330 
+  ;; renumbering of a cycle, 0 otherwise
331 
+  (defparameter *renumber-bit* 3)
332 
+  ;; count keeps track of how many times the formula has been evaluated and
333 
+  ;; is called the formula's timestamp
334 
+  (defparameter *fixed-bit* 4)
335 
+  ;; indicates if formula's value is fixed on this iteration of the constraint
336 
+  ;; solver and thus should not be reevaluated
337 
+
338 
+  (defparameter *count-bit* 5)
339 
+  (defparameter *neg-count-bit* (- *count-bit*))
340 
+
341 
+  ;;; Bits in a dependency structure.
342 
+  ;; bit is 1 if the dependency is part of a cycle, 0 otherwise
343 
+  (defparameter *cycle-edge-bit* 0)
344 
+  ;; the status of a dependency is indicated by a timestamp. if the
345 
+  ;; timestamp is greater than or equal to the timestamp in the dependency's
346 
+  ;; formula, the dependency is valid; otherwise the dependency is invalid
347 
+  (defparameter *status-bit* 1)
348 
+  (defparameter *neg-status-bit* (- *status-bit*)))
349 
+
350 
+
351 
+
352 
+#+EAGER
353 
+(eval-when (:execute :compile-toplevel :load-toplevel)
354 
+  (defparameter *cycle-mask* (ash 1 *cycle-bit*))
355 
+  (defparameter *eval-mask* (ash 1 *eval-bit*))
356 
+  (defparameter *visited-mask* (ash 1 *visited-bit*))
357 
+  (defparameter *renumber-mask* (ash 1 *renumber-bit*))
358 
+  (defparameter *fixed-mask* (ash 1 *fixed-bit*))
359 
+  (defparameter *count-mask* (ash 1 *count-bit*))
360 
+  (defparameter *status-mask* (ash 1 *status-bit*))
361 
+  (defparameter *cycle-edge-mask* (ash 1 *cycle-edge-bit*)))
362 
+
363 
+
364 
+#+EAGER
365 
+(defvar *eval-queue* nil
366 
+  "Contains formulas to be evaluated")
367 
+
368 
+#+EAGER
369 
+(defvar *eval-count* 0
370 
+  "Number of times propagate has been called")
371 
+
372 
+#+EAGER
373 
+(defvar *not-within-propagate* t
374 
+  "Set to nil within propagate")
375 
+
376 
+#+EAGER
377 
+(defvar *do-not-eval-list* nil
378 
+  "Contains a list of formulas that should not be evaluated during an
379 
+  iteration of the constraint solver")
380 
+
381 
+#+EAGER
382 
+;; types of evaluation--normal, in a cycle, or evaluation of a new formula
383 
+;;
384 
+(defvar *eval-type* :normal)
385 
+
386 
+#+EAGER
387 
+(defmacro set-cycle-bit (formula value)
388 
+  `(setf (a-formula-bits ,formula)
389 
+	 (if ,value
390 
+	     (logior (a-formula-bits ,formula) ,*cycle-mask*)
391 
+	     (logand (a-formula-bits ,formula) ,(lognot *cycle-mask*)))))
392 
+
393 
+#+EAGER
394 
+(defmacro set-eval-bit (formula value)
395 
+  `(setf (a-formula-bits ,formula)
396 
+	 ,(if value
397 
+	      `(logior (a-formula-bits ,formula) ,*eval-mask*)
398 
+	      `(logand (a-formula-bits ,formula) ,(lognot *eval-mask*)))))
399 
+
400 
+
401 
+#+EAGER
402 
+(defmacro set-visited-bit (formula value)
403 
+  `(setf (a-formula-bits ,formula)
404 
+	 ,(if value
405 
+	      `(logior (a-formula-bits ,formula) ,*visited-mask*)
406 
+	      `(logand (a-formula-bits ,formula) ,(lognot *visited-mask*)))))
407 
+
408 
+#+EAGER
409 
+(defmacro set-valid-bit (formula value)
410 
+  `(if ,value
411 
+       (setf (a-formula-valid ,formula) (1- *eval-count*))
412 
+       (setf (a-formula-valid ,formula) *eval-count*)))
413 
+
414 
+#+EAGER
415 
+(defmacro set-renumber-bit (formula value)
416 
+  `(setf (a-formula-bits ,formula)
417 
+	 ,(if value
418 
+	      `(logior (a-formula-bits ,formula) ,*renumber-mask*)
419 
+	      `(logand (a-formula-bits ,formula) ,(lognot *renumber-mask*)))))
420 
+
421 
+#+EAGER
422 
+(defmacro set-fixed-bit (formula value)
423 
+  `(setf (a-formula-bits ,formula)
424 
+	 ,(if value
425 
+	      `(logior (a-formula-bits ,formula) ,*fixed-mask*)
426 
+	      `(logand (a-formula-bits ,formula) ,(lognot *fixed-mask*)))))
427 
+
428 
+#+EAGER
429 
+(defmacro prev-priority (index)
430 
+  `(aref *prev-priority-array* ,index))
431 
+
432 
+#+EAGER
433 
+(defmacro succ-priority (index)
434 
+  `(aref *succ-priority-array* ,index))
435 
+
436 
+#+EAGER
437 
+(defmacro priority-value (index)
438 
+  `(car (aref *priority-array* ,index)))
439 
+
440 
+#+EAGER
441 
+(defmacro priority-<=-p (p1 p2)
442 
+  `(<= (priority-value ,p1) (priority-value ,p2)))
443 
+
444 
+#+EAGER
445 
+(defmacro priority-<-p (p1 p2)
446 
+  `(< (priority-value ,p1) (priority-value ,p2)))
447 
+
448 
+#+EAGER
449 
+(defmacro priority-=-p (p1 p2)
450 
+  `(= ,p1 ,p2))
451 
+
452 
+#+EAGER
453 
+(defmacro priority->-p (p1 p2)
454 
+  `(> (priority-value ,p1) (priority-value ,p2)))
455 
+
456 
+#+EAGER
457 
+(defmacro priority->=-p (p1 p2)
458 
+  `(>= (priority-value ,p1) (priority-value ,p2)))
459 
+
460 
+#+EAGER
461 
+(defmacro min-priority (p1 p2)
462 
+  `(if (priority-<=-p ,p1 ,p2)
463 
+       ,p1
464 
+       ,p2))
465 
+
466 
+#+EAGER
467 
+(defmacro max-priority (p1 p2)
468 
+  `(if (priority->=-p ,p1 ,p2)
469 
+       ,p1
470 
+       ,p2))
471 
+
472 
+#+EAGER
473 
+(defmacro dolist-test-elim ((list-var list test) &body body)
474 
+  `(let ((dotest-prev ,list))
475 
+     (do ((list-vars ,list list-vars)) ; loop control handled in loop
476 
+	 ((null list-vars) ,list)
477 
+       (let ((,list-var (car list-vars)))
478 
+	 (if ,test
479 
+	     (progn
480 
+	       ,@body
481 
+	       ; update the loop variables
482 
+	       (setf dotest-prev list-vars)
483 
+	       (setf list-vars (cdr list-vars)))
484 
+	     ; if element does not meet test, remove it from the list
485 
+	     (if (eq list-vars ,list) ; if front of list
486 
+		 (progn
487 
+		   (pop list-vars)
488 
+		   (setf ,list list-vars)
489 
+		   (setf dotest-prev list-vars))
490 
+		 (progn
491 
+		   (pop (cdr dotest-prev))
492 
+		   (setf list-vars (cdr dotest-prev)))))))))
493 
+
494 
+#+EAGER
495 
+(defmacro dolist-test ((list-var list test) &body body)
496 
+  `(do ((list-vars ,list (cdr list-vars)))
497 
+      ((null list-vars))
498 
+    (let ((,list-var (car list-vars)))
499 
+      (when ,test
500 
+	,@body))))
501 
+
502 
+
503 
+;;; Low-level slot access
504 
+
505 
+;; Replace these macros with inline functions.
506 
+
507 
+;; (defmacro deleted-p (schema)
508 
+;;   `(locally (declare ,*special-kr-optimization*)
509 
+;;      (null (schema-bins ,schema))))
510 
+
511 
+;; (defmacro not-deleted-p (schema)
512 
+;;   `(locally (declare ,*special-kr-optimization*)
513 
+;;      (schema-bins ,schema)))
514 
+
515 
+;; (defmacro is-inherited (bits)
516 
+;;   `(logbitp ,*inherited-bit* ,bits))
517 
+
518 
+;; (defmacro is-parent (bits)
519 
+;;   `(logbitp ,*is-parent-bit* ,bits))
520 
+
521 
+;; (defmacro is-constant (bits)
522 
+;;   `(logbitp ,*is-constant-bit* ,bits))
523 
+
524 
+;; (defmacro is-update-slot (bits)
525 
+;;   `(logbitp ,*is-update-slot-bit* ,bits))
526 
+
527 
+;; (defmacro set-is-update-slot (bits)
528 
+;;   `(logior ,*is-update-slot-mask* ,bits))
529 
+
530 
+;; (defmacro is-local-only (bits)
531 
+;;   `(logbitp ,*is-local-only-slot-bit* ,bits))
532 
+
533 
+;; (defmacro is-parameter (bits)
534 
+;;   `(logbitp ,*is-parameter-slot-bit* ,bits))
535 
+
536 
+;; (defmacro extract-type-code (bits)
537 
+;;   `(logand ,*type-mask* ,bits))
538 
+
539 
+;; (defmacro get-entry-type-code (entry)
540 
+;;   `(locally (declare ,*special-kr-optimization*)
541 
+;;      (extract-type-code (sl-bits ,entry))))
542 
+
543 
+;; (defmacro code-to-type (type-code)
544 
+;;   `(svref types-array ,type-code))
545 
+
546 
+;; (defmacro code-to-type-fn (type-code)
547 
+;;   `(svref type-fns-array ,type-code))
548 
+
549 
+;; (defmacro code-to-type-doc (type-code)
550 
+;;   `(svref type-docs-array ,type-code))
551 
+
552 
+;; (defmacro check-kr-type (value code)
553 
+;;   `(funcall (code-to-type-fn ,code) ,value))
554 
+
555 
+
556 
+
557 
+;;; Macros.
558 
+;;  FMG Changed many of them to inline functions; tried to only leave macros
559 
+;;      that are somehow syntactic in nature.
560 
+
561 
+;; This macro will output the <forms> only if GARNET-DEBUG is defined.
562 
+;;;
563 
+(defmacro when-debug (&rest forms)
564 
+  #+GARNET-DEBUG
565 
+  `(progn ,@forms)
566 
+  #-GARNET-DEBUG
567 
+  (declare (ignore forms))
568 
+  #-GARNET-DEBUG
569 
+  nil)
570 
+
571 
+(declaim (inline
572 
+	  formula-p deleted-p not-deleted-p is-inherited is-parent is-constant
573 
+	  is-update-slot set-is-update-slot is-local-only is-parameter
574 
+	  extract-type-code get-entry-type-code))
575 
+
576 
+(defun formula-p (thing)
577 
+  (a-formula-p thing))
578 
+
579 
+(defun deleted-p (schema)
580 
+  (declare #.*special-kr-optimization*)
581 
+  (null (schema-bins schema)))
582 
+
583 
+(defun not-deleted-p (schema)
584 
+  (declare #.*special-kr-optimization*)
585 
+  (schema-bins schema))
586 
+
587 
+(defun is-inherited (bits)
588 
+  (declare (fixnum bits))
589 
+  (logbitp *inherited-bit* bits))
590 
+
591 
+(defun is-parent (bits)
592 
+  (declare (fixnum bits))
593 
+  (logbitp *is-parent-bit* bits))
594 
+
595 
+(defun is-constant (bits)
596 
+  (declare (fixnum bits))
597 
+  (logbitp *is-constant-bit* bits))
598 
+
599 
+(defun is-update-slot (bits)
600 
+  (declare (fixnum bits))
601 
+  (logbitp *is-update-slot-bit* bits))
602 
+
603 
+(defun set-is-update-slot (bits)
604 
+  (declare (fixnum bits))
605 
+  (logior *is-update-slot-mask* bits))
606 
+
607 
+(defun is-local-only (bits)
608 
+  (declare (fixnum bits))
609 
+  (logbitp *is-local-only-slot-bit* bits))
610 
+
611 
+(defun is-parameter (bits)
612 
+  (declare (fixnum bits))
613 
+  (logbitp *is-parameter-slot-bit* bits))
614 
+
615 
+(defun extract-type-code (bits)
616 
+  (declare (fixnum bits))
617 
+  (logand *type-mask* bits))
618 
+
619 
+(defun get-entry-type-code (entry)
620 
+  (declare #.*special-kr-optimization*)
621 
+  (extract-type-code (sl-bits entry)))
622 
+
623 
+;; Moved type functions to kr.lisp (to get rid of free variable warnings).
624 
+
625 
+;;; DEF-KR-TYPE
626 
+;;
627 
+;; Create a new type, which can then be used for typechecking.
628 
+;;
629 
+(defmacro def-kr-type (typename-or-type &optional args body type-doc)
630 
+  "Defines a new type for KR's type-checking mechanism.  You must define
631 
+a type using def-kr-type before you can reference that type.  There
632 
+are 2 formats for def-kr-type, one named, one un-named, as the following
633 
+examples show:
634 
+
635 
+     (def-kr-type my-named-type () '(or keyword null))
636 
+     (def-kr-type '(or keyword null))
637 
+
638 
+Note that the first format is the same syntax as Lisp's 'deftype'.
639 
+With either definition, you could then specify some object's type to be
640 
+ (OR KEYWORD NULL).  With the first defn, you could also specify the type
641 
+to be \"MY-NAMED-TYPE\".
642 
+
643 
+You can also provide a documentation string as the last parameter, as in:
644 
+     (def-kr-type my-named-type () '(or keyword null) \"Sample doc string\")"
645 
+
646 
+  (cond ((listp typename-or-type)
647 
+	   (unless (eq (car typename-or-type) 'QUOTE)
648 
+	     (error "Illegal typename to def-kr-type: ~S" typename-or-type))
649 
+	   (unless (and (null args) (null body) (null type-doc))
650 
+	     (error "Illegal specification: (DEF-KR-TYPE ~S ~S ~S ~S)"
651 
+			typename-or-type args body type-doc))
652 
+	   (setq body typename-or-type)
653 
+	   (setq typename-or-type NIL))
654 
+        (args
655 
+	   (error "DEF-KR-TYPE only works with NULL args, not ~S~%" args))
656 
+        (T
657 
+	   (setq typename-or-type (symbol-name typename-or-type))))
658 
+  (setq body (eval body))
659 
+  `(add-new-type ,typename-or-type ',body ,(type-to-fn body) ,type-doc))
660 
+
661 
+;;; List-or-value code
662 
+(defmacro memberq (item list)
663 
+  "Member, but with a test of EQ.  Interestingly, if 'item' is a keyword,
664 
+then it is faster to use the normal member fn!"
665 
+  (if (keywordp item)
666 
+  `(member ,item ,list)
667 
+  `(member ,item ,list :test #'eq)))
668 
+
669 
+
670 
+(defmacro assocq (item alist)
671 
+  "Assoc, but with a test of EQ."
672 
+  (if (keywordp item)
673 
+  `(assoc ,item ,alist)
674 
+  `(assoc ,item ,alist :test #'eq)))
675 
+
676 
+
677 
+(defmacro do-one-or-list ((var list &optional use-continue) &body body)
678 
+  "Execute the <body> on each element of the <list>, or only once if the
679 
+<list> is a single value."
680 
+  `(let* ((do-one-list ,list)
681 
+	  (,var (if (listp do-one-list) (car do-one-list) do-one-list)))
682 
+    (block nil
683 
+      (tagbody
684 
+       again
685 
+	 (if (null do-one-list)
686 
+	     (return-from nil nil))
687 
+	 ,@body
688 
+       ,@(if use-continue
689 
+	   '(endbody))
690 
+	 (if (not (listp do-one-list))
691 
+	     (return-from nil nil))
692 
+	 (setq do-one-list (cdr do-one-list)
693 
+	       ,var (car do-one-list))
694 
+	 (go again)))))
695 
+
696 
+
697 
+(defmacro push-one-or-list (item accessor-form &optional check-new-p)
698 
+  `(let ((current ,accessor-form))
699 
+    (if (null current)
700 
+      (setf ,accessor-form ,item)
701 
+      (if (listp current)
702 
+	,@(if check-new-p
703 
+	    `((if (not (member ,item current))
704 
+	      (setf ,accessor-form (cons ,item current))))
705 
+	    `((setf ,accessor-form (cons ,item current))))
706 
+	,@(if check-new-p
707 
+	    `((if (not (eq ,item current))
708 
+		(setf ,accessor-form (list ,item current))))
709 
+	    `((setf ,accessor-form (list ,item current))))))))
710 
+
711 
+
712 
+(defmacro delete-one-or-list (item accessor-form)
713 
+  `(let ((current ,accessor-form))
714 
+    (if (listp current)
715 
+      (setf ,accessor-form (delete ,item current))
716 
+      (if (eq ,item current)
717 
+	(setf ,accessor-form NIL)))))
718 
+
719 
+(defmacro continue-out ()
720 
+  "Allow the current iteration of do-one-or-list to be terminated
721 
+prematurely."
722 
+  `(go endbody))
723 
+
724 
+
725 
+(declaim (inline get-dependent-formula))
726 
+(defun get-dependent-formula (dependency)
727 
+  "Returns the formula in a dependency."
728 
+  (car dependency))
729 
+
730 
+
731 
+(declaim (inline slot-dependents))
732 
+(defun slot-dependents (slot-structure)
733 
+  (declare #.*special-kr-optimization*)
734 
+  (let ((entry slot-structure))
735 
+    (when (full-sl-p entry)
736 
+      (full-sl-dependents entry))))
737 
+
738 
+
739 
+(declaim (inline slot-accessor))
740 
+(defun slot-accessor (schema slot)
741 
+  "Returns a slot structure, or NIL."
742 
+  (values (gethash slot (schema-bins schema))))
743 
+
744 
+
745 
+(defmacro set-slot-accessor (schema slot value bits dependents)
746 
+  "Returns the slot structure it created or modified.
747 
+SIDE EFFECTS: if <dependents> is specified, the slot structure is
748 
+modified to be a full-slot structure."
749 
+  (let ((the-bins (gensym))
750 
+	(the-entry (gensym))
751 
+	(the-dependents (gensym)))
752 
+    `(let* ((,the-bins (schema-bins ,schema))
753 
+	    (,the-entry (gethash ,slot ,the-bins))
754 
+	    (,the-dependents ,dependents))
755 
+       (if ,the-entry
756 
+	   (progn
757 
+	     (when (and ,the-dependents (not (full-sl-p ,the-entry)))
758 
+	       ;; Need to use a full slot, only have a short one.
759 
+	       (setf (gethash ,slot ,the-bins) (setf ,the-entry (make-full-sl)))
760 
+	       (setf (sl-name ,the-entry) ,slot))
761 
+	     ;; Slot is present - update it.
762 
+	     (setf (sl-value ,the-entry) ,value)
763 
+	     (setf (sl-bits ,the-entry) ,bits)
764 
+	     (when ,the-dependents
765 
+	       (setf (full-sl-dependents ,the-entry) ,the-dependents))
766 
+	     ,the-entry)
767 
+	   ;; Slot is not present - create it.
768 
+	   (progn
769 
+	     (setf ,the-entry (if ,the-dependents (make-full-sl) (make-sl)))
770 
+	     (setf (sl-name ,the-entry) ,slot)
771 
+	     (setf (sl-value ,the-entry) ,value)
772 
+	     (setf (sl-bits ,the-entry) ,bits)
773 
+	     (when ,the-dependents
774 
+	       (setf (full-sl-dependents ,the-entry) ,the-dependents))
775 
+	     (setf (gethash ,slot ,the-bins) ,the-entry))))))
776 
+
777 
+
778 
+;;; A few specialized accessors for formula slots.
779 
+;;
780 
+
781 
+;; The "bins" structure slot, which is defined by the <schema> defstruct, is
782 
+;; not used in formulas, so we reuse it to store the formula number.
783 
+;; XXX This unfortunately means that we can't properly declare the slot
784 
+;; as a fixnum since it gets set to nil when the formula is destroyed.
785 
+(defmacro a-formula-number (formula)
786 
+  `(the (or null fixnum) (a-formula-bins ,formula)))
787 
+
788 
+(defmacro set-formula-number (formula value)
789 
+  `(setf (a-formula-number ,formula) ,value))
790 
+
791 
+(defmacro on-schema (formula)
792 
+  `(a-formula-schema ,formula))
793 
+
794 
+(defmacro on-slot (formula)
795 
+  `(a-formula-slot ,formula))
796 
+
797 
+(defmacro cached-value (thing)
798 
+  `(a-formula-cached-value ,thing))
799 
+
800 
+(defmacro cache-is-valid (thing)
801 
+  `(logbitp 0 (a-formula-number ,thing)))
802 
+
803 
+(defmacro set-cache-is-valid (thing value)
804 
+  (if value
805 
+      `(set-formula-number ,thing (logior (a-formula-number ,thing) 1))
806 
+      `(set-formula-number ,thing
807 
+	(logand (a-formula-number ,thing) ,(lognot 1)))))
808 
+
809 
+(defmacro cache-mark (thing)
810 
+  `(logand (a-formula-number ,thing) (lognot 1)))
811 
+
812 
+(defmacro set-cache-mark (thing mark)
813 
+  `(set-formula-number
814 
+    ,thing
815 
+    (logior (logand (a-formula-number ,thing) 1) ,mark)))
816 
+
817 
+;; This is a global because some of KR's internals want to access the
818 
+;; entry on which iterate-slot-value is working.
819 
+;;
820 
+(defparameter iterate-slot-value-entry nil
821 
+  "Ugly")
822 
+
823 
+
824 
+
825 
+;;; Iterators
826 
+
827 
+(defmacro iterate-slot-value ((a-schema inherited everything check-formula-p)
828 
+			      &body body)
829 
+"Iterate the <body> for all the slots in the <schema>, with the variable
830 
+<slot> bound to each slot in turn and the variable <value> bound to
831 
+the <slot>'s value.
832 
+If <everything> is T, even slots which contain *no-value* (but with same
833 
+bit set) are used."
834 
+  `(locally (declare ,*special-kr-optimization*)
835 
+     (,@(if check-formula-p `(if (not (formula-p ,a-schema))) '(progn))
836 
+	(maphash
837 
+	 #'(lambda (iterate-ignored-slot-name iterate-slot-value-entry)
838 
+	     (declare (ignore iterate-ignored-slot-name))
839 
+	     (let ((slot (sl-name iterate-slot-value-entry)) ; name for the slot
840 
+		   (value (sl-value iterate-slot-value-entry)))
841 
+	       ;; This slot exists
842 
+	       ,@(if inherited
843 
+		     ;; Either local or inherited will do.
844 
+		     (if everything
845 
+			 ;; Execute on a no-value, too.
846 
+			 body
847 
+			 ;; Only execute on real values.
848 
+			 `((unless (eq value *no-value*)
849 
+			     ,@body)))
850 
+		     ;; Make sure that the slot is not inherited.
851 
+		     `((unless (is-inherited (sl-bits iterate-slot-value-entry))
852 
+			 ,@(if everything
853 
+			       body
854 
+			       `((unless (eq value *no-value*)
855 
+				   ,@body))))))))
856 
+	 (schema-bins ,a-schema))
857 
+	)))
858 
+
859 
+
860 
+;; (defmacro iterate-slot-value ((a-schema inherited everything check-formula-p)
861 
+;;			      &body body)
862 
+;;   `(locally (declare ,*special-kr-optimization*)
863 
+;;     (,@(if check-formula-p `(if (not (formula-p ,a-schema))) '(progn))
864 
+;;      (print ,a-schema))))
865 
+
866 
+
867 
+(defmacro doslots ((slot-var a-schema &optional inherited) &body body)
868 
+"Executes the <body> with <slot> bound in turn to each slot in the <schema>."
869 
+  `(iterate-slot-value (,a-schema ,inherited NIL NIL)
870 
+     (let ((,slot-var slot))
871 
+       ,@body)))
872 
+
873 
+
874 
+(declaim (inline get-local-value))
875 
+(defun get-local-value (schema slot)
876 
+  (locally (declare #.*special-kr-optimization*)
877 
+    (let ((entry (slot-accessor schema slot)))
878 
+      (if (if entry (not (is-inherited (sl-bits entry))))
879 
+	  (sl-value entry)))))
880 
+
881 
+;; Compatibility only!
882 
+;;
883 
+(declaim (inline get-local-values))
884 
+(defun get-local-values (schema slot)
885 
+  (get-local-value schema slot))
886 
+
887 
+
888 
+(defmacro expand-accessor (accessor-function schema &rest slots)
889 
+"EXPAND-ACCESSOR is used by macros such as GV or G-VALUE, which can
890 
+be called with any number of slot names and expand into
891 
+a nested chain of calls to <accessor-function>."
892 
+  (if slots
893 
+      ;; At least one slot was specified.
894 
+      (let ((kernel schema))
895 
+	;; "Grow" the kernel by wrapping more gv-fn's around it
896 
+	(do ((slot slots (cdr slot)))
897 
+	    ((null slot))
898 
+	  (setf kernel
899 
+		`(,accessor-function ,kernel ,(car slot))))
900 
+	kernel)
901 
+      ;; No slots!
902 
+      (error "expand-accessor: at least one slot is required")))
903 
+
904 
+
905 
+(defmacro with-constants-disabled (&body body)
906 
+"Execute the <body> with constant processing disabled."
907 
+  `(let ((*constants-disabled* t))
908 
+     ,@body))
909 
+
910 
+
911 
+(defmacro with-types-disabled (&body body)
912 
+"Execute the <body> with type declaration processing disabled."
913 
+  `(let ((*types-enabled* nil))
914 
+     ,@body))
915 
+
916 
+
917 
+(defmacro with-dependencies-disabled (&body body)
918 
+"Execute the <body> with dependencies processing disabled."
919 
+  `(let ((*setup-dependencies* nil))
920 
+     ,@body))
921 
+
922 
+
923 
+(defmacro with-demons-disabled (&body body)
924 
+"Execute the <body> with pre- and post-demons disabled."
925 
+  `(let ((*demons-disabled* t))
926 
+     ,@body))
927 
+
928 
+
929 
+(defmacro with-demon-disabled (demon &body body)
930 
+"Execute the <body> with a specific demon disabled."
931 
+  `(let ((*demons-disabled* (disable-a-demon ,demon)))
932 
+    ,@body))
933 
+
934 
+
935 
+(defmacro with-demon-enabled (demon &body body)
936 
+"Execute the <body> with a specific demon enabled (in the context
937 
+where a demon or demons are disabled)."
938 
+  `(let ((*demons-disabled* (enable-a-demon ,demon)))
939 
+    ,@body))
940 
+
941 
+
942 
+(declaim (inline relation-p))
943 
+(defun relation-p (slot)
944 
+  (assocq slot *relations*))
945 
+
946 
+
947 
+;;
948 
+(defmacro g-value-body (schema slot inherit-p formula-p)
949 
+"This implements g-value, g-local-value, get-value, and get-local-value.
950 
+If <inherit-p> is true, generates code to inherit a value; otherwise,
951 
+generates code for the local-only case.
952 
+If <formula-p> is true, generates code to evaluate formulas; otherwise,
953 
+the formula object itself is returned."
954 
+  (let ((schema-form (if (symbolp schema) schema 'schema))
955 
+	(entry (gensym))
956 
+	(value (gensym)))
957 
+    `(locally (declare ,*special-kr-optimization*)
958 
+       (let* (,@(unless (symbolp schema) `((schema ,schema)))
959 
+	    (,entry
960 
+	     #+GARNET-DEBUG
961 
+	     (if (is-schema ,schema-form) ; this is just schema-p
962 
+	       ;; make sure it's not a formula or deleted
963 
+	       (let ((bins (schema-bins ,schema-form)))
964 
+		 (if (and bins (not (integerp bins)))
965 
+		   (slot-accessor ,schema-form ,slot)
966 
+		   (error "Non-object ~S in g-value or get-value (slot is ~S)"
967 
+			  ,schema-form ,slot)))
968 
+	       (error "Non-object ~S in g-value or get-value (slot is ~S)"
969 
+		      ,schema-form ,slot))
970 
+	     #-GARNET-DEBUG
971 
+	     (slot-accessor ,schema-form ,slot))
972 
+	    (,value (if ,entry
973 
+		      ,@(if (not inherit-p)
974 
+			  `((if (is-inherited (sl-bits ,entry))
975 
+			      ,@(if formula-p
976 
+				  `((if (a-formula-p (sl-value ,entry))
977 
+				      (sl-value ,entry)))
978 
+				  `(NIL))
979 
+			      (sl-value ,entry)))
980 
+			  `((sl-value ,entry)))
981 
+		      ,@(if (or inherit-p formula-p)
982 
+			  `(*no-value*)))))
983 
+      (if (eq ,value *no-value*)
984 
+	,@(cond ((and (not inherit-p) (not formula-p))
985 
+		 `((setf ,value NIL)))
986 
+		((and (not inherit-p) formula-p)
987 
+		 `((if ,entry
988 
+		     (setf ,value NIL)
989 
+		     (if (not (formula-p (setf ,value
990 
+					       (g-value-inherit-values
991 
+						,schema-form ,slot T NIL))))
992 
+		       (setf ,value NIL)))))
993 
+
994 
+		((a-local-only-slot slot)
995 
+		 ;; slots such as :IS-A-INV should never be inherited!
996 
+		 `((setf ,value NIL)))
997 
+		(t
998 
+		 `((if (if ,entry (is-inherited (sl-bits ,entry)))
999 
+		     ;; in which case, no-value was already inherited.
1000 
+		     (setf ,value NIL)
1001 
+		     ;; otherwise, try to inherit the value.
1002 
+		     (progn
1003 
+		       (setf ,value (g-value-inherit-values ,schema-form ,slot
1004 
+							    T ,entry))
1005 
+		       (if (eq ,value *no-value*)
1006 
+			 (setf ,value NIL))))))))
1007 
+      ,@(if formula-p
1008 
+	  `((if (a-formula-p ,value)
1009 
+	      (g-value-formula-value ,schema-form ,slot ,value ,entry)
1010 
+	      ,value))
1011 
+	  `(,value))))))
1012 
+
1013 
+
1014 
+(defmacro get-value (schema slot)
1015 
+  `(g-value-body ,schema ,slot T NIL))
1016 
+
1017 
+
1018 
+;; GET-VALUES
1019 
+;;
1020 
+;;(defmacro get-values (schema slot)
1021 
+;;  `(let ((values (get-value ,schema ,slot)))
1022 
+;;     (if (listp values)
1023 
+;;	 values
1024 
+;;	 (list values))))
1025 
+
1026 
+
1027 
+(defmacro g-value (schema &rest slots)
1028 
+  "This macro expands into nested calls to g-value-fn.  For example:
1029 
+  (g-value schema :slot1 :slot2 :slot3 5) expands into
1030 
+  (g-value-fn (g-value-fn (g-value-fn schema :slot1 0) :slot2 0) :slot3 5)"
1031 
+  (if slots
1032 
+      `(expand-accessor value-fn ,schema ,@slots)
1033 
+    `(progn ,schema)))
1034 
+
1035 
+
1036 
+(defmacro g-local-value (schema &rest slots)
1037 
+  (if slots
1038 
+      `(expand-accessor g-local-value-fn ,schema ,@slots)
1039 
+      `(progn ,schema)))
1040 
+
1041 
+
1042 
+;;; Demons
1043 
+
1044 
+;; Used to look in the :UPDATE-SLOTS of the <schema> to determine whether the
1045 
+;; <slot> has an associated demon.  This gives us the freedom to let different
1046 
+;; schemata have demons on possibly different slots.
1047 
+;;
1048 
+;; Now, it uses the <slot>'s is-update-slot bit to check.  This bit is set at
1049 
+;; create-instance time by traversing the :UPDATE-SLOTS list of the <schema>.
1050 
+;;
1051 
+(declaim (inline slot-requires-demon))
1052 
+(defun slot-requires-demon (schema slot &optional entry)
1053 
+  (declare #.*special-kr-optimization*)
1054 
+  (let ((.entry. (or entry (slot-accessor schema slot))))
1055 
+    (when .entry.
1056 
+      (is-update-slot (sl-bits .entry.)))))
1057 
+
1058 
+#-(and)
1059 
+(defmacro slot-requires-demon (schema slot &optional entry)
1060 
+  `(let ((update (get-value ,schema, :UPDATE-SLOTS)))
1061 
+    (or (eq (car update) T)
1062 
+     (memberq ,slot update))))
1063 
+
1064 
+
1065 
+(declaim (inline run-invalidate-demons))
1066 
+(defun run-invalidate-demons (schema slot entry)
1067 
+  "Execute the update demon associated with the <schema> and <slot>, if there
1068 
+is one."
1069 
+  (unless (eq *demons-disabled* T)
1070 
+    (when (slot-requires-demon schema slot entry)
1071 
+      (let ((demon (get-value schema :INVALIDATE-DEMON)))
1072 
+	(when demon
1073 
+	  (unless (demon-is-disabled demon)
1074 
+	    (funcall demon schema slot nil)))))))
1075 
+
1076 
+
1077 
+(defmacro run-pre-set-demons (schema slot new-value is-formula reason)
1078 
+"Invokes the pre-set demon, if one is defined and if the <slot> is an
1079 
+'interesting' slot (i.e., if it is listed in the :update-slots of the
1080 
+<schema>).
1081 
+Also, if *slot-setter-debug* is bound, it invokes it.  This is a debugging
1082 
+function that gets called every time a slot is modified, either by s-value
1083 
+or as a result of formula evaluation.  The <reason> is given as the fourth
1084 
+parameter to the function; it is a keyword that explains why the slot
1085 
+was changed."
1086 
+  #-GARNET-DEBUG
1087 
+  (declare (ignore reason))
1088 
+  `(unless (eq *demons-disabled* T)
1089 
+    #+GARNET-DEBUG
1090 
+    (if *slot-setter-debug*
1091 
+	(funcall *slot-setter-debug* ,schema ,slot ,new-value ,reason))
1092 
+    (if *pre-set-demon*
1093 
+      (if (not (demon-is-disabled *pre-set-demon*))
1094 
+	(if (slot-requires-demon ,schema ,slot)
1095 
+	  (if ,@(if is-formula
1096 
+		  `((not (equal
1097 
+			  ,new-value
1098 
+			  ,@(cond ((eq is-formula :CURRENT-FORMULA)
1099 
+				   `((cached-value *current-formula*)))
1100 
+				  ((eq is-formula T)
1101 
+				   `((g-cached-value ,schema ,slot)))
1102 
+				  (t
1103 
+				   `(,is-formula))))))
1104 
+		  `(T))
1105 
+	      (funcall *pre-set-demon* ,schema ,slot ,new-value)))))))
1106 
+
1107 
+
1108 
+
1109 
+;;; S-VALUE
1110 
+
1111 
+;; Helper function for multi-level S-VALUE
1112 
+;;
1113 
+(defun s-value-chain (schema &rest slots)
1114 
+  (locally (declare #.*special-kr-optimization*)
1115 
+    (if (null schema)
1116 
+	(error "S-VALUE on a null object:  (S-VALUE ~S~{ ~S~})" schema slots)
1117 
+	(unless (schema-p schema)
1118 
+	  (error "S-VALUE called with the non-object ~S :  (s-value ~S~{ ~S~})."
1119 
+		 schema schema slots)))
1120 
+    (do* ((s slots (cdr s))
1121 
+	  (intermediate schema))
1122 
+	 ((null (cddr s))
1123 
+	  (s-value-fn intermediate (first s) (second s)))
1124 
+      (let ((new-schema (value-fn intermediate (car s))))
1125 
+	(if (null new-schema)
1126 
+	    (error
1127 
+	     "An intermediate schema is null:  slot ~S of object ~S has value
1128 
+  NIL in (S-VALUE ~S~{ ~S~})"
1129 
+	     (car s) intermediate schema slots)
1130 
+	    (unless (schema-p new-schema)
1131 
+	      (error "An intermediate value is not a schema in (S-VALUE ~S~{ ~S~}),
1132 
+at slot ~S  (non-schema value is ~S, last schema was ~S)"
1133 
+		     schema slots (car s) new-schema intermediate)))
1134 
+	(setf intermediate new-schema)))))
1135 
+
1136 
+
1137 
+
1138 
+;;; S-VALUE & FRIENDS
1139 
+
1140 
+(defmacro s-value (schema &rest slots)
1141 
+"The basic value-setting macro.
1142 
+
1143 
+Inputs:
1144 
+   - <schema>: the name of a schema
1145 
+   - <slot>: name of the slot to be modified.
1146 
+   - <value>: new value for the <slot>."
1147 
+  (when slots
1148 
+    ;; This is the more general case.
1149 
+    (if (cddr slots)
1150 
+	;; Several slots.
1151 
+	`(s-value-chain ,schema ,@slots)
1152 
+	;; One (non-special) slot only.
1153 
+	`(s-value-fn ,schema ,(first slots) ,(second slots)))))
1154 
+
1155 
+
1156 
+(defmacro dovalues ((variable schema slot &key (local nil) (result nil)
1157 
+			      (formulas T) (in-formula NIL))
1158 
+		    &rest body)
1159 
+"Executes <body> with <variable> bound to all the values of the <slot> in
1160 
+<schema>."
1161 
+
1162 
+  `(locally (declare ,*special-kr-optimization*)
1163 
+     (let* ((schema ,@(if (eq schema :SELF)
1164 
+			`(*schema-self*)
1165 
+			`(,schema)))
1166 
+	  (values ,@(if local
1167 
+		      (if formulas
1168 
+			`((g-local-value schema ,slot))
1169 
+			`((get-local-value schema ,slot)))
1170 
+		      (if formulas
1171 
+			(if in-formula
1172 
+			    `((gv schema ,slot))
1173 
+			    `((g-value schema ,slot)))
1174 
+			(if in-formula
1175 
+			  `((gv schema ,slot))
1176 
+			  `((get-value schema ,slot)))))))
1177 
+     ;; Now iterate
1178 
+     (if values
1179 
+       (progn
1180 
+	 (unless (listp values)
1181 
+	   (format t "(DOVALUES ~s ~s) does not contain a list of values!~%"
1182 
+		   ,schema ,slot)
1183 
+	   (setf values (list values)))
1184 
+	 ;; Extra code for the case FORMULAS = T
1185 
+	 (dolist (,variable values)
1186 
+	   ,@(if formulas
1187 
+	       ;; Generate test for formula-p, unless :FORMULAS is nil
1188 
+	       `((when (formula-p ,variable)
1189 
+		       #+EAGER
1190 
+		       (propagate)
1191 
+		       (setf ,variable
1192 
+			     #+EAGER
1193 
+			     (cached-value ,variable)
1194 
+			     #-EAGER
1195 
+			     (g-value-formula-value
1196 
+			      schema ,slot ,variable NIL)))))
1197 
+	   ,@body)))
1198 
+     ,result)))
1199 
+
1200 
+
1201 
+
1202 
+;;; Various
1203 
+
1204 
+(defmacro create-relation (relation inheritance-p &rest inverses)
1205 
+"Defines a new relation with its inverses.  If <inheritance-p>
1206 
+is non-nil, classifies the relation as one that performs inheritance.
1207 
+Note that <relation> should be a slot name, not a schema."
1208 
+  (let ((entry (gensym)))
1209 
+    `(let ((inverses ',inverses))
1210 
+      (when ,inheritance-p
1211 
+	(pushnew ,relation *inheritance-relations*)
1212 
+	(dolist (inverse inverses)
1213 
+	  (pushnew inverse *inheritance-inverse-relations*)))
1214 
+      (unless (assocq ,relation *relations*)
1215 
+	(push (cons ,relation inverses) *relations*))
1216 
+      (dolist (inv inverses)
1217 
+	(let ((,entry (assocq inv *relations*)))
1218 
+	  (if ,entry
1219 
+	    (pushnew ,relation (cdr ,entry))
1220 
+	    (progn
1221 
+	      (push (list inv ,relation) *relations*))))))))
1222 
+
1223 
+
1224 
+(declaim (inline has-slot-p))
1225 
+(defun has-slot-p (schema slot)
1226 
+  (locally (declare #.*special-kr-optimization*)
1227 
+    (let ((entry (slot-accessor schema slot)))
1228 
+      (and entry
1229 
+	   (not (eq (sl-value entry) *no-value*))
1230 
+	   (not (is-inherited (sl-bits entry)))))))
1231 
+
1232 
+
1233 
+;; This is here for compatibility purposes.
1234 
+;;
1235 
+(declaim (inline set-values))
1236 
+(defun set-values (schema slot values)
1237 
+  (if (relation-p slot)
1238 
+      (s-value schema slot (if (listp values) values (list values)))
1239 
+      (s-value schema slot values)))
1240 
+
1241 
+
1242 
+;;; Methods.
1243 
+(defmacro kr-send (schema slot &rest args)
1244 
+  (let ((the-schema (gensym))
1245 
+	(the-function (gensym)))
1246 
+    `(let* ((,the-schema ,schema)
1247 
+	    (,the-function (g-value ,the-schema ,slot)))
1248 
+       (when ,the-function
1249 
+	 ;; Bind these in case call prototype method is used.
1250 
+	 (let ((*kr-send-self* ,the-schema)
1251 
+	       (*kr-send-slot* ,slot)
1252 
+	       (*kr-send-parent* NIL))
1253 
+	   (funcall ,the-function ,@args))))))
1254 
+
1255 
+
1256 
+(defmacro call-prototype-method (&rest args)
1257 
+  (let ((entry (gensym)))
1258 
+    `(locally (declare ,*special-kr-optimization*)
1259 
+       (let ((first-c-p-m (and (null *kr-send-parent*)
1260 
+			     (let ((,entry (slot-accessor *kr-send-self*
1261 
+							  *kr-send-slot*)))
1262 
+			       (or (null ,entry)
1263 
+				   (is-inherited (sl-bits ,entry)))))))
1264 
+      (multiple-value-bind (method new-parent)
1265 
+	  (find-parent *kr-send-self* *kr-send-slot*)
1266 
+	(when method
1267 
+	  (if first-c-p-m
1268 
+	    (multiple-value-setq (method *kr-send-parent*)
1269 
+	      (find-parent new-parent *kr-send-slot*))
1270 
+	    (setf *kr-send-parent* new-parent))
1271 
+	  (if method
1272 
+	    (let ((*kr-send-self* *kr-send-parent*))
1273 
+	      (funcall method ,@args)))))))))
1274 
+
1275 
+
1276 
+(defmacro apply-prototype-method (&rest args)
1277 
+  (let ((entry (gensym)))
1278 
+    `(locally (declare ,*special-kr-optimization*)
1279 
+       (let ((first-c-p-m (and (null *kr-send-parent*)
1280 
+			     (let ((,entry (slot-accessor *kr-send-self*
1281 
+							  *kr-send-slot*)))
1282 
+			       (or (null ,entry)
1283 
+				   (is-inherited (sl-bits ,entry)))))))
1284 
+      (multiple-value-bind (method new-parent)
1285 
+	  (find-parent *kr-send-self* *kr-send-slot*)
1286 
+	(when method
1287 
+	  (if first-c-p-m
1288 
+	    (multiple-value-setq (method *kr-send-parent*)
1289 
+	      (find-parent new-parent *kr-send-slot*))
1290 
+	    (setf *kr-send-parent* new-parent))
1291 
+	  (if method
1292 
+	    (let ((*kr-send-self* *kr-send-parent*))
1293 
+	      (apply method ,@args)))))))))
1294 
+
1295 
+
1296 
+(defmacro define-method (name class arg-list &rest body)
1297 
+  (unless (keywordp name)
1298 
+    (setf name (intern (symbol-name name) (find-package "KEYWORD")))
1299 
+    (format t "DEFINE-METHOD takes a keyword as the method name - using ~S~%"
1300 
+	    name))
1301 
+  (let* ((function-name (intern (concatenate 'string
1302 
+					     (symbol-name name)
1303 
+					     "-METHOD-"
1304 
+					     (symbol-name class)))))
1305 
+    `(progn
1306 
+       (defun ,function-name ,arg-list
1307 
+	 ,@body)
1308 
+       (s-value ,class ,name ',function-name))))
1309 
+
1310 
+
1311 
+(defmacro method-trace (class generic-fn)
1312 
+  `(let ((fn (g-value ,class ,generic-fn)))
1313 
+    (if fn
1314 
+      (eval `(trace ,fn)))))
1315 
+
1316 
+
1317 
+;;; Schemas
1318 
+
1319 
+;; CREATE-SCHEMA
1320 
+;;
1321 
+;; The keyword :OVERRIDE may be used to indicate that the schema should
1322 
+;; be kept, if it exists, and newly specified slots should simply override
1323 
+;; existing ones.  The default behavior is to wipe out the old schema.
1324 
+;;
1325 
+;; Another keyword that can be used as an argument is name-prefix. If there's
1326 
+;; an unnamed schema but :name-prefix <some name> is given as an argument,
1327 
+;; the system will auto-generate names for the schemas using the name-prefix
1328 
+;; argument as the prefix for the names.
1329 
+(defmacro create-schema (name &rest rest)
1330 
+  (let ((prefix (memberq :NAME-PREFIX rest)))
1331 
+    ;; Check that all elements of the list are well-formed, give warnings
1332 
+    ;; otherwise
1333 
+    (when prefix
1334 
+      (if name
1335 
+	  (progn
1336 
+	    (format
1337 
+	     t "Warning - you specified both a name and a :NAME-PREFIX option~:
1338 
+in (create-schema ~S).~%   Ignoring the :NAME-PREFIX.~%"
1339 
+	     name)
1340 
+	    (setf prefix nil))
1341 
+	  (progn
1342 
+	    ;; We have an unnamed schema but a name prefix - use it.
1343 
+	    (setf name (second prefix))
1344 
+	    (setf prefix NIL))))
1345 
+    ;; Make the schema name known at compile time, so we do not issue
1346 
+    ;; silly warnings.
1347 
+    (when (and (listp name) (eq (car name) 'QUOTE))
1348 
+      (proclaim `(special ,(eval name))))
1349 
+    (let* ((override (not (null (memberq :OVERRIDE rest))))
1350 
+	   (destroy (and name (not override))) ; avoid trouble with (c-s NIL :override)
1351 
+	   (*create-schema-schema* name)
1352 
+	   (slots (process-slots rest))
1353 
+	   (generate-instance (not (null (memberq :generate-instance rest)))))
1354 
+      (creation-message name)
1355 
+      `(do-schema-body
1356 
+	   ,(if destroy
1357 
+		`(make-a-new-schema ,name)
1358 
+		(if (and (listp name)
1359 
+			 (eq (car name) 'QUOTE)
1360 
+			 (boundp (second name)))
1361 
+		    (eval name)
1362 
+		    `(make-a-new-schema ,name)))
1363 
+	 ,(car slots)				    ; is-a
1364 
+	 ,generate-instance			    ; create instance
1365 
+	 ,(null (memberq :delayed-processing rest)) ; process constant slots
1366 
+	 ,override
1367 
+	 ,@(cdr slots)))))		; types, plus slot specifiers
1368 
+
1369 
+
1370 
+(defmacro create-prototype (name &rest slots)
1371 
+  "Creates a prototype; really just another name for create-schema."
1372 
+  `(create-schema ,name ,@slots))
1373 
+
1374 
+
1375 
+;; create-instance
1376 
+;;
1377 
+;; I am not sure the following enhancement will work because of the
1378 
+;; quote around the instance name... [2005/12/20:rpg]
1379 
+(defmacro create-instance (name class &body body)
1380 
+  "If CLASS is not nil, creates a schema with an IS-A slot set to that class.
1381 
+   Otherwise, just creates a schema."
1382 
+  (when (and (listp class)
1383 
+	     (eq (car class) 'QUOTE))
1384 
+    ;; Prevent a common mistake.
1385 
+    (cerror
1386 
+     "Remove the quote and use the resulting object."
1387 
+     "  Quoted symbols cannot be used as prototypes: (create-instance ~S ~S)~%"
1388 
+     name class)
1389 
+    (setf class (eval (second class))))
1390 
+  (dolist (element body)
1391 
+    (when (and (listp element) (eq (car element) :IS-A))
1392 
+      (format
1393 
+       t
1394 
+       "CREATE-INSTANCE ~S ~S: do not specify the :IS-A slot!  Ignored.~%"
1395 
+       name class)
1396 
+      (setf body (remove (assocq :IS-A body) body))))
1397 
+  ;; Everything is OK.
1398 
+  `(progn
1399 
+     #+allegro
1400 
+     (excl:record-source-file ,name :type :kr-instance)
1401 
+     (create-schema ,name :GENERATE-INSTANCE
1402 
+		    ;; class might be nil, which means no IS-A slot
1403 
+		    ,@(if class `((:is-a ,class)))
1404 
+		    ,@body)))
1405 
+
1406 
+
1407 
+(defmacro begin-create-instance (name class &body body)
1408 
+  "Processes the first half of a create-instance where constant-slot
1409 
+processing needs to be delayed.
1410 
+This should only be used for specialized applications, such as those
1411 
+found in aggrelists."
1412 
+  (dolist (descriptor body)
1413 
+    (when (and (listp descriptor) (eq (car descriptor) :IS-A))
1414 
+      (format
1415 
+       t
1416 
+       "BEGIN-CREATE-INSTANCE ~S ~S: do not specify the :IS-A slot!  Ignored.~%"
1417 
+       name class)
1418 
+      (setf body (remove descriptor body))
1419 
+      (return)))
1420 
+  `(create-schema ,name :DELAYED-PROCESSING
1421 
+     ;; class might be nil, which means no IS-A slot
1422 
+     ,@(if class `((:is-a ,class)))
1423 
+     ,@body))
1424 
+
1425 
+
1426 
+;;; Setf forms for several macros
1427 
+
1428 
+(defsetf g-value s-value)
1429 
+
1430 
+(defsetf get-values s-value)
1431 
+
1432 
+(defsetf get-local-values s-value)
1433 
+
1434 
+(defsetf g-local-value s-value)
1435 
+
1436 
+(defsetf gv (schema &rest slots) (value)
1437 
+  `(progn
1438 
+    (if *current-formula*
1439 
+      (gv ,schema ,@slots))
1440 
+    (s-value ,schema ,@slots ,value))
1441 
+  "At the top-level, (setf (gv ...)) behaves just like s-value; when
1442 
+inside a formula, it also sets up a dependency, just like gv would.")
1443 
+
1444 
+
1445 
+
1446 
+;;; Internal debugging function
1447 
+;;
1448 
+(defmacro with (schema slot &body form)
1449 
+  `(let* ((*schema-self* (if (numberp ,schema) (s ,schema) ,schema))
1450 
+	  (*schema-slot* ,slot)
1451 
+	  (*current-formula* (get-value *schema-self* *schema-slot*))
1452 
+	  (*warning-on-null-link* T))
1453 
+     (catch 'no-link
1454 
+       ,@form)))
kr/kr.changes
History View file @ 6e35003
0 1455 
new file mode 100644
... ... 
@@ -0,0 +1,2356 @@
1 
+Made SCHEMA-P faster.
2 
+
3 
+Modified g-value-body so that even if GARNET-DEBUG is on, g-value and friends
4 
+run a lot faster.  This adds back most of the improvements for the case
5 
+where GARNET-DEBUG is off.
6 
+[10-29-1993	David Kosbie, Dario Giuse]
7 
+
8 
+
9 
+
10 
+Added David Kosbie's fix to APPLY-PROTOTYPE-METHOD, which had failed to be
11 
+updated when call-prototype-method was fixed.
12 
+[10-26-1993	Dario Giuse]
13 
+
14 
+
15 
+Modified the conditional definition of REALP, as per the following message:
16 
+The small change is to just add ALLEGRO-V3.1 to the switch before the code
17 
+in kr.lisp:
18 
+
19 
+#+(or LUCID ALLEGRO-V3.1)
20 
+;;; REALP seems to be undefined on these lisps.
21 
+;;;
22 
+(let ((realp-symbol (find-symbol "REALP" 'lisp)))
23 
+[10-19-1993	Dario Giuse]
24 
+
25 
+
26 
+Added Pedro's fix to DESTROY-SLOT to make sure the schema was properly
27 
+deleted.
28 
+[10-11-1993	Dario Giuse]
29 
+
30 
+
31 
+
32 
+Fixed a bug in ADD-NEW-TYPE which caused declarations such as
33 
+(def-kr-type ACCELERATORS-TYPE () 'list
34 
+  "[list of lists: ((#\r \"Alt-r\" #\meta-r)...)]")
35 
+which used a type body (i.e., 'list) already defined to actually lose the
36 
+type definition.
37 
+
38 
+Exported kr:get-type-definition
39 
+[10-8-1993	Dario Giuse]
40 
+
41 
+
42 
+
43 
+Added a new &key argument to PS, :stream.  This argument (default value
44 
+*standard-output*) allows a stream to be specified, thus redirecting
45 
+all of PS's output to a stream other than the terminal.
46 
+[9-22-1993	Dario Giuse]
47 
+
48 
+
49 
+Added a SETF form for GV, which works as follows:
50 
+- at the top level, (setf (gv object slots) value) is identical to
51 
+  (s-value object slots value);
52 
+- if embedded in a formula, it is identical to the above, except that it
53 
+  also sets up a dependency, just like GV would.
54 
+
55 
+
56 
+Added a new, non-exported function, kr::get-type-definition.  Given
57 
+the symbol which names a KR type (e.g., 'KR-BOOLEAN), this function
58 
+returns the type expression that was used to define the type.
59 
+Syntax:   (kr::get-type-definition type-symbol)
60 
+Example:
61 
+ (get-type-definition 'bitmap-or-nil) ==>
62 
+ (OR NULL (IS-A-P OPAL:BITMAP))
63 
+[9-21-1993	Dario Giuse]
64 
+
65 
+
66 
+Eliminated code which caused a value change in a formula in a
67 
+prototype to physically delete all formulas which were inherited from
68 
+that formula.  This caused such an operation to delete and recreate
69 
+formulas in the instances.
70 
+This bug was reported by Andy Mickish.
71 
+[9-14-1993	Dario Giuse]
72 
+
73 
+
74 
+Eliminated BREAK in GV; replaced with CERROR.  The error message is
75 
+now cleaner and indicates whether the GV occurred inside a formula or
76 
+at the top level.
77 
+
78 
+Eliminated BREAK in CREATE-INSTANCE for the case when NIL is used
79 
+instead of a slot specifier.  Also, gave better error message.
80 
+
81 
+Fixed "illegal instruction" error caused by a slot specification in
82 
+CREATE-INSTANCE which was a symbol instead of a correct specifier.
83 
+This situation now gives a meaningful error message.
84 
+[9-13-1993	Dario Giuse]
85 
+
86 
+
87 
+Exported the functions GET-DECLARATIONS and GET-SLOT-DECLARATIONS from the KR
88 
+package.
89 
+[8-19-1993	Dario Giuse]
90 
+
91 
+
92 
+
93 
+Added the non-exported function kr::SELF-OLD-VALUE, which can be used
94 
+within formulas to access the currently cached value of the formula.
95 
+This allows formulas to do destructive modifications in the case where
96 
+their value is a list, an array, or some other structured object.  The
97 
+syntax is:
98 
+(kr::self-old-value)
99 
+If there is no currently cached value, the function returns NIL.
100 
+[8-9-1993	Dario Giuse]
101 
+
102 
+
103 
+------------  last change log update
104 
+
105 
+
106 
+;;; Version 2.3.2
107 
+
108 
+
109 
+Better error checking for ill-structured :local-only-slots
110 
+declarations.
111 
+
112 
+
113 
+Fixed DESTROY-CONSTRAINT to keep the update-slot bit of the slot.  The
114 
+old version incorrectly used to reset the bit.
115 
+[6-28-1993	Dario Giuse]
116 
+
117 
+
118 
+
119 
+Moved the macro DEF-KR-TYPE to kr-macros.lisp, from kr.lisp.  Added the
120 
+documentation string David Kosbie suggested.
121 
+
122 
+Exported DEF-KR-TYPE from the KR package.
123 
+
124 
+Added David Kosbie's change to add-new-type, with modification to get a
125 
+symbol name (rather than a string) for things like KR-BOOLEAN.
126 
+
127 
+Added fix from BVZ to COPY-FORMULA, to make sure that meta-information is
128 
+copied properly from the formula being copied.
129 
+
130 
+Fixed problem with S-TYPE on slots that had no value (used to cause a
131 
+warning about no-value not being a valid object of the type).
132 
+[6-25-1993	Dario Giuse]
133 
+
134 
+
135 
+
136 
+Better checking for destroyed objects in destroy-slot.
137 
+[6-24-1993	Dario Giuse]
138 
+
139 
+
140 
+
141 
+Bound *print-length* in the function used by PS, so large arrays which
142 
+are values in slots are truncated after 10 elements.  This is the same
143 
+as what the printer does when it prints such arrays at the top level.
144 
+[6-22-1993	Dario Giuse]
145 
+
146 
+
147 
+
148 
+Changed the KR-SEND macro so it no longer traps the binding of the symbol
149 
+SCHEMA.
150 
+[6-17-1993	Dario Giuse]
151 
+
152 
+
153 
+
154 
+Fixed problem with macroexpansion of a multi-level GV (or GVL), which caused
155 
+things to fail if one of the slot names was not a keyword but a variable
156 
+containing a keyword.
157 
+[6-10-1993	Dario Giuse]
158 
+
159 
+
160 
+A multi-level S-VALUE now gives a better error message when one of the
161 
+intermediate slots contains a value which is not a schema.
162 
+
163 
+Giving a non-schema object or a null object to S-VALUE (through a multi-level
164 
+S-VALUE) now produces a better error message.
165 
+
166 
+Giving a non-schema object to G-VALUE and GET-VALUE (either directly or in a
167 
+multi-level G-VALUE) now gives a better error message.
168 
+[6-9-1993	Dario Giuse]
169 
+
170 
+
171 
+
172 
+Created the new function KR::ADD-UPDATE-SLOT, which allows slots to be
173 
+declared (or undeclared) as update-slots dynamically, after create-instance.
174 
+In addition to setting (resetting) the internal bit, the function also
175 
+modifies the :update-slots slot accordingly.   Syntax:
176 
+(kr::add-update-slot object slot &optional (turn-off nil))
177 
+The default is to make <slot> be an update slot.  If <turn-off> is non-nil,
178 
+however, the slot is changed to no longer be an update slot.
179 
+[6-7-1993	Dario Giuse]
180 
+
181 
+
182 
+Fixed a problem with destroyed formulas being kept around in their parent
183 
+formula's list of children.  This was causing formulas to disappear
184 
+mysteriously under certain conditions.  The bug was reported by Francesmary
185 
+Modugno.
186 
+
187 
+Added the non-exported function I-DEPEND-ON, which returns a list of dotted
188 
+pairs (schema . slot) for all slots upon which a certain formula depends.
189 
+
190 
+Merged in David Kosbie's changes for speedup.
191 
+[5-26-1993	Dario Giuse]
192 
+
193 
+
194 
+Fixed iterate-slot-value, which was broken for the case T nil nil.  Changed
195 
+(and extended) the regression test suite correspondingly.
196 
+
197 
+Added conditionally compiled code for the HP, where the function REALP seems
198 
+to be undefined.
199 
+[5-25-1993	Dario Giuse]
200 
+
201 
+
202 
+First version with the new optimized internal representation.  The distinction
203 
+between special and non-special slots has been removed.  All slots are stored
204 
+in a certain number (currently 8) of bins in a schema.  Each bin contains
205 
+a list of slot structures.  The bin for each slot is determined from the
206 
+first character of the slot's printname, looking up an array that tells what
207 
+bin to use.
208 
+This change is user-invisible, except for the considerable speedups.
209 
+[5-24-1993	Dario Giuse, David Kosbie]
210 
+
211 
+
212 
+;;; Version 2.2.2
213 
+
214 
+
215 
+Fixed meta-slot creation for formulas so that if a formula supplies some
216 
+meta slots at creation time, and it also has a parent which supplies other
217 
+meta slots, the final meta schema correctly inherits the parent's slots
218 
+when needed.
219 
+[4-23-1993	Dario Giuse]
220 
+
221 
+
222 
+Added BVZ's fix to destroy-slot for the case where a formula that depends
223 
+on the slot being destroyed is not attached to a schema.
224 
+[4-20-1993	Dario Giuse]
225 
+
226 
+
227 
+Fixed a problem with destroy-slot that could cause dependencies to destroyed
228 
+formulas to be kept around after the slot was destroyed.  This bug was
229 
+reported by Brad Vander Zanded.
230 
+[4-19-1993	Dario Giuse]
231 
+
232 
+
233 
+Made MAKE-INTO-O-FORMULA return the formula it is given as argument.
234 
+[4-6-1993	Dario Giuse]
235 
+
236 
+
237 
+
238 
+Added error message for improper schema in GV and GVL.
239 
+
240 
+Better error message when GV is given a non-schema.
241 
+[3-29-93	Dario Giuse]
242 
+
243 
+
244 
+Fixed storage leakage problems and time problems in IS-A-P type declarations.
245 
+Merged the SCHEMA-P check with the SATISFIES check, which eliminates
246 
+unnecessary consing.
247 
+[3-29-93	David Kosbie]
248 
+
249 
+
250 
+
251 
+Fixed bug in CALL-ON-PS-SLOTS: the supplied function was being called with one
252 
+argument too few when the object was a formula.
253 
+
254 
+
255 
+Remember to modify KR documentation about "create-instance copies the
256 
+formula down into the instances".  This should be clarified; at the very least,
257 
+there should be a pointer to some place that explains that in reality, formulas
258 
+are only copied when requested, and in any case setting a value locally forces
259 
+the formula never to be inherited.
260 
+[3-23-1993	Dario Giuse]
261 
+
262 
+
263 
+The function PS now returns the object it was given.  This allows the
264 
+interactive expression * to be used after an object is printed.
265 
+
266 
+
267 
+The new, non-exported macro WITH-DEPENDENCIES-DISABLED can be used to prevent
268 
+the evaluation of GV and GVL inside formulas from setting up dependencies.
269 
+Inside its body, GV and GVL effectively behave (temporarily) like G-VALUE.
270 
+
271 
+
272 
+The variable kr::*slot-setter-debug* may now be bound to a function, to be
273 
+called every time the value of a slot is set.  This occurs because of S-VALUE,
274 
+formula evaluation, inheritance changes, or slot destruction.  If the value
275 
+has a non-nil value, the value should be a function of four arguments:
276 
+  #'(lambda (schema slot new-value reason)
277 
+	...)
278 
+The <reason> is a keyword that describes what event triggered the function.
279 
+
280 
+Note that there may be only one such function at a time, and it is not possible
281 
+for an object to use a different function.  Therefore, this is an inefficient
282 
+mechanism which should be used ONLY for debugging purposes.
283 
+[3-22-1993	Dario Giuse]
284 
+
285 
+
286 
+Modified S-TYPE to return the type it was given, rather than NIL.  This is
287 
+more compatible with S-VALUE.
288 
+[3-18-1993	Dario Giuse]
289 
+
290 
+
291 
+Created a new non-exported function, CALL-ON-ONE-SLOT, which works like
292 
+CALL-ON-PS-SLOTS but for a single slot in a schema.  Syntax:
293 
+(call-on-one-slot  object  slot  #'function)
294 
+The parameters to the <function> are the same as in CALL-ON-PS-SLOTS.
295 
+
296 
+This function returns T if the slot exists and the <function> was called, and
297 
+NIL otherwise.
298 
+[3-16-1993	Dario Giuse]
299 
+
300 
+
301 
+Added the new reader macro #f(), which is read as (o-formula ...).
302 
+For example, this allows you to write
303 
+   (s-value a :left #f(gvl :top))
304 
+instead of
305 
+   (s-value a :left (o-formula (gvl :top)))
306 
+
307 
+Added one more built-in name to G-FORMULA-VALUE.  Specifying :META as the
308 
+slot name retrieves the meta-schema for the formula, is one exists, or NIL.
309 
+Note that this does not attempt to inherit a meta-schema.
310 
+[3-11-93	Dario Giuse]
311 
+
312 
+
313 
+Added printing of meta-information when PS is given a formula.
314 
+[3-10-93	Dario Giuse]
315 
+
316 
+
317 
+Added a SETF form for G-LOCAL-VALUE, which simply expands into S-VALUE.
318 
+
319 
+Fixed new bug in CALL-ON-PS-SLOTS that was crashing when printing formulas.
320 
+
321 
+Change documentation for invalidate demon - need to clarify.
322 
+[3-8-93		Dario Giuse]
323 
+
324 
+
325 
+S-VALUE may now have more than one slot in its argument list.  This is similar
326 
+to G-VALUE: all slots but the last one are used to access objects, and then
327 
+the value of the last slot specified is set in the resulting object.
328 
+For example:
329 
+  (s-value item :parent :parent :left 100)
330 
+sets the :left slot of the item's parent's parent to 100.  An appropriate
331 
+error message is given if any of the intervening objects is found to be NIL.
332 
+[3-5-93		Dario Giuse]
333 
+
334 
+
335 
+
336 
+Made GV behave exactly like G-VALUE when used outside formulas.  In other words,
337 
+if there is no current formula, GV just calls G-VALUE and does not attempt to set
338 
+up a dependency.
339 
+
340 
+Replaced kr-call-initialize-method in BEGIN-CREATE-INSTANCE with the more modern
341 
+kr-init-method
342 
+[3-4-93		Dario Giuse]
343 
+
344 
+
345 
+Removed the definition of KR-BOOLEAN, which is now defined in the types file.
346 
+[2-25-93	Dario Giuse]
347 
+
348 
+
349 
+Rearranged things and used DEFVARs so it should now be possible to reload the
350 
+file kr.fasl without having the type system choke when types are already
351 
+defined.
352 
+[2-24-93	Dario Giuse]
353 
+
354 
+
355 
+Fixed the new version of PS to work properly with inheritable formulas that
356 
+are invalid.  Formulas are copied down, but their value is not recomputed.
357 
+[2-23-93	Dario Giuse]
358 
+
359 
+
360 
+Added a new function, CALL-ON-PS-SLOTS, which can be used to call a function
361 
+on each slot that would be printed by PS.  The arguments are as follows:
362 
+(call-on-ps-slots schema function &key (control t) inherit (indent NIL)
363 
+				types-p all-p)
364 
+The keyword arguments have the same meaning as in PS.  The <function> should
365 
+be a function of 9 arguments, as follows:
366 
+(lambda (schema slot formula is-inherited valid real-value
367 
+	types-p bits indent limits))
368 
+
369 
+The <slot> is bound to each slot in turn.  The <formula> is nil, for
370 
+non-formula values, or the original formula in the slot.  <is-inherited> is T
371 
+if the value in the <slot> was inherited.  <valid> is nil if the <slot> contains
372 
+a formula whose cached value is invalid.  The <real-value> is what g-value
373 
+would return.  If <types-p> is T, the <function> should process type information
374 
+for the <slot>.  The <bits> are the internal representation of the slot's
375 
+features.  <indent> is the level of indentation; <limits> is a number (the
376 
+maximum number of values from the <slot> to process), or NIL if all values
377 
+should be processed.
378 
+[2-20-93	Dario Giuse]
379 
+
380 
+
381 
+Generating an error message for type declarations that do not contain any slot
382 
+names at all.  Most often, this results from misplaced parentheses in the
383 
+type declaration.
384 
+
385 
+
386 
+Added support for the same syntax that is used for :CONSTANT slots to all other
387 
+declaration slots (i.e., :IGNORED-SLOTS, :LOCAL-ONLY-SLOTS, :MAYBE-CONSTANT,
388 
+:PARAMETERS, :OUTPUT, :SORTED-SLOTS, :UPDATE-SLOTS).  This allows things
389 
+such as:
390 
+  (create-schema 'a
391 
+    :declare (:parameters :left :top :width) (:update-slots :left :top))
392 
+  (create-instance 'b a
393 
+    :declare (:parameters T :except :width) (:update-slots T :height))
394 
+which behave the same as :CONSTANT declarations (except they do not use the
395 
+:MAYBE-CONSTANT slot, of course).  So, the following would happen:
396 
+  (get-declarations a :parameters) ==> (:left :top :width)
397 
+  (get-declarations b :parameters) ==> (:left :top)
398 
+  (get-declarations b :update-slots) ==> (:height :left :top)
399 
+[2-19-93	Dario Giuse]
400 
+
401 
+
402 
+Fixed problem with setting a value (with S-VALUE) in a slot which had
403 
+a type declaration, but no value.  This used to destroy the type
404 
+declaration, because GET-VALUE was incorrectly used by
405 
+CHECK-SLOT-TYPE.
406 
+[2-8-93		Dario Giuse]
407 
+
408 
+
409 
+
410 
+Fixed check-slot-type to actually ignore the new value if the user decides
411 
+to continue after the error message is given.
412 
+[2-4-93		Dario Giuse]
413 
+
414 
+
415 
+Added better error checking for cases like
416 
+  (create-instance nil 'PROTO)
417 
+where the prototype name is quoted.
418 
+
419 
+Fixed GET-TYPE-DOCUMENTATION, which had gotten mangled and gave an array index
420 
+error.
421 
+[1-21-93	Dario Giuse]
422 
+
423 
+
424 
+Fixed the bug with (create-schema 'A nil (:left 10)), which used to create
425 
+a slot named NIL with value NIL.  This is true of any slot specifier: NIL is
426 
+not allowed in any position.
427 
+[1-19-1993	Dario Giuse]
428 
+
429 
+
430 
+Enabled the #k<...> macro reader by default.  To turn it off, push the
431 
+keyword :NO-K-READER onto the *features* list.
432 
+[1-15-1993	Dario Giuse]
433 
+
434 
+
435 
+Added :OUTPUT as a valid slot declarations.  This is similar to the
436 
+:PARAMETERS declaration, and is meant to allow users to declare slots that
437 
+are computed by formulas and provide useful output values in an object.
438 
+
439 
+Created a reader macro for the #k<...> notation, which is produced when
440 
+*print-as-structure* is non-nil.  This macro allows the thing to be read
441 
+back in as a KR object.
442 
+
443 
+Eliminated the new version of CHECK-SLOT-TYPE, which allowed multiple
444 
+restarts.  This version used some CLTL-II functions that turned out to be
445 
+extremely expensive.
446 
+[1-12-1993	Dario Giuse]
447 
+
448 
+
449 
+Added support for meta-slots, i.e., slots attached to a formula.  This works
450 
+by using a KR schema, which is stored in the formula if needed.  The
451 
+following supports meta-slots:
452 
+
453 
+G-FORMULA-VALUE  formula  slot
454 
+This function returns the value of meta-slot <slot> for the <formula>.
455 
+If the latter is not a formula, or the meta-slot is not present, the
456 
+function returns NIL.  If the <formula> inherits from some other
457 
+formula, inheritance is used to find the meta-slot.
458 
+As a convenience, the <slot> can be the name of an internal formula
459 
+slot, i.e., one of the structure slots used by KR in handling
460 
+formulas.  Such slots should be treated as read-only and should never
461 
+be modified by application programs.  The built-in slot names are:
462 
+ :DEPENDS-ON (object, or list of objects, on which the formula depends)
463 
+ :SCHEMA (object on which the formula is installed)
464 
+ :SLOT (slot on which the formula is installed)
465 
+ :CACHED-VALUE (current cached value of the formula)
466 
+ :VALID (whether the formula is valid)
467 
+ :PATH (path accessor, if any)
468 
+ :IS-A (parent formula, or NIL)
469 
+ :FUNCTION (compiled formula expression)
470 
+ :LAMBDA (original formula expression)
471 
+ :IS-A-INV (child formula, or list of children formulas)
472 
+ :NUMBER (valid/invalid bit, and cycle counter; internal use only)
473 
+
474 
+
475 
+S-FORMULA-VALUE  formula  slot  value
476 
+Sets the value of a meta-slot in a formula.  Creates a meta-schema if
477 
+needed.
478 
+
479 
+
480 
+FORMULA and O-FORMULA now take, as additional parameters, slot
481 
+specifications in the style of CREATE-INSTANCE.  The slot
482 
+specifications are used to create meta-information for the formula.
483 
+Note that to do so, one has to specify the default initial value for
484 
+the formula, which is also an optional parameter.  For example:
485 
+  (o-formula (get-value a :top) NIL
486 
+	   (:creator 'GILT) (:date "today"))
487 
+creates a formula with two meta-slots, :creator and :date.
488 
+[1-8-1993	Dario Giuse]
489 
+
490 
+
491 
+Added the (non-exported) function MAKE-INTO-O-FORMULA, which modifies a
492 
+formula created using FORMULA to look like it was created using O-FORMULA.
493 
+This allows the formula to be dumped properly with save-gadget.  It is possible
494 
+to specify that the expression be compiled first.
495 
+The syntax is:
496 
+(make-into-o-formula formula &optional compile-p)
497 
+[1-4-1993	Dario Giuse]
498 
+
499 
+
500 
+Check-slot-type now allows the user to redefine the value in the slot,
501 
+if desired.  This means that the function now returns multiple values
502 
+if error-p is non-nil, as follows:
503 
+
504 
+- if error-p is non-nil, returns multiple values:
505 
+  - a replacement value, if the user chose to continue and supply a
506 
+    replacement;  T if no error;  NIL otherwise;
507 
+  - one of the following:
508 
+    - T (if type error and the user did not supply a value), or
509 
+    - NIL (if there was no type error), or
510 
+    - :REPLACE, if a replacement value was supplied by the user.
511 
+- if error-p is nil, returns a string describing what error condition
512 
+  was found.
513 
+[12-21-1992	Dario Giuse]
514 
+
515 
+
516 
+Added a new type, KR-BOOLEAN, which is equivalent to T.  It allows a
517 
+slot to contain NIL or anything else, but it can be used by editors to
518 
+display a yes/no button for setting the value of slots of this type.
519 
+[12-15-1992	Dario Giuse]
520 
+
521 
+
522 
+Fixed S-TYPE to NOT give an error when the value in the slot is a
523 
+formula.
524 
+
525 
+Added string documentations, i.e., human-readable messages, for types.
526 
+These can be added using the new function SET-TYPE-DOCUMENTATION:
527 
+  SET-TYPE-DOCUMENTATION  type  string
528 
+This function associates the <string> to the type.  When an error
529 
+message which concerns the type is printed, the documentation string
530 
+is printed in addition to the raw type.
531 
+For example:
532 
+  (set-type-documentation '(integer 0) "non-negative integer")
533 
+
534 
+The documentation can be retrieved with GET-TYPE-DOCUMENTATION:
535 
+  (get-type-documentation '(integer 0))
536 
+     ==> "non-negative integer"
537 
+
538 
+
539 
+The error message for bad KR types now tells whether the bad type was
540 
+found as a consequence of evaluating a formula.
541 
+[12-14-1992	Dario Giuse]
542 
+
543 
+
544 
+
545 
+Modified PS to print out type information.  Also, modified to print
546 
+out slots that have been declared but have no value.  The function PS
547 
+now takes two more &key parameters:
548 
+- :types-p    if non-nil, type information for slots is printed out
549 
+- :all-p      if non-nil, even slots that have no value (but which
550 
+              have some attribute bits) are printed out.
551 
+[12-8-1992	Dario Giuse]
552 
+
553 
+
554 
+
555 
+Changed macroexpansion of type declarations.  The old expansion, which
556 
+was incorrect, would replace types with their encoded number.
557 
+However, this could not work, because encoded numbers may change for
558 
+each session.  The new macroexpansion leaves type specifiers alone, so
559 
+the encoding will happen at load time rather than at compile time.
560 
+
561 
+Renamed the new type specifier from IS-A to IS-A-P.  This does not create
562 
+a conflict, and avoids exporting a different name from the KR package.
563 
+It is also more mnemonic.
564 
+
565 
+Changes :declare syntax to use keywords, rather than symbols.  This
566 
+makes it unnecessary to export more symbols (such as TYPE and
567 
+UPDATE-SLOTS) from the KR package.  The new syntax, therefore, is:
568 
+ ... :declare ((:type (integer :left :top)) (:update-slots))
569 
+[12-4-1992	Dario Giuse]
570 
+
571 
+
572 
+Added an error-p parameter to CHECK-SLOT-TYPE.  This allows the
573 
+function to return a string containing the error message, rather than
574 
+raising an error.  The default value of error-p is T, which causes an
575 
+error.
576 
+
577 
+Modified things so declarations, in particular CONSTANT declarations,
578 
+that appear in prototypes can be eliminated in instances by specifying
579 
+an empty clause.  For example, use the expression
580 
+  :declare ((TYPE) (CONSTANT))
581 
+in a create-instance to turn off all constants declared by the
582 
+prototype and eliminate all type declarations.
583 
+[12-2-1992	Dario Giuse]
584 
+
585 
+
586 
+
587 
+Added support for slot types and type checking.  Slots can be declared to be
588 
+of a certain type; if typechecking is enabled (i.e., if kr::*TYPES-ENABLED*
589 
+is non-nil), KR checks the type when a slot is first created using
590 
+CREATE-INSTANCE, set with S-VALUE, or reevaluated by a formula.
591 
+Type declarations are normally inherited at create-instance time, so
592 
+there is no need to specify them in every instance.  To override a
593 
+declaration from a prototype, specify a new type in the instance (the
594 
+type specifier T, which means any type, can be used if you want to
595 
+unrestrict the possible type of a slot).  Note that the symbol NULL
596 
+(not the symbol NIL!) should be used to specify that a slot may
597 
+contain NIL.
598 
+
599 
+
600 
+The syntax of type declarations in create-instance is as follows:
601 
+(create-instance instance prototype
602 
+  :DECLARE (type type1 type2 ...)
603 
+  :DECLARE ((type type1 type2 ...)
604 
+	    (type type1 type2 ...)
605 
+	    (other-declaration decl1 decl2 ...))
606 
+  slot-specifiers ...)
607 
+The keyword :DECLARE introduces a declaration group (currently, only type
608 
+declarations are supported).  Each declaration group consists of a list of
609 
+declarations; if only one is present, the outside parentheses may be
610 
+omitted, as shown in the second line of the example.
611 
+Each declaration, in turns, consists of a symbol (currently, only TYPE
612 
+is supported), followed by one or more list.  In the case of TYPE,
613 
+each list is of the form
614 
+(type-specifier list-of-slots)
615 
+This declares that each slot in the list-of-slots is of the given
616 
+type-specifier.  For example:
617 
+
618 
+(create-instance 'rec opal:rectangle
619 
+  :declare ((type (vector :BOX)
620 
+		  (integer :LEFT :TOP)
621 
+		  ((satisfies plusp) :WIDTH :HEIGHT)
622 
+		  ((or (satisfies schema-p) null) :PARENT)
623 
+		  ((or integer null) :COUNT)
624 
+		  ((member :yes :no) :VALUE)
625 
+		  (list :IS-A))
626 
+	    (type ((or (is-a a-window) null) :WINDOW))
627 
+	    ;; equivalent of :update-slots mechanism
628 
+	    (update-slots :LEFT :TOP :WIDTH :HEIGHT :VALUE))
629 
+  :declare (type (list :IS-A-INV))
630 
+  (:left (o-formula (+ (gvl :parent :left) (floor (gvl :width) 2))))
631 
+  (:top 10))
632 
+
633 
+
634 
+The main (exported) functions that manipulate declarations are as follows:
635 
+
636 
+G-TYPE  schema  slot
637 
+Returns the type information associated with the <slot> of the <schema>.
638 
+
639 
+S-TYPE  schema  slot  type  &optional (check-old T)
640 
+Adds a type declaration to the <slot> in the <schema>.  The <type> should
641 
+be a valid Lisp type declaration, such as INTEGER or (OR LIST SYMBOL).
642 
+Normally, this function checks that the existing value in the <slot> meets
643 
+the new type specification, and gives an error if this is not the case.
644 
+The <check-old> parameter may be set to nil to suppress this behavior;
645 
+this should be used with caution, because it may leave the <slot> with
646 
+a value that does not typecheck.
647 
+
648 
+CHECK-SLOT-TYPE  schema  slot  value
649 
+Checks whether the given <value> is of the valid type for the <slot> in
650 
+the <schema>.  If not, raises a continuable error.  This function is called
651 
+automatically by KR when a slot is modified, so you shouldn't have to
652 
+call it explicitly.
653 
+
654 
+
655 
+GET-DECLARATIONS  schema  selector
656 
+Returns a list of all the slots in the <schema> that have associated
657 
+declarations of the type given by <selector>, which should be one of:
658 
+:TYPE :CONSTANT :UPDATE-SLOTS :LOCAL-ONLY-SLOTS.  If <selector> is
659 
+:TYPE, the return value is a list of lists; for example,
660 
+((:LEFT (OR INTEGER NULL)) (:TOP (OR INTEGER NULL)) (:NUMBER FLOAT))
661 
+If <selector> is any other value, the return value is a list of the
662 
+slots that have the corresponding declaration.
663 
+
664 
+
665 
+GET-SLOT-DECLARATIONS  schema  slot
666 
+Returns a list of all the declarations associated with the <slot> in
667 
+the <schema>.  The list consists of keywords, such as :CONSTANT and
668 
+:UPDATE-SLOT, and (in the case of type declarations) a list of the
669 
+form (:TYPE ...).  For example,
670 
+(get-slot-declarations a :left) ==>
671 
+ (:CONSTANT (:TYPE (OR INTEGER NULL)))
672 
+
673 
+
674 
+IS-A  object
675 
+This is a new type declarations, NOT a function or macro.  It can only
676 
+be used within Lisp type specifiers.  The <object> can be any Garnet
677 
+object.  The type declaration is true of all objects that satisfy
678 
+(is-a-p object), i.e., of all instances (direct or indirect) of the
679 
+<object>.  The following, for example, might be the type specification
680 
+for a :WINDOW slot:
681 
+(s-type foo :window '(or (is-a opal:window) null))
682 
+
683 
+[11-24-1992	Dario Giuse]
684 
+
685 
+
686 
+;;; Version 2.1.14
687 
+
688 
+Changed CALL-PROTOTYPE-FUNCTION to use APPLY instead of FUNCALL, which
689 
+was not correct.  Thanks to Dave Kosbie for the bug report.
690 
+[10-9-1992	Dario Giuse]
691 
+
692 
+
693 
+Fixed problem with GV refusing :SELF as a valid first argument.
694 
+[9-17-1992	Dario Giuse]
695 
+
696 
+
697 
+Eliminated compilation warnings from unused SLOT variable in kr.lisp.
698 
+This was caused by the macroexpansion of iterate-slot-value.
699 
+
700 
+Added increment of kr::*sweep-mark* to RECOMPUTE-FORMULA, a non-exported
701 
+function that is used by some system code in Garnet.  This ensures that
702 
+formulas affected by this function are invalidated properly.
703 
+
704 
+Replaced BREAK with CERROR in all the G-VALUE related functions.  This
705 
+generates a true continuable error, and can be handled
706 
+programmatically if so desired.
707 
+
708 
+Exported the symbol KR:SCHEMA, which may be used for type declarations and
709 
+such.
710 
+[9-14-1992	Dario Giuse]
711 
+
712 
+Split up all the macros in a separate file, named kr-macros.lisp.  This file
713 
+should be compiled and loaded before kr.lisp and constraints.lisp.
714 
+[8-20-1992	Dario Giuse]
715 
+
716 
+
717 
+
718 
+---- last change log update
719 
+
720 
+
721 
+;;; Version 2.0.11
722 
+
723 
+Added checks for NIL objects in G-VALUE and related functions.
724 
+[8-5-1992	Dario Giuse]
725 
+
726 
+
727 
+
728 
+Fixed bug in DESTROY-SLOT which prevented the inverse relation from being
729 
+eliminated when a relation slot was destroyed.
730 
+[7-29-1992	Dario Giuse]
731 
+
732 
+
733 
+Added the new exported macro WITH-DEMON-ENABLED, which is similar to
734 
+with-demon-disabled.  It works identically, except of course that the
735 
+demon is re-enabled if it had been disabled (either selectively or with
736 
+with-demons-disabled).
737 
+[7-28-1992	Dario Giuse]
738 
+
739 
+
740 
+Fixed bug which caused the "...array is nil..." message in Lapidary.  This
741 
+used to happen when a never-evaluated formula referenced a slot though a
742 
+link, and the schema involved in the link was destroyed.  This is fixed by
743 
+adding checks to the GV family of functions.
744 
+
745 
+Calling S-VALUE of a relation slot with a single value which is a valid
746 
+schema still gives a warning, but then continues and sets the relation slot
747 
+with a list of the one schema.
748 
+[7-24-1992	Dario Giuse]
749 
+
750 
+
751 
+Fixed bug in eliminate-formula which caused update to be invoked recursively.
752 
+This bug, introduced in 2.0.1, caused the demon to be invoked when a formula
753 
+was found constant and eliminated.
754 
+[7-15-1992	Dario Giuse]
755 
+
756 
+
757 
+DECLARE-CONSTANT does nothing if *constants-disabled* is set to T.
758 
+This means that this function is a no-operation inside WITH-CONSTANTS-DISABLED.
759 
+[7-14-1992	Dario Giuse]
760 
+
761 
+
762 
+
763 
+Creating a schema with the :override keyword makes sure that formulas that
764 
+depend on the OLD values are properly invalidated.  In the old code, they
765 
+were not.
766 
+
767 
+
768 
+Modified DECLARE for functions FORMULA and DESTROY-CONSTRAINT in kr.lisp,
769 
+hoping to eliminate warnings from some compilers.
770 
+[7-10-1992	Dario Giuse]
771 
+
772 
+
773 
+GV now gives an error message if its first argument is a keyword.  This is
774 
+most likely the result of using GV instead of GVL.
775 
+
776 
+
777 
+DESTROY-SLOT now runs the invalidate demon before deleting the slot.  This
778 
+ensures that the Update algorithm sees the change.
779 
+
780 
+Fixed :override in CREATE-INSTANCE so that the contents of the
781 
+:IS-A-INV slot of the parent are not duplicated.
782 
+[7-9-1992	Dario Giuse]
783 
+
784 
+
785 
+
786 
+;;; Version 2.0.10
787 
+
788 
+Fixed PS to work with formulas (they used to be skipped, after the change
789 
+to SCHEMA-P).
790 
+
791 
+Made it possible for the is-a-inv slot of formulas (i.e., a-formula-is-a-inv)
792 
+to contain single formulas, as well as lists of formulas.  This reduces the
793 
+storage for all formulas which have exactly one child.
794 
+[6-23-1992	Dario Giuse]
795 
+
796 
+
797 
+
798 
+Added an optional parameter, INHERITED, to DOSLOTS.  The parameter controls
799 
+whether inherited slots should be cycled through, in addition to local slots.
800 
+The default is NIL, meaning that only local slots are used.
801 
+
802 
+Fixed bug in DESTROY-SCHEMA which had been introduced in 2.0.8.
803 
+[6-18-1992	Dario Giuse]
804 
+
805 
+
806 
+Made SCHEMA-P return NIL when given a formula.
807 
+[6-17-1992	Dario Giuse]
808 
+
809 
+
810 
+Eliminate potential problem with shared formulas (which should never occur
811 
+anyway).
812 
+[6-3-1992	Dario Giuse]
813 
+
814 
+
815 
+Added a call to MARK-AS-CHANGED inside DESTROY-CONSTRAINT.  This means that
816 
+dependents are notified even if the actual value remains the same.  This
817 
+feature is primarily needed by applications such as C32 and Lapidary, which
818 
+need to know the difference between slots with values and slots with formulas.
819 
+[6-10-1992	Dario Giuse]
820 
+
821 
+
822 
+
823 
+;;; Version 2.0.8
824 
+
825 
+
826 
+Changed DO-SCHEMA-BODY to take a parameter for :override.  This fixes the
827 
+problem with :override in CREATE-SCHEMA actually causing two slots by
828 
+the same name.
829 
+
830 
+
831 
+Incorporate BVZ's changes for CHANGE-FORMULA, so the lambda slot is
832 
+set properly.
833 
+
834 
+Fixed FIND-DEPENDENTS, and consequently GET-DEPENDENTS.  The former
835 
+was still using some obsolete code.
836 
+[5-27-1992	Dario Giuse]
837 
+
838 
+
839 
+Modified kr::GET-DEPENDENTS to always return a list, even if there is
840 
+only one dependent.  Note that the list is reused and should not be
841 
+modified.
842 
+[4-27-1992	Dario Giuse]
843 
+
844 
+
845 
+Link constants are now disabled by default.  They may be enabled by
846 
+setting kr::*link-constants-disabled* to NIL.
847 
+[4-22-1992	Dario Giuse]
848 
+
849 
+
850 
+The function PS now makes sure that all inheritable values are
851 
+actually inherited before printing out an object when the :inherit
852 
+option is set.  This means that the user always sees ALL inheritable
853 
+values from all possible prototypes, no matter whether the values had
854 
+actually been inherited already.
855 
+[4-21-1992	Dario Giuse]
856 
+
857 
+---- last change doc update
858 
+
859 
+
860 
+Added a new mechanism, link constants.  This is somewhat similar to the
861 
+existing :CONSTANT slot, in that it allows the user to specify a list
862 
+of slots.  These slots are considered constant, however, only if they
863 
+appear in a GV or GVL expression, and only if they are not the very
864 
+last slot in the expression.
865 
+The idea is that link constants can be used to declare certain paths
866 
+that involve system-defined slots constant.  For example, inside
867 
+aggregates one can use this to specify that a formula be eliminated if
868 
+it depends on a constant value which is reached via a path that
869 
+consists entirely of :LINK-CONSTANT slots.  This mechanism makes it
870 
+unnecessary to declare all slots in the path constant, and therefore
871 
+allows the user to change intervening slots (in a benign way,
872 
+naturally) if needed.
873 
+
874 
+Added the new exported function DECLARE-LINK-CONSTANT, which takes an
875 
+object and a slot.  This is similar to declare-constant, except that
876 
+it works for link constants.  The only legal value for the second
877 
+argument is a single slot name; T or other values are not allowed.
878 
+[4-20-1992	Dario Giuse]
879 
+
880 
+
881 
+Attempting to call DESTROY-SLOT on a constant slot now gives a continuable
882 
+error, just like S-VALUE.
883 
+[4-16-1992	Dario Giuse]
884 
+
885 
+
886 
+The function PS now prints lists of values properly.  Before, parentheses
887 
+were not printed, which made it impossible to distinguish between single
888 
+values and lists of one element.
889 
+
890 
+Added check in PS for the case when :IGNORED-SLOTS contains a single value
891 
+rather than a list.
892 
+[4-15-1992	Dario Giuse]
893 
+
894 
+
895 
+
896 
+Formulas that are evaluated and found constant are no longer eliminated if
897 
+*constants-disabled* is true, i.e., if inside WITH-CONSTANTS-DISABLED.
898 
+
899 
+
900 
+Fixed bug in copy-to-all-instances (formula pointers were not being set
901 
+properly).
902 
+[4-14-1992	Dario Giuse]
903 
+
904 
+
905 
+Fixed bug in kr-send for objects with a locally-defined NIL method.  This
906 
+used to incorrectly invoke the prototype method.
907 
+
908 
+Fixed bug in PS (for :sorted option on a slot that is not present).
909 
+[4-10-1992	Dario Giuse]
910 
+
911 
+
912 
+Made KR code reentrant, eliminated global variables *slot-position* and
913 
+*slot-array*.
914 
+[4-9-1992	Dario Giuse]
915 
+
916 
+
917 
+
918 
+;;; Version 2.0.7
919 
+
920 
+
921 
+Added non-exported function copy-to-all-instances, which is similar to a
922 
+recursive s-value that works on a schema and ALL its instances, no matter
923 
+whether local values are already set.  This was requested by BVZ.
924 
+[4-6-1992	Dario Giuse]
925 
+
926 
+
927 
+Fixed bug in KR-SEND.
928 
+[4-2-1992	Dario Giuse]
929 
+
930 
+
931 
+
932 
+Fixed call-prototype-method.  The latest version would go into an infinite
933 
+loop if A had no method, B (is-a A) had a method which used
934 
+call-prototype, and C (is-a B) also had a method using
935 
+call-prototype-method.
936 
+[4-1-1992	Dario Giuse]
937 
+
938 
+
939 
+Added the variable kr::*REDEFINE-OK* which can be used to turn off
940 
+errors caused by create-instance redefining slots that were declared constant
941 
+in a prototype.
942 
+[3-20-1992	Dario Giuse]
943 
+
944 
+
945 
+It is now illegal for create-instance to set the value of a slot that was
946 
+declared constant in the prototype.  Currently, this causes a continuable
947 
+error.
948 
+[3-19-1992	Dario Giuse]
949 
+
950 
+
951 
+Reduced consing for CREATE-INSTANCE.
952 
+[3-18-1992	Dario Giuse]
953 
+
954 
+
955 
+Changed the :CONSTANT slot such that it is now possible to specify its contents
956 
+using a formula, rather than a hard-wired list.  Of course, the value of the
957 
+formula is only used at instance creation time.
958 
+[3-17-1992	Dario Giuse]
959 
+
960 
+
961 
+Modified KR-SEND and CALL-PROTOTYPE-METHOD to handle the latter much faster.
962 
+This is done by keeping track of the last place from which a method was
963 
+inherited, allowing the search for the next method to start from the middle
964 
+of the hierarchy rather than from the bottom.
965 
+[3-16-1992	Dario Giuse]
966 
+
967 
+
968 
+Rewrote create-schema and create-instance almost completely.  The mechanism
969 
+avoids consing for slot creation, using a reusable set of arrays instead.
970 
+[3-11-1992	Dario Giuse]
971 
+
972 
+
973 
+
974 
+;;; Version 2.0.6
975 
+
976 
+Made recursive destroy of objects (which occurs when creating a named schema
977 
+more than once) considerably faster.  This is done by having the
978 
+low-level code know that it is not necessary to maintain relations and
979 
+their inverses in such cases, since everything will be destroyed
980 
+anyway.
981 
+[3-10-1992	Dario Giuse]
982 
+
983 
+
984 
+Fixed bug with :NAME-PREFIX in create-instance.  The syntax was broken, and
985 
+made it impossible to specify the name prefix properly.
986 
+The syntax is now the same as in create-schema:
987 
+(create-instance nil prototype :name-prefix "MY-NAME" (...slots))
988 
+[3-9-1992	Dario Giuse]
989 
+
990 
+
991 
+Better error checking for DESTROY-CONSTRAINT.  If any of the children of the
992 
+formula have already been destroyed, nothing bad happens.  Other children are
993 
+still destroyed as usual.
994 
+[3-2-1992	Dario Giuse]
995 
+
996 
+
997 
+
998 
+Better diagnostics for the case where there is an extra ' in front of
999 
+a constant list.
1000 
+
1001 
+Attempting to set a constant slot now results in a continuable error,
1002 
+i.e. a call to BREAK.  Previously, there was no way to continue from
1003 
+the error.
1004 
+[2-20-1992	Dario Giuse]
1005 
+
1006 
+
1007 
+
1008 
+;;; Version 2.0.5
1009 
+
1010 
+Added check for null schema in S-VALUE.  Modified the macroexpansion
1011 
+to generate less inline code and allow better checking.
1012 
+
1013 
+
1014 
+Created the non-exported function kr::GET-LAMBDA.  Given a formula, it
1015 
+returns the expression that was used to create the formula (as a
1016 
+list).  Given anything else, it returns NIL.
1017 
+
1018 
+
1019 
+Added BVZ's fixes to satisfy the Lucid compiler.  Among others,
1020 
+changed the initial size of *reuse-formulas* and *reuse-slots* to 1,
1021 
+but kept the fill pointer to 0.
1022 
+
1023 
+
1024 
+Modified IS-A-P to handle formulas as well as schemata.
1025 
+
1026 
+
1027 
+Fixed bug in S-VALUE for the case when a formula was being installed
1028 
+on a slot that had dependents.  This happened when the slot contained
1029 
+another unevaluated formula which caused a broken link throw (thanks
1030 
+to BVZ for the fix).
1031 
+[2-19-1992	Dario Giuse]
1032 
+
1033 
+
1034 
+The function PATH is now named KR-PATH.  Actually, this is an old
1035 
+change, but the original description managed to disappear from the
1036 
+change log.
1037 
+
1038 
+
1039 
+Added some error checking in PROPAGATE-CHANGE.  This code checks for
1040 
+formulas that are installed on destroyed schemata.
1041 
+
1042 
+
1043 
+Exported the function DECLARE-CONSTANT.
1044 
+
1045 
+It is now possible to use T as the second argument to
1046 
+DECLARE-CONSTANT.  This means that all slots that were defined in
1047 
+:MAYBE-CONSTANT (if any) are declared constant for the schema.
1048 
+The syntax is (declare-constant schema T).
1049 
+
1050 
+
1051 
+Modified SCHEMA-P to do a better job of checking for destroyed
1052 
+objects.  The function now returns T if the object is a schema AND it
1053 
+was not destroyed.
1054 
+
1055 
+
1056 
+Changed the way destroyed schemata (and formulas) are handled.  Destroyed
1057 
+objects are now marked by setting their "slots" structure slot to nil.  The
1058 
+advantage is that the old name remains around.  Consequently, destroyed
1059 
+objects are now printed in a more informative way.  For example,
1060 
+  (create-schema 'a (:left 10))
1061 
+  (setf p a)		; store pointer to schema
1062 
+  (destroy-schema a)
1063 
+  (ps p)    prints out:
1064 
+  *DESTROYED*(was A)
1065 
+
1066 
+
1067 
+Also, reused storage in formula structures.  The "a-formula-slots"
1068 
+structure slot, which was shared with the "schema" structure, was
1069 
+unused for formulas.  It is now used to store "a-formula-number",
1070 
+through a macro definition.  Destroying the formula sets this slot to
1071 
+NIL, which is fine.
1072 
+[2-13-1992	Dario Giuse]
1073 
+
1074 
+
1075 
+
1076 
+;;; Version 2.0.4
1077 
+
1078 
+
1079 
+Eliminated the setting of dependencies for constant slots (one case was
1080 
+not handled properly).
1081 
+
1082 
+Fixed a bug in DECLARE-CONSTANT.
1083 
+
1084 
+Fixed a bug in constant evaluation which caused formulas that had not been
1085 
+inherited always to be considered non-constant, even though they would, in
1086 
+fact, eventually become constant.
1087 
+[2-12-1992	Dario Giuse]
1088 
+
1089 
+
1090 
+Changed formula inheritance so that when a formula is inherited, it is made
1091 
+an instance of the prototype's formula.  This saves some storage.
1092 
+[2-11-1992	Dario Giuse]
1093 
+
1094 
+
1095 
+
1096 
+Created a new, non-exported function named MOVE-FORMULA.  It takes a formula
1097 
+from a slot in a schema and moves it to another slot in another schema.  This
1098 
+function is needed because simply using something like
1099 
+  (s-value new-schema new-slot (get-value old-schema old-slot))
1100 
+creates a deadly situation, i.e., a formula which is stored in two slots
1101 
+at once.
1102 
+Syntax:
1103 
+  (MOVE-FORMULA from-schema from-slot to-schema to-slot)
1104 
+[2-6-1992	Dario Giuse]
1105 
+
1106 
+
1107 
+Created a new function named DECLARE-CONSTANT.  This
1108 
+function may be used to declare that a slot is constant AFTER instance
1109 
+creation time.  The behavior is the same as if the slot had been
1110 
+declared in the :CONSTANT slot at instance creation time, although of
1111 
+course the change does not affect other formulas which might have been
1112 
+evaluated previously.
1113 
+The :CONSTANT slot is modified accordingly: the new slot is added, and
1114 
+it is removed from the :EXCEPT portion if it was originally declared there.
1115 
+Syntax:
1116 
+  (DECLARE-CONSTANT schema slot)
1117 
+[2-6-1992	Dario Giuse]
1118 
+
1119 
+
1120 
+
1121 
+
1122 
+Modified s-value and create-instance to check for formulas that are
1123 
+already installed on another slot.  This is an error, since a formula
1124 
+should only be installed on one slot at a time.
1125 
+[2-6-1992	Dario Giuse]
1126 
+
1127 
+
1128 
+;;; Version 2.0.3
1129 
+
1130 
+Fixed a bug in run-invalidate-demons which caused the incorrect demon
1131 
+(i.e., the demon from the original schema rather than the schema whose
1132 
+formula was becoming invalid) to be called.
1133 
+[2-5-1992	Dario Giuse]
1134 
+
1135 
+
1136 
+Modified the dependents portion of slots so that a single value
1137 
+(rather than a list) is stored if the slot is depended on by only one
1138 
+formula.
1139 
+[2-3-1992	Dario Giuse]
1140 
+
1141 
+
1142 
+Created a new function, kr::SLOT-CONSTANT-P, which tells whether a slot
1143 
+was declared constant or has been made constant through formula evaluation.
1144 
+Note that the function returns NIL for unevaluated formulas, even
1145 
+though they might become constant upon evaluation.
1146 
+SYNTAX:   (kr::slot-constant-p schema slot)
1147 
+RETURNS:  T if slot is constant, NIL otherwise
1148 
+[2-3-1992	Dario Giuse]
1149 
+
1150 
+
1151 
+Added the new macro WITH-DEMON-DISABLED, which is rather similar to
1152 
+WITH-DEMONS-DISABLED.  While the latter disables all demons, however,
1153 
+the former takes a specific demon which is disabled; other demons are
1154 
+executed normally.
1155 
+Syntax: (with-demon-disabled demon &body body)
1156 
+Examples:
1157 
+  (with-demon-disabled 'opal::rectangle-invalidate-demon
1158 
+    ...)
1159 
+  (with-demon-disabled (g-value foo :invalidate-demon)
1160 
+    ...)
1161 
+[1-31-1992	Dario Giuse]
1162 
+
1163 
+
1164 
+Removed the obsolete variable *ALLOW-CHANGE-TO-CACHED-VALUE*
1165 
+[1-30-1992	Dario Giuse]
1166 
+
1167 
+
1168 
+The variable *debug-switch*, which controls the printing of debugging
1169 
+information, is now exported from the KR package.
1170 
+[1-30-1992	Dario Giuse]
1171 
+
1172 
+
1173 
+Created two new functions (actually, a macro and a function) to split the
1174 
+work of CREATE-INSTANCE.  This can be used (by developers) to create
1175 
+complex objects that need special constant-slot processing.  The
1176 
+following sequence demonstrates a possible application:
1177 
+  (begin-create-instance 'inst complex-part
1178 
+  	(:left 13) (:top (o-formula ...)))
1179 
+  (s-value inst :foo "BAR")
1180 
+  (s-value inst :width 100)
1181 
+  (s-value inst :constant (if ... '(:left :top :width) T))
1182 
+  (end-create-instance inst)
1183 
+
1184 
+The first half (i.e., the call to BEGIN-CREATE-INSTANCE) sets up the
1185 
+schema and the initial value of the slots.  In the example, nothing is
1186 
+declared constant.  Some slots are then set, including the :CONSTANT
1187 
+slot.  The second half (i.e., the call to END-CREATE-INSTANCE)
1188 
+processes the constant declarations and then calls the :INITIALIZE
1189 
+method for the instanec.
1190 
+[1-30-1992	Dario Giuse]
1191 
+
1192 
+
1193 
+Trying to set a constant slot now generates an actual error.  If the variable
1194 
+kr::*constants-disabled* is non-nil, however, nothing happens.  This is the
1195 
+same variable that cab be used to turn off constant processing in
1196 
+CREATE-INSTANCE.
1197 
+[1-30-1992	Dario Giuse]
1198 
+
1199 
+
1200 
+Changed the mechanism for demon invocation.  NOTE: this applies only
1201 
+to the invalidate demon; the pre-set-demon, which is unused in Garnet, is not
1202 
+affected.
1203 
+The demon is now stored in objects (typically, it is inherited),
1204 
+rather than stored in the local variable kr::*invalidate-demon*.  If a
1205 
+demon is present in the :INVALIDATE-DEMON slot of an object, the demon is
1206 
+invoked.  The check for invocation is as before, i.e., the demon is invoked
1207 
+only if the name of the slot that is being invalidated is present in the
1208 
+:UPDATE-SLOTS slot of the object.
1209 
+[1-30-1992      Dario Giuse]
1210 
+
1211 
+
1212 
+;;; Version 2.0.2
1213 
+
1214 
+The switch to control whether constant declarations are used is now called
1215 
+kr::*constants-disabled* .  It may be bound to T to cause all constant
1216 
+declarations to be ignored.  This includes turning off error checking
1217 
+for setting slots that are declared constant.
1218 
+[1-29-1992	Dario Giuse]
1219 
+
1220 
+
1221 
+
1222 
+;;; Version 2.0.1
1223 
+
1224 
+Added a new (non-exported) function, GET-DEPENDENTS.  Given a schema and a
1225 
+slot, it returns the list of formulas which depend on the slot.
1226 
+Syntax:
1227 
+(GET-DEPENDENTS SCHEMA SLOT)
1228 
+
1229 
+
1230 
+The depends-on slot of formulas may now contain either a single schema or
1231 
+a list of schemata.  This saves storage in the common case.
1232 
+[1-13-1992	Dario Giuse]
1233 
+
1234 
+
1235 
+
1236 
+
1237 
+Changed the syntax for constant slot declarations.  Things are now as
1238 
+follows:
1239 
+
1240 
+- the :MAYBE-CONSTANT slot is used in prototypes to declare a list
1241 
+  of slots which instances may want to declare constant.  This should
1242 
+  correspond to the user-settable "parameters" of a gadget, for example.
1243 
+  This declaration, per se, has no effect.
1244 
+
1245 
+- the :CONSTANT slot is used at instance creation time to control
1246 
+  which slots are actually marked constant.  The syntax is:
1247 
+  ( :constant [T] [ADD-SLOTS] [:except DELETE-SLOTS] )
1248 
+  - T, if specified, declares that all slots contained in the :MAYBE-CONSTANT
1249 
+    slot (which is typically inherited from a prototype) should be declared
1250 
+    constant.
1251 
+  - ADD-SLOTS, if specified, is a list of slots which should be declared
1252 
+    constant.  If T was also specified, the two lists are merged.
1253 
+  - if :EXCEPT is specified, all slot names which follow it are taken out
1254 
+    of the list of constant slot.  This mechanism allows the user to eliminate
1255 
+    certain slots from the list which was specified in :MAYBE-CONSTANT.
1256 
+
1257 
+The following examples illustrate the use of the new syntax.
1258 
+
1259 
+
1260 
+(create-instance 'prototype NIL (:MAYBE-CONSTANT :left :top)
1261 
+  (:width (o-formula (+ (gvl :left) 40))))
1262 
+
1263 
+(create-instance 'inst-1 prototype
1264 
+  (:CONSTANT T)
1265 
+  (:left 12) (:top 100))
1266 
+
1267 
+The first time (g-value inst-1 :width) is evaluated, the system will notice
1268 
+that the formula depends only on the constant slot inst-1.left, and will
1269 
+eliminate the formula.  Afterwards, inst-1.width will contain the number 42,
1270 
+rather than a formula.
1271 
+
1272 
+
1273 
+(create-instance 'inst-2 prototype
1274 
+  (:CONSTANT :slot-1 :slot-2 T :EXCEPT :left)
1275 
+  (:slot-1 12))
1276 
+
1277 
+
1278 
+Slots :top, :slot-1, and :slot-2 are declared constant.  Slot :left is not,
1279 
+even though it appears in the prototype's :MAYBE-CONSTANT, because it is
1280 
+explicitly excluded via the :EXCEPT keyword.
1281 
+
1282 
+
1283 
+(create-instance 'example nil
1284 
+  (:MAYBE-CONSTANT :left :top :width :height)
1285 
+  (:CONSTANT T)
1286 
+  (:left 12))
1287 
+
1288 
+
1289 
+This example declares the :maybe-constant slot, which will be used by
1290 
+future instances, and also declares that the four slots should be constant
1291 
+in the EXAMPLE schema.
1292 
+
1293 
+[1-8-1992	Dario Giuse]
1294 
+
1295 
+
1296 
+
1297 
+;; Version 2.0
1298 
+
1299 
+
1300 
+Changed G-LOCAL-VALUE to work properly with the new formula inheritance
1301 
+scheme.  When a formula is inherited from a prototype, it is now marked
1302 
+as inherited.  However, G-LOCAL-VALUE used to fail on this, and returned
1303 
+nil.  The fixes version evaluates the formula and returns its value.
1304 
+[1-6-1992	Dario Giuse]
1305 
+
1306 
+
1307 
+
1308 
+Changed create-instance to avoid copying formulas down at instance creation
1309 
+time.
1310 
+
1311 
+Fixed s-value.  Setting a prototype slot now correctly changes the values of
1312 
+all the slots which inherited a value, even though the prototype slot contained
1313 
+a formula.
1314 
+[1-3-1992	Dario Giuse]
1315 
+
1316 
+
1317 
+Inherited formulas which are declared constant in the prototype are now
1318 
+destroyed after their are evaluated the first time.
1319 
+[12-12-1991	Dario Giuse]
1320 
+
1321 
+
1322 
+
1323 
+Significantly reduced the size of the code generated by CREATE-INSTANCE and
1324 
+GVL.  The former now produces a function call; the latter produces more
1325 
+efficient, iterative code when all slots in a GV link are special slots.
1326 
+[12-10-1991	Dario Giuse]
1327 
+
1328 
+
1329 
+Fixed a problem with DOVALUES which caused a compilation error if the
1330 
+body of dovalues contained a (RETURN) statement.  This was not working
1331 
+because of the special branch taken if the slot ended up containing a
1332 
+single value instead of a list.
1333 
+
1334 
+
1335 
+Made PS print the expression (i.e., the lambda slot) of formulas.
1336 
+
1337 
+
1338 
+
1339 
+Fixed the problem with gv-local.  This happened because G-LOCAL-VALUE (which
1340 
+is used by gv-local) does NOT create an empty slot, and therefore the
1341 
+function SETUP-DEPENDENCY did not have any place to record the dependency.
1342 
+[12-3-1991	Dario Giuse]
1343 
+
1344 
+
1345 
+Eliminated the problem with IS-A-P which forced the file KR.LISP to have to
1346 
+be compiled twice.  Simply moved that function to CONSTRAINTS.LISP.
1347 
+[12-2-1991	Dario Giuse]
1348 
+
1349 
+
1350 
+Added code for constant formulas.  This code is, for now, conditionally
1351 
+compiled (on a #+SUICIDE switch).
1352 
+This supports the following extensions to the syntax:
1353 
+- a slot in create-schema or create-instance may be specified as, e.g.,
1354 
+  (:CONST :left 14)
1355 
+  This declares the :left slot to be a constant.  Formulas which only
1356 
+  depend on constant slots are eliminated.
1357 
+	(*** note - the name of this slot is now :CONSTANT)
1358 
+- the slot :MAYBE-CONSTANTS may be specified in prototypes.  When this
1359 
+  is done, the contents of the slot (which must be a list of slot names)
1360 
+  are used to determined what slots in the INSTANCES of the prototype will
1361 
+  be marked constant at instance-creation time.
1362 
+- the slot :NOT-CONSTANT-SLOTS may be specified in instances.  If it is
1363 
+  specified (its contents must be a list of slots), all slots mentioned in
1364 
+  it are NOT marked constant, even if the prototype declares them as
1365 
+  constant.  This slot is NOT inherited - it must be present locally.
1366 
+	(*** note - this last point is now obsolete)
1367 
+[11-25-1991	Dario Giuse]
1368 
+
1369 
+
1370 
+Fixed problem in demo-arith by eliminating the setting of a KR slot in a
1371 
+formula.  This is no longer allowed in KR 1.5.1
1372 
+[11-14-1991	Dario Giuse]
1373 
+
1374 
+
1375 
+
1376 
+Fixed the problem with leftbutton not working in demo-grow.  This required
1377 
+setting the window formula to be invalid in the select-it interactor.  Change
1378 
+is in interactors.lisp (in function Check-Required-Slots)
1379 
+[11-12-1991	Dario Giuse]
1380 
+
1381 
+
1382 
+Fixed FULL and PS to work properly when a value is a dotted pair.
1383 
+[11-8-1991	Dario Giuse]
1384 
+
1385 
+
1386 
+
1387 
+Sped up propagate-change and setup-dependency, by using a new function
1388 
+named find-dependents.
1389 
+
1390 
+
1391 
+;; new version (from opal/update-basics.lisp):
1392 
+(defun update-slot-invalidated (gob slot save)
1393 
+  (declare (ignore save))
1394 
+  (let* ((gob-update-info (g-local-value gob :update-info))
1395 
+	 (the-window (if gob-update-info
1396 
+			 (update-info-window gob-update-info))))
1397 
+  (if the-window
1398 
+    (if (eq the-window gob)			;; is this a window?
1399 
+      (pushnew slot (win-update-info-invalid-slots
1400 
+			(g-local-value the-window :win-update-info)))
1401 
+      (and (not (update-info-invalid-p gob-update-info))
1402 
+	   (make-object-invalid gob gob-update-info the-window))))))
1403 
+[10-29-1991	Dario Giuse]
1404 
+
1405 
+
1406 
+Modified GV to work properly when a relation slot is used inside a path.
1407 
+For example, (gv :parent :components :left) works, even though the second
1408 
+slot returns a list of components.  The fist component in the list is simply
1409 
+used.  This provides backward compatibility.
1410 
+[10-20-1991	Dario Giuse]
1411 
+
1412 
+
1413 
+Added a switch, tentatively named *debug-switch*, which can be used to improve
1414 
+error checking in KR.  Currently, this can be set to T to generate meaningful
1415 
+error messages within GV if a non-schema value is found in the middle of a
1416 
+path.
1417 
+[10-16-1991	Dario Giuse]
1418 
+
1419 
+
1420 
+Fixed the following problem:
1421 
+When a slot has a formula which evaluates to NIL, and when the slot
1422 
+is valid, it still shows the display as:
1423 
+  :FOO =  #k<KR-DEBUG:F590>(nil . NIL)
1424 
+whereas it should be (NIL . T)
1425 
+[10-15-1991	Dario Giuse]
1426 
+
1427 
+
1428 
+Merged the two versions of G-VALUE-FN, improved generated code when schema
1429 
+is simply a symbol.
1430 
+[10-14-1991	Dario Giuse]
1431 
+
1432 
+
1433 
+Added a DEFVAR variable, kr::*store-lambdas*, which allows formulas to be
1434 
+stored without the lambda expression.  The default, T, means to store the
1435 
+expression.  This is a compile-time switch.
1436 
+[10-10-1991	Dario Giuse]
1437 
+
1438 
+
1439 
+Optimized propagate-change by using dependent-position instead of a full
1440 
+slot-accessor.
1441 
+[10-9-1991	Dario Giuse]
1442 
+
1443 
+
1444 
+
1445 
+;;; Version 1.5.0
1446 
+
1447 
+
1448 
+[Group of changes from Brad Vander Zanden follows:]
1449 
+
1450 
+1. Changed code that handled cycles. Cycles are now detected using
1451 
+	the strong connectivity algorithm given in Aho, Hopcroft, and
1452 
+	Ullman on pp 189-195. Any strongly connected component of size
1453 
+	greater than 1 is a cycle. Cycles of size 1 (i.e., a slot that
1454 
+	depends on itself) are not labeled as cycles, but the dependencies
1455 
+	are labeled as being part of a cycle, so everything works out.
1456 
+
1457 
+	The code changes involved replacing check-priority and reorder,
1458 
+	deleting validate-cycle, renumber-cycle, and invalidate, and
1459 
+	adding a new function called reorder-formulas.
1460 
+
1461 
+2. Changed the set-cycle-bit and set-valid-bit macros. They used to assume
1462 
+	that the value parameter was either t or nil. They were changed so
1463 
+	that the value parameter can be an expression that is computed at
1464 
+	run time.
1465 
+
1466 
+3. Changed the last parameter in a call to add-to-reeval from
1467 
+	(cycle-p *current-formula*) to t. The call was in re-evaluate-formula.
1468 
+
1469 
+4. Replaced a call to invalidate with a call to reorder-formulas in
1470 
+	propagate.
1471 
+
1472 
+5. Changed the last line of mark-as-changed from a call to propagate to
1473 
+	a call to add-to-reeval. The add-to-reeval call adds the slot's
1474 
+	dependents to the evaluation queue, ensuring that they will be
1475 
+	evaluated the next time propagate is called. The original code did
1476 
+	not add the dependents to the evaluation queue, so the change was
1477 
+	never noticed.
1478 
+
1479 
+6. Added a statement to g-value-inherit-values that add a formula to
1480 
+	the evaluation queue if necessary.
1481 
+
1482 
+7. Added a progn statement to destroy-slot that in the case of eager
1483 
+	evaluation, resets a formula's fixed bit to nil and places the
1484 
+	formula on the evaluation queue. This has the same effect as
1485 
+	setting the formula's cache value bit to nil in lazy evaluation.
1486 
+	Added a second statement earlier in destroy-slot that saves the
1487 
+	eval-bit for a formula before it is s-valued with a value.
1488 
+
1489 
+8. In update-inherited-values, I changed the behavior of the function if
1490 
+	the inherited value is a formula. Instead of calling propagate and
1491 
+	then extracting the value of the formula, I create an instance of
1492 
+	the formula and store the instance in the inherited slot. This
1493 
+	change occurred in two different blocks of code in update-inherited-
1494 
+	values. In both cases, the statements:
1495 
+
1496 
+	  (progn
1497 
+	    (propagate)
1498 
+	    (setf value (cached-value value)))))
1499 
+
1500 
+	were replaced by the statements:
1501 
+
1502 
+	      (progn
1503 
+		(setf value (formula value))
1504 
+		(setf (a-formula-schema value) schema)
1505 
+		(setf (a-formula-slot value) a-slot)
1506 
+		(setf *eval-queue* (insert-pq value *eval-queue*)))))
1507 
+
1508 
+	This is not completely correct, because it doesn't take the old
1509 
+	value of the slot and store it in the new formula.
1510 
+[4-2-1991]
1511 
+
1512 
+
1513 
+
1514 
+Renamed to version 1.5.0, since 1.4 is being released.
1515 
+[3-26-1991	Dario Giuse]
1516 
+
1517 
+
1518 
+
1519 
+; Version 1.4.2
1520 
+
1521 
+
1522 
+Improved the error message when GV or GVL are mistakenly used without a
1523 
+formula wrapped around them.  The message now explains what might have
1524 
+happened and shows the name of the last slot in the GV expression.
1525 
+[1-18-1991	Dario Giuse]
1526 
+
1527 
+
1528 
+First working version of 1.4.2 (without eager evaluation).  The following
1529 
+are the main highlights:
1530 
+
1531 
+Storage for KR schemata is greatly reduced.  Slots are represented in a
1532 
+completely new fashion.
1533 
+
1534 
+Multiple values are no longer supported (although some old functions are
1535 
+provided for backward-compatibility).  All slots now store a single value,
1536 
+which of course may be a list of values.  All relation slots store a list
1537 
+of schemata (i.e., the single value in the slot is a list).
1538 
+
1539 
+Local-only-slots is also handled as a list of lists.
1540 
+
1541 
+inheriting values from a slot with a formula now creates a copy of the
1542 
+formula.
1543 
+
1544 
+[1-15-1991	Dario Giuse]
1545 
+
1546 
+
1547 
+
1548 
+; Version 1.4.1
1549 
+
1550 
+
1551 
+Fixed METHOD-TRACE, which was hopelessly broken and had been so for a long time.
1552 
+[10-24-1990	Dario Giuse]
1553 
+
1554 
+
1555 
+;;; version 1.3.24
1556 
+
1557 
+
1558 
+Added the non-exported function INHERITED-P
1559 
+[9-12-1990	Dario Giuse]
1560 
+
1561 
+
1562 
+Fixed bug with (CREATE-INSTANCE NIL).
1563 
+[9-11-1990	Dario Giuse]
1564 
+
1565 
+
1566 
+Fixed DELETE-SCHEMA to do nothing if given a schema that was already destroyed.
1567 
+[9-11-1990	Dario Giuse]
1568 
+
1569 
+
1570 
+Fixed bug with setting formulas which depend on relation slots (this was a
1571 
+bug in REMOVE-FORMULAS, and was reported by Brad Vander Zanden).
1572 
+[9-7-1990	Dario Giuse]
1573 
+
1574 
+
1575 
+Modified KR-SEND to avoid infinite loops (when looking for a method) if there
1576 
+are loops in the inheritance hierarchy.  This was causing problems in
1577 
+degenerate cases.
1578 
+[9-4-1990	Dario Giuse]
1579 
+
1580 
+
1581 
+Modified DESTROY-SCHEMA to call the :DESTROY method on the schema just before
1582 
+it gets rid of it.  This was previously disabled because of the problems with
1583 
+infinite loops looking for a method, as described above.
1584 
+[9-4-1990	Dario Giuse]
1585 
+
1586 
+
1587 
+Fixed CREATE-SCHEMA so that the following would behave properly:
1588 
+(create-schema 'foo :override)
1589 
+in the case where foo was NOT a previously created schema.  This code used
1590 
+to do nothing, i.e., the schema would not be created at all.
1591 
+[9-4-1990	Dario Giuse]
1592 
+
1593 
+
1594 
+
1595 
+;;; version 1.3.23
1596 
+
1597 
+
1598 
+Eliminated problem with the *debug-names* array (reported by Paul Werkowski).
1599 
+The array is now initialized to NIL elements.
1600 
+[9-4-1990	Dario Giuse]
1601 
+
1602 
+
1603 
+
1604 
+Added a new exported function, RECOMPUTE-FORMULA.  This function takes a schema
1605 
+and a slot, and forces the formula in the slot to be recomputed.  The change is
1606 
+then propagated and demons are fired as usual, exactly as if the formula had
1607 
+been recomputed because of a change in its depended values.
1608 
+The syntax is:
1609 
+  (RECOMPUTE-FORMULA SCHEMA SLOT)
1610 
+If the <schema> does not contain a formula in the <slot>, nothing happens.
1611 
+[9-3-1990	Dario Giuse]
1612 
+
1613 
+
1614 
+
1615 
+Eliminated the change to MARK-AS-CHANGED (see 8-29-90), which apparently
1616 
+caused some compatibility problems.
1617 
+[9-3-1990	Dario Giuse]
1618 
+
1619 
+
1620 
+
1621 
+Modified MARK-AS-CHANGED so that when it is called on a slot which contains
1622 
+a formula, it immediately reevaluates the formula.  This behavior is different
1623 
+from the previous one, which always left the slot itself unchanged.
1624 
+--- NOTE - this change was eliminated - see 9-3-1990)
1625 
+[8-29-1990	Dario Giuse]
1626 
+
1627 
+
1628 
+
1629 
+Fixed a couple of bugs in MARK-AS-CHANGED, including the one reported by
1630 
+Roger a while back.  This bug meant that slots which had formulas depending
1631 
+on inherited values which should have been invalidated were not.
1632 
+[8-20-1990	Dario Giuse]
1633 
+
1634 
+
1635 
+
1636 
+Fixed CREATE-INSTANCE so that local overriding of slots which might be
1637 
+inherited but are declared as :local-only-slots does the right thing, i.e.,
1638 
+the overriding value takes precedence.
1639 
+
1640 
+
1641 
+The macros GET-VALUE and GET-VALUES no longer retrieve values in :is-a-inv
1642 
+slots which are not local.  This is equivalent to making the slot :IS-A-INV
1643 
+a :local-only-slots slot.  Other functions may have to do the same thing, for
1644 
+consistency.
1645 
+[8-1-1990	Dario Giuse]
1646 
+
1647 
+
1648 
+
1649 
+Create-INSTANCE now uses a special slot in a prototype to control whether
1650 
+values should be inherited normally, or whether certain slots in the
1651 
+prototype are considered local only and therefore should NOT be inherited.
1652 
+
1653 
+The slot is called :LOCAL-ONLY-SLOTS; it should contain any number of
1654 
+lists, where each list consists of a slot name and T or NIL.
1655 
+
1656 
+If the second element of the list is T, the value of the slot in the
1657 
+prototype is copied into the instance, and inheritance is never used
1658 
+thereafter.  Note that if the value in the prototype contains a formula,
1659 
+the formula is copied down.
1660 
+
1661 
+If, on the other hand, the second element of the list is NIL, the slot is never
1662 
+inherited, and it is created in the instance with the value NIL.
1663 
+
1664 
+The following example explains the different behaviors:
1665 
+  (create-schema 'a (:left 15) (:top 21) (:width 32)
1666 
+	            (:local-only-slots '(:top T) '(:width NIL)))
1667 
+  (create-instance 'b a)
1668 
+  (g-value b :left)  ==> 15	; inherited
1669 
+  (g-value b :top)   ==> 21     ; instance slot was set to prototype value
1670 
+  (g-value b :width) ==> NIL    ; instance slot was set to NIL
1671 
+
1672 
+  (s-value a :left 100)
1673 
+  (s-value a :top 100)
1674 
+  (s-value a :width 100)
1675 
+
1676 
+  (g-value b :left)  ==> 100	; new value is inherited as usual
1677 
+  (g-value b :top)   ==> 21	; value is unaffected
1678 
+  (g-value b :width) ==> NIL    ; value is unaffected
1679 
+[7-30-1990	Dario Giuse]
1680 
+
1681 
+
1682 
+
1683 
+CREATE-SCHEMA (and thus CREATE-INSTANCE) now destroy all old instances of a
1684 
+schema, in addition to the old schema itself, when they create the schema.
1685 
+For example, the code
1686 
+  (create-schema 'a (:left 10))
1687 
+  (create-instance 'b a)
1688 
+  (create-schema 'a (:width 43))
1689 
+will destroy the instance B, as well as the old value of A.
1690 
+[7-30-1990	Dario Giuse]
1691 
+
1692 
+
1693 
+Added a (non-exported) function named KR-SEND-FUNCTION.  This behaves the same as KR-SEND, but it is a function which can be funcall-ed.  The syntax is the same as KR-SEND:
1694 
+(KR-SEND-FUNCTION schema slot &rest arguments)
1695 
+[7-30-1990	Dario Giuse]
1696 
+
1697 
+
1698 
+Exported the new function COPY-FORMULA, which may be used to create a copy
1699 
+of a formula which shares the same parent (if there is one) and the same
1700 
+initial value.  This function is primarily intended for advanced users.
1701 
+[7-27-1990	Dario Giuse]
1702 
+
1703 
+
1704 
+Changed IS-A-P to return T if the two objects it is given are EQ.  This means
1705 
+that (IS-A-P a a) now returns T; the old code used to return NIL.
1706 
+[7-23-1990	Dario Giuse]
1707 
+
1708 
+
1709 
+
1710 
+;;; version 1.3.22
1711 
+
1712 
+Fixed CHANGE-FORMULA to get rid of the second value in the :KR-FUNCTION
1713 
+slot.  Since the function always makes formulas be like the result of
1714 
+FORMULA, rather than O-FORMULA, it would be incorrect to keep the second
1715 
+value around.
1716 
+
1717 
+Fixed EXPAND-ACCESSOR to eliminate program self-modification.  The argument
1718 
+list of macros such as G-VALUE used to be self-modifying if it ended with a
1719 
+non-keyword argument, i.e., a position argument.  This has been fixed.
1720 
+[6-27-1990	Dario Giuse]
1721 
+
1722 
+
1723 
+
1724 
+Fixed a bug in SET-VALUES.  This caused (SET-VALUES ... NIL) to incorrectly
1725 
+eliminate the information that a slot was depended on by some formulas, and
1726 
+as a result formulas would not be reevaluated correctly afterwards.
1727 
+
1728 
+Added the internal function COPY-FORMULA, originally provided by Roger
1729 
+Dannenberg.  This function is not exported.  It copies a formula and keeps
1730 
+the same parent (if there is one) and the same initial value.
1731 
+[6-26-1990	Dario Giuse]
1732 
+
1733 
+
1734 
+Fixed the bug in G-VALUE-NO-COPY-DOWN which caused local :INITIALIZE
1735 
+methods to be ignored at instance creation time.  This would cause
1736 
+incorrect behavior, since the parent method was always invoked first.
1737 
+[6-25-1990	Dario Giuse]
1738 
+
1739 
+
1740 
+;;; version 1.3.21
1741 
+
1742 
+
1743 
+DESTROY-SCHEMA now physically destroys formulas that used to be attached
1744 
+to slots of the schema.  This didn't use to be case, but is by now
1745 
+perfectly safe.  This means that old formulas can be garbage-collected.
1746 
+[6-15-1990	Dario Giuse]
1747 
+
1748 
+
1749 
+Modified CREATE-SCHEMA to work properly with variables whose value is NIL.
1750 
+This resulted in smaller code being generated for both CREATE-SCHEMA and
1751 
+CREATE-INSTANCE.
1752 
+[6-10-1990	Dario Giuse]
1753 
+
1754 
+
1755 
+;;; version 1.3.20
1756 
+
1757 
+Eliminated internal slot names from formulas.  This means that internal
1758 
+slots (such as the schema slot) are accessed directly through structure
1759 
+accessors, and the corresponding "reserved slot names" (such as :KR-SCHEMA)
1760 
+have been eliminated.
1761 
+[6-6-1990	Dario Giuse]
1762 
+
1763 
+
1764 
+Trying to initialize a relation slot to a non-schema value produces a
1765 
+warning and the value is ignored.  This used to go unnoticed, and would
1766 
+happen, for example, in the erroneous call
1767 
+  (create-schema nil (:left 12) (:parent NIL))
1768 
+[6-4-1990	Dario Giuse]
1769 
+
1770 
+
1771 
+
1772 
+;;; version 1.3.1
1773 
+
1774 
+The :INITIALIZE method is no longer copied down into every object.
1775 
+Inherited slots are normally copied down the first time they are inherited,
1776 
+and the same was happening to the :INITIALIZE slot.  This, however, was
1777 
+creating unnecessary garbage, since the method is typically only used once.
1778 
+The method is now inherited, but not copied down.
1779 
+[5-7-1990	Dario Giuse]
1780 
+
1781 
+
1782 
+Started version 1.3.1, which optimizes storage.
1783 
+[5-1-1990	Dario Giuse]
1784 
+
1785 
+
1786 
+
1787 
+;;; version 1.1.27
1788 
+
1789 
+Added #+allegro (gc t) at the end of kr-compiler.lisp
1790 
+[4/12/90 Mitchell]
1791 
+
1792 
+
1793 
+In low-level-set-value, changed #'formula-p to #'a-formula-p
1794 
+because Lucid complains about formula-p being a macro.
1795 
+Removed :is-a and :update-slots from *formula-slots*.
1796 
+In fixed-path-accessor, added test that "current" exists and
1797 
+is large enough before doing elt on it.
1798 
+[4/3/90 Ed Pervin]
1799 
+
1800 
+
1801 
+Define the package "KR" for the TI Explorer in kr-loader.lisp
1802 
+and kr-compiler.lisp.
1803 
+New and improved mode lines at the top of each file.
1804 
+Changed copyright to 1989, 1990.
1805 
+[4/2/90 Ed Pervin and Robert Cook]
1806 
+
1807 
+
1808 
+Added a new, non-advertised function named PATH which implements immutable
1809 
+paths.  The syntax is as follows:
1810 
+(path number list-of-slots)
1811 
+
1812 
+The easiest way to use PATH is as follows:
1813 
+  (gvl :parent :parent :previous-item :left)
1814 
+should be replaced by
1815 
+  (gv (path :parent :parent :previous-item) :left)
1816 
+All of the slots but the last one are moved inside PATH.  This makes performance
1817 
+significantly better.
1818 
+
1819 
+The <number> should be unique for the same path within each formula.  For
1820 
+example, replace the formula
1821 
+  (o-formula (+ (gvl :parent :parent :previous-item :left)
1822 
+		(gvl :parent :parent :width)))
1823 
+with the formula
1824 
+  (o-formula (+ (gv (path 0 :parent :parent :previous-item) :left)
1825 
+		(gv (path 1 :parent :parent) :width)))
1826 
+
1827 
+Note that it is admissible to use the same number for identical paths
1828 
+within the same formula.  So, for instance, replace
1829 
+  (o-formula (+ (gv (path 0 :parent :parent :previous-item) :left)
1830 
+		(gv (path 1 :parent :parent :previous-item) :width)))
1831 
+with:
1832 
+  (o-formula (+ (gv (path 0 :parent :parent :previous-item) :left)
1833 
+		(gv (path 0 :parent :parent :previous-item) :width)))
1834 
+(note that number 0 is used for both paths).
1835 
+[3-23-90  Dario Giuse]
1836 
+
1837 
+
1838 
+
1839 
+
1840 
+Rewrote the low-level structure accessors to correct a portability problem
1841 
+uncovered by the Lucid compiler.  All accesses are now through actual
1842 
+structure accessors, rather than the previous (array-based) scheme.
1843 
+Regular access is unaffected; iterate-accessors is slightly slower for
1844 
+slots whose name is unknown at compile time.
1845 
+[3-21-90  Dario Giuse]
1846 
+
1847 
+
1848 
+Fixed the compilation problem (reported by ecp) caused by SETF not being
1849 
+defined for LOGBITP in certain Lisp compilers.
1850 
+[3-19-90  Dario Giuse]
1851 
+
1852 
+
1853 
+
1854 
+;;; version 1.1.26
1855 
+
1856 
+Fixed compilation problem with PATH in constraints.lisp
1857 
+[3-16-90  Dario Giuse]
1858 
+
1859 
+
1860 
+Added an exported function, DO-PRINTABLE-SLOTS, which is somewhat of a cross
1861 
+between DOSLOTS and PS.  It takes a schema and a function, and applies the
1862 
+function to all the slots in the schema that would be printed by PS.  Unlike
1863 
+DOSLOTS, then, DO-PRINTABLE-SLOTS knows about ignored slots, sorted slots, and
1864 
+all the other print-control options used by PS.
1865 
+
1866 
+The syntax is:
1867 
+(do-printable-slots schema function &key (control t) (inherit nil))
1868 
+
1869 
+The <function> is called with three parameters: the <schema> itself, the name
1870 
+of the slot, and either T (if the slot is inherited) or NIL (if the slot is
1871 
+local).  The meaning of <control> and <inherit> is the same as for the function
1872 
+PS.
1873 
+
1874 
+Example:
1875 
+(create-instance 'r opal:rectangle)
1876 
+
1877 
+(do-printable-slots
1878 
+ r
1879 
+ #'(lambda (schema slot is-inherited)
1880 
+     (format t ": ~S ~S ~S (~s)~%"
1881 
+	     schema slot (g-value schema slot) is-inherited)))
1882 
+
1883 
+prints out the four slots :IS-A, :VISIBLE, :FAST-REDRAW-P, and :UPDATE-INFO
1884 
+and ignores the slots :DEPENDED-SLOTS and :UPDATE-SLOTS.
1885 
+[3-14-90  Dario Giuse]
1886 
+
1887 
+
1888 
+
1889 
+More work on improving performance of formula evaluation
1890 
+[2-13-90  Dario Giuse]
1891 
+
1892 
+
1893 
+Fixed the bug in CREATE-SCHEMA which prevented the following code from working:
1894 
+(let ((the-name 'FOO))
1895 
+  (create-schema the-name))
1896 
+[2-12-90  Dario Giuse]
1897 
+
1898 
+
1899 
+;;; version 1.1.25
1900 
+
1901 
+Fixed CREATE-SCHEMA to eliminate the compiler warning about schema
1902 
+variables being undefined.
1903 
+[1/31/90  Dario Giuse]
1904 
+
1905 
+
1906 
+Modified DESTROY-SLOT to not destroy formulas that depend on the slot being
1907 
+destroyed.  The old version used to indiscriminately destroy dependent
1908 
+formulas; the new version simply invalidates them.  This ensures that
1909 
+inheritance (or setting a new value) will correctly recompute the formulas.
1910 
+[1/30/90  Dario Giuse]
1911 
+
1912 
+
1913 
+Fixed CREATE-INSTANCE to give a warning when the :IS-A slot is specified in
1914 
+the slot list.  The :IS-A slot specification is simply ignored.
1915 
+[1/30/90  Dario Giuse]
1916 
+
1917 
+
1918 
+Changed DESTROY-SCHEMA so that deleted schemata are now printed out as
1919 
+#k<*DESTROYED*>
1920 
+[1/30/90  Dario Giuse]
1921 
+
1922 
+
1923 
+Fixed DESTROY-SLOT to handle inherited values (including ones which are
1924 
+depended on by some formula) to be modified properly.  Values are simply
1925 
+inherited again when needed.
1926 
+[1/30/90  Dario Giuse]
1927 
+
1928 
+
1929 
+Changed the default value of the :CONTROL option in PS.  The default value
1930 
+is now T, which means that ignored slots are not printed by default (and, in
1931 
+general, all print control options inherited from the schema itself).
1932 
+[1/30/90  Dario Giuse]
1933 
+
1934 
+
1935 
+Fixed check-relation-slot so that relation slots are no longer inherited
1936 
+when their value is set.
1937 
+[1/29/90  Dario Giuse]
1938 
+
1939 
+
1940 
+Created and exported a new function, NAME-FOR-SCHEMA.  Given a schema, this
1941 
+function returns its printable name as a string.  Note that the returned
1942 
+string SHOULD NOT be modified by the caller.
1943 
+The string name does not use the #k<> notation, i.e., the pure name is
1944 
+returned.
1945 
+[1/28/90  Dario Giuse]
1946 
+
1947 
+
1948 
+Eliminated the interface definition for the obsolete function LINK-VALID-P,
1949 
+which was effectively removed several months ago.
1950 
+[1/3/90 Dario Giuse]
1951 
+
1952 
+
1953 
+Added a variable, KR::*WARNING-ON-EVALUATION*, which may be set to T to
1954 
+give a warning whenever a formula is evaluated.  This may be useful for
1955 
+debugging.  The default setting is NIL.
1956 
+[12/1/89 Dario Giuse]
1957 
+
1958 
+
1959 
+Added a variable, KR::*WARNING-ON-CIRCULARITY*, which may be set to T to
1960 
+give a warning whenever a circularity is detected.  The default is NIL.
1961 
+[11/28/89 Dario Giuse]
1962 
+
1963 
+
1964 
+Modified GV and GVL so that the last parameter is only taken to be a
1965 
+value position if it is a number.  Everything else is assumed to be an
1966 
+expression which computes a slot.  This allows, for example, the following:
1967 
+(gvl :parent (gvl :which-slot))
1968 
+which computes the value of the parent's slot whose name is contained in
1969 
+the local slot :which-slot
1970 
+[11/28/89 Dario Giuse]
1971 
+
1972 
+
1973 
+---- last documentation update
1974 
+
1975 
+
1976 
+
1977 
+10-23-1989
1978 
+----------
1979 
+
1980 
+1.
1981 
+Modified CREATE-SCHEMA to only print out the message about a schema being
1982 
+created during compilation.
1983 
+
1984 
+
1985 
+
1986 
+10-9-1989
1987 
+---------
1988 
+
1989 
+1.
1990 
+Fixed bug in PS (actually, in printing names of schemata whose parent
1991 
+was a formula).
1992 
+
1993 
+2.
1994 
+(IS-A-P thing T) now returns true if <thing> is a schema.  I.e., T acts as
1995 
+the top-level superclass.
1996 
+
1997 
+
1998 
+
1999 
+10-2-1989
2000 
+---------
2001 
+
2002 
+
2003 
+1.
2004 
+Unnamed schemata are now given names that have as a prefix the name of the
2005 
+schema's parent, rather than the string "S".  This is intended to make
2006 
+it easier to understand what type of object an unnamed schema is.
2007 
+
2008 
+2.
2009 
+The formula which caused a null link is now stored in a variable internal
2010 
+to the KR package (named *last-formula*).  This variable is useful for
2011 
+debugging and, in particular, is used by Roger's debugging code.
2012 
+
2013 
+3.
2014 
+The function PS has a different interface, which is based on keywords
2015 
+rather than optional parameters.  The new syntax is:
2016 
+
2017 
+(PS schema &key control (inherit nil) (indent 0))
2018 
+
2019 
+:control has exactly the same meaning as the old, optional parameter.
2020 
+:inherit may be set to T to cause PS to print out not only local slots,
2021 
+  but also slots whose value has been inherited.  Such slots are printed
2022 
+  out in a distinctive format.
2023 
+:indent may be used to set an indentation level.  This is only used by some
2024 
+  of the debugging code and does not concern ordinary users.
2025 
+
2026 
+
2027 
+4.
2028 
+CREATE-SCHEMA has an additional feature.  It is now possible to create
2029 
+"unnamed" schemata with a name prefix.  This causes the creation
2030 
+of automatic names where the prefix part of the name is given explicitly as
2031 
+a symbol or a string.  The new syntax is
2032 
+  (create-schema name [:OVERRIDE] [:NAME-PREFIX prefix] {slot-descriptor}*)
2033 
+
2034 
+For example,
2035 
+(create-schema nil :name-prefix 'AGGREGATE (:left 45) (:top 3))
2036 
+  ==>  #k<AGGREGATE-264>
2037 
+
2038 
+Note that these are not "unnamed" schemata in the true sense of the word.
2039 
+A name for such schemata is created immediately; this includes a symbol in
2040 
+the KR-DEBUG package, which is exported.  Compare this with "true" unnamed
2041 
+schemata, which are created with (create-schema NIL); such schemata are
2042 
+never given any symbol name unless they are printed out.  True unnamed
2043 
+schemata, therefore, are significantly cheaper than name-prefix schemata.
2044 
+
2045 
+
2046 
+5.
2047 
+Fixed the problem with CREATE-INSTANCE which made it impossible to use a
2048 
+variable as the schema name.  This bug prevented CREATE-INSTANCE from being
2049 
+used inside a function, for example, when the name of the schema to be
2050 
+created was supplied as a function argument.
2051 
+
2052 
+
2053 
+
2054 
+8-22-1989
2055 
+---------
2056 
+
2057 
+1.
2058 
+Fixed APPEND-VALUE, which had been broken in the conversion to 2.3
2059 
+
2060 
+2.
2061 
+Fixed CREATE-INSTANCE to give an error when called with the same name for
2062 
+object and class.
2063 
+
2064 
+3.
2065 
+kr::*print-as-structure* is now T by default; this causes all schema names to
2066 
+be printed with the #k<> notation.  Setting kr::*print-as-structure* to NIL
2067 
+causes the pure symbol name to be printed instead.
2068 
+
2069 
+
2070 
+
2071 
+
2072 
+8-2-1989  (Version 2.3)
2073 
+
2074 
+1.
2075 
+SET-VALUES is now supposed to work properly with formulas (and thus it
2076 
+should be renamed to S-VALUES, really).
2077 
+
2078 
+SET-VALUES on the :IS-A slot, for example, is still known not to work
2079 
+properly.
2080 
+
2081 
+
2082 
+2.
2083 
+It is now consider illegal to use (RETURN) to exit DOVALUES.
2084 
+
2085 
+DOVALUES has more options, including one that can be used inside formulas
2086 
+to cause the formula to be invalidated when the ENTIRE list of values which
2087 
+is iterated upon by DOVALUES is modified in any way.
2088 
+
2089 
+The new, complete syntax is as follows:
2090 
+(DOVALUES (variable schema slot &key (local nil) (result nil)
2091 
+	     (formulas T) (in-formula nil))
2092 
+          &body)
2093 
+
2094 
+The meaning of the options is:
2095 
+- :LOCAL  : if non-nil, DOVALUES only examines local slots, and ignores
2096 
+  values that might be inherited.  The default is to access the slot
2097 
+  no matter whether it is local or inherited.
2098 
+- :RESULT  : specifies the value which is to be returned by DOVALUES.
2099 
+  Normally, DOVALUES simply returns NIL.
2100 
+- :FORMULAS  : the default is to obtain the value of each formula which
2101 
+  appears in the slot.  If :FORMULAS is nil, however, the formulas
2102 
+  themselves are returns (this behavior is similar to that of GET-VALUE).
2103 
+- :IN-FORMULA  : if this is non-nil, the DOVALUES may be used inside a
2104 
+  formula and the formula is invalidated when the slot is modified in any
2105 
+  way.  This allows the proper behavior when a formulas needs to examine
2106 
+  all values in a slot.  Note that in this case the special keyword :SELF
2107 
+  may be used as the name of the schema; this works exactly as in GV.
2108 
+
2109 
+An example of the latter usage of DOVALUES:
2110 
+
2111 
+(formula '(let ((is-odd nil))
2112 
+	    (dovalues (value :SELF :components :in-formula T)
2113 
+	      (if (odd value) (setf is-odd T)))
2114 
+	    is-odd))
2115 
+
2116 
+Note that it is possible to use DOVALUES inside a formula without
2117 
+specifying the :in-formula option, but in this case the formula would NOT
2118 
+be invalidated when the slot changes:  for example, the code
2119 
+(formula '(let ((is-odd nil))
2120 
+	    (dovalues (value :SELF :components)
2121 
+	      (if (odd value) (setf is-odd T)))
2122 
+	    is-odd))
2123 
+would correctly compute the answer the first time the formula is evaluated,
2124 
+but would never be evaluated again.
2125 
+
2126 
+
2127 
+
2128 
+3.
2129 
+
2130 
+G-VALUE may now be called with no slot names at all.  This simply
2131 
+returns the schema itself:
2132 
+(g-value a)    ==>   a
2133 
+
2134 
+More interestingly, GV may also be called without any slot names (in which
2135 
+case it also returns the schema).  The special name :self may be used, of
2136 
+course; this gives a standard idiom for a formula to obtain at runtime the
2137 
+name of the schema on which it is installed:
2138 
+(gv :SELF).
2139 
+
2140 
+
2141 
+
2142 
+4.
2143 
+
2144 
+The special variable KR::*WARNING-ON-CREATE-SCHEMA* may be bound to NIL in
2145 
+order to prevent the usual warning when CREATE-SCHEMA is redefining an
2146 
+extant schema.
2147 
+This variable is mostly for internal use and is not exported.
2148 
+
2149 
+
2150 
+
2151 
+5.
2152 
+
2153 
+GET-VALUES should be avoided and is superseded by DOVALUES.  In KR 2.3 and
2154 
+following, GET-VALUES may be inefficient because it conses when called on
2155 
+single-valued slots.
2156 
+
2157 
+DOVALUES, on the other hand, never creates any garbage storage.  The
2158 
+old idiom:
2159 
+	(dolist (item (get-values schema slot)) ...)
2160 
+should be replaced by
2161 
+	(dovalues (item schema slot) ...)
2162 
+
2163 
+
2164 
+
2165 
+
2166 
+
2167 
+
2168 
+-------------------
2169 
+
2170 
+
2171 
+
2172 
+Changes required for the conversion to the new version of KR (i.e., KR 2.0)
2173 
+from old, keyword-based versions:
2174 
+
2175 
+
2176 
+1.
2177 
+No schema name can be a keyword.  Symbols can be used instead, and
2178 
+NIL can be used to create nameless schemata.
2179 
+Also, quoted symbols cannot be used as schema names.  Therefore, write
2180 
+(create-instance foo ...) instead of (create-instance 'foo ...)
2181 
+
2182 
+Note that (create-instance foo some-class ...) automatically assigns the
2183 
+schema as the value of the variable FOO.  This variable is also
2184 
+automatically proclaimed SPECIAL.
2185 
+
2186 
+Unnamed schemata, i.e., the result of (create-schema nil ...), are not
2187 
+given any name by default.  If they are ever printed out, a name is created
2188 
+for them in the KR-DEBUG package and exported.  After being printed,
2189 
+unnamed schemata become the same as regular schemata, i.e., the symbol in
2190 
+the KR-DEBUG package has the schema itself as its value.
2191 
+
2192 
+
2193 
+2.
2194 
+All class names should be symbols, and they should be EXPORTED by the
2195 
+package where they are created.  It is recommended that programs refer to
2196 
+class names through the package name, since this enhances readability.  For
2197 
+example, all programs that use Opal should use
2198 
+  opal:rectangle
2199 
+as the name of the class.  This should be done even if the program actually
2200 
+does (use-package "OPAL").
2201 
+
2202 
+
2203 
+3.
2204 
+It is possible to create top-level classes by simply specifying NIL as the
2205 
+second argument to create-instance:
2206 
+(create-schema object nil ...)
2207 
+
2208 
+This makes OBJECT a new schema, and its :is-a slot will contain NIL.
2209 
+
2210 
+
2211 
+4.
2212 
+It is no longer possible to use and reference schemata that have not been
2213 
+previously created.  Try to access a non-existent schema will cause an
2214 
+error message.  If you need top-level schemata, use create-instance with
2215 
+NIL, as described above.
2216 
+
2217 
+
2218 
+5.
2219 
+The old version of KR used to be very casual about using NIL as a schema.
2220 
+The current version of KR still allows retrieving values from a NIL schema
2221 
+(for instance, when you do something like
2222 
+  (g-value (g-value a :slot1) :slot2)
2223 
+and :slot1 contains NIL), but I am considering turning this "feature" off
2224 
+in the future for better error checking.  In the meanwhile, all old code will
2225 
+still work.
2226 
+
2227 
+Setting values of a NIL schema, on the other hand, causes an error.
2228 
+
2229 
+
2230 
+6.
2231 
+Some KR functions have been renamed.  Here is a list of the renaming
2232 
+scheme:
2233 
+
2234 
+the-formula			--> formula
2235 
+create-fresh-schema		--> create-schema (default behavior)
2236 
+create-schema			--> (create-schema :OVERRIDE ...)
2237 
+is-formula			--> formula-p
2238 
+do-slots			--> doslots
2239 
+remove-constraint		--> destroy-constraint
2240 
+check-link			--> link-valid-p
2241 
+schema-call			--> kr-send
2242 
+call-parent-method		--> call-prototype-method
2243 
+defmeth				--> define-method
2244 
+meth-trace			--> method-trace
2245 
+
2246 
+The following functions have been eliminated:
2247 
+delete-schema
2248 
+delete-slot
2249 
+create-slot
2250 
+get-slots
2251 
+get-all-slots
2252 
+do-all-values
2253 
+print-schema (its functionality is now part of PS)
2254 
+
2255 
+
2256 
+7.
2257 
+Since schemata are now structures, it is no longer possible to use CASE
2258 
+(for instance) to discriminate among different schema types.  The old code
2259 
+(case (get-value schema :IS-A)
2260 
+  (opal:rectangle ...)
2261 
+  (opal:window ...))
2262 
+, for example, will no longer work.  It MUST be replaced by something like
2263 
+(let ((type (get-value schema :IS-A)))
2264 
+  (cond ((eq type opal:rectangle) ...)
2265 
+        ((eq type opal:window) ...))
2266 
+
2267 
+I am thinking about writing a little macro that does this, but for the time
2268 
+being, beware.
2269 
+
2270 
+
2271 
+8.
2272 
+Local variables CANNOT have the same name as a class schema created by the
2273 
+same package.  This is because the schema name is a special variable and
2274 
+thus it conflicts with local variable names.
2275 
+Note that there is no problem with class schemata created by other
2276 
+packages.
2277 
+
2278 
+
2279 
+
2280 
+9.
2281 
+Unnamed schemata have an internally generated name which is an integer.
2282 
+If the variable kr::*intern-unnamed-schemata* is set to T (the default), a
2283 
+symbol by the proper name is automatically created as soon as an unnamed
2284 
+schema is printed (by PS, or otherwise).  This means that:
2285 
+- unnamed schemata may be referenced just like any other schema;
2286 
+- unnamed schemata that have been printed will NOT be garbage collected,
2287 
+  unless of course someone does an explicit DESTROY-SCHEMA on them.
2288 
+
2289 
+Symbols thus created are automatically interned and exported by the KR
2290 
+package.
2291 
+
2292 
+
2293 
+It is possible to have the system NOT create symbols this way.  This makes
2294 
+referring to unnamed schemata a little more awkward, but it allows them to
2295 
+be garbage collected as needed.  This can be achieved by setting
2296 
+kr::*intern-unnamed-schemata* to NIL.  If this is the case, the following
2297 
+applies:
2298 
+
2299 
+Unnamed schemata are printed as S1234, for example, but their name IS NOT the
2300 
+symbol S1234.  One can refer to schemata by number, but only when the
2301 
+reference is rather recent (since only recently printed unnamed schemata
2302 
+are kept in a cache).
2303 
+
2304 
+An internal function named S is available for this purpose: this function
2305 
+takes an integer and returns the corresponding unnamed schema, if the
2306 
+reference is recent enough, or NIL.
2307 
+
2308 
+
2309 
+10.
2310 
+CREATE-RELATION has a slightly different syntax: the inverses are now a
2311 
+simple &rest list.  Therefore,
2312 
+(create-relation :components nil '(:parent)) should now be written as
2313 
+(create-relation :components nil :parent)
2314 
+
2315 
+
2316 
+11.
2317 
+Define-method now takes a KEYWORD, rather than a symbol, as the method
2318 
+name.  For instance,
2319 
+(define-method :draw opal-rectangle ...)
2320 
+
2321 
+Also, define-method no longer creates an automatic macro with the same name
2322 
+as the method name.  The method is created just as before.
2323 
+
2324 
+
2325 
+12.
2326 
+Change-formula has a different syntax.  It no longer takes a formula and an
2327 
+expression; instead, it takes a schema, slot, and an expression.  For example,
2328 
+(change-formula box-12 :right '(+ (gvl :left) 10))
2329 
+
2330 
+
2331 
+
2332 
+---------------------------- Changes for version 2.1
2333 
+
2334 
+
2335 
+1.
2336 
+A new macro, named O-FORMULA, is exported by KR.  This is similar to
2337 
+FORMULA, except that:
2338 
+- the formula expression does not need to be quoted;
2339 
+- O-FORMULA arranges for the expression to be immediately compilable.  This
2340 
+  means that O-FORMULA in a compiled file causes the formula to be
2341 
+  installed as a compiled formula.  This makes formula evaluation
2342 
+  significantly faster in many cases.  Executing O-FORMULA in an
2343 
+  interpretive environment, on the other hand, creates an interpreted formula.
2344 
+
2345 
+
2346 
+
2347 
+2.
2348 
+The function COPY-SCHEMA has been eliminated altogether.
2349 
+
2350 
+
2351 
+3.
2352 
+If the print-control schema passed to PS (or inherited from the object
2353 
+being printed) contains a non-nil :PRINT-AS-STRUCTURE slot, schemata which
2354 
+are values in some slot are printed with a structure syntax, which shows
2355 
+some of their slots.  Exactly which slots are printed can be selected by
2356 
+setting the slot :PRINT-SLOTS in the print-control schema.
kr/kr.lisp
History View file @ 6e35003
0 2357 
new file mode 100644
... ... 
@@ -0,0 +1,2787 @@
1 
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: KR; Base: 10 -*-
2 
+
3 
+;; The Garnet User Interface Development Environment
4 
+;;
5 
+;; This code was written as part of the Garnet project at Carnegie
6 
+;; Mellon University, and has been placed in the public domain.
7 
+
8 
+;;; Slot bits assignment:
9 
+;; 0-9 types encoding
10 
+;;   - inherited
11 
+;;   - is-parent
12 
+;;   - constant-slot
13 
+;;   - is-update-slot
14 
+;;   - local-only-slot    ; not implemented
15 
+;;   - parameter-slot     ; not implemented
16 
+
17 
+(in-package :kr)
18 
+
19 
+(declaim (inline clear-one-slot))
20 
+
21 
+(defun clear-one-slot (schema slot entry)
22 
+  "Completely clear a slot, including dependencies, inherited, etc...
23 
+   BUT... Leave around the declarations (constant, type, update,...)"
24 
+  (locally (declare #.*special-kr-optimization*)
25 
+    (let ((the-entry (or entry (slot-accessor schema slot))))
26 
+      (when the-entry
27 
+	(setf (sl-value the-entry) *no-value*
28 
+	      (sl-bits the-entry)  (logand (sl-bits the-entry)
29 
+					   *clear-slot-mask*))))))
30 
+
31 
+(declaim (inline clear-schema-slots))
32 
+(defun clear-schema-slots (schema)
33 
+  "Completely clear ALL the slots in the <schema>."
34 
+  (locally (declare #.*special-kr-optimization*)
35 
+    (clrhash (schema-bins schema))))
36 
+
37 
+(defun value-fn (schema slot)
38 
+  "Does the actual work of G-VALUE."
39 
+  (g-value-body schema slot T T))
40 
+
41 
+(defun g-local-value-fn (schema slot)
42 
+  "Similar to g-value-fn, but no inheritance."
43 
+  (g-value-body schema slot NIL T))
44 
+
45 
+(let ((list-of-one (list nil)))
46 
+  (defun get-dependents (schema slot)
47 
+    "RETURNS: the formulas which depend on the <slot> of the <schema>."
48 
+    (let ((value (slot-dependents (slot-accessor schema slot))))
49 
+      (if (listp value)
50 
+	  value
51 
+	  (progn
52 
+	    (setf (car list-of-one) value)
53 
+	    list-of-one)))))
54 
+
55 
+(declaim (inline get-lambda))
56 
+(defun get-lambda (formula)
57 
+  "Returns the lambda expression in a formula, or NIL."
58 
+  (when (formula-p formula)
59 
+    (a-formula-lambda formula)))
60 
+
61 
+(defun enable-a-demon (demon)
62 
+  "Turns ON a demon if it was turned off.  If all demons are currently
63 
+disabled, the variable *demons-disabled* is made of the form
64 
+(T demon), where the names following the T are, in fact, enabled."
65 
+  (cond ((eq *demons-disabled* T)
66 
+	 (list T demon))
67 
+	((eq *demons-disabled* NIL))	; nothing is disabled
68 
+	((listp *demons-disabled*)
69 
+	 ;; A list
70 
+	 (if (eq (car *demons-disabled*) T)
71 
+	     ;; Special format
72 
+	     (if (memberq demon (cdr *demons-disabled*))
73 
+		 *demons-disabled*	; nothing is needed
74 
+		 (cons T (cons demon (cdr *demons-disabled*))))
75 
+	     ;; Normal format
76 
+	     (if (memberq demon *demons-disabled*)
77 
+		 (remove demon *demons-disabled*)
78 
+		 *demons-disabled*)))
79 
+	((eq demon *demons-disabled*)
80 
+	 NIL)
81 
+	(t
82 
+	 *demons-disabled*)))
83 
+
84 
+(defun disable-a-demon (demon)
85 
+  (if (eq *demons-disabled* T)
86 
+      T					; everything is already turned off
87 
+      (if (eq *demons-disabled* NIL)
88 
+	  demon
89 
+	  (if (listp *demons-disabled*)
90 
+	      ;; A list
91 
+	      (if (eq (car *demons-disabled*) T)
92 
+		  ;; Special format used by with-demon-enable
93 
+		  (if (memberq demon *demons-disabled*)
94 
+		      (let ((new-value (delete demon *demons-disabled*)))
95 
+			(if (null (cdr new-value))
96 
+			    T
97 
+			    new-value))
98 
+		      ;; Already disabled
99 
+		      *demons-disabled*)
100 
+		  ;; Normal format
101 
+		  (cons demon *demons-disabled*))
102 
+	      ;; A single value - make a list.
103 
+	      (list demon *demons-disabled*)))))
104 
+
105 
+
106 
+(defun demon-is-disabled (demon)
107 
+  "Is the <demon> currently enabled?"
108 
+  (if (listp *demons-disabled*)
109 
+      (if (eq (car *demons-disabled*) T)
110 
+	  ;; Special format
111 
+	  (not (memberq demon (cdr *demons-disabled*)))
112 
+	  ;; Normal format
113 
+	  (memberq demon *demons-disabled*))
114 
+      (eq demon *demons-disabled*)))
115 
+
116 
+
117 
+(defun g-value-inherit-values (schema slot is-leaf slot-structure)
118 
+  "Search up the tree for inherited slot.
119 
+RETURNS: the inherited value, or NIL."
120 
+  (declare (ftype (function (t &optional t) t) formula-fn))
121 
+  (let (has-parents)
122 
+    (when (a-local-only-slot slot)	; These CANNOT be inherited.
123 
+      (return-from g-value-inherit-values NIL))
124 
+    (dolist (relation *inheritance-relations*)
125 
+      (dolist (parent (if (eq relation :IS-A)
126 
+			  (get-local-value schema :IS-A)
127 
+			  (get-local-value schema relation)))
128 
+	(setf has-parents T)
129 
+	(let ((entry (slot-accessor parent slot))
130 
+	      (value *no-value*)
131 
+	      bits			; parent bits
132 
+	      (intermediate-constant NIL))
133 
+	  (when entry
134 
+	    (setf value (sl-value entry))
135 
+	    (when (is-constant (sl-bits entry))
136 
+	      (setf intermediate-constant T)))
137 
+	  (if (eq value *no-value*)
138 
+	      ;; Attempt to inherit from its ancestors.
139 
+	      (multiple-value-setq (value bits)
140 
+		(g-value-inherit-values parent slot NIL nil))
141 
+	      ;; If value, just set bits.
142 
+	      (setf bits (sl-bits entry)))
143 
+	  (unless (eq value *no-value*)
144 
+	    (if (and bits (is-parent bits))
145 
+		;; Clear the parent bit, since we will set the child.
146 
+		(setf bits (logand bits *not-parent-mask*))
147 
+		;; Set the bit in the parent which says that the value was
148 
+		;; inherited by someone.
149 
+		(if entry
150 
+		    ;; Destructively set the bits.
151 
+		    (setf (sl-bits entry) (logior bits *is-parent-mask*))
152 
+		    (set-slot-accessor parent slot value
153 
+				       (logior bits *is-parent-mask*) nil)))
154 
+	    ;; Copy the value down to the inheriting slot, unless the value
155 
+	    ;; contains a formula.
156 
+	    (let ((was-formula (formula-p value)))
157 
+	      (when was-formula
158 
+		;; Inherit the formula, making a copy of it.
159 
+		(setf value (formula-fn value (a-formula-cached-value value)))
160 
+		(setf (a-formula-schema value) schema)
161 
+		(setf (a-formula-slot value) slot)
162 
+		(set-cache-is-valid value NIL))
163 
+	      ;; Copy down, mark as inherited if inherited
164 
+	      (when (and is-leaf slot-structure)	; slot had constant bit
165 
+		(setf bits (logior bits (sl-bits slot-structure))))
166 
+	      (setf bits (logior *inherited-mask* bits
167 
+				 #+TEST
168 
+				 (logand bits *not-parent-constant-mask*)))
169 
+	      (when intermediate-constant
170 
+		(setf bits (logior *constant-mask* bits)))
171 
+	      (set-slot-accessor schema slot value bits
172 
+				 (slot-dependents slot-structure)))
173 
+	    (return-from g-value-inherit-values (values value bits))))))
174 
+    ;; We didn't find anything, so return an appropriate null value and set
175 
+    ;; the local cache (even though we have no value) to avoid further
176 
+    ;; inheritance search.
177 
+    (set-slot-accessor schema slot
178 
+		       (if has-parents NIL *no-value*)
179 
+		       (cond (is-leaf
180 
+			      (if slot-structure
181 
+				  (logior *inherited-mask*
182 
+					  (sl-bits slot-structure))
183 
+				  *inherited-mask*))
184 
+			     (has-parents *inherited-parent-mask*)
185 
+			     (t		; top-level, no parents
186 
+			      *is-parent-mask*))
187 
+		       (slot-dependents slot-structure))
188 
+    *no-value*))
189 
+
190 
+;; G-CACHED-VALUE
191 
+;;
192 
+(declaim (inline g-cached-value))
193 
+(defun g-cached-value (schema slot)
194 
+  "Returns the value of the <slot> in the <schema>.  If this is a formula, it
195 
+  returns the cached value of the formula, without ever recomputing the
196 
+  formula."
197 
+  ;; Note use of GET-VALUE
198 
+  (let ((g-cached-value-val (get-value schema slot)))
199 
+    (if (formula-p g-cached-value-val)
200 
+	(cached-value g-cached-value-val)
201 
+	g-cached-value-val)))
202 
+
203 
+
204 
+(defun g-value-no-copy (schema slot &optional skip-local)
205 
+  "This is a specialized function which does inheritance but does NOT copy
206 
+values down.  It is used by the :INITIALIZE method, which is called exactly
207 
+once per object and should NOT copy down anything (since the method will
208 
+never be used again)."
209 
+  (unless skip-local
210 
+    ;; Is there a local value?
211 
+    (let ((value (slot-accessor schema slot)))
212 
+      (when value
213 
+	(return-from g-value-no-copy (sl-value value)))))
214 
+  ;; Now try inherited values.
215 
+  (dolist (relation *inheritance-relations*)
216 
+    (dolist (*schema-self* (if (eq relation :IS-A)
217 
+			       (get-local-value schema :IS-A)
218 
+			       (get-local-value schema relation)))
219 
+      (unless (eq *schema-self* schema)	; avoid infinite loops!
220 
+	(let ((value (g-value-no-copy *schema-self* slot)))
221 
+	  (when value
222 
+	    (return-from g-value-no-copy value)))))))
223 
+
224 
+
225 
+;;; PRINTING AND DEBUGGING
226 
+
227 
+(declaim (fixnum *debug-names-length* *debug-index*))
228 
+(defparameter *debug-names-length* 500)
229 
+
230 
+(defvar *debug-names* (make-array *debug-names-length* :initial-element nil))
231 
+
232 
+(defvar *debug-index* -1)
233 
+
234 
+(defvar *intern-unnamed-schemata* T
235 
+  "This variable may be set to NIL to prevent PS from automatically creating
236 
+  any unnamed schemata it prints out.")
237 
+
238 
+(defun cache-schema-name (schema name)
239 
+  "This does not cause any creation of symbols.  It simply records
240 
+the schema in an array, thus creating a semi-permanent way to refer
241 
+to a schema."
242 
+  (unless (find-if #'(lambda (x)
243 
+		       (and x (eql (schema-name x) name)))
244 
+		   *debug-names*)
245 
+    ;; A new schema.  Store it in the next position (cycle if
246 
+    ;; we reach the end of the array).
247 
+    (setf (aref *debug-names*
248 
+		(setf *debug-index*
249 
+		      (mod (incf *debug-index*) *debug-names-length*)))
250 
+	  schema)))
251 
+
252 
+;;
253 
+(defun make-new-schema-name (schema name)
254 
+  "Creates symbols for all automatic schema names that happen to
255 
+be printed out."
256 
+  (let* ((debug-package (find-package "KR-DEBUG"))
257 
+	 parent
258 
+	 (symbol
259 
+	  (intern (cond ((stringp name)
260 
+			 ;; a name-prefix schema
261 
+			 (format nil "~A-~D"
262 
+				 name (incf *schema-counter*)))
263 
+			((setf parent
264 
+			       (if (formula-p schema)
265 
+				   (a-formula-is-a schema)
266 
+				   (when (not-deleted-p schema)
267 
+				     (car (get-local-value schema :IS-A)))))
268 
+			 (let ((parent-name (when parent (schema-name parent))))
269 
+			   (when (or (integerp parent-name)
270 
+				     (stringp parent-name))
271 
+			     ;; Parent is unnamed yet - force a name.
272 
+			     (with-output-to-string
273 
+				 (bit-bucket)
274 
+			       (print-the-schema parent bit-bucket 0))
275 
+			     (setf parent-name (schema-name parent)))
276 
+			   (format nil "~A-~D" parent-name name)))
277 
+			(t
278 
+			 (format nil "~C~D"
279 
+				 (if (formula-p schema) #\F #\S)
280 
+				 name)))
281 
+		  debug-package)))
282 
+    (set symbol schema)
283 
+    (setf (schema-name schema) symbol)
284 
+    (export symbol debug-package)))
285 
+
286 
+(defun print-the-slot (slot stream level)
287 
+  (declare (ignore level))
288 
+  (format stream "<slot ~S  value ~S, bits ~S"
289 
+	  (sl-name slot) (sl-value slot) (sl-bits slot))
290 
+  (if (full-sl-p slot)
291 
+      (format stream ",  dependents ~S>" (full-sl-dependents slot))
292 
+      (format stream ">")))
293 
+
294 
+(defun print-the-schema (schema stream level)
295 
+  (declare (ignore level))
296 
+  (let ((name (schema-name schema))
297 
+	(destroyed (not (not-deleted-p schema))))
298 
+    ;; This version is for debugging.  Record the latest schemata in the
299 
+    ;; array.
300 
+    (cond ((or (integerp name) (stringp name))
301 
+	   ;; This is a nameless schema.  Print it out, and record it in the
302 
+	   ;; debugging array.
303 
+	   (when *intern-unnamed-schemata*
304 
+	     (make-new-schema-name schema name))
305 
+	   (cache-schema-name schema name)
306 
+	   ;; This gives control over whether unnamed schemata are interned.
307 
+	   (setf name (schema-name schema)))
308 
+	  ((null name)
309 
+	   ;; This was a deleted schema
310 
+	   (setf name '*DESTROYED*)))
311 
+    (when destroyed (format stream "*DESTROYED*(was "))
312 
+    (if *print-as-structure*
313 
+	(progn
314 
+	  (format stream "#k<~S" name)
315 
+	  (dolist (slot *print-structure-slots*)
316 
+	    (let ((value (g-value schema slot)))
317 
+	      (when value
318 
+		(format stream " (~S ~S)" slot value))))
319 
+	  (format stream ">")
320 
+	  (when destroyed (format stream ")")))
321 
+	(progn
322 
+	  (format stream "~S" name)
323 
+	  (when destroyed (format stream ")"))))))
324 
+
325 
+
326 
+(defun name-for-schema (schema)
327 
+  "Given a schema, returns its printable name as a string.  The string
328 
+CANNOT be destructively modified.
329 
+Note that this returns the pure name, without the #k<> notation."
330 
+  (let ((name (schema-name schema)))
331 
+    (when (or (integerp name) (stringp name))
332 
+      ;; This is a nameless schema.  Print it out, and record it in the
333 
+      ;; debugging array.
334 
+      (when *intern-unnamed-schemata*
335 
+	(make-new-schema-name schema name))
336 
+      (cache-schema-name schema name)
337 
+      ;; This gives control over whether unnamed schemata are interned.
338 
+      (setf name (schema-name schema)))
339 
+    (symbol-name name)))
340 
+
341 
+
342 
+(defun s (number)
343 
+  "This is a debugging function which returns a schema, given its internal
344 
+number.  It only works if the schema was printed out rather recently,
345 
+i.e., if it is contained in the temporary array of names."
346 
+  (setf number (format nil "~D" number))
347 
+  (find-if #'(lambda (x)
348 
+	       (and x
349 
+		    (symbolp (schema-name x))
350 
+		    (do* ((name (symbol-name (schema-name x)))
351 
+			  (i (1- (length name)) (1- i))
352 
+			  (j (1- (length number)) (1- j)))
353 
+			 ((minusp j)
354 
+			  (unless (digit-char-p (schar name i))
355 
+			    x))
356 
+		      (unless (char= (schar name i) (schar number j))
357 
+			(return nil)))))
358 
+	   *debug-names*))
359 
+
360 
+
361 
+
362 
+;;; RELATIONS
363 
+
364 
+(defun unlink-one-value (schema slot value)	    ; e.g., child :is-a parent
365 
+  "Remove the inverse link from <value> to <schema>, following the inverse
366 
+of <slot>."
367 
+  (let ((inverse (cadr (assocq slot *relations*)))) ; e.g., is-a-inv
368 
+    (when inverse
369 
+      ;; If the relation has an INVERSE slot, remove <schema> from the
370 
+      ;; inverse slot.
371 
+      (let ((entry (slot-accessor value inverse)) ; e.g., A child B
372 
+	    values)
373 
+	(when entry
374 
+	  (setf values (sl-value entry))
375 
+	  (if (eq (car values) schema)
376 
+	      ;; <schema> is first in the inverse list
377 
+	      (set-slot-accessor value inverse (delete schema values)
378 
+				 (sl-bits entry) (slot-dependents entry))
379 
+	      ;; just do a destructive operation
380 
+	      (setf (cdr values) (delete schema (cdr values)))))))))
381 
+
382 
+(defun unlink-all-values (schema slot)
383 
+  "Same as above, but unlinks all schemata that are in <slot>."
384 
+  (let ((inverse (cadr (assocq slot *relations*))))
385 
+    (when inverse
386 
+      (let ((entry (if (eq slot :IS-A)
387 
+		       (slot-accessor schema :IS-A)
388 
+		       (if (eq slot :IS-A-INV)
389 
+			   (slot-accessor schema :IS-A-INV)
390 
+			   (slot-accessor schema slot)))))
391 
+	(when entry
392 
+	  (dolist (parent (sl-value entry))
393 
+	    (when (not-deleted-p parent) ; parent is not destroyed
394 
+	      ;; If the terminal has an INVERSE slot, remove <schema> from the
395 
+	      ;; inverse slot.
396 
+	      (let ((entry (if (eq inverse :is-a-inv)
397 
+			       (slot-accessor parent :is-a-inv) ; e.g., A child B
398 
+			       (slot-accessor parent inverse)))
399 
+		    values)
400 
+		(when entry
401 
+		  (setf values (sl-value entry))
402 
+		  (if (eq (car values) schema)
403 
+		      (pop (sl-value entry))
404 
+		      (setf (cdr values) (delete schema (cdr values)))))))))))))
405 
+
406 
+
407 
+(defun link-in-relation (schema slot values)
408 
+  "Since the <values> are being added to <slot>, see if we need to put in an
409 
+inverse link to <schema> from each of the <values>.
410 
+This happens when <slot> is a relation with an inverse."
411 
+  (let ((inverse (if (eq slot :is-a)
412 
+		     :is-a-inv
413 
+		     (cadr (assocq slot *relations*)))))
414 
+    (when inverse
415 
+      ;; <values> is a list: cycle through them all
416 
+      (dolist (value values)
417 
+	(let* ((entry (if (eq slot :is-a)
418 
+			  (slot-accessor value :is-a-inv)
419 
+			  (slot-accessor value inverse)))
420 
+	       (previous-values (when entry (sl-value entry))))
421 
+	  (if entry
422 
+	      ;; Create the back-link.  We use primitives here to avoid looping.
423 
+	      (if (or *schema-is-new*
424 
+		      (not (memberq schema previous-values)))
425 
+		  ;; Handle an important special case efficiently.
426 
+		  (if (eq (sl-value entry) *no-value*)
427 
+		      ;; There was no value after all!
428 
+		      (setf (sl-value entry) (list schema))
429 
+		      ;; There were real values.
430 
+		      (push schema (sl-value entry))))
431 
+	      ;; There was no inverse in the parent yet.
432 
+	      (set-slot-accessor value inverse (list schema) *local-mask* nil)))))))
433 
+
434 
+
435 
+(defun check-relation-slot (schema slot values)
436 
+  "We are setting the <slot> (a relation) to <values>.  Check that the
437 
+latter contains valid relation entries.
438 
+RETURNS: <values> (or a list of a single value, if <values> is not a list)
439 
+if success; *no-value* if failure."
440 
+  (unless (listp values)
441 
+    (format
442 
+     t "S-VALUE: relation ~s in schema ~S should be given a list of values!~%"
443 
+     slot schema)
444 
+    (if (schema-p values)
445 
+	(setf values (list values))	; go ahead, use anyway.
446 
+	(return-from check-relation-slot *no-value*)))
447 
+  (dolist (value values)
448 
+    (unless (is-schema value)
449 
+      (when-debug
450 
+       (format
451 
+	t
452 
+	"S-VALUE: value ~s for relation ~s in ~s is not a schema!  Ignored.~%"
453 
+	value slot schema))
454 
+      (return-from check-relation-slot *no-value*)))
455 
+  (do ((value values (cdr value)))
456 
+      ((null value))
457 
+    (when (memberq (car value) (cdr value))
458 
+      (format
459 
+       t
460 
+       "Trying to set relation slot ~S in schema ~S with duplicate value ~S!~%"
461 
+       slot schema (car value))
462 
+      (format t "  The slot was not set.~%")
463 
+      (return-from check-relation-slot *no-value*)))
464 
+  values)
465 
+
466 
+
467 
+(declaim (inline inherited-p))
468 
+(defun inherited-p (schema slot)
469 
+  "Similar to HAS-SLOT-P, but when there is a formula checks whether this is
470 
+an inherited formula."
471 
+  (let ((entry (slot-accessor schema slot)))
472 
+    (when entry
473 
+      (or (is-inherited (sl-bits entry))
474 
+	  (and (formula-p (sl-value entry))
475 
+	       (formula-p (a-formula-is-a (sl-value entry))))))))
476 
+
477 
+(defun formula-push (f)
478 
+  (bordeaux-threads:with-lock-held  (*formula-lock*)
479 
+    (push f *formula-pool*)))
480 
+
481 
+;;; encode types
482 
+(defparameter *types-table* (make-hash-table :test #'equal)
483 
+  "Hash table used to look up a Lisp type and returns its code")
484 
+
485 
+(defparameter *types-table-lock* (bordeaux-threads:make-recursive-lock)
486 
+  "Lock to synchonize access to *types-table*")
487 
+
488 
+(defmacro with-types-table-lock-held ((table) &body body)
489 
+  `(let ((,table *types-table*))
490 
+     (bordeaux-threads:with-recursive-lock-held (*types-table-lock*)
491 
+     ,@body)))
492 
+
493 
+(declaim (fixnum *types-array-inc*))
494 
+(defparameter *types-array-inc* 255) ;; allocate in blocks of this size
495 
+
496 
+(declaim (fixnum *next-type-code*))
497 
+(defparameter *next-type-code*  0)   ;; next code to allocate
498 
+
499 
+(defparameter types-array NIL
500 
+  "Array used to decode a number into its corresponding Lisp type.")
501 
+
502 
+(defparameter type-fns-array NIL
503 
+  "Array used to decode a number into its corresponding type-fn.")
504 
+
505 
+(defparameter type-docs-array NIL
506 
+  "Array used to decode a number into its corresponding documentation string.")
507 
+
508 
+(declaim (inline code-to-type code-to-type-fn code-to-type-doc check-kr-type))
509 
+
510 
+(defun code-to-type (type-code)
511 
+  (svref types-array type-code))
512 
+
513 
+(defun code-to-type-fn (type-code)
514 
+  (svref type-fns-array type-code))
515 
+
516 
+(defun code-to-type-doc (type-code)
517 
+  (svref type-docs-array type-code))
518 
+
519 
+(defun check-kr-type (value code)
520 
+  (funcall (code-to-type-fn code) value))
521 
+
522 
+
523 
+(declaim (inline find-lisp-predicate))
524 
+(defun find-lisp-predicate (simple-type)
525 
+  "Given simple type ('NULL, 'KEYWORD, etc...), returns the name of
526 
+the lisp predicate to test this ('NULL, 'KEYWORDP, etc....)"
527 
+  (let ((p-name (concatenate 'string (symbol-name simple-type) "P"))
528 
+	(-p-name (concatenate 'string (symbol-name simple-type) "-P")))
529 
+    (cond ((memberq simple-type '(NULL ATOM)) simple-type)
530 
+	  (T (or (find-symbol p-name 'common-lisp)
531 
+		 (find-symbol -p-name 'common-lisp)
532 
+		 (find-symbol p-name)
533 
+		 (find-symbol -p-name)
534 
+		 (error "Could not find predicate for simple-type ~S~%"
535 
+			simple-type))))))
536 
+
537 
+(defun make-lambda-body (complex-type)
538 
+  (with-types-table-lock-held (types-table)
539 
+    (let (code)
540 
+      (cond ((consp complex-type)	;; complex type (a list)
541 
+	     (let ((fn   (first complex-type))
542 
+		   (args (rest  complex-type)))
543 
+	       (case fn
544 
+		 ((OR AND NOT)
545 
+		  (cons fn (mapcar #'make-lambda-body args)))
546 
+		 (MEMBER
547 
+		  `(memberq value ',args))
548 
+		 ((IS-A-P IS-A)
549 
+		  `(is-a-p value ,(second complex-type)))
550 
+		 (SATISFIES
551 
+		  `(,(second complex-type) value))
552 
+		 ((INTEGER REAL)
553 
+		  (let* ((pred (find-lisp-predicate fn))
554 
+			 (lo (first args))
555 
+			 (lo-expr (when (and lo (not (eq lo '*)))
556 
+				    (if (listp lo)
557 
+					`((< ,(car lo) value))
558 
+					`((<= ,lo value)))))
559 
+			 (hi (second args))
560 
+			 (hi-expr (when (and hi (not (eq hi '*)))
561 
+				    (if (listp hi)
562 
+					`((> ,(car hi) value))
563 
+					`((>= ,hi value))))))
564 
+		    (if (or lo-expr hi-expr)
565 
+			`(and (,pred value) ,@lo-expr ,@hi-expr)
566 
+			`(,pred value))))
567 
+		 (T  (error "Unknown complex-type specifier: ~S~%" fn)))))
568 
+	    ((setq code (gethash (symbol-name complex-type) types-table))
569 
+	     ;; is this a def-kr-type?
570 
+	     (make-lambda-body (code-to-type code)))
571 
+	    (T ;; simple-type
572 
+	     (list (find-lisp-predicate complex-type) 'value))))))
573 
+
574 
+(defun type-to-fn (type)
575 
+  "Given the Lisp type, construct the lambda expr, or return the
576 
+   built-in function"
577 
+  (with-types-table-lock-held (types-table)
578 
+    (let (code)
579 
+      (cond ((consp type)			; complex type
580 
+	     (if (eq (car type) 'SATISFIES)
581 
+		 (let ((fn-name (second type)))
582 
+		   `',fn-name) ;; koz
583 
+		 `(function (lambda (value)
584 
+		    (declare #.*special-kr-optimization*)
585 
+		    ,(make-lambda-body type)))))
586 
+	    ((setq code (gethash (symbol-name type) types-table))
587 
+	     ;; is this a def-kr-type?
588 
+	     (code-to-type-fn code))
589 
+	    (T
590 
+	     `',(find-lisp-predicate type))))))
591 
+
592 
+(declaim (inline copy-extend-array))
593 
+(defun copy-extend-array (oldarray oldlen newlen)
594 
+  (let ((result (make-array newlen)))
595 
+    (dotimes (i oldlen)
596 
+      (setf (svref result i) (svref oldarray i)))
597 
+    result))
598 
+
599 
+
600 
+(defun get-next-type-code ()
601 
+  "Return the next available type-code, and extend the type arrays
602 
+if necessary."
603 
+  (let ((curlen (length types-array)))
604 
+   (when (>= *next-type-code* curlen)
605 
+    ;; out of room, allocate more space
606 
+    (let ((newlen (+ curlen *types-array-inc*)))
607 
+     (setf types-array     (copy-extend-array types-array     curlen newlen)
608 
+           type-fns-array  (copy-extend-array type-fns-array  curlen newlen)
609 
+           type-docs-array (copy-extend-array type-docs-array curlen newlen))))
610 
+   ;; in any case, return current code, then add one to it
611 
+   (prog1
612 
+       *next-type-code*
613 
+     (incf *next-type-code*))))
614 
+
615 
+
616 
+(defun add-new-type (typename type-body type-fn &optional type-doc)
617 
+  "This adds a new type, if necessary
618 
+Always returns the CODE of the resulting type (whether new or not)"
619 
+  (with-types-table-lock-held (types-table)
620 
+    (let ((code (gethash (or typename type-body) types-table)))
621 
+      (if code
622 
+	  ;; redefining same name
623 
+	  (if (equal (code-to-type code) type-body)
624 
+	      ;; redefining same name, same type
625 
+	      (progn
626 
+		(format t "Ignoring redundant def-kr-type of ~S to ~S~%"
627 
+			typename type-body)
628 
+		(return-from add-new-type code))
629 
+	      ;; redefining same name, new type --> replace it!
630 
+	      (format t "def-kr-type redefining ~S from ~S to ~S~%"
631 
+		      typename (code-to-type code) type-body))
632 
+	  ;; defining a new name, establish new code
633 
+	  (progn
634 
+	    (setq code (or (gethash type-body types-table)
635 
+			   (get-next-type-code)))
636 
+	    (setf (gethash typename types-table) code)))
637 
+      (unless (gethash type-body types-table)
638 
+	(setf (gethash type-body types-table) code))
639 
+      (setf (svref types-array code)
640 
+	    (if typename
641 
+		(if (stringp typename)
642 
+		    (intern typename (find-package "KR"))
643 
+		    typename)
644 
+		type-body))
645 
+      (setf (svref type-docs-array code) (or type-doc NIL))
646 
+      (setf (svref type-fns-array  code)
647 
+	    (if (and (symbolp type-fn) ;; koz
648 
+		     (fboundp type-fn))
649 
+		(symbol-function type-fn)
650 
+		type-fn))
651 
+      code)))
652 
+
653 
+(defun kr-type-error (type)
654 
+  (error "Type ~S not defined; use~% (def-kr-type ... () '~S)~%" type type))
655 
+
656 
+(eval-when (:execute :compile-toplevel :load-toplevel)
657 
+  (defun encode-type (type)
658 
+    "Given a LISP type, returns its encoding."
659 
+    (with-types-table-lock-held (types-table)
660 
+      ;; if there, just return it!
661 
+      (cond ((gethash type types-table))
662 
+	    ((and (listp type) (eq (car type) 'SATISFIES))
663 
+	     ;; add new satisfies type
664 
+	     (add-new-type NIL type (type-to-fn type)))
665 
+	    ((symbolp type)
666 
+	     (or (gethash (symbol-name type) types-table)
667 
+		 (let ((predicate (find-lisp-predicate type)))
668 
+		   (when predicate
669 
+		     (add-new-type NIL type predicate)))
670 
+		 (kr-type-error type)))
671 
+	    (T (kr-type-error type))))))
672 
+
673 
+(defun set-type-documentation (type string)
674 
+  "Add a human-readable description to a Lisp type."
675 
+   (setf (aref type-docs-array (encode-type type)) string))
676 
+
677 
+
678 
+(defun get-type-documentation (type)
679 
+  "RETURNS: the documentation string for the internal number <type>."
680 
+  (aref type-docs-array (encode-type type)))
681 
+
682 
+
683 
+
684 
+;;; Formula and slot code.
685 
+
686 
+;; Helper function
687 
+;;
688 
+(defun eliminate-constant-formula ()
689 
+  (declare (ftype (function (t t) t) destroy-constraint))
690 
+  ;; This was a constant formula!  Commit suicide.
691 
+  (with-demons-disabled
692 
+    (destroy-constraint *schema-self* *schema-slot*))
693 
+  (when *warning-on-evaluation*
694 
+      (format t "formula (~S ~S) is constant - eliminated~%"
695 
+	      *schema-self* *schema-slot*))
696 
+  (let ((entry (slot-accessor *schema-self* *schema-slot*)))
697 
+    (if entry
698 
+	(setf (sl-bits entry)
699 
+	      (logior *constant-mask* (sl-bits entry))))))
700 
+
701 
+(declaim (inline slot-is-constant))
702 
+(defun slot-is-constant (schema slot)
703 
+  (let ((entry (slot-accessor schema slot)))
704 
+    (is-constant (sl-bits entry))))
705 
+
706 
+
707 
+(declaim (fixnum *warning-level*))
708 
+(defparameter *warning-level* 0)
709 
+
710 
+;; Helper function
711 
+;;
712 
+(defun re-evaluate-formula (schema-self schema-slot current-formula entry #+EAGER eval-type)
713 
+  (let ((*schema-self* schema-self)
714 
+	(*schema-slot* schema-slot)
715 
+	(*current-formula* current-formula)
716 
+	#+EAGER (*eval-type* eval-type)
717 
+	)
718 
+    (when *warning-on-evaluation*
719 
+      (dotimes (i *warning-level*) (write-string " "))
720 
+      (format t "evaluating ~S (on ~S, slot ~S)~%"
721 
+	      *current-formula* *schema-self* *schema-slot*)
722 
+      (incf *warning-level* 2))
723 
+    (let* ((*within-g-value* T)
724 
+	   (*check-constants*		; only for the first evaluation!
725 
+	    (unless *constants-disabled*
726 
+	      (zerop (the fixnum (a-formula-number *current-formula*)))))
727 
+	   (*accessed-slots* NIL)
728 
+	   (*is-constant* T)
729 
+	   (declared-constant (when *check-constants*
730 
+				(when (or entry
731 
+					  (setf entry (slot-accessor
732 
+						       *schema-self*
733 
+						       *schema-slot*)))
734 
+				  (is-constant (sl-bits entry))))))
735 
+      (when declared-constant		; save work, since we know the answer
736 
+	(setf *check-constants* nil))
737 
+      (set-cache-mark *current-formula* *sweep-mark*)
738 
+      (let ((the-result
739 
+	     (catch 'no-link
740 
+	       ;; If no-link, return cached-value anyway.
741 
+	       ;; Evaluate the formula.
742 
+	       (let ((new-v (funcall (coerce (a-formula-function *current-formula*) 'function))))
743 
+		 (if (and *types-enabled*
744 
+			  (multiple-value-bind (value result)
745 
+			      (check-slot-type *schema-self* *schema-slot* new-v
746 
+					       T entry)
747 
+			    (cond ((eq result :REPLACE)
748 
+				   (setf new-v value)
749 
+				   NIL)
750 
+				  ((eq result T) T)
751 
+				  (T NIL))))
752 
+		     ;; A type error
753 
+		     (setf new-v NIL)
754 
+		     ;; OK
755 
+		     (unless (eq new-v (cached-value *current-formula*))
756 
+		       ;; Do nothing if value has not changed.
757 
+		       (let ((*check-constants* *check-constants*))
758 
+			 ;; Call the pre-set-demon function on this schema if
759 
+			 ;; this slot is an interesting slot.
760 
+			 (run-pre-set-demons *schema-self* *schema-slot* new-v
761 
+					     :CURRENT-FORMULA :FORMULA-EVALUATION)
762 
+			 #+EAGER
763 
+			 (do-eager-reeval new-v)
764 
+			 ;; Set the cache to the new value
765 
+			 (setf (cached-value *current-formula*) new-v))))
766 
+		 new-v))))
767 
+	(if (or declared-constant
768 
+		(and *check-constants* *is-constant* *accessed-slots*))
769 
+	    ;; Eliminate constant formulas, if needed.
770 
+	    (eliminate-constant-formula)
771 
+	    ;; Mark formula as valid here.
772 
+	    (unless *setting-formula-p*
773 
+	      (set-cache-is-valid *current-formula* t)))
774 
+	(when *warning-on-evaluation* (decf *warning-level* 2))
775 
+	the-result))))
776 
+
777 
+;; We are working with a formula.  Note that broken links leave
778 
+;; the formula valid.
779 
+;;
780 
+(defun g-value-formula-value (schema-self slot formula entry)
781 
+  (let ((*schema-self* schema-self))
782 
+    (if (cache-is-valid formula)
783 
+	(a-formula-cached-value formula)
784 
+	(progn
785 
+	  (unless *within-g-value*
786 
+	    ;; Bump the sweep mark only at the beginning of a chain of formula
787 
+	    ;; accesses.  Increment by 2 since lower bit is "valid" flag.
788 
+	    (incf *sweep-mark* 2))
789 
+	  (if (= (cache-mark formula) *sweep-mark*)
790 
+	      ;; If the sweep mark is the same as the current one, WE ARE IN THE
791 
+	      ;; MIDDLE OF A CIRCULARITY.  Just use the old value, and mark it
792 
+	      ;; valid.
793 
+	      (progn
794 
+		(when *warning-on-circularity*
795 
+		  (format t "Warning - circularity detected on ~S, slot ~S~%"
796 
+			  *schema-self* slot))
797 
+		(unless *setting-formula-p*
798 
+		  (set-cache-is-valid formula T))
799 
+		(a-formula-cached-value formula))
800 
+	      ;; Compute, cache and return the new value.
801 
+	      (re-evaluate-formula *schema-self* slot formula entry))))))
802 
+
803 
+
804 
+;;; Inheritance
805 
+
806 
+(defun copy-to-all-instances (schema a-slot value &optional (is-first T))
807 
+  "Forces the <value> to be physically copied to the <a-slot> of all
808 
+instances of the <schema>, even though local values were defined.
809 
+However, if there was a local formula, do nothing."
810 
+  (s-value schema a-slot value)
811 
+  ;; Do not create copies of formulas, but set things up for inheritance
812 
+  (when (and is-first (formula-p value))
813 
+    (setf value *no-value*))
814 
+  (dolist (inverse *inheritance-inverse-relations*)
815 
+    (let ((children (if (eq inverse :IS-A-INV) ; for efficiency
816 
+			(let ((entry (slot-accessor schema :IS-A-INV)))
817 
+			  (when entry (sl-value entry)))
818 
+			(get-local-value schema inverse))))
819 
+      (unless (eq children *no-value*)
820 
+	(dolist (child children)
821 
+	  ;; force new inheritance
822 
+	  (unless (formula-p (get-value child a-slot))
823 
+	    ;; Do not override if the user has specified a local formula!
824 
+	    (copy-to-all-instances child a-slot value NIL)))))))
825 
+
826 
+(defun update-inherited-internal (child a-slot entry)
827 
+  (let ((old-value (sl-value entry)))
828 
+    (unless (eq old-value *no-value*)
829 
+      (let ((child-bits (sl-bits entry)))
830 
+	(when (is-inherited child-bits)
831 
+	  ;; NOTE: we erase the inherited value in all cases, even if it might
832 
+	  ;; have been inherited from somewhere else (in the case of multiple
833 
+	  ;; inheritance).  In any case, this is correct; at worst, it may
834 
+	  ;; cause the value to be needlessly inherited again.
835 
+	  ;; Force the children to re-inherit.
836 
+	  (when (formula-p old-value)
837 
+	    (delete-formula old-value T))
838 
+	  (clear-one-slot child a-slot entry)
839 
+	  ;; Recursively change children.
840 
+	  (update-inherited-values child a-slot *no-value* NIL))))))
841 
+
842 
+(defun update-inherited-values (schema a-slot value is-first)
843 
+  "This function is used when a value is changed in a prototype.  It makes
844 
+sure that any child schema which inherited the previous value is updated
845 
+with the new value.
846 
+INPUTS:
847 
+  - <value>: the new (i.e., current) value for the <schema>
848 
+  - <old-bits>: the setting of the slot bits for the <schema>, before the
849 
+    current value-setting operation.
850 
+  - <is-first>: if non-nil, this is the top-level call.
851 
+"
852 
+  (let ((*schema-self* schema))
853 
+    (unless is-first
854 
+      ;; Invoke demons and propagate change around.
855 
+      (run-pre-set-demons schema a-slot value NIL :INHERITANCE-PROPAGATION)
856 
+      (run-invalidate-demons schema a-slot NIL)
857 
+      (propagate-change schema a-slot))
858 
+    (dolist (inverse *inheritance-inverse-relations*)
859 
+      (let ((children (if (eq inverse :IS-A-INV) ; for efficiency
860 
+			  (let ((entry (slot-accessor schema :IS-A-INV)))
861 
+			    (when entry (sl-value entry)))
862 
+			  (get-local-value schema inverse))))
863 
+	(unless (eq children *no-value*)
864 
+	  (dolist (child children)
865 
+	    (let ((entry (slot-accessor child a-slot)))
866 
+	      (when entry
867 
+		;; If child had no value, no need to propagate down
868 
+		(setf is-first NIL)
869 
+		;; force new inheritance
870 
+		(update-inherited-internal child a-slot entry)))))))))
871 
+
872 
+
873 
+;;; Slot and formula change  code.
874 
+
875 
+
876 
+(declaim (inline mark-as-changed))
877 
+(defun mark-as-changed (schema slot)
878 
+  "Forces formulas which depend on the <slot> in the <schema> to be
879 
+invalidated.  Mostly used for internal implementation.
880 
+This function can be used when manually changing a slot (without using
881 
+s-value).  It will run the demons and propagate the invalidate wave
882 
+to all the ordinary places."
883 
+  (let ((entry (slot-accessor schema slot)))
884 
+    (run-invalidate-demons schema slot entry)
885 
+    (when (and entry (is-parent (sl-bits entry)))
886 
+      (update-inherited-values schema slot (sl-value entry) T)))
887 
+  (propagate-change schema slot))
888 
+
889 
+
890 
+(declaim (inline mark-as-invalid))
891 
+(defun mark-as-invalid (schema slot)
892 
+  "Invalidates the value of the formula at <position> in the <slot> of the
893 
+  <schema>.  If the value is not a formula, nothing happens."
894 
+  (let ((value (get-value schema slot)))
895 
+    (when (formula-p value)
896 
+      (set-cache-is-valid value NIL))))
897 
+
898 
+
899 
+(defun recompute-formula (schema slot)
900 
+  "Forces the formula installed on the <slot> of the <schema> to be
901 
+recomputed, propagating the change as needed.
902 
+This may be used for implementation of formulas which depend on some
903 
+non-KR value."
904 
+  (let* ((entry (slot-accessor schema slot))
905 
+	 (formula (when entry (sl-value entry))))
906 
+    (when (formula-p formula)
907 
+      (let ((bits (sl-bits entry)))
908 
+	(unless *within-g-value*
909 
+	  (incf *sweep-mark* 2))
910 
+	(re-evaluate-formula schema slot formula entry #+EAGER *eval-type*)
911 
+	(run-invalidate-demons schema slot entry)
912 
+	(when (is-parent bits)
913 
+	  (update-inherited-values schema slot formula T))
914 
+	#-EAGER
915 
+	(propagate-change schema slot)
916 
+	#+EAGER
917 
+	(propagate)))))
918 
+
919 
+
920 
+(defun propagate-change (schema slot)
921 
+  "Since the <slot> of the <schema> was modified, we need to propagate the
922 
+change to all the formulas which depended on the old value."
923 
+  (let ((entry (slot-accessor schema slot)))
924 
+    ;; access the dependent formulas.
925 
+    (do-one-or-list (formula (slot-dependents entry) T)
926 
+      ;; Stop propagating if this dependent formula was already marked dirty.
927 
+      (if (and (not-deleted-p formula) (cache-is-valid formula))
928 
+	(let* ((new-schema (on-schema formula))
929 
+	       (new-slot (on-slot formula))
930 
+	       (schema-ok (schema-p new-schema))
931 
+	       (new-entry  NIL))
932 
+	  (unless (and new-schema new-slot)
933 
+	    (when *warning-on-disconnected-formula*
934 
+	      (format
935 
+	       t
936 
+	       "Warning: disconnected formula ~S in propagate-change ~S ~S~%"
937 
+	       formula schema slot))
938 
+	    (continue-out))
939 
+	  (if schema-ok
940 
+	    (progn
941 
+	      (setf new-entry (slot-accessor new-schema new-slot))
942 
+	      (run-invalidate-demons new-schema new-slot new-entry))
943 
+	    #+GARNET-DEBUG
944 
+	    (progn
945 
+	      (format
946 
+	       t
947 
+	       "propagate-change: formula ~S on destroyed object ~S ~S~%    ~
948 
+	from change in schema ~S, slot ~S.~%"
949 
+	       formula new-schema new-slot schema slot)))
950 
+	  ;; The formula gets invalidated here.
951 
+	  (set-cache-is-valid formula nil)
952 
+	  ;; Notify all children who used to inherit the old value of the
953 
+	  ;; formula.
954 
+	  (if (and schema-ok new-entry)
955 
+	    (if (slot-dependents new-entry)
956 
+	      (propagate-change new-schema new-slot))))))))
957 
+
958 
+
959 
+(defun visit-inherited-values (schema a-slot function)
960 
+  "Similar to update-inherited-values, but used when the hierarchy is
961 
+modified or when an inheritable slot is destroyed.
962 
+SIDE EFFECTS:
963 
+ - the <function> is called on all children which actually inherit the
964 
+   values in the <a-slot> of the <schema>.  This is determined by a fast
965 
+   check (the list of values should be EQ to that of the parent).
966 
+Note that the <function> is called after all children have been visited..
967 
+This allows it to be a destructive function."
968 
+  (let* ((entry (slot-accessor schema a-slot))
969 
+	 (parent-entry (when entry (sl-value entry))))
970 
+    (dolist (inverse *inheritance-inverse-relations*)
971 
+      (dolist (child (if (eq inverse :IS-A-INV)
972 
+			 (get-local-value schema :IS-A-INV)
973 
+			 (get-local-value schema inverse)))
974 
+	(let* ((entry (slot-accessor child a-slot))
975 
+	       (value (when entry (sl-value entry))))
976 
+	  (when (and value
977 
+		     (is-inherited (sl-bits entry))
978 
+		     (eq value parent-entry))
979 
+	    (visit-inherited-values child a-slot function)
980 
+	    (funcall function child a-slot)))))))
981 
+
982 
+
983 
+(defun run-demons-and-set-value (schema slot new-value old-value is-relation
984 
+				 is-formula was-formula the-bits entry)
985 
+  "Internal function which runs demons as appropriate (before changing the
986 
+value) and then physically sets the <slot> in the <schema> to be
987 
+<new-value>."
988 
+  (run-invalidate-demons schema slot entry)
989 
+  ;; Now set the value in the slot to be new-value.
990 
+  (cond ((and was-formula (not is-formula))
991 
+	 ;; This is the case when we allow temporary overwriting
992 
+	 (setf (cached-value old-value) new-value)
993 
+	 ;; Set this to NIL, temporarily, in order to cause propagation
994 
+	 ;; to leave the value alone.  It will be validated by s-value.
995 
+	 (set-cache-is-valid old-value NIL))
996 
+	(t
997 
+	 ;; All other cases
998 
+	 (when (and is-formula (null (cached-value new-value)))
999 
+	   ;; place old value in the cache only if an initial value
1000 
+	   ;; was not provided for the new formula
1001 
+	   ;; Set value, but keep formula invalid.
1002 
+	   (setf (cached-value new-value)
1003 
+		 (if was-formula (cached-value old-value) old-value)))
1004 
+	 ;; Take care of relations.
1005 
+	 (when is-relation
1006 
+	   (when old-value (unlink-all-values schema slot))
1007 
+	   (link-in-relation schema slot new-value))
1008 
+	 (let ((new-bits (or the-bits *local-mask*)))
1009 
+	   (if entry
1010 
+	       ;; This is a special slot - just set it
1011 
+	       (setf (sl-value entry) new-value
1012 
+		     (sl-bits entry) new-bits)
1013 
+	       ;; This is not a special slot.
1014 
+	       (set-slot-accessor schema slot new-value new-bits nil)))))
1015 
+  ;; Now propagate the change to all the children which used to
1016 
+  ;; inherit the previous value of this slot from the schema.
1017 
+  (when (and the-bits (is-parent the-bits))
1018 
+    (let ((*setting-formula-p* T))
1019 
+      (update-inherited-values schema slot new-value T))))
1020 
+
1021 
+
1022 
+(defun constant-slot-error (schema slot)
1023 
+  (cerror "Set the slot anyway"
1024 
+	  "Schema ~S - trying to set slot ~S, which is constant."
1025 
+	  schema slot))
1026 
+
1027 
+
1028 
+(declaim (inline check-not-constant))
1029 
+(defun check-not-constant (schema slot entry)
1030 
+  "Signals an error if the <slot> of the <schema> is not constant."
1031 
+  (and (not *constants-disabled*)
1032 
+       entry
1033 
+       (is-constant (sl-bits entry))
1034 
+       (constant-slot-error schema slot)))
1035 
+
1036 
+
1037 
+(declaim (inline slot-constant-p))
1038 
+(defun slot-constant-p (schema slot)
1039 
+  "RETURN: T if the <slot> in the <schema> is constant, nil otherwise"
1040 
+  (let ((entry (slot-accessor schema slot)))
1041 
+    (when entry
1042 
+      (is-constant (sl-bits entry)))))
1043 
+
1044 
+
1045 
+(defun set-formula-error (schema slot formula)
1046 
+  "Called to give error message on multiply-installed formulas."
1047 
+  ;; Formulas can only be installed on one slot!
1048 
+  (format t "(s-value ~S ~S): formula ~S is already installed on~%~
1049 
+	schema ~S, slot ~S.  Ignored.~%"
1050 
+	  schema slot formula (on-schema formula) (on-slot formula))
1051 
+  formula)
1052 
+
1053 
+
1054 
+(defun s-value-fn (schema slot value)
1055 
+  "Does all the work of the macro S-VALUE.
1056 
+
1057 
+RGA --- no, returns two values: the value function set to and t if there
1058 
+was an error.  Note that in the case of a type error, it returns the
1059 
+current value of the slot."
1060 
+  (locally (declare #.*special-kr-optimization*)
1061 
+    (unless (schema-p schema)
1062 
+      #+GARNET-DEBUG
1063 
+      (if schema
1064 
+	  (error "S-VALUE called with the non-object  ~S  (slot ~S, value ~S)."
1065 
+		 schema slot value)
1066 
+	  (error "S-VALUE called with a null schema:  (slot ~S, value ~S)."
1067 
+		 slot value))
1068 
+      ;; RGA added t for error return.
1069 
+      (return-from s-value-fn (values value t)))
1070 
+    (let* ((entry (slot-accessor schema slot))
1071 
+	   (old-value (when entry
1072 
+			;; Slot position is known at compile time
1073 
+			(sl-value entry)))
1074 
+	   the-bits is-depended)
1075 
+      ;; give error if setting constant slot
1076 
+      (check-not-constant schema slot entry)
1077 
+
1078 
+      (if entry
1079 
+	  (setf the-bits (sl-bits entry)
1080 
+		is-depended (slot-dependents entry))
1081 
+	  (setf the-bits 0))
1082 
+
1083 
+      (when (and the-bits
1084 
+		 (not (is-inherited the-bits))
1085 
+		 (eq old-value value)
1086 
+		 value)
1087 
+	;; We are setting to the same value as the old one!  Do nothing.
1088 
+	;; RGA --- Error return function
1089 
+	(return-from s-value-fn (values value nil)))
1090 
+
1091 
+      (when (and *types-enabled* (not (formula-p value)))
1092 
+	(multiple-value-bind (result error-p)
1093 
+	    (check-slot-type schema slot value T entry)
1094 
+	  (cond ((not error-p))  ; Everything is OK
1095 
+		((eq error-p T)
1096 
+		 ;; A type error - user wants to do nothing
1097 
+		 ;; RGA --should return old-value, added a second
1098 
+		 ;; value indicating error.
1099 
+		 (return-from s-value-fn (values old-value t)))
1100 
+		(T
1101 
+		 ;; A type error - user supplied new value
1102 
+		 (setf value result)))))
1103 
+
1104 
+      (let ((is-formula nil) (is-relation nil)
1105 
+	    (was-formula (formula-p old-value)))
1106 
+	;; Check for special cases in relation slots.
1107 
+	(when (and (setf is-relation (relation-p slot))
1108 
+		   (eq (setf value (check-relation-slot schema slot value)) *no-value*))
1109 
+	  ;; RGA --- added no-error return code
1110 
+	  (return-from s-value-fn (values old-value nil)))
1111 
+
1112 
+	;; If we are installing a formula, make sure that the formula
1113 
+	;; points to the schema and slot.
1114 
+	(when (formula-p value)
1115 
+	  (when (on-schema value)
1116 
+	    ;; RGA --- added error return code.
1117 
+	    (return-from s-value-fn
1118 
+	      (values (set-formula-error schema slot value) T)))
1119 
+	  (setf is-formula T)
1120 
+	  (setf (on-schema value) schema)
1121 
+	  (setf (on-slot value) slot)
1122 
+	  (unless (schema-name value)
1123 
+	    ;; This is an obscure case.  It may happen if somebody stores a
1124 
+	    ;; formula away, deletes the formula from its original slot, and
1125 
+	    ;; then restores the formula.  This is generally bad practice, but
1126 
+	    ;; there are cases when it may be necessary.
1127 
+	    (incf *schema-counter*)
1128 
+	    (setf (schema-name value) *schema-counter*)))
1129 
+
1130 
+	;; Now we call a demon to perform redisplay activities if the new
1131 
+	;; value is not a formula. If the new value is a formula, it has
1132 
+	;; not been evaluated yet so we do not know what its result is.
1133 
+	;; Since the display demon needs to know the new result to determine
1134 
+	;; if the object's bounding box should be merged with a clip region,
1135 
+	;; it does not make sense to call the display demon until the new
1136 
+	;; result is known
1137 
+	(unless is-formula
1138 
+	  (run-pre-set-demons schema slot value NIL :S-VALUE))
1139 
+
1140 
+	;; Now we can set the new value.
1141 
+	(setf the-bits (logand the-bits *not-inherited-mask*))
1142 
+	(run-invalidate-demons schema slot entry)
1143 
+	;; Now set the value in the slot to be <value>.
1144 
+	(cond
1145 
+	  ((and was-formula (not is-formula))
1146 
+	   (when (zerop (a-formula-number old-value))
1147 
+	     (format t "*** Warning: you are setting the value of slot ~S of
1148 
+ object ~S.  This slot contains a formula which was never evaluated.
1149 
+ The formula is now valid, but its dependencies are not set up properly.  As
1150 
+ a result, the formula will never be evaluated.
1151 
+ In order for this formula to work properly, you should have used
1152 
+ (g-value ~S ~S) before using S-VALUE.  If you want to fix things now,
1153 
+ re-install the formula using s-value.~%"
1154 
+		     slot schema schema slot))
1155 
+	   ;; This is the case when we allow temporary overwriting
1156 
+	   (setf (cached-value old-value) value)
1157 
+	   ;; Set this to NIL, temporarily, in order to cause propagation
1158 
+	   ;; to leave the value alone.  It will be validated by s-value.
1159 
+	   (set-cache-is-valid old-value NIL))
1160 
+	  (t
1161 
+	   ;; All other cases
1162 
+	   (when (and is-formula (null (cached-value value)))
1163 
+	     ;; place old value in the cache only if an initial value
1164 
+	     ;; was not provided for the new formula
1165 
+	     ;; Set value, but keep formula invalid.
1166 
+	     (setf (cached-value value)
1167 
+		   (if was-formula (cached-value old-value) old-value)))
1168 
+	   ;; Take care of relations.
1169 
+	   (when is-relation
1170 
+	     (when old-value (unlink-all-values schema slot))
1171 
+	     (link-in-relation schema slot value))
1172 
+	   (let ((new-bits (or the-bits *local-mask*)))
1173 
+	     (if entry
1174 
+		 ;; This is a special slot - just set it
1175 
+		 (setf (sl-value entry) value
1176 
+		       (sl-bits entry) new-bits)
1177 
+		 ;; This is not a special slot.
1178 
+		 (setf entry (set-slot-accessor schema
1179 
+						slot value new-bits nil))))))
1180 
+
1181 
+	;; Now propagate the change to all the children which used to
1182 
+	;; inherit the previous value of this slot from the schema.
1183 
+	(when (and the-bits (is-parent the-bits))
1184 
+	  (let ((*setting-formula-p* T))
1185 
+	    (update-inherited-values schema slot value T)))
1186 
+
1187 
+	;; Notify all dependents that the value changed.
1188 
+	(when is-depended
1189 
+	  (let ((*warning-on-disconnected-formula* nil))
1190 
+	    (propagate-change schema slot)))
1191 
+	(when (and was-formula (not is-formula))
1192 
+	  ;; We validate now, rather than earlier, because of a technicality
1193 
+	  ;; in demons-and-old-values.
1194 
+	  (set-cache-is-valid old-value T))
1195 
+
1196 
+	;; Was the old value a formula?
1197 
+	(when (and was-formula is-formula)
1198 
+	  ;; This is replacing a formula with another.  Eliminate the dependency
1199 
+	  ;; to the old one.
1200 
+	  (delete-formula old-value T))
1201 
+
1202 
+	(when is-relation
1203 
+	  ;; A relation slot is being changed.  We may need to invalidate all
1204 
+	  ;; inherited values.
1205 
+	  (reset-inherited-values schema))
1206 
+	;; RGA added nil error return flag.
1207 
+	(values value nil)))))
1208 
+
1209 
+
1210 
+(defun internal-s-value (schema slot value)
1211 
+  "This is a stripped-down version of s-value-fn which is used by
1212 
+create-schema and friends.  It skips a lot of the stuff that is
1213 
+unnecessary at schema creation time."
1214 
+  (let ((is-formula (formula-p value))
1215 
+	(is-relation (relation-p slot)))
1216 
+    (when is-relation
1217 
+      (unless (listp value)
1218 
+	(setf value (list value)))
1219 
+      ;; Check for special cases in relation slots.
1220 
+      (when (eq (setf value (check-relation-slot schema slot value)) *no-value*)
1221 
+	(return-from internal-s-value NIL)))
1222 
+
1223 
+    ;; If we are installing a formula, make sure that the formula
1224 
+    ;; points to the schema and slot.
1225 
+    (when is-formula
1226 
+      (when (on-schema value)
1227 
+	(return-from internal-s-value (set-formula-error schema slot value)))
1228 
+      (setf (on-schema value) schema)
1229 
+      (setf (on-slot value) slot))
1230 
+
1231 
+    (set-slot-accessor schema slot value *local-mask* nil)
1232 
+
1233 
+    ;; Take care of relations.
1234 
+    (when is-relation
1235 
+      (link-in-relation schema slot value))
1236 
+    value))
1237 
+
1238 
+
1239 
+(defun set-is-a (schema value)
1240 
+  "A specialized version of internal-s-value"
1241 
+  ;; Check for special cases in relation slots.
1242 
+  (when (eq (setf value (check-relation-slot schema :is-a value)) *no-value*)
1243 
+    (return-from set-is-a NIL))
1244 
+  ;; Set slot
1245 
+  (set-slot-accessor schema :IS-A value *local-mask* NIL)
1246 
+  (link-in-relation schema :IS-A value)
1247 
+  value)
1248 
+
1249 
+
1250 
+(defun eliminate-formula-dependencies (formula except-schema)
1251 
+  "If <except-schema> is non-nil, it indicates that a schema is in the
1252 
+process of being destroyed, and hence dependencies to THAT schema should
1253 
+not be tracked down."
1254 
+  (do-one-or-list (schema (a-formula-depends-on formula))
1255 
+    (unless (or (eq schema except-schema)
1256 
+		(deleted-p schema))	; schema is destroyed
1257 
+      (iterate-slot-value (schema T T T)
1258 
+	slot value			; suppress warning
1259 
+	(let ((formulas (slot-dependents iterate-slot-value-entry)))
1260 
+	  (if (listp formulas)
1261 
+	      ;; Several dependents
1262 
+	      (when (memberq formula formulas)
1263 
+		(setf (full-sl-dependents iterate-slot-value-entry)
1264 
+		      (delete formula formulas)))
1265 
+	      ;; One dependent
1266 
+	      (when (eq formula formulas)
1267 
+		(setf (full-sl-dependents iterate-slot-value-entry) NIL))))))))
1268 
+
1269 
+
1270 
+(defun delete-formula (formula remove-from-parent)
1271 
+  "Eliminate all dependency pointers from the <formula>, since it is no
1272 
+longer installed on a slot.
1273 
+
1274 
+INPUTS:
1275 
+ - <formula>: the formula to get rid of
1276 
+ - <hard-p>: if T, do a more thorough job of deleting everything, and
1277 
+   destroy the <formula> schema itself."
1278 
+  (when (a-formula-number formula)
1279 
+    (eliminate-formula-dependencies formula NIL)
1280 
+    (when remove-from-parent
1281 
+      ;; Eliminate the <formula> from its parent's list of children.
1282 
+      (let ((parent (a-formula-is-a formula)))
1283 
+	(when parent
1284 
+	  (delete-one-or-list formula (a-formula-is-a-inv parent)))))
1285 
+    ;; Formula was not destroyed yet
1286 
+    (setf (a-formula-bins formula) nil	; mark as destroyed.
1287 
+	  (a-formula-schema formula) nil
1288 
+	  (a-formula-slot formula) nil
1289 
+	  (a-formula-lambda formula) nil
1290 
+	  (a-formula-depends-on formula) nil)
1291 
+    (let ((meta (a-formula-meta formula)))
1292 
+      (when meta
1293 
+	(setf (a-formula-meta formula) NIL)
1294 
+	(destroy-schema meta)))
1295 
+    (formula-push formula)))
1296 
+
1297 
+
1298 
+(defun destroy-slot-helper (x slot)
1299 
+  ;; Make sure formulas are updated properly
1300 
+  (mark-as-changed x slot)
1301 
+  ;; Physically remove the slot in the child.
1302 
+  (clear-one-slot x slot NIL))
1303 
+
1304 
+(defparameter *in-destroy-slot* 0)
1305 
+(defparameter *invalid-destroy-slot* 0)
1306 
+
1307 
+
1308 
+(defun destroy-slot (schema slot)
1309 
+  "Eliminates the <slot>, and all the values it contains, from the <schema>,
1310 
+taking care of possible constraints."
1311 
+  ;; Take care of all formulas which used to depend on this slot.
1312 
+  (let ((entry (slot-accessor schema slot))
1313 
+	old-value)
1314 
+    (when entry
1315 
+      (setf old-value (sl-value entry))
1316 
+      (check-not-constant schema slot entry)
1317 
+      (let ((bits (sl-bits entry))
1318 
+	    (dependents (slot-dependents entry))
1319 
+	    new-value)
1320 
+	(run-invalidate-demons schema slot entry)
1321 
+	(when dependents
1322 
+	  ;; Access all dependent formulas.
1323 
+	  (do-one-or-list (formula dependents)
1324 
+	    #+EAGER
1325 
+	    (setf formula (car formula))
1326 
+	    #+EAGER
1327 
+	    (setf in-pq (eval-bit-set formula))
1328 
+	    (incf *in-destroy-slot*)
1329 
+	    (unless (cache-is-valid formula)
1330 
+	      (incf *invalid-destroy-slot*))
1331 
+	    ;; If this value is depended on by others, replace their value
1332 
+	    ;; by the current value.
1333 
+	    (let ((the-schema (on-schema formula))
1334 
+		  (the-slot (on-slot formula)))
1335 
+	      (when (and the-schema
1336 
+			 (schema-p the-schema) ; not destroyed
1337 
+			 (not (formula-p (g-value the-schema the-slot))))
1338 
+		;; Avoid complications with shared formulas.
1339 
+		(s-value the-schema the-slot
1340 
+			 (g-value the-schema the-slot))))
1341 
+	    ;; The formula is then marked invalid.
1342 
+	    #-EAGER
1343 
+	    (set-cache-is-valid formula NIL)
1344 
+	    #+EAGER
1345 
+	    (progn
1346 
+	      ;; set the formula's fixed bit back to nil to indicate it should
1347 
+	      ;; be evaluated during this iteration of the constraint solver
1348 
+	      (set-fixed-bit formula nil)
1349 
+	      (when (not in-pq)
1350 
+		(setf *eval-queue* (insert-pq formula *eval-queue*))))))
1351 
+
1352 
+	;; Destroy the formula, if this was a constrained slot.
1353 
+	(when (formula-p old-value)
1354 
+	  (delete-formula old-value T))
1355 
+
1356 
+	(when (relation-p slot)
1357 
+	  (unlink-all-values schema slot))
1358 
+
1359 
+	(setf new-value (g-value-inherit-values schema slot T entry))
1360 
+	;; Call the pre-set-demon function on this schema if
1361 
+	;; this slot is an interesting slot and the value it is
1362 
+	;; now inheriting is different from its previous value
1363 
+	(run-pre-set-demons schema slot new-value old-value :DESTROY-SLOT)
1364 
+
1365 
+	#+EAGER
1366 
+	;; Add this slot's dependents to the evaluation queue if its
1367 
+	;; new inherited value is different from its old value.
1368 
+	(unless (equal old-value new-value)
1369 
+	  (add-to-reeval schema slot))
1370 
+
1371 
+	(let ((was-parent (and bits (is-parent bits))))
1372 
+	  (when was-parent
1373 
+	    ;; Was this slot inherited by other schemata?  If so, make sure
1374 
+	    ;; they will inherit the right value afterwards.
1375 
+	    (update-inherited-values schema slot new-value T)
1376 
+	    (visit-inherited-values schema slot #'destroy-slot-helper))))
1377 
+      ;; Now go ahead and physically destroy the slot.
1378 
+      (clear-one-slot schema slot NIL)
1379 
+      NIL)))
1380 
+
1381 
+
1382 
+(defun delete-schema (schema recursive-p)
1383 
+  "Internal function.  If <recursive-p>, this is being called from within
1384 
+recursive-destroy-schema, so there is no need to maintain upwards
1385 
+relations properly."
1386 
+  (when (not-deleted-p schema)	; do nothing if schema is already destroyed
1387 
+    ;; Remove all inverse links.
1388 
+    (if (formula-p schema)
1389 
+	;; Formulas do not use regular relations.
1390 
+	(let ((parent (a-formula-is-a schema))
1391 
+	      children)
1392 
+	  (when parent
1393 
+	    (setf children (a-formula-is-a-inv parent))
1394 
+	    (setf (a-formula-is-a-inv parent)
1395 
+		  (if (listp children)
1396 
+		    (delete schema children)
1397 
+		    (if (eq schema children)
1398 
+		      NIL
1399 
+		      children))))
1400 
+	  (do-one-or-list (child (a-formula-is-a-inv schema))
1401 
+	    ;; ? What exactly should happen here ?
1402 
+	    (setf (a-formula-is-a child) NIL)))
1403 
+	;; A normal schema
1404 
+	(progn
1405 
+	  (unless recursive-p
1406 
+	    (iterate-slot-value (schema NIL NIL NIL)
1407 
+	      value                     ; eliminate warning
1408 
+	      (when (relation-p slot)
1409 
+		(unlink-all-values schema slot))))
1410 
+	  (iterate-slot-value (schema NIL NIL NIL)
1411 
+	    slot value			; eliminate warning
1412 
+	    ;; Delete any formula value.
1413 
+	    (when (formula-p value)
1414 
+	      ;; This is a formula.  Get rid of it.
1415 
+	      (delete-formula value (not recursive-p))
1416 
+	      (delete-schema value recursive-p)))
1417 
+	  ;; Physically delete all the slots
1418 
+	  (clear-schema-slots schema)))
1419 
+    ;; Now wipe out the symbol value as well.
1420 
+    (when (symbolp (schema-name schema))
1421 
+      (makunbound (schema-name schema)))
1422 
+    ;; This is used as a marker for deleted schemas.
1423 
+    (setf (schema-bins schema) nil)))
1424 
+
1425 
+
1426 
+(defun find-direct-dependency (expression target)
1427 
+  "RETURNS: T if the given <expression>, or one of its subexpressions,
1428 
+directly depends on the <target>.  This must be a direct dependency,
1429 
+i.e., one which does not use a link."
1430 
+  (when (listp expression)
1431 
+    (or (and (eq (car expression) 'GV)
1432 
+	     (eq (cadr expression) target))
1433 
+	(dolist (thing expression)
1434 
+	  (when (find-direct-dependency thing target)
1435 
+	    (return T))))))
1436 
+
1437 
+
1438 
+(defun destroy-schema (schema &optional (send-destroy-message NIL) recursive-p)
1439 
+  "Destroys the <schema>, eliminates all dependencies to and from it."
1440 
+  (unless (schema-p schema)
1441 
+    ;; If schema is already destroyed, do nothing.
1442 
+    (return-from destroy-schema))
1443 
+  (let ((done nil)
1444 
+	bizarre)
1445 
+    (iterate-slot-value (schema T T NIL)
1446 
+      slot				; eliminate warning
1447 
+      (unless (eq value *no-value*)
1448 
+	;; Look at all formulas which depend on this slot.
1449 
+	(do-one-or-list (formula (slot-dependents iterate-slot-value-entry))
1450 
+	  (when (and formula		; defensive programming
1451 
+		     (not (memberq formula done)))
1452 
+	    ;; If this is a value depended on by others, replace their
1453 
+	    ;; value by the current value.  Do this, however, only if the
1454 
+	    ;; dependency is a DIRECT one, i.e., if the name of the
1455 
+	    ;; schema we are destroying is wired into the formula.  If
1456 
+	    ;; this is a link, leave things as they are.
1457 
+	    (let ((the-form
1458 
+		   (or (a-formula-lambda formula) ; for o-formulas
1459 
+		       (and (setf bizarre
1460 
+				  ;; This should always be a
1461 
+				  ;; list, but be prudent just
1462 
+				  ;; in case.
1463 
+				  (a-formula-function formula))
1464 
+			    (listp bizarre)
1465 
+			    (cddr bizarre)))))
1466 
+	      (when (find-direct-dependency the-form schema)
1467 
+		;; This is indeed a direct-dependency formula.  Install the
1468 
+		;; appropriate value.
1469 
+		(s-value (on-schema formula) (on-slot formula)
1470 
+			 (g-value (on-schema formula) (on-slot formula)))
1471 
+		(push formula done)
1472 
+		;; The formula now commits suicide.
1473 
+		(delete-formula formula (not recursive-p))))))
1474 
+	;; If this is a formula, eliminate dependencies to it, so we
1475 
+	;; do not get warnings in propagate-change.
1476 
+	(when (formula-p value)
1477 
+	  (delete-formula value T))))
1478 
+    (when send-destroy-message
1479 
+      ;; Call the :DESTROY method.
1480 
+      (kr-call-initialize-method schema :DESTROY))
1481 
+    ;; Physically delete the schema.
1482 
+    (delete-schema schema recursive-p)))
1483 
+
1484 
+
1485 
+(defun recursive-destroy-schema (schema level)
1486 
+  "This is an internal function used by CREATE-INSTANCE.  The purpose is to
1487 
+destroy not only the <schema> itself, but also its instances (and so on,
1488 
+recursively)."
1489 
+  (unless (or (formula-p schema)	; safety check
1490 
+	      (deleted-p schema))
1491 
+    (let* ((entry (slot-accessor schema :IS-A-INV))
1492 
+	   (children (if entry (sl-value entry))))
1493 
+      (unless (eq children *no-value*)
1494 
+	(dolist (child children)
1495 
+	  (unless (eq child schema)
1496 
+	    (recursive-destroy-schema child (1+ level)))))
1497 
+      (when *warning-on-create-schema*
1498 
+	(if (zerop level)
1499 
+	    (format t "Warning - create-schema is destroying the old ~S.~%"
1500 
+		    schema)
1501 
+	    (format t "Warning - create-schema is recursively destroying ~S.~%"
1502 
+		    schema)))))
1503 
+  (destroy-schema
1504 
+   schema
1505 
+   NIL
1506 
+   (if (zerop level)
1507 
+       ;; if this is a top-level schema which has no prototype, use an
1508 
+       ;; indiscriminate destroy.
1509 
+       (null (slot-accessor schema :is-a))
1510 
+       T)))
1511 
+
1512 
+
1513 
+(defun reset-inherited-values (schema)
1514 
+  "Since the <relation> slot was changed, all children of the <schema> may
1515 
+have to inherit different values."
1516 
+  (iterate-slot-value (schema T NIL T)	; use inheritance!
1517 
+    (unless (relation-p slot)
1518 
+      (unless (eq value *no-value*)
1519 
+	(when (is-inherited (sl-bits iterate-slot-value-entry))
1520 
+	  (destroy-slot schema slot))))))
1521 
+
1522 
+
1523 
+
1524 
+;;; SCHEMA PRINTING
1525 
+
1526 
+
1527 
+(defun print-one-value (value type)
1528 
+  (let ((string (cond ((formula-p value)
1529 
+		       (let ((cached (cached-value value))
1530 
+			     (valid (cache-is-valid value)))
1531 
+			 (if (or valid cached)
1532 
+			     (format nil "~S(~S . ~D)"
1533 
+				     value
1534 
+				     cached
1535 
+				     valid)
1536 
+			     (format nil "~S(nil . NIL)" value))))
1537 
+		      ((eq value *no-value*)
1538 
+		       "")
1539 
+		      (t
1540 
+		       (format nil "~S" value)))))
1541 
+    (when type
1542 
+      (setf string (concatenate 'simple-string string
1543 
+				(format nil "  ~([~S]~)" type))))
1544 
+    (write-string string)
1545 
+    (length string)))
1546 
+
1547 
+
1548 
+(defun print-one-slot-helper (value column indent space-p type)
1549 
+  (when (> column 78)
1550 
+    (format t "~%    ")
1551 
+    (setf column (indent-by indent)))
1552 
+  (when space-p
1553 
+    (write-string " "))
1554 
+  (incf column (print-one-value value type))
1555 
+  column)
1556 
+
1557 
+
1558 
+(defun print-meta (formula)
1559 
+  "Print the meta-information associated with a formula."
1560 
+  (let ((meta (a-formula-meta formula)))
1561 
+    (when (and meta (schema-p meta))
1562 
+      (format t "  ---- meta information (~A):~%" meta)
1563 
+      (call-on-ps-slots meta 'SLOT-PRINTER))))
1564 
+
1565 
+
1566 
+(defun indent-by (indent)
1567 
+  (dotimes (i indent)
1568 
+    (write-string "   "))
1569 
+  (* indent 3))
1570 
+
1571 
+
1572 
+(defun force-down-helper (schema original-slots slots)
1573 
+  (iterate-slot-value (schema T T NIL)
1574 
+    value				; eliminate warning
1575 
+    (unless (memberq slot original-slots)
1576 
+      (pushnew slot slots)))
1577 
+  (dolist (parent (get-local-value schema :IS-A))
1578 
+    (setf slots (force-down-helper parent original-slots slots)))
1579 
+  slots)
1580 
+
1581 
+
1582 
+(defun force-down-all-inheritance (schema)
1583 
+  "A potentially VERY expensive operation.  It is done by PS when it wants
1584 
+to print out all inherited and inheritable slots of an object."
1585 
+  (let ((original-slots nil))
1586 
+    (iterate-slot-value (schema T NIL NIL)
1587 
+      value				; eliminate warning
1588 
+      (push slot original-slots))
1589 
+    (dolist (slot (force-down-helper schema original-slots nil))
1590 
+      (get-value schema slot))))
1591 
+
1592 
+
1593 
+(defun call-func-on-one-slot (schema slot inherited-ok function
1594 
+				     types-p indent limits)
1595 
+  "Helper function for the following.
1596 
+The <function> is called with:
1597 
+(schema slot formula inherited valid real-value types-p indent limits)"
1598 
+  (let* ((entry (slot-accessor schema slot))
1599 
+	 (values (when entry (sl-value entry)))
1600 
+	 (bits (when entry (sl-bits entry)))
1601 
+	 form valid real-value)
1602 
+    (when bits
1603 
+      (let ((are-inherited (and (is-inherited bits)
1604 
+				;; inherited formulas are printed anyway.
1605 
+				(not (formula-p values)))))
1606 
+	(unless (and (not inherited-ok) are-inherited)
1607 
+	  (unless (eq values *no-value*)
1608 
+	    (if (formula-p values)
1609 
+		(let ((cached (cached-value values))
1610 
+		      (is-valid (cache-is-valid values)))
1611 
+		  (setq form values)
1612 
+		  (setq valid is-valid)
1613 
+		  (setq real-value cached))
1614 
+		;; else not a formula
1615 
+		(setq real-value values))
1616 
+	    (funcall function
1617 
+		     schema slot form are-inherited valid real-value
1618 
+		     types-p bits indent limits)))
1619 
+	;; Indicate that the function was called.
1620 
+	T))))
1621 
+
1622 
+
1623 
+(defun call-on-ps-slots (schema function
1624 
+			 &key (control t)
1625 
+			      inherit
1626 
+			      (indent NIL)
1627 
+			      types-p
1628 
+			      all-p)
1629 
+  "Apply the <function> to slots, the way PS would."
1630 
+  (declare (special print-schema-control))
1631 
+  (let ((is-ps (eq function 'SLOT-PRINTER))) ; true if inside PS
1632 
+    (when (null indent)
1633 
+      (setf indent 0))
1634 
+    (when (numberp schema)
1635 
+      (setf schema (s schema)))
1636 
+    (unless (or (schema-p schema) (formula-p schema))
1637 
+      (when is-ps
1638 
+	(format t "~S~%" schema))
1639 
+      (return-from call-on-ps-slots nil))
1640 
+    (when is-ps
1641 
+      (indent-by indent))
1642 
+    (cond ((formula-p schema)
1643 
+	   (setf control NIL))
1644 
+	  ((eq control :default)
1645 
+	   ;; use default control schema
1646 
+	   (setf control PRINT-SCHEMA-CONTROL))
1647 
+	  ((eq control T)
1648 
+	   ;; use schema itself as the control schema (i.e., use hierarchy)
1649 
+	   (setf control schema)))
1650 
+    (let ((slots-ignored (when control (g-value-no-copy control :IGNORED-SLOTS)))
1651 
+	  (sorted (when control (g-value-no-copy control :SORTED-SLOTS)))
1652 
+	  (limit-values (when control (g-value-no-copy control :LIMIT-VALUES)))
1653 
+	  (global-limit (if control
1654 
+			    (g-value-no-copy control :GLOBAL-LIMIT-VALUES)
1655 
+			    most-positive-fixnum))
1656 
+	  (*print-as-structure*
1657 
+	   (if (and control (g-value-no-copy control :print-as-structure))
1658 
+	       ;; value is defined
1659 
+	       (g-value-no-copy control :print-as-structure)
1660 
+	       ;; value is undefined
1661 
+	       *print-as-structure*))
1662 
+	  (*print-structure-slots*
1663 
+	   (when control (g-value-no-copy control :print-slots))))
1664 
+      (when is-ps
1665 
+	(format t "{~S~%" schema))
1666 
+      ;; Print out all the sorted slots, first.
1667 
+      (dolist (o sorted)
1668 
+	(call-func-on-one-slot schema o inherit function types-p indent
1669 
+			       (or (second (assocq o limit-values)) global-limit)))
1670 
+      ;; Now print the remaining slots.
1671 
+      (unless (listp slots-ignored)
1672 
+	(setf slots-ignored (list slots-ignored)))
1673 
+      ;; Pre-inherit all slots that are inheritable.
1674 
+      (unless (a-formula-p schema)
1675 
+	(when inherit
1676 
+	  (force-down-all-inheritance schema))
1677 
+	(if all-p
1678 
+	    (iterate-slot-value (schema T T NIL)
1679 
+	      (unless (or (memberq slot slots-ignored) (memberq slot sorted)
1680 
+			  (eq value *no-value*))
1681 
+		(call-func-on-one-slot
1682 
+		 schema slot inherit function types-p indent
1683 
+		 (or (second (assocq slot limit-values)) global-limit))))
1684 
+	    (iterate-slot-value (schema T NIL NIL)
1685 
+	      (unless (or (memberq slot slots-ignored) (memberq slot sorted)
1686 
+			  (eq value *no-value*))
1687 
+		(call-func-on-one-slot
1688 
+		 schema slot inherit function types-p indent
1689 
+		 (or (second (assocq slot limit-values)) global-limit))))))
1690 
+      (when (and slots-ignored is-ps)
1691 
+	(indent-by indent)
1692 
+	(format t "  List of ignored slots:  ~{ ~A~}~%" slots-ignored))
1693 
+      ;; special formula slots?
1694 
+      (when (a-formula-p schema)
1695 
+	(if is-ps
1696 
+	    (progn
1697 
+	      (indent-by indent)
1698 
+	      (format t "  lambda:        ~(~S~)~%" (a-formula-lambda schema))
1699 
+	      (format t "  cached value:  (~S . ~S)~%"
1700 
+		      (cached-value schema) (cache-is-valid schema))
1701 
+	      (format t "  on schema ~S, slot ~S~%"
1702 
+		      (on-schema schema) (on-slot schema))
1703 
+	      (indent-by indent))
1704 
+	    (dolist (name '(:lambda :cached-value-valid :cached-value
1705 
+			    :schema :slot))
1706 
+	      (funcall function schema name nil nil T ; valid
1707 
+		       (g-formula-value schema name) nil 0 indent nil)))))
1708 
+    (when is-ps
1709 
+      (format t "  }~%"))))
1710 
+
1711 
+
1712 
+(defun call-on-one-slot (schema slot function)
1713 
+  "Similar to CALL-ON-PS-SLOTS, but works on one slot only."
1714 
+  (call-func-on-one-slot schema slot T function NIL 0 NIL))
1715 
+
1716 
+
1717 
+(defun slot-printer (schema name formula are-inherited valid values
1718 
+			    type-p bits indent limit-values)
1719 
+  "Used by PS to print out one slot."
1720 
+  (declare (ignore schema))
1721 
+  (let ((number 0)
1722 
+	(printed nil)
1723 
+	(column (+ 20 (indent-by indent)))
1724 
+	(*print-length* 10)		; do not print out very long arrays!
1725 
+	type)
1726 
+    (if are-inherited
1727 
+      (format t "  ~(~S~) (inherited): " name)
1728 
+      (format t "  ~S = " name))
1729 
+    (when type-p
1730 
+      (setf type (code-to-type (extract-type-code bits))))
1731 
+    (when formula
1732 
+      (format t "~S(" formula))
1733 
+    (cond ((eq values *no-value*)
1734 
+	   (if type-p
1735 
+	     (setf column (print-one-slot-helper ; print types
1736 
+			   *no-value* column indent T type)))
1737 
+	   (setf printed T))
1738 
+	  ((and values (listp values) (listp (cdr values)))
1739 
+	   (format t "(")
1740 
+	   (dolist (value values)
1741 
+	     (setf printed t)
1742 
+	     (setf column (print-one-slot-helper value column indent
1743 
+						 (> number 0) nil))
1744 
+	     (incf number)
1745 
+	     (when (and limit-values (> number limit-values))
1746 
+	       ;; Too many values: use ellipsis form.
1747 
+	       (format t " ...")
1748 
+	       (return nil)))
1749 
+	   (format t ")")
1750 
+	   (when formula
1751 
+	     (format t " . ~S)" valid))
1752 
+	   (when type
1753 
+	     (print-one-slot-helper	; print out type
1754 
+	      *no-value* column indent nil type)))
1755 
+	  ((null values)
1756 
+	   (if formula
1757 
+	     (format t "nil . ~S)" valid)
1758 
+	     (format t " NIL"))
1759 
+	   (setf printed T)
1760 
+	   (when type
1761 
+	     (print-one-slot-helper	; print out type
1762 
+	      *no-value* column indent nil type)))
1763 
+	  (t
1764 
+	   (setf printed t)
1765 
+	   (setf column
1766 
+		 (print-one-slot-helper values column indent (not formula) type))
1767 
+	   (when formula
1768 
+	     (format t " . ~S)" valid))))
1769 
+    (if printed
1770 
+      (terpri)
1771 
+      (format t " NIL~%"))))
1772 
+
1773 
+
1774 
+(defun ps (schema &key (control t) inherit (indent 0) types-p all-p
1775 
+		  (stream *standard-output*))
1776 
+  "PS prints the <schema>.  The optional arguments allow fancy control of
1777 
+  what is printed.
1778 
+
1779 
+  A control schema may be used to determine which options are printed, which
1780 
+  ones are ignored, etc.  See the manual for details.
1781 
+
1782 
+  <control> can be one of the following:
1783 
+ -  T, which means that the <schema> itself is used as the control schema;
1784 
+ -  :DEFAULT, which means that the schema KR:PRINT-SCHEMA-CONTROL is used;
1785 
+ -  any schema, which is used as the control schema.
1786 
+ -  NIL, which means that the <schema> is printed in its entirety (i.e. no
1787 
+    schema control.)
1788 
+
1789 
+  If <inherit> is non-nil, slots that have been inherited are also printed.
1790 
+  <indent> is used for debugging and should not be set by the user."
1791 
+
1792 
+  (let ((*standard-output* stream))
1793 
+    (call-on-ps-slots schema 'SLOT-PRINTER
1794 
+		      :control control :inherit inherit :indent indent
1795 
+		      :types-p types-p :all-p all-p)
1796 
+    (when (formula-p schema)
1797 
+      (print-meta schema)))
1798 
+  schema)
1799 
+
1800 
+
1801 
+(defun the-bits (bits)
1802 
+  (if (integerp bits)
1803 
+      ;; The normal case
1804 
+      (let ((type (extract-type-code bits)))
1805 
+	(format t "~:[-~;p~]~:[-~;l~]~:[-~;C~]~:[-~;P~]~:[-~;u~]~:[-~;i~] "
1806 
+		(is-parameter bits) (is-local-only bits)
1807 
+		(is-constant bits) (is-parent bits)
1808 
+		(is-update-slot bits) (is-inherited bits))
1809 
+	(unless (zerop type)
1810 
+	  (format t "[~(~S~)]   " (code-to-type type))))
1811 
+      ;; A special case for formula slots which are stored in a special way
1812 
+      (format t "---- ")))
1813 
+
1814 
+
1815 
+(defun full-normal-slot (schema slot)
1816 
+  "Helper function for FULL."
1817 
+  (format t "~(~24S~) " slot)
1818 
+  (let* ((entry (slot-accessor schema slot))
1819 
+	 (values (if entry (sl-value entry)))
1820 
+	 (bits (if entry (sl-bits entry)))
1821 
+	 (dependents (slot-dependents entry)))
1822 
+    (the-bits bits)
1823 
+    (if entry
1824 
+	;; Slot is there
1825 
+	(let ((first t))
1826 
+	  (when (eq values *no-value*)
1827 
+	    (setf values NIL))
1828 
+	  (if (and (listp values) (listp (cdr values)))
1829 
+	      (when values
1830 
+		(format t " (")
1831 
+		(dolist (value values)
1832 
+		  (if first
1833 
+		      (setf first nil)
1834 
+		      (write-string " "))
1835 
+		  (print-one-value value NIL))
1836 
+		(format t ")"))
1837 
+	      (progn
1838 
+		(write-string " ")
1839 
+		(print-one-value values NIL)))
1840 
+	  ;; Show dependent formulas, if any
1841 
+	  (when dependents
1842 
+	    (format t "   ****--> ")
1843 
+	    (do-one-or-list (f dependents)
1844 
+	      (format t " ~s" f)))
1845 
+	  (terpri))
1846 
+	;; No slot???
1847 
+	(terpri)))
1848 
+  (values))
1849 
+
1850 
+
1851 
+(defun full (&rest schemata)
1852 
+  "Internal debugging - print out schemata in gory detail."
1853 
+  (dolist (schema schemata)
1854 
+    (when (numberp schema)
1855 
+      (setf schema (s schema)))
1856 
+    (let ((is-formula (a-formula-p schema)))
1857 
+      ;; use iterators to get inherited slots as well
1858 
+      (if is-formula
1859 
+	  ;; This is a formula
1860 
+	  (progn
1861 
+	    (format
1862 
+	     t "---------------------------------------------- formula ~S~%"
1863 
+	     schema)
1864 
+	    ;; print special formula slots.
1865 
+	    (format t "Schema, slot:           ~S  ~S~%"
1866 
+		    (on-schema schema) (on-slot schema))
1867 
+	    (format t "Cached value:           (~S . ~S)~%"
1868 
+		    (cached-value schema) (a-formula-number schema))
1869 
+	    (format t "Depends on:             ~S~%"
1870 
+		    (a-formula-depends-on schema))
1871 
+	    (format t "Lambda:                 ~(~S~)~%"
1872 
+		    (a-formula-lambda schema))
1873 
+	    (when (a-formula-is-a schema)
1874 
+	      (format t
1875 
+		      "parent formula:         ~S~%"
1876 
+		      (a-formula-is-a schema)))
1877 
+	    (when (a-formula-is-a-inv schema)
1878 
+	      (format t "children:               ~S~%"
1879 
+		      (a-formula-is-a-inv schema)))
1880 
+	    (print-meta schema))
1881 
+	  ;; This is a normal slot
1882 
+	  (progn
1883 
+	    (format
1884 
+	     t "---------------------------------------------- schema ~S~%"
1885 
+	     schema)
1886 
+	    (iterate-slot-value (schema T T nil)
1887 
+	      value ;; eliminate warning
1888 
+	      (full-normal-slot schema slot))))))
1889 
+  (values))
1890 
+
1891 
+
1892 
+
1893 
+;;; O-O PROGRAMMING
1894 
+
1895 
+
1896 
+(defun find-parent (schema slot)
1897 
+  "Find a parent of <schema> from which the <slot> can be inherited."
1898 
+  (dolist (relation *inheritance-relations*)
1899 
+    (dolist (a-parent (if (eq relation :is-a)
1900 
+			  (get-local-value schema :IS-A)
1901 
+			  (get-local-value schema relation)))
1902 
+      (when a-parent
1903 
+	(let ((value (g-local-value a-parent slot)))
1904 
+	  (if value
1905 
+	      (return-from find-parent (values value a-parent))
1906 
+	      (multiple-value-bind (value the-parent)
1907 
+		  (find-parent a-parent slot)
1908 
+		(when value
1909 
+		  (return-from find-parent (values value the-parent))))))))))
1910 
+
1911 
+
1912 
+(defun old-kr-send-function (schema slot &rest args)
1913 
+  "Same as KR-SEND, but as a function."
1914 
+  (let ((the-function (g-value schema slot)))
1915 
+    (when the-function
1916 
+      ;; Bind these in case call prototype method is used.
1917 
+      (let ((*kr-send-self* schema)
1918 
+	    (*kr-send-slot* slot)
1919 
+	    (*demons-disabled* T))
1920 
+	(apply the-function args)))))
1921 
+
1922 
+
1923 
+(defun kr-call-initialize-method (schema slot)
1924 
+  "This is similar to kr-send-function, except that it is careful NOT to
1925 
+inherit the method, which is only used once.  This is to reduce unnecessary
1926 
+storage in every object."
1927 
+  (let ((the-function (g-value-no-copy schema slot)))
1928 
+    (when the-function
1929 
+      ;; Bind these in case call prototype method is used.
1930 
+      (let ((*kr-send-self* schema)
1931 
+	    (*kr-send-slot* slot)
1932 
+	    (*kr-send-parent* NIL)
1933 
+	    (*demons-disabled* T))
1934 
+	(funcall the-function schema)))))
1935 
+
1936 
+
1937 
+(defun kr-init-method (schema the-function)
1938 
+  "Similar, but even more specialized.  It is only called by create-schema
1939 
+and friends, which know whether an :initialize method was specified locally."
1940 
+  (let ((*kr-send-parent* nil))
1941 
+    (if the-function
1942 
+      (setf *kr-send-parent* schema)
1943 
+      (multiple-value-setq (the-function *kr-send-parent*)
1944 
+	(find-parent schema :INITIALIZE)))
1945 
+    (when the-function
1946 
+      ;; Bind these in case call prototype method is used.
1947 
+      (let ((*kr-send-self* schema)
1948 
+	    (*kr-send-slot* :INITIALIZE)
1949 
+            (*kr-send-parent* NIL)
1950 
+	    #-(and) (*demons-disabled* T))
1951 
+	(funcall the-function schema)))))
1952 
+
1953 
+
1954 
+(defun call-prototype-function (&rest args)
1955 
+  "Functional version of CALL-PROTOTYPE-METHOD."
1956 
+  (let (parent)
1957 
+    (if (get-local-value *kr-send-self* *kr-send-slot*)
1958 
+	(setf parent *kr-send-self*)
1959 
+	(multiple-value-bind (method real-parent)
1960 
+			     (find-parent *kr-send-self* *kr-send-slot*)
1961 
+	  (declare (ignore method))
1962 
+	  (setf parent real-parent)))
1963 
+    (multiple-value-bind (function- the-parent)
1964 
+			 (find-parent parent *kr-send-slot*)
1965 
+      (when function-
1966 
+	(let ((*kr-send-self* the-parent)
1967 
+	      (*kr-send-parent* NIL))
1968 
+	  (apply function- args))))))
1969 
+
1970 
+;;; Schemas
1971 
+
1972 
+(defun allocate-schema-slots (schema)
1973 
+  (locally (declare #.*special-kr-optimization*)
1974 
+    (setf (schema-bins schema)
1975 
+	  (make-hash-table :test #'eq #+sbcl :synchronized #+sbcl t)))
1976 
+  schema)
1977 
+
1978 
+
1979 
+(defun make-a-new-schema (name)
1980 
+  "Creates a schema with the given <name>, making sure to destroy the old
1981 
+one by that name if it exists.  The initial number of slots is
1982 
+<needed-slots>."
1983 
+  (locally (declare #.*special-kr-optimization*)
1984 
+    (when (keywordp name)
1985 
+      (setf name (symbol-name name)))
1986 
+    (cond ((null name)
1987 
+	   ;; An unnamed schema.
1988 
+	   (let ((schema (make-schema)))
1989 
+	     (setf *schema-counter* (1+ *schema-counter*))
1990 
+	     (setf (schema-name schema) *schema-counter*)
1991 
+	     (allocate-schema-slots schema)
1992 
+	     schema))
1993 
+
1994 
+	  ((stringp name)
1995 
+	   ;; This clause must precede the next!
1996 
+	   (let ((schema (make-schema)))
1997 
+	     (allocate-schema-slots schema)
1998 
+	     (setf (schema-name schema) name)
1999 
+	     schema))
2000 
+
2001 
+	  ;; Is this an existing schema?  If so, destroy the old one and its
2002 
+	  ;; children.
2003 
+	  ((and (boundp name)
2004 
+		(symbolp name))
2005 
+	   (let ((schema (symbol-value name)))
2006 
+	     (if (is-schema schema)
2007 
+		 (progn
2008 
+		   (recursive-destroy-schema schema 0)
2009 
+		   (allocate-schema-slots schema))
2010 
+		 (progn
2011 
+		   (setf schema (make-schema))
2012 
+		   (allocate-schema-slots schema)
2013 
+		   (eval `(defvar ,name))))
2014 
+	     ;; Assign the new schema as the value of the variable <name>.
2015 
+	     (setf (schema-name schema) name)
2016 
+	     (set name schema)))
2017 
+
2018 
+	  ((symbolp name)
2019 
+	   (eval `(defvar ,name))
2020 
+	   (let ((schema (make-schema)))
2021 
+	     (allocate-schema-slots schema)
2022 
+	     (setf (schema-name schema) name)
2023 
+	     (set name schema)))
2024 
+	  (t
2025 
+	   (format t "Error in CREATE-SCHEMA - ~S is not a valid schema name.~%"
2026 
+		   name)))))
2027 
+
2028 
+
2029 
+;;; Constant slots
2030 
+
2031 
+
2032 
+(defun process-one-constant (schema slot)
2033 
+  "The <slot> in <schema> was declared constant."
2034 
+  ;; set slot information
2035 
+  (let ((entry (slot-accessor schema slot)))
2036 
+    (if (null entry)
2037 
+	;; Slot is not present - create it, mark constant.
2038 
+	(set-slot-accessor schema slot *no-value* *constant-mask* nil)
2039 
+	;; Slot is present
2040 
+	(setf (sl-bits entry) (logior *constant-mask* (sl-bits entry))))))
2041 
+
2042 
+
2043 
+(defun declare-constant (schema slot)
2044 
+  "Declare slot constants AFTER instance creation time."
2045 
+  (unless *constants-disabled*
2046 
+    (if (eq slot T)
2047 
+      ;; This means that all constants declared in :MAYBE-CONSTANT should be
2048 
+      ;; made constant
2049 
+      (let ((maybe (g-value-no-copy schema :MAYBE-CONSTANT)))
2050 
+	(dolist (m maybe)
2051 
+	  (declare-constant schema m)))
2052 
+      ;; This is the normal case - only 1 slot.
2053 
+      (let ((constant-list (g-value schema :CONSTANT))
2054 
+	    (positive T))
2055 
+	(do ((list constant-list (if (listp list) (cdr list) NIL))
2056 
+	     (prev nil list)
2057 
+	     c)
2058 
+	    ((null list)
2059 
+	     (setf constant-list (cons slot (if (listp constant-list)
2060 
+					      constant-list
2061 
+					      (list constant-list))))
2062 
+	     (s-value schema :CONSTANT constant-list)
2063 
+	     (process-one-constant schema slot))
2064 
+	  (setf c (if (listp list) (car list) list))
2065 
+	  (cond ((eq c :EXCEPT)
2066 
+		 (setf positive NIL))
2067 
+		((eq c slot)
2068 
+		 (when positive
2069 
+		   ;; Slot is already marked constant, so there's nothing
2070 
+		   ;; to do.
2071 
+		   (process-one-constant schema slot)
2072 
+		   (return nil))
2073 
+		 ;; Slot was explicitly excepted from constant list.
2074 
+		 (setf (cdr prev) (cddr prev)) ; remove from :EXCEPT
2075 
+		 (when (and (null (cdr prev))
2076 
+			    (eq (car prev) :EXCEPT))
2077 
+		   ;; We are removing the last exception to the constant list
2078 
+		   (let ((end (nthcdr (- (length constant-list) 2)
2079 
+				      constant-list)))
2080 
+		     (setf (cdr end) nil)))
2081 
+		 (setf constant-list (cons c constant-list))
2082 
+		 (s-value schema :CONSTANT constant-list)
2083 
+		 (process-one-constant schema slot)
2084 
+		 (return))))))))
2085 
+
2086 
+
2087 
+(defun merge-prototype-values (object slot parents values)
2088 
+  "Process declarations such as :DECLARE (:PARAMETERS T :EXCEPT :WIDTH),
2089 
+which modify the prototype's specification of a declaration by adding or
2090 
+removing new slot names."
2091 
+  (unless values
2092 
+    (setf values (when parents (g-value (car parents) slot))))
2093 
+  (let ((exceptions nil)
2094 
+	(add-prototype nil)
2095 
+	(results nil))
2096 
+    ;; process declarations
2097 
+    (when (and values (not (eq values :NONE)))
2098 
+      (if (listp values)
2099 
+	  (progn
2100 
+	    (if (eq (car values) 'QUOTE)
2101 
+		(format
2102 
+		 t "The ~S list for schema ~S is specified incorrectly - too many quotes:~%   ~S~%" slot object values))
2103 
+	    ;; Normal case - a list
2104 
+	    (do ((c values (cdr c)))
2105 
+		((null c))
2106 
+	      (cond ((eq (car c) T)
2107 
+		     (setf add-prototype T))
2108 
+		    ((eq (car c) :EXCEPT) ; following is list of exceptions.
2109 
+		     (setf exceptions (cdr c))
2110 
+		     (return))
2111 
+		    (t
2112 
+		     (if (eq slot :CONSTANT)
2113 
+			 (process-one-constant object (car c))
2114 
+			 (pushnew (car c) results))))))
2115 
+	  ;; For the case (:CONSTANT T), for example - single value
2116 
+	  (if (eq values T)
2117 
+	      (setf add-prototype T)
2118 
+	      (if (eq slot :CONSTANT)
2119 
+		  (process-one-constant object values)
2120 
+		  (setf results (list values)))))
2121 
+      (when add-prototype			; Add slots declared in prototype
2122 
+	(let ((maybe-constant
2123 
+	       (if (eq slot :CONSTANT)
2124 
+		   (g-value-no-copy object :MAYBE-CONSTANT)
2125 
+		   (g-value (car parents) slot))))
2126 
+	  (do-one-or-list (c maybe-constant)
2127 
+	    (unless (memberq c exceptions)
2128 
+	      (if (eq slot :CONSTANT)
2129 
+		  (process-one-constant object c)
2130 
+		  (pushnew c results))))))
2131 
+      (unless (eq slot :CONSTANT)
2132 
+	(setf results (nreverse results))
2133 
+	(unless (equal results values)
2134 
+	  (s-value object slot results))))))
2135 
+
2136 
+
2137 
+(defun process-constant-slots (the-schema parents constants do-types)
2138 
+  "Process local-only and constant declarations."
2139 
+  (locally (declare #.*special-kr-optimization*)
2140 
+    ;; Install all update-slots entries, and set their is-update-slot bits
2141 
+    (dolist (slot (g-value-no-copy the-schema :UPDATE-SLOTS))
2142 
+      (let ((entry (slot-accessor the-schema slot)))
2143 
+	(if entry
2144 
+	    (setf (sl-bits entry) (set-is-update-slot (sl-bits entry)))
2145 
+	    (set-slot-accessor the-schema slot *no-value*
2146 
+			       (set-is-update-slot *local-mask*)
2147 
+			       NIL))))
2148 
+    ;; Mark the local-only slots.
2149 
+    (dolist (parent parents)
2150 
+      (dolist (local (g-value-no-copy parent :LOCAL-ONLY-SLOTS))
2151 
+	(unless (listp local)
2152 
+	  (cerror "Ignore the declaration"
2153 
+		  "create-instance (object ~S, parent ~S):  :local-only-slots
2154 
+declarations should consist of lists of the form (:slot T-or-NIL).  Found
2155 
+the expression ~S instead."
2156 
+		  the-schema parent local)
2157 
+	  (return))
2158 
+	;; Set the slots marked as local-only
2159 
+	(let ((slot (car local)))
2160 
+	  (unless (slot-accessor the-schema slot)
2161 
+	    (if (second local)
2162 
+		;; Copy down the parent value, once and for all.
2163 
+		(let* ((entry (slot-accessor parent slot))
2164 
+		       (value (if entry (sl-value entry))))
2165 
+		  (unless (formula-p value)
2166 
+		    ;; Prevent inheritance from ever happening
2167 
+		    (internal-s-value the-schema slot (g-value parent slot))))
2168 
+		;; Avoid inheritance and set the slot to NIL.
2169 
+		(internal-s-value the-schema slot NIL))))))
2170 
+    ;; Now process constant declarations.
2171 
+    (unless *constants-disabled*
2172 
+      (merge-prototype-values the-schema :CONSTANT parents constants))
2173 
+    ;; Now process type declarations
2174 
+    (when (and do-types *types-enabled*)
2175 
+      ;; Copy type declarations down from the parent(s), unless overridden
2176 
+      ;; locally.
2177 
+      (dolist (parent parents)
2178 
+	(iterate-slot-value (parent T T nil)
2179 
+	  value						 ;; suppress warning
2180 
+	  (let ((bits (sl-bits iterate-slot-value-entry))) ; get parent's bits
2181 
+	    ;; keep only the type information
2182 
+	    (setf bits (logand bits *type-mask*))
2183 
+	    (unless (zerop bits)
2184 
+	      (let ((the-entry (slot-accessor the-schema slot)))
2185 
+		(if the-entry
2186 
+		    (let ((schema-bits (sl-bits the-entry)))
2187 
+		      (when (zerop (extract-type-code schema-bits))
2188 
+			;; Leave type alone, if one was declared locally.
2189 
+			(setf (sl-bits the-entry)
2190 
+			      (logior (logand schema-bits *all-bits-mask*)
2191 
+				      bits))))
2192 
+		    (set-slot-accessor the-schema slot *no-value* bits NIL)))))))
2193 
+      ;; Typecheck
2194 
+      (iterate-slot-value (the-schema T T nil)
2195 
+	(unless (eq value *no-value*)
2196 
+	  (unless (formula-p value)	; don't bother with formulas.
2197 
+	    (multiple-value-bind (new-value result)
2198 
+		(check-slot-type the-schema slot value)
2199 
+	      (when (eq result :REPLACE)
2200 
+		(s-value the-schema slot new-value)))))))))
2201 
+
2202 
+
2203 
+(defun add-update-slot (schema slot &optional turn-off)
2204 
+  "Turn the <slot> of the <schema> into an :update-slot; add the <slot> to
2205 
+the contents of :update-slots, and turn on the internal bit.  If
2206 
+<turn-off> is T, make the <slot> be no longer an update slot."
2207 
+  (let ((entry (slot-accessor schema slot)))
2208 
+    (if entry
2209 
+      ;; There is an entry - manipulate the bits directly
2210 
+      (if turn-off
2211 
+	;; Turn bit off
2212 
+	(setf (sl-bits entry) (logand (sl-bits entry)
2213 
+				      (lognot *is-update-slot-mask*)))
2214 
+	;; Turn bit on
2215 
+	(setf (sl-bits entry) (set-is-update-slot (sl-bits entry))))
2216 
+      ;; There is no entry
2217 
+      (unless turn-off
2218 
+	(set-slot-accessor schema slot *no-value*
2219 
+			   (set-is-update-slot *local-mask*)
2220 
+			   NIL))))
2221 
+  (if turn-off
2222 
+    (setf (g-value schema :UPDATE-SLOTS)
2223 
+	  (delete slot (g-value schema :UPDATE-SLOTS)))
2224 
+    (pushnew slot (g-value schema :UPDATE-SLOTS))))
2225 
+
2226 
+
2227 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2228 
+  (defun cannot-be-quoted (value)
2229 
+    (or (listp value)
2230 
+	(and (symbolp value)
2231 
+	     (not (keywordp value))))))
2232 
+
2233 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2234 
+  (defun process-slot-descriptor (x)
2235 
+    (if (listp x)
2236 
+	(if (find-if #'cannot-be-quoted (cdr x))
2237 
+	    (cons 'list x)
2238 
+	    `',x)
2239 
+	x)))
2240 
+
2241 
+(defun merge-declarations (declaration keyword output)
2242 
+  (let ((old (find keyword output :key #'second)))
2243 
+    (if old
2244 
+	(setf (cadr (third old)) (union (cdr declaration)
2245 
+					(cadr (third old))))
2246 
+	(push `(cons ,keyword ',(cdr declaration)) output)))
2247 
+  output)
2248 
+
2249 
+
2250 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2251 
+  (defun process-slots (slots)
2252 
+    "This function processes all the parameters of CREATE-INSTANCE and returns
2253 
+an argument list suitable for do-schema-body.  It is called at compile time.
2254 
+
2255 
+RETURNS: a list, with elements as follows:
2256 
+ - FIRST: the prototype (or list of prototypes), or NIL;
2257 
+ - SECOND: the list of type declarations, in the form (type slot slot ...)
2258 
+   or NIL (if there were no type declarations) or :NONE (if the declaration
2259 
+   (type) was used, which explicitly turns off all types declared in the
2260 
+   prototype(s).
2261 
+ - REST OF THE LIST: all slot specifiers, with :IS-A removed (because that
2262 
+   information is moved to the prototype list)."
2263 
+    (let ((output nil)
2264 
+	  (is-a nil))
2265 
+      (do ((head slots (cdr head))
2266 
+	   (types nil)
2267 
+	   (had-types nil)		; true if there is a declaration
2268 
+	   slot)
2269 
+	  ((null head)
2270 
+	   (if types
2271 
+	       (push `(quote ,types) output)
2272 
+	       (if had-types
2273 
+		   (push :NONE output)
2274 
+		   (push NIL output))))
2275 
+	(setf slot (car head))
2276 
+	(cond ((null slot)
2277 
+	       ;; This is an error.
2278 
+	       (cerror
2279 
+		"Ignore the specification"
2280 
+		"Error in CREATE-SCHEMA: NIL is not a valid slot ~
2281 
+		 specifier; ignored.~%~
2282 
+	         Object ~S, slot specifiers are ~S~%"
2283 
+		kr::*create-schema-schema* head))
2284 
+	      ((keywordp slot)
2285 
+	       ;; Process declarations and the like.
2286 
+	       (case slot
2287 
+		 (:NAME-PREFIX
2288 
+		  (pop head))
2289 
+		 (:DECLARE
2290 
+		  (pop head)
2291 
+		  (dolist (declaration (if (listp (caar head))
2292 
+					   (car head)
2293 
+					   (list (car head))))
2294 
+		    (case (car declaration)
2295 
+		      (:TYPE
2296 
+		       (setf had-types T)
2297 
+		       (dolist (spec (cdr declaration))
2298 
+			 (push spec types)))
2299 
+		      ((:CONSTANT :IGNORED-SLOTS :LOCAL-ONLY-SLOTS
2300 
+				  :MAYBE-CONSTANT :PARAMETERS :OUTPUT
2301 
+				  :SORTED-SLOTS :UPDATE-SLOTS)
2302 
+		       (setf output (merge-declarations declaration
2303 
+							(car declaration)
2304 
+							output)))
2305 
+		      (t
2306 
+		       (cerror
2307 
+			"Ignore the declaration"
2308 
+			"Unknown declaration (~S) in object creation:~%~S~%"
2309 
+			(car declaration)
2310 
+			declaration)))))))
2311 
+	      ((listp slot)
2312 
+	       ;; Process slot descriptors.
2313 
+	       (if (eq (car slot) :IS-A)
2314 
+		   (setf is-a (if (cddr slot)
2315 
+				  `(list ,@(cdr slot))
2316 
+				  (cadr slot)))
2317 
+		   (if (listp (cdr slot))
2318 
+		       (if (find-if #'cannot-be-quoted (cdr slot))
2319 
+			   (if (cddr slot)
2320 
+			       (push `(list ,(car slot) . ,(cdr slot)) output)
2321 
+			       (push `(cons ,(car slot) . ,(cdr slot)) output))
2322 
+			   (if (cddr slot)
2323 
+			       (push `'(,(car slot) . ,(cdr slot)) output)
2324 
+			       (push `'(,(car slot) . ,(cadr slot)) output)))
2325 
+		       (push (cdr slot) output))))
2326 
+	      (T
2327 
+	       (cerror
2328 
+		"Ignore the specification"
2329 
+		"A slot specification should be of the form ~
2330 
+		 (:name [values]*) ;~%found ~S instead.  Object ~S, slots ~S."
2331 
+		slot kr::*create-schema-schema* slots))))
2332 
+      (cons is-a output))))
2333 
+
2334 
+
2335 
+(defun handle-is-a (schema is-a generate-instance override)
2336 
+  (if (or (eq schema is-a)
2337 
+	  (memberq schema is-a))
2338 
+      (format t "~A: cannot make ~S an instance of itself!  ~
2339 
+    			Using NIL instead.~%"
2340 
+	      (if generate-instance
2341 
+		  "CREATE-INSTANCE" "CREATE-SCHEMA")
2342 
+	      schema)
2343 
+      ;; Make sure :override does not duplicate is-a-inv contents.
2344 
+      (let ((*schema-is-new* (not override)))
2345 
+	(set-is-a schema is-a))))
2346 
+
2347 
+
2348 
+(defun do-schema-body (schema is-a generate-instance do-constants override
2349 
+		       types &rest slot-specifiers)
2350 
+  "Create-schema and friends expand into a call to this function."
2351 
+  (when (equal is-a '(nil))
2352 
+    (format
2353 
+     t
2354 
+     "*** (create-instance ~S) called with an illegal (unbound?) class name.~%"
2355 
+     schema)
2356 
+    (setf is-a NIL))
2357 
+  (unless (listp is-a)
2358 
+    (setf is-a (list is-a)))
2359 
+  (when is-a
2360 
+    (let ((*schema-is-new* T))	      ; Bind to prevent search on insertion
2361 
+				      ; of :is-a-inv in parent schemata.
2362 
+      ;; Check for immediate is-a loop, and set the :IS-A slot.
2363 
+      (handle-is-a schema is-a generate-instance override)))
2364 
+
2365 
+  (do* ((slots slot-specifiers (cdr slots))
2366 
+	(slot (car slots) (car slots))
2367 
+	(initialize-method NIL)
2368 
+	(constants NIL)
2369 
+	(had-constants NIL)		; true if declared, including NIL
2370 
+	(cancel-constants (find '(:constant) slot-specifiers :test #'equal))
2371 
+	(parent (car is-a))
2372 
+	(slot-counter (if is-a 1 0)))
2373 
+
2374 
+       ((null slots)
2375 
+	;; Process the type declarations.
2376 
+	(unless (eq types :NONE)
2377 
+	  (dolist (type types)
2378 
+	    (if (cdr type)
2379 
+		(let ((n (encode-type (car type))))
2380 
+		  (dolist (slot (cdr type))
2381 
+		    (set-slot-type schema slot n)))
2382 
+		(format t "*** ERROR - empty list of slots in type declaration ~
2383 
+                          for object ~S:~%  ~S~%" schema (car type)))))
2384 
+	;; Process the constant declarations, and check the types.
2385 
+	(when do-constants
2386 
+	  (process-constant-slots
2387 
+	   schema is-a
2388 
+	   (if had-constants
2389 
+	       ;; There WAS a constant declaration, perhaps NIL.
2390 
+	       (if constants
2391 
+		   (if (formula-p constants)
2392 
+		       (g-value-formula-value schema :CONSTANT constants NIL)
2393 
+		       constants)
2394 
+		   :NONE)
2395 
+	       ;; There was no constant declaration.
2396 
+	       NIL)
2397 
+	   (not (eq types :NONE))))
2398 
+	;; Merge prototype and local declarations.
2399 
+	(dolist (slot slot-specifiers)
2400 
+	  (when (and (listp slot)
2401 
+		     (memberq (car slot)
2402 
+			      '(:IGNORED-SLOTS :LOCAL-ONLY-SLOTS
2403 
+				:MAYBE-CONSTANT :PARAMETERS :OUTPUT
2404 
+				:SORTED-SLOTS :UPDATE-SLOTS)))
2405 
+	    (merge-prototype-values schema (car slot) is-a (cdr slot))))
2406 
+	(when generate-instance
2407 
+	  ;; We are generating code for a CREATE-INSTANCE, really.
2408 
+	  (kr-init-method schema initialize-method))
2409 
+	schema)
2410 
+
2411 
+    (cond ((eq slot :NAME-PREFIX)
2412 
+	   ;; Skip this and the following argument
2413 
+	   (pop slots))
2414 
+	  ((consp slot)
2415 
+	   (let ((slot-name (car slot))
2416 
+		 (slot-value (cdr slot)))
2417 
+	     (case slot-name		; handle a few special slots.
2418 
+	       (:INITIALIZE
2419 
+		(when slot-value
2420 
+		  ;; A local :INITIALIZE method was provided
2421 
+		  (setf initialize-method slot-value)))
2422 
+	       (:CONSTANT
2423 
+		(setf constants (cdr slot))
2424 
+		(setf had-constants T)))
2425 
+	     ;; Check that the slot is not declared constant in the parent.
2426 
+	     (when (and (not cancel-constants) (not *constants-disabled*)
2427 
+			(not *redefine-ok*))
2428 
+	       (when (and parent (slot-constant-p parent slot-name))
2429 
+		 (cerror
2430 
+		  "If continued, the value of the slot will change anyway"
2431 
+		  "Slot ~S in ~S was declared constant in prototype ~S!~%"
2432 
+		  slot-name schema (car is-a))))
2433 
+	     (if override
2434 
+		 ;; This is more costly - check whether the slot already exists,
2435 
+		 ;; dependencies, etc.
2436 
+		 (s-value schema slot-name slot-value)
2437 
+		 ;; No check needed in this case.
2438 
+		 (setf slot-counter
2439 
+		       (internal-s-value schema slot-name slot-value)))))
2440 
+	  (T
2441 
+	   (format t "Incorrect slot specification: object ~S ~S~%"
2442 
+		   schema slot)))))
2443 
+
2444 
+
2445 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2446 
+  (defun creation-message (name)
2447 
+    (when *print-new-instances*
2448 
+      (when (and (listp name)
2449 
+		 (eq (car name) 'QUOTE))
2450 
+	(format *standard-output* "~&Object ~S~%" (eval name))))))
2451 
+
2452 
+
2453 
+(defun end-create-instance (schema)
2454 
+  "Processes the second half of a create-instance.  Begin-create-instance must
2455 
+have been called on the <schema>."
2456 
+  (process-constant-slots schema (get-local-value schema :IS-A)
2457 
+			  (get-local-value schema :CONSTANT)
2458 
+			  nil)
2459 
+  (kr-init-method schema (get-local-value schema :INITIALIZE)))
2460 
+
2461 
+
2462 
+;;; TYPE CHECKING
2463 
+
2464 
+(declaim (inline get-slot-type-code))
2465 
+(defun get-slot-type-code (object slot)
2466 
+  (let ((entry (slot-accessor object slot)))
2467 
+    (and entry
2468 
+	 (get-entry-type-code entry))))
2469 
+
2470 
+
2471 
+(declaim (inline g-type))
2472 
+(defun g-type (object slot)
2473 
+  (let ((type (get-slot-type-code object slot)))
2474 
+    (and type
2475 
+	 (code-to-type type))))
2476 
+
2477 
+
2478 
+(defun check-slot-type (object slot value &optional (error-p T) entry)
2479 
+  "Check whether <value> has the right type for the <slot> in the <object>.
2480 
+
2481 
+RETURNS:
2482 
+ if error-p is non-nil: multiple values:
2483 
+ - a replacement value, if the user chose to continue and supply a
2484 
+   replacement;  T if no error;  NIL otherwise;
2485 
+ - T (if type error and the user did not supply a value), or
2486 
+   NIL (if there was no type error), or
2487 
+   :REPLACE, if a replacement value was supplied by the user.
2488 
+ if error-p is nil:
2489 
+ an error string describing what error condition was found.
2490 
+"
2491 
+  (let ((type-code (if entry
2492 
+		       (get-entry-type-code entry)
2493 
+		       (get-slot-type-code object slot))))
2494 
+    (or (null type-code)
2495 
+        (zerop type-code)
2496 
+	(check-kr-type value type-code)
2497 
+	(let* ((type (code-to-type type-code))
2498 
+	       (readable-type (get-type-documentation type))
2499 
+	       (message
2500 
+		(format
2501 
+		 nil
2502 
+		 "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.~]~%"
2503 
+		 value value (type-of value)
2504 
+		 slot object type
2505 
+		 readable-type
2506 
+		 (formula-p (get-local-value object slot)))))
2507 
+	  (if error-p
2508 
+	      (progn
2509 
+		(cerror "Retain old value in the slot" message)
2510 
+		(values T T))
2511 
+	      message)))))
2512 
+
2513 
+
2514 
+;; This version allows multiple restart actions.  However, it is extremely
2515 
+;; slow and sets up a ton of garbage (Cons space and Other space).  It should
2516 
+;; not be used for common operations, such as s-value.
2517 
+;;
2518 
+;;; (defun check-slot-type (object slot value &optional (error-p T))
2519 
+;;;   (loop
2520 
+;;;    (restart-case
2521 
+;;;     (return
2522 
+;;;       (let ((type (get-slot-type-code object slot)))
2523 
+;;; 	(if type
2524 
+;;; 	  (if (zerop type)
2525 
+;;; 	    (values T NIL)		; no type specified
2526 
+;;; 	    (if (check-kr-type value type)
2527 
+;;; 	      (values T NIL)
2528 
+;;; 	      (let* ((readable-type (get-type-documentation type))
2529 
+;;; 		     (message
2530 
+;;; 		      (format
2531 
+;;; 		       nil
2532 
+;;; 		       "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.~]~%"
2533 
+;;; 		       value value (type-of value) slot object
2534 
+;;; 		       (code-to-type type)
2535 
+;;; 		       readable-type
2536 
+;;; 		       (formula-p (get-value object slot)))))
2537 
+;;; 		(if error-p
2538 
+;;; 		  (error message)
2539 
+;;; 		  message))))
2540 
+;;; 	  (values T NIL))))
2541 
+;;;     ;; Allow the user to specify different continuation strategies if we
2542 
+;;;     ;; get an error and enter the debugger.
2543 
+;;;     (nil (arg)
2544 
+;;; 	 :report "Retain old value in the slot"
2545 
+;;; 	 :interactive (lambda ()
2546 
+;;; 			(list value))
2547 
+;;; 	 arg
2548 
+;;; 	 (return (values NIL T)))
2549 
+;;;     (nil (arg)
2550 
+;;; 	 :report "Enter replacement value for the slot"
2551 
+;;; 	 :interactive (lambda ()
2552 
+;;; 			(format t "New value for ~S slot ~S: " object slot)
2553 
+;;; 			(force-output)
2554 
+;;; 			(list (read)))
2555 
+;;; 	 (multiple-value-bind (new-value result)
2556 
+;;; 	     (check-slot-type object slot arg T)
2557 
+;;; 	   (cond ((null result)
2558 
+;;; 		  ;; no error in replacement value
2559 
+;;; 		  (return (values arg :REPLACE)))
2560 
+;;; 		 ((eq result :REPLACE)
2561 
+;;; 		  (return (values new-value :REPLACE)))))))))
2562 
+
2563 
+
2564 
+(defun set-slot-type (object slot type)
2565 
+  (let ((entry (or (slot-accessor object slot)
2566 
+		   (set-slot-accessor object slot *no-value* type NIL))))
2567 
+    (setf (sl-bits entry)
2568 
+	  (logior (logand (sl-bits entry) *all-bits-mask*) type))))
2569 
+
2570 
+
2571 
+(defun s-type (object slot type &optional (check-p T))
2572 
+  "Adds a type declaration to the given <slot>, eliminating any previous
2573 
+type declarations.  If <check-p> is true, checks whether the value
2574 
+already in the <slot> satisfies the new type declaration."
2575 
+  (set-slot-type object slot (if type
2576 
+			       (encode-type type)
2577 
+			       ;; 0 means "no type declarations"
2578 
+			       0))
2579 
+  (when check-p
2580 
+    (let* ((entry (slot-accessor object slot))
2581 
+	   (value (if entry (sl-value entry))))
2582 
+      (unless (or (eq value *no-value*)
2583 
+		  (formula-p value))
2584 
+	(multiple-value-bind (new-value result)
2585 
+	    (check-slot-type object slot value T entry)
2586 
+	  (cond ((eq result :REPLACE)
2587 
+		 (s-value object slot new-value)))))))
2588 
+  type)
2589 
+
2590 
+
2591 
+
2592 
+;;; DECLARATION ACCESSORS
2593 
+
2594 
+
2595 
+(defun get-declarations (schema declaration)
2596 
+  "RETURNS: a list of all slots in the <schema> which are declared as
2597 
+<declaration>.
2598 
+
2599 
+Example: (get-declarations A :type)"
2600 
+  (let ((slots nil))
2601 
+    (case declaration
2602 
+      (:CONSTANT nil)
2603 
+      (:TYPE nil)
2604 
+      ((:IGNORED-SLOTS :SORTED-SLOTS :MAYBE-CONSTANT
2605 
+		       :PARAMETERS :OUTPUT :UPDATE-SLOTS)
2606 
+       (return-from get-declarations (g-value schema declaration)))
2607 
+      (:LOCAL-ONLY-SLOTS
2608 
+       (return-from get-declarations (g-local-value schema declaration)))
2609 
+      (t
2610 
+       (return-from get-declarations NIL)))
2611 
+    ;; Visit all slots, construct information
2612 
+    (iterate-slot-value (schema T T NIL)
2613 
+      value ;; suppress warning
2614 
+      (let ((bits (sl-bits iterate-slot-value-entry)))
2615 
+	(case declaration
2616 
+	  (:CONSTANT
2617 
+	   (when (is-constant bits)
2618 
+	     (push slot slots)))
2619 
+	  (:TYPE
2620 
+	   (let ((type (extract-type-code bits)))
2621 
+	     (unless (zerop type)
2622 
+	       (push (list slot (code-to-type type)) slots)))))))
2623 
+    slots))
2624 
+
2625 
+
2626 
+(defun get-slot-declarations (schema slot)
2627 
+  (let* ((entry (slot-accessor schema slot))
2628 
+	 (bits (if entry (sl-bits entry) 0))
2629 
+	 (declarations nil))
2630 
+    (if (is-constant bits)
2631 
+      (push :CONSTANT declarations))
2632 
+    (if (memberq slot (g-value schema :update-slots))
2633 
+      (push :UPDATE-SLOTS declarations))
2634 
+    (if (memberq slot (g-value schema :local-only-slots))
2635 
+      (push :LOCAL-ONLY-SLOTS declarations))
2636 
+    (if (memberq slot (g-value schema :maybe-constant))
2637 
+      (push :MAYBE-CONSTANT declarations))
2638 
+    (let ((type (extract-type-code bits)))
2639 
+      (unless (zerop type)
2640 
+	(push (list :type (code-to-type type)) declarations)))
2641 
+    ;; Now process all declarations that are not stored in the slot bits.
2642 
+    (dolist (s-slot '(:IGNORED-SLOTS :PARAMETERS :OUTPUT :SORTED-SLOTS))
2643 
+      (let ((values (g-value schema s-slot)))
2644 
+	(if (memberq slot values)
2645 
+	  (push s-slot declarations))))
2646 
+    declarations))
2647 
+
2648 
+
2649 
+
2650 
+;;; Define support fns for basic builtin types.  These definitions must come
2651 
+;;  before the file CONSTRAINTS.LISP is compiled.
2652 
+
2653 
+
2654 
+(defun T-P (value)
2655 
+  (declare #.*special-kr-optimization*
2656 
+	   (ignore value))
2657 
+  T)
2658 
+
2659 
+(defun no-type-error-p (value)
2660 
+  (cerror "Return T"
2661 
+          "KR typechecking called on value ~S with no type"
2662 
+          value)
2663 
+  T)
2664 
+
2665 
+
2666 
+(defun get-type-definition (type-descriptor)
2667 
+  "Given the symbol which names a KR type (e.g., 'KR-BOOLEAN), this function
2668 
+returns the type expression that was used to define the type.
2669 
+
2670 
+Example:
2671 
+ (base-type-for 'bitmap-or-nil) ==>
2672 
+ (OR NULL (IS-A-P OPAL:BITMAP))
2673 
+"
2674 
+  (let* ((name (if (symbolp type-descriptor) (symbol-name type-descriptor)))
2675 
+	 (code (gethash name kr::types-table)))
2676 
+    (when name
2677 
+      (maphash #'(lambda (key value)
2678 
+		   (when (and (eq value code)
2679 
+			    (not (stringp key)))
2680 
+		       (return-from get-type-definition key)))
2681 
+	       kr::types-table))))
2682 
+
2683 
+
2684 
+
2685 
+;;; FORMULA META-SLOTS
2686 
+
2687 
+(defun find-meta (formula)
2688 
+  "Returns, or inherits, the meta-schema associated with the <formula>, or
2689 
+NIL if none exists."
2690 
+  (let ((meta (a-formula-meta formula)))
2691 
+    (unless meta
2692 
+      ;; Try to inherit the meta-information from the formula's parent(s).
2693 
+      (do ((f (a-formula-is-a formula) (a-formula-is-a f)))
2694 
+	  ((null f))
2695 
+	(if (setf meta (a-formula-meta f))
2696 
+	    ;; Do not copy down the meta-schema, to reduce storage.
2697 
+	    (return))))
2698 
+    meta))
2699 
+
2700 
+
2701 
+(defun g-formula-value (formula slot)
2702 
+  "RETURNS:
2703 
+the value of the meta-slot <slot> in the <formula>, or NIL if none
2704 
+exists.  The value may be inherited from the <formula>'s parent(s), but
2705 
+no new meta-schema is created as a result of this operation."
2706 
+  (when (formula-p formula)
2707 
+    (case slot
2708 
+      (:NUMBER (a-formula-number formula))
2709 
+      (:VALID (cache-is-valid formula))
2710 
+      (:DEPENDS-ON (a-formula-depends-on formula))
2711 
+      (:SCHEMA (a-formula-schema formula))
2712 
+      (:SLOT (a-formula-slot formula))
2713 
+      (:CACHED-VALUE (a-formula-cached-value formula))
2714 
+      (:PATH (a-formula-path formula))
2715 
+      (:IS-A (a-formula-is-a formula))
2716 
+      (:FUNCTION (a-formula-function formula))
2717 
+      (:LAMBDA (a-formula-lambda formula))
2718 
+      (:IS-A-INV (a-formula-is-a-inv formula))
2719 
+      (:META (a-formula-meta formula))
2720 
+      (T
2721 
+       ;; Normal case: this is not a built-in formula slot.  Use meta-slots.
2722 
+       (let ((meta (find-meta formula)))
2723 
+	 (if meta
2724 
+	     (g-value meta slot)))))))
2725 
+
2726 
+
2727 
+(defun s-formula-value (formula slot value)
2728 
+  "Sets the value of the meta-slot <slot> in the <formula> to be <value>.
2729 
+If no meta-schema exists for the <formula>, creates one."
2730 
+  (when (formula-p formula)
2731 
+    (let ((meta (a-formula-meta formula)))
2732 
+      (unless meta
2733 
+	(setf meta (find-meta formula))
2734 
+	(if meta
2735 
+	    ;; We do have a meta-schema that can be inherited.
2736 
+	    (let ((new (create-schema nil)))
2737 
+	      (s-value new :is-a (list meta))
2738 
+	      (setf meta new))
2739 
+	    ;; Create a brand new, non-inheriting meta-schema.
2740 
+	    (setf meta (create-schema nil)))
2741 
+	;; Install the new meta-schema.
2742 
+	(setf (a-formula-meta formula) meta))
2743 
+      (s-value meta slot value))))
2744 
+
2745 
+
2746 
+;;; READER MACROS
2747 
+
2748 
+
2749 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2750 
+  (defun k-reader (stream subchar arg)
2751 
+    "Modify the readtable so #k<NAME> is read as the KR object NAME, if
2752 
+defined.  This allows objects written with the *print-as-structure*
2753 
+notation to be read back in."
2754 
+    (declare (ignore subchar arg))
2755 
+    (let ((next-char (read-char stream)))
2756 
+      (if (char= next-char #\<)
2757 
+	  ;; This is a KR #k<...> object name
2758 
+	  (let ((string ""))
2759 
+	    (do ((c (read-char stream) (read-char stream)))
2760 
+		((char= c #\>))
2761 
+	      (setf string (format nil "~A~C" string c)))
2762 
+	    (setf string (read-from-string string))
2763 
+	    (if (and (boundp string)
2764 
+		     (or (schema-p (symbol-value string))
2765 
+			 (formula-p (symbol-value string))))
2766 
+		(symbol-value string)
2767 
+		(cerror "Ignore the object"
2768 
+			"Non-existing KR object: ~S" string)))
2769 
+	  ;; This is something else
2770 
+	  (cerror
2771 
+	   "Ignore the token"
2772 
+	   "  Illegal character ~S after reader macro #k (expecting \"<\")"
2773 
+	   next-char)))))
2774 
+
2775 
+
2776 
+;; Install this reader macro in the standard readtable.
2777 
+(eval-when (:execute :compile-toplevel :load-toplevel)
2778 
+  (set-dispatch-macro-character #\# #\k (function k-reader)))
2779 
+
2780 
+(defun o-formula-reader (stream subchar arg)
2781 
+  "Modify the readtable to #f(...) is read as (o-formula ...).  For example,
2782 
+this allows you to write
2783 
+(S-VALUE A :LEFT #F(GVL :TOP))"
2784 
+  (declare (ignore subchar arg))
2785 
+  `(o-formula ,(read stream t nil t)))
2786 
+
2787 
+(set-dispatch-macro-character #\# #\f #'o-formula-reader)
package.lisp
History View file @ 6e35003
0 2788 
new file mode 100644
... ... 
@@ -0,0 +1,96 @@
1 
+(in-package :cl-user)
2 
+
3 
+(defpackage :garnet-utils
4 
+  (:use :common-lisp)
5 
+  (:nicknames :gu)
6 
+  (:export *garnet-break-key*
7 
+           2pi -2pi
8 
+           add-to-list
9 
+           black
10 
+           directory-p
11 
+           do2lists
12 
+           dolist2
13 
+           m
14 
+           m1
15 
+           pi/2
16 
+           pi3/2
17 
+           safe-functionp
18 
+           short-pi
19 
+           str
20 
+           string+
21 
+           till
22 
+           until
23 
+           verify-binding
24 
+           white
25 
+           while))
26 
+
27 
+(defpackage :kr-debug
28 
+  (:use :common-lisp))
29 
+
30 
+(defpackage :kr
31 
+  (:use :common-lisp :kr-debug)
32 
+  (:export schema
33 
+           create-instance
34 
+           create-prototype
35 
+           create-relation
36 
+           create-schema
37 
+           formula
38 
+           o-formula
39 
+           schema-p
40 
+           relation-p
41 
+           is-a-p
42 
+           has-slot-p
43 
+           formula-p
44 
+           s-value
45 
+           g-value
46 
+           g-cached-value
47 
+           g-local-value
48 
+           gv
49 
+           gvl
50 
+           gv-local
51 
+           get-value
52 
+           get-local-value
53 
+           dovalues
54 
+           doslots
55 
+           define-method
56 
+           kr-send
57 
+           call-prototype-method
58 
+           apply-prototype-method
59 
+           method-trace
60 
+           *print-as-structure*
61 
+           with-constants-disabled
62 
+           with-types-disabled
63 
+           with-demons-disabled
64 
+           with-demon-disabled
65 
+           with-demon-enabled
66 
+           change-formula
67 
+           move-formula
68 
+           recompute-formula
69 
+           copy-formula
70 
+           kr-path
71 
+           mark-as-changed
72 
+           mark-as-invalid
73 
+           ps
74 
+           call-on-ps-slots
75 
+           name-for-schema
76 
+           declare-constant
77 
+           slot-constant-p
78 
+           destroy-slot
79 
+           destroy-schema
80 
+           destroy-constraint
81 
+           def-kr-type
82 
+           g-type
83 
+           s-type
84 
+           check-slot-type
85 
+           kr-boolean
86 
+           get-slot-doc
87 
+           set-slot-doc
88 
+           get-type-documentation
89 
+           set-type-documentation
90 
+           get-type-definition
91 
+           get-declarations
92 
+           get-slot-declarations
93 
+           g-formula-value
94 
+           s-formula-value
95 
+           self-old-value))
96 
+
utils/README
History View file @ 6e35003
0 97 
new file mode 100644
... ... 
@@ -0,0 +1,86 @@
1 
+
2 
+garnet/src/utils/README
3 
+
4 
+This file describes the Lisp utilities available in the "GARNET-UTILS" package.
5 
+These utilities are supposed to be general-purpose (ie, Garnet-independent).
6 
+While we hope that they are efficient and bug-free, we cannot make any
7 
+guarantees -- USE AT YOUR OWN RISK!  Finally, if you find any improvements
8 
+or reasonable additions to these utilities, we very much welcome your input.
9 
+Please send mail to "garnet-bugs@CS.CMU.EDU".
10 
+
11 
+The rest of this file first lists and then  describes all of the exported
12 
+functions in the "GARNET-UTILS" package, listed in alphabetical order.
13 
+If you add new entries, please follow the established format.
14 
+
15 
+                       ;;;;;;;;;;;;;;;;;;
16 
+                       ;;  Utils List  ;;
17 
+                       ;;;;;;;;;;;;;;;;;;
18 
+
19 
+add-to-list  (element list &optional where locator)
20 
+do2lists     ((var1 list1 var2 list2) &rest body)
21 
+dolist2      ((var1 var2 list) &rest body)
22 
+m            (s-expr)
23 
+m1           (s-expr)
24 
+string+      (&rest args)
25 
+until        (test &rest body)
26 
+while        (test &rest body)
27 
+
28 
+                   ;;;;;;;;;;;;;;;;;;;;;;;;;;
29 
+                   ;;  Utils Descriptions  ;;
30 
+                   ;;;;;;;;;;;;;;;;;;;;;;;;;;
31 
+
32 
+add-to-list (element list &optional where locator)
33 
+
34 
+          This adds <element> to <list> according to the <where>/<locator>
35 
+          specification according to the rules described in Garnet's
36 
+          Opal manual for "add-component".  This can modify destructively.
37 
+          Ex: (add-to-list element list)
38 
+              (add-to-list element list :head) ; or use :front instead of :head
39 
+              (add-to-list element list :tail) ; or use :back  instead of :tail
40 
+              (add-to-list element list :before other-element)
41 
+              (add-to-list element list :after other-element)
42 
+
43 
+do2lists ((var1 list1 var2 list2 &key either?) &rest body)
44 
+
45 
+          This is identical to "dolist", except that it iterates over TWO
46 
+          lists, on each iteration binding <var1> to the first element of
47 
+          <list1> and <var2> to the first element of <list2>.  The default
48 
+          behavior is to exit when *BOTH* lists are empty, but if you specify
49 
+          "either?" as T, then it exits when EITHER list is empty.
50 
+          Ex:  (do2lists (parent parents child children)
51 
+                  (s-value child :parent parent))
52 
+
53 
+dolist2 ((var1 var2 list) &rest body)
54 
+
55 
+          This is identical to "dolist", except that it iterates TWO
56 
+          variables over the list, on each iteration binding <var1> to
57 
+          the first element and <var2> to the second element.
58 
+          Ex:  (dolist2 (slot value '(:left 20 :top 30))
59 
+                 (s-value object slot value))
60 
+
61 
+m (s-expr)
62 
+
63 
+          This is identical to "macroexpand", except that it does not require
64 
+          you to quote the expression, and it pretty-prints the output.
65 
+          Ex: (m (while my-test my-body))
66 
+
67 
+m1 (s-expr)
68 
+
69 
+          This is to "macroexpand-1" as "m" is to "macroexpand".
70 
+          Ex: (m1 (while my-test my-body))
71 
+
72 
+string+ (&rest args)
73 
+
74 
+          String summation -- that is, concatenate the strings together.
75 
+          Ex: (string+ "This" " is " "neat!")
76 
+
77 
+until (test &rest body)
78 
+
79 
+          Execute <body> repeatedly until <test> returns non-NIL.
80 
+          Ex:  (let ((x 0)) (until (< x 10) (princ (incf x))))
81 
+
82 
+while (test &rest body)
83 
+
84 
+          While <test> returns non-NIL, repeatedly execute <body>.
85 
+          Ex:  (let ((x 0)) (while (< x 10) (princ (incf x))))
86 
+
utils/general.lisp
History View file @ 6e35003
0 87 
new file mode 100644
... ... 
@@ -0,0 +1,178 @@
1 
+;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: GARNET-UTILS; Base: 10 -*-
2 
+
3 
+
4 
+;; The Garnet User Interface Development Environment.
5 
+;;
6 
+;; This code was written as part of the Garnet project at Carnegie
7 
+;; Mellon University, and has been placed in the public domain.
8 
+;;
9 
+;; by David S. Kosbie
10 
+
11 
+;; Host of Lisp utilities used by other Garnet code.
12 
+
13 
+(in-package :garnet-utils)
14 
+
15 
+(defvar *debug-utils-mode* t)
16 
+
17 
+(defconstant pi/2 (/ pi 2))
18 
+(defconstant pi3/2 (* 3 (/ pi 2)))
19 
+(defconstant 2PI (* 2 PI))
20 
+(defconstant -2PI (- (* 2 PI)))
21 
+(defconstant short-PI (coerce PI 'short-float))
22 
+
23 
+(defmacro while (test &rest body)
24 
+  "Loop while test is true. If already not true, don't loop at all."
25 
+  `(do ()
26 
+     ((not ,test))
27 
+     ,@body))
28 
+
29 
+(defmacro till (test &body body)
30 
+  "Loop until test is true. If already true, don't loop at all."
31 
+  `(do ()
32 
+       (,test)
33 
+     ,@body))
34 
+
35 
+;; Original Garnet version (loops at least once).
36 
+(defmacro until (test &body body)
37 
+  "Loop until test is true. Loops at least once."
38 
+  `(loop ,@body
39 
+      (when ,test (return))))
40 
+
41 
+(defmacro do2lists ((var1 list1 var2 list2 &key either?) &rest body)
42 
+ (let ((list1var  (gensym))
43 
+       (list2var  (gensym))
44 
+       (done-test (if either? 'and 'or)))
45 
+  `(let ((,list1var ,list1)
46 
+         (,list2var ,list2)
47 
+         ,var1 ,var2)
48 
+      (while (,done-test ,list1var ,list2var)
49 
+        (setq ,var1 (car ,list1var))
50 
+        (setq ,var2 (car ,list2var))
51 
+        (setq ,list1var (cdr ,list1var))
52 
+        (setq ,list2var (cdr ,list2var))
53 
+       ,@body))))
54 
+
55 
+(defmacro dolist2 ((var1 var2 list) &rest body)
56 
+  (let ((listvar (gensym)))
57 
+  `(let ((,listvar ,list) ,var1 ,var2)
58 
+     (while ,listvar
59 
+       (setq ,var1 (car ,listvar))
60 
+       (setq ,var2 (cadr ,listvar))
61 
+       (setq ,listvar (cddr ,listvar))
62 
+       ,@body))))
63 
+
64 
+(defmacro m (s-expr)
65 
+  `(pprint (macroexpand (quote ,s-expr))))
66 
+
67 
+(defmacro m1 (s-expr)
68 
+  `(pprint (macroexpand-1 (quote ,s-expr))))
69 
+
70 
+(defmacro string+ (&rest args) `(concatenate 'string ,@args))
71 
+
72 
+(defun add-to-list (element list &optional where locator)
73 
+  "Add-to-list legal invocations:
74 
+     (add-to-list element list)
75 
+     (add-to-list element list :head) (or :front)
76 
+     (add-to-list element list :tail) (or :back)
77 
+     (add-to-list element list :before other-element)
78 
+     (add-to-list element list :after other-element)"
79 
+ (let  ((new-cons (list element))
80 
+        result)
81 
+   (if (null list)
82 
+       (setq result new-cons)
83 
+       (case where
84 
+         ((:head :front NIL)
85 
+          (setq result (cons element list)))
86 
+         ((:before)
87 
+          (if (eq (first list) locator)
88 
+              (setq result (cons element list))
89 
+              (do ((cons1 list (cdr cons1))
90 
+                   (cons2 (cdr list) (cdr cons2)))
91 
+                  ((null cons2))
92 
+                (when (eq (first cons2) locator)
93 
+                  (setf (cdr new-cons) cons2)
94 
+                  (setf (cdr cons1) new-cons)
95 
+                  (setq result list)
96 
+                  (return)))))
97 
+         ((:after)
98 
+          (do ((cons1 list (cdr cons1))
99 
+               (cons2 (cdr list) (cdr cons2)))
100 
+              ((null cons1))
101 
+            (when (eq (first cons1) locator)
102 
+              (setf (cdr new-cons) cons2)
103 
+              (setf (cdr cons1) new-cons)
104 
+              (setq result list)
105 
+              (return))))))
106 
+ (unless result
107 
+   (setf (cdr (last list)) new-cons)
108 
+   (setq result list))
109 
+ result))
110 
+
111 
+
112 
+;; Verify-Binding implementation
113 
+;;
114 
+;; Keep --- a demo uses this
115 
+(defun verify-binding (string)
116 
+  "Takes a string and returns the symbol coercion of the string if the
117 
+   symbol is bound.  Note: The suffix of the string is converted to
118 
+   all uppercase characters before checking if it is bound in the
119 
+   package."
120 
+  (let ((result-1 (verify-binding-aux string 0)))
121 
+    (if result-1
122 
+        (let* ((colon-p (first result-1))
123 
+               (prefix (second result-1))
124 
+               (symbol-1 (values (read-from-string prefix)))
125 
+               (index (third result-1)))
126 
+          (if colon-p
127 
+              ;; Then symbol-1 indicates a package name
128 
+              (when (find-package symbol-1)
129 
+                ;; Then symbol-1 is a valid package name
130 
+                (let ((result-2 (verify-binding-aux string (+ 1 index))))
131 
+                  (when result-2
132 
+                    ;; Then suffix indicates a var in the package symbol-1
133 
+                    (let* ((suffix (string-upcase (second result-2)))
134 
+                           (access-internal-p (fourth result-2)))
135 
+                      (multiple-value-call
136 
+                          #'(lambda (symbol-2 access)
137 
+                              (if symbol-2
138 
+                                  (if (or (eq access :external)
139 
+                                          access-internal-p)
140 
+                                      ;; verify that symbol-2 is not a function
141 
+                                      (when (boundp symbol-2)
142 
+                                        (values (read-from-string string)))
143 
+                                      )))
144 
+                        (find-symbol suffix symbol-1))))))
145 
+              ;; Then symbol indicates a var in the working package
146 
+              (when (and (not (numberp symbol-1)) (boundp symbol-1)) symbol-1))))))
147 
+
148 
+(defun verify-binding-aux (string start)
149 
+  "Split the string at the colon(s) to return either the package name
150 
+   or the symbol name if called where the first character is a colon."
151 
+  (let ((str-len (length string)))
152 
+    (when (> str-len start)
153 
+      ;; Skip second colon if there is a double colon between package and var
154 
+      (let ((access-internal-p (when (and (char= (char string start) #\:)
155 
+                                          (/= start 0))
156 
+                                 (incf start))))
157 
+        ;; Abort if a special character begins the string
158 
+        (unless (or (char= (char string start) #\:)
159 
+                    (char= (char string start) #\#))
160 
+          ;; Return the part of the string up to but not including the colon
161 
+          ;; and the index of the last character checked
162 
+          ;; FMG --- Just use lisp utilities to do this stuff.
163 
+          (let* ((colon (position #\: string :start start :test #'char=))
164 
+                 (new-string (subseq string start colon)))
165 
+            (list (not (null colon))
166 
+                  new-string
167 
+                  (or colon (1- str-len))
168 
+                  access-internal-p)))))))
169 
+
170 
+(defun safe-functionp (fn)
171 
+  (or (functionp fn)
172 
+      (and (symbolp fn) (fboundp fn))))
173 
+
174 
+(defun directory-p (pathname)
175 
+  (cl-fad:directory-exists-p pathname))
176 
+
177 
+(defmacro str (&rest rest)
178 
+  `(concatenate 'string ,@rest))
utils/global.lisp
History View file @ 6e35003
0 179 
new file mode 100644
... ... 
@@ -0,0 +1,6 @@
1 
+
2 
+(in-package :garnet-utils)
3 
+
4 
+(defvar black nil)
5 
+(defvar white nil)
6 
+(defvar *garnet-break-key* :F1)
utils/mouse-keys.lisp
History View file @ 6e35003
0 7 
new file mode 100644
... ... 
@@ -0,0 +1,56 @@
1 
+(in-package :COMMON-LISP-USER)
2 
+
3 
+(eval-when (:execute :load-toplevel :compile-toplevel)
4 
+  (defvar REFRESH-INIT
5 
+    (progn
6 
+      (garnet-load "gadgets:text-buttons-loader")
7 
+      (garnet-load "gadgets:radio-buttons-loader"))))
8 
+
9 
+(defvar SMALL-FONT (opal:get-standard-font NIL NIL :small))
10 
+
11 
+(when (boundp 'REFRESH-WIN) (opal:destroy REFRESH-WIN))
12 
+
13 
+(create-instance 'REFRESH-WIN inter:interactor-window
14 
+  (:left 515) (:top 365) (:height 110) (:width 120)
15 
+  (:title "Keys")
16 
+  (:aggregate (create-instance 'REFRESH-TOP-AGG opal:aggregate)))
17 
+
18 
+(opal:update REFRESH-WIN)
19 
+
20 
+(create-instance 'REFRESH gg:text-button
21 
+  (:left 10) (:top 10)
22 
+  (:text-offset 2) (:gray-width 3) (:shadow-offset 5)
23 
+  (:font SMALL-FONT)
24 
+  (:string "Refresh")
25 
+  (:final-feedback-p NIL)
26 
+  (:selection-function #'(lambda (gadget value)
27 
+                           (declare (ignore gadget value))
28 
+                           (opal:update-all T))))
29 
+
30 
+(defun function-key-fn (gadget value)
31 
+  (declare (ignore gadget value))
32 
+  (setf inter::*leftdown-key* 105
33 
+        inter::*middledown-key* 107
34 
+        inter::*rightdown-key* 113))
35 
+
36 
+(defun arrow-key-fn (gadget value)
37 
+  (declare (ignore gadget value))
38 
+  (setf inter::*leftdown-key* 123
39 
+        inter::*middledown-key* 124
40 
+        inter::*rightdown-key* 125))
41 
+
42 
+(create-instance 'MOUSE-KEYS gg:radio-button-panel
43 
+  (:left 10) (:top 40)
44 
+  (:font SMALL-FONT)
45 
+  (:text-offset 2) (:gray-width 3) (:shadow-offset 5)
46 
+  (:button-diameter 20)
47 
+  (:items `(("Function keys" Function-key-fn)
48 
+            ("Arrow keys" Arrow-key-fn))))
49 
+
50 
+(g-value MOUSE-KEYS :value)
51 
+(s-value MOUSE-KEYS :value "Function keys")
52 
+
53 
+(opal:add-components REFRESH-TOP-AGG REFRESH MOUSE-KEYS)
54 
+(opal:update REFRESH-WIN)
55 
+
56 
+(opal:update REFRESH-WIN T)