base: with-parsed-body, different interface.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 2c463e9..23bb4ef 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
@@ -149,6 +150,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)