From b8c698eeb25ff564145079e4310b0bd71f84155b Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] 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. --- src/codegen-proto.lisp | 11 ++++--- src/parser/scanner-proto.lisp | 9 ++++-- src/pset-proto.lisp | 22 +++++++------ src/utilities.lisp | 72 +++++++++++++++++++++++-------------------- 4 files changed, 65 insertions(+), 49 deletions(-) diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 6b1f947..a96c6ff 100644 --- 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 --- 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 --- 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 --- 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 -------------------------------------------------- -- 2.11.0