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 6b1f947f3f7fd669d453e89f96b1e8583b4aa335..a96c6ffa82e9e3fbf70ca0c650b12429c9ce307d 100644 (file)
--- a/src/codegen-proto.lisp
+++ b/src/codegen-proto.lisp
@@ -334,10 +334,13 @@ (defmacro with-temporary-var ((codegen var type) &body body)
 
    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
    available for re-use."
 
    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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation idioms.

diff --git a/src/parser/scanner-proto.lisp b/src/parser/scanner-proto.lisp
index bd7e160c72444dea97ed68dc2287cd3e83038eea..ea41ad649e7e7a51d4292ae20802a61ab5464893 100644 (file)
--- a/src/parser/scanner-proto.lisp
+++ b/src/parser/scanner-proto.lisp
@@ -99,9 +99,12 @@ (defmacro with-scanner-place ((place scanner) &body body)
    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)
    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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Character scanner protocol.

diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp
index 332bcef11c6dc7d21a87413d96dfa058fe0acd14..2326ebad056f3b8520d134d8cbbec75d9f21a104 100644 (file)
--- a/src/pset-proto.lisp
+++ b/src/pset-proto.lisp
@@ -321,14 +321,18 @@ (defmacro default-slot-from-property
    slot value."
 
   (once-only (instance slot slot-names pset property type)
    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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/utilities.lisp b/src/utilities.lisp
index d1755da2a5077f385a8d80712f3136fd98e63e7c..3c33be2191dac56f88466564b5b0212dcfac5f82 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -175,19 +175,20 @@ (defmacro once-only (binds &body body)
                 (,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 @@ (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
 
   (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 @@ (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
                 (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 @@ (defmacro define-on-demand-slot (class slot (instance) &body body)
 
    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 --------------------------------------------------