3 ;;; Various handy utilities
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
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.
28 ;;;--------------------------------------------------------------------------
31 (defun mappend (function list &rest more-lists)
32 "Like a nondestructive MAPCAN.
34 Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
35 and return the result of appending all of the resulting lists."
36 (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
38 (define-condition inconsistent-merge-error (error)
39 ((candidates :initarg :candidates
40 :reader merge-error-candidates))
42 "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
43 (:report (lambda (condition stream)
44 (format stream "Merge inconsistency: failed to decide among ~A."
45 (merge-error-candidates condition)))))
47 (defun merge-lists (lists &key pick (test #'eql))
48 "Return a merge of the given LISTS.
50 The resulting LIST contains the items of the given lists, with duplicates
51 removed. The order of the resulting list is consistent with the orders of
52 the input LISTS in the sense that if A precedes B in some input list then
53 A will also precede B in the output list. If the lists aren't consistent
54 (e.g., some list contains A followed by B, and another contains B followed
55 by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
57 Item equality is determined by TEST.
59 If there is an ambiguity at any point -- i.e., a choice between two or
60 more possible next items to emit -- then PICK is called to arbitrate.
61 PICK is called with two arguments: the list of candidate next items, and
62 the current output list. It should return one of the candidate items. If
63 PICK is omitted then an arbitrary choice is made.
65 The primary use of this function is in computing class precedence lists.
66 By building the input lists and selecting the PICK function appropriately,
67 a variety of different CPL algorithms can be implemented."
69 ;; In this loop, TAIL points to the last cons cell in the list. This way
70 ;; we can build the list up forwards, so as not to make the PICK function
71 ;; interface be weird. HEAD is a dummy cons cell inserted before the list,
72 ;; which gives TAIL something to point to initially. (If we had locatives,
73 ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
74 ;; instead, it points to the cons cell whose cdr holds the final NIL --
75 ;; which means that we need to invent a cons cell if the list is empty.)
76 (do* ((head (cons nil nil))
78 ((null lists) (cdr head))
80 ;; The candidate items are the ones at the front of the input lists.
81 ;; Gather them up, removing duplicates. If a candidate is somewhere in
82 ;; one of the other lists other than at the front then we reject it. If
83 ;; we've just rejected everything, then we can make no more progress and
84 ;; the input lists were inconsistent.
85 (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
86 (leasts (remove-if (lambda (item)
88 (member item (cdr list) :test test))
91 (winner (cond ((null leasts)
92 (error 'inconsistent-merge-error
93 :candidates candidates))
97 (funcall pick leasts (cdr head)))
99 (new (cons winner nil)))
101 ;; Check that the PICK function isn't conning us.
102 (assert (member winner leasts :test test))
104 ;; Update the output list and remove the winning item from the input
105 ;; lists. We know that it must be at the front of each input list
106 ;; containing it. At this point, we discard input lists entirely when
107 ;; they run out of entries. The loop ends when there are no more input
108 ;; lists left, i.e., when we've munched all of the input items.
111 lists (delete nil (mapcar (lambda (list)
112 (if (funcall test winner (car list))
117 ;;;--------------------------------------------------------------------------
118 ;;; Strings and characters.
120 (defun frob-case (string)
121 "Twiddles the case of STRING.
123 If all the letters in STRING are uppercase, switch them to lowercase; if
124 they're all lowercase then switch them to uppercase. If there's a mix
125 then leave them all alone. This is an invertible transformation."
127 ;; Given that this operation is performed by the reader anyway, it's
128 ;; surprising that there isn't a Common Lisp function to do this built
130 (let ((flags (reduce (lambda (state ch)
132 (cond ((upper-case-p ch) 1)
133 ((lower-case-p ch) 2)
138 ;; Now FLAGS has bit 0 set if there are any upper-case characters, and
139 ;; bit 1 if there are lower-case. So if it's zero there were no letters
140 ;; at all, and if it's three then there were both kinds; either way, we
141 ;; leave the string unchanged. Otherwise we know how to flip the case.
143 (1 (string-downcase string))
144 (2 (string-upcase string))
147 (declaim (inline whitespace-char-p))
148 (defun whitespace-char-p (char)
149 "Returns whether CHAR is a whitespace character.
151 Whitespaceness is determined relative to the compile-time readtable, which
152 is probably good enough for most purposes."
154 (#.(loop for i below char-code-limit
155 for ch = (code-char i)
156 unless (with-input-from-string (in (string ch))
157 (peek-char t in nil))
161 ;;;--------------------------------------------------------------------------
164 (defun symbolicate (&rest symbols)
165 "Return a symbol named after the concatenation of the names of the SYMBOLS.
167 The symbol is interned in the current *PACKAGE*. Trad."
168 (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
170 ;;;--------------------------------------------------------------------------
173 (defmacro maybe-print-unreadable-object
174 ((object stream &rest args) &body body)
175 "Print helper for usually-unreadable objects.
177 If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
178 Otherwise just print using BODY."
179 (let ((func (gensym "PRINT")))
180 `(flet ((,func () ,@body))
182 (print-unreadable-object (,object ,stream ,@args)
186 ;;;--------------------------------------------------------------------------
187 ;;; Keyword arguments and lambda lists.
189 (eval-when (:compile-toplevel :load-toplevel :execute)
190 (defun transform-otherkeys-lambda-list (bvl)
191 "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
193 &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
194 (which must also be present); &ALLOW-OTHER-KEYS must not be present.
196 The behaviour is that
198 * the presence of non-listed keyword arguments is permitted, as if
199 &ALLOW-OTHER-KEYS had been provided, and
201 * a list of the keyword arguments other than the ones explicitly listed
202 is stored in the VAR.
204 The return value is a replacement BVL which binds the &OTHER-KEYS variable
205 as an &AUX parameter if necessary.
207 At least for now, fancy things like destructuring lambda-lists aren't
208 supported. I suspect you'll get away with a specializing lambda-list."
217 ;; Scan forwards until we find &REST or &KEY. If we find the former,
218 ;; then remember the variable name. If we find the latter first then
219 ;; there can't be a &REST argument, so we should invent one. If we
220 ;; find neither then there's nothing to do.
223 (let ((item (pop tail)))
226 (&rest (when (endp tail)
227 (error "Missing &REST argument name"))
228 (setf rest-var (pop tail))
229 (push rest-var new-bvl))
231 (&key (unless rest-var
232 (setf rest-var (gensym "REST"))
233 (setf new-bvl (nconc (list '&key rest-var '&rest)
239 ;; Read keyword argument specs one-by-one. For each one, stash it on
240 ;; the NEW-BVL list, and also parse it to extract the keyword, which
241 ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
242 ;; nothing for us to do.
245 (let ((item (pop tail)))
248 ((&aux &allow-other-keys) (go ignore))
249 (&other-keys (go fix-tail)))
250 (let ((keyword (if (symbolp item)
251 (intern (symbol-name item) :keyword)
252 (let ((var (car item)))
254 (intern (symbol-name var) :keyword)
256 (push keyword keywords))
260 ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
263 (error "Missing &OTHER-KEYS argument name"))
264 (setf other-keys-var (pop tail))
265 (push '&allow-other-keys new-bvl)
267 ;; There should be an &AUX next. If there isn't, assume there isn't
268 ;; one and provide our own. (This is safe as long as nobody else is
269 ;; expecting to plumb in lambda keywords too.)
270 (when (and (not (endp tail)) (eq (car tail) '&aux))
274 ;; Add our shiny new &AUX argument.
275 (let ((keys-var (gensym "KEYS"))
276 (list-var (gensym "LIST")))
277 (push `(,other-keys-var (do ((,list-var nil)
278 (,keys-var ,rest-var (cddr ,keys-var)))
279 ((endp ,keys-var) (nreverse ,list-var))
280 (unless (member (car ,keys-var)
283 (cons (cadr ,keys-var)
284 (cons (car ,keys-var)
289 (return (nreconc new-bvl tail))
292 ;; Nothing to do. Return the unmolested lambda-list.
295 (defmacro lambda-otherkeys (bvl &body body)
296 "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
297 `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
299 (defmacro defun-otherkeys (name bvl &body body)
300 "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
301 `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
303 (defmacro defmethod-otherkeys (name &rest stuff)
304 "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
306 (stuff stuff (cdr stuff)))
308 `(defmethod ,name ,@(nreverse quals)
309 ,(transform-otherkeys-lambda-list (car stuff))
311 (push (car stuff) quals)))
313 ;;;--------------------------------------------------------------------------
314 ;;; Iteration macros.
316 (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body)
317 "Macro for iterating over general sequences.
319 Iterates over a (sub)sequence SEQ, delimited by START and END (which are
320 evaluated). For each item of SEQ, BODY is invoked with VAR bound to the
321 item, and INDEXVAR (if requested) bound to the item's index. (Note that
322 this is different from most iteration constructs in Common Lisp, which
323 work by mutating the variable.)
325 The loop is surrounded by an anonymous BLOCK and the loop body forms an
326 implicit TAGBODY, as is usual. There is no result-form, however."
328 (let ((seqvar (gensym "SEQ"))
329 (startvar (gensym "START"))
330 (endvar (gensym "END"))
331 (ivar (gensym "INDEX"))
332 (bodyfunc (gensym "BODY")))
334 (flet ((loopguts (indexp listp use-endp)
335 ;; Build a DO-loop to do what we want.
337 (end-condition (if use-endp
339 `(>= ,ivar ,endvar)))
342 `(aref ,seqvar ,ivar)))
343 (body-call `(,bodyfunc ,item)))
345 (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar))
348 (push `(,ivar ,startvar (1+ ,ivar)) do-vars))
350 (setf body-call (append body-call (list ivar))))
351 `(do ,do-vars (,end-condition) ,body-call))))
354 (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
356 (let* ((,seqvar ,seq)
360 (let ((,endvar (or ,end (length ,seqvar))))
361 ,(loopguts t nil nil)))
363 (let ((,endvar ,end))
366 ,(loopguts indexvar t t)))))))))))
368 ;;;--------------------------------------------------------------------------
369 ;;; Meta-object hacking.
371 (defgeneric copy-instance-using-class (class object &rest initargs)
373 "Return a copy of OBJECT.
375 OBJECT is assumed to be an instance of CLASS. The copy returned is a
376 fresh instance whose slots have the same values as OBJECT except where
377 overridden by INITARGS.")
379 (:method ((class standard-class) object &rest initargs)
380 (let ((copy (apply #'allocate-instance class initargs)))
381 (dolist (slot (class-slots class))
382 (if (slot-boundp-using-class class object slot)
383 (setf (slot-value-using-class class copy slot)
384 (slot-value-using-class class object slot))
385 (slot-makunbound-using-class class copy slot)))
386 (apply #'shared-initialize copy nil initargs)
389 (defun copy-instance (object &rest initargs)
390 "Return a copy of OBJECT.
392 The copy returned is a fresh instance whose slots have the same values as
393 OBJECT except where overridden by INITARGS."
394 (apply #'copy-instance-using-class (class-of object) object initargs))
396 (defmacro default-slot ((instance slot) &body value &environment env)
397 "If INSTANCE's SLOT is unbound, set it to VALUE.
399 Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
400 evaluated if it's needed."
402 (let* ((quotep (constantp slot env))
403 (instancevar (gensym "INSTANCE"))
404 (slotvar (if quotep slot (gensym "SLOT"))))
405 `(let ((,instancevar ,instance)
406 ,@(and (not quotep) `((,slotvar ,slot))))
407 (unless (slot-boundp ,instancevar ,slotvar)
408 (setf (slot-value ,instancevar ,slotvar)
411 ;;;----- That's all, folks --------------------------------------------------