macros.lisp

   1 (in-package :alexandria)
   2
   3 (defmacro with-unique-names (names &body forms)
   4   "Binds each variable named by NAMES to a unique symbol."
   5   `(let ,(mapcar (lambda (name)
   6                    `(,name (gensym ,(symbol-name name))))
   7                  names)
   8      ,@forms))
   9
  10 (defmacro once-only (names &body forms)
  11   "Evaluates FORMS with NAMES rebound to temporary variables,
  12 ensuring that each is evaluated only once.
  13
  14 Example:
  15   (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
  16   (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
  17   (let ((gensyms (make-gensym-list (length names) "ONCE-ONLY")))
  18     ;; bind in user-macro
  19     `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string n))))
  20                    gensyms names)
  21        ;; bind in final expansion
  22        `(let (,,@(mapcar (lambda (g n) ``(,,g ,,n)) gensyms names))
  23           ;; bind in user-macro
  24           ,(let ,(mapcar #'list names gensyms)
  25              ,@forms)))))
  26
  27 (defun parse-body (body &key documentation whole)
  28   "Parses BODY into (values remaining-forms declarations doc-string).
  29 Documentation strings are recognized only if DOCUMENTATION is true.
  30 Syntax errors in body are signalled and WHOLE is used in the signal
  31 arguments when given."
  32   (let ((doc nil)
  33         (decls nil)
  34         (current nil))
  35     (tagbody
  36      :declarations
  37        (setf current (car body))
  38        (when (and documentation (stringp current) (cdr body))
  39          (if doc
  40              (error "Too many documentation strings in ~S." (or whole body))
  41              (setf doc (pop body)))
  42          (go :declarations))
  43        (when (starts-with 'declare current)
  44          (push (pop body) decls)
  45          (go :declarations)))
  46     (values body (nreverse decls) doc)))