macros.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) 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 FORMS.
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 SYMBOL).
8
9 Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL
10 should be bound to a symbol constructed using GENSYM with the string designated
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 introducing
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 in order
40 to evaluate EXPR-1, ..., EXPR-N once, only. RES is code that is the result of
41 evaluating the implicit progn FORMS within a special context determined by
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 INITFORM).
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 the
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. INITFORMs of
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) spec
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 body))
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-list:~% ~S"
185 elt lambda-list))
186 (check-variable (elt what &optional (allow-specializers allow-specializers))
187 (unless (and (or (symbolp elt)
188 (and allow-specializers
189 (consp elt) (= 2 (length elt)) (symbolp (first elt))))
190 (not (constantp elt)))
191 (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
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-list:~% ~S"
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 &allow-other-keys &aux)))
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 parameter"))
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 name ~S in ordinary ~
263 lambda-list:~% ~S"
264 keyword lambda-list))
265 (check-variable var "keyword parameter")))
266 (t
267 (check-variable var-or-kv "keyword parameter")
268 (when normalize-keyword
269 (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
270 (cond ((cdr tail)
271 (check-spec tail "keyword-supplied-p parameter"))
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) nil nil)
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" lambda-list)))))))
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 body) clause
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 DESTRUCTURING-BIND.
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 ECASE,
321 is selected, and FORMs are then executed with CDR of KEY is destructured and
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-case 'function)))
368
369
370