Fix default ARRAY-INDEX and ARRAY-LENGTH.
[alexandria.git] / macros.lisp
blob4dd679a1b8eb100efcceebeb7d65464a2d48913b
1 (in-package :alexandria)
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:
7 (symbol string-designator)
9 Bare symbols appearing in NAMES are equivalent to:
11 (symbol symbol)
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))
26 (defmacro with-unique-names (names &body forms)
27 "Alias for WITH-GENSYMS."
28 `(with-gensyms ,names ,@forms))
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.
34 Each of SPECS must either be a symbol naming the variable to be rebound, or of
35 the form:
37 (symbol initform)
39 Bare symbols in SPECS are equivalent to
41 (symbol symbol)
43 Example:
45 (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
46 (let ((y 0)) (cons1 (incf y))) => (1 . 1)
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)))))
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)))
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:
97 1. Required parameters.
99 2. Optional parameter specifications, normalized into form:
101 (name init suppliedp)
103 3. Name of the rest parameter, or NIL.
105 4. Keyword parameter specifications, normalized into form:
107 ((keyword-name name) init suppliedp)
109 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
111 6. &AUX parameter specifications, normalized into form
113 (name init).
115 7. Existence of &KEY in the lambda-list.
117 Signals a PROGRAM-ERROR is the lambda-list is malformed."
118 (let ((state :required)
119 (allow-other-keys nil)
120 (auxp nil)
121 (required nil)
122 (optional nil)
123 (rest nil)
124 (keys nil)
125 (keyp nil)
126 (aux nil))
127 (labels ((fail (elt)
128 (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
129 elt lambda-list))
130 (check-variable (elt what &optional (allow-specializers allow-specializers))
131 (unless (and (or (symbolp elt)
132 (and allow-specializers
133 (consp elt) (= 2 (length elt)) (symbolp (first elt))))
134 (not (constantp elt)))
135 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
136 what elt lambda-list)))
137 (check-spec (spec what)
138 (destructuring-bind (init suppliedp) spec
139 (declare (ignore init))
140 (check-variable suppliedp what nil))))
141 (dolist (elt lambda-list)
142 (case elt
143 (&optional
144 (if (eq state :required)
145 (setf state elt)
146 (fail elt)))
147 (&rest
148 (if (member state '(:required &optional))
149 (setf state elt)
150 (fail elt)))
151 (&key
152 (if (member state '(:required &optional :after-rest))
153 (setf state elt)
154 (fail elt))
155 (setf keyp t))
156 (&allow-other-keys
157 (if (eq state '&key)
158 (setf allow-other-keys t
159 state elt)
160 (fail elt)))
161 (&aux
162 (cond ((eq state '&rest)
163 (fail elt))
164 (auxp
165 (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
166 elt lambda-list))
168 (setf auxp t
169 state elt))
171 (otherwise
172 (when (member elt '#.(set-difference lambda-list-keywords
173 '(&optional &rest &key &allow-other-keys &aux)))
174 (simple-program-error
175 "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
176 elt lambda-list))
177 (case state
178 (:required
179 (check-variable elt "required parameter")
180 (push elt required))
181 (&optional
182 (cond ((consp elt)
183 (destructuring-bind (name &rest tail) elt
184 (check-variable name "optional parameter")
185 (cond ((cdr tail)
186 (check-spec tail "optional-supplied-p parameter"))
187 (normalize-optional
188 (setf elt (append elt '(nil)))))))
190 (check-variable elt "optional parameter")
191 (when normalize-optional
192 (setf elt (cons elt '(nil nil))))))
193 (push (ensure-list elt) optional))
194 (&rest
195 (check-variable elt "rest parameter")
196 (setf rest elt
197 state :after-rest))
198 (&key
199 (cond ((consp elt)
200 (destructuring-bind (var-or-kv &rest tail) elt
201 (cond ((consp var-or-kv)
202 (destructuring-bind (keyword var) var-or-kv
203 (unless (symbolp keyword)
204 (simple-program-error "Invalid keyword name ~S in ordinary ~
205 lambda-list:~% ~S"
206 keyword lambda-list))
207 (check-variable var "keyword parameter")))
209 (check-variable var-or-kv "keyword parameter")
210 (when normalize-keyword
211 (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
212 (if (cdr tail)
213 (check-spec tail "keyword-supplied-p parameter")
214 (when normalize-keyword
215 (setf tail (append tail '(nil)))))
216 (setf elt (cons var-or-kv tail))))
218 (check-variable elt "keyword parameter")
219 (setf elt (if normalize-keyword
220 (list (list (make-keyword elt) elt) nil nil)
221 elt))))
222 (push elt keys))
223 (&aux
224 (if (consp elt)
225 (destructuring-bind (var &optional init) elt
226 (declare (ignore init))
227 (check-variable var "&aux parameter"))
228 (progn
229 (check-variable elt "&aux parameter")
230 (setf elt (list* elt (when normalize-auxilary
231 '(nil))))))
232 (push elt aux))
234 (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
235 (values (nreverse required) (nreverse optional) rest (nreverse keys)
236 allow-other-keys (nreverse aux) keyp)))
238 ;;;; DESTRUCTURING-*CASE
240 (defun expand-destructuring-case (key clauses case)
241 (once-only (key)
242 `(if (typep ,key 'cons)
243 (,case (car ,key)
244 ,@(mapcar (lambda (clause)
245 (destructuring-bind ((keys . lambda-list) &body body) clause
246 `(,keys
247 (destructuring-bind ,lambda-list (cdr ,key)
248 ,@body))))
249 clauses))
250 (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
252 (defmacro destructuring-case (keyform &body clauses)
253 "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
254 KEYFORM must evaluate to a CONS.
256 Clauses are of the form:
258 ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
260 The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
261 is selected, and FORMs are then executed with CDR of KEY is destructured and
262 bound by the DESTRUCTURING-LAMBDA-LIST.
264 Example:
266 (defun dcase (x)
267 (destructuring-case x
268 ((:foo a b)
269 (format nil \"foo: ~S, ~S\" a b))
270 ((:bar &key a b)
271 (format nil \"bar, ~S, ~S\" a b))
272 (((:alt1 :alt2) a)
273 (format nil \"alt: ~S\" a))
274 ((t &rest rest)
275 (format nil \"unknown: ~S\" rest))))
277 (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
278 (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
279 (dcase (list :alt1 1)) ; => \"alt: 1\"
280 (dcase (list :alt2 2)) ; => \"alt: 2\"
281 (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
283 (defun decase (x)
284 (destructuring-case x
285 ((:foo a b)
286 (format nil \"foo: ~S, ~S\" a b))
287 ((:bar &key a b)
288 (format nil \"bar, ~S, ~S\" a b))
289 (((:alt1 :alt2) a)
290 (format nil \"alt: ~S\" a))))
292 (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
293 (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
294 (decase (list :alt1 1)) ; => \"alt: 1\"
295 (decase (list :alt2 2)) ; => \"alt: 2\"
296 (decase (list :quux 1 2 3)) ; =| error
298 (expand-destructuring-case keyform clauses 'case))
300 (defmacro destructuring-ccase (keyform &body clauses)
301 (expand-destructuring-case keyform clauses 'ccase))
303 (defmacro destructuring-ecase (keyform &body clauses)
304 (expand-destructuring-case keyform clauses 'ecase))
306 (dolist (name '(destructuring-ccase destructuring-ecase))
307 (setf (documentation name 'function) (documentation 'destructuring-case 'function)))