parse-body: Allow docstring to be mixed in among the declarations.

Ooops.  I've just re-read CLtL, and found that the top of most forms
allows the docstring to be mixed in among the declarations in any old
order, rather than docstring-first, declarations-after.  And I've also
just read Hyperspec 3.4.11, which explains that a final string isn't a
docstring, so handle that correctly too.

So rewrite the code to handle this case.  It means that macros will
probably reorder the forms in their output, but that's all right.

While we're here, glue all the declarations into a single `declare'
form, which makes it easier to put the declarations into some other kind
of form such as `declaim'.  And provide a keyword argument
:allow-docstring-p (defaulting true) to disallow docstrings.

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 6b235f5..269b398 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -105,24 +105,24 @@
    structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
-(compile-time-defun parse-body (body)
+(compile-time-defun parse-body (body &key (allow-docstring-p t))
   "Given a BODY (a list of forms), parses it into three sections: a
    docstring, a list of declarations (forms beginning with the symbol
    `declare') and the body forms.  The result is returned as three lists
    (even the docstring), suitable for interpolation into a backquoted list
-   using `@,'."
-  (multiple-value-bind
-      (doc body)
-      (if (and (consp body)
-              (stringp (car body)))
-         (values (list (car body)) (cdr body))
-         (values nil body))
-    (loop for forms on body
-         for form = (car forms)
-         while (and (consp form)
-                    (eq (car form) 'declare))
-         collect form into decls
-         finally (return (values doc decls forms)))))
+   using `@,'.  If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at
+   all."
+  (let ((doc nil) (decls nil))
+    (do ((forms body (cdr forms))) (nil)
+      (let ((form (and forms (car forms))))
+       (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms))
+              (setf doc form))
+             ((and (consp form)
+                   (eq (car form) 'declare))
+              (setf decls (append decls (cdr form))))
+             (t (return (values (and doc (list doc))
+                                (and decls (list (cons 'declare decls)))
+                                forms))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.