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."
 
    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 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)
    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 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)
    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 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 --------------------------------------------------