Merge branch 'master' of /home/mdw/public-git/lisp

* 'master' of /home/mdw/public-git/lisp:
  base: with-parsed-body, different interface.
  collect: Provide functional interface for collectors.

diff --git a/collect.lisp b/collect.lisp
index 359780c..cab2808 100644 (file)
--- a/collect.lisp
+++ b/collect.lisp
@@ -25,15 +25,26 @@
 
 (defpackage #:collect
   (:use #:common-lisp #:mdw.base)
-  (:export #:collecting #:with-collection #:collect #:collect-tail))
+  (:export #:make-collector #:collected
+          #:collecting #:with-collection
+          #:collect #:collect-tail
+          #:collect-append #:collect-nconc))
 (in-package collect)
 
 (eval-when (:compile-toplevel :load-toplevel)
   (defvar *collecting-anon-list-name* (gensym)
-    "The default name for anonymous `collecting' lists.")
-  (defun make-collector ()
-    (let ((head (cons nil nil)))
-      (setf (car head) head))))
+    "The default name for anonymous `collecting' lists."))
+
+(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))))
+
+(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 collecting (vars &body body)
   "Collect items into lists.  The VARS are a list of collection variables --
@@ -45,7 +56,7 @@
        ((atom vars) (setf vars (list vars))))
   `(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
      ,@body
-     (values ,@(mapcar (lambda (v) `(the list (cdr ,v))) vars))))
+     (values ,@(mapcar (lambda (v) `(collected ,v)) vars))))
 
 (defmacro with-collection (vars collection &body body)
   "Collect items into lists VARS according to the form COLLECTION; then

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 88ef8ba..ffda8c0 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -31,7 +31,8 @@
   (:export #:unsigned-fixnum
           #:compile-time-defun
           #:show
-          #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
+          #:stringify #:mappend #:listify #:fix-pair #:pairify
+          #:parse-body #:with-parsed-body
           #:whitespace-char-p
           #:slot-uninitialized
           #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
@@ -151,6 +152,17 @@
                                 (and decls (list (cons 'declare decls)))
                                 forms))))))))
 
+(defmacro with-parsed-body
+    ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body)
+  "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR
+   to the body, DECLVAR to the declarations, and DOCVAR to (a list
+   containing) the docstring, and evaluate BODY."
+  `(multiple-value-bind
+       (,docvar ,declvar ,bodyvar)
+       (parse-body ,form :allow-docstring-p ,docp)
+     ,@(if docp nil `((declare (ignore ,docvar))))
+     ,@body))
+
 #-cmu
 (progn
   (declaim (inline fixnump))

diff --git a/mdw-mop.lisp b/mdw-mop.lisp
index 85e7885..d578f51 100644 (file)
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -106,10 +106,7 @@
                             (listify slots)
                             (mapcar #'slot-definition-name
                                     (class-slots class))))))
-      (multiple-value-bind
-         (docs decls body)
-         (parse-body body :allow-docstring-p nil)
-       (declare (ignore docs))
+      (with-parsed-body (body decls) body
        (with-gensyms (instvar)
          `(let ((,instvar ,instance))
             ,@(and class `((declare (type ,(class-name class) ,instvar))))

diff --git a/optparse.lisp b/optparse.lisp
index 08192d0..4207933 100644 (file)
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -446,7 +446,7 @@ Ambiguous long option `~A' -- could be any of:~{~%  --~A~}"
    on some parameters (the ARGS) and the value of an option-argument named
    ARG."
   (let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
-    (multiple-value-bind (docs decls body) (parse-body body)
+    (with-parsed-body (body decls docs) body
       `(progn
         (setf (get ',name 'opthandler) ',func)
         (defun ,func (,var ,arg ,@args)