X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bb80145308ea388d7c6ed5336c061340e78f66e8..cac85e0be5833902081c903f75e348b949294fb9:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index d1755da..3c33be2 100644
--- 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 --------------------------------------------------