doc/: Document where declarations are permitted in macros.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index d1755da..3c33be2 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -175,19 +175,20 @@
                 (,bodyfunc))))))))
 
 (export 'parse-body)
-(defun parse-body (body)
+(defun parse-body (body &key (docp t) (declp t))
   "Parse the BODY into a docstring, declarations and the body forms.
 
    These are returned as three lists, so that they can be spliced into a
    macro expansion easily.  The declarations are consolidated into a single
-   `declare' form."
+   `declare' form.  If DOCP is nil then a docstring is not permitted; if
+   DECLP is nil, then declarations are not permitted."
   (let ((decls nil)
        (doc nil))
     (loop
       (cond ((null body) (return))
-           ((and (consp (car body)) (eq (caar body) 'declare))
+           ((and declp (consp (car body)) (eq (caar body) 'declare))
             (setf decls (append decls (cdr (pop body)))))
-           ((and (stringp (car body)) (not doc) (cdr body))
+           ((and docp (stringp (car body)) (not doc) (cdr body))
             (setf doc (pop body)))
            (t (return))))
     (values (and doc (list doc))
@@ -721,29 +722,32 @@
 
   (once-only (:environment env seq start end)
     (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
-
-      (flet ((loopguts (indexp listp endvar)
-              ;; Build a DO-loop to do what we want.
-              (let* ((do-vars nil)
-                     (end-condition (if endvar
-                                        `(>= ,ivar ,endvar)
-                                        `(endp ,seq)))
-                     (item (if listp
-                               `(car ,seq)
-                               `(aref ,seq ,ivar)))
-                     (body-call `(,bodyfunc ,item)))
-                (when listp
-                  (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
-                        do-vars))
-                (when indexp
-                  (push `(,ivar ,start (1+ ,ivar)) do-vars))
-                (when indexvar
-                  (setf body-call (append body-call (list ivar))))
-                `(do ,do-vars (,end-condition) ,body-call))))
-
-       `(block nil
-          (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
-                   (tagbody ,@body)))
+      (multiple-value-bind (docs decls body) (parse-body body :docp nil)
+       (declare (ignore docs))
+
+       (flet ((loopguts (indexp listp endvar)
+                ;; Build a DO-loop to do what we want.
+                (let* ((do-vars nil)
+                       (end-condition (if endvar
+                                          `(>= ,ivar ,endvar)
+                                          `(endp ,seq)))
+                       (item (if listp
+                                 `(car ,seq)
+                                 `(aref ,seq ,ivar)))
+                       (body-call `(,bodyfunc ,item)))
+                  (when listp
+                    (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+                          do-vars))
+                  (when indexp
+                    (push `(,ivar ,start (1+ ,ivar)) do-vars))
+                  (when indexvar
+                    (setf body-call (append body-call (list ivar))))
+                  `(do ,do-vars (,end-condition) ,body-call))))
+
+         `(block nil
+            (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+                     ,@decls
+                     (tagbody ,@body)))
               (etypecase ,seq
                 (vector
                  (let ((,endvar (or ,end (length ,seq))))
@@ -751,7 +755,7 @@
                 (list
                  (if ,end
                      ,(loopguts t t end)
-                     ,(loopguts indexvar t nil))))))))))
+                     ,(loopguts indexvar t nil)))))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Structure accessor hacks.
@@ -803,10 +807,12 @@
 
    Sets up the named SLOT of CLASS to establish its value as the implicit
    progn BODY, by defining an appropriate method on `slot-unbound'."
-  (with-gensyms (classvar slotvar)
-    `(defmethod slot-unbound
-        (,classvar (,instance ,class) (,slotvar (eql ',slot)))
-       (declare (ignore ,classvar))
-       (setf (slot-value ,instance ',slot) (progn ,@body)))))
+  (multiple-value-bind (docs decls body) (parse-body body)
+    (with-gensyms (classvar slotvar)
+      `(defmethod slot-unbound
+          (,classvar (,instance ,class) (,slotvar (eql ',slot)))
+        ,@docs ,@decls
+        (declare (ignore ,classvar))
+        (setf (slot-value ,instance ',slot) (progn ,@body))))))
 
 ;;;----- That's all, folks --------------------------------------------------