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   "Evaluates FORMS with symbols specified in SPECS rebound to temporary
  32 variables, ensuring that each initform is evaluated only once.
  33
  34 Each of SPECS must either be a symbol naming the variable to be rebound, or of
  35 the form:
  36
  37   (symbol initform)
  38
  39 Bare symbols in SPECS are equivalent to
  40
  41   (symbol symbol)
  42
  43 Example:
  44
  45   (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
  46   (let ((y 0)) (cons1 (incf y))) => (1 . 1)
  47 "
  48   (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
  49         (names-and-forms (mapcar (lambda (spec)
  50                                    (etypecase spec
  51                                      (list
  52                                       (destructuring-bind (name form) spec
  53                                         (cons name form)))
  54                                      (symbol
  55                                       (cons spec spec))))
  56                                  specs)))
  57     ;; bind in user-macro
  58     `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
  59                    gensyms names-and-forms)
  60        ;; bind in final expansion
  61        `(let (,,@(mapcar (lambda (g n)
  62                            ``(,,g ,,(cdr n)))
  63                          gensyms names-and-forms))
  64           ;; bind in user-macro
  65           ,(let ,(mapcar (lambda (n g) (list (car n) g))
  66                          names-and-forms gensyms)
  67              ,@forms)))))
  68
  69 (defun parse-body (body &key documentation whole)
  70   "Parses BODY into (values remaining-forms declarations doc-string).
  71 Documentation strings are recognized only if DOCUMENTATION is true.
  72 Syntax errors in body are signalled and WHOLE is used in the signal
  73 arguments when given."
  74   (let ((doc nil)
  75         (decls nil)
  76         (current nil))
  77     (tagbody
  78      :declarations
  79        (setf current (car body))
  80        (when (and documentation (stringp current) (cdr body))
  81          (if doc
  82              (error "Too many documentation strings in ~S." (or whole body))
  83              (setf doc (pop body)))
  84          (go :declarations))
  85        (when (and (listp current) (eql (first current) 'declare))
  86          (push (pop body) decls)
  87          (go :declarations)))
  88     (values body (nreverse decls) doc)))
  89
  90 (defun parse-ordinary-lambda-list (lambda-list &key (normalize t)
  91                                    allow-specializers
  92                                    (normalize-optional normalize)
  93                                    (normalize-keyword normalize)
  94                                    (normalize-auxilary normalize))
  95   "Parses an ordinary lambda-list, returning as multiple values:
  96
  97 1. Required parameters.
  98
  99 2. Optional parameter specifications, normalized into form:
 100
 101    (name init suppliedp)
 102
 103 3. Name of the rest parameter, or NIL.
 104
 105 4. Keyword parameter specifications, normalized into form:
 106
 107    ((keyword-name name) init suppliedp)
 108
 109 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
 110
 111 6. &AUX parameter specifications, normalized into form
 112
 113    (name init).
 114
 115 Signals a PROGRAM-ERROR is the lambda-list is malformed."
 116   (let ((state :required)
 117         (allow-other-keys nil)
 118         (auxp nil)
 119         (required nil)
 120         (optional nil)
 121         (rest nil)
 122         (keys nil)
 123         (aux nil))
 124     (labels ((fail (elt)
 125                (simple-program-error "Misplaced ~S in ordinary lambda-list:~%  ~S"
 126                                      elt lambda-list))
 127              (check-variable (elt what &optional (allow-specializers allow-specializers))
 128                (unless (and (or (symbolp elt)
 129                                 (and allow-specializers
 130                                      (consp elt) (= 2 (length elt)) (symbolp (first elt))))
 131                             (not (constantp elt)))
 132                  (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~%  ~S"
 133                                        what elt lambda-list)))
 134              (check-spec (spec what)
 135                (destructuring-bind (init suppliedp) spec
 136                  (declare (ignore init))
 137                  (check-variable suppliedp what nil))))
 138       (dolist (elt lambda-list)
 139         (case elt
 140           (&optional
 141            (if (eq state :required)
 142                (setf state elt)
 143                (fail elt)))
 144           (&rest
 145            (if (member state '(:required &optional))
 146                (setf state elt)
 147                (fail elt)))
 148           (&key
 149            (if (member state '(:required &optional :after-rest))
 150                (setf state elt)
 151                (fail elt)))
 152           (&allow-other-keys
 153            (if (eq state '&key)
 154                (setf allow-other-keys t
 155                      state elt)
 156                (fail elt)))
 157           (&aux
 158            (cond ((eq state '&rest)
 159                   (fail elt))
 160                  (auxp
 161                   (simple-program-error "Multiple ~S in ordinary lambda-list:~%  ~S"
 162                                         elt lambda-list))
 163                  (t
 164                   (setf auxp t
 165                         state elt))
 166                  ))
 167           (otherwise
 168            (when (member elt '#.(set-difference lambda-list-keywords
 169                                                 '(&optional &rest &key &allow-other-keys &aux)))
 170              (simple-program-error
 171               "Bad lambda-list keyword ~S in ordinary lambda-list:~%  ~S"
 172               elt lambda-list))
 173            (case state
 174              (:required
 175               (check-variable elt "required parameter")
 176               (push elt required))
 177              (&optional
 178               (cond ((consp elt)
 179                      (destructuring-bind (name &rest tail) elt
 180                        (check-variable name "optional parameter")
 181                        (cond ((cdr tail)
 182                               (check-spec tail "optional-supplied-p parameter"))
 183                              (normalize-optional
 184                               (setf elt (append elt '(nil)))))))
 185                     (t
 186                      (check-variable elt "optional parameter")
 187                      (when normalize-optional
 188                        (setf elt (cons elt '(nil nil))))))
 189               (push (ensure-list elt) optional))
 190              (&rest
 191               (check-variable elt "rest parameter")
 192               (setf rest elt
 193                     state :after-rest))
 194              (&key
 195               (cond ((consp elt)
 196                      (destructuring-bind (var-or-kv &rest tail) elt
 197                        (cond ((consp var-or-kv)
 198                               (destructuring-bind (keyword var) var-or-kv
 199                                 (unless (symbolp keyword)
 200                                   (simple-program-error "Invalid keyword name ~S in ordinary ~
 201                                                          lambda-list:~%  ~S"
 202                                                         keyword lambda-list))
 203                                 (check-variable var "keyword parameter")))
 204                              (t
 205                               (check-variable var-or-kv "keyword parameter")
 206                               (when normalize-keyword
 207                                 (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
 208                        (if (cdr tail)
 209                            (check-spec tail "keyword-supplied-p parameter")
 210                            (when normalize-keyword
 211                              (setf tail (append tail '(nil)))))
 212                        (setf elt (cons var-or-kv tail))))
 213                     (t
 214                      (check-variable elt "keyword parameter")
 215                      (setf elt (if normalize-keyword
 216                                    (list (list (make-keyword elt) elt) nil nil)
 217                                    elt))))
 218               (push elt keys))
 219              (&aux
 220               (if (consp elt)
 221                   (destructuring-bind (var &optional init) elt
 222                     (declare (ignore init))
 223                     (check-variable var "&aux parameter"))
 224                   (progn
 225                     (check-variable elt "&aux parameter")
 226                     (setf elt (list* elt (when normalize-auxilary
 227                                            '(nil))))))
 228               (push elt aux))
 229              (t
 230               (simple-program-error "Invalid ordinary lambda-list:~%  ~S" lambda-list)))))))
 231     (values (nreverse required) (nreverse optional) rest (nreverse keys)
 232             allow-other-keys (nreverse aux))))