Lots of tidying up.

diff --git a/aa-tree.lisp b/aa-tree.lisp
index 6c42746..a08d52d 100644 (file)
--- a/aa-tree.lisp
+++ b/aa-tree.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Andersson tree implementation
 ;;;
 ;;; (c) 2006 Straylight/Edgeware
 ;;; Andersson tree implementation
 ;;;
 ;;; (c) 2006 Straylight/Edgeware


@@ -27,9 +25,7 @@
 ;;; Package.
 
 (defpackage #:aa-tree
 ;;; Package.
 
 (defpackage #:aa-tree

-  (:use #:common-lisp #:mdw.base)
-  (:export #:make-aa-tree #:aa-tree-p #:aa-tree-key<
-          #:getaa #:updateaa #:mapaa #:doaa #:aa-tree-iterator #:remaa))
+  (:use #:common-lisp #:mdw.base))

 (in-package #:aa-tree)
 
 ;;;--------------------------------------------------------------------------
 (in-package #:aa-tree)
 
 ;;;--------------------------------------------------------------------------


@@ -51,6 +47,7 @@
 
 (deftype tree-node () 'simple-vector)
 
 
 (deftype tree-node () 'simple-vector)
 

+(export '(make-aa-tree aa-tree aa-tree-p aa-tree-key<))

 (defstruct (aa-tree
             (:predicate treep)
             (:constructor make-aa-tree
 (defstruct (aa-tree
             (:predicate treep)
             (:constructor make-aa-tree


@@ -103,6 +100,7 @@
        (do ((need (ash size 1) (ash need 1)))
            ((>= need want) (setf (tree-stack tree) (make-array need)))))))
 
        (do ((need (ash size 1) (ash need 1)))
            ((>= need want) (setf (tree-stack tree) (make-array need)))))))
 

+(export 'getaa)

 (defun getaa (tree key &optional default)
   "Look up the given KEY in an Andersson TREE; if the KEY was found, return
    the corresponding data and t, otherwise return DEFAULT and nil."
 (defun getaa (tree key &optional default)
   "Look up the given KEY in an Andersson TREE; if the KEY was found, return
    the corresponding data and t, otherwise return DEFAULT and nil."


@@ -195,6 +193,7 @@
     (cond (node (setf (node-data node) data))
          (t (fixup-insert tree stack sp (make-tree-node key data)) data))))
 
     (cond (node (setf (node-data node) data))
          (t (fixup-insert tree stack sp (make-tree-node key data)) data))))
 

+(export 'updateaa)

 (defun updateaa (tree key func)
   "Search TREE for an item with the given KEY.  If it was found, call FUNC
    with arguments of the node's data and t, and store its result as the
 (defun updateaa (tree key func)
   "Search TREE for an item with the given KEY.  If it was found, call FUNC
    with arguments of the node's data and t, and store its result as the


@@ -208,6 +207,7 @@
               (fixup-insert tree stack sp (make-tree-node key data))
               data)))))
 
               (fixup-insert tree stack sp (make-tree-node key data))
               data)))))
 

+(export 'remaa)

 (defun remaa (tree key)
   "Deletes the node with the given KEY from an Andersson TREE.  Returns t if
    the node was found and deleted, or nil if it wasn't there to begin with."
 (defun remaa (tree key)
   "Deletes the node with the given KEY from an Andersson TREE.  Returns t if
    the node was found and deleted, or nil if it wasn't there to begin with."


@@ -266,6 +266,7 @@
        ;; Store the new root.
        (setf (tree-root tree) node)))))
 
        ;; Store the new root.
        (setf (tree-root tree) node)))))
 

+(export 'aa-tree-iterator)

 (defun aa-tree-iterator (tree)
   "Returns a tree iterator function for TREE.  The function returns three
    values.  For each node in the tree, it returns t, the key and the value;
 (defun aa-tree-iterator (tree)
   "Returns a tree iterator function for TREE.  The function returns three
    values.  For each node in the tree, it returns t, the key and the value;


@@ -287,6 +288,7 @@
                         (pushleft (node-right node))
                         (values t (node-key node) (node-data node)))))))))))
 
                         (pushleft (node-right node))
                         (values t (node-key node) (node-data node)))))))))))
 

+(export 'mapaa)

 (defun mapaa (func tree)
   "Apply FUNC to each key and value in the TREE."
   (labels ((walk (node)
 (defun mapaa (func tree)
   "Apply FUNC to each key and value in the TREE."
   (labels ((walk (node)


@@ -297,6 +299,7 @@
     (walk (tree-root tree))
     nil))
 
     (walk (tree-root tree))
     nil))
 

+(export 'doaa)

 (defmacro doaa ((key value tree &optional result) &body body)
   "Iterate over the items of TREE; for each one, bind KEY to its key and
    VALUE to the associated data, and evaluate BODY, which is an implicit
 (defmacro doaa ((key value tree &optional result) &body body)
   "Iterate over the items of TREE; for each one, bind KEY to its key and
    VALUE to the associated data, and evaluate BODY, which is an implicit

diff --git a/anaphora.lisp b/anaphora.lisp
index be2fae4..d8686e9 100644 (file)
--- a/anaphora.lisp
+++ b/anaphora.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Anaphoric extensions
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; Anaphoric extensions
 ;;;
 ;;; (c) 2005 Straylight/Edgeware

diff --git a/collect.lisp b/collect.lisp
index c275bc5..be689cb 100644 (file)
--- a/collect.lisp
+++ b/collect.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Collecting things into lists
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; Collecting things into lists
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -24,32 +22,31 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:collect
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:collect

-  (:use #:common-lisp #:mdw.base)
-  (:export #:make-collector #:collected
-          #:collecting #:with-collection
-          #:collect #:collect-tail
-          #:collect-append #:collect-nconc))
+  (:use #:common-lisp #:mdw.base))

 (in-package collect)
 
 (eval-when (:compile-toplevel :load-toplevel)
   (defvar *collecting-anon-list-name* (gensym)
     "The default name for anonymous `collecting' lists."))
 
 (in-package collect)
 
 (eval-when (:compile-toplevel :load-toplevel)
   (defvar *collecting-anon-list-name* (gensym)
     "The default name for anonymous `collecting' lists."))
 

+(export 'make-collector)

 (defun make-collector (&optional list)
   "Return a new collector object whose initial contents is LIST.  Note that
    LIST will be destroyed if anything else is collected."
   (let ((head (cons nil list)))
     (setf (car head) (if list (last list) head))))
 
 (defun make-collector (&optional list)
   "Return a new collector object whose initial contents is LIST.  Note that
    LIST will be destroyed if anything else is collected."
   (let ((head (cons nil list)))
     (setf (car head) (if list (last list) head))))
 

+(export 'collected)

 (defmacro collected (&optional (name *collecting-anon-list-name*))
   "Return the current list collected into the collector NAME (or
    *collecting-anon-list-name* by default)."
   `(the list (cdr ,name)))
 
 (defmacro collected (&optional (name *collecting-anon-list-name*))
   "Return the current list collected into the collector NAME (or
    *collecting-anon-list-name* by default)."
   `(the list (cdr ,name)))
 

+(export 'collecting)

 (defmacro collecting (vars &body body)
   "Collect items into lists.  The VARS are a list of collection variables --
    their values are unspecified, except that they may be passed to `collect'
 (defmacro collecting (vars &body body)
   "Collect items into lists.  The VARS are a list of collection variables --
    their values are unspecified, except that they may be passed to `collect'

-   and `collect-tail' If VARS is empty then *collecting-anon-list-name* is
+   and `collect-tail'.  If VARS is empty then *collecting-anon-list-name* is

    used.  VARS may be an atom instead of a singleton list.  The form produces
    multiple values, one for each list constructed."
   (cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
    used.  VARS may be an atom instead of a singleton list.  The form produces
    multiple values, one for each list constructed."
   (cond ((null vars) (setf vars (list *collecting-anon-list-name*)))


@@ -58,14 +55,16 @@
      ,@body
      (values ,@(mapcar (lambda (v) `(collected ,v)) vars))))
 
      ,@body
      (values ,@(mapcar (lambda (v) `(collected ,v)) vars))))
 

+(export 'with-collection)

 (defmacro with-collection (vars collection &body body)
   "Collect items into lists VARS according to the form COLLECTION; then
    evaluate BODY with VARS bound to those lists."
   `(multiple-value-bind
 (defmacro with-collection (vars collection &body body)
   "Collect items into lists VARS according to the form COLLECTION; then
    evaluate BODY with VARS bound to those lists."
   `(multiple-value-bind

-   ,(listify vars)
+       ,(listify vars)

        (collecting ,vars ,collection)
      ,@body))
 
        (collecting ,vars ,collection)
      ,@body))
 

+(export 'collect)

 (defmacro collect (x &optional (name *collecting-anon-list-name*))
   "Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
    by default)."
 (defmacro collect (x &optional (name *collecting-anon-list-name*))
   "Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
    by default)."


@@ -74,6 +73,7 @@
        (setf (cdar ,name) ,new)
        (setf (car ,name) ,new))))
 
        (setf (cdar ,name) ,new)
        (setf (car ,name) ,new))))
 

+(export 'collect-tail)

 (defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
   "Make item X be the tail of `collecting' list NAME (or
    *collecting-anon-list-name* by default).  It is an error to continue
 (defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
   "Make item X be the tail of `collecting' list NAME (or
    *collecting-anon-list-name* by default).  It is an error to continue


@@ -82,6 +82,7 @@
      (setf (cdar ,name) ,x)
      (setf (car ,name) nil)))
 
      (setf (cdar ,name) ,x)
      (setf (car ,name) nil)))
 

+(export 'collect-append)

 (defmacro collect-append (list &optional (name *collecting-anon-list-name*))
   "Append LIST to the tail of `collecting' list NAME.  This obviously
    involves copying LIST."
 (defmacro collect-append (list &optional (name *collecting-anon-list-name*))
   "Append LIST to the tail of `collecting' list NAME.  This obviously
    involves copying LIST."


@@ -89,6 +90,7 @@
     `(dolist (,item ,list)
        (collect ,item ,name))))
 
     `(dolist (,item ,list)
        (collect ,item ,name))))
 

+(export 'collect-nconc)

 (defmacro collect-nconc (list &optional (name *collecting-anon-list-name*))
   "Attach LIST to the tail of `collecting' list NAME.  This will involve
    destroying LIST if anything else gets collected afterwards."
 (defmacro collect-nconc (list &optional (name *collecting-anon-list-name*))
   "Attach LIST to the tail of `collecting' list NAME.  This will involve
    destroying LIST if anything else gets collected afterwards."

diff --git a/dep.lisp b/dep.lisp
index 8a9410d..c437538 100644 (file)
--- a/dep.lisp
+++ b/dep.lisp
@@ -22,12 +22,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:dep
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:dep

-  (:use #:common-lisp #:queue #:weak)
-  (: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))
+  (:use #:common-lisp #:queue #:weak))

 (in-package #:dep)
 
 ;;;--------------------------------------------------------------------------
 (in-package #:dep)
 
 ;;;--------------------------------------------------------------------------


@@ -86,6 +81,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Data structures.
 
 ;;;--------------------------------------------------------------------------
 ;;; Data structures.
 

+(export '(dep depp dep-name))

 (defstruct (dep (:predicate depp)
                (:constructor %make-dep))
   "There are two kinds of `dep', though we use the same object type for both.
 (defstruct (dep (:predicate depp)
                (:constructor %make-dep))
   "There are two kinds of `dep', though we use the same object type for both.


@@ -99,9 +95,9 @@
    value of a bad dep results in a throw of `bad-dep'.  Badness propagates
    automatically during recomputation phases."
   (%value .bad. :type t)
    value of a bad dep results in a throw of `bad-dep'.  Badness propagates
    automatically during recomputation phases."
   (%value .bad. :type t)

-  (name nil :type t)
-  (value-function nil :type (or function null))
-  (value-predicate #'eql :type function)
+  (name nil :type t :read-only t)
+  (value-function nil :type (or function null) :read-only t)
+  (value-predicate #'eql :type function :read-only t)

   (%flags 0 :type (unsigned-byte 8))
   (generation *generation* :type list)
   (listeners nil :type list)
   (%flags 0 :type (unsigned-byte 8))
   (generation *generation* :type list)
   (listeners nil :type list)


@@ -238,6 +234,7 @@
     (pushnew dep (dep-dependencies *evaluating-dep*)))
   (force-dep-value dep))
 
     (pushnew dep (dep-dependencies *evaluating-dep*)))
   (force-dep-value dep))
 

+(export 'dep-value)

 (declaim (inline dep-value))
 (defun dep-value (dep)
   "Retrieve the current value from DEP."
 (declaim (inline dep-value))
 (defun dep-value (dep)
   "Retrieve the current value from DEP."


@@ -248,12 +245,14 @@
        (throw 'dep-bad .bad.)
        value)))
 
        (throw 'dep-bad .bad.)
        value)))
 

+(export 'dep-goodp)

 (defun dep-goodp (dep)
   "Answer whether DEP is good."
   (when (eq *state* :recomputing)
     (force-dep-value dep))
   (not (eq (dep-%value dep) .bad.)))
 
 (defun dep-goodp (dep)
   "Answer whether DEP is good."
   (when (eq *state* :recomputing)
     (force-dep-value dep))
   (not (eq (dep-%value dep) .bad.)))
 

+(export 'dep-try)

 (defmacro dep-try (expr &body body)
   "Evaluate EXPR.  If it throws DEP-BAD then evaluate BODY instead."
   (let ((block-name (gensym "TRY")))
 (defmacro dep-try (expr &body body)
   "Evaluate EXPR.  If it throws DEP-BAD then evaluate BODY instead."
   (let ((block-name (gensym "TRY")))


@@ -262,6 +261,7 @@
         (return-from ,block-name ,expr))
        ,@body)))
 
         (return-from ,block-name ,expr))
        ,@body)))
 

+(export 'dep-bad)

 (defun dep-bad ()
   "Call from a value-function: indicates that the dep should marked as bad."
   (throw 'dep-bad nil))
 (defun dep-bad ()
   "Call from a value-function: indicates that the dep should marked as bad."
   (throw 'dep-bad nil))


@@ -308,6 +308,7 @@
                 (return))
               (funcall (dequeue *delayed-operations*))))))))
 
                 (return))
               (funcall (dequeue *delayed-operations*))))))))
 

+(export 'with-deps-frozen)

 (defmacro with-deps-frozen ((&key delay) &body body)
   "Evaluate BODY in the :FROZEN state.
 
 (defmacro with-deps-frozen ((&key delay) &body body)
   "Evaluate BODY in the :FROZEN state.
 


@@ -346,16 +347,19 @@
       (propagate-to-dependents dep)))
   value)
 
       (propagate-to-dependents dep)))
   value)
 

