Commit | Line | Data |
---|---|---|
2626af66 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Maintenance and recalculation of dependent values | |
4 | ;;; | |
5 | ;;; (c) 2008 Mark Wooding | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
14 | ;;; | |
15 | ;;; This program is distributed in the hope that it will be useful, | |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | (defpackage #:dep | |
77f935da | 25 | (:use #:common-lisp #:queue #:weak)) |
2626af66 MW |
26 | (in-package #:dep) |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
af33e77c MW |
29 | ;;; Constants. |
30 | ||
31 | (defconstant +value+ 1 | |
32 | "Flag: dep's value is up-to-date.") | |
33 | (defconstant +deps+ 2 | |
34 | "Flag: dep is known as a dependent on its dependencies.") | |
35 | (defconstant +changed+ 4 | |
36 | "Flag: dep has changed in the current recomputation phase.") | |
37 | (defconstant +recomputing+ 8 | |
38 | "Flag: dep is currently being recomputed.") | |
39 | (defconstant +queued+ 16 | |
40 | "Flag: dep is currently on the queue for recomputation.") | |
41 | ||
42 | (defconstant .bad. '.bad. | |
43 | "Magical value used to indicate bad deps.") | |
44 | ||
45 | ;;;-------------------------------------------------------------------------- | |
46 | ;;; Global and special variables. | |
2626af66 | 47 | |
23bc61bd MW |
48 | (defvar *generation* (list '*generation*) |
49 | "Generation marker, used to remember when we last updated a particular dep. | |
8f1a2329 MW |
50 | Essentially, if the dep's generation matches `*generation*' then it |
51 | doesn't need updating again.") | |
23bc61bd MW |
52 | |
53 | (defvar *evaluating-dep* nil | |
54 | "The dep currently being evaluated. This is bound only during the call of | |
af33e77c | 55 | a value-function, and is used to track the dependencies implied during the |
23bc61bd MW |
56 | function's evaluation.") |
57 | ||
af33e77c MW |
58 | (defvar *state* :ready |
59 | "The current state. It may be any of: | |
60 | ||
8f1a2329 | 61 | * `:ready' -- the usual state: everything is up-to-date and correct. |
af33e77c | 62 | |
8f1a2329 MW |
63 | * `:frozen' -- the state used to evaluate the body of |
64 | `with-deps-frozen'. Deps may be assigned values, but their dependents | |
65 | are not immediately recomputed. | |
af33e77c | 66 | |
8f1a2329 | 67 | * `:recomputing' -- the state imposed while updating dependents.") |
af33e77c MW |
68 | |
69 | (defvar *delayed-operations* nil | |
8f1a2329 MW |
70 | "A queue of operations delayed by `with-deps-frozen'. Only available in |
71 | the `:recomputing' state.") | |
af33e77c | 72 | |
23bc61bd MW |
73 | (defvar *pending-deps* nil |
74 | "A queue of deps pending recomputation. This is bound to a queue during | |
75 | recomputation and restored afterwards, so it can also be used as a flag to | |
af33e77c MW |
76 | detect whether recomputation is happening. |
77 | ||
78 | Deps on the queue are always in the current generation, and have the | |
8f1a2329 | 79 | `+queued+' flag set.") |
af33e77c MW |
80 | |
81 | ;;;-------------------------------------------------------------------------- | |
82 | ;;; Data structures. | |
23bc61bd | 83 | |
77f935da | 84 | (export '(dep depp dep-name)) |
2626af66 MW |
85 | (defstruct (dep (:predicate depp) |
86 | (:constructor %make-dep)) | |
87 | "There are two kinds of `dep', though we use the same object type for both. | |
88 | A leaf dep has no dependencies, and its value is set explicitly by the | |
89 | programmer. A non-leaf dep has a value /function/, which computes the | |
90 | dep's value as a function of other deps' values. The dependencies don't | |
91 | need to be declared in advance, or remain constant over time. | |
92 | ||
93 | When not during a recomputation phase (i.e., when `stable'), a dep is | |
94 | either `good' (i.e., it has a value) or `bad'. An attempt to read the | |
95 | value of a bad dep results in a throw of `bad-dep'. Badness propagates | |
96 | automatically during recomputation phases." | |
af33e77c | 97 | (%value .bad. :type t) |
77f935da MW |
98 | (name nil :type t :read-only t) |
99 | (value-function nil :type (or function null) :read-only t) | |
100 | (value-predicate #'eql :type function :read-only t) | |
af33e77c | 101 | (%flags 0 :type (unsigned-byte 8)) |
23bc61bd | 102 | (generation *generation* :type list) |
2626af66 | 103 | (listeners nil :type list) |
5f61c961 | 104 | (dependents nil :type list) |
af33e77c | 105 | (dependencies nil :type list) |
5f61c961 | 106 | (weak-pointer nil :type t)) |
2626af66 | 107 | |
af33e77c MW |
108 | ;;;-------------------------------------------------------------------------- |
109 | ;;; Main code. | |
110 | ||
111 | (declaim (inline dep-flags)) | |
112 | (defun dep-flags (dep) | |
113 | "Return the current flags of DEP. | |
114 | ||
115 | The flags are fetched from the object if we're in a recomputation phase | |
116 | and the object's generation is current. Otherwise the object's flags are | |
117 | out of date, and we make up a better set." | |
118 | (cond ((eq *state* :ready) (logior +value+ +deps+)) | |
119 | ((eq (dep-generation dep) *generation*) (dep-%flags dep)) | |
120 | ((not (dep-value-function dep)) (logior +value+ +deps+)) | |
121 | (t 0))) | |
122 | ||
123 | (declaim (inline (setf dep-flags))) | |
124 | (defun (setf dep-flags) (flags dep) | |
125 | "Set the DEP's flags. | |
126 | ||
127 | This doesn't do anything else like force DEP's generation." | |
128 | (setf (dep-%flags dep) flags)) | |
129 | ||
130 | (defun update-dep (dep value) | |
131 | "Modify the value of DEP. | |
132 | ||
133 | If DEP's value is now different (according to its badness or | |
134 | value-predicate) then return true; otherwise return false." | |
135 | (let ((old-value (dep-%value dep))) | |
136 | (if (if (eq value .bad.) | |
137 | (eq old-value .bad.) | |
138 | (and (not (eq old-value .bad.)) | |
139 | (funcall (dep-value-predicate dep) value old-value))) | |
140 | nil | |
141 | (progn (setf (dep-%value dep) value) t)))) | |
142 | ||
143 | (defun new-dep-value (dep) | |
8f1a2329 | 144 | "Recompute and return the value of DEP, or `.bad.' if the dep is bad. |
af33e77c MW |
145 | |
146 | This function is very minimal. The caller expected to deal with many | |
147 | aspects of caring for and feeding DEP. In particular: | |
148 | ||
8f1a2329 | 149 | * Non-local exits (except throwing `dep-bad') are not handled here. |
af33e77c MW |
150 | |
151 | * We assume that DEP is already in the current generation, and has its | |
8f1a2329 | 152 | `+recomputing+' flag set. |
af33e77c MW |
153 | |
154 | * The caller is responsible for setting the current flags afterwards." | |
155 | (catch 'dep-bad | |
156 | (let ((*evaluating-dep* dep)) | |
157 | (setf (dep-dependencies dep) nil) | |
158 | (funcall (dep-value-function dep))))) | |
159 | ||
160 | (defun propagate-to-dependents (dep) | |
161 | "Notify the dependents of DEP of a change to its value. | |
162 | ||
163 | We assume that DEP is up-to-date in the current generation, and has | |
8f1a2329 | 164 | correct flags (at least `+value+' and `+changed+', and maybe `+deps+'). |
af33e77c MW |
165 | Dependents of DEP are enqueued for recomputation. The DEP's dependents |
166 | are forced into the current generation and enqueued, and the dependents | |
167 | list is cleared ready to be repopulated. The DEP's listener functions are | |
168 | invoked." | |
5f61c961 MW |
169 | (dolist (dweak (dep-dependents dep)) |
170 | (let ((d (weak-pointer-value dweak))) | |
af33e77c MW |
171 | (when d |
172 | (let ((flags (dep-flags d))) | |
173 | (unless (plusp (logand flags (logior +queued+ +deps+))) | |
174 | (enqueue d *pending-deps*) | |
175 | (setf (dep-generation d) *generation* | |
176 | (dep-flags d) (logior (logand flags +value+) | |
177 | +queued+))))))) | |
2626af66 | 178 | (setf (dep-dependents dep) nil) |
af33e77c MW |
179 | (dolist (listener (dep-listeners dep)) |
180 | (funcall listener))) | |
181 | ||
182 | (defun recompute-dep-value (dep) | |
183 | "Recompute the value of DEP. | |
184 | ||
185 | Returns true if DEP's value actually changed, or nil otherwise. On exit, | |
8f1a2329 MW |
186 | the DEP's `+value+' and `+deps+' flags are set, and `+changed+' is set if |
187 | the value actually changed. | |
af33e77c MW |
188 | |
189 | We assume that DEP's dependencies are up-to-date already, and that DEP's | |
8f1a2329 MW |
190 | `+recomputing+' flag is set. In the former case, DEP's dependents and |
191 | listeners are notified, using `propagate-to-dependents'." | |
e9de36a9 MW |
192 | (let ((winning nil) |
193 | (new-flags (logior (logand (dep-%flags dep) +queued+) | |
194 | +value+ +deps+))) | |
af33e77c MW |
195 | (flet ((update (value) |
196 | (cond ((update-dep dep value) | |
e9de36a9 | 197 | (setf (dep-flags dep) (logior new-flags +changed+)) |
af33e77c MW |
198 | (propagate-to-dependents dep) |
199 | t) | |
200 | (t | |
e9de36a9 | 201 | (setf (dep-flags dep) new-flags) |
af33e77c | 202 | nil)))) |
23bc61bd | 203 | (unwind-protect |
af33e77c MW |
204 | (prog1 (update (new-dep-value dep)) (setf winning t)) |
205 | (unless winning (update .bad.)))))) | |
206 | ||
207 | (defun force-dep-value (dep) | |
208 | "Arrange for DEP to have a current value. | |
209 | ||
210 | Returns true if the DEP's value has changed in this recomputation phase, | |
211 | or nil if not. | |
212 | ||
213 | If DEP is already has a good value, then we just use that; the return | |
8f1a2329 MW |
214 | value is determined by the `+changed+' flag. Otherwise, we set |
215 | `+recomputing+' (in order to trap circularities) and force the values of | |
af33e77c MW |
216 | DEP's dependencies in turn. If any of them returned true then we have to |
217 | explicitly recompute DEP (so we do); otherwise we can leave it as it is." | |
218 | (let ((flags (dep-flags dep))) | |
219 | (cond ((plusp (logand flags +recomputing+)) | |
220 | (error "Ouch! Circular dependency detected.")) | |
221 | ((plusp (logand flags +value+)) | |
222 | (plusp (logand flags +changed+))) | |
223 | (t | |
224 | (setf (dep-generation dep) *generation* | |
225 | (dep-flags dep) (logior (logand flags +queued+) | |
226 | +recomputing+)) | |
227 | (if (some #'force-dep-value (dep-dependencies dep)) | |
228 | (recompute-dep-value dep) | |
229 | (progn (setf (dep-flags dep) flags) nil)))))) | |
230 | ||
231 | (defun %dep-value (dep) | |
b59116d4 MW |
232 | "Do the difficult work of retrieving the current value of a DEP. |
233 | ||
234 | This is the unhappy path of `dep-value'." | |
813da880 | 235 | (force-dep-value dep) |
af33e77c MW |
236 | (when *evaluating-dep* |
237 | (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep)) | |
813da880 | 238 | (pushnew dep (dep-dependencies *evaluating-dep*)))) |
af33e77c | 239 | |
77f935da | 240 | (export 'dep-value) |
af33e77c MW |
241 | (declaim (inline dep-value)) |
242 | (defun dep-value (dep) | |
243 | "Retrieve the current value from DEP." | |
244 | (when (eq *state* :recomputing) | |
245 | (%dep-value dep)) | |
246 | (let ((value (dep-%value dep))) | |
247 | (if (eq value .bad.) | |
248 | (throw 'dep-bad .bad.) | |
249 | value))) | |
250 | ||
77f935da | 251 | (export 'dep-goodp) |
af33e77c MW |
252 | (defun dep-goodp (dep) |
253 | "Answer whether DEP is good." | |
254 | (when (eq *state* :recomputing) | |
255 | (force-dep-value dep)) | |
256 | (not (eq (dep-%value dep) .bad.))) | |
257 | ||
77f935da | 258 | (export 'dep-try) |
af33e77c | 259 | (defmacro dep-try (expr &body body) |
8f1a2329 | 260 | "Evaluate EXPR. If it throws `dep-bad' then evaluate BODY instead." |
af33e77c MW |
261 | (let ((block-name (gensym "TRY"))) |
262 | `(block ,block-name | |
263 | (catch 'dep-bad | |
264 | (return-from ,block-name ,expr)) | |
265 | ,@body))) | |
266 | ||
77f935da | 267 | (export 'dep-bad) |
af33e77c MW |
268 | (defun dep-bad () |
269 | "Call from a value-function: indicates that the dep should marked as bad." | |
270 | (throw 'dep-bad nil)) | |
271 | ||
272 | (defun recompute-pending-deps () | |
8f1a2329 | 273 | "Process the `*pending-deps*' queue, recomputing the deps listed on it. |
af33e77c | 274 | |
8f1a2329 | 275 | We bind `*state*' to `:recomputing' during the process." |
af33e77c MW |
276 | (let ((*state* :recomputing)) |
277 | (unwind-protect | |
278 | (loop (when (queue-emptyp *pending-deps*) | |
279 | (return)) | |
280 | (let* ((dep (dequeue *pending-deps*)) | |
281 | (flags (dep-%flags dep))) | |
282 | (setf (dep-%flags dep) (logandc2 flags +queued+)) | |
283 | (cond ((zerop (logand flags +value+)) | |
284 | (recompute-dep-value dep)) | |
285 | ((zerop (logand flags +deps+)) | |
286 | (new-dep-value dep) | |
287 | (setf (dep-%flags dep) (logior flags +deps+)))))) | |
288 | (loop (when (queue-emptyp *pending-deps*) | |
289 | (return)) | |
290 | (let ((d (dequeue *pending-deps*))) | |
291 | (setf (dep-%value d) .bad.)))))) | |
292 | ||
293 | (defun with-deps-frozen* (thunk &key delay) | |
8f1a2329 | 294 | "Invoke THUNK in the `:frozen' state. See `with-deps-frozen' for full |
af33e77c MW |
295 | information." |
296 | (ecase *state* | |
297 | (:frozen | |
298 | (funcall thunk)) | |
2626af66 | 299 | (:recomputing |
af33e77c MW |
300 | (unless delay |
301 | (error "This really isn't a good time.")) | |
302 | (enqueue thunk *delayed-operations*)) | |
303 | (:ready | |
304 | (let ((*state* :frozen) | |
305 | (*delayed-operations* (make-queue)) | |
306 | (*pending-deps* (make-queue))) | |
307 | (setf *generation* (list '*generation*)) | |
308 | (multiple-value-prog1 (funcall thunk) | |
309 | (loop (recompute-pending-deps) | |
310 | (when (queue-emptyp *delayed-operations*) | |
311 | (return)) | |
312 | (funcall (dequeue *delayed-operations*)))))))) | |
313 | ||
77f935da | 314 | (export 'with-deps-frozen) |
af33e77c | 315 | (defmacro with-deps-frozen ((&key delay) &body body) |
8f1a2329 MW |
316 | "Evaluate BODY in the `:frozen' state. |
317 | ||
318 | In the `:frozen' state, recomutation is deferred. If the current state is | |
319 | `:ready', then we enter `:frozen', evaluate the BODY, and then enter | |
320 | `:recomputing' to fix up the dependency graph. If the current state is | |
321 | `:frozen', we do nothing particularly special. Finally, if the current | |
322 | state is `:recomputing' then the behaviour depends on the value of | |
323 | the `:delay' argument: if false, an error is signalled; if true, the | |
af33e77c MW |
324 | evaluation is postponed until the end of the recomputation. |
325 | ||
326 | This macro has four immediate uses. | |
327 | ||
328 | * Firstly, it's actually the only way to trigger recomputation at all. | |
329 | It's invoked behind the scenes to do the right thing. | |
330 | ||
331 | * If you're making a large number of updates without data dependencies | |
8f1a2329 MW |
332 | then you can make them go faster by wrapping them in |
333 | `with-deps-frozen' and only having a single recomputation phase. | |
af33e77c | 334 | |
8f1a2329 MW |
335 | * A simple (setf (dep-value ...) ...) is unsafe during recomputation. |
336 | You can use `with-deps-frozen' to indicate that it's safe to defer the | |
af33e77c MW |
337 | assignment until later. Deferred operations take place in the order |
338 | in which they were requested. | |
339 | ||
340 | * Finally, you can use it to force a number of deps to hold given values | |
341 | simultaneously, despite their value-functions disagreeing." | |
342 | `(with-deps-frozen* (lambda () ,@body) :delay ,delay)) | |
2626af66 MW |
343 | |
344 | (defun (setf dep-value) (value dep) | |
af33e77c MW |
345 | "Assign the VALUE to the DEP, forcing recomputation if necessary." |
346 | (with-deps-frozen () | |
347 | (when (update-dep dep value) | |
348 | (setf (dep-generation dep) *generation* | |
349 | (dep-flags dep) (logior +value+ +changed+)) | |
350 | (propagate-to-dependents dep))) | |
2626af66 MW |
351 | value) |
352 | ||
77f935da | 353 | (export 'dep-make-bad) |
2626af66 MW |
354 | (defun dep-make-bad (dep) |
355 | "Mark DEP as being bad." | |
af33e77c | 356 | (setf (dep-value dep) .bad.)) |
2626af66 | 357 | |
77f935da | 358 | (export 'dep-add-listener) |
2626af66 MW |
359 | (defun dep-add-listener (dep func) |
360 | "Add a listener function FUNC to the DEP. The FUNC is called each time the | |
361 | DEP's value (or good/bad state) changes. It is called with no arguments, | |
362 | and its return value is ignored." | |
363 | (push func (dep-listeners dep))) | |
364 | ||
77f935da | 365 | (export 'make-dep) |
2626af66 MW |
366 | (defun make-dep (&rest args) |
367 | "Create a new DEP object. There are two basic argument forms: | |
368 | ||
23bc61bd | 369 | (:value &optional OBJECT) |
2626af66 | 370 | Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the |
8f1a2329 | 371 | dep is initially bad. The keyword `:leaf' is accepted as a synonym. |
2626af66 MW |
372 | |
373 | (:function FUNCTION) | |
374 | Return a non-leaf dep whose value is computed by FUNCTION. | |
375 | ||
8f1a2329 MW |
376 | Additionally, if the first argument is something other than `:value' or |
377 | `:function' (ideally not a keyword, for forward compatibility), then the | |
2626af66 | 378 | first argument is inspected: if it's a function, then a function dep is |
8f1a2329 | 379 | retuerned (as if you'd specified `:function'); otherwise a leaf dep is |
2626af66 MW |
380 | returned. |
381 | ||
8f1a2329 | 382 | Finally, it's possible to specify both `:value' and `:function' |
23bc61bd MW |
383 | simultaneously; this will set the initial values as requested, but |
384 | recompute them as necessary. It is possible to establish dependency | |
385 | cycles, but you need to suppress recomputation in order to do this | |
8f1a2329 | 386 | correctly -- see the `with-deps-frozen' macro. |
23bc61bd | 387 | |
2626af66 MW |
388 | If no arguments are given, a bad leaf dep is returned." |
389 | ||
23bc61bd | 390 | (flet ((arg () (if args (pop args) |
8f1a2329 | 391 | (error "Not enough arguments to `make-dep'.")))) |
2626af66 MW |
392 | |
393 | ;; Sort out the arguments. | |
af33e77c | 394 | (let ((value .bad.) |
23bc61bd | 395 | (valuep nil) |
af33e77c | 396 | (name nil) |
5f61c961 | 397 | (predicate #'eql) |
af33e77c | 398 | (listeners nil) |
23bc61bd MW |
399 | (function nil)) |
400 | (do () ((endp args)) | |
401 | (let ((indicator (pop args))) | |
5f61c961 MW |
402 | (case indicator |
403 | ((:value :leaf) | |
af33e77c MW |
404 | (setf value (if args (pop args) .bad.) |
405 | valuep t)) | |
5f61c961 MW |
406 | (:function |
407 | (setf function (arg))) | |
408 | (:predicate | |
409 | (setf predicate (arg))) | |
af33e77c MW |
410 | (:name |
411 | (setf name (arg))) | |
412 | (:listener | |
413 | (push (arg) listeners)) | |
5f61c961 MW |
414 | (t |
415 | (cond ((functionp indicator) | |
416 | (setf function indicator)) | |
417 | (t | |
af33e77c MW |
418 | (setf value indicator |
419 | valuep t))))))) | |
420 | (unless (or valuep function) | |
421 | (setf valuep t)) | |
2626af66 MW |
422 | |
423 | ;; Create the object appropriately. | |
af33e77c | 424 | (let ((dep (%make-dep :value-function function |
23bc61bd | 425 | :%value value |
af33e77c MW |
426 | :name name |
427 | :listeners listeners | |
428 | :%flags (logior (if valuep +value+ 0) | |
429 | (if function +queued+ +deps+) | |
430 | +changed+) | |
5f61c961 | 431 | :value-predicate predicate |
af33e77c | 432 | :generation *generation*))) |
5f61c961 | 433 | (setf (dep-weak-pointer dep) (make-weak-pointer dep)) |
af33e77c MW |
434 | (when function |
435 | (with-deps-frozen () | |
436 | (enqueue dep *pending-deps*))) | |
437 | dep)))) | |
2626af66 | 438 | |
77f935da | 439 | (export 'install-dep-syntax) |
2626af66 MW |
440 | (defun install-dep-syntax (&optional (readtable *readtable*)) |
441 | "Installs into the given READTABLE some syntactic shortcuts: | |
442 | ||
443 | ?FORM -> (dep-value FORM) | |
444 | Extract (or modify, for a leaf dep) the value of the dep indicated by | |
445 | FORM. | |
446 | ||
447 | #[FORM ...] -> (make-dep :funcion (lambda () FORM ...)) | |
448 | Return a derived dep whose value function computes the given FORMs | |
8f1a2329 | 449 | (as an implicit `progn') |
2626af66 MW |
450 | |
451 | Returns the READTABLE." | |
452 | (set-macro-character #\? | |
453 | (lambda (stream char) | |
454 | (declare (ignore char)) | |
455 | (list 'dep-value (read stream t nil t))) | |
456 | readtable) | |
457 | (set-syntax-from-char #\] #\) readtable readtable) | |
458 | (set-dispatch-macro-character #\# #\[ | |
459 | (lambda (stream arg char) | |
460 | (declare (ignore arg char)) | |
461 | `(make-dep :function | |
462 | (lambda () | |
463 | ,@(read-delimited-list #\] | |
464 | stream | |
465 | t)))) | |
466 | readtable) | |
467 | readtable) | |
468 | ||
af33e77c | 469 | #- abcl |
2626af66 MW |
470 | (defmethod print-object ((dep dep) stream) |
471 | (print-unreadable-object (dep stream :type t :identity t) | |
af33e77c MW |
472 | (pprint-logical-block (stream nil) |
473 | (let ((flags (dep-flags dep)) | |
474 | (value (dep-%value dep))) | |
475 | (cond ((zerop (logand flags +value+)) | |
476 | (write-string "#<out-of-date>" stream)) | |
477 | ((eq value .bad.) | |
478 | (write-string "#<bad>" stream)) | |
479 | (t | |
480 | (write value :stream stream))) | |
481 | (when (dep-name dep) | |
482 | (format stream " ~_~S ~@_~W" :name (dep-name dep))) | |
483 | (when (zerop (logand flags +deps+)) | |
484 | (format stream " ~_~S" :recompute-deps)) | |
485 | (when (plusp (logand flags +queued+)) | |
486 | (format stream " ~_~S" :queued)) | |
487 | (when (plusp (logand flags +changed+)) | |
488 | (format stream " ~_~S" :changed)))))) | |
489 | ||
490 | ;;;-------------------------------------------------------------------------- | |
491 | ;;; Tests. | |
2626af66 MW |
492 | |
493 | #+ test | |
494 | (progn | |
af33e77c MW |
495 | (defparameter x (make-dep :name 'x 1)) |
496 | (defparameter y (make-dep :name 'y 2)) | |
497 | (defparameter z (make-dep :name 'z | |
498 | (lambda () (+ (dep-value x) (dep-value y))))) | |
499 | (defparameter w (make-dep :name 'w | |
500 | (lambda () (* (dep-value x) (dep-value z))))) | |
6b66874f MW |
501 | (dep-add-listener x (lambda () (format t ";; x now ~S~%" x))) |
502 | (dep-add-listener z (lambda () (format t ";; z now ~S~%" z))) | |
503 | (dep-add-listener w (lambda () (format t ";; w now ~S~%" w)))) | |
2626af66 | 504 | |
af33e77c MW |
505 | #+ test |
506 | (progn | |
507 | (defparameter a (make-dep :name 'a 1)) | |
508 | (defparameter b (make-dep :name 'b 2)) | |
509 | (defparameter c (make-dep :name 'c | |
510 | (lambda () (1+ (dep-value a))))) | |
511 | (defparameter d (make-dep :name 'd | |
512 | (lambda () (* (dep-value c) (dep-value b))))) | |
513 | (defparameter e (make-dep :name 'e | |
514 | (lambda () (- (dep-value d) (dep-value a))))) | |
515 | ;; a b c = a + 1 d = c*b e = d - a | |
516 | ;; 1 2 2 4 3 | |
517 | ;; 4 2 5 10 6 | |
518 | (values (dep-value e) | |
519 | (progn | |
520 | (setf (dep-value a) 4) | |
521 | (dep-value e)))) | |
522 | ||
523 | #+ test | |
524 | (progn | |
525 | (defparameter x nil) | |
526 | (defparameter y nil) | |
527 | (with-deps-frozen () | |
528 | (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1))) | |
529 | y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2)))))) | |
530 | ||
531 | #+ test | |
532 | (trace with-deps-frozen* update-dep new-dep-value force-dep-value | |
533 | recompute-dep-value recompute-pending-deps propagate-to-dependents | |
534 | dep-value) | |
535 | ||
2626af66 | 536 | ;;;----- That's all, folks -------------------------------------------------- |