From 8f801ae819d1f622601c9786a0fce27102b49378 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 24 Dec 2006 18:27:34 +0000
Subject: [PATCH] base: with-parsed-body, different interface.

---
 mdw-base.lisp | 14 +++++++++++++-
 mdw-mop.lisp  |  5 +----
 optparse.lisp |  2 +-
 3 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 2c463e9..23bb4ef 100644
--- 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
--- 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
--- 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)
-- 
2.11.0