From: Mark Wooding <mdw@distorted.org.uk>
Date: Sat, 27 Jan 2007 16:33:40 +0000 (+0000)
Subject: Merge branch 'master' of /home/mdw/public-git/lisp
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/commitdiff_plain/67b41ed338b6050f40bf9de24804502e96f84104?hp=53e95db096ab58c3acbf176f4c671cb612d832ae

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
--- 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 @@ (defmacro collecting (vars &body body)
 	((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
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -31,7 +31,8 @@ (defpackage #:mdw.base
   (: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 @@ (compile-time-defun parse-body (body &key (allow-docstring-p t))
 				 (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
--- a/mdw-mop.lisp
+++ b/mdw-mop.lisp
@@ -106,10 +106,7 @@ (defmacro with-slot-variables (slots instance &body body)
 			     (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
--- a/optparse.lisp
+++ b/optparse.lisp
@@ -446,7 +446,7 @@ (defmacro defopthandler (name (var &optional (arg (gensym)))
    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)