,@doc
(destructuring-bind ,bvl ,tail
,@decls
- ,@body))
+ (block ,name ,@body)))
',name))))
(export 'c-type-alias)
(print-unreadable-object (,inst-var ,streamvar :type t)
(format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
,@(mappend #'list keys args)))
- (progn ,@body))))
+ (block ,code ,@body))))
,@(and export `((export '(,class-name ,constructor-name
,@(mapcar (lambda (arg)
(symbolicate 'inst- arg))
When `clear-the-decks' is called, the BODY will be evaluated as a progn.
The relative order of `clear-the-decks' operations is unspecified."
- `(add-clear-the-decks-function ',name (lambda () ,@body)))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(add-clear-the-decks-function ',name (lambda ()
+ ,@docs ,@decls
+ (block ,name ,@body)))))
(export 'clear-the-decks)
(defun clear-the-decks ()
,@docs ,@decls
(declare (ignorable ,arg))
(with-locatives ,var
- ,@body))
+ (block ,name ,@body)))
',name))))
(defun parse-c-integer (string &key radix (start 0) end)
Option macros should produce a list of expressions producing one option
structure each."
- `(progn
- (setf (get ',name 'optmacro) (lambda ,args ,@body))
- ',name))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(progn
+ (setf (get ',name 'optmacro) (lambda ,args
+ ,@docs ,@decls
+ (block ,name ,@body)))
+ ',name)))
(export 'parse-option-form)
(eval-when (:compile-toplevel :load-toplevel :execute)
((,context ,ctxclass) (,head (eql ',name)) ,tail)
,@doc
(declare (ignorable ,context))
- (block ,name
- (destructuring-bind ,bvl ,tail
- ,@decls
- ,@body)))))))
+ (destructuring-bind ,bvl ,tail
+ ,@decls
+ (block ,name ,@body)))))))
(export '(with-parser-context parse))
(defmacro with-parser-context ((class &rest initargs) &body body)
If a parser with the given TAG is already attached to SYMBOL then the new
parser replaces the old one; otherwise it is added to the collection."
- `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body)))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(pluggable-parser-add ',symbol ',tag
+ (lambda ,bvl
+ ,@docs ,@decls
+ (block ,symbol ,@body)))))
;;;--------------------------------------------------------------------------
;;; Rewindable parser context protocol.
(,classvar (,instance ,class) (,slotvar (eql ',slot)))
,@docs ,@decls
(declare (ignore ,classvar))
- (setf (slot-value ,instance ',slot) (progn ,@body))))))
+ (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
;;;----- That's all, folks --------------------------------------------------