- (dolist (l (dep-listeners dep))
- (funcall l)))
-
-(defun update-dep (dep value &optional (goodp t))
- "Modify the value of DEP. If GOODP is t, then mark it as good and store
- VALUE is its new value; otherwise mark it bad. If DEP's value is now
- different (according to its value-predicate) then return true; otherwise
- return false."
- (setf (dep-state dep) :stable)
- (cond ((not goodp)
- (if (dep-goodp dep)
- (progn (setf (dep-goodp dep) nil) t)
- nil))
- ((and (dep-goodp dep)
- (funcall (dep-value-predicate dep) value (dep-%value dep)))
- nil)
- (t
- (setf (dep-goodp dep) t
- (dep-%value dep) value)
- t)))
-
-(defun recompute-dep (dep)
- "Recompute the value of DEP. This function is careful to trap nonlocal
- transfers from the value-func."
- (let ((winning nil))
+ (dolist (listener (dep-listeners dep))
+ (funcall listener)))
+
+(defun recompute-dep-value (dep)
+ "Recompute the value of DEP.
+
+ Returns true if DEP's value actually changed, or nil otherwise. On exit,
+ the DEP's +VALUE+ and +DEPS+ flags are set, and +CHANGED+ is set if the
+ value actually changed.
+
+ We assume that DEP's dependencies are up-to-date already, and that DEP's
+ +RECOMPUTING+ flag is set. In the former case, DEP's dependents and
+ listeners are notified, using PROPAGATE-TO-DEPENDENTS."
+ (let ((winning nil)
+ (new-flags (logior (logand (dep-%flags dep) +queued+)
+ +value+ +deps+)))
+ (flet ((update (value)
+ (cond ((update-dep dep value)
+ (setf (dep-flags dep) (logior new-flags +changed+))
+ (propagate-to-dependents dep)
+ t)
+ (t
+ (setf (dep-flags dep) new-flags)
+ nil))))
+ (unwind-protect
+ (prog1 (update (new-dep-value dep)) (setf winning t))
+ (unless winning (update .bad.))))))
+
+(defun force-dep-value (dep)
+ "Arrange for DEP to have a current value.
+
+ Returns true if the DEP's value has changed in this recomputation phase,
+ or nil if not.
+
+ If DEP is already has a good value, then we just use that; the return
+ value is determined by the +CHANGED+ flag. Otherwise, we set
+ +RECOMPUTING+ (in order to trap circularities) and force the values of
+ DEP's dependencies in turn. If any of them returned true then we have to
+ explicitly recompute DEP (so we do); otherwise we can leave it as it is."
+ (let ((flags (dep-flags dep)))
+ (cond ((plusp (logand flags +recomputing+))
+ (error "Ouch! Circular dependency detected."))
+ ((plusp (logand flags +value+))
+ (plusp (logand flags +changed+)))
+ (t
+ (setf (dep-generation dep) *generation*
+ (dep-flags dep) (logior (logand flags +queued+)
+ +recomputing+))
+ (if (some #'force-dep-value (dep-dependencies dep))
+ (recompute-dep-value dep)
+ (progn (setf (dep-flags dep) flags) nil))))))
+
+(defun %dep-value (dep)
+ "Do the difficult work of retrieving the current value of a DEP.
+
+ This is the unhappy path of `dep-value'."
+ (force-dep-value dep)
+ (when *evaluating-dep*
+ (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
+ (pushnew dep (dep-dependencies *evaluating-dep*))))
+
+(export 'dep-value)
+(declaim (inline dep-value))
+(defun dep-value (dep)
+ "Retrieve the current value from DEP."
+ (when (eq *state* :recomputing)
+ (%dep-value dep))
+ (let ((value (dep-%value dep)))
+ (if (eq value .bad.)
+ (throw 'dep-bad .bad.)
+ value)))
+
+(export 'dep-goodp)
+(defun dep-goodp (dep)
+ "Answer whether DEP is good."
+ (when (eq *state* :recomputing)
+ (force-dep-value dep))
+ (not (eq (dep-%value dep) .bad.)))
+
+(export 'dep-try)
+(defmacro dep-try (expr &body body)
+ "Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
+ (let ((block-name (gensym "TRY")))
+ `(block ,block-name
+ (catch 'dep-bad
+ (return-from ,block-name ,expr))
+ ,@body)))
+
+(export 'dep-bad)
+(defun dep-bad ()
+ "Call from a value-function: indicates that the dep should marked as bad."
+ (throw 'dep-bad nil))
+
+(defun recompute-pending-deps ()
+ "Process the *PENDING-DEPS* queue, recomputing the deps listed on it.
+
+ We bind *STATE* to :RECOMPUTING during the process."
+ (let ((*state* :recomputing))
~mdw / lisp / blobdiff