tmacros.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tmacros.lisp (12185B)
---
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 7. Existence of &KEY in the lambda-list.
116
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))
167 (t
168 (setf auxp t
169 state elt))
170 ))
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 ((and normalize-optional tail)
188 (setf elt (append elt '(nil))))
189 (normalize-optional
190 (setf elt (append elt '(nil nil)))))))
191 (t
192 (check-variable elt "optional parameter")
193 (when normalize-optional
194 (setf elt (cons elt '(nil nil))))))
195 (push (ensure-list elt) optional))
196 (&rest
197 (check-variable elt "rest parameter")
198 (setf rest elt
199 state :after-rest))
200 (&key
201 (cond ((consp elt)
202 (destructuring-bind (var-or-kv &rest tail) elt
203 (cond ((consp var-or-kv)
204 (destructuring-bind (keyword var) var-or-kv
205 (unless (symbolp keyword)
206 (simple-program-error "Invalid keyword name ~S in ordinary ~
207 lambda-list:~% ~S"
208 keyword lambda-list))
209 (check-variable var "keyword parameter")))
210 (t
211 (check-variable var-or-kv "keyword parameter")
212 (when normalize-keyword
213 (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv)))))
214 (cond ((cdr tail)
215 (check-spec tail "keyword-supplied-p parameter"))
216 ((and normalize-keyword tail)
217 (setf tail (append tail '(nil))))
218 (normalize-keyword
219 (setf tail '(nil nil))))
220 (setf elt (cons var-or-kv tail))))
221 (t
222 (check-variable elt "keyword parameter")
223 (setf elt (if normalize-keyword
224 (list (list (make-keyword elt) elt) nil nil)
225 elt))))
226 (push elt keys))
227 (&aux
228 (if (consp elt)
229 (destructuring-bind (var &optional init) elt
230 (declare (ignore init))
231 (check-variable var "&aux parameter"))
232 (progn
233 (check-variable elt "&aux parameter")
234 (setf elt (list* elt (when normalize-auxilary
235 '(nil))))))
236 (push elt aux))
237 (t
238 (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
239 (values (nreverse required) (nreverse optional) rest (nreverse keys)
240 allow-other-keys (nreverse aux) keyp)))
241
242 ;;;; DESTRUCTURING-*CASE
243
244 (defun expand-destructuring-case (key clauses case)
245 (once-only (key)
246 `(if (typep ,key 'cons)
247 (,case (car ,key)
248 ,@(mapcar (lambda (clause)
249 (destructuring-bind ((keys . lambda-list) &body body) clause
250 `(,keys
251 (destructuring-bind ,lambda-list (cdr ,key)
252 ,@body))))
253 clauses))
254 (error "Invalid key to DESTRUCTURING-~S: ~S" ',case ,key))))
255
256 (defmacro destructuring-case (keyform &body clauses)
257 "DESTRUCTURING-CASE, -CCASE, and -ECASE are a combination of CASE and DESTRUCTURING-BIND.
258 KEYFORM must evaluate to a CONS.
259
260 Clauses are of the form:
261
262 ((CASE-KEYS . DESTRUCTURING-LAMBDA-LIST) FORM*)
263
264 The clause whose CASE-KEYS matches CAR of KEY, as if by CASE, CCASE, or ECASE,
265 is selected, and FORMs are then executed with CDR of KEY is destructured and
266 bound by the DESTRUCTURING-LAMBDA-LIST.
267
268 Example:
269
270 (defun dcase (x)
271 (destructuring-case x
272 ((:foo a b)
273 (format nil \"foo: ~S, ~S\" a b))
274 ((:bar &key a b)
275 (format nil \"bar: ~S, ~S\" a b))
276 (((:alt1 :alt2) a)
277 (format nil \"alt: ~S\" a))
278 ((t &rest rest)
279 (format nil \"unknown: ~S\" rest))))
280
281 (dcase (list :foo 1 2)) ; => \"foo: 1, 2\"
282 (dcase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
283 (dcase (list :alt1 1)) ; => \"alt: 1\"
284 (dcase (list :alt2 2)) ; => \"alt: 2\"
285 (dcase (list :quux 1 2 3)) ; => \"unknown: 1, 2, 3\"
286
287 (defun decase (x)
288 (destructuring-case x
289 ((:foo a b)
290 (format nil \"foo: ~S, ~S\" a b))
291 ((:bar &key a b)
292 (format nil \"bar: ~S, ~S\" a b))
293 (((:alt1 :alt2) a)
294 (format nil \"alt: ~S\" a))))
295
296 (decase (list :foo 1 2)) ; => \"foo: 1, 2\"
297 (decase (list :bar :a 1 :b 2)) ; => \"bar: 1, 2\"
298 (decase (list :alt1 1)) ; => \"alt: 1\"
299 (decase (list :alt2 2)) ; => \"alt: 2\"
300 (decase (list :quux 1 2 3)) ; =| error
301 "
302 (expand-destructuring-case keyform clauses 'case))
303
304 (defmacro destructuring-ccase (keyform &body clauses)
305 (expand-destructuring-case keyform clauses 'ccase))
306
307 (defmacro destructuring-ecase (keyform &body clauses)
308 (expand-destructuring-case keyform clauses 'ecase))
309
310 (dolist (name '(destructuring-ccase destructuring-ecase))
311 (setf (documentation name 'function) (documentation 'destructuring-case 'function)))
312
313
314