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 (specs &body forms)
  21   "Each SPEC must be either a NAME, or a (NAME INITFORM), with plain
  22 NAME using the named variable as initform.
  23
  24 Evaluates FORMS with names rebound to temporary variables, ensuring
  25 that each is evaluated only once.
  26
  27 Example:
  28   (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
  29   (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
  30   (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
  31         (names-and-forms (mapcar (lambda (spec)
  32                                    (etypecase spec
  33                                      (list
  34                                       (destructuring-bind (name form) spec
  35                                         (cons name form)))
  36                                      (symbol
  37                                       (cons spec spec))))
  38                                  specs)))
  39     ;; bind in user-macro
  40     `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
  41                    gensyms names-and-forms)
  42        ;; bind in final expansion
  43        `(let (,,@(mapcar (lambda (g n)
  44                            ``(,,g ,,(cdr n)))
  45                          gensyms names-and-forms))
  46           ;; bind in user-macro
  47           ,(let ,(mapcar (lambda (n g) (list (car n) g))
  48                          names-and-forms gensyms)
  49              ,@forms)))))
  50
  51 (defun parse-body (body &key documentation whole)
  52   "Parses BODY into (values remaining-forms declarations doc-string).
  53 Documentation strings are recognized only if DOCUMENTATION is true.
  54 Syntax errors in body are signalled and WHOLE is used in the signal
  55 arguments when given."
  56   (let ((doc nil)
  57         (decls nil)
  58         (current nil))
  59     (tagbody
  60      :declarations
  61        (setf current (car body))
  62        (when (and documentation (stringp current) (cdr body))
  63          (if doc
  64              (error "Too many documentation strings in ~S." (or whole body))
  65              (setf doc (pop body)))
  66          (go :declarations))
  67        (when (and (listp current) (eql (first current) 'declare))
  68          (push (pop body) decls)
  69          (go :declarations)))
  70     (values body (nreverse decls) doc)))