macros.lisp - clic - Clic is an command line interactive client for gopher writ… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
macros.lisp (13999B) | |
--- | |
1 (in-package :alexandria) | |
2 | |
3 (defmacro with-gensyms (names &body forms) | |
4 "Binds a set of variables to gensyms and evaluates the implicit progn … | |
5 | |
6 Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL | |
7 STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMB… | |
8 | |
9 Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named b… | |
10 should be bound to a symbol constructed using GENSYM with the string des… | |
11 by STRING-DESIGNATOR being its first argument." | |
12 `(let ,(mapcar (lambda (name) | |
13 (multiple-value-bind (symbol string) | |
14 (etypecase name | |
15 (symbol | |
16 (values name (symbol-name name))) | |
17 ((cons symbol (cons string-designator null)) | |
18 (values (first name) (string (second name))))) | |
19 `(,symbol (gensym ,string)))) | |
20 names) | |
21 ,@forms)) | |
22 | |
23 (defmacro with-unique-names (names &body forms) | |
24 "Alias for WITH-GENSYMS." | |
25 `(with-gensyms ,names ,@forms)) | |
26 | |
27 (defmacro once-only (specs &body forms) | |
28 "Constructs code whose primary goal is to help automate the handling of | |
29 multiple evaluation within macros. Multiple evaluation is handled by int… | |
30 intermediate variables, in order to reuse the result of an expression. | |
31 | |
32 The returned value is a list of the form | |
33 | |
34 (let ((<gensym-1> <expr-1>) | |
35 ... | |
36 (<gensym-n> <expr-n>)) | |
37 <res>) | |
38 | |
39 where GENSYM-1, ..., GENSYM-N are the intermediate variables introduced … | |
40 to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the resu… | |
41 evaluating the implicit progn FORMS within a special context determined … | |
42 SPECS. RES should make use of (reference) the intermediate variables. | |
43 | |
44 Each element within SPECS is either a symbol SYMBOL or a pair (SYMBOL IN… | |
45 Bare symbols are equivalent to the pair (SYMBOL SYMBOL). | |
46 | |
47 Each pair (SYMBOL INITFORM) specifies a single intermediate variable: | |
48 | |
49 - INITFORM is an expression evaluated to produce EXPR-i | |
50 | |
51 - SYMBOL is the name of the variable that will be bound around FORMS to … | |
52 corresponding gensym GENSYM-i, in order for FORMS to generate RES that | |
53 references the intermediate variable | |
54 | |
55 The evaluation of INITFORMs and binding of SYMBOLs resembles LET. INITFO… | |
56 all the pairs are evaluated before binding SYMBOLs and evaluating FORMS. | |
57 | |
58 Example: | |
59 | |
60 The following expression | |
61 | |
62 (let ((x '(incf y))) | |
63 (once-only (x) | |
64 `(cons ,x ,x))) | |
65 | |
66 ;;; => | |
67 ;;; (let ((#1=#:X123 (incf y))) | |
68 ;;; (cons #1# #1#)) | |
69 | |
70 could be used within a macro to avoid multiple evaluation like so | |
71 | |
72 (defmacro cons1 (x) | |
73 (once-only (x) | |
74 `(cons ,x ,x))) | |
75 | |
76 (let ((y 0)) | |
77 (cons1 (incf y))) | |
78 | |
79 ;;; => (1 . 1) | |
80 | |
81 Example: | |
82 | |
83 The following expression demonstrates the usage of the INITFORM field | |
84 | |
85 (let ((expr '(incf y))) | |
86 (once-only ((var `(1+ ,expr))) | |
87 `(list ',expr ,var ,var))) | |
88 | |
89 ;;; => | |
90 ;;; (let ((#1=#:VAR123 (1+ (incf y)))) | |
91 ;;; (list '(incf y) #1# #1)) | |
92 | |
93 which could be used like so | |
94 | |
95 (defmacro print-succ-twice (expr) | |
96 (once-only ((var `(1+ ,expr))) | |
97 `(format t \"Expr: ~s, Once: ~s, Twice: ~s~%\" ',expr ,var ,var))) | |
98 | |
99 (let ((y 10)) | |
100 (print-succ-twice (incf y))) | |
101 | |
102 ;;; >> | |
103 ;;; Expr: (INCF Y), Once: 12, Twice: 12" | |
104 (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) | |
105 (names-and-forms (mapcar (lambda (spec) | |
106 (etypecase spec | |
107 (list | |
108 (destructuring-bind (name form) sp… | |
109 (cons name form))) | |
110 (symbol | |
111 (cons spec spec)))) | |
112 specs))) | |
113 ;; bind in user-macro | |
114 `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) | |
115 gensyms names-and-forms) | |
116 ;; bind in final expansion | |
117 `(let (,,@(mapcar (lambda (g n) | |
118 ``(,,g ,,(cdr n))) | |
119 gensyms names-and-forms)) | |
120 ;; bind in user-macro | |
121 ,(let ,(mapcar (lambda (n g) (list (car n) g)) | |
122 names-and-forms gensyms) | |
123 ,@forms))))) | |
124 | |
125 (defun parse-body (body &key documentation whole) | |
126 "Parses BODY into (values remaining-forms declarations doc-string). | |
127 Documentation strings are recognized only if DOCUMENTATION is true. | |
128 Syntax errors in body are signalled and WHOLE is used in the signal | |
129 arguments when given." | |
130 (let ((doc nil) | |
131 (decls nil) | |
132 (current nil)) | |
133 (tagbody | |
134 :declarations | |
135 (setf current (car body)) | |
136 (when (and documentation (stringp current) (cdr body)) | |
137 (if doc | |
138 (error "Too many documentation strings in ~S." (or whole bo… | |
139 (setf doc (pop body))) | |
140 (go :declarations)) | |
141 (when (and (listp current) (eql (first current) 'declare)) | |
142 (push (pop body) decls) | |
143 (go :declarations))) | |
144 (values body (nreverse decls) doc))) | |
145 | |
146 (defun parse-ordinary-lambda-list (lambda-list &key (normalize t) | |
147 allow-specializers | |
148 (normalize-optional normalize) | |
149 (normalize-keyword normalize) | |
150 (normalize-auxilary normalize)) | |
151 "Parses an ordinary lambda-list, returning as multiple values: | |
152 | |
153 1. Required parameters. | |
154 | |
155 2. Optional parameter specifications, normalized into form: | |
156 | |
157 (name init suppliedp) | |
158 | |
159 3. Name of the rest parameter, or NIL. | |
160 | |
161 4. Keyword parameter specifications, normalized into form: | |
162 | |
163 ((keyword-name name) init suppliedp) | |
164 | |
165 5. Boolean indicating &ALLOW-OTHER-KEYS presence. | |
166 | |
167 6. &AUX parameter specifications, normalized into form | |
168 | |
169 (name init). | |
170 | |
171 7. Existence of &KEY in the lambda-list. | |
172 | |
173 Signals a PROGRAM-ERROR is the lambda-list is malformed." | |
174 (let ((state :required) | |
175 (allow-other-keys nil) | |
176 (auxp nil) | |
177 (required nil) | |
178 (optional nil) | |
179 (rest nil) | |
180 (keys nil) | |
181 (keyp nil) | |
182 (aux nil)) | |
183 (labels ((fail (elt) | |
184 (simple-program-error "Misplaced ~S in ordinary lambda-li… | |
185 elt lambda-list)) | |
186 (check-variable (elt what &optional (allow-specializers all… | |
187 (unless (and (or (symbolp elt) | |
188 (and allow-specializers | |
189 (consp elt) (= 2 (length elt)) (sym… | |
190 (not (constantp elt))) | |
191 (simple-program-error "Invalid ~A ~S in ordinary lambda… | |
192 what elt lambda-list))) | |
193 (check-spec (spec what) | |
194 (destructuring-bind (init suppliedp) spec | |
195 (declare (ignore init)) | |
196 (check-variable suppliedp what nil)))) | |
197 (dolist (elt lambda-list) | |
198 (case elt | |
199 (&optional | |
200 (if (eq state :required) | |
201 (setf state elt) | |
202 (fail elt))) | |
203 (&rest | |
204 (if (member state '(:required &optional)) | |
205 (setf state elt) | |
206 (fail elt))) | |
207 (&key | |
208 (if (member state '(:required &optional :after-rest)) | |
209 (setf state elt) | |
210 (fail elt)) | |
211 (setf keyp t)) | |
212 (&allow-other-keys | |
213 (if (eq state '&key) | |
214 (setf allow-other-keys t | |
215 state elt) | |
216 (fail elt))) | |
217 (&aux | |
218 (cond ((eq state '&rest) | |
219 (fail elt)) | |
220 (auxp | |
221 (simple-program-error "Multiple ~S in ordinary lambda-… | |
222 elt lambda-list)) | |
223 (t | |
224 (setf auxp t | |
225 state elt)) | |
226 )) | |
227 (otherwise | |
228 (when (member elt '#.(set-difference lambda-list-keywords | |
229 '(&optional &rest &key &… | |
230 (simple-program-error | |
231 "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S" | |
232 elt lambda-list)) | |
233 (case state | |
234 (:required | |
235 (check-variable elt "required parameter") | |
236 (push elt required)) | |
237 (&optional | |
238 (cond ((consp elt) | |
239 (destructuring-bind (name &rest tail) elt | |
240 (check-variable name "optional parameter") | |
241 (cond ((cdr tail) | |
242 (check-spec tail "optional-supplied-p para… | |
243 ((and normalize-optional tail) | |
244 (setf elt (append elt '(nil)))) | |
245 (normalize-optional | |
246 (setf elt (append elt '(nil nil))))))) | |
247 (t | |
248 (check-variable elt "optional parameter") | |
249 (when normalize-optional | |
250 (setf elt (cons elt '(nil nil)))))) | |
251 (push (ensure-list elt) optional)) | |
252 (&rest | |
253 (check-variable elt "rest parameter") | |
254 (setf rest elt | |
255 state :after-rest)) | |
256 (&key | |
257 (cond ((consp elt) | |
258 (destructuring-bind (var-or-kv &rest tail) elt | |
259 (cond ((consp var-or-kv) | |
260 (destructuring-bind (keyword var) var-or-kv | |
261 (unless (symbolp keyword) | |
262 (simple-program-error "Invalid keyword… | |
263 lambda-list:~% … | |
264 keyword lambda-l… | |
265 (check-variable var "keyword parameter")… | |
266 (t | |
267 (check-variable var-or-kv "keyword paramet… | |
268 (when normalize-keyword | |
269 (setf var-or-kv (list (make-keyword var-… | |
270 (cond ((cdr tail) | |
271 (check-spec tail "keyword-supplied-p param… | |
272 ((and normalize-keyword tail) | |
273 (setf tail (append tail '(nil)))) | |
274 (normalize-keyword | |
275 (setf tail '(nil nil)))) | |
276 (setf elt (cons var-or-kv tail)))) | |
277 (t | |
278 (check-variable elt "keyword parameter") | |
279 (setf elt (if normalize-keyword | |
280 (list (list (make-keyword elt) elt) n… | |
281 elt)))) | |
282 (push elt keys)) | |
283 (&aux | |
284 (if (consp elt) | |
285 (destructuring-bind (var &optional init) elt | |
286 (declare (ignore init)) | |
287 (check-variable var "&aux parameter")) | |
288 (progn | |
289 (check-variable elt "&aux parameter") | |
290 (setf elt (list* elt (when normalize-auxilary | |
291 '(nil)))))) | |
292 (push elt aux)) | |
293 (t | |
294 (simple-program-error "Invalid ordinary lambda-list:~% ~S… | |
295 (values (nreverse required) (nreverse optional) rest (nreverse keys) | |
296 allow-other-keys (nreverse aux) keyp))) | |
297 | |
298 ;;;; DESTRUCTURING-*CASE | |
299 | |
300 (defun expand-destructuring-case (key clauses case) | |
301 (once-only (key) | |
302 `(if (typep ,key 'cons) | |
303 (,case (car ,key) | |
304 ,@(mapcar (lambda (clause) | |
305 (destructuring-bind ((keys . lambda-list) &body b… | |
306 `(,keys | |
307 (destructuring-bind ,lambda-list (cdr ,key) | |
308 ,@body)))) | |
309 clauses)) | |
310 (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key)))) | |
311 | |
312 (defmacro destructuring-case (keyform &body clauses) | |
313 "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and … | |
314 KEYFORM must evaluate to a CONS. | |
315 | |
316 Clauses are of the form: | |
317 | |
318 ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*) | |
319 | |
320 The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or … | |
321 is selected, and FORMs are then executed with CDR of KEY is destructured… | |
322 bound by the DESTRUCTURING-LAMBDA-LIST. | |
323 | |
324 Example: | |
325 | |
326 (defun dcase (x) | |
327 (destructuring-case x | |
328 ((:foo a b) | |
329 (format nil \"foo: ~S, ~S\" a b)) | |
330 ((:bar &key a b) | |
331 (format nil \"bar: ~S, ~S\" a b)) | |
332 (((:alt1 :alt2) a) | |
333 (format nil \"alt: ~S\" a)) | |
334 ((t &rest rest) | |
335 (format nil \"unknown: ~S\" rest)))) | |
336 | |
337 (dcase (list :foo 1 2)) ; => \"foo: 1, 2\" | |
338 (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" | |
339 (dcase (list :alt1 1)) ; => \"alt: 1\" | |
340 (dcase (list :alt2 2)) ; => \"alt: 2\" | |
341 (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\" | |
342 | |
343 (defun decase (x) | |
344 (destructuring-case x | |
345 ((:foo a b) | |
346 (format nil \"foo: ~S, ~S\" a b)) | |
347 ((:bar &key a b) | |
348 (format nil \"bar: ~S, ~S\" a b)) | |
349 (((:alt1 :alt2) a) | |
350 (format nil \"alt: ~S\" a)))) | |
351 | |
352 (decase (list :foo 1 2)) ; => \"foo: 1, 2\" | |
353 (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\" | |
354 (decase (list :alt1 1)) ; => \"alt: 1\" | |
355 (decase (list :alt2 2)) ; => \"alt: 2\" | |
356 (decase (list :quux 1 2 3)) ; =| error | |
357 " | |
358 (expand-destructuring-case keyform clauses 'case)) | |
359 | |
360 (defmacro destructuring-ccase (keyform &body clauses) | |
361 (expand-destructuring-case keyform clauses 'ccase)) | |
362 | |
363 (defmacro destructuring-ecase (keyform &body clauses) | |
364 (expand-destructuring-case keyform clauses 'ecase)) | |
365 | |
366 (dolist (name '(destructuring-ccase destructuring-ecase)) | |
367 (setf (documentation name 'function) (documentation 'destructuring-cas… | |
368 | |
369 | |
370 |