macros.lisp

   1 (in-package :alexandria)
   2
   3 (defmacro with-gensyms (names &body forms)
   4   "Binds each variable named by a symbol in NAMES to a unique symbol around
   5 FORMS. Each of NAMES must either be either a symbol, or of the form:
   6
   7  (symbol string-designator)
   8
   9 Bare symbols appearing in NAMES are equivalent to:
  10
  11  (symbol symbol)
  12
  13 The string-designator is used as the argument to GENSYM when constructing the
  14 unique symbol the named variable will be bound to."
  15   `(let ,(mapcar (lambda (name)
  16                    (multiple-value-bind (symbol string)
  17                        (etypecase name
  18                          (symbol
  19                           (values name (symbol-name name)))
  20                          ((cons symbol (cons string-designator null))
  21                           (values (first name) (string (second name)))))
  22                      `(,symbol (gensym ,string))))
  23                  names)
  24      ,@forms))
  25
  26 (defmacro with-unique-names (names &body forms)
  27   "Alias for WITH-GENSYMS."
  28   `(with-gensyms ,names ,@forms))
  29
  30 (defmacro once-only (specs &body forms)
  31   "Each SPEC must be either a NAME, or a (NAME INITFORM), with plain
  32 NAME using the named variable as initform.
  33
  34 Evaluates FORMS with names rebound to temporary variables, ensuring
  35 that each is evaluated only once.
  36
  37 Example:
  38   (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
  39   (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
  40   (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
  41         (names-and-forms (mapcar (lambda (spec)
  42                                    (etypecase spec
  43                                      (list
  44                                       (destructuring-bind (name form) spec
  45                                         (cons name form)))
  46                                      (symbol
  47                                       (cons spec spec))))
  48                                  specs)))
  49     ;; bind in user-macro
  50     `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
  51                    gensyms names-and-forms)
  52        ;; bind in final expansion
  53        `(let (,,@(mapcar (lambda (g n)
  54                            ``(,,g ,,(cdr n)))
  55                          gensyms names-and-forms))
  56           ;; bind in user-macro
  57           ,(let ,(mapcar (lambda (n g) (list (car n) g))
  58                          names-and-forms gensyms)
  59              ,@forms)))))
  60
  61 (defun parse-body (body &key documentation whole)
  62   "Parses BODY into (values remaining-forms declarations doc-string).
  63 Documentation strings are recognized only if DOCUMENTATION is true.
  64 Syntax errors in body are signalled and WHOLE is used in the signal
  65 arguments when given."
  66   (let ((doc nil)
  67         (decls nil)
  68         (current nil))
  69     (tagbody
  70      :declarations
  71        (setf current (car body))
  72        (when (and documentation (stringp current) (cdr body))
  73          (if doc
  74              (error "Too many documentation strings in ~S." (or whole body))
  75              (setf doc (pop body)))
  76          (go :declarations))
  77        (when (and (listp current) (eql (first current) 'declare))
  78          (push (pop body) decls)
  79          (go :declarations)))
  80     (values body (nreverse decls) doc)))