+(export 'dep-make-bad)

 (defun dep-make-bad (dep)
   "Mark DEP as being bad."
   (setf (dep-value dep) .bad.))
 
 (defun dep-make-bad (dep)
   "Mark DEP as being bad."
   (setf (dep-value dep) .bad.))
 

+(export 'dep-add-listener)

 (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-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)))
 

+(export 'make-dep)

 (defun make-dep (&rest args)
   "Create a new DEP object.  There are two basic argument forms:
 
 (defun make-dep (&rest args)
   "Create a new DEP object.  There are two basic argument forms:
 


@@ -429,6 +433,7 @@
            (enqueue dep *pending-deps*)))
        dep))))
 
            (enqueue dep *pending-deps*)))
        dep))))
 

+(export 'install-dep-syntax)

 (defun install-dep-syntax (&optional (readtable *readtable*))
   "Installs into the given READTABLE some syntactic shortcuts:
 
 (defun install-dep-syntax (&optional (readtable *readtable*))
   "Installs into the given READTABLE some syntactic shortcuts:
 

diff --git a/factorial.lisp b/factorial.lisp
index 3a76843..64c521e 100644 (file)
--- a/factorial.lisp
+++ b/factorial.lisp
@@ -22,28 +22,25 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.factorial
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.factorial

-  (:use #:common-lisp)
-  (:export #:factorial))
+  (:use #:common-lisp))

 (in-package #:mdw.factorial)
 
 (in-package #:mdw.factorial)
 

+(export 'factorial)

 (defun factorial (n)
 (defun factorial (n)

-  "Compute a factorial.  This is a little bit optimized: we try to multiply
-   values which are similar in size."
+  "Compute a factorial."
+
+  ;; This is a little bit optimized: we try to multiply values which are
+  ;; similar in size.

   (when (minusp n)
     (error "negative factorial argument ~A" n))
   (when (minusp n)
     (error "negative factorial argument ~A" n))

-  (let ((stack nil))
-    (do ((i 2 (1+ i)))
-       ((> i n))
-      (let ((f i))
-       (loop
-         (unless stack (return))
-         (let ((top (car stack)))
-           (when (< f top) (return))
-           (setf f (* f top))
-           (pop stack)))
-       (push f stack)))
-    (do ((stack stack (cdr stack))
-        (a 1 (* a (car stack))))
-       ((null stack) a))))
+  (do ((i 2 (1+ i))
+       (stack nil (do ((s stack (cdr s))
+                      (f i (* f (car s))))
+                     ((or (null s) (< f (car s)))
+                      (cons f s)))))
+      ((> i n)
+       (do ((s stack (cdr s))
+           (a 1 (* a (car s))))
+          ((null s) a)))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/heap.lisp b/heap.lisp
index 53eb2b8..7eb4587 100644 (file)
--- a/heap.lisp
+++ b/heap.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Heap data structure; useful for priority queues and suchlike
 ;;;
 ;;; (c) 2006 Straylight/Edgeware
 ;;; Heap data structure; useful for priority queues and suchlike
 ;;;
 ;;; (c) 2006 Straylight/Edgeware


@@ -24,10 +22,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:heap
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:heap

-  (:use #:common-lisp)
-  (:export #:make-heap #:heap-count #:heap-empty-p
-          #:heap-insert #:heap-head #:heap-remove
-          #:heap-sort))
+  (:use #:common-lisp))

 (in-package #:heap)
 
 ;;;--------------------------------------------------------------------------
 (in-package #:heap)
 
 ;;;--------------------------------------------------------------------------


@@ -108,13 +103,15 @@
 ;;;--------------------------------------------------------------------------
 ;;; High-level heap things
 
 ;;;--------------------------------------------------------------------------
 ;;; High-level heap things
 

+(export '(heap heapp))

 (defstruct (heap (:predicate heapp) (:constructor %make-heap))
   "Data structure for a heap."
   (v (make-array 16) :type vector)
   (n 0 :type index)
 (defstruct (heap (:predicate heapp) (:constructor %make-heap))
   "Data structure for a heap."
   (v (make-array 16) :type vector)
   (n 0 :type index)

-  (key #'identity :type function)
-  (compare #'<= :type function))
+  (key #'identity :type function :read-only t)
+  (compare #'<= :type function :read-only t))

 
 

+(export 'make-heap)

 (defun make-heap
     (&key (compare #'<=) (key #'identity)
          (type 't) (init-size 16) (contents nil contentsp))
 (defun make-heap
     (&key (compare #'<=) (key #'identity)
          (type 't) (init-size 16) (contents nil contentsp))


@@ -146,16 +143,19 @@
                :initial-value 0))
       (%make-heap :compare compare :key key :n n :v v))))
 
                :initial-value 0))
       (%make-heap :compare compare :key key :n n :v v))))
 

+(export 'heap-count)

 (defun heap-count (heap)
   "Return the number of elements in HEAP."
   (declare (type heap heap))
   (heap-n heap))
 
 (defun heap-count (heap)
   "Return the number of elements in HEAP."
   (declare (type heap heap))
   (heap-n heap))
 

+(export 'heap-empty-p)

 (defun heap-empty-p (heap)
   "True if HEAP is empty."
   (declare (type heap heap))
   (zerop (heap-count heap)))
 
 (defun heap-empty-p (heap)
   "True if HEAP is empty."
   (declare (type heap heap))
   (zerop (heap-count heap)))
 

+(export 'heap-insert)

 (defun heap-insert (heap item)
   "Insert ITEM into the HEAP."
   (declare (type heap heap))
 (defun heap-insert (heap item)
   "Insert ITEM into the HEAP."
   (declare (type heap heap))


@@ -168,12 +168,14 @@
     (upheap v (heap-key heap) (heap-compare heap) n item)
     (setf (heap-n heap) (1+ n))))
 
     (upheap v (heap-key heap) (heap-compare heap) n item)
     (setf (heap-n heap) (1+ n))))
 

+(export 'heap-head)

 (defun heap-head (heap)
   "Peep at the head item on HEAP."
   (declare (type heap heap))
   (assert (not (heap-empty-p heap)))
   (aref (heap-v heap) 0))
 
 (defun heap-head (heap)
   "Peep at the head item on HEAP."
   (declare (type heap heap))
   (assert (not (heap-empty-p heap)))
   (aref (heap-v heap) 0))
 

+(export 'heap-remove)

 (defun heap-remove (heap)
   "Remove the head item from HEAP and return it."
   (declare (type heap heap))
 (defun heap-remove (heap)
   "Remove the head item from HEAP and return it."
   (declare (type heap heap))


@@ -184,6 +186,7 @@
       (setf (heap-n heap) n)
       (downheap v (heap-key heap) (heap-compare heap) n (aref v n)))))
 
       (setf (heap-n heap) n)
       (downheap v (heap-key heap) (heap-compare heap) n (aref v n)))))
 

+(export 'heap-sort)

 (defun heap-sort (items compare &key (key #'identity))
   "Return the ITEMS, least-first, as sorted by the ordering COMPARE."
   (let ((heap (make-heap :compare compare :contents items :key key)))
 (defun heap-sort (items compare &key (key #'identity))
   "Return the ITEMS, least-first, as sorted by the ordering COMPARE."
   (let ((heap (make-heap :compare compare :contents items :key key)))

diff --git a/infix.lisp b/infix.lisp
index ff5a3c9..88b976c 100644 (file)
--- a/infix.lisp
+++ b/infix.lisp
@@ -38,24 +38,15 @@
           #:bind))
 
 (defpackage #:infix
           #:bind))
 
 (defpackage #:infix

-  (:use #:common-lisp #:infix-keywords)
-  (:export #:operator #:operatorp
-          #:*token* #:get-token #:*get-token*
-          #:pushval #:popval #:flushops #:pushop
-          #:infix-done #:parse-infix
-          #:defopfunc #:definfix #:defprefix #:defpostfix
-          #:infix #:prefix #:postfix #:operand
-          #:delim #:errfunc
-          #:binop-apply #:binop-apply-append
-          #:unop-apply #:unop-apply-toggle
-          #:strip-progn
-          #:read-infix #:install-infix-reader))
+  (:use #:common-lisp #:infix-keywords))

 
 (in-package #:infix)
 
 ;;;--------------------------------------------------------------------------
 ;;; Data structures.
 
 
 (in-package #:infix)
 
 ;;;--------------------------------------------------------------------------
 ;;; Data structures.
 

+(export '(operator operatorp
+         op-name op-lprec op-rprec op-func))

 (defstruct (operator (:predicate operatorp)
                     (:conc-name op-))
   "An operator object.  The name serves mainly for documentation.  The left
 (defstruct (operator (:predicate operatorp)
                     (:conc-name op-))
   "An operator object.  The name serves mainly for documentation.  The left


@@ -67,10 +58,12 @@
    /left/-precedence are popped before this operator can be pushed.  If the
    right precedence is nil, then this operator is not in fact pushed, but
    processed immediately."
    /left/-precedence are popped before this operator can be pushed.  If the
    right precedence is nil, then this operator is not in fact pushed, but
    processed immediately."

-  (name nil :type symbol)
-  (lprec nil :type (or fixnum null))
-  (rprec nil :type (or fixnum null))
-  (func (lambda () nil) :type #-ecl (function () t) #+ecl function))
+  (name nil :type symbol :read-only t)
+  (lprec nil :type (or fixnum null) :read-only t)
+  (rprec nil :type (or fixnum null) :read-only t)
+  (func (lambda () nil)
+       :type #-ecl (function () t) #+ecl function
+       :read-only t))

 
 ;;;--------------------------------------------------------------------------
 ;;; Global parser state.
 
 ;;;--------------------------------------------------------------------------
 ;;; Global parser state.


@@ -85,6 +78,7 @@
   "Value stack.  Contains (partially constructed) Lisp forms.")
 (defvar *opstk* nil
   "Operator stack.  Contains operator objects.")
   "Value stack.  Contains (partially constructed) Lisp forms.")
 (defvar *opstk* nil
   "Operator stack.  Contains operator objects.")

+(export '*token*)

 (defvar *token* nil
   "The current token.  Could be any Lisp object.")
 (defvar *paren-depth* 0
 (defvar *token* nil
   "The current token.  Could be any Lisp object.")
 (defvar *paren-depth* 0


@@ -149,9 +143,11 @@
           ((#\newline) (go top))
           (t (go comment)))))))
 
           ((#\newline) (go top))
           (t (go comment)))))))
 

+(export '*get-token*)

 (defvar *get-token* #'default-get-token
   "The current tokenizing function.")
 
 (defvar *get-token* #'default-get-token
   "The current tokenizing function.")
 

+(export 'get-token)

 (defun get-token ()
   "Read a token, and store it in *token*.  Indirects via *get-token*."
   (funcall *get-token*))
 (defun get-token ()
   "Read a token, and store it in *token*.  Indirects via *get-token*."
   (funcall *get-token*))


@@ -159,14 +155,17 @@
 ;;;--------------------------------------------------------------------------
 ;;; Stack manipulation.
 
 ;;;--------------------------------------------------------------------------
 ;;; Stack manipulation.
 

+(export 'pushval)

 (defun pushval (val)
   "Push VAL onto the value stack."
   (push val *valstk*))
 
 (defun pushval (val)
   "Push VAL onto the value stack."
   (push val *valstk*))
 

+(export 'popval)

 (defun popval ()
   "Pop a value off the value stack and return it."
   (pop *valstk*))
 
 (defun popval ()
   "Pop a value off the value stack and return it."
   (pop *valstk*))
 

+(export 'flushops)

 (defun flushops (prec)
   "Flush out operators on the operator stack with precedecnce higher than or
    equal to PREC.  This is used when a new operator is pushed, to ensure that
 (defun flushops (prec)
   "Flush out operators on the operator stack with precedecnce higher than or
    equal to PREC.  This is used when a new operator is pushed, to ensure that


@@ -180,6 +179,7 @@
       (pop *opstk*)
       (funcall (op-func head)))))
 
       (pop *opstk*)
       (funcall (op-func head)))))
 

+(export 'pushop)

 (defun pushop (op)
   "Push the operator OP onto the stack.  If the operator has a
    left-precedence, then operators with higher precedence are flushed (see
 (defun pushop (op)
   "Push the operator OP onto the stack.  If the operator has a
    left-precedence, then operators with higher precedence are flushed (see


@@ -195,12 +195,14 @@
 ;;;--------------------------------------------------------------------------
 ;;; The main parser.
 
 ;;;--------------------------------------------------------------------------
 ;;; The main parser.
 

+(export 'infix-done)

 (defun infix-done ()
   "Signal that `parse-infix' has reached the end of an expression.  This is
    primarily used by the `)' handler function if it finds there are no
    parentheses."
   (throw 'infix-done nil))
 
 (defun infix-done ()
   "Signal that `parse-infix' has reached the end of an expression.  This is
    primarily used by the `)' handler function if it finds there are no
    parentheses."
   (throw 'infix-done nil))
 

+(export 'parse-infix)

 (defun parse-infix (&optional minprec)
   "Parses an infix expression and return the resulting Lisp form.  This is
    the heart of the whole thing.
 (defun parse-infix (&optional minprec)
   "Parses an infix expression and return the resulting Lisp form.  This is
    the heart of the whole thing.


@@ -275,6 +277,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Machinery for defining operators.
 
 ;;;--------------------------------------------------------------------------
 ;;; Machinery for defining operators.
 

+(export 'defopfunc)

 (defmacro defopfunc (op kind &body body)
   "Defines a magical operator.  The operator's name is the symbol OP.  The
    KIND must be one of the symbols `infix', `prefix' or `postfix'.  The body
 (defmacro defopfunc (op kind &body body)
   "Defines a magical operator.  The operator's name is the symbol OP.  The
    KIND must be one of the symbols `infix', `prefix' or `postfix'.  The body


@@ -286,6 +289,7 @@
           (lambda () ,@body))
     ',op))
 
           (lambda () ,@body))
     ',op))
 

+(export 'definfix)

 (defmacro definfix (op prec &body body)
   "Defines an infix operator.  The operator's name is the symbol OP.  The
    operator's precedence is specified by PREC, which may be one of the
 (defmacro definfix (op prec &body body)
   "Defines an infix operator.  The operator's name is the symbol OP.  The
    operator's precedence is specified by PREC, which may be one of the


@@ -345,12 +349,16 @@
                               (postfix :lprec)) ,prec
                            :func (lambda () ,@body)))
        ',op)))
                               (postfix :lprec)) ,prec
                            :func (lambda () ,@body)))
        ',op)))

+
+(export 'defprefix)

 (defmacro defprefix (op prec &body body)
   "Defines a prefix operator.  The operator's name is the symbol OP.  The
    operator's (right) precedence is PREC.  The body is evaluated with the
    operator's argument is fully determined.  It should pop off one argument
    and push one result."
   (do-defunary 'prefix op prec body))
 (defmacro defprefix (op prec &body body)
   "Defines a prefix operator.  The operator's name is the symbol OP.  The
    operator's (right) precedence is PREC.  The body is evaluated with the
    operator's argument is fully determined.  It should pop off one argument
    and push one result."
   (do-defunary 'prefix op prec body))

+
+(export 'defpostfix)

 (defmacro defpostfix (op prec &body body)
   "Defines a postfix operator.  The operator's name is the symbol OP.  The
    operator's (left) precedence is PREC.  The body is evaluated with the
 (defmacro defpostfix (op prec &body body)
   "Defines a postfix operator.  The operator's name is the symbol OP.  The
    operator's (left) precedence is PREC.  The body is evaluated with the


@@ -361,6 +369,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Infrastructure for operator definitions.
 
 ;;;--------------------------------------------------------------------------
 ;;; Infrastructure for operator definitions.
 

+(export 'delim)

 (defun delim (delim &optional (requiredp t))
   "Parse DELIM, and read the next token.  Returns t if the DELIM was found,
    or nil if not (and REQUIREDP was nil)."
 (defun delim (delim &optional (requiredp t))
   "Parse DELIM, and read the next token.  Returns t if the DELIM was found,
    or nil if not (and REQUIREDP was nil)."


@@ -368,17 +377,20 @@
        (requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
        (t nil)))
 
        (requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
        (t nil)))
 

+(export 'errfunc)

 (defun errfunc (&rest args)
   "Returns a function which reports an error.  Useful when constructing
    operators by hand."
   (lambda () (apply #'error args)))
 
 (defun errfunc (&rest args)
   "Returns a function which reports an error.  Useful when constructing
    operators by hand."
   (lambda () (apply #'error args)))
 

+(export 'binop-apply)

 (defun binop-apply (name)
   "Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
    if the top two items are Y and X, then we push (NAME X Y)."
   (let ((y (popval)) (x (popval)))
     (pushval (list name x y))))
 
 (defun binop-apply (name)
   "Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
    if the top two items are Y and X, then we push (NAME X Y)."
   (let ((y (popval)) (x (popval)))
     (pushval (list name x y))))
 

+(export 'binop-apply-append)

 (defun binop-apply-append (name)
   "As for `binop-apply' but if the second-from-top item on the stack has the
    form (NAME SOMETHING ...) then fold the top item into the form rather than
 (defun binop-apply-append (name)
   "As for `binop-apply' but if the second-from-top item on the stack has the
    form (NAME SOMETHING ...) then fold the top item into the form rather than


@@ -388,11 +400,13 @@
                 (append x (list y))
                 (list name x y)))))
 
                 (append x (list y))
                 (list name x y)))))
 

+(export 'unop-apply)

 (defun unop-apply (name)
   "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
    top item is X, then push (NAME X)."
   (pushval (list name (popval))))
 
 (defun unop-apply (name)
   "Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
    top item is X, then push (NAME X)."
   (pushval (list name (popval))))
 

+(export 'unop-apply-toggle)

 (defun unop-apply-toggle (name)
   "As for `unop-apply', but if the top item has the form (NAME X) already,
    then push just X."
 (defun unop-apply-toggle (name)
   "As for `unop-apply', but if the top item has the form (NAME X) already,
    then push just X."


@@ -404,6 +418,7 @@
                 (cadr x)
                 (list name x)))))
 
                 (cadr x)
                 (list name x)))))
 

+(export 'strip-progn)

 (defun strip-progn (form)
   "Return a version of FORM suitable for putting somewhere where there's an
    implicit `progn'.  If FORM has the form (PROGN . FOO) then return FOO,
 (defun strip-progn (form)
   "Return a version of FORM suitable for putting somewhere where there's an
    implicit `progn'.  If FORM has the form (PROGN . FOO) then return FOO,


@@ -413,6 +428,7 @@
       (cdr form)
       (list form)))
 
       (cdr form)
       (list form)))
 

+(export 'parse-expr-list)

 (defun parse-expr-list ()
   "Parse a list of expressions separated by commas."
   (let ((stuff nil))
 (defun parse-expr-list ()
   "Parse a list of expressions separated by commas."
   (let ((stuff nil))


@@ -422,6 +438,7 @@
        (return)))
     (nreverse stuff)))
 
        (return)))
     (nreverse stuff)))
 

+(export 'parse-ident-list)

 (defun parse-ident-list ()
   "Parse a list of symbols separated by commas."
   (let ((stuff nil))
 (defun parse-ident-list ()
   "Parse a list of symbols separated by commas."
   (let ((stuff nil))


@@ -493,6 +510,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Parentheses, for grouping and function-calls.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parentheses, for grouping and function-calls.
 

+(export 'push-paren)

 (defun push-paren (right)
   "Pushes a funny parenthesis operator.  Since this operator has no left
    precedence, and very low right precedence, it is pushed over any stack of
 (defun push-paren (right)
   "Pushes a funny parenthesis operator.  Since this operator has no left
    precedence, and very low right precedence, it is pushed over any stack of


@@ -504,6 +522,7 @@
   (incf *paren-depth*)
   (get-token))
 
   (incf *paren-depth*)
   (get-token))
 

+(export 'pop-paren)

 (defun pop-paren (right)
   "Pops a parenthesis.  If there are no parentheses, maybe they belong to the
    caller's syntax.  Otherwise, pop off operators above the current funny
 (defun pop-paren (right)
   "Pops a parenthesis.  If there are no parentheses, maybe they belong to the
    caller's syntax.  Otherwise, pop off operators above the current funny


@@ -710,6 +729,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; User-interface stuff.
 
 ;;;--------------------------------------------------------------------------
 ;;; User-interface stuff.
 

+(export 'read-infix)

 (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
   "Reads an infix expression from STREAM and returns the corresponding Lisp.
    Requires the expression to be delimited properly by DELIM (by default
 (defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
   "Reads an infix expression from STREAM and returns the corresponding Lisp.
    Requires the expression to be delimited properly by DELIM (by default


@@ -721,6 +741,7 @@
       (unless (eq *token* delim)
        (error "expected ~S; found ~S" delim *token*)))))
 
       (unless (eq *token* delim)
        (error "expected ~S; found ~S" delim *token*)))))
 

+(export 'install-infix-reader)

 (defun install-infix-reader
     (&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
   "Installs a macro character `{ INFIX... }' for translating infix notation
 (defun install-infix-reader
     (&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
   "Installs a macro character `{ INFIX... }' for translating infix notation


@@ -738,7 +759,7 @@
                      (func nontermp)
                      (get-macro-character end readtable)
                    (and func (not nontermp))))
                      (func nontermp)
                      (get-macro-character end readtable)
                    (and func (not nontermp))))

-       (set-macro-character end (lambda (noise)
+       (set-macro-character end (lambda (&rest noise)

                                   (declare (ignore noise))
                                   (error "Unexpected `~C'." end))
                             nil readtable)))))
                                   (declare (ignore noise))
                                   (error "Unexpected `~C'." end))
                             nil readtable)))))

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 2bad2c2..774ea9f 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Basic definitions
 ;;;
 ;;; (c) 2005 Mark Wooding
 ;;; Basic definitions
 ;;;
 ;;; (c) 2005 Mark Wooding


@@ -193,6 +191,15 @@
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 

+(export 'symbolicate)
+(defun symbolicate (&rest names)
+  "Return a symbol constructued by concatenating the NAMES.
+
+   The NAMES are coerced to strings, using the `string' function, so they may
+   be strings, characters, or symbols.  The resulting symbol is interned in
+   the current `*package*'."
+  (intern (apply #'concatenate 'string (mapcar #'string names))))
+

 (export 'with-gensyms)
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
 (export 'with-gensyms)
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index e744fcd..01c829c 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Useful bits of MOP hacking
 ;;;
 ;;; (c) 2006 Straylight/Edgeware
 ;;; Useful bits of MOP hacking
 ;;;
 ;;; (c) 2006 Straylight/Edgeware


@@ -30,25 +28,14 @@
   (:use #:common-lisp #:mdw.base
        #+(or cmu clisp) #:mop
        #+sbcl #:sb-mop
   (:use #:common-lisp #:mdw.base
        #+(or cmu clisp) #:mop
        #+sbcl #:sb-mop

-       #+ecl #:clos)
-  (:export #:copy-instance #:copy-instance-using-class
-          #:with-slot-variables
-          #:compatible-class
-          #:initargs-for-effective-slot #:make-effective-slot
-          #:filtered-slot-class-mixin
-            #:filtered-direct-slot-definition
-            #:filtered-effective-slot-definition
-          #:predicate-class-mixin
-          #:abstract-class-mixin #:instantiate-abstract-class
-          #:singleton-class-mixin
-          #:mdw-class #:abstract-class #:singleton-class
-          #:print-object-with-slots))
+       #+ecl #:clos))

 
 (in-package #:mdw.mop)
 
 ;;;--------------------------------------------------------------------------
 ;;; Copying instances.
 
 
 (in-package #:mdw.mop)
 
 ;;;--------------------------------------------------------------------------
 ;;; Copying instances.
 

+(export 'copy-instance-using-class)

 (defgeneric copy-instance-using-class (class object &rest initargs)
   (:documentation
    "Does the donkey-work behind copy-instance."))
 (defgeneric copy-instance-using-class (class object &rest initargs)
   (:documentation
    "Does the donkey-work behind copy-instance."))


@@ -62,6 +49,7 @@
     (apply #'shared-initialize new nil initargs)
     new))
 
     (apply #'shared-initialize new nil initargs)
     new))
 

+(export 'copy-instance)

 (defun copy-instance (object &rest initargs)
   "Make a copy of OBJECT, modifying it by setting slots as requested by
    INITARGS."
 (defun copy-instance (object &rest initargs)
   "Make a copy of OBJECT, modifying it by setting slots as requested by
    INITARGS."


@@ -70,6 +58,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Handy macros.
 
 ;;;--------------------------------------------------------------------------
 ;;; Handy macros.
 

+(export 'with-slot-variables)

 (defmacro with-slot-variables (slots instance &body body)
   "A copy-out-and-write-back variant of with-slots.
 
 (defmacro with-slot-variables (slots instance &body body)
   "A copy-out-and-write-back variant of with-slots.
 


@@ -139,6 +128,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 
 ;;;--------------------------------------------------------------------------
 ;;; Basic stuff.
 

+(export 'compatible-class)

 (defclass compatible-class (standard-class)
   ()
   (:documentation
 (defclass compatible-class (standard-class)
   ()
   (:documentation


@@ -161,6 +151,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Utilities for messing with slot options.
 
 ;;;--------------------------------------------------------------------------
 ;;; Utilities for messing with slot options.
 

+(export 'initargs-for-effective-slot)

 (defgeneric initargs-for-effective-slot (class direct-slots)
   (:documentation
    "Missing functionality from the MOP: given a class and its direct slots
 (defgeneric initargs-for-effective-slot (class direct-slots)
   (:documentation
    "Missing functionality from the MOP: given a class and its direct slots


@@ -185,8 +176,9 @@
                                    direct-slots)))
          :allocation (slot-definition-allocation (car direct-slots)))))
 
                                    direct-slots)))
          :allocation (slot-definition-allocation (car direct-slots)))))
 

+(export 'make-effective-slot)

 (defun make-effective-slot (class initargs)
 (defun make-effective-slot (class initargs)

-  "Construct an effectie slot definition for a slot on the class, given the
+  "Construct an effective slot definition for a slot on the class, given the

    required arguments."
   (apply #'make-instance
         (apply #'effective-slot-definition-class class initargs)
    required arguments."
   (apply #'make-instance
         (apply #'effective-slot-definition-class class initargs)


@@ -212,6 +204,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Filterered slots.
 
 ;;;--------------------------------------------------------------------------
 ;;; Filterered slots.
 

+(export 'filtered-slot-class-mixin)

 (defclass filtered-slot-class-mixin (compatible-class)
   ()
   (:documentation
 (defclass filtered-slot-class-mixin (compatible-class)
   ()
   (:documentation


@@ -224,10 +217,12 @@
 (defgeneric slot-definition-filter (slot)
   (:method ((slot slot-definition)) nil))
 
 (defgeneric slot-definition-filter (slot)
   (:method ((slot slot-definition)) nil))
 

+(export 'filtered-direct-slot-definition)

 (defclass filtered-direct-slot-definition
     (standard-direct-slot-definition)
   ((filter :initarg :filter :reader slot-definition-filter)))
 
 (defclass filtered-direct-slot-definition
     (standard-direct-slot-definition)
   ((filter :initarg :filter :reader slot-definition-filter)))
 

+(export 'filtered-effective-slot-definition)

 (defclass filtered-effective-slot-definition
     (standard-effective-slot-definition)
   ((filter :initarg :filter :accessor slot-definition-filter)))
 (defclass filtered-effective-slot-definition
     (standard-effective-slot-definition)
   ((filter :initarg :filter :accessor slot-definition-filter)))


@@ -276,6 +271,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Predicates.
 
 ;;;--------------------------------------------------------------------------
 ;;; Predicates.
 

+(export 'predicate-class-mixin)

 (defclass predicate-class-mixin (compatible-class)
   ((predicates :type list :initarg :predicate :initform nil
               :documentation "Predicate generic function to create."))
 (defclass predicate-class-mixin (compatible-class)
   ((predicates :type list :initarg :predicate :initform nil
               :documentation "Predicate generic function to create."))


@@ -310,12 +306,14 @@
 ;;;--------------------------------------------------------------------------
 ;;; Abstract classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Abstract classes.
 

+(export 'abstract-class-mixin)

 (defclass abstract-class-mixin (compatible-class)
   ()
   (:documentation
    "Confusingly enough, a concrete metaclass for abstract classes.  This
     class has a `make-instance' implementation which signals an error."))
 
 (defclass abstract-class-mixin (compatible-class)
   ()
   (:documentation
    "Confusingly enough, a concrete metaclass for abstract classes.  This
     class has a `make-instance' implementation which signals an error."))
 

+(export '(instantiate-abstract-class instantiate-abstract-class-class))

 (define-condition instantiate-abstract-class (error)
   ((class :reader instantiate-abstract-class-class :initarg :class
          :documentation "The class someone attempted to instantiate."))
 (define-condition instantiate-abstract-class (error)
   ((class :reader instantiate-abstract-class-class :initarg :class
          :documentation "The class someone attempted to instantiate."))


@@ -333,6 +331,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Singleton classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Singleton classes.
 

+(export 'singleton-class-mixin)

 (defclass singleton-class-mixin (compatible-class)
   ((instance :initform nil :type (or null standard-object)))
   (:documentation
 (defclass singleton-class-mixin (compatible-class)
   ((instance :initform nil :type (or null standard-object)))
   (:documentation


@@ -349,6 +348,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Useful classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Useful classes.
 

+(export 'mdw-class)

 (defclass mdw-class (filtered-slot-class-mixin
                     predicate-class-mixin
                     compatible-class)
 (defclass mdw-class (filtered-slot-class-mixin
                     predicate-class-mixin
                     compatible-class)


@@ -359,12 +359,16 @@
     metaclass for all your classes if you don't use any of its fancy
     features."))
 
     metaclass for all your classes if you don't use any of its fancy
     features."))
 

+(export 'abstract-class)

 (defclass abstract-class (mdw-class abstract-class-mixin) ())
 (defclass abstract-class (mdw-class abstract-class-mixin) ())

+
+(export 'singleton-class)

 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.
 
 (defclass singleton-class (mdw-class singleton-class-mixin) ())
 
 ;;;--------------------------------------------------------------------------
 ;;; Printing things.
 

+(export 'print-object-with-slots)

 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."
   (let ((class (class-of obj))
 (defun print-object-with-slots (obj stream)
   "Prints objects in a pleasant way.  Not too clever about circularity."
   (let ((class (class-of obj))

diff --git a/optparse.lisp b/optparse.lisp
index a949128..b418017 100644 (file)
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Option parser, standard issue
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; Option parser, standard issue
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -27,37 +25,22 @@
 ;;; Packages.
 
 (defpackage #:optparse
 ;;; Packages.
 
 (defpackage #:optparse

-  (:use #:common-lisp #:mdw.base #:mdw.sys-base)
-  (:export #:exit #:*program-name* #:*command-line*
-          #:moan #:die
-          #:option #:optionp #:make-option
-            #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
-            #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
-          #:option-parser #:make-option-parser #:option-parser-p
-            #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
-            #:op-negated-numeric-p #:op-negated-p
-          #:option-parse-error
-          #:option-parse-remainder #:option-parse-next #:option-parse-try
-            #:with-unix-error-reporting #:option-parse-return
-          #:defopthandler #:invoke-option-handler
-            #:set #:clear #:inc #:dec #:read #:int #:string
-            #:keyword #:list
-          #:parse-option-form #:options
-          #:simple-usage #:show-usage #:show-version #:show-help
-          #:sanity-check-option-list
-          #:*help* #:*version* #:*usage* #:*options*
-          #:do-options #:help-options
-          #:define-program #:do-usage #:die-usage))
+  (:use #:common-lisp #:mdw.base #:mdw.sys-base))

 
 (in-package #:optparse)
 
 
 (in-package #:optparse)
 

+;; Re-export symbols from sys-base.
+(export '(exit *program-name* *command-line*))
+

 ;;;--------------------------------------------------------------------------
 ;;; Standard error-reporting functions.
 
 ;;;--------------------------------------------------------------------------
 ;;; Standard error-reporting functions.
 

+(export 'moan)

 (defun moan (msg &rest args)
   "Report an error message in the usual way."
   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
 
 (defun moan (msg &rest args)
   "Report an error message in the usual way."
   (format *error-output* "~&~A: ~?~%" *program-name* msg args))
 

+(export 'die)

 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)
 (defun die (&rest args)
   "Report an error message and exit."
   (apply #'moan args)


@@ -66,8 +49,12 @@
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.
 
 ;;;--------------------------------------------------------------------------
 ;;; The main option parser.
 

+(export '*options*)

 (defvar *options* nil)
 
 (defvar *options* nil)
 

+(export '(option optionp make-option
+         opt-short-name opt-long-name opt-tag opt-negated-tag
+         opt-arg-name opt-arg-optional-p opt-documentation))

 (defstruct (option
             (:predicate optionp)
             (:conc-name opt-)
 (defstruct (option
             (:predicate optionp)
             (:conc-name opt-)


@@ -121,14 +108,17 @@
                text.
 
    Usually, one won't use make-option, but use the option macro instead."
                text.
 
    Usually, one won't use make-option, but use the option macro instead."

-  (long-name nil :type (or null string))
-  (tag nil :type t)
-  (negated-tag nil :type t)
-  (short-name nil :type (or null character))
-  (arg-name nil :type (or null string))
-  (arg-optional-p nil :type t)
-  (documentation nil :type (or null string)))
-
+  (long-name nil :type (or null string) :read-only t)
+  (tag nil :type t :read-only t)
+  (negated-tag nil :type t :read-only t)
+  (short-name nil :type (or null character) :read-only t)
+  (arg-name nil :type (or null string) :read-only t)
+  (arg-optional-p nil :type t :read-only t)
+  (documentation nil :type (or null string)) :read-only t)
+
+(export '(option-parser option-parser-p make-option-parser
+         op-options op-non-option op-long-only-p
+         op-numeric-p op-negated-numeric-p op-negated-p))

 (defstruct (option-parser
             (:conc-name op-)
             (:constructor make-option-parser
 (defstruct (option-parser
             (:conc-name op-)
             (:constructor make-option-parser


@@ -172,17 +162,19 @@
                still allowed, and may be cuddled as usual.  The default is
                nil."
   (args nil :type list)
                still allowed, and may be cuddled as usual.  The default is
                nil."
   (args nil :type list)

-  (options nil :type list)
-  (non-option :skip :type (or function (member :skip :stop :return)))
+  (options nil :type list :read-only t)
+  (non-option :skip :type (or function (member :skip :stop :return))
+             :read-only t)

   (next nil :type list)
   (short-opt nil :type (or null string))
   (short-opt-index 0 :type fixnum)
   (short-opt-neg-p nil :type t)
   (next nil :type list)
   (short-opt nil :type (or null string))
   (short-opt-index 0 :type fixnum)
   (short-opt-neg-p nil :type t)

-  (long-only-p nil :type t)
-  (numeric-p nil :type t)
-  (negated-numeric-p nil :type t)
-  (negated-p nil :type t))
+  (long-only-p nil :type t :read-only t)
+  (numeric-p nil :type t :read-only t)
+  (negated-numeric-p nil :type t :read-only t)
+  (negated-p nil :type t) :read-only t)

 
 

+(export 'option-parse-error)

 (define-condition option-parse-error (error simple-condition)
   ()
   (:documentation
 (define-condition option-parse-error (error simple-condition)
   ()
   (:documentation


@@ -195,16 +187,19 @@
                         :format-control msg
                         :format-arguments args)))
 
                         :format-control msg
                         :format-arguments args)))
 

+(export 'option-parse-remainder)

 (defun option-parse-remainder (op)
   "Returns the unparsed remainder of the command line."
   (cdr (op-args op)))
 
 (defun option-parse-remainder (op)
   "Returns the unparsed remainder of the command line."
   (cdr (op-args op)))
 

+(export 'option-parse-return)

 (defun option-parse-return (tag &optional argument)
   "Should be called from an option handler: forces a return from the
    immediately enclosing `option-parse-next' with the given TAG and
    ARGUMENT."
   (throw 'option-parse-return (values tag argument)))
 
 (defun option-parse-return (tag &optional argument)
   "Should be called from an option handler: forces a return from the
    immediately enclosing `option-parse-next' with the given TAG and
    ARGUMENT."
   (throw 'option-parse-return (values tag argument)))
 

+(export 'option-parse-next)

 (defun option-parse-next (op)
   "The main option-parsing function.  OP is an option-parser object,
    initialized appropriately.  Returns two values, OPT and ARG: OPT is the
 (defun option-parse-next (op)
   "The main option-parsing function.  OP is an option-parser object,
    initialized appropriately.  Returns two values, OPT and ARG: OPT is the


@@ -398,6 +393,7 @@
                                 (op-short-opt-index op) 1
                                 (op-short-opt-neg-p op) negp))))))))))))))
 
                                 (op-short-opt-index op) 1
                                 (op-short-opt-neg-p op) negp))))))))))))))
 

+(export 'option-parse-try)

 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and continue struggling
    along.  Also establishes a restart `stop-parsing'.  Returns t if parsing
 (defmacro option-parse-try (&body body)
   "Report errors encountered while parsing options, and continue struggling
    along.  Also establishes a restart `stop-parsing'.  Returns t if parsing


@@ -419,6 +415,7 @@
           (setf ,retcode nil)))
        ,retcode)))
 
           (setf ,retcode nil)))
        ,retcode)))
 

+(export 'with-unix-error-reporting)

 (defmacro with-unix-error-reporting ((&key) &body body)
   "Evaluate BODY with errors reported in the standard Unix fashion."
   (with-gensyms (cond)
 (defmacro with-unix-error-reporting ((&key) &body body)
   "Evaluate BODY with errors reported in the standard Unix fashion."
   (with-gensyms (cond)


@@ -434,6 +431,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Standard option handlers.
 
 ;;;--------------------------------------------------------------------------
 ;;; Standard option handlers.
 

+(export 'defopthandler)

 (defmacro defopthandler (name (var &optional (arg (gensym)))
                         (&rest args)
                         &body body)
 (defmacro defopthandler (name (var &optional (arg (gensym)))
                         (&rest args)
                         &body body)


@@ -501,6 +499,7 @@
          (t
           (get-radix start radix +1)))))
 
          (t
           (get-radix start radix +1)))))
 

+(export 'invoke-option-handler)

 (defun invoke-option-handler (handler loc arg args)
   "Call the HANDLER function, giving it LOC to update, the option-argument
    ARG, and the remaining ARGS."
 (defun invoke-option-handler (handler loc arg args)
   "Call the HANDLER function, giving it LOC to update, the option-argument
    ARG, and the remaining ARGS."


@@ -513,14 +512,17 @@
 ;;;--------------------------------------------------------------------------
 ;;; Built-in option handlers.
 
 ;;;--------------------------------------------------------------------------
 ;;; Built-in option handlers.
 

+(export 'set)

 (defopthandler set (var) (&optional (value t))
   "Sets VAR to VALUE; defaults to t."
   (setf var value))
 
 (defopthandler set (var) (&optional (value t))
   "Sets VAR to VALUE; defaults to t."
   (setf var value))
 

+(export 'clear)

 (defopthandler clear (var) (&optional (value nil))
   "Sets VAR to VALUE; defaults to nil."
   (setf var value))
 
 (defopthandler clear (var) (&optional (value nil))
   "Sets VAR to VALUE; defaults to nil."
   (setf var value))
 

+(export 'inc)

 (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
    nil for no maximum).  No errors are signalled."
 (defopthandler inc (var) (&optional max (step 1))
   "Increments VAR by STEP (defaults to 1), but not greater than MAX (default
    nil for no maximum).  No errors are signalled."


@@ -528,6 +530,7 @@
   (when (>= var max)
     (setf var max)))
 
   (when (>= var max)
     (setf var max)))
 

+(export 'dec)

 (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
    for no maximum).  No errors are signalled."
 (defopthandler dec (var) (&optional min (step 1))
   "Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
    for no maximum).  No errors are signalled."


@@ -535,6 +538,7 @@
   (when (<= var min)
     (setf var min)))
 
   (when (<= var min)
     (setf var min)))
 

+(export 'read)

 (defopthandler read (var arg) ()
   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is
    forbidden while reading ARG.  If there is an error during reading, an
 (defopthandler read (var arg) ()
   "Stores in VAR the Lisp object found by reading the ARG.  Evaluation is
    forbidden while reading ARG.  If there is an error during reading, an


@@ -548,6 +552,7 @@
     (error (cond)
       (option-parse-error (format nil "~A" cond)))))
 
     (error (cond)
       (option-parse-error (format nil "~A" cond)))))
 

+(export 'int)

 (defopthandler int (var arg) (&key radix min max)
   "Stores in VAR the integer read from the ARG.  Integers are parsed
    according to C rules, which is normal in Unix; the RADIX may be nil to
 (defopthandler int (var arg) (&key radix min max)
   "Stores in VAR the integer read from the ARG.  Integers are parsed
    according to C rules, which is normal in Unix; the RADIX may be nil to


@@ -567,10 +572,12 @@
        arg min max))
     (setf var v)))
 
        arg min max))
     (setf var v)))
 

+(export 'string)

 (defopthandler string (var arg) ()
   "Stores ARG in VAR, just as it is."
   (setf var arg))
 
 (defopthandler string (var arg) ()
   "Stores ARG in VAR, just as it is."
   (setf var arg))
 

+(export 'keyword)

 (defopthandler keyword (var arg) (&optional (valid t))
   "Converts ARG into a keyword.  If VALID is t, then any ARG string is
    acceptable: the argument is uppercased and interned in the keyword
 (defopthandler keyword (var arg) (&optional (valid t))
   "Converts ARG into a keyword.  If VALID is t, then any ARG string is
    acceptable: the argument is uppercased and interned in the keyword


@@ -608,6 +615,7 @@
                                             "~{~%~8T~(~A~)~}")
                              arg matches)))))))
 
                                             "~{~%~8T~(~A~)~}")
                              arg matches)))))))
 

+(export 'list)

 (defopthandler list (var arg) (&optional handler &rest handler-args)
   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,
    if specified.  If not, it's as if you asked for `string'."
 (defopthandler list (var arg) (&optional handler &rest handler-args)
   "Collect ARGs in a list at VAR.  ARGs are translated by the HANDLER first,
    if specified.  If not, it's as if you asked for `string'."


@@ -618,6 +626,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Option descriptions.
 
 ;;;--------------------------------------------------------------------------
 ;;; Option descriptions.
 

+(export 'defoptmacro)

 (defmacro defoptmacro (name args &body body)
   "Defines an option macro NAME.  Option macros should produce a list of
    expressions producing one option structure each."
 (defmacro defoptmacro (name args &body body)
   "Defines an option macro NAME.  Option macros should produce a list of
    expressions producing one option structure each."


@@ -625,6 +634,7 @@
      (setf (get ',name 'optmacro) (lambda ,args ,@body))
      ',name))
 
      (setf (get ',name 'optmacro) (lambda ,args ,@body))
      ',name))
 

+(export 'parse-option-form)

 (compile-time-defun parse-option-form (form)
   "Does the heavy lifting for parsing an option form.  See the docstring for
    the `option' macro for details of the syntax."
 (compile-time-defun parse-option-form (form)
   "Does the heavy lifting for parsing an option form.  See the docstring for
    the `option' macro for details of the syntax."


@@ -697,6 +707,7 @@
                           ,@(and negated-tag `(:negated-tag ,negated-tag))
                           ,@(and doc `(:documentation ,doc))))))))
 
                           ,@(and negated-tag `(:negated-tag ,negated-tag))
                           ,@(and doc `(:documentation ,doc))))))))
 

+(export 'options)

 (defmacro options (&rest optlist)
   "More convenient way of initializing options.  The OPTLIST is a list of
    OPTFORMS.  Each OPTFORM is one of the following:
 (defmacro options (&rest optlist)
   "More convenient way of initializing options.  The OPTLIST is a list of
    OPTFORMS.  Each OPTFORM is one of the following:


@@ -798,6 +809,7 @@
                    (#\] (when (plusp nest) (decf nest))))))
           (incf i))))))
 
                    (#\] (when (plusp nest) (decf nest))))))
           (incf i))))))
 

+(export 'simple-usage)

 (defun simple-usage (opts &optional mandatory-args)
   "Build a simple usage list from a list of options, and (optionally)
    mandatory argument names."
 (defun simple-usage (opts &optional mandatory-args)
   "Build a simple usage list from a list of options, and (optionally)
    mandatory argument names."


@@ -840,6 +852,7 @@
                               :key #'opt-long-name)))
            (listify mandatory-args)))))
 
                               :key #'opt-long-name)))
            (listify mandatory-args)))))
 

+(export 'show-usage)

 (defun show-usage (prog usage &optional (stream *standard-output*))
   "Basic usage-showing function.  PROG is the program name, probably from
    *command-line*.  USAGE is a list of possible usages of the program, each
 (defun show-usage (prog usage &optional (stream *standard-output*))
   "Basic usage-showing function.  PROG is the program name, probably from
    *command-line*.  USAGE is a list of possible usages of the program, each


@@ -882,6 +895,7 @@
                 (print-text doc stream))
               (terpri stream)))))))
 
                 (print-text doc stream))
               (terpri stream)))))))
 

+(export 'show-help)

 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
   "Basic help-showing function.  PROG is the program name, probably from
    *command-line*.  VER is the program's version number.  USAGE is a list of
 (defun show-help (prog ver usage opts &optional (stream *standard-output*))
   "Basic help-showing function.  PROG is the program name, probably from
    *command-line*.  VER is the program's version number.  USAGE is a list of


@@ -893,6 +907,7 @@
   (terpri stream)
   (show-options-help opts stream))
 
   (terpri stream)
   (show-options-help opts stream))
 

+(export 'sanity-check-options-list)

 (defun sanity-check-option-list (opts)
   "Check the option list OPTS for basic sanity.  Reused short and long option
    names are diagnosed.  Maybe other problems will be reported later.
 (defun sanity-check-option-list (opts)
   "Check the option list OPTS for basic sanity.  Reused short and long option
    names are diagnosed.  Maybe other problems will be reported later.


@@ -918,13 +933,16 @@
 ;;;--------------------------------------------------------------------------
 ;;; Full program descriptions.
 
 ;;;--------------------------------------------------------------------------
 ;;; Full program descriptions.
 

+(export '(*help* *version* *usage))

 (defvar *help* nil)
 (defvar *version* "<unreleased>")
 (defvar *usage* nil)
 
 (defvar *help* nil)
 (defvar *version* "<unreleased>")
 (defvar *usage* nil)
 

+(export 'do-usage)

 (defun do-usage (&optional (stream *standard-output*))
   (show-usage *program-name* *usage* stream))
 
 (defun do-usage (&optional (stream *standard-output*))
   (show-usage *program-name* *usage* stream))
 

+(export 'die-usage)

 (defun die-usage ()
   (do-usage *error-output*)
   (exit 1))
 (defun die-usage ()
   (do-usage *error-output*)
   (exit 1))


@@ -947,6 +965,7 @@
   (do-usage)
   (exit 0))
 
   (do-usage)
   (exit 0))
 

+(export 'help-options)

 (defoptmacro help-options (&key (short-help #\h)
                                (short-version #\v)
                                (short-usage #\u))
 (defoptmacro help-options (&key (short-help #\h)
                                (short-version #\v)
                                (short-usage #\u))


@@ -963,6 +982,7 @@
        (,@(shortform short-usage) "usage" #'opt-usage
        ("Show a very brief usage summary for ~A." *program-name*))))))
 
        (,@(shortform short-usage) "usage" #'opt-usage
        ("Show a very brief usage summary for ~A." *program-name*))))))
 

+(export 'define-program)

 (defun define-program (&key
                       (program-name nil progp)
                       (help nil helpp)
 (defun define-program (&key
                       (program-name nil progp)
                       (help nil helpp)


@@ -980,6 +1000,7 @@
        (usagep (setf *usage* (simple-usage *options* usage)))
        (fullp (setf *usage* full-usage))))
 
        (usagep (setf *usage* (simple-usage *options* usage)))
        (fullp (setf *usage* full-usage))))
 

+(export 'do-options)

 (defmacro do-options ((&key (parser '(make-option-parser)))
                      &body clauses)
   "Handy all-in-one options parser macro.  PARSER defaults to a new options
 (defmacro do-options ((&key (parser '(make-option-parser)))
                      &body clauses)
   "Handy all-in-one options parser macro.  PARSER defaults to a new options

diff --git a/queue.lisp b/queue.lisp
index 49c69c5..44ec534 100644 (file)
--- a/queue.lisp
+++ b/queue.lisp
@@ -22,10 +22,10 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:queue
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:queue

-  (:use #:common-lisp)
-  (:export #:make-queue #:queue-emptyp #:enqueue #:pushqueue #:dequeue))
+  (:use #:common-lisp))

 (in-package #:queue)
 
 (in-package #:queue)
 

+(export 'make-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
 (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


@@ -35,16 +35,19 @@
   (let ((q (cons nil nil)))
     (setf (car q) q)))
 
   (let ((q (cons nil nil)))
     (setf (car q) q)))
 

+(export 'queue-emptyp)

 (defun queue-emptyp (q)
   "Answer whether the queue Q is empty."
   (null (cdr q)))
 
 (defun queue-emptyp (q)
   "Answer whether the queue Q is empty."
   (null (cdr q)))
 

+(export 'enqueue)

 (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 enqueue (x q)
   "Enqueue the object X into the queue Q."
   (let ((c (cons x nil)))
     (setf (cdr (car q)) c
          (car q) c)))
 

+(export 'pushqueue)

 (defun pushqueue (x q)
   "Push the object X onto the front of the queue Q."
   (let* ((first (cdr q))
 (defun pushqueue (x q)
   "Push the object X onto the front of the queue Q."
   (let* ((first (cdr q))


@@ -52,6 +55,7 @@
     (setf (cdr q) new)
     (unless first (setf (car q) new))))
 
     (setf (cdr q) new)
     (unless first (setf (car q) new))))
 

+(export 'dequeue)

 (defun dequeue (q)
   "Remove and return the object at the head of the queue Q."
   (if (queue-emptyp q)
 (defun dequeue (q)
   "Remove and return the object at the head of the queue Q."
   (if (queue-emptyp q)

diff --git a/safely.lisp b/safely.lisp
index 43ea4fe..9b39518 100644 (file)
--- a/safely.lisp
+++ b/safely.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Safely modify collections of files
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; Safely modify collections of files
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -24,10 +22,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:safely
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:safely

-  (:use #:common-lisp #:mdw.base)
-  (:export #:safely #:safely-close #:safely-delete-file
-          #:safely-open-output-stream #:safely-bail #:safely-commit
-          #:safely-writing))
+  (:use #:common-lisp #:mdw.base))

 (in-package #:safely)
 
 #+(or cmu sbcl)
 (in-package #:safely)
 
 #+(or cmu sbcl)


@@ -41,15 +36,18 @@
     (declare (ignore as-file))
     (unix-namestring pathname nil)))
 
     (declare (ignore as-file))
     (unix-namestring pathname nil)))
 

-(defstruct (safely (:predicate safelyp))
+(export '(safely safelyp make-safely))
+(defstruct (safely (:predicate safelyp) (:constructor make-safely ()))

   "Stores information about how to commit or undo safe writes."
   (streams nil)
   (trail nil))
 
   "Stores information about how to commit or undo safe writes."
   (streams nil)
   (trail nil))
 

+(export 'safely-close)

 (defun safely-close (safe stream)
   "Make sure that STREAM is closed when SAFE is finished."
   (push stream (safely-streams safe)))
 
 (defun safely-close (safe stream)
   "Make sure that STREAM is closed when SAFE is finished."
   (push stream (safely-streams safe)))
 

+(export 'safely-delete-file)

 (defun safely-delete-file (safe file)
   "Delete FILE when SAFE is committed."
   (push `(:delete ,file) (safely-trail safe)))
 (defun safely-delete-file (safe file)
   "Delete FILE when SAFE is committed."
   (push `(:delete ,file) (safely-trail safe)))


@@ -94,6 +92,7 @@
        (when ret
          (return (values new ret)))))))
 
        (when ret
          (return (values new ret)))))))
 

+(export 'safely-open-output-stream)

 (defun safely-open-output-stream (safe file &rest open-args)
   "Create an output stream which will be named FILE when SAFE is committed.
    Other OPEN-ARGS are passed to open."
 (defun safely-open-output-stream (safe file &rest open-args)
   "Create an output stream which will be named FILE when SAFE is committed.
    Other OPEN-ARGS are passed to open."


@@ -160,6 +159,7 @@
   (setf (safely-streams safe) nil)
   (setf (safely-trail safe) nil))
 
   (setf (safely-streams safe) nil)
   (setf (safely-trail safe) nil))
 

+(export 'safely-bail)

 (defun safely-bail (safe)
   "Abort the operations in SAFE, unwinding all the things that have been
    done.  Streams are closed, new files are removed."
 (defun safely-bail (safe)
   "Abort the operations in SAFE, unwinding all the things that have been
    done.  Streams are closed, new files are removed."


@@ -219,6 +219,7 @@
                     (return copy))))))
        (close output)))))
 
                     (return copy))))))
        (close output)))))
 

+(export 'safely-commit)

 (defun safely-commit (safe)
   "Commit SAFE.  The files deleted by safely-delete-file are deleted; the
    files created by safely-open-output-stream are renamed over the old
 (defun safely-commit (safe)
   "Commit SAFE.  The files deleted by safely-delete-file are deleted; the
    files created by safely-open-output-stream are renamed over the old


@@ -257,6 +258,7 @@
       (safely-unwind cleanup)
       (safely-reset safe))))
 
       (safely-unwind cleanup)
       (safely-reset safe))))
 

+;; The symbol `safely' is already exported.

 (defmacro safely ((safe &key) &body body)
   "Do stuff within the BODY safely.  If BODY completes without errors, the
    SAFE is committed; otherwise it's bailed."
 (defmacro safely ((safe &key) &body body)
   "Do stuff within the BODY safely.  If BODY completes without errors, the
    SAFE is committed; otherwise it's bailed."


@@ -269,6 +271,7 @@
        (when ,safe
         (safely-bail ,safe)))))
 
        (when ,safe
         (safely-bail ,safe)))))
 

+(export 'safely-writing)

 (defmacro safely-writing ((stream file &rest open-args) &body body)
   "Simple macro for writing a single file safely.  STREAM is opened onto a
    temporary file, and if BODY completes, it is renamed to FILE."
 (defmacro safely-writing ((stream file &rest open-args) &body body)
   "Simple macro for writing a single file safely.  STREAM is opened onto a
    temporary file, and if BODY completes, it is renamed to FILE."

diff --git a/str.lisp b/str.lisp
index a943bae..aff11a8 100644 (file)
--- a/str.lisp
+++ b/str.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; String utilities of various kinds
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; String utilities of various kinds
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -24,11 +22,10 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.str
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.str

-  (:use #:common-lisp #:mdw.base)
-  (:export #:join-strings #:str-next-word #:str-split-words
-          #:str-beginsp #:str-endsp))
+  (:use #:common-lisp #:mdw.base))

 (in-package #:mdw.str)
 
 (in-package #:mdw.str)
 

+(export 'join-strings)

 (defun join-strings (del strs)
   "Join together the strings STRS with DEL between them.  All the arguments
    are first converted to strings, as if by `stringify'.  Otherwise, this is
 (defun join-strings (del strs)
   "Join together the strings STRS with DEL between them.  All the arguments
    are first converted to strings, as if by `stringify'.  Otherwise, this is


@@ -42,6 +39,7 @@
          (return))
        (princ del s)))))
 
          (return))
        (princ del s)))))
 

+(export 'str-next-word)

 (defun str-next-word (string &key quotedp start end)
   "Extract a whitespace-delimited word from STRING, returning it and the
    index to continue parsing from.  If no word is found, return nil twice.
 (defun str-next-word (string &key quotedp start end)
   "Extract a whitespace-delimited word from STRING, returning it and the
    index to continue parsing from.  If no word is found, return nil twice.


@@ -108,6 +106,7 @@
                        :initial-contents w)
            i)))
 
                        :initial-contents w)
            i)))
 

+(export 'str-split-words)

 (defun str-split-words (string &key quotedp start end max)
   "Break STRING into words, like str-next-word does, returning the list of
    the individual words.  If QUOTEDP, then allow quoting and backslashifying;
 (defun str-split-words (string &key quotedp start end max)
   "Break STRING into words, like str-next-word does, returning the list of
    the individual words.  If QUOTEDP, then allow quoting and backslashifying;


@@ -135,6 +134,7 @@
         (incf n)))
     (nreverse l)))
 
         (incf n)))
     (nreverse l)))
 

+(export 'str-beginsp)

 (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
 (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


@@ -148,6 +148,7 @@
                  :start1 start1 :end1 (+ start1 prelen)
                  :start2 start2 :end2 end2))))
 
                  :start1 start1 :end1 (+ start1 prelen)
                  :start2 start2 :end2 end2))))
 

+(export 'str-endsp)

 (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
 (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

diff --git a/sys-base.lisp b/sys-base.lisp
index bef7ce9..4f52ec8 100644 (file)
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Basic system-specific stuff
 ;;;
 ;;; (c) 2005 Mark Wooding
 ;;; Basic system-specific stuff
 ;;;
 ;;; (c) 2005 Mark Wooding


@@ -64,7 +62,7 @@
   (defun exit (&optional (code 0))
     "Polite way to end a program."
     #+(or cmu ecl) (ext:quit code)
   (defun exit (&optional (code 0))
     "Polite way to end a program."
     #+(or cmu ecl) (ext:quit code)

-    #+sbcl (sb-ext:quit :unix-status code)
+    #+sbcl (sb-ext:exit :code code)

     #-(or cmu ecl sbcl)
     (progn
       (unless (zerop code)
     #-(or cmu ecl sbcl)
     (progn
       (unless (zerop code)


@@ -76,7 +74,7 @@
    after fork, for example, to avoid flushing buffers."
   (declare (type (unsigned-byte 32) code))
   #+cmu (unix::void-syscall ("_exit" c-call:int) code)
    after fork, for example, to avoid flushing buffers."
   (declare (type (unsigned-byte 32) code))
   #+cmu (unix::void-syscall ("_exit" c-call:int) code)

-  #+sbcl (sb-ext:quit :unix-status code :recklessly-p t)
+  #+sbcl (sb-ext:exit :code code :abort t)

   #+(or clisp ecl) (ext:quit code))
 
 ;;;----- That's all, folks --------------------------------------------------
   #+(or clisp ecl) (ext:quit code))
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/unix.lisp b/unix.lisp
index be823f0..254540d 100644 (file)
--- a/unix.lisp
+++ b/unix.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Unix system call stuff
 ;;;
 ;;; (c) 2005 Straylight/Edgeware
 ;;; Unix system call stuff
 ;;;
 ;;; (c) 2005 Straylight/Edgeware


@@ -24,15 +22,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.unix
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (defpackage #:mdw.unix

-  (:use #:common-lisp #:mdw.base #:collect)
-  (:export #:unix-error #:errno-value #:with-errno-handlers
-          #:syscall #:syscall*
-          #:stat #:sys-stat
-          #:sys-open #:sys-close #:sys-read #:sys-write
-          #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
-          #:sys-utimes #:sys-unlink #:sys-rename
-          #:sys-gettimeofday #:sys-gethostname
-          #:with-unix-open #:copy-file))
+  (:use #:common-lisp #:mdw.base #:collect))

 (in-package #:mdw.unix)
 
 (defmacro with-buffer ((var len) &body body)
 (in-package #:mdw.unix)
 
 (defmacro with-buffer ((var len) &body body)


@@ -47,6 +37,7 @@
             ,@body)
         (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
 
             ,@body)
         (when ,var (system:deallocate-system-memory ,var ,lenvar))))))
 

+(export '(unix-error unix-error-func unix-error-args unix-error-errno))

 (define-condition unix-error (error)
   ((func :initform 'unknown :initarg :func :reader unix-error-func)
    (args :initform nil :initarg :args :reader unix-error-args)
 (define-condition unix-error (error)
   ((func :initform 'unknown :initarg :func :reader unix-error-func)
    (args :initform nil :initarg :args :reader unix-error-args)


@@ -58,12 +49,14 @@
                     (unix-error-errno c))))
   (:documentation "Reports an error from a Unix system call."))
 
                     (unix-error-errno c))))
   (:documentation "Reports an error from a Unix system call."))
 

+(export 'errno-value)

 (compile-time-defun errno-value (err)
 (compile-time-defun errno-value (err)

-    "Returns the numeric value corresponding to an errno name."
-    (etypecase err
-      (integer err)
-      (symbol (symbol-value (intern (symbol-name err) :unix)))))
+  "Returns the numeric value corresponding to an errno name."
+  (etypecase err
+    (integer err)
+    (symbol (symbol-value (intern (symbol-name err) :unix)))))

 
 

+(export 'with-errno-handlers)

 (defmacro with-errno-handlers ((&key cond
                                     (errno (gensym))
                                     errstring)
 (defmacro with-errno-handlers ((&key cond
                                     (errno (gensym))
                                     errstring)


@@ -109,6 +102,7 @@
                         clauses
                         labels)))))))))
 
                         clauses
                         labels)))))))))
 

+(export 'syscall*)

 (defun syscall* (name func &rest args)
   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
    signal the unix-error condition, with NAME and ARGS."
 (defun syscall* (name func &rest args)
   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
    signal the unix-error condition, with NAME and ARGS."


@@ -120,22 +114,30 @@
                                  :errno (car stuff)))
                         (apply #'values rc stuff))
                       (apply func args)))
                                  :errno (car stuff)))
                         (apply #'values rc stuff))
                       (apply func args)))

+
+(export 'syscall)

 (defmacro syscall (func &rest args)
   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
    signal the unix-error condition, with FUNC and ARGS."
   `(syscall* ',func
    #',func ,@args))
 
 (defmacro syscall (func &rest args)
   "Call Unix system call FUNC, passing it ARGS.  If it returns an error,
    signal the unix-error condition, with FUNC and ARGS."
   `(syscall* ',func
    #',func ,@args))
 

+(export '(stat statp))

 (macrolet ((doit (doc slots)
 (macrolet ((doit (doc slots)

-            `(defstruct (stat (:predicate statp)
-                              (:conc-name st-)
-                              (:constructor %make-stat-boa ,slots))
-               ,doc
-               ,@slots)))
+            `(progn
+               (export ',(mapcar (lambda (slot) (symbolicate 'st- slot))
+                                 slots))
+               (defstruct (stat (:predicate statp)
+                                (:conc-name st-)
+                                (:constructor %make-stat-boa ,slots))
+                 ,doc
+                 ,@slots))))

   (doit
   (doit

-   "Structure representing all the useful information `stat' returns about a
-   file."
-   (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+    "Structure representing all the useful information `stat' returns about a
+     file."
+    (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+
+(export 'sys-stat)

 (defun sys-stat (file)
   "Return information about FILE in a structure rather than as inconvenient
    multiple values."
 (defun sys-stat (file)
   "Return information about FILE in a structure rather than as inconvenient
    multiple values."


@@ -149,10 +151,13 @@
     (unix:unix-stat file)))
 
 (defmacro defsyscall (name)
     (unix:unix-stat file)))
 
 (defmacro defsyscall (name)

-  (let ((sysname (intern (format nil "SYS-~:@(~A~)" name)))
-       (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
-    `(defun ,sysname (&rest args)
-       (apply #'syscall* ',sysname #',unixname args))))
+  (let ((sysname (symbolicate 'sys- name))
+       (unixname (let ((*package* (find-package :unix)))
+                   (symbolicate 'unix- name))))
+    `(progn
+       (export ',sysname)
+       (defun ,sysname (&rest args)
+        (apply #'syscall* ',sysname #',unixname args)))))

 
 (macrolet ((defsys (&rest names)
             `(progn ,@(mapcar (lambda (name)
 
 (macrolet ((defsys (&rest names)
             `(progn ,@(mapcar (lambda (name)


@@ -163,6 +168,7 @@
          unlink rename
          gethostname gettimeofday))
 
          unlink rename
          gethostname gettimeofday))
 

+(export 'with-unix-open)

 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
    `open' syscall with arguments FILE, HOW and MODE.  Close the file
 (defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
   "Evaluate BODY with FD bound to a file descriptor obtained from a Unix
    `open' syscall with arguments FILE, HOW and MODE.  Close the file


@@ -174,6 +180,7 @@
           ,@body)
        (when ,fd (sys-close ,fd)))))
 
           ,@body)
        (when ,fd (sys-close ,fd)))))
 

+(export 'copy-file)

 (defun copy-file (from to &optional (how 0))
   "Make a copy of the file FROM called TO.  The copy has the same permissions
    and timestamps (except for ctime) and attempts to have the same owner and
 (defun copy-file (from to &optional (how 0))
   "Make a copy of the file FROM called TO.  The copy has the same permissions
    and timestamps (except for ctime) and attempts to have the same owner and