3 ;;; Various handy utilities
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
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.
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.
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.
26 (cl:defpackage #:sod-utilities
29 ;; MOP from somewhere.
31 #+(or cmu clisp) #:mop
34 (cl:in-package #:sod-utilities)
36 ;;;--------------------------------------------------------------------------
39 (export 'with-gensyms)
40 (defmacro with-gensyms ((&rest binds) &body body)
41 "Evaluate BODY with variables bound to fresh symbols.
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)
49 (values bind (concatenate 'string
50 (symbol-name bind) "-"))
53 (name (concatenate 'string
54 (symbol-name var) "-")))
57 `(,var (gensym ,name))))
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.
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'."
69 (cond ((and (consp form)
70 (eq (car form) 'quote)
73 (let ((body (cadr form)))
74 (if (or (not (or (consp body) (symbolp body)))
75 (member body '(t nil))
79 ((and (symbolp form) (boundp form) (null (symbol-value form)))
85 (defmacro once-only (binds &body body)
86 "Macro helper for preventing repeated evaluation.
88 The syntax is actually hairier than shown:
90 once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* )
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.
98 The result of evaluating a ONCE-ONLY form is a form with the structure
100 (let ((#:GS1 VALUE-FORM1)
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.
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
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.
123 (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-"))
126 ;; First things first: let's pick up the keywords.
128 (unless (and binds (keywordp (car binds)))
131 (:environment (setf env (pop binds)))))
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
136 (let ((canon (mapcar (lambda (bind)
137 (multiple-value-bind (var form)
141 (var &optional (form var)) bind
144 (gensym (format nil "T-~A-"
145 (symbol-name var))))))
148 `(let* (,@(and env `((,envvar ,env)))
150 ,@(mapcar (lambda (bind)
151 (destructuring-bind (var form temp) bind
152 (declare (ignore var))
155 ,@(mapcar (lambda (bind)
156 (destructuring-bind (var form temp) bind
157 (declare (ignore form))
159 (cond ((constantp ,temp
160 ,@(and env `(,envvar)))
166 ,(concatenate 'string
169 (push (list ,sym ,temp) ,lets)
172 (flet ((,bodyfunc () ,@body))
174 `(let (,@(nreverse ,lets)) ,(,bodyfunc))
178 (defun parse-body (body)
179 "Parse the BODY into a docstring, declarations and the body forms.
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
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)))
193 (values (and doc (list doc))
194 (and decls (list (cons 'declare decls)))
197 ;;;--------------------------------------------------------------------------
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.
206 Otherwise, if given, evaluate ALT; `it' isn't bound in ALT."
208 `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt)))))
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)))
216 (defmacro acond (&body clauses &environment env)
217 "Like COND, but with `it' bound to the value of the condition.
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)
227 (once-only (:environment env (cond (caar clauses)))
228 (if (and (constantp cond)
229 (if (and (consp cond) (eq (car cond) 'quote))
233 (declare (ignorable it))
239 (declare (ignorable it))
242 ,(walk (cdr clauses))))))))
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)))
256 (defmacro asetf (&rest places-and-values &environment env)
257 "Anaphoric update of places.
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
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)
268 (multiple-value-bind ,newtemps ,value
271 ;;;--------------------------------------------------------------------------
272 ;;; MOP hacks (not terribly demanding).
274 (export 'instance-initargs)
275 (defgeneric instance-initargs (instance)
277 "Return a plausble list of initargs for INSTANCE.
279 The idea is that you can make a copy of INSTANCE by invoking
281 (apply #'make-instance (class-of INSTANCE)
282 (instance-initargs INSTANCE))
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
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)
294 (slot-value instance (slot-definition-name slot)))
296 (class-slots (class-of instance)))))
298 (export '(copy-instance copy-instance-using-class))
299 (defgeneric copy-instance-using-class (class instance &rest initargs)
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.
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))
316 ;;;--------------------------------------------------------------------------
319 (export 'make-list-builder)
320 (defun make-list-builder (&optional initial)
321 "Return a simple list builder."
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.
329 (let ((builder (cons nil initial)))
330 (setf (car builder) (last builder))
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
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."
345 (setf (cdar builder) list
346 (car builder) (last list)))
349 (export 'lbuild-list)
350 (defun lbuild-list (builder)
351 "Return the constructed list."
355 (defun mappend (function list &rest more-lists)
356 "Like a nondestructive MAPCAN.
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))
362 (export '(inconsistent-merge-error merge-error-candidates))
363 (define-condition inconsistent-merge-error (error)
364 ((candidates :initarg :candidates
365 :reader merge-error-candidates))
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)))))
372 (export 'merge-lists)
373 (defun merge-lists (lists &key pick (test #'eql))
374 "Return a merge of the given LISTS.
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
381 by A) then an error of type `inconsistent-merge-error' is signalled.
383 Item equality is determined by TEST.
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.
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."
395 (do* ((lb (make-list-builder)))
396 ((null lists) (lbuild-list lb))
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)
406 (member item (cdr list) :test test))
409 (winner (cond ((null leasts)
410 (error 'inconsistent-merge-error
411 :candidates candidates))
415 (funcall pick leasts (lbuild-list lb)))
418 ;; Check that the PICK function isn't conning us.
419 (assert (member winner leasts :test test))
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))
434 (defmacro categorize ((itemvar items &key bind) categories &body body)
435 "Categorize ITEMS into lists and invoke BODY.
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
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.
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
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) "-")))
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)
468 (cond ,@(mapcar (lambda (cat-match-form cat-var)
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)))
479 ;;;--------------------------------------------------------------------------
480 ;;; Strings and characters.
482 (export 'frob-identifier)
483 (defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
484 "Twiddles the case of STRING.
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.
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
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.
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)
508 (cond ((upper-case-p ch) 1)
509 ((lower-case-p ch) 2)
515 (mask (logxor flags (ash flags 1)))
516 (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
520 (and (alpha-char-p ch) (char-downcase ch))))
523 (and (alpha-char-p ch) (char-upcase ch))))))
524 (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
527 (lambda (ch) (and (char= ch #\-) #\_)))
529 (lambda (ch) (and (char= ch #\_) #\-))))))
531 (if (logbitp 3 (logior mask (ash mask 2)))
532 (map 'string (lambda (ch)
533 (or (funcall letter ch)
534 (funcall uscore-hyphen ch)
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.
544 Whitespaceness is determined relative to the compile-time readtable, which
545 is probably good enough for most purposes."
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))
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.
559 Returns the new LINE and COLUMN numbers."
561 ((#\newline #\vt #\page)
562 (values (1+ line) 0))
564 (values line (logandc2 (+ column 8) 7)))
566 (values line (1+ column)))))
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.
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
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.
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))
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)))
594 ;; Anything else: just decrement the column and cross fingers.
595 (t (values line (1- column)))))
597 ;;;--------------------------------------------------------------------------
601 (defun compose (function &rest more-functions)
602 "Composition of functions. Functions are applied left-to-right.
604 This is the reverse order of the usual mathematical notation, but I find
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."
609 (labels ((compose1 (func-a func-b)
611 (multiple-value-call func-b (apply func-a args)))))
612 (reduce #'compose1 more-functions :initial-value function)))
614 ;;;--------------------------------------------------------------------------
617 (export 'symbolicate)
618 (defun symbolicate (&rest symbols)
619 "Return a symbol named after the concatenation of the names of the SYMBOLS.
621 The symbol is interned in the current `*package*'. Trad."
622 (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
624 ;;;--------------------------------------------------------------------------
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.
632 If `*print-escape*' is set then print OBJECT unreadably using BODY.
633 Otherwise just print using BODY."
634 (with-gensyms (print)
635 `(flet ((,print () ,@body))
637 (print-unreadable-object (,object ,stream ,@args)
641 ;;;--------------------------------------------------------------------------
642 ;;; Iteration macros.
645 (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
648 "Macro for iterating over general sequences.
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.)
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."
659 (once-only (:environment env seq start end)
660 (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
662 (flet ((loopguts (indexp listp endvar)
663 ;; Build a DO-loop to do what we want.
665 (end-condition (if endvar
671 (body-call `(,bodyfunc ,item)))
673 (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
676 (push `(,ivar ,start (1+ ,ivar)) do-vars))
678 (setf body-call (append body-call (list ivar))))
679 `(do ,do-vars (,end-condition) ,body-call))))
682 (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
686 (let ((,endvar (or ,end (length ,seq))))
687 ,(loopguts t nil endvar)))
691 ,(loopguts indexvar t nil))))))))))
693 ;;;--------------------------------------------------------------------------
696 (export 'default-slot)
697 (defmacro default-slot ((instance slot &optional (slot-names t))
700 "If INSTANCE's slot named SLOT is unbound, set it to VALUE.
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."
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)
717 ;;;----- That's all, folks --------------------------------------------------