macros.lisp

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