Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Various handy utilities | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Sensble Object Design, an object system for C. | |
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 | ||
26 | (cl:defpackage #:sod-utilities | |
27 | (:use #:common-lisp | |
28 | ||
29 | ;; MOP from somewhere. | |
30 | #+sbcl #:sb-mop | |
31 | #+(or cmu clisp) #:mop | |
32 | #+ecl #:clos)) | |
33 | ||
34 | (cl:in-package #:sod-utilities) | |
35 | ||
36 | ;;;-------------------------------------------------------------------------- | |
37 | ;;; Macro hacks. | |
38 | ||
39 | (export 'with-gensyms) | |
40 | (defmacro with-gensyms ((&rest binds) &body body) | |
41 | "Evaluate BODY with variables bound to fresh symbols. | |
42 | ||
43 | The BINDS are a list of entries (VAR [NAME]), and a singleton list can be | |
44 | replaced by just a symbol; each VAR is bound to a fresh symbol generated | |
45 | by (gensym NAME), where NAME defaults to the symbol-name of VAR." | |
46 | `(let (,@(mapcar (lambda (bind) | |
47 | (multiple-value-bind (var name) | |
48 | (if (atom bind) | |
49 | (values bind (concatenate 'string | |
50 | (symbol-name bind) "-")) | |
51 | (destructuring-bind | |
52 | (var &optional | |
53 | (name (concatenate 'string | |
54 | (symbol-name var) "-"))) | |
55 | bind | |
56 | (values var name))) | |
57 | `(,var (gensym ,name)))) | |
58 | binds)) | |
59 | ,@body)) | |
60 | ||
61 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
62 | (defun strip-quote (form) | |
63 | "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO. | |
64 | ||
65 | If FORM is a symbol whose constant value is `nil' then return `nil'. | |
66 | Otherwise return FORM unchanged. This makes it easier to inspect constant | |
67 | things. This is a utility for `once-only'." | |
68 | ||
69 | (cond ((and (consp form) | |
70 | (eq (car form) 'quote) | |
71 | (cdr form) | |
72 | (null (cddr form))) | |
73 | (let ((body (cadr form))) | |
74 | (if (or (not (or (consp body) (symbolp body))) | |
75 | (member body '(t nil)) | |
76 | (keywordp body)) | |
77 | body | |
78 | form))) | |
79 | ((and (symbolp form) (boundp form) (null (symbol-value form))) | |
80 | nil) | |
81 | (t | |
82 | form)))) | |
83 | ||
84 | (export 'once-only) | |
85 | (defmacro once-only (binds &body body) | |
86 | "Macro helper for preventing repeated evaluation. | |
87 | ||
88 | The syntax is actually hairier than shown: | |
89 | ||
90 | once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* ) | |
91 | { FORM }* | |
92 | ||
93 | So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list | |
94 | can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR. | |
95 | But before them you can have keyword arguments. Only one is defined so | |
96 | far. See below for the crazy things that does. | |
97 | ||
98 | The result of evaluating a ONCE-ONLY form is a form with the structure | |
99 | ||
100 | (let ((#:GS1 VALUE-FORM1) | |
101 | ... | |
102 | (#:GSn VALUE-FORMn)) | |
103 | STUFF) | |
104 | ||
105 | where STUFF is the value of the BODY forms, as an implicit progn, in an | |
106 | environment with the VARs bound to the corresponding gensyms. | |
107 | ||
108 | As additional magic, if any of the VALUE-FORMs is actually constant (as | |
109 | determined by inspection, and aided by `constantp' if an :environment is | |
110 | supplied, then no gensym is constructed for it, and the VAR is bound | |
111 | directly to the constant form. Moreover, if the constant form looks like | |
112 | (quote FOO) for a self-evaluating FOO then the outer layer of quoting is | |
113 | stripped away." | |
114 | ||
115 | ;; We need an extra layer of gensyms in our expansion: we'll want the | |
116 | ;; expansion to examine the various VALUE-FORMs to find out whether they're | |
117 | ;; constant without evaluating them repeatedly. This also helps with | |
118 | ;; another problem: we explicitly encourage the rebinding of a VAR | |
119 | ;; (probably a macro argument) to a gensym which will be bound to the value | |
120 | ;; of the form previously held in VAR itself -- so the gensym and value | |
121 | ;; form must exist at the same time and we need two distinct variables. | |
122 | ||
123 | (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-")) | |
124 | (let ((env nil)) | |
125 | ||
126 | ;; First things first: let's pick up the keywords. | |
127 | (loop | |
128 | (unless (and binds (keywordp (car binds))) | |
129 | (return)) | |
130 | (ecase (pop binds) | |
131 | (:environment (setf env (pop binds))))) | |
132 | ||
133 | ;; Now we'll investigate the bindings. Turn each one into a list (VAR | |
134 | ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note | |
135 | ;; above. | |
136 | (let ((canon (mapcar (lambda (bind) | |
137 | (multiple-value-bind (var form) | |
138 | (if (atom bind) | |
139 | (values bind bind) | |
140 | (destructuring-bind | |
141 | (var &optional (form var)) bind | |
142 | (values var form))) | |
143 | (list var form | |
144 | (gensym (format nil "T-~A-" | |
145 | (symbol-name var)))))) | |
146 | binds))) | |
147 | ||
148 | `(let* (,@(and env `((,envvar ,env))) | |
149 | (,lets nil) | |
150 | ,@(mapcar (lambda (bind) | |
151 | (destructuring-bind (var form temp) bind | |
152 | (declare (ignore var)) | |
153 | `(,temp ,form))) | |
154 | canon) | |
155 | ,@(mapcar (lambda (bind) | |
156 | (destructuring-bind (var form temp) bind | |
157 | (declare (ignore form)) | |
158 | `(,var | |
159 | (cond ((constantp ,temp | |
160 | ,@(and env `(,envvar))) | |
161 | (strip-quote ,temp)) | |
162 | ((symbolp ,temp) | |
163 | ,temp) | |
164 | (t | |
165 | (let ((,sym (gensym | |
166 | ,(concatenate 'string | |
167 | (symbol-name var) | |
168 | "-")))) | |
169 | (push (list ,sym ,temp) ,lets) | |
170 | ,sym)))))) | |
171 | canon)) | |
172 | (flet ((,bodyfunc () ,@body)) | |
173 | (if ,lets | |
174 | `(let (,@(nreverse ,lets)) ,(,bodyfunc)) | |
175 | (,bodyfunc)))))))) | |
176 | ||
177 | (export 'parse-body) | |
178 | (defun parse-body (body) | |
179 | "Parse the BODY into a docstring, declarations and the body forms. | |
180 | ||
181 | These are returned as three lists, so that they can be spliced into a | |
182 | macro expansion easily. The declarations are consolidated into a single | |
183 | `declare' form." | |
184 | (let ((decls nil) | |
185 | (doc nil)) | |
186 | (loop | |
187 | (cond ((null body) (return)) | |
188 | ((and (consp (car body)) (eq (caar body) 'declare)) | |
189 | (setf decls (append decls (cdr (pop body))))) | |
190 | ((and (stringp (car body)) (not doc) (cdr body)) | |
191 | (setf doc (pop body))) | |
192 | (t (return)))) | |
193 | (values (and doc (list doc)) | |
194 | (and decls (list (cons 'declare decls))) | |
195 | body))) | |
196 | ||
197 | ;;;-------------------------------------------------------------------------- | |
198 | ;;; Anaphorics. | |
199 | ||
200 | (export 'it) | |
201 | ||
202 | (export 'aif) | |
203 | (defmacro aif (cond cons &optional (alt nil altp)) | |
204 | "If COND is not nil, evaluate CONS with `it' bound to the value of COND. | |
205 | ||
206 | Otherwise, if given, evaluate ALT; `it' isn't bound in ALT." | |
207 | (once-only (cond) | |
208 | `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt))))) | |
209 | ||
210 | (export 'awhen) | |
211 | (defmacro awhen (cond &body body) | |
212 | "If COND, evaluate BODY as a progn with `it' bound to the value of COND." | |
213 | `(let ((it ,cond)) (when it ,@body))) | |
214 | ||
215 | (export 'acond) | |
bf090e02 | 216 | (defmacro acond (&body clauses &environment env) |
dea4d055 MW |
217 | "Like COND, but with `it' bound to the value of the condition. |
218 | ||
219 | Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is | |
220 | non-nil then evaluate the FORMs with `it' bound to the non-nil value, and | |
221 | return the value of the last FORM; if there are no FORMs, then return `it' | |
222 | itself. If the CONDITION is nil then continue with the next clause; if | |
223 | all clauses evaluate to nil then the result is nil." | |
224 | (labels ((walk (clauses) | |
225 | (if (null clauses) | |
226 | `nil | |
227 | (once-only (:environment env (cond (caar clauses))) | |
228 | (if (and (constantp cond) | |
229 | (if (and (consp cond) (eq (car cond) 'quote)) | |
230 | (cadr cond) cond)) | |
231 | (if (cdar clauses) | |
232 | `(let ((it ,cond)) | |
233 | (declare (ignorable it)) | |
234 | ,@(cdar clauses)) | |
235 | cond) | |
236 | `(if ,cond | |
237 | ,(if (cdar clauses) | |
238 | `(let ((it ,cond)) | |
239 | (declare (ignorable it)) | |
240 | ,@(cdar clauses)) | |
241 | cond) | |
242 | ,(walk (cdr clauses)))))))) | |
243 | (walk clauses))) | |
244 | ||
245 | (export '(acase aecase atypecase aetypecase)) | |
246 | (defmacro acase (value &body clauses) | |
247 | `(let ((it ,value)) (case it ,@clauses))) | |
248 | (defmacro aecase (value &body clauses) | |
249 | `(let ((it ,value)) (ecase it ,@clauses))) | |
250 | (defmacro atypecase (value &body clauses) | |
251 | `(let ((it ,value)) (typecase it ,@clauses))) | |
252 | (defmacro aetypecase (value &body clauses) | |
253 | `(let ((it ,value)) (etypecase it ,@clauses))) | |
254 | ||
255 | (export 'asetf) | |
256 | (defmacro asetf (&rest places-and-values &environment env) | |
257 | "Anaphoric update of places. | |
258 | ||
259 | The PLACES-AND-VALUES are alternating PLACEs and VALUEs. Each VALUE is | |
260 | evaluated with IT bound to the current value stored in the corresponding | |
261 | PLACE." | |
262 | `(progn ,@(loop for (place value) on places-and-values by #'cddr | |
263 | collect (multiple-value-bind | |
264 | (temps inits newtemps setform getform) | |
265 | (get-setf-expansion place env) | |
266 | `(let* (,@(mapcar #'list temps inits) | |
267 | (it ,getform)) | |
268 | (multiple-value-bind ,newtemps ,value | |
269 | ,setform)))))) | |
270 | ||
271 | ;;;-------------------------------------------------------------------------- | |
272 | ;;; MOP hacks (not terribly demanding). | |
273 | ||
bf090e02 MW |
274 | (export 'instance-initargs) |
275 | (defgeneric instance-initargs (instance) | |
276 | (:documentation | |
277 | "Return a plausble list of initargs for INSTANCE. | |
278 | ||
279 | The idea is that you can make a copy of INSTANCE by invoking | |
280 | ||
281 | (apply #'make-instance (class-of INSTANCE) | |
282 | (instance-initargs INSTANCE)) | |
283 | ||
284 | The default implementation works by inspecting the slot definitions and | |
285 | extracting suitable initargs, so this will only succeed if enough slots | |
286 | actually have initargs specified that `initialize-instance' can fill in | |
287 | the rest correctly. | |
288 | ||
289 | The list returned is freshly consed, and you can destroy it if you like.") | |
290 | (:method ((instance standard-object)) | |
291 | (mapcan (lambda (slot) | |
292 | (aif (slot-definition-initargs slot) | |
293 | (list (car it) | |
294 | (slot-value instance (slot-definition-name slot))) | |
295 | nil)) | |
296 | (class-slots (class-of instance))))) | |
297 | ||
dea4d055 MW |
298 | (export '(copy-instance copy-instance-using-class)) |
299 | (defgeneric copy-instance-using-class (class instance &rest initargs) | |
300 | (:documentation | |
301 | "Metaobject protocol hook for `copy-instance'.") | |
302 | (:method ((class standard-class) instance &rest initargs) | |
303 | (let ((copy (allocate-instance class))) | |
304 | (dolist (slot (class-slots class)) | |
305 | (let ((name (slot-definition-name slot))) | |
306 | (when (slot-boundp instance name) | |
307 | (setf (slot-value copy name) (slot-value instance name))))) | |
308 | (apply #'shared-initialize copy nil initargs)))) | |
309 | (defun copy-instance (object &rest initargs) | |
310 | "Construct and return a copy of OBJECT. | |
311 | ||
312 | The new object has the same class as OBJECT, and the same slot values | |
313 | except where overridden by INITARGS." | |
314 | (apply #'copy-instance-using-class (class-of object) object initargs)) | |
315 | ||
316 | ;;;-------------------------------------------------------------------------- | |
317 | ;;; List utilities. | |
318 | ||
319 | (export 'make-list-builder) | |
320 | (defun make-list-builder (&optional initial) | |
321 | "Return a simple list builder." | |
322 | ||
323 | ;; The `builder' is just a cons cell whose cdr will be the list that's | |
324 | ;; wanted. Effectively, then, we have a list that's one item longer than | |
325 | ;; we actually want. The car of this extra initial cons cell is always the | |
326 | ;; last cons in the list -- which is now well defined because there's | |
327 | ;; always at least one. | |
328 | ||
329 | (let ((builder (cons nil initial))) | |
330 | (setf (car builder) (last builder)) | |
331 | builder)) | |
332 | ||
333 | (export 'lbuild-add) | |
334 | (defun lbuild-add (builder item) | |
335 | "Add an ITEM to the end of a list BUILDER." | |
336 | (let ((new (cons item nil))) | |
337 | (setf (cdar builder) new | |
338 | (car builder) new)) | |
339 | builder) | |
340 | ||
341 | (export 'lbuild-add-list) | |
342 | (defun lbuild-add-list (builder list) | |
343 | "Add a LIST to the end of a list BUILDER. The LIST will be clobbered." | |
344 | (when list | |
345 | (setf (cdar builder) list | |
346 | (car builder) (last list))) | |
347 | builder) | |
348 | ||
349 | (export 'lbuild-list) | |
350 | (defun lbuild-list (builder) | |
351 | "Return the constructed list." | |
352 | (cdr builder)) | |
353 | ||
354 | (export 'mappend) | |
355 | (defun mappend (function list &rest more-lists) | |
356 | "Like a nondestructive MAPCAN. | |
357 | ||
358 | Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, | |
359 | and return the result of appending all of the resulting lists." | |
360 | (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) | |
361 | ||
362 | (export '(inconsistent-merge-error merge-error-candidates)) | |
363 | (define-condition inconsistent-merge-error (error) | |
364 | ((candidates :initarg :candidates | |
365 | :reader merge-error-candidates)) | |
366 | (:documentation | |
367 | "Reports an inconsistency in the arguments passed to MERGE-LISTS.") | |
368 | (:report (lambda (condition stream) | |
369 | (format stream "Merge inconsistency: failed to decide among ~A." | |
370 | (merge-error-candidates condition))))) | |
371 | ||
372 | (export 'merge-lists) | |
373 | (defun merge-lists (lists &key pick (test #'eql)) | |
374 | "Return a merge of the given LISTS. | |
375 | ||
376 | The resulting LIST contains the items of the given lists, with duplicates | |
377 | removed. The order of the resulting list is consistent with the orders of | |
378 | the input LISTS in the sense that if A precedes B in some input list then | |
379 | A will also precede B in the output list. If the lists aren't consistent | |
380 | (e.g., some list contains A followed by B, and another contains B followed | |
3109662a | 381 | by A) then an error of type `inconsistent-merge-error' is signalled. |
dea4d055 MW |
382 | |
383 | Item equality is determined by TEST. | |
384 | ||
385 | If there is an ambiguity at any point -- i.e., a choice between two or | |
386 | more possible next items to emit -- then PICK is called to arbitrate. | |
387 | PICK is called with two arguments: the list of candidate next items, and | |
388 | the current output list. It should return one of the candidate items. If | |
389 | PICK is omitted then an arbitrary choice is made. | |
390 | ||
391 | The primary use of this function is in computing class precedence lists. | |
392 | By building the input lists and selecting the PICK function appropriately, | |
393 | a variety of different CPL algorithms can be implemented." | |
394 | ||
395 | (do* ((lb (make-list-builder))) | |
396 | ((null lists) (lbuild-list lb)) | |
397 | ||
398 | ;; The candidate items are the ones at the front of the input lists. | |
399 | ;; Gather them up, removing duplicates. If a candidate is somewhere in | |
400 | ;; one of the other lists other than at the front then we reject it. If | |
401 | ;; we've just rejected everything, then we can make no more progress and | |
402 | ;; the input lists were inconsistent. | |
403 | (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test)) | |
404 | (leasts (remove-if (lambda (item) | |
405 | (some (lambda (list) | |
406 | (member item (cdr list) :test test)) | |
407 | lists)) | |
408 | candidates)) | |
409 | (winner (cond ((null leasts) | |
410 | (error 'inconsistent-merge-error | |
411 | :candidates candidates)) | |
412 | ((null (cdr leasts)) | |
413 | (car leasts)) | |
414 | (pick | |
415 | (funcall pick leasts (lbuild-list lb))) | |
416 | (t (car leasts))))) | |
417 | ||
418 | ;; Check that the PICK function isn't conning us. | |
419 | (assert (member winner leasts :test test)) | |
420 | ||
421 | ;; Update the output list and remove the winning item from the input | |
422 | ;; lists. We know that it must be at the front of each input list | |
423 | ;; containing it. At this point, we discard input lists entirely when | |
424 | ;; they run out of entries. The loop ends when there are no more input | |
425 | ;; lists left, i.e., when we've munched all of the input items. | |
426 | (lbuild-add lb winner) | |
427 | (setf lists (delete nil (mapcar (lambda (list) | |
428 | (if (funcall test winner (car list)) | |
429 | (cdr list) | |
430 | list)) | |
431 | lists)))))) | |
432 | ||
433 | (export 'categorize) | |
434 | (defmacro categorize ((itemvar items &key bind) categories &body body) | |
435 | "Categorize ITEMS into lists and invoke BODY. | |
436 | ||
437 | The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR | |
438 | will contain the current item. The BIND argument is a list of LET*-like | |
439 | clauses. The CATEGORIES are a list of clauses of the form (SYMBOL | |
440 | PREDICATE). | |
441 | ||
442 | The behaviour of the macro is as follows. ITEMVAR is assigned (not | |
443 | bound), in turn, each item in the list ITEMS. The PREDICATEs in the | |
444 | CATEGORIES list are evaluated in turn, in an environment containing | |
445 | ITEMVAR and the BINDings, until one of them evaluates to a non-nil value. | |
446 | At this point, the item is assigned to the category named by the | |
447 | corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an | |
448 | error is signalled; a PREDICATE consisting only of T will (of course) | |
449 | match anything; it is detected specially so as to avoid compiler warnings. | |
450 | ||
451 | Once all of the ITEMS have been categorized in this fashion, the BODY is | |
452 | evaluated as an implicit PROGN. For each SYMBOL naming a category, a | |
453 | variable named after that symbol will be bound in the BODY's environment | |
454 | to a list of the items in that category, in the same order in which they | |
455 | were found in the list ITEMS. The final values of the macro are the final | |
456 | values of the BODY." | |
457 | ||
458 | (let* ((cat-names (mapcar #'car categories)) | |
459 | (cat-match-forms (mapcar #'cadr categories)) | |
460 | (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string | |
461 | (symbol-name name) "-"))) | |
462 | cat-names)) | |
463 | (items-var (gensym "ITEMS-"))) | |
464 | `(let ((,items-var ,items) | |
465 | ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) | |
466 | (dolist (,itemvar ,items-var) | |
467 | (let* ,bind | |
468 | (cond ,@(mapcar (lambda (cat-match-form cat-var) | |
469 | `(,cat-match-form | |
470 | (push ,itemvar ,cat-var))) | |
471 | cat-match-forms cat-vars) | |
472 | ,@(and (not (member t cat-match-forms)) | |
473 | `((t (error "Failed to categorize ~A" ,itemvar))))))) | |
474 | (let ,(mapcar (lambda (name var) | |
475 | `(,name (nreverse ,var))) | |
476 | cat-names cat-vars) | |
477 | ,@body)))) | |
478 | ||
479 | ;;;-------------------------------------------------------------------------- | |
480 | ;;; Strings and characters. | |
481 | ||
482 | (export 'frob-identifier) | |
483 | (defun frob-identifier (string &key (swap-case t) (swap-hyphen t)) | |
484 | "Twiddles the case of STRING. | |
485 | ||
486 | If all the letters in STRING are uppercase, and SWAP-CASE is true, then | |
487 | switch them to lowercase; if they're all lowercase then switch them to | |
488 | uppercase. If there's a mix then leave them all alone. At the same time, | |
489 | if there are underscores but no hyphens, and SWAP-HYPHEN is true, then | |
490 | switch them to hyphens, if there are hyphens and no underscores, switch | |
491 | them underscores, and if there are both then leave them alone. | |
492 | ||
493 | This is an invertible transformation, which turns vaguely plausible Lisp | |
494 | names into vaguely plausible C names and vice versa. Lisp names with | |
495 | `funny characters' like stars and percent signs won't be any use, of | |
496 | course." | |
497 | ||
498 | ;; Work out what kind of a job we've got to do. Gather flags: bit 0 means | |
499 | ;; there are upper-case letters; bit 1 means there are lower-case letters; | |
500 | ;; bit 2 means there are hyphens; bit 3 means there are underscores. | |
501 | ;; | |
502 | ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set | |
503 | ;; if we have to frob case; bit 3 is set if we have to swap hyphens and | |
504 | ;; underscores. So use this to select functions which do bits of the | |
505 | ;; mapping, and then compose them together. | |
506 | (let* ((flags (reduce (lambda (state ch) | |
507 | (logior state | |
508 | (cond ((upper-case-p ch) 1) | |
509 | ((lower-case-p ch) 2) | |
510 | ((char= ch #\-) 4) | |
511 | ((char= ch #\_) 8) | |
512 | (t 0)))) | |
513 | string | |
514 | :initial-value 0)) | |
515 | (mask (logxor flags (ash flags 1))) | |
516 | (letter (cond ((or (not swap-case) (not (logbitp 1 mask))) | |
517 | (constantly nil)) | |
518 | ((logbitp 0 flags) | |
519 | (lambda (ch) | |
520 | (and (alpha-char-p ch) (char-downcase ch)))) | |
521 | (t | |
522 | (lambda (ch) | |
523 | (and (alpha-char-p ch) (char-upcase ch)))))) | |
524 | (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen)) | |
525 | (constantly nil)) | |
526 | ((logbitp 2 flags) | |
527 | (lambda (ch) (and (char= ch #\-) #\_))) | |
528 | (t | |
529 | (lambda (ch) (and (char= ch #\_) #\-)))))) | |
530 | ||
531 | (if (logbitp 3 (logior mask (ash mask 2))) | |
532 | (map 'string (lambda (ch) | |
533 | (or (funcall letter ch) | |
534 | (funcall uscore-hyphen ch) | |
535 | ch)) | |
536 | string) | |
537 | string))) | |
538 | ||
539 | (export 'whitespace-char-p) | |
540 | (declaim (inline whitespace-char-p)) | |
541 | (defun whitespace-char-p (char) | |
542 | "Returns whether CHAR is a whitespace character. | |
543 | ||
544 | Whitespaceness is determined relative to the compile-time readtable, which | |
545 | is probably good enough for most purposes." | |
546 | (case char | |
547 | (#.(loop for i below char-code-limit | |
548 | for ch = (code-char i) | |
549 | unless (with-input-from-string (in (string ch)) | |
550 | (peek-char t in nil)) | |
551 | collect ch) t) | |
552 | (t nil))) | |
553 | ||
554 | (export 'update-position) | |
555 | (declaim (inline update-position)) | |
556 | (defun update-position (char line column) | |
557 | "Updates LINE and COLUMN appropriately for having read the character CHAR. | |
558 | ||
559 | Returns the new LINE and COLUMN numbers." | |
560 | (case char | |
561 | ((#\newline #\vt #\page) | |
562 | (values (1+ line) 0)) | |
563 | ((#\tab) | |
564 | (values line (logandc2 (+ column 8) 7))) | |
565 | (t | |
566 | (values line (1+ column))))) | |
567 | ||
568 | (export 'backtrack-position) | |
569 | (declaim (inline backtrack-position)) | |
570 | (defun backtrack-position (char line column) | |
571 | "Updates LINE and COLUMN appropriately for having unread CHAR. | |
572 | ||
573 | Well, actually an approximation for it; it will likely be wrong if the | |
574 | last character was a tab. But when the character is read again, it will | |
575 | be correct." | |
576 | ||
577 | ;; This isn't perfect: if the character doesn't actually match what was | |
578 | ;; really read then it might not actually be possible: for example, if we | |
579 | ;; push back a newline while in the middle of a line, or a tab while not at | |
580 | ;; a tab stop. In that case, we'll just lose, but hopefully not too badly. | |
581 | (case char | |
582 | ||
583 | ;; In the absence of better ideas, I'll set the column number to zero. | |
584 | ;; This is almost certainly wrong, but with a little luck nobody will ask | |
585 | ;; and it'll be all right soon. | |
586 | ((#\newline #\vt #\page) (values (1- line) 0)) | |
587 | ||
588 | ;; Winding back a single space is sufficient. If the position is | |
589 | ;; currently on a tab stop then it'll advance back here next time. If | |
590 | ;; not, we're going to lose anyway because the previous character | |
591 | ;; certainly couldn't have been a tab. | |
592 | (#\tab (values line (1- column))) | |
593 | ||
594 | ;; Anything else: just decrement the column and cross fingers. | |
595 | (t (values line (1- column))))) | |
596 | ||
597 | ;;;-------------------------------------------------------------------------- | |
598 | ;;; Functions. | |
599 | ||
600 | (export 'compose) | |
601 | (defun compose (function &rest more-functions) | |
602 | "Composition of functions. Functions are applied left-to-right. | |
603 | ||
604 | This is the reverse order of the usual mathematical notation, but I find | |
bf090e02 MW |
605 | it easier to read. It's also slightly easier to work with in programs. |
606 | That is, (compose F1 F2 ... Fn) is what a category theorist might write as | |
607 | F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn." | |
608 | ||
dea4d055 MW |
609 | (labels ((compose1 (func-a func-b) |
610 | (lambda (&rest args) | |
611 | (multiple-value-call func-b (apply func-a args))))) | |
612 | (reduce #'compose1 more-functions :initial-value function))) | |
613 | ||
614 | ;;;-------------------------------------------------------------------------- | |
615 | ;;; Symbols. | |
616 | ||
617 | (export 'symbolicate) | |
618 | (defun symbolicate (&rest symbols) | |
619 | "Return a symbol named after the concatenation of the names of the SYMBOLS. | |
620 | ||
3109662a | 621 | The symbol is interned in the current `*package*'. Trad." |
dea4d055 MW |
622 | (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) |
623 | ||
624 | ;;;-------------------------------------------------------------------------- | |
625 | ;;; Object printing. | |
626 | ||
627 | (export 'maybe-print-unreadable-object) | |
628 | (defmacro maybe-print-unreadable-object | |
629 | ((object stream &rest args) &body body) | |
630 | "Print helper for usually-unreadable objects. | |
631 | ||
3109662a | 632 | If `*print-escape*' is set then print OBJECT unreadably using BODY. |
dea4d055 MW |
633 | Otherwise just print using BODY." |
634 | (with-gensyms (print) | |
635 | `(flet ((,print () ,@body)) | |
636 | (if *print-escape* | |
637 | (print-unreadable-object (,object ,stream ,@args) | |
638 | (,print)) | |
639 | (,print))))) | |
640 | ||
641 | ;;;-------------------------------------------------------------------------- | |
642 | ;;; Iteration macros. | |
643 | ||
644 | (export 'dosequence) | |
645 | (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) | |
646 | &body body | |
647 | &environment env) | |
648 | "Macro for iterating over general sequences. | |
649 | ||
650 | Iterates over a (sub)sequence SEQ, delimited by START and END (which are | |
651 | evaluated). For each item of SEQ, BODY is invoked with VAR bound to the | |
652 | item, and INDEXVAR (if requested) bound to the item's index. (Note that | |
653 | this is different from most iteration constructs in Common Lisp, which | |
654 | work by mutating the variable.) | |
655 | ||
656 | The loop is surrounded by an anonymous BLOCK and the loop body forms an | |
657 | implicit TAGBODY, as is usual. There is no result-form, however." | |
658 | ||
659 | (once-only (:environment env seq start end) | |
660 | (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-")) | |
661 | ||
662 | (flet ((loopguts (indexp listp endvar) | |
663 | ;; Build a DO-loop to do what we want. | |
664 | (let* ((do-vars nil) | |
665 | (end-condition (if endvar | |
666 | `(>= ,ivar ,endvar) | |
667 | `(endp ,seq))) | |
668 | (item (if listp | |
669 | `(car ,seq) | |
670 | `(aref ,seq ,ivar))) | |
671 | (body-call `(,bodyfunc ,item))) | |
672 | (when listp | |
673 | (push `(,seq (nthcdr ,start ,seq) (cdr ,seq)) | |
674 | do-vars)) | |
675 | (when indexp | |
676 | (push `(,ivar ,start (1+ ,ivar)) do-vars)) | |
677 | (when indexvar | |
678 | (setf body-call (append body-call (list ivar)))) | |
679 | `(do ,do-vars (,end-condition) ,body-call)))) | |
680 | ||
681 | `(block nil | |
682 | (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) | |
683 | (tagbody ,@body))) | |
684 | (etypecase ,seq | |
685 | (vector | |
686 | (let ((,endvar (or ,end (length ,seq)))) | |
687 | ,(loopguts t nil endvar))) | |
688 | (list | |
689 | (if ,end | |
690 | ,(loopguts t t end) | |
691 | ,(loopguts indexvar t nil)))))))))) | |
692 | ||
693 | ;;;-------------------------------------------------------------------------- | |
694 | ;;; CLOS hacking. | |
695 | ||
696 | (export 'default-slot) | |
697 | (defmacro default-slot ((instance slot &optional (slot-names t)) | |
698 | &body value | |
699 | &environment env) | |
700 | "If INSTANCE's slot named SLOT is unbound, set it to VALUE. | |
701 | ||
702 | Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we | |
703 | obey the `shared-initialize' protocol). SLOT-NAMES defaults to `t', so | |
704 | you can use it in `initialize-instance' or similar without ill effects. | |
705 | Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only | |
706 | evaluated if it's needed." | |
707 | ||
708 | (once-only (:environment env instance slot slot-names) | |
709 | `(when ,(if (eq slot-names t) | |
710 | `(not (slot-boundp ,instance ,slot)) | |
711 | `(and (not (slot-boundp ,instance ,slot)) | |
712 | (or (eq ,slot-names t) | |
713 | (member ,slot ,slot-names)))) | |
714 | (setf (slot-value ,instance ,slot) | |
715 | (progn ,@value))))) | |
716 | ||
717 | ;;;----- That's all, folks -------------------------------------------------- |