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)))
  81
  82 (defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
  83                                    allow-specializers
  84                                    (normalize-optional normalize)
  85                                    (normalize-keyword normalize)
  86                                    (normalize-auxilary normalize))
  87   "Parses an ordinary lambda-list, returning:
  88
  89 \(values requireds optionals rest keywords allow-other-keys? auxiliaries)
  90
  91  1. Required parameters.
  92  2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
  93     where SUPPLIEDP is NIL if not present.
  94  3. Name of the rest parameter, or NIL.
  95  4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
  96     where SUPPLIEDP is NIL if not present.
  97  5. Boolean indicating &ALLOW-OTHER-KEYS presence.
  98  6. &AUX parameter specifications, normalized into form (NAME INIT).
  99
 100 Signals a PROGRAM-ERROR is the lambda-list is malformed."
 101   (let ((state :required)
 102         (allow-other-keys nil)
 103         (auxp nil)
 104         (required nil)
 105         (optional nil)
 106         (rest nil)
 107         (keys nil)
 108         (aux nil))
 109     (labels ((fail (elt)
 110                (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
 111                                      elt lambda-list))
 112              (check-variable (elt what &optional (allow-specializers allow-specializers))
 113                (unless (and (or (symbolp elt)
 114                                 (and allow-specializers
 115                                      (consp elt) (= 2 (length elt)) (symbolp (first elt))))
 116                             (not (constantp elt)))
 117                  (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
 118                                        what elt lambda-list)))
 119              (check-spec (spec what)
 120                (destructuring-bind (init suppliedp) spec
 121                  (declare (ignore init))
 122                  (check-variable suppliedp what nil))))
 123       (dolist (elt lambda-list)
 124         (case elt
 125           (&optional
 126            (if (eq state :required)
 127                (setf state elt)
 128                (fail elt)))
 129           (&rest
 130            (if (member state '(:required &optional))
 131                (setf state elt)
 132                (fail elt)))
 133           (&key
 134            (if (member state '(:required &optional :after-rest))
 135                (setf state elt)
 136                (fail elt)))
 137           (&allow-other-keys
 138            (if (eq state '&key)
 139                (setf allow-other-keys t
 140                      state elt)
 141                (fail elt)))
 142           (&aux
 143            (cond ((eq state '&rest)
 144                   (fail elt))
 145                  (auxp
 146                   (simple-program-error "Multiple ~S in ordinary lambda-list:~%  ~S"
 147                                         elt lambda-list))
 148                  (t
 149                   (setf auxp t
 150                         state elt))
 151                  ))
 152           (otherwise
 153            (when (member elt '#.(set-difference lambda-list-keywords
 154                                                 '(&optional &rest &key &allow-other-keys &aux)))
 155              (simple-program-error
 156               "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
 157               elt lambda-list))
 158            (case state
 159              (:required
 160               (check-variable elt "required parameter")
 161               (push elt required))
 162              (&optional
 163               (cond ((consp elt)
 164                      (destructuring-bind (name &rest tail) elt
 165                        (check-variable name "optional parameter")
 166                        (cond ((cdr tail)
 167                               (check-spec tail "optional-supplied-p parameter"))
 168                              (normalize-optional
 169                               (setf elt (append elt '(nil)))))))
 170                     (t
 171                      (check-variable elt "optional parameter")
 172                      (when normalize-optional
 173                        (setf elt (cons elt '(nil nil))))))
 174               (push (ensure-list elt) optional))
 175              (&rest
 176               (check-variable elt "rest parameter")
 177               (setf rest elt
 178                     state :after-rest))
 179              (&key
 180               (cond ((consp elt)
 181                      (destructuring-bind (var-or-kv &rest tail) elt
 182                        (cond ((consp var-or-kv)
 183                               (destructuring-bind (keyword var) var-or-kv
 184                                 (unless (symbolp keyword)
 185                                   (simple-program-error "Invalid keyword name ~S in ordinary ~
 186                                                          lambda-list:~%  ~S"
 187                                                         keyword lambda-list))
 188                                 (check-variable var "keyword parameter")))
 189                              (t
 190                               (check-variable var-or-kv "keyword parameter")
 191                               (when normalize-keyword
 192                                 (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
 193                        (if (cdr tail)
 194                            (check-spec tail "keyword-supplied-p parameter")
 195                            (when normalize-keyword
 196                              (setf tail (append tail '(nil)))))
 197                        (setf elt (cons var-or-kv tail))))
 198                     (t
 199                      (check-variable elt "keyword parameter")
 200                      (setf elt (if normalize-keyword
 201                                    (list (list (make-keyword elt) elt) nil nil)
 202                                    elt))))
 203               (push elt keys))
 204              (&aux
 205               (if (consp elt)
 206                   (destructuring-bind (var &optional init) elt
 207                     (declare (ignore init))
 208                     (check-variable var "&aux parameter"))
 209                   (progn
 210                     (check-variable elt "&aux parameter")
 211                     (setf elt (list* elt (when normalize-auxilary
 212                                            '(nil))))))
 213               (push elt aux))
 214              (t
 215               (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
 216     (values (nreverse required) (nreverse optional) rest (nreverse keys)
 217             allow-other-keys (nreverse aux))))