Commit | Line | Data |
---|---|---|
861345b4 | 1 | ;;; -*-lisp-*- |
2 | ;;; | |
861345b4 | 3 | ;;; Basic definitions |
4 | ;;; | |
5 | ;;; (c) 2005 Mark Wooding | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
b2c12b4e | 14 | ;;; |
861345b4 | 15 | ;;; This program is distributed in the hope that it will be useful, |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
b2c12b4e | 19 | ;;; |
861345b4 | 20 | ;;; You should have received a copy of the GNU General Public License |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
02866e07 MW |
24 | ;;;-------------------------------------------------------------------------- |
25 | ;;; Package things. | |
26 | ||
861345b4 | 27 | (defpackage #:mdw.base |
28 | (:use #:common-lisp) | |
7dcf04ad MW |
29 | #+cmu (:import-from #:extensions #:fixnump)) |
30 | ||
861345b4 | 31 | (in-package #:mdw.base) |
32 | ||
23f32e98 MW |
33 | ;;;-------------------------------------------------------------------------- |
34 | ;;; Useful types. | |
35 | ||
2b525992 | 36 | (export 'unsigned-fixnum) |
23f32e98 MW |
37 | (deftype unsigned-fixnum () |
38 | "Unsigned fixnums; useful as array indices and suchlike." | |
39 | `(mod ,most-positive-fixnum)) | |
40 | ||
02866e07 MW |
41 | ;;;-------------------------------------------------------------------------- |
42 | ;;; Some simple macros to get things going. | |
43 | ||
2b525992 | 44 | (export 'compile-time-defun) |
861345b4 | 45 | (defmacro compile-time-defun (name args &body body) |
46 | "Define a function which can be used by macros during the compilation | |
0ff9df03 | 47 | process." |
fe0f07ea | 48 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
861345b4 | 49 | (defun ,name ,args ,@body))) |
50 | ||
2b525992 | 51 | (export 'show) |
861345b4 | 52 | (defmacro show (x) |
2f94737a | 53 | "Debugging tool: print the expression X and its values." |
861345b4 | 54 | (let ((tmp (gensym))) |
2f94737a | 55 | `(let ((,tmp (multiple-value-list ,x))) |
f36fbd9c | 56 | (fresh-line) |
2f94737a MW |
57 | (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ") |
58 | (format t | |
59 | "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]" | |
60 | ',x | |
61 | ,tmp)) | |
62 | (terpri) | |
63 | (values-list ,tmp)))) | |
861345b4 | 64 | |
2b525992 | 65 | (export 'stringify) |
861345b4 | 66 | (defun stringify (str) |
67 | "Return a string representation of STR. Strings are returned unchanged; | |
0ff9df03 MW |
68 | symbols are converted to their names (unqualified!). Other objects are |
69 | converted to their print representations." | |
861345b4 | 70 | (typecase str |
71 | (string str) | |
72 | (symbol (symbol-name str)) | |
53e95db0 | 73 | (t (princ-to-string str)))) |
02866e07 | 74 | |
2b525992 | 75 | (export 'functionify) |
f5612edb MW |
76 | (defun functionify (func) |
77 | "Convert the function-designator FUNC to a function." | |
78 | (declare (type (or function symbol) func)) | |
79 | (etypecase func | |
80 | (function func) | |
81 | (symbol (symbol-function func)))) | |
82 | ||
2b525992 | 83 | (export 'mappend) |
4b6a6387 MW |
84 | (defun mappend (function list &rest more-lists) |
85 | "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding | |
86 | a list. Return the concatenation of all the resulting lists. Like | |
87 | mapcan, but nondestructive." | |
88 | (apply #'append (apply #'mapcar function list more-lists))) | |
89 | ||
2b525992 | 90 | (export 'listify) |
861345b4 | 91 | (compile-time-defun listify (x) |
92 | "If X is a (possibly empty) list, return X; otherwise return (list X)." | |
93 | (if (listp x) x (list x))) | |
02866e07 | 94 | |
861345b4 | 95 | (compile-time-defun do-fix-pair (x y defaultp) |
96 | "Helper function for fix-pair and pairify." | |
97 | (flet ((singleton (x) (values x (if defaultp y x)))) | |
98 | (cond ((atom x) (singleton x)) | |
99 | ((null (cdr x)) (singleton (car x))) | |
100 | ((atom (cdr x)) (values (car x) (cdr x))) | |
101 | ((cddr x) (error "Too many elements for a pair.")) | |
102 | (t (values (car x) (cadr x)))))) | |
02866e07 | 103 | |
2b525992 | 104 | (export 'fix-pair) |
861345b4 | 105 | (compile-time-defun fix-pair (x &optional (y nil defaultp)) |
106 | "Return two values extracted from X. It works as follows: | |
0ff9df03 MW |
107 | (A) -> A, Y |
108 | (A B) -> A, B | |
109 | (A B . C) -> error | |
110 | (A . B) -> A, B | |
111 | A -> A, Y | |
112 | where Y defaults to A if not specified." | |
861345b4 | 113 | (do-fix-pair x y defaultp)) |
02866e07 | 114 | |
2b525992 | 115 | (export 'pairify) |
861345b4 | 116 | (compile-time-defun pairify (x &optional (y nil defaultp)) |
117 | "As for fix-pair, but returns a list instead of two values." | |
118 | (multiple-value-call #'list (do-fix-pair x y defaultp))) | |
119 | ||
2b525992 | 120 | (export 'whitespace-char-p) |
861345b4 | 121 | (defun whitespace-char-p (ch) |
122 | "Return whether CH is a whitespace character or not." | |
123 | (case ch | |
67cb6748 MW |
124 | (#.(loop for i below char-code-limit |
125 | for ch = (code-char i) | |
126 | unless (with-input-from-string (in (string ch)) | |
127 | (peek-char t in nil)) | |
128 | collect ch) | |
129 | t) | |
861345b4 | 130 | (t nil))) |
131 | ||
2b525992 | 132 | (export 'defconstant*) |
d6caa73b MW |
133 | (defmacro defconstant* (name value &key doc test) |
134 | "Define a constant, like `defconstant'. The TEST is an equality test used | |
135 | to decide whether to override the current definition, if any." | |
136 | (let ((temp (gensym))) | |
137 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
138 | (let ((,temp ,value)) | |
139 | (unless (and (boundp ',name) | |
140 | (funcall ,(or test ''eql) (symbol-value ',name) ,temp)) | |
141 | (defconstant ,name ,value ,@(and doc (list doc)))) | |
142 | ',name)))) | |
143 | ||
2b525992 | 144 | (export 'slot-uninitialized) |
861345b4 | 145 | (declaim (ftype (function nil ()) slot-unitialized)) |
146 | (defun slot-uninitialized () | |
147 | "A function which signals an error. Can be used as an initializer form in | |
0ff9df03 | 148 | structure definitions without doom ensuing." |
861345b4 | 149 | (error "No initializer for slot.")) |
150 | ||
2b525992 | 151 | (export 'parse-body) |
e2a3c923 | 152 | (compile-time-defun parse-body (body &key (allow-docstring-p t)) |
9d3ccec7 | 153 | "Given a BODY (a list of forms), parses it into three sections: a |
0ff9df03 MW |
154 | docstring, a list of declarations (forms beginning with the symbol |
155 | `declare') and the body forms. The result is returned as three lists | |
156 | (even the docstring), suitable for interpolation into a backquoted list | |
e2a3c923 MW |
157 | using `@,'. If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at |
158 | all." | |
159 | (let ((doc nil) (decls nil)) | |
160 | (do ((forms body (cdr forms))) (nil) | |
161 | (let ((form (and forms (car forms)))) | |
162 | (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms)) | |
163 | (setf doc form)) | |
164 | ((and (consp form) | |
165 | (eq (car form) 'declare)) | |
166 | (setf decls (append decls (cdr form)))) | |
167 | (t (return (values (and doc (list doc)) | |
168 | (and decls (list (cons 'declare decls))) | |
169 | forms)))))))) | |
9d3ccec7 | 170 | |
2b525992 | 171 | (export 'with-parsed-body) |
8f801ae8 MW |
172 | (defmacro with-parsed-body |
173 | ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body) | |
174 | "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR | |
175 | to the body, DECLVAR to the declarations, and DOCVAR to (a list | |
176 | containing) the docstring, and evaluate BODY." | |
177 | `(multiple-value-bind | |
178 | (,docvar ,declvar ,bodyvar) | |
179 | (parse-body ,form :allow-docstring-p ,docp) | |
180 | ,@(if docp nil `((declare (ignore ,docvar)))) | |
181 | ,@body)) | |
182 | ||
2b525992 | 183 | (export 'fixnump) |
7dcf04ad MW |
184 | #-cmu |
185 | (progn | |
186 | (declaim (inline fixnump)) | |
187 | (defun fixnump (object) | |
188 | "Answer non-nil if OBJECT is a fixnum, or nil if it isn't." | |
189 | (typep object 'fixnum))) | |
190 | ||
02866e07 MW |
191 | ;;;-------------------------------------------------------------------------- |
192 | ;;; Generating symbols. | |
193 | ||
77f935da MW |
194 | (export 'symbolicate) |
195 | (defun symbolicate (&rest names) | |
196 | "Return a symbol constructued by concatenating the NAMES. | |
197 | ||
198 | The NAMES are coerced to strings, using the `string' function, so they may | |
199 | be strings, characters, or symbols. The resulting symbol is interned in | |
200 | the current `*package*'." | |
201 | (intern (apply #'concatenate 'string (mapcar #'string names)))) | |
202 | ||
2b525992 | 203 | (export 'with-gensyms) |
861345b4 | 204 | (defmacro with-gensyms (syms &body body) |
205 | "Everyone's favourite macro helper." | |
206 | `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) | |
4da88bb9 | 207 | (listify syms))) |
861345b4 | 208 | ,@body)) |
209 | ||
2b525992 | 210 | (export 'let*/gensyms) |
861345b4 | 211 | (defmacro let*/gensyms (binds &body body) |
212 | "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE | |
0ff9df03 MW |
213 | defaults to VAR. The result is that BODY is evaluated in a context where |
214 | each VAR is bound to a gensym, and in the final expansion, each of those | |
215 | gensyms will be bound to the corresponding VALUE." | |
861345b4 | 216 | (labels ((more (binds) |
4da88bb9 MW |
217 | (let ((tmp (gensym "TMP")) (bind (car binds))) |
218 | `((let ((,tmp ,(cadr bind)) | |
219 | (,(car bind) (gensym ,(symbol-name (car bind))))) | |
220 | `(let ((,,(car bind) ,,tmp)) | |
221 | ,,@(if (cdr binds) | |
222 | (more (cdr binds)) | |
223 | body))))))) | |
861345b4 | 224 | (if (null binds) |
4da88bb9 MW |
225 | `(progn ,@body) |
226 | (car (more (mapcar #'pairify (listify binds))))))) | |
861345b4 | 227 | |
7769f8fd MW |
228 | ;;;-------------------------------------------------------------------------- |
229 | ;;; Capturing places as symbols. | |
230 | ||
231 | (defmacro %place-ref (getform setform newtmp) | |
232 | "Grim helper macro for with-places." | |
233 | (declare (ignore setform newtmp)) | |
234 | getform) | |
235 | ||
236 | (define-setf-expander %place-ref (getform setform newtmp) | |
237 | "Grim helper macro for with-places." | |
238 | (values nil nil newtmp setform getform)) | |
239 | ||
240 | (export 'with-places) | |
241 | (defmacro with-places (clauses &body body &environment env) | |
242 | "Define symbols which refer to `setf'-able places. | |
243 | ||
244 | The syntax is similar to `let'. The CLAUSES are a list of (NAME PLACE) | |
245 | pairs. Each NAME is defined as a symbol-macro referring to the | |
246 | corresponding PLACE: a mention of the NAME within the BODY forms extracts | |
247 | the current value(s) of the PLACE, while a `setf' (or `setq', because | |
248 | symbol macros are strange like that) of a NAME updates the value(s) in the | |
249 | PLACE. The returned values are those of the BODY, evaluated as an | |
250 | implicit `progn'." | |
251 | ||
252 | (let ((temp-binds nil) | |
253 | (macro-binds nil)) | |
254 | (dolist (clause clauses) | |
255 | (destructuring-bind (name place) clause | |
256 | (multiple-value-bind (valtmps valforms newtmps setform getform) | |
257 | (get-setf-expansion place env) | |
258 | (setf temp-binds | |
259 | (nconc (nreverse (mapcar #'list valtmps valforms)) | |
260 | temp-binds)) | |
261 | (push `(,name (%place-ref ,getform ,setform ,newtmps)) | |
262 | macro-binds)))) | |
263 | `(let (,@(nreverse temp-binds)) | |
264 | (symbol-macrolet (,@(nreverse macro-binds)) | |
265 | ,@body)))) | |
266 | ||
267 | (export 'with-places/gensyms) | |
268 | (defmacro with-places/gensyms (clauses &body body) | |
269 | "A kind of a cross between `with-places' and `let*/gensyms'. | |
270 | ||
271 | This is a hairy helper for writing `setf'-like macros. The CLAUSES are a | |
272 | list of (NAME [PLACE]) pairs, where the PLACE defaults to NAME, and a | |
273 | bare NAME may be written in place of the singleton list (NAME). The | |
274 | PLACEs are evaluated. | |
275 | ||
276 | The BODY forms are evaluated as an implicit `progn', with each NAME bound | |
277 | to a gensym, to produce a Lisp form, called the `kernel'. The result of | |
278 | the `with-places/gensyms' macro is then itself a Lisp form, called the | |
279 | `result'. | |
280 | ||
281 | The effect of evaluating the `result' form is to evaluate the `kernel' | |
282 | form with each of the gensyms stands for the value(s) stored in the | |
283 | corresponding PLACE; a `setf' (or `setq') of one of the gensyms updates | |
284 | the value(s) in the corresponding PLACE. The values returned by the | |
285 | `result' form are the values returned by the `kernel'." | |
286 | ||
287 | (let* ((clauses (mapcar #'pairify clauses)) | |
288 | (names (mapcar #'car clauses)) | |
289 | (places (mapcar #'cadr clauses)) | |
290 | (gensyms (mapcar (lambda (name) (gensym (symbol-name name))) | |
291 | names))) | |
292 | ``(with-places (,,@(mapcar (lambda (gensym place) | |
293 | ``(,',gensym ,,place)) | |
294 | gensyms places)) | |
295 | ,(let (,@(mapcar (lambda (name gensym) | |
296 | `(,name ',gensym)) | |
297 | names gensyms)) | |
298 | ,@body)))) | |
299 | ||
f2d46aaa MW |
300 | ;;;-------------------------------------------------------------------------- |
301 | ;;; Some simple yet useful control structures. | |
302 | ||
2b525992 | 303 | (export 'nlet) |
f2d46aaa MW |
304 | (defmacro nlet (name binds &body body) |
305 | "Scheme's named let." | |
306 | (multiple-value-bind (vars vals) | |
307 | (loop for bind in binds | |
308 | for (var val) = (pairify bind nil) | |
309 | collect var into vars | |
310 | collect val into vals | |
311 | finally (return (values vars vals))) | |
312 | `(labels ((,name ,vars | |
4da88bb9 | 313 | ,@body)) |
f2d46aaa MW |
314 | (,name ,@vals)))) |
315 | ||
2b525992 | 316 | (export 'while) |
f2d46aaa MW |
317 | (defmacro while (cond &body body) |
318 | "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." | |
38ccae7f MW |
319 | `(loop (unless ,cond (return)) (progn ,@body))) |
320 | ||
2b525992 | 321 | (export 'until) |
38ccae7f MW |
322 | (defmacro until (cond &body body) |
323 | "If COND is true, evaluate to nil; otherwise evaluate BODY and try again." | |
324 | `(loop (when ,cond (return)) (progn ,@body))) | |
f2d46aaa | 325 | |
560e1186 MW |
326 | (compile-time-defun do-case2-like (kind vform clauses) |
327 | "Helper function for `case2' and `ecase2'." | |
328 | (with-gensyms (scrutinee argument) | |
329 | `(multiple-value-bind (,scrutinee ,argument) ,vform | |
330 | (declare (ignorable ,argument)) | |
331 | (,kind ,scrutinee | |
332 | ,@(mapcar (lambda (clause) | |
333 | (destructuring-bind | |
b3bc3745 | 334 | (cases (&optional varx vary) &rest forms) |
560e1186 MW |
335 | clause |
336 | `(,cases | |
b3bc3745 MW |
337 | ,@(if varx |
338 | (list `(let ((,(or vary varx) ,argument) | |
339 | ,@(and vary | |
340 | `((,varx ,scrutinee)))) | |
4da88bb9 | 341 | ,@forms)) |
560e1186 MW |
342 | forms)))) |
343 | clauses))))) | |
344 | ||
d9cfb3e0 | 345 | (export 'case2) |
560e1186 MW |
346 | (defmacro case2 (vform &body clauses) |
347 | "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT. | |
b3bc3745 MW |
348 | The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a |
349 | standard `case' clause has the form (CASES FORMS...). The `case2' form | |
350 | evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in | |
351 | order, just like `case'. If there is a match, then the corresponding | |
352 | FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to | |
353 | the SCRUTINEE (where specified). Note the bizarre defaulting behaviour: | |
354 | ARGVAR is less optional than SCRUVAR." | |
560e1186 MW |
355 | (do-case2-like 'case vform clauses)) |
356 | ||
2b525992 | 357 | (export 'ecase2) |
560e1186 MW |
358 | (defmacro ecase2 (vform &body clauses) |
359 | "Like `case2', but signals an error if no clause matches the SCRUTINEE." | |
360 | (do-case2-like 'ecase vform clauses)) | |
361 | ||
2b525992 | 362 | (export 'setf-default) |
79ae1f5c | 363 | (defmacro setf-default (&rest specs) |
2af61873 MW |
364 | "Like setf, but only sets places which are currently nil. |
365 | ||
366 | The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE | |
367 | is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the | |
368 | default is /not/ stored. The result is the (new) value of the last | |
369 | PLACE." | |
79ae1f5c MW |
370 | `(progn ,@(do ((list nil) |
371 | (specs specs (cddr specs))) | |
372 | ((endp specs) (nreverse list)) | |
373 | (unless (cdr specs) | |
374 | (error "Odd number of arguments for `setf-default'.")) | |
375 | (push (with-places/gensyms ((place (car specs))) | |
376 | `(or ,place (setf ,place ,(cadr specs)))) | |
377 | list)))) | |
2af61873 | 378 | |
02866e07 MW |
379 | ;;;-------------------------------------------------------------------------- |
380 | ;;; Update-in-place macros built using with-places. | |
381 | ||
2b525992 | 382 | (export 'update-place) |
171bb403 | 383 | (defmacro update-place (op place &rest args) |
53ccd042 | 384 | "Update PLACE with (OP PLACE . ARGS), returning the new value." |
171bb403 | 385 | (with-places/gensyms (place) |
53ccd042 | 386 | `(setf ,place (,op ,place ,@args)))) |
02866e07 | 387 | |
2b525992 | 388 | (export 'update-place-after) |
171bb403 | 389 | (defmacro update-place-after (op place &rest args) |
53ccd042 | 390 | "Update PLACE with (OP PLACE . ARGS), returning the old value." |
171bb403 | 391 | (with-places/gensyms (place) |
e979e568 MW |
392 | (with-gensyms (x) |
393 | `(let ((,x ,place)) | |
53ccd042 | 394 | (setf ,place (,op ,x ,@args)) |
02866e07 MW |
395 | ,x)))) |
396 | ||
2b525992 | 397 | (export 'incf-after) |
e979e568 MW |
398 | (defmacro incf-after (place &optional (by 1)) |
399 | "Increment PLACE by BY, returning the old value." | |
400 | `(update-place-after + ,place ,by)) | |
02866e07 | 401 | |
2b525992 | 402 | (export 'decf-after) |
e979e568 MW |
403 | (defmacro decf-after (place &optional (by 1)) |
404 | "Decrement PLACE by BY, returning the old value." | |
405 | `(update-place-after - ,place ,by)) | |
406 | ||
02866e07 MW |
407 | ;;;-------------------------------------------------------------------------- |
408 | ;;; Locatives. | |
e979e568 | 409 | |
2b525992 | 410 | (export 'locp) |
861345b4 | 411 | (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) |
412 | "Locative data type. See `locf' and `ref'." | |
bd5bea43 MW |
413 | (reader (slot-uninitialized) :type function :read-only t) |
414 | (writer (slot-uninitialized) :type function :read-only t)) | |
02866e07 | 415 | |
2b525992 | 416 | (export 'locf) |
861345b4 | 417 | (defmacro locf (place &environment env) |
418 | "Slightly cheesy locatives. (locf PLACE) returns an object which, using | |
0ff9df03 MW |
419 | the `ref' function, can be used to read or set the value of PLACE. It's |
420 | cheesy because it uses closures rather than actually taking the address of | |
421 | something. Also, unlike Zetalisp, we don't overload `car' to do our dirty | |
422 | work." | |
861345b4 | 423 | (multiple-value-bind |
424 | (valtmps valforms newtmps setform getform) | |
425 | (get-setf-expansion place env) | |
426 | `(let* (,@(mapcar #'list valtmps valforms)) | |
427 | (make-loc (lambda () ,getform) | |
4da88bb9 | 428 | (lambda (,@newtmps) ,setform))))) |
02866e07 | 429 | |
2b525992 | 430 | (export 'ref) |
ad18ddfc | 431 | (declaim (inline ref (setf ref))) |
861345b4 | 432 | (defun ref (loc) |
433 | "Fetch the value referred to by a locative." | |
434 | (funcall (loc-reader loc))) | |
435 | (defun (setf ref) (new loc) | |
436 | "Store a new value in the place referred to by a locative." | |
437 | (funcall (loc-writer loc) new)) | |
02866e07 | 438 | |
2b525992 | 439 | (export 'with-locatives) |
861345b4 | 440 | (defmacro with-locatives (locs &body body) |
441 | "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a | |
0ff9df03 MW |
442 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it |
443 | defaults to SYM. As an abbreviation for a common case, LOCS may be a | |
444 | symbol instead of a list. The BODY is evaluated in an environment where | |
445 | each SYM is a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, | |
446 | something similar which doesn't break if LOC-EXPR has side-effects. Thus, | |
447 | references, including `setf' forms, fetch or modify the thing referred to | |
448 | by the LOC-EXPR. Useful for covering over where something uses a | |
449 | locative." | |
861345b4 | 450 | (setf locs (mapcar #'pairify (listify locs))) |
451 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) | |
452 | (ll (mapcar #'cadr locs)) | |
453 | (ss (mapcar #'car locs))) | |
454 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) | |
455 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) | |
456 | `(,sym (ref ,tmp))) ss tt)) | |
457 | ,@body)))) | |
458 | ||
459 | ;;;----- That's all, folks -------------------------------------------------- |