X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/jlisp/blobdiff_plain/ca5f00c8c447c05ab7d843a075bb68bc884fef47..a2e7266a20fff562054c0f546e4a49c03b93ce20:/dep.lisp diff --git a/dep.lisp b/dep.lisp deleted file mode 100644 index 07460b8..0000000 --- a/dep.lisp +++ /dev/null @@ -1,213 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Maintenance and recalculation of dependent values -;;; -;;; (c) 2008 Mark Wooding -;;; - -;;;----- Licensing notice --------------------------------------------------- -;;; -;;; This program is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program; if not, write to the Free Software Foundation, -;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(defpackage #:dep - (:use #:common-lisp #:queue) - (:export #:dep #:depp #:make-dep #:make-leaf-dep #:dep-goodp - #:dep-value #:dep-make-bad #:dep-bad #:dep-try - #:dep-add-listener)) -(in-package #:dep) - -;;;-------------------------------------------------------------------------- -;;; Dependencies. - -(defstruct (dep (:predicate depp) - (:constructor %make-dep)) - "There are two kinds of `dep', though we use the same object type for both. - A leaf dep has no dependencies, and its value is set explicitly by the - programmer. A non-leaf dep has a value /function/, which computes the - dep's value as a function of other deps' values. The dependencies don't - need to be declared in advance, or remain constant over time. - - When not during a recomputation phase (i.e., when `stable'), a dep is - either `good' (i.e., it has a value) or `bad'. An attempt to read the - value of a bad dep results in a throw of `bad-dep'. Badness propagates - automatically during recomputation phases." - (%value nil :type t) - (value-func nil :type (or function null)) - (value-predicate #'eql :type function) - (goodp nil :type boolean) - (state :pending :type (member :stable :pending :recomputing)) - (listeners nil :type list) - (dependents nil :type list)) - -(defvar *evaluating-dep* nil - "The dep currently being evaluated. This is bound only during the call of - a value-func, and is used to track the dependencies implied during the - function's evaluation.") - -(defvar *pending-deps* nil - "A queue of deps pending recomputation. This is bound to a queue during - recomputation and restored afterwards, so it can also be used as a flag to - detect whether recomputation is happening.") - -(defun kick-dep (dep) - "Call when DEP's value (or good/bad state) has changed. Marks the - dependents of DEP as :pending, if they're currently :stable, and then - clears the dependent list. Also invokes DEP's listener functions." - (dolist (d (dep-dependents dep)) - (when (eq (dep-state d) :stable) - (enqueue d *pending-deps*) - (setf (dep-state d) :pending))) - (setf (dep-dependents dep) nil) - (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)) - (unwind-protect - (catch 'dep-bad - (setf (dep-state dep) :recomputing) - (when (update-dep dep (let ((*evaluating-dep* dep)) - (funcall (dep-value-func dep)))) - (kick-dep dep)) - (setf winning t)) - (unless winning - (when (update-dep dep nil nil) - (kick-dep dep)))))) - -(defun recompute-deps () - "Recompute all the pending deps, and any others that depend on them." - (unwind-protect - (loop (when (queue-emptyp *pending-deps*) - (return)) - (let ((dep (dequeue *pending-deps*))) - (when (eq (dep-state dep) :pending) - (recompute-dep dep)))) - (loop (when (queue-emptyp *pending-deps*) - (return)) - (let ((d (dequeue *pending-deps*))) - (setf (dep-state d) :stable - (dep-goodp d) nil))))) - -(defun ensure-dep-has-value (dep) - "Ensure that DEP has a stable value. If DEP is currently computing, - signals an error." - (ecase (dep-state dep) - (:stable) - (:pending - (recompute-dep dep)) - (:recomputing - (error "Ouch! Cyclic dependency.")))) - -(defun pulse-dep (dep) - "Notifies DEP of a change in its value. If a recomputation phase is - currently under way, queue the dependents and leave fixing things up to - the outer loop; otherwise start up a recomputation phase." - (if *pending-deps* - (kick-dep dep) - (let ((*pending-deps* (make-queue))) - (kick-dep dep) - (recompute-deps)))) - -(defun (setf dep-value) (value dep) - "Set DEP's value to be VALUE (and mark it as being good)." - (when (dep-value-func dep) - (error "Not a leaf dep.")) - (when (update-dep dep value) - (pulse-dep dep)) - value) - -(defun dep-make-bad (dep) - "Mark DEP as being bad." - (when (dep-value-func dep) - (error "Not a leaf dep.")) - (when (update-dep dep nil nil) - (pulse-dep dep))) - -(defun dep-add-listener (dep func) - "Add a listener function FUNC to the DEP. The FUNC is called each time the - DEP's value (or good/bad state) changes. It is called with no arguments, - and its return value is ignored." - (push func (dep-listeners dep))) - -(defun dep-value (dep) - "Retrieve the current value from DEP." - (when *evaluating-dep* - (pushnew *evaluating-dep* (dep-dependents dep))) - (ensure-dep-has-value dep) - (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil))) - -(defun make-dep (value-func) - "Create a new DEP with the given VALUE-FUNC." - (let ((dep (%make-dep :value-func value-func))) - (let ((*pending-deps* (make-queue))) - (enqueue dep *pending-deps*) - (recompute-deps)) - dep)) - -(defun make-leaf-dep (&optional (value nil goodp)) - "Creates a new DEP with the given VALUE, if any." - (%make-dep :%value value :goodp goodp :state :stable)) - -(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))) - -(defun dep-bad () - "Call from a value-func: indicates that the dep should marked as bad." - (throw 'dep-bad nil)) - -#+ no -(defmethod print-object ((dep dep) stream) - (print-unreadable-object (dep stream :type t :identity t) - (ensure-dep-has-value dep) - (if (dep-goodp dep) - (format stream ":GOOD ~W" (dep-%value dep)) - (format stream ":BAD")))) - -#+ test -(progn - (defparameter x (make-leaf-dep 1)) - (defparameter y (make-leaf-dep 2)) - (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y))))) - (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z))))) - (dep-add-listener x (lambda () (format t "x now ~A~%" x))) - (dep-add-listener z (lambda () (format t "z now ~A~%" z))) - (dep-add-listener w (lambda () (format t "w now ~A~%" w)))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/dep.lisp b/dep.lisp new file mode 120000 index 0000000..961d986 --- /dev/null +++ b/dep.lisp @@ -0,0 +1 @@ +lisp/dep.lisp \ No newline at end of file