From 23bc61bdf1dd3d1bda9884eac836a603a96dd053 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 9 Jun 2008 23:50:35 +0100
Subject: [PATCH 01/16] dep: Provide semantics for setting the value of a
 non-leaf dep.

The behaviour is that we recompute the rest of the system as usual, but
retain dependencies on the deps that the value-function examines.

We do more: it's now possible for cycles to occur in the dependency
graph, as long as a value is explicitly set somewhere in the cycle,
which effectively breaks it.  Cycles of purely computational deps are
still considered to be meaningless, and therefore forbidden.

Finally, we note that DELAY-RECOMPUTING-DEPS can be used to set
explicitly the values of a number of deps simultaneously, even if their
value functions would otherwise forbid it.
---
 dep.lisp | 169 ++++++++++++++++++++++++++++++++++++---------------------------
 1 file changed, 97 insertions(+), 72 deletions(-)

diff --git a/dep.lisp b/dep.lisp
index 5903743..c2d1008 100644
--- a/dep.lisp
+++ b/dep.lisp
@@ -24,7 +24,7 @@
 (defpackage #:dep
   (:use #:common-lisp #:queue)
   (:export #:dep #:depp #:make-dep #:dep-goodp
-	   :delay-recomputing-deps
+	   #:delay-recomputing-deps
 	   #:install-dep-syntax
 	   #:dep-value #:dep-make-bad #:dep-bad #:dep-try
 	   #:dep-add-listener))
@@ -33,6 +33,21 @@
 ;;;--------------------------------------------------------------------------
 ;;; Dependencies.
 
+(defvar *generation* (list '*generation*)
+  "Generation marker, used to remember when we last updated a particular dep.
+   Essentially, if the dep's generation matches *GENERATION* then it doesn't
+   need updating again.")
+
+(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.")
+
 (defstruct (dep (:predicate depp)
 		(:constructor %make-dep))
   "There are two kinds of `dep', though we use the same object type for both.
@@ -50,23 +65,15 @@
   (value-predicate #'eql :type function)
   (goodp nil :type boolean)
   (state :pending :type (member :stable :pending :recomputing))
+  (generation *generation* :type list)
   (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."
+  (setf (dep-generation dep) *generation*)
   (dolist (d (dep-dependents dep))
     (when (eq (dep-state d) :stable)
       (enqueue d *pending-deps*)
@@ -96,17 +103,18 @@
 (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))))))
+  (unless (eq (dep-generation dep) *generation*)
+    (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."
@@ -136,26 +144,27 @@
   "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))))
+  (setf *generation* (list '*generation*))
+  (flet ((kick (dep)
+	   (kick-dep dep)
+	   (when (dep-value-func dep)
+	     (catch 'dep-bad
+	       (let ((*evaluating-dep* dep))
+		 (funcall (dep-value-func dep)))))))
+    (if *pending-deps*
+	(kick dep)
+	(let ((*pending-deps* (make-queue)))
+	  (kick 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))
+  (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)))
+  (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
@@ -173,56 +182,63 @@
 (defun make-dep (&rest args)
   "Create a new DEP object.  There are two basic argument forms:
 
-   (:leaf &optional OBJECT)
+   (:value &optional OBJECT)
 	Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
-	dep is initially bad.
+	dep is initially bad.  The keyword :leaf is accepted as a synonym.
 
    (:function FUNCTION)
 	Return a non-leaf dep whose value is computed by FUNCTION.
 
-   Additionally, if the first argument is something other than :leaf or
-   :function (ideally not a keyword, for forward compatibility), then the
+   Additionally, if the first argument is something other than :VALUE or
+   :FUNCTION (ideally not a keyword, for forward compatibility), then the
    first argument is inspected: if it's a function, then a function dep is
    retuerned (as if you'd specified :function); otherwise a leaf dep is
    returned.
 
+   Finally, it's possible to specify both :value and :function
+   simultaneously; this will set the initial values as requested, but
+   recompute them as necessary.  It is possible to establish dependency
+   cycles, but you need to suppress recomputation in order to do this
+   correctly -- see the DELAY-RECOMPUTING-DEPS macro.
+
    If no arguments are given, a bad leaf dep is returned."
 
-  (flet ((arg (&optional (default nil defaultp))
-	   (cond (args (pop args))
-		 (defaultp default)
-		 (t (error "Not enough arguments to MAKE-DEP.")))))
+  (flet ((arg () (if args (pop args)
+		     (error "Not enough arguments to MAKE-DEP."))))
 
     ;; Sort out the arguments.
-    (multiple-value-bind (type value goodp)
-      (if (null args)
-	  (values :leaf nil nil)
-	  (let ((indicator (pop args)))
-	    (cond ((eq indicator :leaf)
-		   (if args
-		       (values :leaf (pop args) t)
-		       (values :leaf nil nil)))
-		  ((eq indicator :function)
-		   (values :function (arg) nil))
-		  ((functionp indicator)
-		   (values :function indicator nil))
-		  (t
-		   (values :leaf indicator t)))))
-      (unless (endp args)
-	(error "Excess arguments to MAKE-DEP."))
+    (let ((value nil)
+	  (valuep nil)
+	  (function nil))
+      (do () ((endp args))
+	(let ((indicator (pop args)))
+	  (cond ((or (eq indicator :value)
+		     (eq indicator :leaf))
+		 (if args
+		     (setf value (pop args) valuep t)
+		     (setf value nil valuep t)))
+		((eq indicator :function)
+		 (setf function (arg)))
+		((functionp indicator)
+		 (setf function indicator))
+		(t
+		 (setf value indicator valuep t)))))
 
       ;; Create the object appropriately.
-      (case type
-	(:function
-	 (let ((dep (%make-dep :value-func value :state :pending)))
-	   (if *pending-deps*
-	       (enqueue dep *pending-deps*)
+      (let ((dep (%make-dep :value-func function
+			    :%value value
+			    :state (if valuep :stable :pending)
+			    :generation (if function nil *generation*)
+			    :goodp valuep)))
+	(cond ((not function) t)
+	      (valuep (pulse-dep dep))
+	      (*pending-deps*
+	       (enqueue dep *pending-deps*))
+	      (t
 	       (let ((*pending-deps* (make-queue)))
 		 (enqueue dep *pending-deps*)
-		 (recompute-deps)))
-	   dep))
-	(:leaf
-	 (%make-dep :%value value :goodp goodp :state :stable))))))
+		 (recompute-deps))))
+	  dep))))
 
 (defmacro dep-try (expr &body body)
   "Evaluate EXPR.  If it throws dep-bad then evaluate BODY instead."
@@ -237,12 +253,13 @@
   (throw 'dep-bad nil))
 
 (defun delay-recomputing-deps* (thunk)
-  "The guts of the DELAY-RECOMPUTATING-DEPS macro.  Evaluate THUNK without
+  "The guts of the DELAY-RECOMPUTING-DEPS macro.  Evaluate THUNK without
    immediately updating dependencies until THUNK finishes.  Returns the
    value(s) of THUNK."
   (if *pending-deps*
       (funcall thunk)
       (let ((*pending-deps* (make-queue)))
+	(setf *generation* (list '*generation*))
 	(multiple-value-prog1
 	    (funcall thunk)
 	  (recompute-deps)))))
@@ -257,9 +274,17 @@
    recomputed as necessary); higher-level dependents won't be noticed until
    the direct dependents are recomputed.
 
-   This form is intended to be used for bulk update to leaves, for which
-   purpose it is fairly safe."
-  `(delay-recomputating-deps* #'(lambda () ,@body)))
+   It can be used to apply a number of updates simultaneously to the system.
+   This is useful for two reasons:
+
+     * Firstly, it avoids the computational overheads of propagating changes
+       repeatedly, so it can be used as a simple optimization.
+
+     * Secondly, and perhaps more interestingly, it allows the values of
+       mutually-dependent deps to be set simultaneously, even though the
+       values being set may not be compatible with the deps' value
+       functions."
+  `(delay-recomputing-deps* #'(lambda () ,@body)))
 
 (defun install-dep-syntax (&optional (readtable *readtable*))
   "Installs into the given READTABLE some syntactic shortcuts:
-- 
2.11.0


From 8f96789a867b163e71781dc2599ae217bfe35ae4 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 10 Jun 2008 12:36:10 +0100
Subject: [PATCH 02/16] weak: Uniform interface to weak pointers.

---
 mdw.asd   |  1 +
 weak.lisp | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 62 insertions(+)
 create mode 100644 weak.lisp

diff --git a/mdw.asd b/mdw.asd
index 0dc10a7..51f5981 100644
--- a/mdw.asd
+++ b/mdw.asd
@@ -13,6 +13,7 @@
 	       (:file "sys-base")
 	       (:file "factorial")
 	       (:file "queue")
+	       (:file "weak")
 	       (:file "dep" :depends-on ("queue"))
 	       (:file "mdw-mop" :depends-on ("mdw-base"))
 	       (:file "str" :depends-on ("mdw-base"))
diff --git a/weak.lisp b/weak.lisp
new file mode 100644
index 0000000..ff7c9c3
--- /dev/null
+++ b/weak.lisp
@@ -0,0 +1,61 @@
+;;; -*-lisp-*-
+;;;
+;;; Weak pointers and data structures
+;;;
+;;; (c) 2008 Straylight/Edgeware
+;;;
+
+;;;----- 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.
+
+(cl:defpackage #:weak
+  (:use #:common-lisp)
+  #+sbcl
+    (:import-from #:sb-ext #:make-weak-pointer #:weak-pointer-value)
+  #+(or cmu clisp)
+    (:import-from #:ext #:make-weak-pointer #:weak-pointer-value)
+  (:export #:make-weak-pointer #:weak-pointer-value))
+(cl:in-package #:weak)
+
+#+(or allegro common-lispworks)
+(progn
+  (defun make-weak-pointer (object)
+    (make-array 1 :initial-contents (list object) :weak t))
+  (defun weak-pointer-value (weak)
+    (aref weak 0)))
+
+#+ecl
+(progn
+  (defun make-weak-pointer (object)
+    (ffi:c-inline (object) (:object) :pointer-void
+      "{ cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
+	 *weak = #0;
+	 GC_general_register_disappearing_link(weak, GC_base(#0));
+	 @(return) = weak; }"
+      :one-liner nil))
+  (defun weak-pointer-value (weak)
+    (ffi:c-inline (weak) (:pointer-void) (values :object :object)
+      "{ cl_object *weak = #0;
+	 if (*weak) { @(return 0) = *weak; @(return 1) = @t; }
+	 else { @(return 0) = @nil; @(return 1) = @nil; } }"
+      :one-liner nil)))
+
+#-(or sbcl cmu clisp allegro common-lispworks ecl)
+(progn
+  (defun make-weak-pointer (object) object)
+  (defun weak-pointer-value (weak) (values weak t)))
+
+;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0


From 5f61c96135dd8b0e795f6e1e5d96708347fc8f5e Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 10 Jun 2008 12:36:50 +0100
Subject: [PATCH 03/16] dep: Use weak pointers for maintaining dependents.

---
 dep.lisp | 51 ++++++++++++++++++++++++++++++---------------------
 mdw.asd  |  2 +-
 2 files changed, 31 insertions(+), 22 deletions(-)

diff --git a/dep.lisp b/dep.lisp
index c2d1008..7220975 100644
--- a/dep.lisp
+++ b/dep.lisp
@@ -22,7 +22,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:dep
-  (:use #:common-lisp #:queue)
+  (:use #:common-lisp #:queue #:weak)
   (:export #:dep #:depp #:make-dep #:dep-goodp
 	   #:delay-recomputing-deps
 	   #:install-dep-syntax
@@ -67,17 +67,19 @@
   (state :pending :type (member :stable :pending :recomputing))
   (generation *generation* :type list)
   (listeners nil :type list)
-  (dependents nil :type list))
+  (dependents nil :type list)
+  (weak-pointer nil :type t))
 
 (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."
   (setf (dep-generation dep) *generation*)
-  (dolist (d (dep-dependents dep))
-    (when (eq (dep-state d) :stable)
-      (enqueue d *pending-deps*)
-      (setf (dep-state d) :pending)))
+  (dolist (dweak (dep-dependents dep))
+    (let ((d (weak-pointer-value dweak)))
+      (when (and d (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)))
@@ -108,7 +110,8 @@
       (unwind-protect
 	   (catch 'dep-bad
 	     (setf (dep-state dep) :recomputing)
-	     (when (update-dep dep (let ((*evaluating-dep* dep))
+	     (when (update-dep dep (let ((*evaluating-dep*
+					  (dep-weak-pointer dep)))
 				     (funcall (dep-value-func dep))))
 	       (kick-dep dep))
 	     (setf winning t))
@@ -149,7 +152,7 @@
 	   (kick-dep dep)
 	   (when (dep-value-func dep)
 	     (catch 'dep-bad
-	       (let ((*evaluating-dep* dep))
+	       (let ((*evaluating-dep* (dep-weak-pointer dep)))
 		 (funcall (dep-value-func dep)))))))
     (if *pending-deps*
 	(kick dep)
@@ -209,27 +212,33 @@
     ;; Sort out the arguments.
     (let ((value nil)
 	  (valuep nil)
+	  (predicate #'eql)
 	  (function nil))
       (do () ((endp args))
 	(let ((indicator (pop args)))
-	  (cond ((or (eq indicator :value)
-		     (eq indicator :leaf))
-		 (if args
-		     (setf value (pop args) valuep t)
-		     (setf value nil valuep t)))
-		((eq indicator :function)
-		 (setf function (arg)))
-		((functionp indicator)
-		 (setf function indicator))
-		(t
-		 (setf value indicator valuep t)))))
+	  (case indicator
+	    ((:value :leaf)
+	     (if args
+		 (setf value (pop args) valuep t)
+		 (setf value nil valuep t)))
+	    (:function
+	     (setf function (arg)))
+	    (:predicate
+	     (setf predicate (arg)))
+	    (t
+	     (cond ((functionp indicator)
+		    (setf function indicator))
+		   (t
+		    (setf value indicator valuep t)))))))
 
       ;; Create the object appropriately.
       (let ((dep (%make-dep :value-func function
 			    :%value value
 			    :state (if valuep :stable :pending)
+			    :value-predicate predicate
 			    :generation (if function nil *generation*)
 			    :goodp valuep)))
+	(setf (dep-weak-pointer dep) (make-weak-pointer dep))
 	(cond ((not function) t)
 	      (valuep (pulse-dep dep))
 	      (*pending-deps*
@@ -326,8 +335,8 @@
 
 #+ test
 (progn
-  (defparameter x (make-leaf-dep 1))
-  (defparameter y (make-leaf-dep 2))
+  (defparameter x (make-dep 1))
+  (defparameter y (make-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)))
diff --git a/mdw.asd b/mdw.asd
index 51f5981..8a91809 100644
--- a/mdw.asd
+++ b/mdw.asd
@@ -14,7 +14,7 @@
 	       (:file "factorial")
 	       (:file "queue")
 	       (:file "weak")
-	       (:file "dep" :depends-on ("queue"))
+	       (:file "dep" :depends-on ("queue" "weak"))
 	       (:file "mdw-mop" :depends-on ("mdw-base"))
 	       (:file "str" :depends-on ("mdw-base"))
 	       (:file "collect" :depends-on ("mdw-base"))
-- 
2.11.0


From 6d23b6ba1cdc4a0667b4534936b76357d3d176e7 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 10 Jun 2008 19:33:06 +0100
Subject: [PATCH 04/16] weak: Kill race condition in ECL weak pointer
 implementation.

---
 weak.lisp | 24 +++++++++++++++---------
 1 file changed, 15 insertions(+), 9 deletions(-)

diff --git a/weak.lisp b/weak.lisp
index ff7c9c3..b7325d7 100644
--- a/weak.lisp
+++ b/weak.lisp
@@ -39,18 +39,24 @@
 
 #+ecl
 (progn
+  (ffi:clines
+   "static GC_PTR fetch_obj(GC_PTR p) { return *(cl_object *)p; }")
   (defun make-weak-pointer (object)
-    (ffi:c-inline (object) (:object) :pointer-void
-      "{ cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
-	 *weak = #0;
-	 GC_general_register_disappearing_link(weak, GC_base(#0));
-	 @(return) = weak; }"
+    (ffi:c-inline (object) (:object) :pointer-void "
+      {
+	cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
+	*weak = #0;
+	GC_general_register_disappearing_link(weak, GC_base(#0));
+	@(return) = weak;
+      }"
       :one-liner nil))
   (defun weak-pointer-value (weak)
-    (ffi:c-inline (weak) (:pointer-void) (values :object :object)
-      "{ cl_object *weak = #0;
-	 if (*weak) { @(return 0) = *weak; @(return 1) = @t; }
-	 else { @(return 0) = @nil; @(return 1) = @nil; } }"
+    (ffi:c-inline (weak) (:pointer-void) (values :object :object) "
+      {
+	cl_object obj = GC_call_with_alloc_lock(fetch_obj, #0);
+	if (obj) { @(return 0) = obj; @(return 1) = @t; }
+	else { @(return 0) = @nil; @(return 1) = @nil; }
+      }"
       :one-liner nil)))
 
 #-(or sbcl cmu clisp allegro common-lispworks ecl)
-- 
2.11.0


From dd33a77309be7d492ef49bfdacbc131abe1ddced Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 16 Jun 2008 23:27:32 +0100
Subject: [PATCH 05/16] queue: Allow stuff to be pushed on the front.

---
 queue.lisp | 15 ++++++++++++---
 1 file changed, 12 insertions(+), 3 deletions(-)

diff --git a/queue.lisp b/queue.lisp
index 03de433..49c69c5 100644
--- a/queue.lisp
+++ b/queue.lisp
@@ -23,7 +23,7 @@
 
 (defpackage #:queue
   (:use #:common-lisp)
-  (:export #:make-queue #:queue-emptyp #:enqueue #:dequeue))
+  (:export #:make-queue #:queue-emptyp #:enqueue #:pushqueue #:dequeue))
 (in-package #:queue)
 
 (defun make-queue ()
@@ -45,6 +45,13 @@
     (setf (cdr (car q)) c
 	  (car q) c)))
 
+(defun pushqueue (x q)
+  "Push the object X onto the front of the queue Q."
+  (let* ((first (cdr q))
+	 (new (cons x first)))
+    (setf (cdr q) new)
+    (unless first (setf (car q) new))))
+
 (defun dequeue (q)
   "Remove and return the object at the head of the queue Q."
   (if (queue-emptyp q)
@@ -74,10 +81,12 @@
   (let ((q (make-queue))
 	(want nil))
     (dotimes (i 10000)
-      (case (random 2)
+      (case (random 3)
 	(0 (setf want (nconc want (list i)))
 	   (enqueue i q))
-	(1 (if (null want)
+	(1 (push i want)
+	   (pushqueue i q))
+	(2 (if (null want)
 	       (assert (queue-emptyp q))
 	       (progn
 		 (let ((j (dequeue q))
-- 
2.11.0


From af33e77c00654c222a8a04a5e69a5eb1f56c1e8c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 16 Jun 2008 23:27:44 +0100
Subject: [PATCH 06/16] dep: Major overhaul.

The previous implementation was just fundamentally incorrect.  The new
version is somewhat better organized (though fairly similar
superficially) and documented, and actually (I think) correct.

Changes include:

  * DELAY-RECOMPUTING-DEPS has been renamed to WITH-DEPS-FROZEN.  The
    new version is semantically slightly different: it's the only point
    which actually triggers recomputation.  It has also grown the
    ability to defer its body until after the current recomputation
    phase is complete.

  * It is now a (diagnosed) error to attempt to modify a dep during
    recomputation; modifications can be deferred explicitly, though
    doing this sort of thing automatically seems a bad idea.
---
 dep.lisp | 540 ++++++++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 361 insertions(+), 179 deletions(-)

diff --git a/dep.lisp b/dep.lisp
index 7220975..8a9410d 100644
--- a/dep.lisp
+++ b/dep.lisp
@@ -23,15 +23,32 @@
 
 (defpackage #:dep
   (:use #:common-lisp #:queue #:weak)
-  (:export #:dep #:depp #:make-dep #:dep-goodp
-	   #:delay-recomputing-deps
+  (:export #:dep #:depp #:make-dep #:dep-goodp #:dep-name
+	   #:with-deps-frozen
 	   #:install-dep-syntax
 	   #:dep-value #:dep-make-bad #:dep-bad #:dep-try
 	   #:dep-add-listener))
 (in-package #:dep)
 
 ;;;--------------------------------------------------------------------------
-;;; Dependencies.
+;;; Constants.
+
+(defconstant +value+ 1
+  "Flag: dep's value is up-to-date.")
+(defconstant +deps+ 2
+  "Flag: dep is known as a dependent on its dependencies.")
+(defconstant +changed+ 4
+  "Flag: dep has changed in the current recomputation phase.")
+(defconstant +recomputing+ 8
+  "Flag: dep is currently being recomputed.")
+(defconstant +queued+ 16
+  "Flag: dep is currently on the queue for recomputation.")
+
+(defconstant .bad. '.bad.
+  "Magical value used to indicate bad deps.")
+
+;;;--------------------------------------------------------------------------
+;;; Global and special variables.
 
 (defvar *generation* (list '*generation*)
   "Generation marker, used to remember when we last updated a particular dep.
@@ -40,13 +57,34 @@
 
 (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
+   a value-function, and is used to track the dependencies implied during the
    function's evaluation.")
 
+(defvar *state* :ready
+  "The current state.  It may be any of:
+
+     * :READY -- the usual state: everything is up-to-date and correct.
+
+     * :FROZEN -- the state used to evaluate the body of WITH-DEPS-FROZEN.
+       Deps may be assigned values, but their dependents are not immediately
+       recomputed.
+
+     * :RECOMPUTING -- the state imposed while updating dependents.")
+
+(defvar *delayed-operations* nil
+  "A queue of operations delayed by WITH-DEPS-FROZEN.  Only available in the
+   :RECOMPUTING state.")
+
 (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.")
+   detect whether recomputation is happening.
+
+   Deps on the queue are always in the current generation, and have the
+   +QUEUED+ flag set.")
+
+;;;--------------------------------------------------------------------------
+;;; Data structures.
 
 (defstruct (dep (:predicate depp)
 		(:constructor %make-dep))
@@ -60,114 +98,257 @@
    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 .bad. :type t)
+  (name nil :type t)
+  (value-function nil :type (or function null))
   (value-predicate #'eql :type function)
-  (goodp nil :type boolean)
-  (state :pending :type (member :stable :pending :recomputing))
+  (%flags 0 :type (unsigned-byte 8))
   (generation *generation* :type list)
   (listeners nil :type list)
   (dependents nil :type list)
+  (dependencies nil :type list)
   (weak-pointer nil :type t))
 
-(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."
-  (setf (dep-generation dep) *generation*)
+;;;--------------------------------------------------------------------------
+;;; Main code.
+
+(declaim (inline dep-flags))
+(defun dep-flags (dep)
+  "Return the current flags of DEP.
+
+   The flags are fetched from the object if we're in a recomputation phase
+   and the object's generation is current.  Otherwise the object's flags are
+   out of date, and we make up a better set."
+  (cond ((eq *state* :ready) (logior +value+ +deps+))
+	((eq (dep-generation dep) *generation*) (dep-%flags dep))
+	((not (dep-value-function dep)) (logior +value+ +deps+))
+	(t 0)))
+
+(declaim (inline (setf dep-flags)))
+(defun (setf dep-flags) (flags dep)
+  "Set the DEP's flags.
+
+   This doesn't do anything else like force DEP's generation."
+  (setf (dep-%flags dep) flags))
+
+(defun update-dep (dep value)
+  "Modify the value of DEP.
+
+   If DEP's value is now different (according to its badness or
+   value-predicate) then return true; otherwise return false."
+  (let ((old-value (dep-%value dep)))
+    (if (if (eq value .bad.)
+	    (eq old-value .bad.)
+	    (and (not (eq old-value .bad.))
+		 (funcall (dep-value-predicate dep) value old-value)))
+	nil
+	(progn (setf (dep-%value dep) value) t))))
+
+(defun new-dep-value (dep)
+  "Recompute and return the value of DEP, or .BAD. if the dep is bad.
+
+   This function is very minimal.  The caller expected to deal with many
+   aspects of caring for and feeding DEP.  In particular:
+
+     * Non-local exits (except throwing DEP-BAD) are not handled here.
+
+     * We assume that DEP is already in the current generation, and has its
+       +RECOMPUTING+ flag set.
+
+     * The caller is responsible for setting the current flags afterwards."
+  (catch 'dep-bad
+    (let ((*evaluating-dep* dep))
+      (setf (dep-dependencies dep) nil)
+      (funcall (dep-value-function dep)))))
+
+(defun propagate-to-dependents (dep)
+  "Notify the dependents of DEP of a change to its value.
+
+   We assume that DEP is up-to-date in the current generation, and has
+   correct flags (at least +VALUE+ and +CHANGED+, and maybe +DEPS+).
+   Dependents of DEP are enqueued for recomputation.  The DEP's dependents
+   are forced into the current generation and enqueued, and the dependents
+   list is cleared ready to be repopulated.  The DEP's listener functions are
+   invoked."
   (dolist (dweak (dep-dependents dep))
     (let ((d (weak-pointer-value dweak)))
-      (when (and d (eq (dep-state d) :stable))
-	(enqueue d *pending-deps*)
-	(setf (dep-state d) :pending))))
+      (when d
+	(let ((flags (dep-flags d)))
+	  (unless (plusp (logand flags (logior +queued+ +deps+)))
+	    (enqueue d *pending-deps*)
+	    (setf (dep-generation d) *generation*
+		  (dep-flags d) (logior (logand flags +value+)
+					+queued+)))))))
   (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."
-  (unless (eq (dep-generation dep) *generation*)
-    (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) (queued (logand (dep-%flags dep) +queued+)))
+    (flet ((update (value)
+	     (cond ((update-dep dep value)
+		    (setf (dep-flags dep) (logior +value+ +deps+ +changed+
+						  queued))
+		    (propagate-to-dependents dep)
+		    t)
+		   (t
+		    (setf (dep-flags dep) (logior +value+ +deps+ queued))
+		    nil))))
       (unwind-protect
-	   (catch 'dep-bad
-	     (setf (dep-state dep) :recomputing)
-	     (when (update-dep dep (let ((*evaluating-dep*
-					  (dep-weak-pointer 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))
+	   (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."
+  (when *evaluating-dep*
+    (pushnew (dep-weak-pointer *evaluating-dep*) (dep-dependents dep))
+    (pushnew dep (dep-dependencies *evaluating-dep*)))
+  (force-dep-value dep))
+
+(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)))
+
+(defun dep-goodp (dep)
+  "Answer whether DEP is good."
+  (when (eq *state* :recomputing)
+    (force-dep-value dep))
+  (not (eq (dep-%value dep) .bad.)))
+
+(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-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))
+    (unwind-protect
+	 (loop (when (queue-emptyp *pending-deps*)
+		 (return))
+	       (let* ((dep (dequeue *pending-deps*))
+		      (flags (dep-%flags dep)))
+		 (setf (dep-%flags dep) (logandc2 flags +queued+))
+		 (cond ((zerop (logand flags +value+))
+			(recompute-dep-value dep))
+		       ((zerop (logand flags +deps+))
+			(new-dep-value dep)
+			(setf (dep-%flags dep) (logior flags +deps+))))))
+      (loop (when (queue-emptyp *pending-deps*)
+	      (return))
+	    (let ((d (dequeue *pending-deps*)))
+	      (setf (dep-%value d) .bad.))))))
+
+(defun with-deps-frozen* (thunk &key delay)
+  "Invoke THUNK in the :FROZEN state.  See WITH-DEPS-FROZEN for full
+   information."
+  (ecase *state*
+    (:frozen
+     (funcall thunk))
     (: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."
-  (setf *generation* (list '*generation*))
-  (flet ((kick (dep)
-	   (kick-dep dep)
-	   (when (dep-value-func dep)
-	     (catch 'dep-bad
-	       (let ((*evaluating-dep* (dep-weak-pointer dep)))
-		 (funcall (dep-value-func dep)))))))
-    (if *pending-deps*
-	(kick dep)
-	(let ((*pending-deps* (make-queue)))
-	  (kick dep)
-	  (recompute-deps)))))
+     (unless delay
+       (error "This really isn't a good time."))
+     (enqueue thunk *delayed-operations*))
+    (:ready
+     (let ((*state* :frozen)
+	   (*delayed-operations* (make-queue))
+	   (*pending-deps* (make-queue)))
+       (setf *generation* (list '*generation*))
+       (multiple-value-prog1 (funcall thunk)
+	 (loop (recompute-pending-deps)
+	       (when (queue-emptyp *delayed-operations*)
+		 (return))
+	       (funcall (dequeue *delayed-operations*))))))))
+
+(defmacro with-deps-frozen ((&key delay) &body body)
+  "Evaluate BODY in the :FROZEN state.
+
+   In the :FROZEN state, recomutation is deferred.  If the current state is
+   :READY, then we enter :FROZEN, evaluate the BODY, and then enter
+   :RECOMPUTING to fix up the dependency graph.  If the current state is
+   :FROZEN, we do nothing particularly special.  Finally, if the current
+   state is :RECOMPUTING then the behaviour depends on the value of
+   the :DELAY argument: if false, an error is signalled; if true, the
+   evaluation is postponed until the end of the recomputation.
+
+   This macro has four immediate uses.
+
+     * Firstly, it's actually the only way to trigger recomputation at all.
+       It's invoked behind the scenes to do the right thing.
+
+     * If you're making a large number of updates without data dependencies
+       then you can make them go faster by wrapping them in WITH-DEPS-FROZEN
+       and only having a single recomputation phase.
+
+     * A simple (SETF (DEP-VALUE ...) ...) is unsafe during recomputation.
+       You can use WITH-DEPS-FROZEN to indicate that it's safe to defer the
+       assignment until later.  Deferred operations take place in the order
+       in which they were requested.
+
+     * Finally, you can use it to force a number of deps to hold given values
+       simultaneously, despite their value-functions disagreeing."
+  `(with-deps-frozen* (lambda () ,@body) :delay ,delay))
 
 (defun (setf dep-value) (value dep)
-  "Set DEP's value to be VALUE (and mark it as being good)."
-  (when (update-dep dep value) (pulse-dep dep))
+  "Assign the VALUE to the DEP, forcing recomputation if necessary."
+  (with-deps-frozen ()
+    (when (update-dep dep value)
+      (setf (dep-generation dep) *generation*
+	    (dep-flags dep) (logior +value+ +changed+))
+      (propagate-to-dependents dep)))
   value)
 
 (defun dep-make-bad (dep)
   "Mark DEP as being bad."
-  (when (update-dep dep nil nil) (pulse-dep dep)))
+  (setf (dep-value dep) .bad.))
 
 (defun dep-add-listener (dep func)
   "Add a listener function FUNC to the DEP.  The FUNC is called each time the
@@ -175,19 +356,12 @@
    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 (&rest args)
   "Create a new DEP object.  There are two basic argument forms:
 
    (:value &optional OBJECT)
 	Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
-	dep is initially bad.  The keyword :leaf is accepted as a synonym.
+	dep is initially bad.  The keyword :LEAF is accepted as a synonym.
 
    (:function FUNCTION)
 	Return a non-leaf dep whose value is computed by FUNCTION.
@@ -198,7 +372,7 @@
    retuerned (as if you'd specified :function); otherwise a leaf dep is
    returned.
 
-   Finally, it's possible to specify both :value and :function
+   Finally, it's possible to specify both :VALUE and :FUNCTION
    simultaneously; this will set the initial values as requested, but
    recompute them as necessary.  It is possible to establish dependency
    cycles, but you need to suppress recomputation in order to do this
@@ -210,90 +384,50 @@
 		     (error "Not enough arguments to MAKE-DEP."))))
 
     ;; Sort out the arguments.
-    (let ((value nil)
+    (let ((value .bad.)
 	  (valuep nil)
+	  (name nil)
 	  (predicate #'eql)
+	  (listeners nil)
 	  (function nil))
       (do () ((endp args))
 	(let ((indicator (pop args)))
 	  (case indicator
 	    ((:value :leaf)
-	     (if args
-		 (setf value (pop args) valuep t)
-		 (setf value nil valuep t)))
+	     (setf value (if args (pop args) .bad.)
+		   valuep t))
 	    (:function
 	     (setf function (arg)))
 	    (:predicate
 	     (setf predicate (arg)))
+	    (:name
+	     (setf name (arg)))
+	    (:listener
+	     (push (arg) listeners))
 	    (t
 	     (cond ((functionp indicator)
 		    (setf function indicator))
 		   (t
-		    (setf value indicator valuep t)))))))
+		    (setf value indicator
+			  valuep t)))))))
+      (unless (or valuep function)
+	(setf valuep t))
 
       ;; Create the object appropriately.
-      (let ((dep (%make-dep :value-func function
+      (let ((dep (%make-dep :value-function function
 			    :%value value
-			    :state (if valuep :stable :pending)
+			    :name name
+			    :listeners listeners
+			    :%flags (logior (if valuep +value+ 0)
+					    (if function +queued+ +deps+)
+					    +changed+)
 			    :value-predicate predicate
-			    :generation (if function nil *generation*)
-			    :goodp valuep)))
+			    :generation *generation*)))
 	(setf (dep-weak-pointer dep) (make-weak-pointer dep))
-	(cond ((not function) t)
-	      (valuep (pulse-dep dep))
-	      (*pending-deps*
-	       (enqueue dep *pending-deps*))
-	      (t
-	       (let ((*pending-deps* (make-queue)))
-		 (enqueue dep *pending-deps*)
-		 (recompute-deps))))
-	  dep))))
-
-(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))
-
-(defun delay-recomputing-deps* (thunk)
-  "The guts of the DELAY-RECOMPUTING-DEPS macro.  Evaluate THUNK without
-   immediately updating dependencies until THUNK finishes.  Returns the
-   value(s) of THUNK."
-  (if *pending-deps*
-      (funcall thunk)
-      (let ((*pending-deps* (make-queue)))
-	(setf *generation* (list '*generation*))
-	(multiple-value-prog1
-	    (funcall thunk)
-	  (recompute-deps)))))
-
-(defmacro delay-recomputing-deps (&body body)
-  "Evaluate BODY, but delay recomputing any deps until the BODY completes
-   execution.
-
-   Note that deps can report incorrect values while delayed recomputation is
-   in effect.  In the current implementation, the direct dependents of a leaf
-   dep whose value has changed will be correctly marked as pending (and
-   recomputed as necessary); higher-level dependents won't be noticed until
-   the direct dependents are recomputed.
-
-   It can be used to apply a number of updates simultaneously to the system.
-   This is useful for two reasons:
-
-     * Firstly, it avoids the computational overheads of propagating changes
-       repeatedly, so it can be used as a simple optimization.
-
-     * Secondly, and perhaps more interestingly, it allows the values of
-       mutually-dependent deps to be set simultaneously, even though the
-       values being set may not be compatible with the deps' value
-       functions."
-  `(delay-recomputing-deps* #'(lambda () ,@body)))
+	(when function
+	  (with-deps-frozen ()
+	    (enqueue dep *pending-deps*)))
+	dep))))
 
 (defun install-dep-syntax (&optional (readtable *readtable*))
   "Installs into the given READTABLE some syntactic shortcuts:
@@ -324,23 +458,71 @@
 				readtable)
   readtable)
 
+#- abcl
 (defmethod print-object ((dep dep) stream)
   (print-unreadable-object (dep stream :type t :identity t)
-    (cond ((not (eq (dep-state dep) :stable))
-	   (format stream "~S" (dep-state dep)))
-	  ((dep-goodp dep)
-	   (format stream "~S ~W" :good (dep-%value dep)))
-	  (t
-	   (format stream "~S" :bad)))))
+    (pprint-logical-block (stream nil)
+      (let ((flags (dep-flags dep))
+	    (value (dep-%value dep)))
+	(cond ((zerop (logand flags +value+))
+	       (write-string "#<out-of-date>" stream))
+	      ((eq value .bad.)
+	       (write-string "#<bad>" stream))
+	      (t
+	       (write value :stream stream)))
+	(when (dep-name dep)
+	  (format stream " ~_~S ~@_~W" :name (dep-name dep)))
+	(when (zerop (logand flags +deps+))
+	  (format stream " ~_~S" :recompute-deps))
+	(when (plusp (logand flags +queued+))
+	  (format stream " ~_~S" :queued))
+	(when (plusp (logand flags +changed+))
+	  (format stream " ~_~S" :changed))))))
+
+;;;--------------------------------------------------------------------------
+;;; Tests.
 
 #+ test
 (progn
-  (defparameter x (make-dep 1))
-  (defparameter y (make-dep 2))
-  (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
-  (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
+  (defparameter x (make-dep :name 'x 1))
+  (defparameter y (make-dep :name 'y 2))
+  (defparameter z (make-dep :name 'z
+			    (lambda () (+ (dep-value x) (dep-value y)))))
+  (defparameter w (make-dep :name 'w
+			    (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))))
 
+#+ test
+(progn
+  (defparameter a (make-dep :name 'a 1))
+  (defparameter b (make-dep :name 'b 2))
+  (defparameter c (make-dep :name 'c
+			    (lambda () (1+ (dep-value a)))))
+  (defparameter d (make-dep :name 'd
+			    (lambda () (* (dep-value c) (dep-value b)))))
+  (defparameter e (make-dep :name 'e
+			    (lambda () (- (dep-value d) (dep-value a)))))
+  ;;  a   b   c = a + 1   d = c*b   e = d - a
+  ;;  1   2      2           4          3
+  ;;  4   2      5          10          6
+  (values (dep-value e)
+	  (progn
+	    (setf (dep-value a) 4)
+	    (dep-value e))))
+
+#+ test
+(progn
+  (defparameter x nil)
+  (defparameter y nil)
+  (with-deps-frozen ()
+    (setf x (make-dep :name 'x 1 (lambda () (+ (dep-value y) 1)))
+	  y (make-dep :name 'y 2 (lambda () (- (dep-value x) 2))))))
+
+#+ test
+(trace with-deps-frozen* update-dep new-dep-value force-dep-value
+       recompute-dep-value recompute-pending-deps propagate-to-dependents
+       dep-value)
+
 ;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0


From f36fbd9c42e8c151fc55de3efa1cb0520ba20927 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 10 Nov 2008 11:41:13 +0000
Subject: [PATCH 07/16] mdw-base: Replace (FORMAT T "~&") by (FRESH-LINE).

No idea why I wrote it like that in the first place.
---
 mdw-base.lisp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/mdw-base.lisp b/mdw-base.lisp
index a41b685..95b79de 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -66,7 +66,7 @@
   "Debugging tool: print the expression X and its values."
   (let ((tmp (gensym)))
     `(let ((,tmp (multiple-value-list ,x)))
-       (format t "~&")
+       (fresh-line)
        (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
 	 (format t
 		 "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
-- 
2.11.0


From 1cbc65e7d3d318b21fa3793676ad203a799e2206 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 26 Nov 2008 21:03:58 +0000
Subject: [PATCH 08/16] sys-base: Improve cl-launch support.

In particular, collect the command line and script name accurately.
---
 sys-base.lisp | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/sys-base.lisp b/sys-base.lisp
index fadbb87..bb1cd45 100644
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -41,16 +41,20 @@
 
 (defun set-command-line-arguments ()
   (setf *raw-command-line*
-	(or #+cl-launch cl-launch:*arguments*
+	(or (when (member :cl-launched *features*)
+	      (cons (or (funcall (intern "GETENV" (find-package :cl-launch))
+				 "CL_LAUNCH_FILE")
+			"<unknown-script>")
+		    (symbol-value (intern "*ARGUMENTS*"
+					  (find-package :cl-launch)))))
 	    #+cmu ext:*command-line-strings*
 	    #+sbcl sb-ext:*posix-argv*
 	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
 	    #+clisp (coerce (ext:argv) 'list)
 	    '("<unknown-lisp>" "--" "<unknown-script>")))
   (setf *command-line*
-	(or #+cl-launch (cons (or (cl-launch:getenv "CL_LAUNCH_FILE")
-				  "<unknown-script>")
-			      cl-launch:*arguments*)
+	(or (when (member :cl-launched *features*)
+	      *raw-command-line*)
 	    (cdr (member "--" *raw-command-line* :test #'string=))
 	    *raw-command-line*))
   (setf *program-name* (pathname-name (car *command-line*))))
-- 
2.11.0


From 460f9a0dd7568719bd102dc5df8d52b4d41423dd Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 26 Nov 2008 21:23:09 +0000
Subject: [PATCH 09/16] sys-base: Further cl-launch improvement.

If CL_LAUNCH_FILE is unset, assume that we've been invoked with the
program name as the first argument anyway.  We can arrange for this to
be the case fairly easily.

The problem is that

  #! /usr/bin/cl-launch -X ... --

doesn't work on Linux because cl-launch is a script.  Besides, it
hard-codes the path of cl-launch.  Putting

  #! /bin/sh
  #|
  exec cl-launch -f "$0" -- "$0" "$@"
  |#
  ... lisp here ...

seems sufficient for one-off Lisp scripts.
---
 sys-base.lisp | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/sys-base.lisp b/sys-base.lisp
index bb1cd45..904c165 100644
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -42,11 +42,14 @@
 (defun set-command-line-arguments ()
   (setf *raw-command-line*
 	(or (when (member :cl-launched *features*)
-	      (cons (or (funcall (intern "GETENV" (find-package :cl-launch))
-				 "CL_LAUNCH_FILE")
-			"<unknown-script>")
-		    (symbol-value (intern "*ARGUMENTS*"
-					  (find-package :cl-launch)))))
+	      (let* ((cll-package (find-package :cl-launch))
+		     (name (funcall (intern "GETENV" cll-package)
+				    "CL_LAUNCH_FILE"))
+		     (args (symbol-value (intern "*ARGUMENTS*"
+						 cll-package))))
+		(if name
+		    (cons name args)
+		    args)))
 	    #+cmu ext:*command-line-strings*
 	    #+sbcl sb-ext:*posix-argv*
 	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
-- 
2.11.0


From 48232c30457dba5a27e8d9ee6b49d18e224568e5 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 13 Jan 2009 22:29:49 +0000
Subject: [PATCH 10/16] optparse-test: Fix to use cl-launch with /bin/sh hack.

---
 optparse-test | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/optparse-test b/optparse-test
index cd1c4f9..da1028d 100755
--- a/optparse-test
+++ b/optparse-test
@@ -1,16 +1,12 @@
-#! /usr/local/bin/runlisp
+#! /bin/sh
+#|
+exec cl-launch -s mdw -i "(load \"$0\")" -- "$0" "$@" || exit 1
+|#
 
 (cl:defpackage #:optparse-test
-  (:use #:common-lisp))
+  (:use #:common-lisp #:optparse))
 (cl:in-package #:optparse-test)
 
-(let ((*compile-verbose* nil)
-      (*load-verbose* nil))
-  (asdf:oos 'asdf:load-op "mdw" :verbose nil))
-(handler-case
-    (use-package '#:optparse)
-  (error (c) (invoke-debugger c)))
-
 (defvar opt-bool nil)
 (defvar opt-int nil)
 (defvar opt-list nil)
-- 
2.11.0


From fee2e08f5f30a1b3a0665c63d1c85c8576da449f Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 9 Feb 2009 00:00:26 +0000
Subject: [PATCH 11/16] mdw-mop: Move DEFGENERIC of SLOT-DEFINITION-FILTER.

For some reason, it was between the two (implicit) method definitions
rather than before them.  This causes warnings, particularly from CLisp.
---
 mdw-mop.lisp | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index e813f97..7af8ad9 100644
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -221,13 +221,13 @@
     (Yes, I know that using functions would be nicer, but the MOP makes
     that surprisingly difficult.)"))
 
+(defgeneric slot-definition-filter (slot)
+  (:method ((slot slot-definition)) nil))
+
 (defclass filtered-direct-slot-definition
     (standard-direct-slot-definition)
   ((filter :initarg :filter :reader slot-definition-filter)))
 
-(defgeneric slot-definition-filter (slot)
-  (:method ((slot slot-definition)) nil))
-
 (defclass filtered-effective-slot-definition
     (standard-effective-slot-definition)
   ((filter :initarg :filter :accessor slot-definition-filter)))
-- 
2.11.0


From 003ebbaa2cf2a7bb71c65c35a8703b38508dea8d Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 9 Feb 2009 00:02:08 +0000
Subject: [PATCH 12/16] sys-base: Fix collection of command-line options for
 CLisp.

I don't like runlisp any more, and looking for its `--' marker is just
unsound.

Also zap *RAW-COMMAND-LINE* because it just isn't a very useful thing
to have around.
---
 sys-base.lisp | 12 ++++--------
 1 file changed, 4 insertions(+), 8 deletions(-)

diff --git a/sys-base.lisp b/sys-base.lisp
index 904c165..a8e23df 100644
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -35,12 +35,11 @@
   (:import-from #:runlisp #:*raw-command-line* #:*command-line* #:exit))
 (in-package #:mdw.sys-base)
 
-(defvar *raw-command-line*)
 (defvar *command-line*)
 (defvar *program-name*)
 
 (defun set-command-line-arguments ()
-  (setf *raw-command-line*
+  (setf *command-line*
 	(or (when (member :cl-launched *features*)
 	      (let* ((cll-package (find-package :cl-launch))
 		     (name (funcall (intern "GETENV" cll-package)
@@ -53,13 +52,10 @@
 	    #+cmu ext:*command-line-strings*
 	    #+sbcl sb-ext:*posix-argv*
 	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
-	    #+clisp (coerce (ext:argv) 'list)
+	    #+clisp (loop with argv = (ext:argv)
+		          for i from 7 below (length argv)
+			  collect (aref argv i))
 	    '("<unknown-lisp>" "--" "<unknown-script>")))
-  (setf *command-line*
-	(or (when (member :cl-launched *features*)
-	      *raw-command-line*)
-	    (cdr (member "--" *raw-command-line* :test #'string=))
-	    *raw-command-line*))
   (setf *program-name* (pathname-name (car *command-line*))))
 (set-command-line-arguments)
 
-- 
2.11.0


From d0754e55e97e5ae7c47a667a8580ca021174918d Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 18 Nov 2009 11:57:17 +0000
Subject: [PATCH 13/16] sys-base: Fix support for CL-LAUNCH.

Firstly, I got the feature wrong.  Secondly, fix the `defpackage' form
for `set-command-line-arguments'.
---
 sys-base.lisp | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/sys-base.lisp b/sys-base.lisp
index 904c165..b852eb3 100644
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -31,7 +31,7 @@
 (defpackage #:mdw.sys-base
   (:use #:common-lisp #:runlisp)
   (:export #:exit #:hard-exit #:*program-name* #:*command-line*
-	   set-command-line-arguments)
+	   #:set-command-line-arguments)
   (:import-from #:runlisp #:*raw-command-line* #:*command-line* #:exit))
 (in-package #:mdw.sys-base)
 
@@ -41,7 +41,7 @@
 
 (defun set-command-line-arguments ()
   (setf *raw-command-line*
-	(or (when (member :cl-launched *features*)
+	(or (when (member :cl-launch *features*)
 	      (let* ((cll-package (find-package :cl-launch))
 		     (name (funcall (intern "GETENV" cll-package)
 				    "CL_LAUNCH_FILE"))
-- 
2.11.0


From abd5cb6f7e0e603753a39dbab541e152f9e682d5 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 18 Nov 2009 12:12:58 +0000
Subject: [PATCH 14/16] optparse-test: Use better launch magic.

---
 optparse-test | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/optparse-test b/optparse-test
index da1028d..de0d6eb 100755
--- a/optparse-test
+++ b/optparse-test
@@ -1,7 +1,5 @@
 #! /bin/sh
-#|
-exec cl-launch -s mdw -i "(load \"$0\")" -- "$0" "$@" || exit 1
-|#
+":"; exec cl-launch -X -s mdw -- "$0" "$@" || exit 1 # -*-lisp-*-
 
 (cl:defpackage #:optparse-test
   (:use #:common-lisp #:optparse))
-- 
2.11.0


From 7413889adaf31a00d1f71598f221f0155d015dab Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 28 Apr 2009 11:19:09 +0100
Subject: [PATCH 15/16] safely: Fix useless use of APPLY in SAFELY-WRITING.

Not quite sure what I was thinking.
---
 safely.lisp | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/safely.lisp b/safely.lisp
index b5d7ff8..2477f9a 100644
--- a/safely.lisp
+++ b/safely.lisp
@@ -237,8 +237,7 @@
    temporary file, and if BODY completes, it is renamed to FILE."
   (with-gensyms safe
     `(safely (,safe)
-       (let ((,stream (apply #'safely-open-output-stream
-			     ,safe ,file ,open-args)))
+       (let ((,stream (safely-open-output-stream ,safe ,file ,@open-args)))
 	 ,@body))))
 
 ;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0


From 3cb9d624f65d603d49bc48bb78af24145615a63a Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 10 Jun 2008 12:07:52 +0100
Subject: [PATCH 16/16] str: Handy functions for testing prefixes/suffixes.

---
 str.lisp | 29 ++++++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/str.lisp b/str.lisp
index 94a58a4..5cf05aa 100644
--- a/str.lisp
+++ b/str.lisp
@@ -25,7 +25,8 @@
 
 (defpackage #:mdw.str
   (:use #:common-lisp #:mdw.base)
-  (:export #:join-strings #:str-next-word #:str-split-words))
+  (:export #:join-strings #:str-next-word #:str-split-words
+	   #:str-beginsp #:str-endsp))
 (in-package #:mdw.str)
 
 (defun join-strings (del strs)
@@ -134,4 +135,30 @@
 	 (incf n)))
     (nreverse l)))
 
+(declaim (inline str-beginsp))
+(defun str-beginsp (string prefix &key (start1 0) end1 (start2 0) end2)
+  "Returns true if STRING (or the appropriate substring of it) begins with
+   PREFIX."
+  (setf-default end1 (length string)
+		end2 (length prefix))
+  (let ((strlen (- end1 start1))
+	(prelen (- end2 start2)))
+    (and (>= strlen prelen)
+	 (string= string prefix
+		  :start1 start1 :end1 (+ start1 prelen)
+		  :start2 start2 :end2 end2))))
+
+(declaim (inline str-endsp))
+(defun str-endsp (string suffix &key (start1 0) end1 (start2 0) end2)
+  "Returns true if STRING (or the appropriate substring of it) ends with
+   SUFFIX."
+  (setf-default end1 (length string)
+		end2 (length suffix))
+  (let ((strlen (- end1 start1))
+	(suflen (- end2 start2)))
+    (and (>= strlen suflen)
+	 (string= string suffix
+		  :start1 (- end1 suflen) :end1 end1
+		  :start2 start2 :end2 end2))))
+
 ;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0