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)
                 (,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
   "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))
   (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)))))
             (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))
             (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-"))
 
   (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))))
               (etypecase ,seq
                 (vector
                  (let ((,endvar (or ,end (length ,seq))))


@@ -751,7 +755,7 @@
                 (list
                  (if ,end
                      ,(loopguts t t end)
                 (list
                  (if ,end
                      ,(loopguts t t end)

-                     ,(loopguts indexvar t nil))))))))))
+                     ,(loopguts indexvar t nil)))))))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Structure accessor hacks.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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'."
 
    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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------