| 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 Simple Object Definition system. |
| 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:in-package #:sod) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; List utilities. |
| 30 | |
| 31 | (defun mappend (function list &rest more-lists) |
| 32 | "Like a nondestructive MAPCAN. |
| 33 | |
| 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)) |
| 37 | |
| 38 | (define-condition inconsistent-merge-error (error) |
| 39 | ((candidates :initarg :candidates |
| 40 | :reader merge-error-candidates)) |
| 41 | (:documentation |
| 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))))) |
| 46 | |
| 47 | (defun merge-lists (lists &key pick (test #'eql)) |
| 48 | "Return a merge of the given LISTS. |
| 49 | |
| 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. |
| 56 | |
| 57 | Item equality is determined by TEST. |
| 58 | |
| 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. |
| 64 | |
| 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." |
| 68 | |
| 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)) |
| 77 | (tail head)) |
| 78 | ((null lists) (cdr head)) |
| 79 | |
| 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) |
| 87 | (some (lambda (list) |
| 88 | (member item (cdr list) :test test)) |
| 89 | lists)) |
| 90 | candidates)) |
| 91 | (winner (cond ((null leasts) |
| 92 | (error 'inconsistent-merge-error |
| 93 | :candidates candidates)) |
| 94 | ((null (cdr leasts)) |
| 95 | (car leasts)) |
| 96 | (pick |
| 97 | (funcall pick leasts (cdr head))) |
| 98 | (t (car leasts)))) |
| 99 | (new (cons winner nil))) |
| 100 | |
| 101 | ;; Check that the PICK function isn't conning us. |
| 102 | (assert (member winner leasts :test test)) |
| 103 | |
| 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. |
| 109 | (setf (cdr tail) new |
| 110 | tail new |
| 111 | lists (delete nil (mapcar (lambda (list) |
| 112 | (if (funcall test winner (car list)) |
| 113 | (cdr list) |
| 114 | list)) |
| 115 | lists)))))) |
| 116 | |
| 117 | ;;;-------------------------------------------------------------------------- |
| 118 | ;;; Strings and characters. |
| 119 | |
| 120 | (defun frob-case (string) |
| 121 | "Twiddles the case of STRING. |
| 122 | |
| 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." |
| 126 | |
| 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 |
| 129 | ;; in. |
| 130 | (let ((flags (reduce (lambda (state ch) |
| 131 | (logior state |
| 132 | (cond ((upper-case-p ch) 1) |
| 133 | ((lower-case-p ch) 2) |
| 134 | (t 0)))) |
| 135 | string |
| 136 | :initial-value 0))) |
| 137 | |
| 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. |
| 142 | (case flags |
| 143 | (1 (string-downcase string)) |
| 144 | (2 (string-upcase string)) |
| 145 | (t string)))) |
| 146 | |
| 147 | (declaim (inline whitespace-char-p)) |
| 148 | (defun whitespace-char-p (char) |
| 149 | "Returns whether CHAR is a whitespace character. |
| 150 | |
| 151 | Whitespaceness is determined relative to the compile-time readtable, which |
| 152 | is probably good enough for most purposes." |
| 153 | (case char |
| 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)) |
| 158 | collect ch) t) |
| 159 | (t nil))) |
| 160 | |
| 161 | ;;;-------------------------------------------------------------------------- |
| 162 | ;;; Symbols. |
| 163 | |
| 164 | (defun symbolicate (&rest symbols) |
| 165 | "Return a symbol named after the concatenation of the names of the SYMBOLS. |
| 166 | |
| 167 | The symbol is interned in the current *PACKAGE*. Trad." |
| 168 | (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) |
| 169 | |
| 170 | ;;;-------------------------------------------------------------------------- |
| 171 | ;;; Object printing. |
| 172 | |
| 173 | (defmacro maybe-print-unreadable-object |
| 174 | ((object stream &rest args) &body body) |
| 175 | "Print helper for usually-unreadable objects. |
| 176 | |
| 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)) |
| 181 | (if *print-escape* |
| 182 | (print-unreadable-object (,object ,stream ,@args) |
| 183 | (,func)) |
| 184 | (,func))))) |
| 185 | |
| 186 | ;;;-------------------------------------------------------------------------- |
| 187 | ;;; Keyword arguments and lambda lists. |
| 188 | |
| 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. |
| 192 | |
| 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. |
| 195 | |
| 196 | The behaviour is that |
| 197 | |
| 198 | * the presence of non-listed keyword arguments is permitted, as if |
| 199 | &ALLOW-OTHER-KEYS had been provided, and |
| 200 | |
| 201 | * a list of the keyword arguments other than the ones explicitly listed |
| 202 | is stored in the VAR. |
| 203 | |
| 204 | The return value is a replacement BVL which binds the &OTHER-KEYS variable |
| 205 | as an &AUX parameter if necessary. |
| 206 | |
| 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." |
| 209 | |
| 210 | (prog ((new-bvl nil) |
| 211 | (rest-var nil) |
| 212 | (keywords nil) |
| 213 | (other-keys-var nil) |
| 214 | (tail bvl)) |
| 215 | |
| 216 | find-rest |
| 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. |
| 221 | (when (endp tail) |
| 222 | (go ignore)) |
| 223 | (let ((item (pop tail))) |
| 224 | (push item new-bvl) |
| 225 | (case item |
| 226 | (&rest (when (endp tail) |
| 227 | (error "Missing &REST argument name")) |
| 228 | (setf rest-var (pop tail)) |
| 229 | (push rest-var new-bvl)) |
| 230 | (&aux (go ignore)) |
| 231 | (&key (unless rest-var |
| 232 | (setf rest-var (gensym "REST")) |
| 233 | (setf new-bvl (nconc (list '&key rest-var '&rest) |
| 234 | (cdr new-bvl)))) |
| 235 | (go scan-keywords))) |
| 236 | (go find-rest)) |
| 237 | |
| 238 | scan-keywords |
| 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. |
| 243 | (when (endp tail) |
| 244 | (go ignore)) |
| 245 | (let ((item (pop tail))) |
| 246 | (push item new-bvl) |
| 247 | (case item |
| 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))) |
| 253 | (if (symbolp var) |
| 254 | (intern (symbol-name var) :keyword) |
| 255 | (car var)))))) |
| 256 | (push keyword keywords)) |
| 257 | (go scan-keywords)) |
| 258 | |
| 259 | fix-tail |
| 260 | ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var. |
| 261 | (pop new-bvl) |
| 262 | (when (endp tail) |
| 263 | (error "Missing &OTHER-KEYS argument name")) |
| 264 | (setf other-keys-var (pop tail)) |
| 265 | (push '&allow-other-keys new-bvl) |
| 266 | |
| 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)) |
| 271 | (pop tail)) |
| 272 | (push '&aux new-bvl) |
| 273 | |
| 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) |
| 281 | ',keywords) |
| 282 | (setf ,list-var |
| 283 | (cons (cadr ,keys-var) |
| 284 | (cons (car ,keys-var) |
| 285 | ,list-var)))))) |
| 286 | new-bvl)) |
| 287 | |
| 288 | ;; Done. |
| 289 | (return (nreconc new-bvl tail)) |
| 290 | |
| 291 | ignore |
| 292 | ;; Nothing to do. Return the unmolested lambda-list. |
| 293 | (return bvl)))) |
| 294 | |
| 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)) |
| 298 | |
| 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)) |
| 302 | |
| 303 | (defmacro defmethod-otherkeys (name &rest stuff) |
| 304 | "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword." |
| 305 | (do ((quals nil) |
| 306 | (stuff stuff (cdr stuff))) |
| 307 | ((listp (car stuff)) |
| 308 | `(defmethod ,name ,@(nreverse quals) |
| 309 | ,(transform-otherkeys-lambda-list (car stuff)) |
| 310 | ,@(cdr stuff))) |
| 311 | (push (car stuff) quals))) |
| 312 | |
| 313 | ;;;-------------------------------------------------------------------------- |
| 314 | ;;; Iteration macros. |
| 315 | |
| 316 | (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body) |
| 317 | "Macro for iterating over general sequences. |
| 318 | |
| 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.) |
| 324 | |
| 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." |
| 327 | |
| 328 | (let ((seqvar (gensym "SEQ")) |
| 329 | (startvar (gensym "START")) |
| 330 | (endvar (gensym "END")) |
| 331 | (ivar (gensym "INDEX")) |
| 332 | (bodyfunc (gensym "BODY"))) |
| 333 | |
| 334 | (flet ((loopguts (indexp listp use-endp) |
| 335 | ;; Build a DO-loop to do what we want. |
| 336 | (let* ((do-vars nil) |
| 337 | (end-condition (if use-endp |
| 338 | `(endp ,seqvar) |
| 339 | `(>= ,ivar ,endvar))) |
| 340 | (item (if listp |
| 341 | `(car ,seqvar) |
| 342 | `(aref ,seqvar ,ivar))) |
| 343 | (body-call `(,bodyfunc ,item))) |
| 344 | (when listp |
| 345 | (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar)) |
| 346 | do-vars)) |
| 347 | (when indexp |
| 348 | (push `(,ivar ,startvar (1+ ,ivar)) do-vars)) |
| 349 | (when indexvar |
| 350 | (setf body-call (append body-call (list ivar)))) |
| 351 | `(do ,do-vars (,end-condition) ,body-call)))) |
| 352 | |
| 353 | `(block nil |
| 354 | (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) |
| 355 | (tagbody ,@body))) |
| 356 | (let* ((,seqvar ,seq) |
| 357 | (,startvar ,start)) |
| 358 | (etypecase ,seqvar |
| 359 | (vector |
| 360 | (let ((,endvar (or ,end (length ,seqvar)))) |
| 361 | ,(loopguts t nil nil))) |
| 362 | (list |
| 363 | (let ((,endvar ,end)) |
| 364 | (if ,endvar |
| 365 | ,(loopguts t t nil) |
| 366 | ,(loopguts indexvar t t))))))))))) |
| 367 | |
| 368 | ;;;-------------------------------------------------------------------------- |
| 369 | ;;; Meta-object hacking. |
| 370 | |
| 371 | (defgeneric copy-instance-using-class (class object &rest initargs) |
| 372 | (:documentation |
| 373 | "Return a copy of OBJECT. |
| 374 | |
| 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.") |
| 378 | |
| 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) |
| 387 | copy))) |
| 388 | |
| 389 | (defun copy-instance (object &rest initargs) |
| 390 | "Return a copy of OBJECT. |
| 391 | |
| 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)) |
| 395 | |
| 396 | (defmacro default-slot ((instance slot) &body value &environment env) |
| 397 | "If INSTANCE's SLOT is unbound, set it to VALUE. |
| 398 | |
| 399 | Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only |
| 400 | evaluated if it's needed." |
| 401 | |
| 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) |
| 409 | (progn ,@value)))))) |
| 410 | |
| 411 | ;;;----- That's all, folks -------------------------------------------------- |