From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 16 Jun 2008 22:11:14 +0000 (+0100)
Subject: Initial revision.
X-Git-Tag: 1.0.0^0
X-Git-Url: https://git.distorted.org.uk/~mdw/jlisp/commitdiff_plain/ee79a5f1df1962cf0106af22c8cf3a30bf126454?ds=sidebyside

Initial revision.

Coincidentally, this was also the first release.
---

ee79a5f1df1962cf0106af22c8cf3a30bf126454
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..2832b88
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,73 @@
+ABCL_JAR = /usr/local/src/abcl-0.0.10/abcl.jar
+JAVAC = javac
+JAR = jar
+GPL = /usr/share/common-licenses/GPL-2
+INSTALLER = setup-dep-ui.exe
+
+VERSION = 1.0.0
+
+all: dep-ui.jar
+
+abcl.jar: $(ABCL_JAR)
+	cp $(ABCL_JAR) $@
+
+SUBSTUFF = \
+	*.abcl \
+	*.cls
+
+TOPSTUFF = \
+	*.class
+
+SUBFILES = \
+	run.lisp
+
+%.class: %.java abcl.jar
+	$(JAVAC) -cp abcl.jar $<
+
+SUBDIR = tmp/org/armedbear/lisp
+dep-ui.jar: abcl.jar dep-ui.abcl $(SUBFILES) Startup.class
+	rm -rf tmp.jar tmp
+	mkdir -p $(SUBDIR)
+	cp abcl.jar tmp.jar
+	cp $(SUBFILES) $(SUBSTUFF) $(SUBDIR)/
+	cp $(TOPSTUFF) tmp/
+	cd tmp; $(JAR) uf ../tmp.jar *
+	mv tmp.jar $@
+	rm -rf tmp.jar tmp
+
+jj.abcl swing.abcl queue.abcl dep.abcl:: dep-ui.abcl
+dep-ui.abcl: build.lisp \
+	jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp
+	abcl --load build.lisp
+
+GPL.dostxt: 
+	cp $(GPL) $@.new
+	todos $@.new
+	mv $@.new $@
+
+installer: $(INSTALLER)
+$(INSTALLER): dep-ui.nsis GPL.dostxt dep-ui.jar rolling.lisp
+	makensis dep-ui.nsis
+
+clean:
+	rm -f $(TOPSTUFF) $(SUBSTUFF) GPL.dostxt *.jar
+
+DISTDIR = dep-ui-$(VERSION)
+distdir:
+	rm -rf $(DISTDIR)
+	mkdir $(DISTDIR)
+	ln \
+		jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp \
+		run.lisp Startup.java rolling.lisp \
+		dep-ui.nsis \
+		$(DISTDIR)
+
+zip: distdir
+	zip -r $(DISTDIR).zip $(DISTDIR)
+	rm -rf $(DISTDIR)
+
+tar: distdir
+	tar cvfz $(DISTDIR).tar.gz $(DISTDIR)
+	rm -rf $(DISTDIR)
+
+### 
\ No newline at end of file
diff --git a/Rolling.xls b/Rolling.xls
new file mode 100644
index 0000000..f9ddaec
Binary files /dev/null and b/Rolling.xls differ
diff --git a/Startup.java b/Startup.java
new file mode 100644
index 0000000..66f3f1e
--- /dev/null
+++ b/Startup.java
@@ -0,0 +1,27 @@
+/* -*-java-*- */
+
+import org.armedbear.lisp.*;
+
+public final class Startup {
+  static final long stacksize = 4194304L;
+  public static final void main(final String[] args) {
+    Runnable r = new Runnable() {
+	public final void run() {
+	  Interpreter.createInstance();
+	  try {
+	    Symbol COMMAND_LINE_ARGS =
+	      Lisp.PACKAGE_EXT.internAndExport("*COMMAND-LINE-ARGS*");
+	    LispObject cmdargs = Lisp.NIL;
+	    for (int i = 0; i < args.length; i++)
+	      cmdargs = new Cons(args[i], cmdargs);
+	    COMMAND_LINE_ARGS.setSymbolValue(cmdargs.nreverse());
+	    Load.loadSystemFile("run.lisp");
+	  } catch (Throwable t) {
+	    t.printStackTrace();
+	    System.exit(127);
+	  }
+	}
+      };
+    new Thread(null, r, "lisp", stacksize).start();
+  }
+}
diff --git a/build.lisp b/build.lisp
new file mode 100644
index 0000000..35aabe5
--- /dev/null
+++ b/build.lisp
@@ -0,0 +1,7 @@
+;;; -*-lisp-*-
+
+(let ((sys:*compile-file-zip* nil))
+  (dolist (file '("jj" "swing" "queue" "dep" "dep-ui"))
+    (compile-file file)
+    (load file)))
+(exit)
diff --git a/dep-ui.lisp b/dep-ui.lisp
new file mode 100644
index 0000000..f31bebc
--- /dev/null
+++ b/dep-ui.lisp
@@ -0,0 +1,237 @@
+;;; -*-lisp-*-
+;;;
+;;; Dependency-based user interfaces
+;;;
+;;; (c) 2007 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-ui
+  (:use #:common-lisp #:jj #:swing #:java #:dep #:extensions)
+  (:export #:make-label #:make-input #:make-output #:make-group
+	   #:make-radio-dep #:within-group #:defwindow #:make-window
+	   #:install-dep-syntax #:add-reason #:drop-reason))
+
+(in-package #:dep-ui)
+
+;;;--------------------------------------------------------------------------
+
+(defparameter bad-text-colour (make-colour 1.0 0.4 0.4))
+(defparameter good-text-colour
+  (let ((text (make :javax.swing.*j-text-field)))
+    (send text :get-background)))
+
+(defun update-text-field-dep (field dep convert-func)
+  (let ((text (send field :get-text)))
+    (multiple-value-bind (value bogusp) (funcall convert-func text)
+      (cond (bogusp
+	     (send field :set-background bad-text-colour)
+	     (dep-make-bad dep))
+	    (t
+	     (unless (dep-goodp dep)
+	       (send field :set-background good-text-colour))
+	     (setf (dep-value dep) value))))))
+
+(defun make-text-field-with-dep (convert-func dep)
+  (let* ((field (make :javax.swing.*j-text-field))
+	 (doc (send field :get-document)))
+    (flet ((kick (&optional ev)
+	     (declare (ignore ev))
+	     (update-text-field-dep field dep convert-func)))
+      (send doc :add-document-listener
+	    (jinterface-implementation
+	       (java-name :javax.swing.event.*document-listener)
+	       (java-name :insert-update) #'kick
+	       (java-name :remove-update) #'kick
+	       (java-name :changed-update) #'kick))
+      (kick))
+    field))
+
+(defun update-dep-text-field (field dep convert-func)
+  (cond ((dep-goodp dep)
+	 (send field :set-background good-text-colour)
+	 (send field :set-text (funcall convert-func (dep-value dep))))
+	(t
+	 (send field :set-background bad-text-colour)
+	 (send field :set-text ""))))
+
+(defun safe-read-from-string (string continuation)
+  (with-input-from-string (stream string)
+    (ignore-errors
+      (let ((value (let ((*read-eval* nil)) (read stream))))
+	(if (peek-char t stream nil)
+	    (values nil :junk)
+	    (funcall continuation value))))))
+
+(defun read-real-from-string (string)
+  (safe-read-from-string string
+			 (lambda (value)
+			   (values value (not (realp value))))))
+
+(defun make-dependent-text-field
+    (dep &optional (convert-func #'princ-to-string))
+  (let ((field (make :javax.swing.*j-text-field)))
+    (send field :set-editable java-false)
+    (flet ((kicked (&optional ev)
+	     (declare (ignore ev))
+	     (update-dep-text-field field dep convert-func)))
+      (dep-add-listener dep #'kicked)
+      (kicked))
+    field))
+
+(defun make-label (string)
+  (let* ((amp (position #\& string))
+	 (text (if amp
+		   (concatenate 'string
+				(subseq string 0 amp)
+				(subseq string (1+ amp)))
+		   string))
+	 (widget (make :javax.swing.*j-label text
+		       (class-field :javax.swing.*j-label
+				    :*trailing*))))
+    (when amp
+      (send widget :set-displayed-mnemonic-index amp))
+    widget))
+
+(defun add-text-and-label (panel label text)
+  (let ((label-widget (make-label label)))
+    (send panel :add label-widget
+	  (make-grid-bag-constraints :fill :horizontal
+				     :anchor :north
+				     :insets 2))
+    (send panel :add text
+	  (make-grid-bag-constraints :fill :horizontal
+				     :anchor :north
+				     :weight-x 1.0
+				     :insets 2
+				     :grid-width :remainder))
+    (send label-widget :set-label-for text)))
+
+(defvar *panel* nil)
+
+(defun make-input (label dep)
+  (let ((text (make-text-field-with-dep #'read-real-from-string dep)))
+    (add-text-and-label *panel* label text)))
+
+(defun make-output (label dep)
+  (let ((text (make-dependent-text-field dep
+					 (lambda (value)
+					   (format nil "~,3F" value)))))
+    (add-text-and-label *panel* label text)))
+
+(defun twiddle-dep-radio (button dep name)
+  (send button :add-action-listener
+	(implementation :java.awt.event.*action-listener
+	  (action-performed (ev)
+	    (declare (ignore ev))
+	    (setf (dep-value dep) name)))))
+
+(defun make-radio-dep (dep &rest settings)
+  (let ((button-group (make :javax.swing.*button-group))
+	(panel (make :javax.swing.*j-panel)))
+    (send *panel* :add panel
+	  (make-grid-bag-constraints :fill :horizontal
+				     :anchor :north
+				     :insets 0
+				     :weight-x 1.0
+				     :grid-width :remainder))
+    (loop for (name label) on settings by #'cddr
+	  for selectp = (progn
+			  (unless (dep-goodp dep)
+			    (setf (dep-value dep) name))
+			  (if (eq (dep-value dep) name)
+			      java-true
+			      java-false))
+	  for button = (make :javax.swing.*j-radio-button label selectp)
+	  do (twiddle-dep-radio button dep name)
+	  do (send button-group :add button)
+	  do (send panel :add button
+		   (make-grid-bag-constraints :fill :horizontal
+					      :insets 2
+					      :weight-x 1.0)))))
+
+(defun make-group (label)
+  (let ((group (make-group-box label)))
+    (send group :set-layout (make :java.awt.*grid-bag-layout))
+    (send *panel* :add group
+	  (make-grid-bag-constraints :fill :horizontal
+				     :anchor :page-start
+				     :insets 2
+				     :weight-x 1.0
+				     :grid-width :remainder))
+    group))
+
+(defmacro within-group ((label) &body body)
+  `(let ((*panel* (make-group ,label)))
+     ,@body))
+
+(defun install-dep-syntax (&optional (readtable *readtable*))
+  (set-macro-character #\?
+		       (lambda (stream char)
+			 (declare (ignore char))
+			 (list 'dep-value (read stream t nil t)))
+		       readtable)
+  (set-syntax-from-char #\] #\) readtable readtable)
+  (set-dispatch-macro-character #\# #\[
+				(lambda (stream arg char)
+				  (declare (ignore arg char))
+				  `(make-dep (lambda ()
+					       ,@(read-delimited-list #\]
+								      stream
+								      t))))
+				readtable))
+
+(let ((reasons 0))
+  (defun add-reason ()
+    (incf reasons))
+  (defun drop-reason ()
+    (assert (plusp reasons))
+    (decf reasons)
+    (when (zerop reasons)
+      (send-class :java.lang.*system :exit 0))))
+
+(defun make-window (title populate-func)
+  (let ((window (make :javax.swing.*j-frame title)))
+    (send window :set-layout (make :java.awt.*grid-bag-layout))
+    (let ((*panel* window))
+      (funcall populate-func))
+    (send window :pack)
+    (send window :set-visible java-true)
+    (add-reason)
+    (send window :set-default-close-operation
+	  (class-field :javax.swing.*j-frame :*do-nothing-on-close*))
+    (send window :add-window-listener
+	  (implementation :java.awt.event.*window-listener
+	    (:window-activated (ev) (declare (ignore ev)))
+	    (:window-deactivated (ev) (declare (ignore ev)))
+	    (:window-iconified (ev) (declare (ignore ev)))
+	    (:window-deiconified (ev) (declare (ignore ev)))
+	    (:window-opened (ev) (declare (ignore ev)))
+	    (:window-closing (ev)
+	      (declare (ignore ev))
+	      (send window :dispose))
+	    (:window-closed (ev)
+	      (declare (ignore ev))
+	      (drop-reason))))
+    window))
+
+(defmacro defwindow (name bvl (title) &body body)
+  `(defun ,name ,bvl
+     (make-window ,title (lambda () ,@body))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/dep-ui.nsis b/dep-ui.nsis
new file mode 100644
index 0000000..b111898
--- /dev/null
+++ b/dep-ui.nsis
@@ -0,0 +1,71 @@
+;;; nsis installer script
+
+Name "Dep-UI"
+OutFile "setup-dep-ui.exe"
+InstallDir $PROGRAMFILES\Straylight-Edgeware\Dep-UI
+InstallDirRegKey HKLM Software\Straylight-Edgeware\Dep-UI install-location
+RequestExecutionLevel user
+
+Page license
+Page directory
+Page components
+Page instfiles
+
+UninstPage uninstConfirm
+UninstPage instfiles
+
+LicenseText "The GNU General Public License" "Whatever"
+LicenseData GPL.dostxt
+
+Section "Programs"
+  SetOutPath $INSTDIR
+  SectionIn RO
+  File dep-ui.jar
+  File /oname=rolling.dui rolling.lisp
+  WriteUninstaller uninstall.exe
+  WriteRegStr \
+    HKLM Software\Straylight-Edgeware\Dep-UI \
+    install-location $INSTDIR
+  WriteRegStr \
+    HKLM Software\Microsoft\Windows\CurrentVersion\Uninstall\Example2 \
+    DisplayName Dep-UI
+  WriteRegStr \
+    HKLM Software\Microsoft\Windows\CurrentVersion\Uninstall\Example2 \
+    UninstallString $INSTDIR\uninstall.exe
+  WriteRegDWORD \
+    HKLM Software\Microsoft\Windows\CurrentVersion\Uninstall\Example2 \
+    NoModify 1
+  WriteRegDWORD \
+    HKLM Software\Microsoft\Windows\CurrentVersion\Uninstall\Example2 \
+    NoRepair 1
+SectionEnd
+
+Section "Start menu shortcuts"
+  CreateDirectory $SMPROGRAMS\Dep-UI
+  CreateShortCut $SMPROGRAMS\Dep-UI\Rolling.lnk \
+    $SYSDIR\javaw.exe "-cp $\"$INSTDIR\dep-ui.jar$\" Startup $\"$INSTDIR\rolling.dui$\"" \
+    $SYSDIR\javaw.exe 0
+  CreateShortCut $SMPROGRAMS\Dep-UI\Uninstall.lnk \
+    $INSTDIR\uninstall.exe "" $INSTDIR\uninstall.exe 0
+SectionEnd
+
+Section "Register file type"
+  WriteRegStr HKCR .dui "" dep-ui-file
+  WriteRegStr HKCR .dui "Content Type" application/x-dep-ui
+  WriteRegStr HKCR dep-ui-file\shell\open\command "" "$SYSDIR\javaw.exe -cp $\"$INSTDIR\dep-ui.jar$\" Startup %1"
+SectionEnd
+
+Section "Uninstall"
+  Delete $INSTDIR\dep-ui.jar
+  Delete $INSTDIR\rolling.dui
+  Delete $INSTDIR\uninstall.exe
+  Delete $SMPROGRAMS\Dep-UI\*.*
+  DeleteRegKey HKLM Software\Straylight-Edgeware\Dep-UI
+  DeleteRegKey \
+    HKLM Software\Microsoft\Windows\CurrentVersion\Uninstall\Example2
+  DeleteRegKey HKCR .dui
+  DeleteRegKey HKCR dep-ui-file
+  RMDir $SMPROGRAMS\Dep-UI
+  RMDir $INSTDIR
+SectionEnd
+
diff --git a/dep.lisp b/dep.lisp
new file mode 100644
index 0000000..07460b8
--- /dev/null
+++ b/dep.lisp
@@ -0,0 +1,213 @@
+;;; -*-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/jj.lisp b/jj.lisp
new file mode 100644
index 0000000..d07d2b4
--- /dev/null
+++ b/jj.lisp
@@ -0,0 +1,640 @@
+;;; -*-lisp-*-
+;;;
+;;; Pleasant Lisp interface to Java class libraries
+;;;
+;;; (c) 2007 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 #:jj
+  (:use #:common-lisp #:java)
+  (:export #:java-name #:lisp-name
+	   #:java-true #:java-false #:java-null
+	   #:send #:send-class #:make #:make-java-array #:java-array
+	   #:field #:class-field
+	   #:magic-constant-case
+	   #:implementation))
+
+(in-package #:jj)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defmacro with-string-iterator ((iterator
+				 string
+				 &key
+				 (character (gensym "CHAR"))
+				 (index (gensym "INDEX"))
+				 (start 0)
+				 (end nil))
+				&body body)
+  "Evaluate BODY with ITERATOR fbound to a function which returns successive
+   characters from the substring of STRING indicated by START and END.  The
+   variables named by INDEX and CHARACTER are bound to the current index
+   within STRING and the current character; they are modified by assignment
+   by the ITERATOR function.  The ITERATOR takes one (optional) argument
+   EOSP: if false (the default), ITERATOR signals an error if it reads past
+   the end of the indicated substring; if true, it returns nil at
+   end-of-string."
+  (let ((tstring (gensym "STRING"))
+	(tend (gensym "END")))
+    `(let* ((,tstring ,string)
+	    (,index ,start)
+	    (,tend (or ,end (length ,tstring)))
+	    (,character nil))
+      (flet ((,iterator (&optional eosp)
+	       (cond ((< ,index ,tend)
+		      (setf ,character (char ,tstring ,index))
+		      (incf ,index)
+		      ,character)
+		     (eosp nil)
+		     (t (error "Unexpected end-of-string.")))))
+	,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Name conversion.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+  (defun java-name (name)
+    "Returns the Java-name for NAME, as a string.  If NAME is a string, it is
+     returned as-is.  If NAME is a symbol, its print-name is converted
+     according to these rules.  The name is split into components separated
+     by `.' characters; the components are converted independently, and
+     joined, again using `.'s.
+
+       * The final component is treated specially: if the first and last
+         characters are both `*' then the `*'s are stripped off, all `-'s are
+         replaced by `_'s, and other characters are emitted as-is.
+
+       * If the first character of a component is `*' then the `*' is
+         stripped and the following character is converted to upper-case.
+
+       * A double `-' is replaced by an underscore `_'.
+
+       * A single `-' is stripped and the following character converted to
+         upper-case.
+
+       * Other characters are converted to lower-case.
+
+     These are the inverse of the rules for lisp-name (q.v.).
+
+     Examples:
+
+     Lisp name				Java name
+
+     FOO				foo
+     JAVA.AWT.*GRID-BAG-CONSTRAINTS	java.awt.GridBagConstraints
+     *HORIZONTAL-SPLIT*			HORIZONTAL_SPLIT"
+
+    (etypecase name
+      (string name)
+      (symbol
+       (let* ((name (symbol-name name))
+	      (n (length name)))
+	 (with-output-to-string (out)
+	   (with-string-iterator (getch name :character ch :index i :end n)
+	     (tagbody
+	      top
+		(getch)
+		(case ch
+		  (#\- (go upnext))
+		  (#\* (cond ((and (char= #\* (char name (1- n)))
+				   (every (lambda (ch)
+					    (or (char= #\- ch)
+						(alphanumericp ch)))
+					  (subseq name i (1- n))))
+			      (map nil
+				   (lambda (ch)
+				     (write-char (if (char= #\- ch) #\_ ch)
+						 out))
+				   (subseq name i (1- n)))
+			      (go done))
+			     (t
+			      (go upnext))))
+		  (t (go main)))
+	      main
+		(unless (alphanumericp ch)
+		  (error "Bad character in name."))
+		(write-char (char-downcase ch) out)
+	      next
+		(unless (getch t) (go done))
+		(case ch
+		  (#\- (go upnext))
+		  (#\. (write-char #\. out) (go top))
+		  (t (go main)))
+	      upnext
+		(getch)
+		(cond ((char= ch #\-) (write-char #\_ out))
+		      ((alphanumericp ch) (write-char (char-upcase ch) out))
+		      (t (error "Bad character in name.")))
+		(go next)
+	      done)))))))
+
+  (defun lisp-name (name &optional (package :keyword))
+    "Returns the Lisp-name for NAME, as a symbol interned in the given
+     PACKAGE (defaults to keyword).  The name is split into components
+     separated by `.' characters, converted independently, and joined again
+     using `.'s.
+
+       * The final component is treated specially.  If it consists entirely
+         of `_', digits and upper-case letters, it is converted by replacing
+         the `_'s by `-'s, and adding a `*' to the beginning and end.
+
+       * If the first character of a component is upper-case, an `*' is
+         prepended.  Other upper-case characters are preceded by `-'s.
+
+       * Any `_' characters are replaced by `--'.
+
+       * All letters are converted to upper-case.
+
+     These are the inverse of the rules for java-name (q.v.)."
+
+    (let ((n (length name)))
+      (intern (with-output-to-string (out)
+		(with-string-iterator
+		    (getch name :character ch :index i :end n)
+		  (tagbody
+		   top
+		     (getch)
+		     (when (upper-case-p ch)
+		       (write-char #\* out)
+		       (let ((mid (make-array (- n i -1)
+					      :element-type
+					      (array-element-type name)
+					      :displaced-to name
+					      :displaced-index-offset
+					      (1- i))))
+			 (when (every (lambda (ch)
+					(or (char= #\_ ch)
+					    (digit-char-p ch)
+					    (upper-case-p ch)))
+				      mid)
+			   (map nil
+				(lambda (ch)
+				  (write-char (if (char= #\_ ch) #\- ch)
+					      out))
+				mid)
+			   (write-char #\* out)
+			   (go done))))
+		   main
+		     (write-char (char-upcase ch) out)
+		   next
+		     (unless (getch t) (go done))
+		     (cond ((char= #\_ ch)
+			    (write-string "--" out)
+			    (go next))
+			   ((char= #\. ch)
+			    (write-char #\. out)
+			    (go top))
+			   ((upper-case-p ch)
+			    (write-char #\- out)))
+		     (go main)
+		   done)))
+	      package))))
+
+;;;--------------------------------------------------------------------------
+;;; Dynamic method dispatch.
+
+(defparameter *class-table* (make-hash-table :test #'equal)
+  "A hash table mapping Java class names (as strings, using their Java names)
+   to java-class structures. ")
+
+(defstruct java-method
+  "Structure describing a Java method or constructor.  The slots are as
+   follows.
+
+     * cache -- hash table mapping a list of argument types (as Java class
+       objects) to appropriate method.  This table is populated as we go.
+
+     * name -- Lisp symbol naming the method; :constructor for constructors.
+
+     * min-args -- smallest number of arguments acceptable to the method.
+
+     * max-args -- largest number of arguments acceptable.
+
+     * overloads -- vector, indexed by (- nargs min-args), of (jmethod .
+       argument-types) pairs."
+
+  (cache (make-hash-table :test #'equal) :type hash-table)
+  (name nil :type symbol)
+  (min-args 0 :type fixnum)
+  (max-args 0 :type fixnum)
+  (overloads nil :type vector))
+
+(defstruct java-class
+  "Structure describing a Java class.  The slots are as follows.
+
+     * name -- Lisp symbol naming the class.
+
+     * jclass -- the Java class object.
+
+     * methods -- hash table mapping Lisp method names to java-method
+       structures.
+
+     * constructor -- java-method structure describing the available
+       constructors."
+
+  (name nil :type symbol)
+  (jclass nil :type java-object)
+  (methods nil :type (or hash-table null))
+  (constructor nil :type (or java-method null)))
+
+(defconstant java-true (make-immediate-object t :boolean)
+  "The Java `true' object.")
+(defconstant java-false (make-immediate-object nil :boolean)
+  "The Java `false' object.")
+(defconstant java-null (make-immediate-object nil :ref)
+  "A Java null reference.")
+
+(defmacro define-java-method (lisp-name class method &body args)
+  "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
+   given arguments.  The CLASS may be a string or symbol (it is converted by
+   java-name).  The ARGS are (NAME TYPE) lists, where each TYPE is a string
+   or symbol naming a Java class."
+  (let ((arg-names (mapcar #'car args))
+	(arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args)))
+  `(let ((meth (jmethod (jclass ,(java-name class))
+			,(java-name method)
+			,@arg-types)))
+     (defun ,lisp-name (this ,@arg-names)
+       (jcall meth this ,@arg-names)))))
+
+(defun find-java-class (class)
+  "Return the java-class structure for the given CLASS, which may be a
+   java-class structure, a Java class object (note the difference!), a string
+   naming a Java class, or a symbol giving the name in Lisp form."
+  (if (java-class-p class)
+      class
+      (let ((jclass (jclass (if (symbolp class) (java-name class) class))))
+	(or (gethash jclass *class-table*)
+	    (setf (gethash jclass *class-table*)
+		  (make-java-class :name (lisp-name (jclass-name jclass))
+				   :jclass jclass))))))
+
+(defun construct-method-table (methods get-params get-name)
+  "Constructs the method table (as a hash-table) for a java-class object.
+   The METHODS are a vector of method (or constructor) objects; GET-PARAMS is
+   a function which is given a method object and returns a sequence of
+   argument type objects; and GET-NAME is a function which is given a method
+   object and returns the method's name, as a Lisp symbol.
+
+   The indirection is because, inexplicably, one has to use different
+   functions to extract this information from methods or constructors."
+
+  (let ((by-name (make-hash-table))
+	(output (make-hash-table)))
+
+    ;; First pass: break the list up by name.
+    (dotimes (i (length methods))
+      (let* ((jmethod (aref methods i))
+	     (arg-types (funcall get-params jmethod)))
+	(push (list* (length arg-types)
+		     jmethod
+		     (coerce arg-types 'list))
+	      (gethash (funcall get-name jmethod) by-name))))
+
+    ;; Second pass: sift each name bucket by numbers of arguments.
+    (maphash (lambda (name list)
+	       (let* ((arg-lengths (mapcar #'car list))
+		      (min-args (apply #'min arg-lengths))
+		      (max-args (apply #'max arg-lengths))
+		      (overloads (make-array (- max-args min-args -1)
+					     :initial-element nil)))
+		 (dolist (item list)
+		   (pushnew (cdr item)
+			    (aref overloads (- (car item) min-args))
+			    :test #'equal
+			    :key #'cdr))
+		 (setf (gethash name output)
+		       (make-java-method :min-args min-args
+					 :name name
+					 :max-args max-args
+					 :overloads overloads))))
+	     by-name)
+
+    ;; Done!
+    output))
+
+(defun ensure-java-method-table (java-class)
+  "Ensure that JAVA-CLASS has a method table, and return it."
+  (or (java-class-methods java-class)
+      (setf (java-class-methods java-class)
+	    (construct-method-table (jclass-methods
+				     (java-class-jclass java-class))
+				    #'jmethod-params
+				    (lambda (jmethod)
+				      (lisp-name (jmethod-name jmethod)))))))
+
+(defun ensure-java-constructor (java-class)
+  "Ensure that JAVA-CLASS has a constructor object, and return it."
+  (or (java-class-constructor java-class)
+      (setf (java-class-constructor java-class)
+	    (gethash :constructor
+		     (construct-method-table (jclass-constructors
+					      (java-class-jclass java-class))
+					     #'jconstructor-params
+					     (constantly :constructor))))))
+
+(defun find-java-method (class name)
+  "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp
+   symbol or Java name string), return the corresponding java-method
+   structure."
+  (let ((java-class (find-java-class class)))
+    (gethash (if (symbolp name) name (lisp-name name))
+	     (ensure-java-method-table java-class))))
+
+(defun find-java-constructor (class)
+  "Given a CLASS (in a form acceptable to find-java-class), return the
+   java-method structure for its constructor."
+  (ensure-java-constructor (find-java-class class)))
+
+(defun expand-java-method (java-method)
+  "Return a list-of-lists: for each overload of the method, return a list of
+   its argument types, in ascending order of number of arguments."
+  (let ((out nil))
+    (dotimes (i (length (java-method-overloads java-method)))
+      (dolist (item (cdr (aref (java-method-overloads java-method) i)))
+	(push (mapcar (lambda (arg)
+			(lisp-name (jclass-name arg)))
+		      (cdr item))
+	      out)))
+    (nreverse out)))
+
+(defun expand-java-class (java-class)
+  "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...))
+   describing the state of a JAVA-CLASS object.  Useful for diagnostics."
+  (list (java-class-name java-class)
+	(cons :constructors
+	      (expand-java-method (ensure-java-constructor java-class)))
+	(loop for name being the hash-keys
+	      of (ensure-java-method-table java-class)
+	      using (hash-value method)
+	      collect (cons name (expand-java-method method)))))
+
+(defparameter *conversions*
+  (let ((raw '((java.lang.*object boolean)
+	       (java.lang.*number double)
+	       (java.lang.*comparable double)
+	       (double float java.lang.*double)
+	       (float long java.lang.*float)
+	       (long int java.lang.*long)
+	       (int short char java.lang.*integer)
+	       (short byte java.lang.*short)
+	       (char java.lang.*character)
+	       (boolean java.lang.*boolean))))
+    (labels ((lookup (type)
+	       (cdr (assoc type raw)))
+	     (closure (type)
+	       (delete-duplicates
+		(cons type
+		      (mapcan #'closure (lookup type))))))
+      (mapcar (lambda (row) (mapcar (lambda (name)
+				      (jclass (java-name name)))
+				    (closure (car row))))
+	      raw)))
+  "Table encoding the various implicit conversions for primitive types, used
+   occasionally to disambiguate multiple method matches.")
+
+(defun jclass-convertible-p (from to)
+  "Return whether there is an automatic conversion between FROM and TO.  This
+   can be considered a partial order on types."
+  (or (jclass-superclass-p to from)
+      (member from (assoc to *conversions* :test #'equal)
+	      :test #'equal)))
+
+(defun argument-list-betterp (first second)
+  "Return whether the type-list FIRST is `better' than SECOND, in the sense
+   that there is an implicit conversion between each element of FIRST and the
+   corresponding element of SECOND.  This lifts the partial order of
+   jclass-better-p to lists of types."
+  (cond ((endp first) (endp second))
+	((endp second) nil)
+	(t (and (jclass-convertible-p (car first) (car second))
+		(argument-list-betterp (cdr first) (cdr second))))))
+
+(defun get-jmethod-for-argument-types (java-method argument-types)
+  "Given a JAVA-METHOD structure, return the best match overload for the
+   given list of ARGUMENT-TYPES.
+
+   An overload is considered to be a match if there is an implicit conversion
+   from each actual argument type to the corresponding formal argument type.
+   One matching overload is better than another if there is an implicit
+   conversion from each of the former's argument types to the type of the
+   corresponding argument of the latter.  If there is no unique best match
+   then an error is signalled.
+
+   In the language of the partial order defined by argument-list-betterp
+   (q.v.), which we write as <=, let us denote the actual argument types by
+   A, and the argument types of an overload O as simply O; then O is a match
+   for A if A <= O and O is a better match than O' if O <= O'; let M be the
+   set of matching overloads M = { O | A <= O }; we seek the minimum element
+   of M."
+
+  (or (gethash argument-types (java-method-cache java-method))
+      (labels ((expand-arglist (args)
+		 (mapcar (lambda (arg)
+			   (lisp-name (jclass-name arg)))
+			 args))
+	       (expand-methodlist (methods)
+		 (mapcar (lambda (method) (expand-arglist (cdr method)))
+			 methods))
+	       (consider (best next)
+		 #+debug
+		 (format t "*** currently: ~S~%*** considering: ~S~%"
+			 (expand-methodlist best)
+			 (expand-arglist (cdr next)))
+		 (let ((winners (remove-if
+				 (lambda (method)
+				   (argument-list-betterp (cdr next)
+							  (cdr method)))
+				 best))
+		       (include-next-p (every
+					(lambda (method)
+					  (not (argument-list-betterp
+						(cdr method)
+						(cdr next))))
+					best)))
+		   (if include-next-p
+		       (cons next winners)
+		       winners))))
+	(let* ((nargs (length argument-types))
+	       (min-args (java-method-min-args java-method))
+	       (max-args (java-method-max-args java-method))
+	       (candidates
+		(and (<= min-args nargs max-args)
+		     (remove-if-not (lambda (method)
+				      (argument-list-betterp argument-types
+							     (cdr method)))
+				    (aref (java-method-overloads java-method)
+					  (- nargs min-args)))))
+	       (chosen (and candidates
+			    (reduce #'consider (cdr candidates)
+				    :initial-value (list
+						    (car candidates))))))
+	  #+debug
+	  (progn
+	    (format t "*** candidates = ~S~%"
+		    (expand-methodlist candidates))
+	    (format t "*** chosen = ~S~%"
+		    (expand-methodlist chosen)))
+	  (cond ((null chosen)
+		 (error "No match found.~%  method = ~A, args = ~A"
+			(java-method-name java-method)
+			(expand-arglist argument-types)))
+		((cdr chosen)
+		 (error "Ambiguous match.~%  ~
+                           method = ~A, args = ~A~%  ~
+                           matches = ~A"
+			(java-method-name java-method)
+			(expand-arglist argument-types)
+			(expand-methodlist chosen)))
+		(t (setf (gethash argument-types
+				  (java-method-cache java-method))
+			 (caar chosen))))))))
+
+(defun argument-type-list-from-names (names)
+  "Given a list of type NAMES, return the corresponding Java class objects."
+  (mapcar (lambda (name)
+	    (java-class-jclass (find-java-class name)))
+	  names))
+
+(defun find-jmethod (class name arg-types)
+  "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
+   method object for the best matching overload of the method."
+  (get-jmethod-for-argument-types (find-java-method class name)
+				  (argument-type-list-from-names arg-types)))
+
+(defun find-jconstructor (class arg-types)
+  "Given a CLASS and a list of ARG-TYPES, return the Java constructor object
+   for the best matching constructor overload."
+  (get-jmethod-for-argument-types (find-java-constructor class)
+				  (argument-type-list-from-names arg-types)))
+
+(defun send (object message &rest arguments)
+  "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
+   other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best
+   matches the types of the ARGUMENTS."
+  (let ((jargs (mapcar #'make-immediate-object arguments)))
+    (apply #'jcall
+	   (find-jmethod (jobject-class object) message
+			 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
+	   object
+	   jargs)))
+
+(defun send-class (class message &rest arguments)
+  "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name
+   (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static
+   method of CLASS named by MESSAGE which best matches the types of the
+   ARGUMENTS."
+  (let ((java-class (find-java-class class))
+	(jargs (mapcar #'make-immediate-object arguments)))
+    (apply #'jcall
+	   (find-jmethod java-class message
+			 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
+	   java-null
+	   jargs)))
+
+(defun make (class &rest arguments)
+  "Given a CLASS (anything acceptable to find-java-class) and other
+   ARGUMENTS, invoke the constructor of CLASS which best matches the types of
+   the ARGUMENTS, returning the result."
+  (let ((java-class (find-java-class class))
+	(jargs (mapcar #'make-immediate-object arguments)))
+    (apply #'jnew
+	   (find-jconstructor java-class
+			      (mapcar (lambda (jarg) (jobject-class jarg))
+				      jargs))
+	   jargs)))
+
+;;;--------------------------------------------------------------------------
+;;; Field access.
+
+(defun field (object name)
+  "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return
+   the value of the OBJECT's field with the given NAME.  This is a valid
+   place for setf."
+  (jfield (java-name name) object))
+
+(defun (setf field) (value object name)
+  "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set
+   the OBJECT's field with the given NAME to be VALUE."
+  (jfield object name value))
+
+(defun class-field (class name)
+  "Given a CLASS and a field NAME (Lisp symbol or Java name string), return
+   the value of the CLASS's static field with the given NAME.  This is a
+   valid place for setf."
+  (jfield (jclass (java-name class)) (java-name name)))
+
+(defun (setf class-field) (value class name)
+  "Given an CLASS and a field NAME (Lisp symbol or Java name string), set
+   the CLASS's static field with the given NAME to be VALUE."
+  (jfield (jclass (java-name class)) (java-name name) nil value))
+
+;;;--------------------------------------------------------------------------
+;;; Arrays.
+
+(defun make-java-array (class items)
+  "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS,
+   return a Java array specialized for the named CLASS, containing the
+   ITEMS."
+  (jnew-array-from-array (if (symbolp class) (java-name class) class)
+			 (if (listp items) (coerce items 'vector) items)))
+
+(defun java-array (class &rest items)
+  "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a
+   Java array specialized for the named CLASS, containing the ITEMS."
+  (make-java-array class items))
+
+;;;--------------------------------------------------------------------------
+;;; Interfaces.
+
+(defmacro implementation (class &body clauses)
+  "Returns an implementation of the interface names by CLASS (Lisp symbol or
+   Java name string), whose methods are defined by CLAUSES; each clause has
+   the form (NAME (BVL ...) FORMS...) where NAME is the name of a method
+   (Lisp symbol or Java name string), BVL is a standard bound-variable list,
+   and FORMS are any Lisp forms providing the implementation of the method."
+  `(jinterface-implementation
+    ,(java-name class)
+    ,@(loop for (name bvl . body) in clauses
+	    collect (java-name name)
+	    collect `(lambda ,bvl ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Other useful hacks.
+
+(defmacro magic-constant-case ((selector class) &body keywords)
+  "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java
+   class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp
+   keyword objects.  The SELECTOR is matched against the KEYWORDS.  If a
+   match is found, the keyword is converted to upper-case, `-' is converted
+   to `_', and the result used as a Java static field name of the specified
+   CLASS; the value of this field is returned as the value of the expression.
+
+   Note that the class field lookups are really done at macro-expansion time,
+   not at run-time."
+  `(ecase ,selector
+     ,@(mapcar (lambda (key)
+		 `(,key ,(class-field class
+				      (substitute #\_ #\-
+						  (string-upcase key)))))
+	       keywords)))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/queue.lisp b/queue.lisp
new file mode 100644
index 0000000..03de433
--- /dev/null
+++ b/queue.lisp
@@ -0,0 +1,88 @@
+;;; -*-lisp-*-
+;;;
+;;; A simple queue
+;;;
+;;; (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 #:queue
+  (:use #:common-lisp)
+  (:export #:make-queue #:queue-emptyp #:enqueue #:dequeue))
+(in-package #:queue)
+
+(defun make-queue ()
+  "Make a new queue object."
+  ;; A queue is just a cons cell.  The cdr is the head of the list of items
+  ;; in the queue, and the car points to the last entry in the list.  If the
+  ;; queue is empty, then the car points to the queue itself for the sake of
+  ;; uniformity.
+  (let ((q (cons nil nil)))
+    (setf (car q) q)))
+
+(defun queue-emptyp (q)
+  "Answer whether the queue Q is empty."
+  (null (cdr q)))
+
+(defun enqueue (x q)
+  "Enqueue the object X into the queue Q."
+  (let ((c (cons x nil)))
+    (setf (cdr (car q)) c
+	  (car q) c)))
+
+(defun dequeue (q)
+  "Remove and return the object at the head of the queue Q."
+  (if (queue-emptyp q)
+      (error "Queue is empty.")
+      (let ((c (cdr q)))
+	(prog1 (car c)
+	  (unless (setf (cdr q) (cdr c))
+	    (setf (car q) q))))))
+
+#+ test
+(defun queue-check (q)
+  "Check consistency of the queue Q."
+  (assert (car q))
+  (if(null (cdr q))
+     (assert (eq (car q) q))
+     (do ((tail (car q))
+	  (collection nil (cons (car item) collection))
+	  (item (cdr q) (cdr item)))
+	 ((endp item) (nreverse collection))
+       (if (cdr item)
+	   (assert (not (eq item tail)))
+	   (assert (eq item tail))))))
+
+#+ test
+(defun test-queue ()
+  "Randomized test of the queue functions."
+  (let ((q (make-queue))
+	(want nil))
+    (dotimes (i 10000)
+      (case (random 2)
+	(0 (setf want (nconc want (list i)))
+	   (enqueue i q))
+	(1 (if (null want)
+	       (assert (queue-emptyp q))
+	       (progn
+		 (let ((j (dequeue q))
+		       (k (pop want)))
+		   (assert (= j k)))))))
+      (assert (equal want (queue-check q))))))
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/rolling.lisp b/rolling.lisp
new file mode 100644
index 0000000..18a67bd
--- /dev/null
+++ b/rolling.lisp
@@ -0,0 +1,61 @@
+;;; -*-lisp-*-
+;;;
+;;; Compute rectangular-section wire sizes
+;;;
+;;; (c) 2007 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.
+
+(install-dep-syntax)
+
+(defwindow rolling-window () ("Rolling")
+  (let* ((width (make-leaf-dep))
+	 (thick (make-leaf-dep))
+	 (length (make-leaf-dep))
+	 (stock-type (make-leaf-dep :round))
+	 (stock-size (make-leaf-dep))
+	 (volume #[(* ?width ?thick ?length)])
+	 (stock-length #[(/ ?volume
+			    (case ?stock-type
+			      (:round (* 1/4 pi (expt ?stock-size 2)))
+			      (:square (expt ?stock-size 2))
+			      (t (dep-bad))))])
+	 (sq-size #[(expt (* (expt ?width 2) ?thick) 1/3)])
+	 (rnd-diam #[(/ (* 2 ?sq-size) (sqrt pi))])
+	 (start-length #[(/ ?volume (expt ?sq-size 2))]))
+    (within-group ("Required size")
+      (make-input "Width:" width)
+      (make-input "Thickness:" thick)
+      (make-input "Length:" length))
+    (within-group ("You should start with")
+      (make-output "Square side:" sq-size)
+      (make-output "Round diameter:" rnd-diam)
+      (make-output "Length:" start-length))
+    (within-group ("Initial stock")
+      (make-radio-dep stock-type
+		      :round "Round section"
+		      :square "Square section")
+      (make-input "Stock size:" stock-size)
+      (make-output "Stock length:" stock-length))
+    #+ no
+    (within-group ("Other data")
+      (make-output "Volume:" volume))))
+
+(rolling-window)
+
+;;;----- That's all, folks --------------------------------------------------
diff --git a/rolling.rexx b/rolling.rexx
new file mode 100644
index 0000000..68092a1
--- /dev/null
+++ b/rolling.rexx
@@ -0,0 +1,64 @@
+/*
+ * rolling.cmd
+ *
+ * Work out side f square wire to get rectangular wire
+ */ 
+
+/* --- Crank up the maths package --- */
+
+Do until Abbrev( 'NO', reply, 1) = 1
+  /* --- Get some input --- */
+
+  say 'Type width , thickness [, length]'
+  pull w ',' t ',' l
+  If w || t = ''  then LEAVE
+  If Datatype( w, 'M') then LEAVE
+
+  If w < t then Do   /* swap t and w if w less than t */
+    temp = t
+    t = w
+    w = temp
+  End
+
+  /* --- Produce some output --- *
+   *
+   * We calculate the side as being $\sqrt[3]{tw^2}$.  This is easy.
+   */
+  side = topower(t * w**2, 1/3)
+  diam =  format(side * 1.128379167,,2)     /* 2*sqrt(side**2/pi)  --  2/sqrt(pi) = 1.128379167 */
+  sqside = format( side,,2)
+  say 'You want square wire with side' sqside', or' diam 'diam round' 
+
+  /* ---  Maybe print out the original length needed --- *
+   *
+   * Original length is $twl \over x^2$.
+   */
+
+  If l\='' then Do
+    vol = w*t*l
+    say 'Of length' format(vol/(sqside**2),,2)', or' format(vol/(3.14159*(diam/2)**2),,2) 'respectively'
+    Say 'Volume' vol/1000 || ', weight' vol * 11.2/1000'gm in 9ctY'
+    Call mould
+  End
+  Say 'Again?'
+  Parse UPPER PULL reply
+End
+
+/* --- Tidy up after us --- */
+
+exit
+
+mould:
+If l \= '' then Do 
+  Say 'Specify diam of round stock as "d", or thickness of square as ",t"'
+  Parse UPPER PULL diam ',' thik
+  If diam \= '' then Do
+   If Datatype( diam, 'N') then  
+     Say 'Length of' diam 'round wire =' format(vol/(3.14159*(diam/2)**2),,2)
+  End
+  If thik \= '' then Do
+   If Datatype( thik, 'N') then  
+     Say 'Length of' thik 'square wire =' format(vol/(thik**2),,2)
+  End
+ End
+Return
diff --git a/run.lisp b/run.lisp
new file mode 100644
index 0000000..09f6b54
--- /dev/null
+++ b/run.lisp
@@ -0,0 +1,13 @@
+;;; -*-lisp-*-
+
+;;; Driver for the system.
+
+(dolist (file '("jj" "swing" "queue" "dep" "dep-ui"))
+  (sys:load-system-file file))
+
+(use-package '(#:dep #:dep-ui))
+
+(add-reason)
+(dolist (arg *command-line-args*)
+  (load arg))
+(drop-reason)
diff --git a/swing.lisp b/swing.lisp
new file mode 100644
index 0000000..238d691
--- /dev/null
+++ b/swing.lisp
@@ -0,0 +1,149 @@
+;;; -*-lisp-*-
+;;;
+;;; Pleasant Lisp interface to Swing functions
+;;;
+;;; (c) 2007 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 #:swing
+  (:use #:common-lisp #:jj)
+  (:export #:make-insets #:make-grid-bag-constraints #:make-colour
+	   #:make-group-box))
+
+(in-package #:swing)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun listify (thing)
+  (if (listp thing) thing (list thing)))
+
+;;;--------------------------------------------------------------------------
+;;; Grid-bag constraints.
+
+(defun make-insets (&rest arguments)
+  "Return a java.awt.*insets object from the given ARGUMENTS.  The forms
+   accepted are:
+
+     * (make-insets) -> (0, 0, 0, 0)
+
+     * (make-insets N) -> (N, N, N, N)
+
+     * (make-insets &key :left :right :top :bottom) -> obvious thing"
+  (apply #'make :java.awt.*insets
+	 (cond ((null arguments) '(0 0 0 0))
+	       ((and (endp (cdr arguments))
+		     (integerp (car arguments)))
+		(make-list 4 :initial-element (car arguments)))
+	       (t (destructuring-bind (&key (left 0) (right 0) (top 0)
+					    (bottom 0)) arguments
+		    (list top left bottom right))))))
+
+(defun make-grid-bag-constraints
+    (&key grid-x grid-y grid-width grid-height weight-x weight-y
+     anchor fill insets internal-pad-x internal-pad-y)
+  "Return a java.awt.*grind-bag-constraints object.  Arguments may be as
+   follows.
+
+     * GRID-X, GRID-Y -- an integer or :relative  [default :relative]
+
+     * GRID-WIDTH, GRID-HEIGHT -- an integer, :relative or  :remainder
+       [default 1]
+
+     * WEIGHT-X, WEIGHT-Y -- a float in [0, 1]  [default 0.0]
+
+     * ANCHOR -- one of :center, :north, :northeast :northwest, :west, :east,
+       :south, :southwest, :southeast, :page-start, :line-start, :line-end,
+       :page-end, :last-line-start, :last-line-end, :first-line-start,
+       :first-line-end  [default :center]
+
+     * FILL -- one of :none, :horizontal, :vertical, :both  [default :none]
+
+     * INSETS -- something acceptable to make-insets (q.v.)  [default 0]
+
+     * INTERNAL-PAD-X, INTERNAL-PAD-Y -- integers  [default 0]"
+
+  (flet ((magic (x)
+	   (if (keywordp x)
+	       (magic-constant-case (x :java.awt.*grid-bag-constraints)
+		 :first-line-start :first-line-end
+		 :page-start :line-start :line-end :page-end
+		 :last-line-start :last-line-end
+		 :none :both :horizontal :vertical
+		 :relative :remainder
+		 :northwest :north :northeast
+		 :west :center :east
+		 :southwest :south :southeast)
+	       x)))
+  (make :java.awt.*grid-bag-constraints
+	(magic (or grid-x :relative)) (magic (or grid-y :relative))
+	(magic (or grid-width 1)) (magic (or grid-height 1))
+	(or weight-x 0.0) (or weight-y 0.0)
+	(magic (or anchor :center)) (magic (or fill :none))
+	(apply #'make-insets (listify insets))
+	(or internal-pad-x 0) (or internal-pad-y 0))))
+
+(let ((builtin-colours (make-hash-table)))
+  (dolist (colour '(:black :blue :cyan :dark-gray :gray :green :light-gray
+		    :magenta :orange :pink :red :white :yellow))
+    (setf (gethash colour builtin-colours)
+	  (class-field :java.awt.*color
+		       (substitute #\_ #\- (string-upcase colour)))))
+  (defun make-colour (&rest arguments)
+    (let ((indicator (car arguments)))
+      (etypecase indicator
+	(null java-null)
+	(java-object indicator)
+	(keyword
+	 (or (gethash indicator builtin-colours)
+	     (error "Colour ~S not found." indicator)))
+	(string
+	 (send-class :java.awt.*color :get-color indicator))
+	(number
+	 (multiple-value-bind (red green blue alpha)
+	     (if (and (integerp indicator) (not (numberp (cadr arguments))))
+		 (destructuring-bind (rgb &key alpha) arguments
+		   (values (ldb (byte 8 16) rgb)
+			   (ldb (byte 8  8) rgb)
+			   (ldb (byte 8  0) rgb)
+			   (case alpha
+			     ((t) (ldb (byte 8 24) rgb))
+			     ((nil) 255)
+			     (t alpha))))
+		 (destructuring-bind (r g b &optional (a 1.0)) arguments
+		   (values r g b a)))
+	   (flet ((fixup (n)
+		    (if (integerp n) n (round (* n 255)))))
+	     (make :java.awt.*color
+		   (fixup red)
+		   (fixup green)
+		   (fixup blue)
+		   (fixup alpha)))))))))
+
+(defun make-group-box (title)
+  (let ((frame (make :javax.swing.*j-panel)))
+    (send frame :set-border
+	  (make :javax.swing.border.*titled-border
+		(make :javax.swing.border.*etched-border
+		      (class-field :javax.swing.border.*etched-border
+				   :*lowered*))
+		title))
+    frame))
+
+;;;----- That's all, folks --------------------------------------------------