src/: Improve handling of declarations in macros.

Teach `parse-body' to be able to parse only declarations or only
documentation.  Use this in macros with convoluted internal binding
structure.

diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp
index 6b1f947..a96c6ff 100644 (file)
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -334,10 +334,13 @@
 
    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
    available for re-use."
-  `(let ((,var (temporary-var ,codegen ,type)))
-     (unwind-protect
-         (progn ,@body)
-       (setf (var-in-use-p ,var) nil))))
+  (multiple-value-bind (doc decls body) (parse-body body :docp nil)
+    (declare (ignore doc))
+    `(let ((,var (temporary-var ,codegen ,type)))
+       ,@decls
+       (unwind-protect
+           (progn ,@body)
+        (setf (var-in-use-p ,var) nil)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation idioms.

diff --git a/src/parser/scanner-proto.lisp b/src/parser/scanner-proto.lisp
index bd7e160..ea41ad6 100644 (file)
--- a/src/parser/scanner-proto.lisp
+++ b/src/parser/scanner-proto.lisp
@@ -99,9 +99,12 @@
    if you wanted to circumvent the cleanup then you should have used
    `with-parser-place', which does all of this in the meta-level."
   (once-only (scanner)
-    `(let ((,place (scanner-capture-place ,scanner)))
-       (unwind-protect (progn ,@body)
-        (scanner-release-place ,scanner ,place)))))
+    (multiple-value-bind (docs decls body) (parse-body body :docp nil)
+      (declare (ignore docs))
+      `(let ((,place (scanner-capture-place ,scanner)))
+        ,@decls
+        (unwind-protect (progn ,@body)
+          (scanner-release-place ,scanner ,place))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Character scanner protocol.

diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp
index 332bcef..2326eba 100644 (file)
--- a/src/pset-proto.lisp
+++ b/src/pset-proto.lisp
@@ -321,14 +321,18 @@
    slot value."
 
   (once-only (instance slot slot-names pset property type)
-    (with-gensyms (floc)
-      `(multiple-value-bind (,pvar ,floc)
-          (get-property ,pset ,property ,type)
-        (if ,floc
-            (setf (slot-value ,instance ,slot)
-                  (with-default-error-location (,floc)
-                    ,@(or convert-forms `(,pvar))))
-            (default-slot (,instance ,slot ,slot-names)
-              ,@default-forms))))))
+    (multiple-value-bind (docs decls body)
+       (parse-body default-forms :docp nil)
+      (declare (ignore docs))
+      (with-gensyms (floc)
+       `(multiple-value-bind (,pvar ,floc)
+            (get-property ,pset ,property ,type)
+          ,@decls
+          (if ,floc
+              (setf (slot-value ,instance ,slot)
+                    (with-default-error-location (,floc)
+                      ,@(or convert-forms `(,pvar))))
+              (default-slot (,instance ,slot ,slot-names)
+                ,@body)))))))
 
 ;;;----- That's all, folks --------------------------------------------------

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 --------------------------------------------------