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