Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Various handy utilities | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
11 | ;;; |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
bb99b695 MW |
26 | (eval-when (:compile-toplevel :load-toplevel :execute) |
27 | (handler-bind ((warning #'muffle-warning)) | |
28 | (cl:defpackage #:sod-utilities | |
29 | (:use #:common-lisp | |
30 | ||
31 | ;; MOP from somewhere. | |
32 | #+sbcl #:sb-mop | |
33 | #+(or cmu clisp) #:mop | |
34 | #+ecl #:clos)))) | |
dea4d055 MW |
35 | |
36 | (cl:in-package #:sod-utilities) | |
37 | ||
38 | ;;;-------------------------------------------------------------------------- | |
8e3552b3 MW |
39 | ;;; Common symbols. |
40 | ;;; | |
41 | ;;; Sometimes, logically independent packages will want to use the same | |
42 | ;;; symbol, and these uses (by careful design) don't conflict with each | |
43 | ;;; other. If we export the symbols here, then the necessary sharing will | |
44 | ;;; happen automatically. | |
45 | ||
46 | (export 'int) ; used by c-types and optparse | |
47 | ||
48 | ;;;-------------------------------------------------------------------------- | |
dea4d055 MW |
49 | ;;; Macro hacks. |
50 | ||
51 | (export 'with-gensyms) | |
52 | (defmacro with-gensyms ((&rest binds) &body body) | |
53 | "Evaluate BODY with variables bound to fresh symbols. | |
54 | ||
55 | The BINDS are a list of entries (VAR [NAME]), and a singleton list can be | |
56 | replaced by just a symbol; each VAR is bound to a fresh symbol generated | |
57 | by (gensym NAME), where NAME defaults to the symbol-name of VAR." | |
58 | `(let (,@(mapcar (lambda (bind) | |
59 | (multiple-value-bind (var name) | |
60 | (if (atom bind) | |
61 | (values bind (concatenate 'string | |
62 | (symbol-name bind) "-")) | |
63 | (destructuring-bind | |
64 | (var &optional | |
65 | (name (concatenate 'string | |
66 | (symbol-name var) "-"))) | |
67 | bind | |
68 | (values var name))) | |
69 | `(,var (gensym ,name)))) | |
70 | binds)) | |
71 | ,@body)) | |
72 | ||
73 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
74 | (defun strip-quote (form) | |
75 | "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO. | |
76 | ||
77 | If FORM is a symbol whose constant value is `nil' then return `nil'. | |
78 | Otherwise return FORM unchanged. This makes it easier to inspect constant | |
79 | things. This is a utility for `once-only'." | |
80 | ||
81 | (cond ((and (consp form) | |
82 | (eq (car form) 'quote) | |
83 | (cdr form) | |
84 | (null (cddr form))) | |
85 | (let ((body (cadr form))) | |
86 | (if (or (not (or (consp body) (symbolp body))) | |
87 | (member body '(t nil)) | |
88 | (keywordp body)) | |
89 | body | |
90 | form))) | |
91 | ((and (symbolp form) (boundp form) (null (symbol-value form))) | |
92 | nil) | |
93 | (t | |
94 | form)))) | |
95 | ||
96 | (export 'once-only) | |
74ca1bf5 | 97 | (defmacro once-only ((&rest binds) &body body) |
dea4d055 MW |
98 | "Macro helper for preventing repeated evaluation. |
99 | ||
100 | The syntax is actually hairier than shown: | |
101 | ||
102 | once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* ) | |
103 | { FORM }* | |
104 | ||
105 | So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list | |
106 | can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR. | |
107 | But before them you can have keyword arguments. Only one is defined so | |
108 | far. See below for the crazy things that does. | |
109 | ||
110 | The result of evaluating a ONCE-ONLY form is a form with the structure | |
111 | ||
112 | (let ((#:GS1 VALUE-FORM1) | |
113 | ... | |
114 | (#:GSn VALUE-FORMn)) | |
115 | STUFF) | |
116 | ||
117 | where STUFF is the value of the BODY forms, as an implicit progn, in an | |
118 | environment with the VARs bound to the corresponding gensyms. | |
119 | ||
120 | As additional magic, if any of the VALUE-FORMs is actually constant (as | |
121 | determined by inspection, and aided by `constantp' if an :environment is | |
122 | supplied, then no gensym is constructed for it, and the VAR is bound | |
123 | directly to the constant form. Moreover, if the constant form looks like | |
124 | (quote FOO) for a self-evaluating FOO then the outer layer of quoting is | |
125 | stripped away." | |
126 | ||
127 | ;; We need an extra layer of gensyms in our expansion: we'll want the | |
128 | ;; expansion to examine the various VALUE-FORMs to find out whether they're | |
129 | ;; constant without evaluating them repeatedly. This also helps with | |
130 | ;; another problem: we explicitly encourage the rebinding of a VAR | |
131 | ;; (probably a macro argument) to a gensym which will be bound to the value | |
132 | ;; of the form previously held in VAR itself -- so the gensym and value | |
133 | ;; form must exist at the same time and we need two distinct variables. | |
134 | ||
135 | (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-")) | |
136 | (let ((env nil)) | |
137 | ||
138 | ;; First things first: let's pick up the keywords. | |
139 | (loop | |
140 | (unless (and binds (keywordp (car binds))) | |
141 | (return)) | |
142 | (ecase (pop binds) | |
143 | (:environment (setf env (pop binds))))) | |
144 | ||
145 | ;; Now we'll investigate the bindings. Turn each one into a list (VAR | |
146 | ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note | |
147 | ;; above. | |
148 | (let ((canon (mapcar (lambda (bind) | |
149 | (multiple-value-bind (var form) | |
150 | (if (atom bind) | |
151 | (values bind bind) | |
152 | (destructuring-bind | |
153 | (var &optional (form var)) bind | |
154 | (values var form))) | |
155 | (list var form | |
156 | (gensym (format nil "T-~A-" | |
157 | (symbol-name var)))))) | |
158 | binds))) | |
159 | ||
160 | `(let* (,@(and env `((,envvar ,env))) | |
161 | (,lets nil) | |
162 | ,@(mapcar (lambda (bind) | |
163 | (destructuring-bind (var form temp) bind | |
164 | (declare (ignore var)) | |
165 | `(,temp ,form))) | |
166 | canon) | |
167 | ,@(mapcar (lambda (bind) | |
168 | (destructuring-bind (var form temp) bind | |
169 | (declare (ignore form)) | |
170 | `(,var | |
171 | (cond ((constantp ,temp | |
172 | ,@(and env `(,envvar))) | |
173 | (strip-quote ,temp)) | |
174 | ((symbolp ,temp) | |
175 | ,temp) | |
176 | (t | |
177 | (let ((,sym (gensym | |
178 | ,(concatenate 'string | |
179 | (symbol-name var) | |
180 | "-")))) | |
181 | (push (list ,sym ,temp) ,lets) | |
182 | ,sym)))))) | |
183 | canon)) | |
184 | (flet ((,bodyfunc () ,@body)) | |
185 | (if ,lets | |
186 | `(let (,@(nreverse ,lets)) ,(,bodyfunc)) | |
187 | (,bodyfunc)))))))) | |
188 | ||
189 | (export 'parse-body) | |
b8c698ee | 190 | (defun parse-body (body &key (docp t) (declp t)) |
dea4d055 MW |
191 | "Parse the BODY into a docstring, declarations and the body forms. |
192 | ||
193 | These are returned as three lists, so that they can be spliced into a | |
194 | macro expansion easily. The declarations are consolidated into a single | |
b8c698ee MW |
195 | `declare' form. If DOCP is nil then a docstring is not permitted; if |
196 | DECLP is nil, then declarations are not permitted." | |
dea4d055 MW |
197 | (let ((decls nil) |
198 | (doc nil)) | |
199 | (loop | |
200 | (cond ((null body) (return)) | |
b8c698ee | 201 | ((and declp (consp (car body)) (eq (caar body) 'declare)) |
dea4d055 | 202 | (setf decls (append decls (cdr (pop body))))) |
b8c698ee | 203 | ((and docp (stringp (car body)) (not doc) (cdr body)) |
dea4d055 MW |
204 | (setf doc (pop body))) |
205 | (t (return)))) | |
206 | (values (and doc (list doc)) | |
207 | (and decls (list (cons 'declare decls))) | |
208 | body))) | |
209 | ||
210 | ;;;-------------------------------------------------------------------------- | |
e8abb286 MW |
211 | ;;; Locatives. |
212 | ||
db960992 MW |
213 | (export '(locative locativep)) |
214 | (defstruct (locative (:predicate locativep) | |
215 | (:constructor make-locative (reader writer)) | |
216 | (:conc-name loc-)) | |
e8abb286 MW |
217 | "Locative data type. See `locf' and `ref'." |
218 | (reader nil :type function) | |
219 | (writer nil :type function)) | |
220 | ||
221 | (export 'locf) | |
222 | (defmacro locf (place &environment env) | |
223 | "Slightly cheesy locatives. | |
224 | ||
225 | (locf PLACE) returns an object which, using the `ref' function, can be | |
226 | used to read or set the value of PLACE. It's cheesy because it uses | |
227 | closures rather than actually taking the address of something. Also, | |
228 | unlike Zetalisp, we don't overload `car' to do our dirty work." | |
229 | (multiple-value-bind | |
230 | (valtmps valforms newtmps setform getform) | |
231 | (get-setf-expansion place env) | |
232 | `(let* (,@(mapcar #'list valtmps valforms)) | |
db960992 MW |
233 | (make-locative (lambda () ,getform) |
234 | (lambda (,@newtmps) ,setform))))) | |
e8abb286 MW |
235 | |
236 | (export 'ref) | |
237 | (declaim (inline ref (setf ref))) | |
238 | (defun ref (loc) | |
239 | "Fetch the value referred to by a locative." | |
240 | (funcall (loc-reader loc))) | |
241 | (defun (setf ref) (new loc) | |
242 | "Store a new value in the place referred to by a locative." | |
243 | (funcall (loc-writer loc) new)) | |
244 | ||
245 | (export 'with-locatives) | |
246 | (defmacro with-locatives (locs &body body) | |
247 | "Evaluate BODY with implicit locatives. | |
248 | ||
249 | LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a | |
250 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it | |
251 | defaults to SYM. As an abbreviation for a common case, LOCS may be a | |
252 | symbol instead of a list. | |
253 | ||
254 | The BODY is evaluated in an environment where each SYM is a symbol macro | |
255 | which expands to (ref LOC-EXPR) -- or, in fact, something similar which | |
256 | doesn't break if LOC-EXPR has side-effects. Thus, references, including | |
257 | `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. | |
258 | Useful for covering over where something uses a locative." | |
259 | (setf locs (mapcar (lambda (item) | |
260 | (cond ((atom item) (list item item)) | |
261 | ((null (cdr item)) (list (car item) (car item))) | |
262 | (t item))) | |
263 | (if (listp locs) locs (list locs)))) | |
264 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) | |
265 | (ll (mapcar #'cadr locs)) | |
266 | (ss (mapcar #'car locs))) | |
267 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) | |
268 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) | |
269 | `(,sym (ref ,tmp))) ss tt)) | |
270 | ,@body)))) | |
271 | ||
272 | ;;;-------------------------------------------------------------------------- | |
dea4d055 MW |
273 | ;;; Anaphorics. |
274 | ||
275 | (export 'it) | |
276 | ||
277 | (export 'aif) | |
278 | (defmacro aif (cond cons &optional (alt nil altp)) | |
279 | "If COND is not nil, evaluate CONS with `it' bound to the value of COND. | |
280 | ||
281 | Otherwise, if given, evaluate ALT; `it' isn't bound in ALT." | |
282 | (once-only (cond) | |
283 | `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt))))) | |
284 | ||
285 | (export 'awhen) | |
286 | (defmacro awhen (cond &body body) | |
287 | "If COND, evaluate BODY as a progn with `it' bound to the value of COND." | |
288 | `(let ((it ,cond)) (when it ,@body))) | |
289 | ||
3e166443 MW |
290 | (export 'aand) |
291 | (defmacro aand (&rest forms) | |
292 | "Like `and', but anaphoric. | |
293 | ||
294 | Each FORM except the first is evaluated with `it' bound to the value of | |
295 | the previous one. If there are no forms, then the result it `t'; if there | |
296 | is exactly one, then wrapping it in `aand' is pointless." | |
297 | (labels ((doit (first rest) | |
298 | (if (null rest) | |
299 | first | |
300 | `(let ((it ,first)) | |
301 | (if it ,(doit (car rest) (cdr rest)) nil))))) | |
302 | (if (null forms) | |
303 | 't | |
304 | (doit (car forms) (cdr forms))))) | |
305 | ||
dea4d055 | 306 | (export 'acond) |
bf090e02 | 307 | (defmacro acond (&body clauses &environment env) |
dea4d055 MW |
308 | "Like COND, but with `it' bound to the value of the condition. |
309 | ||
310 | Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is | |
311 | non-nil then evaluate the FORMs with `it' bound to the non-nil value, and | |
312 | return the value of the last FORM; if there are no FORMs, then return `it' | |
313 | itself. If the CONDITION is nil then continue with the next clause; if | |
314 | all clauses evaluate to nil then the result is nil." | |
315 | (labels ((walk (clauses) | |
316 | (if (null clauses) | |
317 | `nil | |
318 | (once-only (:environment env (cond (caar clauses))) | |
319 | (if (and (constantp cond) | |
320 | (if (and (consp cond) (eq (car cond) 'quote)) | |
321 | (cadr cond) cond)) | |
322 | (if (cdar clauses) | |
323 | `(let ((it ,cond)) | |
324 | (declare (ignorable it)) | |
325 | ,@(cdar clauses)) | |
326 | cond) | |
327 | `(if ,cond | |
328 | ,(if (cdar clauses) | |
329 | `(let ((it ,cond)) | |
330 | (declare (ignorable it)) | |
331 | ,@(cdar clauses)) | |
332 | cond) | |
333 | ,(walk (cdr clauses)))))))) | |
334 | (walk clauses))) | |
335 | ||
336 | (export '(acase aecase atypecase aetypecase)) | |
337 | (defmacro acase (value &body clauses) | |
338 | `(let ((it ,value)) (case it ,@clauses))) | |
339 | (defmacro aecase (value &body clauses) | |
340 | `(let ((it ,value)) (ecase it ,@clauses))) | |
341 | (defmacro atypecase (value &body clauses) | |
342 | `(let ((it ,value)) (typecase it ,@clauses))) | |
343 | (defmacro aetypecase (value &body clauses) | |
344 | `(let ((it ,value)) (etypecase it ,@clauses))) | |
345 | ||
346 | (export 'asetf) | |
347 | (defmacro asetf (&rest places-and-values &environment env) | |
348 | "Anaphoric update of places. | |
349 | ||
350 | The PLACES-AND-VALUES are alternating PLACEs and VALUEs. Each VALUE is | |
351 | evaluated with IT bound to the current value stored in the corresponding | |
352 | PLACE." | |
353 | `(progn ,@(loop for (place value) on places-and-values by #'cddr | |
354 | collect (multiple-value-bind | |
355 | (temps inits newtemps setform getform) | |
356 | (get-setf-expansion place env) | |
357 | `(let* (,@(mapcar #'list temps inits) | |
358 | (it ,getform)) | |
359 | (multiple-value-bind ,newtemps ,value | |
360 | ,setform)))))) | |
361 | ||
362 | ;;;-------------------------------------------------------------------------- | |
363 | ;;; MOP hacks (not terribly demanding). | |
364 | ||
bf090e02 MW |
365 | (export 'instance-initargs) |
366 | (defgeneric instance-initargs (instance) | |
367 | (:documentation | |
368 | "Return a plausble list of initargs for INSTANCE. | |
369 | ||
370 | The idea is that you can make a copy of INSTANCE by invoking | |
371 | ||
372 | (apply #'make-instance (class-of INSTANCE) | |
373 | (instance-initargs INSTANCE)) | |
374 | ||
375 | The default implementation works by inspecting the slot definitions and | |
376 | extracting suitable initargs, so this will only succeed if enough slots | |
377 | actually have initargs specified that `initialize-instance' can fill in | |
378 | the rest correctly. | |
379 | ||
380 | The list returned is freshly consed, and you can destroy it if you like.") | |
381 | (:method ((instance standard-object)) | |
382 | (mapcan (lambda (slot) | |
383 | (aif (slot-definition-initargs slot) | |
384 | (list (car it) | |
385 | (slot-value instance (slot-definition-name slot))) | |
386 | nil)) | |
387 | (class-slots (class-of instance))))) | |
388 | ||
dea4d055 MW |
389 | (export '(copy-instance copy-instance-using-class)) |
390 | (defgeneric copy-instance-using-class (class instance &rest initargs) | |
391 | (:documentation | |
392 | "Metaobject protocol hook for `copy-instance'.") | |
393 | (:method ((class standard-class) instance &rest initargs) | |
394 | (let ((copy (allocate-instance class))) | |
395 | (dolist (slot (class-slots class)) | |
396 | (let ((name (slot-definition-name slot))) | |
397 | (when (slot-boundp instance name) | |
398 | (setf (slot-value copy name) (slot-value instance name))))) | |
399 | (apply #'shared-initialize copy nil initargs)))) | |
400 | (defun copy-instance (object &rest initargs) | |
401 | "Construct and return a copy of OBJECT. | |
402 | ||
403 | The new object has the same class as OBJECT, and the same slot values | |
404 | except where overridden by INITARGS." | |
405 | (apply #'copy-instance-using-class (class-of object) object initargs)) | |
406 | ||
9ec578d9 MW |
407 | (export '(generic-function-methods method-specializers |
408 | eql-specializer eql-specializer-object)) | |
409 | ||
dea4d055 MW |
410 | ;;;-------------------------------------------------------------------------- |
411 | ;;; List utilities. | |
412 | ||
413 | (export 'make-list-builder) | |
414 | (defun make-list-builder (&optional initial) | |
415 | "Return a simple list builder." | |
416 | ||
417 | ;; The `builder' is just a cons cell whose cdr will be the list that's | |
418 | ;; wanted. Effectively, then, we have a list that's one item longer than | |
419 | ;; we actually want. The car of this extra initial cons cell is always the | |
420 | ;; last cons in the list -- which is now well defined because there's | |
421 | ;; always at least one. | |
422 | ||
423 | (let ((builder (cons nil initial))) | |
424 | (setf (car builder) (last builder)) | |
425 | builder)) | |
426 | ||
427 | (export 'lbuild-add) | |
428 | (defun lbuild-add (builder item) | |
429 | "Add an ITEM to the end of a list BUILDER." | |
430 | (let ((new (cons item nil))) | |
431 | (setf (cdar builder) new | |
432 | (car builder) new)) | |
433 | builder) | |
434 | ||
435 | (export 'lbuild-add-list) | |
436 | (defun lbuild-add-list (builder list) | |
437 | "Add a LIST to the end of a list BUILDER. The LIST will be clobbered." | |
438 | (when list | |
439 | (setf (cdar builder) list | |
440 | (car builder) (last list))) | |
441 | builder) | |
442 | ||
443 | (export 'lbuild-list) | |
444 | (defun lbuild-list (builder) | |
445 | "Return the constructed list." | |
446 | (cdr builder)) | |
447 | ||
448 | (export 'mappend) | |
449 | (defun mappend (function list &rest more-lists) | |
69dda0c9 | 450 | "Like a nondestructive `mapcan'. |
dea4d055 MW |
451 | |
452 | Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, | |
453 | and return the result of appending all of the resulting lists." | |
454 | (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) | |
455 | ||
0a8f78ec MW |
456 | (export 'cross-product) |
457 | (defun cross-product (&rest pieces) | |
458 | "Return the cross product of the PIECES. | |
459 | ||
460 | Each arguments may be a list, or a (non-nil) atom, which is equivalent to | |
461 | a singleton list containing just that atom. Return a list of all possible | |
462 | lists which can be constructed by taking one item from each argument list | |
463 | in turn, in an arbitrary order." | |
464 | (reduce (lambda (piece tails) | |
465 | (mapcan (lambda (tail) | |
466 | (mapcar (lambda (head) | |
467 | (cons head tail)) | |
468 | (if (listp piece) piece | |
469 | (list piece)))) | |
470 | tails)) | |
471 | pieces | |
472 | :from-end t | |
473 | :initial-value '(nil))) | |
474 | ||
17c7c784 MW |
475 | (export 'distinguished-point-shortest-paths) |
476 | (defun distinguished-point-shortest-paths (root neighbours-func) | |
477 | "Moderately efficient shortest-paths-from-root computation. | |
478 | ||
479 | The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC | |
480 | accepts a VERTEX as its only argument, and returns a list of conses (V . | |
481 | C) for each of the VERTEX's neighbours, indicating that there is an edge | |
482 | from VERTEX to V, with cost C. | |
483 | ||
484 | The return value is a list of entries (COST . REV-PATH) for each vertex | |
485 | reachable from the ROOT; the COST is the total cost of the shortest path, | |
486 | and REV-PATH is the path from the ROOT, in reverse order -- so the first | |
487 | element is the vertex itself and the last element is the ROOT. | |
488 | ||
489 | The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to | |
490 | produce its output list. The computation as a whole takes O(N^2) time, | |
491 | where N is the number of vertices in the graph, assuming there is at most | |
492 | one edge between any pair of vertices." | |
493 | ||
494 | ;; This is a listish version of Dijkstra's shortest-path algorithm. It | |
495 | ;; could be made more efficient by using a fancy priority queue rather than | |
496 | ;; a linear search for finding the nearest live element (see below), but it | |
497 | ;; still runs pretty well. | |
498 | ||
499 | (let ((map (make-hash-table)) | |
500 | (dead nil) | |
501 | (live (list (list 0 root)))) | |
502 | (setf (gethash root map) (cons :live (car live))) | |
503 | (loop | |
504 | ;; The dead list contains a record, in output format (COST . PATH), for | |
505 | ;; each vertex whose shortest path has been finally decided. The live | |
506 | ;; list contains a record for the vertices of current interest, also in | |
507 | ;; output format; the COST for a live record shows the best cost for a | |
508 | ;; path using only dead vertices. | |
509 | ;; | |
510 | ;; Each time through here, we pull an item off the live list and | |
511 | ;; push it onto the dead list, so we do at most N iterations total. | |
512 | ||
513 | ;; If there are no more live items, then we're done; the remaining | |
514 | ;; vertices, if any, are unreachable from the ROOT. | |
515 | (when (null live) (return)) | |
516 | ||
517 | ;; Find the closest live vertex to the root. The linear scan through | |
518 | ;; the live list costs at most N time. | |
519 | (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live)) | |
520 | (best-cost (car best)) | |
521 | (best-path (cdr best)) | |
522 | (best-vertex (car best-path))) | |
523 | ||
524 | ;; Remove the chosen vertex from the LIVE list, and add the | |
525 | ;; appropriate record to the dead list. We must have the shortest | |
526 | ;; path to this vertex now: we have the shortest path using currently | |
527 | ;; dead vertices; any other path must use at least one live vertex, | |
528 | ;; and, by construction, the path through any such vertex must be | |
529 | ;; further than the path we already have. | |
530 | ;; | |
531 | ;; Removal from the live list uses a linear scan which costs N time. | |
532 | (setf live (delete best live)) | |
533 | (push best dead) | |
534 | (setf (car (gethash best-vertex map)) :dead) | |
535 | ||
536 | ;; Work through the chosen vertex's neighbours, adding each of them | |
537 | ;; to the live list if they're not already there. If a neighbour is | |
538 | ;; already live, and we find a shorter path to it through our chosen | |
539 | ;; vertex, then update the neighbour's record. | |
540 | ;; | |
541 | ;; The chosen vertex obviously has at most N neighbours. There's no | |
542 | ;; more looping in here, so performance is as claimed. | |
543 | (dolist (neigh (funcall neighbours-func best-vertex)) | |
544 | (let* ((neigh-vertex (car neigh)) | |
545 | (neigh-cost (+ best-cost (cdr neigh))) | |
546 | (neigh-record (gethash neigh-vertex map))) | |
547 | (cond ((null neigh-record) | |
548 | ;; If the neighbour isn't known, then now's the time to | |
549 | ;; make a fresh live record for it. | |
550 | (let ((new-record (list* :live neigh-cost | |
551 | neigh-vertex best-path))) | |
552 | (push (cdr new-record) live) | |
553 | (setf (gethash neigh-vertex map) new-record))) | |
554 | ((and (eq (car neigh-record) :live) | |
555 | (< neigh-cost (cadr neigh-record))) | |
556 | ;; If the neighbour is live, and we've found a better path | |
557 | ;; to it, then update its record. | |
558 | (setf (cadr neigh-record) neigh-cost | |
559 | (cdddr neigh-record) best-path))))))) | |
560 | dead)) | |
561 | ||
38b78e87 MW |
562 | (export '(inconsistent-merge-error |
563 | merge-error-candidates merge-error-present-function)) | |
dea4d055 MW |
564 | (define-condition inconsistent-merge-error (error) |
565 | ((candidates :initarg :candidates | |
38b78e87 MW |
566 | :reader merge-error-candidates) |
567 | (present :initarg :present :initform #'identity | |
568 | :reader merge-error-present-function)) | |
dea4d055 | 569 | (:documentation |
9fb4a980 | 570 | "Reports an inconsistency in the arguments passed to `merge-lists'.") |
dea4d055 | 571 | (:report (lambda (condition stream) |
e2838dc5 MW |
572 | (format stream "Merge inconsistency: failed to decide between ~ |
573 | ~{~#[~;~A~;~A and ~A~:;~ | |
574 | ~@{~A, ~#[~;and ~A~]~}~]~}" | |
38b78e87 MW |
575 | (mapcar (merge-error-present-function condition) |
576 | (merge-error-candidates condition)))))) | |
dea4d055 MW |
577 | |
578 | (export 'merge-lists) | |
e2838dc5 | 579 | (defun merge-lists (lists &key pick (test #'eql) (present #'identity)) |
dea4d055 MW |
580 | "Return a merge of the given LISTS. |
581 | ||
e8c5a09e | 582 | The resulting list contains the items of the given LISTS, with duplicates |
dea4d055 MW |
583 | removed. The order of the resulting list is consistent with the orders of |
584 | the input LISTS in the sense that if A precedes B in some input list then | |
585 | A will also precede B in the output list. If the lists aren't consistent | |
586 | (e.g., some list contains A followed by B, and another contains B followed | |
e2838dc5 MW |
587 | by A) then an error of type `inconsistent-merge-error' is signalled. The |
588 | offending items are filtered for presentation through the PRESENT function | |
589 | before being attached to the condition, so as to produce a more useful | |
590 | diagnostic message. | |
dea4d055 MW |
591 | |
592 | Item equality is determined by TEST. | |
593 | ||
594 | If there is an ambiguity at any point -- i.e., a choice between two or | |
595 | more possible next items to emit -- then PICK is called to arbitrate. | |
596 | PICK is called with two arguments: the list of candidate next items, and | |
e8c5a09e MW |
597 | the current output list. It should return one of the candidate items. |
598 | The order of the candidates in the list given to the PICK function | |
599 | reflects their order in the input LISTS: item A will precede item B in the | |
600 | candidates list if and only if an occurrence of A appears in an earlier | |
601 | input list than any occurrence of item B. (This completely determines the | |
602 | order of the candidates: it is not possible that two candidates appear in | |
c5ef873a MW |
603 | the same input list, since that would resolve the ambiguity between them.) |
604 | If PICK is omitted then the item chosen is the one appearing in the | |
605 | earliest of the input lists: i.e., effectively, the default PICK function | |
606 | is | |
e8c5a09e MW |
607 | |
608 | (lambda (candidates output-so-far) | |
609 | (declare (ignore output-so-far)) | |
610 | (car candidates)) | |
dea4d055 MW |
611 | |
612 | The primary use of this function is in computing class precedence lists. | |
613 | By building the input lists and selecting the PICK function appropriately, | |
614 | a variety of different CPL algorithms can be implemented." | |
615 | ||
022a3499 MW |
616 | (do ((lb (make-list-builder))) |
617 | ((null lists) (lbuild-list lb)) | |
dea4d055 MW |
618 | |
619 | ;; The candidate items are the ones at the front of the input lists. | |
620 | ;; Gather them up, removing duplicates. If a candidate is somewhere in | |
621 | ;; one of the other lists other than at the front then we reject it. If | |
622 | ;; we've just rejected everything, then we can make no more progress and | |
623 | ;; the input lists were inconsistent. | |
e8c5a09e MW |
624 | (let* ((candidates (delete-duplicates (mapcar #'car lists) |
625 | :test test :from-end t)) | |
dea4d055 MW |
626 | (leasts (remove-if (lambda (item) |
627 | (some (lambda (list) | |
628 | (member item (cdr list) :test test)) | |
629 | lists)) | |
630 | candidates)) | |
631 | (winner (cond ((null leasts) | |
632 | (error 'inconsistent-merge-error | |
38b78e87 MW |
633 | :candidates candidates |
634 | :present present)) | |
dea4d055 MW |
635 | ((null (cdr leasts)) |
636 | (car leasts)) | |
637 | (pick | |
638 | (funcall pick leasts (lbuild-list lb))) | |
639 | (t (car leasts))))) | |
640 | ||
641 | ;; Check that the PICK function isn't conning us. | |
642 | (assert (member winner leasts :test test)) | |
643 | ||
644 | ;; Update the output list and remove the winning item from the input | |
645 | ;; lists. We know that it must be at the front of each input list | |
646 | ;; containing it. At this point, we discard input lists entirely when | |
647 | ;; they run out of entries. The loop ends when there are no more input | |
648 | ;; lists left, i.e., when we've munched all of the input items. | |
649 | (lbuild-add lb winner) | |
650 | (setf lists (delete nil (mapcar (lambda (list) | |
651 | (if (funcall test winner (car list)) | |
652 | (cdr list) | |
653 | list)) | |
654 | lists)))))) | |
655 | ||
656 | (export 'categorize) | |
657 | (defmacro categorize ((itemvar items &key bind) categories &body body) | |
658 | "Categorize ITEMS into lists and invoke BODY. | |
659 | ||
660 | The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR | |
661 | will contain the current item. The BIND argument is a list of LET*-like | |
662 | clauses. The CATEGORIES are a list of clauses of the form (SYMBOL | |
663 | PREDICATE). | |
664 | ||
665 | The behaviour of the macro is as follows. ITEMVAR is assigned (not | |
666 | bound), in turn, each item in the list ITEMS. The PREDICATEs in the | |
667 | CATEGORIES list are evaluated in turn, in an environment containing | |
668 | ITEMVAR and the BINDings, until one of them evaluates to a non-nil value. | |
669 | At this point, the item is assigned to the category named by the | |
670 | corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an | |
671 | error is signalled; a PREDICATE consisting only of T will (of course) | |
672 | match anything; it is detected specially so as to avoid compiler warnings. | |
673 | ||
674 | Once all of the ITEMS have been categorized in this fashion, the BODY is | |
675 | evaluated as an implicit PROGN. For each SYMBOL naming a category, a | |
676 | variable named after that symbol will be bound in the BODY's environment | |
677 | to a list of the items in that category, in the same order in which they | |
678 | were found in the list ITEMS. The final values of the macro are the final | |
679 | values of the BODY." | |
680 | ||
681 | (let* ((cat-names (mapcar #'car categories)) | |
682 | (cat-match-forms (mapcar #'cadr categories)) | |
683 | (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string | |
684 | (symbol-name name) "-"))) | |
685 | cat-names)) | |
686 | (items-var (gensym "ITEMS-"))) | |
64a7e651 MW |
687 | `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) |
688 | (let ((,items-var ,items)) | |
689 | (dolist (,itemvar ,items-var) | |
690 | (let* ,bind | |
691 | (cond ,@(mapcar (lambda (cat-match-form cat-var) | |
692 | `(,cat-match-form | |
693 | (push ,itemvar ,cat-var))) | |
694 | cat-match-forms cat-vars) | |
695 | ,@(and (not (member t cat-match-forms)) | |
696 | `((t (error "Failed to categorize ~A" | |
697 | ,itemvar)))))))) | |
dea4d055 MW |
698 | (let ,(mapcar (lambda (name var) |
699 | `(,name (nreverse ,var))) | |
700 | cat-names cat-vars) | |
701 | ,@body)))) | |
702 | ||
42291726 MW |
703 | (export 'partial-order-minima) |
704 | (defun partial-order-minima (items order) | |
705 | "Return a list of minimal items according to the non-strict partial ORDER. | |
706 | ||
707 | The ORDER function describes the partial order: (funcall ORDER X Y) should | |
708 | return true if X precedes or is equal to Y in the order." | |
709 | (reduce (lambda (tops this) | |
710 | (let ((new nil) (keep t)) | |
711 | (dolist (top tops) | |
712 | (cond ((funcall order top this) | |
713 | (setf keep nil) | |
714 | (push top new)) | |
715 | ((not (funcall order this top)) | |
716 | (push top new)))) | |
717 | (nreverse (if keep (cons this new) new)))) | |
718 | items | |
719 | :initial-value nil)) | |
720 | ||
64cbfb65 MW |
721 | (export 'find-duplicates) |
722 | (defun find-duplicates (report sequence &key (key #'identity) (test #'eql)) | |
723 | "Call REPORT on each pair of duplicate items in SEQUENCE. | |
724 | ||
725 | Duplicates are determined according to the KEY and TEST funcitons." | |
726 | (when (symbolp test) (setf test (symbol-function test))) | |
727 | (cond ((zerop (length sequence)) nil) | |
728 | ((or (eq test #'eq) | |
729 | (eq test #'eql) | |
730 | (eq test #'equal) | |
731 | (eq test #'equalp)) | |
732 | (let ((seen (make-hash-table :test test))) | |
733 | (map nil (lambda (item) | |
734 | (let ((k (funcall key item))) | |
735 | (multiple-value-bind (previous matchp) | |
736 | (gethash k seen) | |
737 | (if matchp (funcall report item previous) | |
738 | (setf (gethash k seen) item))))) | |
739 | sequence))) | |
740 | ((listp sequence) | |
9a3cb461 MW |
741 | (do ((tail sequence (cdr tail)) |
742 | (i 0 (1+ i))) | |
743 | ((endp tail)) | |
744 | (let* ((item (car tail)) | |
745 | (match (find (funcall key item) sequence | |
746 | :test test :key key :end i))) | |
747 | (when match (funcall report item match))))) | |
64cbfb65 MW |
748 | ((vectorp sequence) |
749 | (dotimes (i (length sequence)) | |
750 | (let* ((item (aref sequence i)) | |
751 | (pos (position (funcall key item) sequence | |
9a3cb461 | 752 | :key key :test test :end i))) |
64cbfb65 MW |
753 | (when pos (funcall report item (aref sequence pos)))))) |
754 | (t | |
755 | (error 'type-error :datum sequence :expected-type 'sequence)))) | |
756 | ||
dea4d055 MW |
757 | ;;;-------------------------------------------------------------------------- |
758 | ;;; Strings and characters. | |
759 | ||
760 | (export 'frob-identifier) | |
761 | (defun frob-identifier (string &key (swap-case t) (swap-hyphen t)) | |
762 | "Twiddles the case of STRING. | |
763 | ||
764 | If all the letters in STRING are uppercase, and SWAP-CASE is true, then | |
765 | switch them to lowercase; if they're all lowercase then switch them to | |
766 | uppercase. If there's a mix then leave them all alone. At the same time, | |
767 | if there are underscores but no hyphens, and SWAP-HYPHEN is true, then | |
768 | switch them to hyphens, if there are hyphens and no underscores, switch | |
769 | them underscores, and if there are both then leave them alone. | |
770 | ||
771 | This is an invertible transformation, which turns vaguely plausible Lisp | |
772 | names into vaguely plausible C names and vice versa. Lisp names with | |
773 | `funny characters' like stars and percent signs won't be any use, of | |
774 | course." | |
775 | ||
776 | ;; Work out what kind of a job we've got to do. Gather flags: bit 0 means | |
777 | ;; there are upper-case letters; bit 1 means there are lower-case letters; | |
778 | ;; bit 2 means there are hyphens; bit 3 means there are underscores. | |
779 | ;; | |
780 | ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set | |
781 | ;; if we have to frob case; bit 3 is set if we have to swap hyphens and | |
782 | ;; underscores. So use this to select functions which do bits of the | |
783 | ;; mapping, and then compose them together. | |
784 | (let* ((flags (reduce (lambda (state ch) | |
785 | (logior state | |
786 | (cond ((upper-case-p ch) 1) | |
787 | ((lower-case-p ch) 2) | |
788 | ((char= ch #\-) 4) | |
789 | ((char= ch #\_) 8) | |
790 | (t 0)))) | |
791 | string | |
792 | :initial-value 0)) | |
793 | (mask (logxor flags (ash flags 1))) | |
794 | (letter (cond ((or (not swap-case) (not (logbitp 1 mask))) | |
795 | (constantly nil)) | |
796 | ((logbitp 0 flags) | |
797 | (lambda (ch) | |
798 | (and (alpha-char-p ch) (char-downcase ch)))) | |
799 | (t | |
800 | (lambda (ch) | |
801 | (and (alpha-char-p ch) (char-upcase ch)))))) | |
802 | (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen)) | |
803 | (constantly nil)) | |
804 | ((logbitp 2 flags) | |
805 | (lambda (ch) (and (char= ch #\-) #\_))) | |
806 | (t | |
807 | (lambda (ch) (and (char= ch #\_) #\-)))))) | |
808 | ||
809 | (if (logbitp 3 (logior mask (ash mask 2))) | |
810 | (map 'string (lambda (ch) | |
811 | (or (funcall letter ch) | |
812 | (funcall uscore-hyphen ch) | |
813 | ch)) | |
814 | string) | |
815 | string))) | |
816 | ||
817 | (export 'whitespace-char-p) | |
818 | (declaim (inline whitespace-char-p)) | |
819 | (defun whitespace-char-p (char) | |
820 | "Returns whether CHAR is a whitespace character. | |
821 | ||
822 | Whitespaceness is determined relative to the compile-time readtable, which | |
823 | is probably good enough for most purposes." | |
824 | (case char | |
825 | (#.(loop for i below char-code-limit | |
826 | for ch = (code-char i) | |
827 | unless (with-input-from-string (in (string ch)) | |
828 | (peek-char t in nil)) | |
829 | collect ch) t) | |
830 | (t nil))) | |
831 | ||
832 | (export 'update-position) | |
833 | (declaim (inline update-position)) | |
834 | (defun update-position (char line column) | |
835 | "Updates LINE and COLUMN appropriately for having read the character CHAR. | |
836 | ||
837 | Returns the new LINE and COLUMN numbers." | |
838 | (case char | |
839 | ((#\newline #\vt #\page) | |
840 | (values (1+ line) 0)) | |
841 | ((#\tab) | |
842 | (values line (logandc2 (+ column 8) 7))) | |
843 | (t | |
844 | (values line (1+ column))))) | |
845 | ||
846 | (export 'backtrack-position) | |
847 | (declaim (inline backtrack-position)) | |
848 | (defun backtrack-position (char line column) | |
849 | "Updates LINE and COLUMN appropriately for having unread CHAR. | |
850 | ||
851 | Well, actually an approximation for it; it will likely be wrong if the | |
852 | last character was a tab. But when the character is read again, it will | |
853 | be correct." | |
854 | ||
855 | ;; This isn't perfect: if the character doesn't actually match what was | |
856 | ;; really read then it might not actually be possible: for example, if we | |
857 | ;; push back a newline while in the middle of a line, or a tab while not at | |
858 | ;; a tab stop. In that case, we'll just lose, but hopefully not too badly. | |
859 | (case char | |
860 | ||
861 | ;; In the absence of better ideas, I'll set the column number to zero. | |
862 | ;; This is almost certainly wrong, but with a little luck nobody will ask | |
863 | ;; and it'll be all right soon. | |
864 | ((#\newline #\vt #\page) (values (1- line) 0)) | |
865 | ||
866 | ;; Winding back a single space is sufficient. If the position is | |
867 | ;; currently on a tab stop then it'll advance back here next time. If | |
868 | ;; not, we're going to lose anyway because the previous character | |
869 | ;; certainly couldn't have been a tab. | |
870 | (#\tab (values line (1- column))) | |
871 | ||
872 | ;; Anything else: just decrement the column and cross fingers. | |
873 | (t (values line (1- column))))) | |
874 | ||
875 | ;;;-------------------------------------------------------------------------- | |
876 | ;;; Functions. | |
877 | ||
878 | (export 'compose) | |
b0d4e74f | 879 | (defun compose (&rest functions) |
dea4d055 MW |
880 | "Composition of functions. Functions are applied left-to-right. |
881 | ||
882 | This is the reverse order of the usual mathematical notation, but I find | |
bf090e02 MW |
883 | it easier to read. It's also slightly easier to work with in programs. |
884 | That is, (compose F1 F2 ... Fn) is what a category theorist might write as | |
885 | F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn." | |
886 | ||
dea4d055 MW |
887 | (labels ((compose1 (func-a func-b) |
888 | (lambda (&rest args) | |
889 | (multiple-value-call func-b (apply func-a args))))) | |
b0d4e74f MW |
890 | (if (null functions) #'values |
891 | (reduce #'compose1 (cdr functions) | |
892 | :initial-value (car functions))))) | |
dea4d055 MW |
893 | |
894 | ;;;-------------------------------------------------------------------------- | |
c34b237d MW |
895 | ;;; Variables. |
896 | ||
897 | (export 'defvar-unbound) | |
898 | (defmacro defvar-unbound (var doc) | |
899 | "Make VAR a special variable with documentation DOC, but leave it unbound." | |
900 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
901 | (defvar ,var) | |
902 | (setf (documentation ',var 'variable) ',doc) | |
903 | ',var)) | |
904 | ||
905 | ;;;-------------------------------------------------------------------------- | |
dea4d055 MW |
906 | ;;; Symbols. |
907 | ||
908 | (export 'symbolicate) | |
909 | (defun symbolicate (&rest symbols) | |
910 | "Return a symbol named after the concatenation of the names of the SYMBOLS. | |
911 | ||
3109662a | 912 | The symbol is interned in the current `*package*'. Trad." |
dea4d055 MW |
913 | (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) |
914 | ||
915 | ;;;-------------------------------------------------------------------------- | |
916 | ;;; Object printing. | |
917 | ||
918 | (export 'maybe-print-unreadable-object) | |
919 | (defmacro maybe-print-unreadable-object | |
920 | ((object stream &rest args) &body body) | |
921 | "Print helper for usually-unreadable objects. | |
922 | ||
3109662a | 923 | If `*print-escape*' is set then print OBJECT unreadably using BODY. |
dea4d055 MW |
924 | Otherwise just print using BODY." |
925 | (with-gensyms (print) | |
926 | `(flet ((,print () ,@body)) | |
927 | (if *print-escape* | |
928 | (print-unreadable-object (,object ,stream ,@args) | |
929 | (,print)) | |
930 | (,print))))) | |
931 | ||
08b6e064 MW |
932 | (export 'print-ugly-stuff) |
933 | (defun print-ugly-stuff (stream func) | |
934 | "Print not-pretty things to the stream underlying STREAM. | |
935 | ||
936 | The Lisp pretty-printing machinery, notably `pprint-logical-block', may | |
937 | interpose additional streams between its body and the original target | |
938 | stream. This makes it difficult to make use of the underlying stream's | |
939 | special features, whatever they might be." | |
940 | ||
941 | ;; This is unpleasant. Hacky hacky. | |
942 | #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream) | |
943 | (let ((target (sb-pretty::pretty-stream-target stream))) | |
944 | (pprint-newline :mandatory stream) | |
945 | (funcall func target)) | |
946 | (funcall func stream)) | |
947 | #+cmu '(if (typep stream 'pp:pretty-stream) | |
948 | (let ((target (pp::pretty-stream-target stream))) | |
949 | (pprint-newline :mandatory stream) | |
950 | (funcall func target)) | |
951 | (funcall func stream)) | |
952 | '(funcall func stream))) | |
953 | ||
dea4d055 MW |
954 | ;;;-------------------------------------------------------------------------- |
955 | ;;; Iteration macros. | |
956 | ||
957 | (export 'dosequence) | |
958 | (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) | |
959 | &body body | |
960 | &environment env) | |
961 | "Macro for iterating over general sequences. | |
962 | ||
963 | Iterates over a (sub)sequence SEQ, delimited by START and END (which are | |
964 | evaluated). For each item of SEQ, BODY is invoked with VAR bound to the | |
965 | item, and INDEXVAR (if requested) bound to the item's index. (Note that | |
966 | this is different from most iteration constructs in Common Lisp, which | |
967 | work by mutating the variable.) | |
968 | ||
969 | The loop is surrounded by an anonymous BLOCK and the loop body forms an | |
970 | implicit TAGBODY, as is usual. There is no result-form, however." | |
971 | ||
bacaaec3 MW |
972 | (once-only (:environment env start end) |
973 | (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-") | |
974 | (endvar "END-") (bodyfunc "BODY-")) | |
b8c698ee MW |
975 | (multiple-value-bind (docs decls body) (parse-body body :docp nil) |
976 | (declare (ignore docs)) | |
977 | ||
978 | (flet ((loopguts (indexp listp endvar) | |
979 | ;; Build a DO-loop to do what we want. | |
980 | (let* ((do-vars nil) | |
981 | (end-condition (if endvar | |
982 | `(>= ,ivar ,endvar) | |
bacaaec3 | 983 | `(endp ,seqvar))) |
b8c698ee | 984 | (item (if listp |
bacaaec3 MW |
985 | `(car ,seqvar) |
986 | `(aref ,seqvar ,ivar))) | |
b8c698ee MW |
987 | (body-call `(,bodyfunc ,item))) |
988 | (when listp | |
bacaaec3 | 989 | (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar)) |
b8c698ee MW |
990 | do-vars)) |
991 | (when indexp | |
992 | (push `(,ivar ,start (1+ ,ivar)) do-vars)) | |
993 | (when indexvar | |
994 | (setf body-call (append body-call (list ivar)))) | |
995 | `(do ,do-vars (,end-condition) ,body-call)))) | |
996 | ||
997 | `(block nil | |
bacaaec3 MW |
998 | (let ((,seqvar ,seq)) |
999 | (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) | |
1000 | ,@decls | |
1001 | (tagbody ,@body))) | |
1002 | (etypecase ,seqvar | |
1003 | (vector | |
1004 | (let ((,endvar (or ,end (length ,seqvar)))) | |
1005 | ,(loopguts t nil endvar))) | |
1006 | (list | |
1007 | (if ,end | |
1008 | ,(loopguts t t end) | |
1009 | ,(loopguts indexvar t nil)))))))))))) | |
dea4d055 MW |
1010 | |
1011 | ;;;-------------------------------------------------------------------------- | |
4b8e5c03 MW |
1012 | ;;; Structure accessor hacks. |
1013 | ||
1014 | (export 'define-access-wrapper) | |
1015 | (defmacro define-access-wrapper (from to &key read-only) | |
1016 | "Make (FROM THING) work like (TO THING). | |
1017 | ||
1018 | If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like | |
1019 | (setf (TO THING) VALUE). | |
1020 | ||
1021 | This is mostly useful for structure slot accessors where the slot has to | |
1022 | be given an unpleasant name to avoid it being an external symbol." | |
1023 | `(progn | |
1024 | (declaim (inline ,from ,@(and (not read-only) `((setf ,from))))) | |
1025 | (defun ,from (object) | |
1026 | (,to object)) | |
1027 | ,@(and (not read-only) | |
1028 | `((defun (setf ,from) (value object) | |
1029 | (setf (,to object) value)))))) | |
1030 | ||
1031 | ;;;-------------------------------------------------------------------------- | |
db6c3279 MW |
1032 | ;;; Condition and error utilities. |
1033 | ||
1034 | (export 'designated-condition) | |
1035 | (defun designated-condition (default-type datum arguments | |
1036 | &key allow-pointless-arguments) | |
1037 | "Return the condition designated by DATUM and ARGUMENTS. | |
1038 | ||
1039 | DATUM and ARGUMENTS together are a `condition designator' of (some | |
1040 | supertype of) DEFAULT-TYPE; return the condition so designated." | |
1041 | (typecase datum | |
1042 | (condition | |
1043 | (unless (or allow-pointless-arguments (null arguments)) | |
1044 | (error "Argument list provided with specific condition")) | |
1045 | datum) | |
1046 | (symbol | |
1047 | (apply #'make-condition datum arguments)) | |
1048 | ((or string function) | |
1049 | (make-condition default-type | |
1050 | :format-control datum | |
1051 | :format-arguments arguments)) | |
1052 | (t | |
1053 | (error "Unexpected condition designator datum ~S" datum)))) | |
1054 | ||
f7b60deb MW |
1055 | (export 'simple-control-error) |
1056 | (define-condition simple-control-error (control-error simple-error) | |
1057 | ()) | |
1058 | ||
1059 | (export 'invoke-associated-restart) | |
1060 | (defun invoke-associated-restart (restart condition &rest arguments) | |
1061 | "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS. | |
1062 | ||
1063 | Find an active restart designated by RESTART; if CONDITION is not nil, | |
1064 | then restrict the search to restarts associated with CONDITION, and | |
1065 | restarts not associated with any condition. If no such restart is found | |
1066 | then signal an error of type `control-error'; otherwise invoke the restart | |
1067 | with the given ARGUMENTS." | |
1068 | (apply #'invoke-restart | |
1069 | (or (find-restart restart condition) | |
1070 | (error 'simple-control-error | |
1071 | :format-control "~:[Restart ~S is not active~;~ | |
1072 | No active `~(~A~)' restart~]~ | |
1073 | ~@[ for condition ~S~]" | |
1074 | :format-arguments (list (symbolp restart) | |
1075 | restart | |
1076 | condition))) | |
1077 | arguments)) | |
1078 | ||
c884ec24 MW |
1079 | (export '(enclosing-condition enclosed-condition)) |
1080 | (define-condition enclosing-condition (condition) | |
1081 | ((%enclosed-condition :initarg :condition :type condition | |
1082 | :reader enclosed-condition)) | |
1083 | (:documentation | |
1084 | "A condition which encloses another condition | |
1085 | ||
1086 | This is useful if one wants to attach additional information to an | |
1087 | existing condition. The enclosed condition can be obtained using the | |
1088 | `enclosed-condition' function.") | |
1089 | (:report (lambda (condition stream) | |
1090 | (princ (enclosed-condition condition) stream)))) | |
1091 | ||
1092 | (export 'information) | |
1093 | (define-condition information (condition) | |
1094 | ()) | |
1095 | ||
1096 | (export 'simple-information) | |
1097 | (define-condition simple-information (simple-condition information) | |
1098 | ()) | |
1099 | ||
1100 | (export 'info) | |
1101 | (defun info (datum &rest arguments) | |
1102 | "Report some useful diagnostic information. | |
1103 | ||
1104 | Establish a simple restart named `noted', and signal the condition of type | |
1105 | `information' designated by DATUM and ARGUMENTS. Return non-nil if the | |
1106 | restart was invoked, otherwise nil." | |
1107 | (restart-case | |
1108 | (signal (designated-condition 'simple-information datum arguments)) | |
1109 | (noted () :report "Noted." t))) | |
1110 | ||
1111 | (export 'noted) | |
1112 | (defun noted (&optional condition) | |
1113 | "Invoke the `noted' restart, possibly associated with the given CONDITION." | |
1114 | (invoke-associated-restart 'noted condition)) | |
1115 | ||
1116 | (export 'promiscuous-cerror) | |
1117 | (defun promiscuous-cerror (continue-string datum &rest arguments) | |
1118 | "Like standard `cerror', but robust against sneaky changes of conditions. | |
1119 | ||
1120 | It seems that `cerror' (well, at least the version in SBCL) is careful | |
1121 | to limit its restart to the specific condition it signalled. But that's | |
1122 | annoying, because `sod-parser:with-default-error-location' substitutes | |
1123 | different conditions carrying the error-location information." | |
1124 | (restart-case (apply #'error datum arguments) | |
1125 | (continue () | |
1126 | :report (lambda (stream) | |
1127 | (apply #'format stream continue-string datum arguments)) | |
1128 | nil))) | |
1129 | ||
1130 | (export 'cerror*) | |
1131 | (defun cerror* (datum &rest arguments) | |
1132 | (apply #'promiscuous-cerror "Continue" datum arguments)) | |
1133 | ||
db6c3279 | 1134 | ;;;-------------------------------------------------------------------------- |
dea4d055 MW |
1135 | ;;; CLOS hacking. |
1136 | ||
1137 | (export 'default-slot) | |
1138 | (defmacro default-slot ((instance slot &optional (slot-names t)) | |
1139 | &body value | |
1140 | &environment env) | |
1141 | "If INSTANCE's slot named SLOT is unbound, set it to VALUE. | |
1142 | ||
1143 | Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we | |
1144 | obey the `shared-initialize' protocol). SLOT-NAMES defaults to `t', so | |
1145 | you can use it in `initialize-instance' or similar without ill effects. | |
1146 | Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only | |
1147 | evaluated if it's needed." | |
1148 | ||
1149 | (once-only (:environment env instance slot slot-names) | |
1150 | `(when ,(if (eq slot-names t) | |
1151 | `(not (slot-boundp ,instance ,slot)) | |
1152 | `(and (not (slot-boundp ,instance ,slot)) | |
1153 | (or (eq ,slot-names t) | |
1154 | (member ,slot ,slot-names)))) | |
1155 | (setf (slot-value ,instance ,slot) | |
1156 | (progn ,@value))))) | |
1157 | ||
141283ff MW |
1158 | (export 'define-on-demand-slot) |
1159 | (defmacro define-on-demand-slot (class slot (instance) &body body) | |
1160 | "Defines a slot which computes its initial value on demand. | |
1161 | ||
1162 | Sets up the named SLOT of CLASS to establish its value as the implicit | |
1163 | progn BODY, by defining an appropriate method on `slot-unbound'." | |
b8c698ee MW |
1164 | (multiple-value-bind (docs decls body) (parse-body body) |
1165 | (with-gensyms (classvar slotvar) | |
1166 | `(defmethod slot-unbound | |
1167 | (,classvar (,instance ,class) (,slotvar (eql ',slot))) | |
1168 | ,@docs ,@decls | |
1169 | (declare (ignore ,classvar)) | |
fc09e191 | 1170 | (setf (slot-value ,instance ',slot) (block ,slot ,@body)))))) |
141283ff | 1171 | |
dea4d055 | 1172 | ;;;----- That's all, folks -------------------------------------------------- |