mdw@git.distorted.org.uk Git - sod/blob - src/utilities.lisp

   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)
 216 (defmacro acond (&body clauses &environment env)
 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
 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
 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 (export '(generic-function-methods method-specializers
 317           eql-specializer eql-specializer-object))
 318
 319 ;;;--------------------------------------------------------------------------
 320 ;;; List utilities.
 321
 322 (export 'make-list-builder)
 323 (defun make-list-builder (&optional initial)
 324   "Return a simple list builder."
 325
 326   ;; The `builder' is just a cons cell whose cdr will be the list that's
 327   ;; wanted.  Effectively, then, we have a list that's one item longer than
 328   ;; we actually want.  The car of this extra initial cons cell is always the
 329   ;; last cons in the list -- which is now well defined because there's
 330   ;; always at least one.
 331
 332   (let ((builder (cons nil initial)))
 333     (setf (car builder) (last builder))
 334     builder))
 335
 336 (export 'lbuild-add)
 337 (defun lbuild-add (builder item)
 338   "Add an ITEM to the end of a list BUILDER."
 339   (let ((new (cons item nil)))
 340     (setf (cdar builder) new
 341           (car builder) new))
 342   builder)
 343
 344 (export 'lbuild-add-list)
 345 (defun lbuild-add-list (builder list)
 346   "Add a LIST to the end of a list BUILDER.  The LIST will be clobbered."
 347   (when list
 348     (setf (cdar builder) list
 349           (car builder) (last list)))
 350   builder)
 351
 352 (export 'lbuild-list)
 353 (defun lbuild-list (builder)
 354   "Return the constructed list."
 355   (cdr builder))
 356
 357 (export 'mappend)
 358 (defun mappend (function list &rest more-lists)
 359   "Like a nondestructive MAPCAN.
 360
 361    Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
 362    and return the result of appending all of the resulting lists."
 363   (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
 364
 365 (export '(inconsistent-merge-error merge-error-candidates))
 366 (define-condition inconsistent-merge-error (error)
 367   ((candidates :initarg :candidates
 368                :reader merge-error-candidates))
 369   (:documentation
 370    "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
 371   (:report (lambda (condition stream)
 372              (format stream "Merge inconsistency: failed to decide among ~A."
 373                      (merge-error-candidates condition)))))
 374
 375 (export 'merge-lists)
 376 (defun merge-lists (lists &key pick (test #'eql))
 377   "Return a merge of the given LISTS.
 378
 379    The resulting LIST contains the items of the given lists, with duplicates
 380    removed.  The order of the resulting list is consistent with the orders of
 381    the input LISTS in the sense that if A precedes B in some input list then
 382    A will also precede B in the output list.  If the lists aren't consistent
 383    (e.g., some list contains A followed by B, and another contains B followed
 384    by A) then an error of type `inconsistent-merge-error' is signalled.
 385
 386    Item equality is determined by TEST.
 387
 388    If there is an ambiguity at any point -- i.e., a choice between two or
 389    more possible next items to emit -- then PICK is called to arbitrate.
 390    PICK is called with two arguments: the list of candidate next items, and
 391    the current output list.  It should return one of the candidate items.  If
 392    PICK is omitted then an arbitrary choice is made.
 393
 394    The primary use of this function is in computing class precedence lists.
 395    By building the input lists and selecting the PICK function appropriately,
 396    a variety of different CPL algorithms can be implemented."
 397
 398   (do* ((lb (make-list-builder)))
 399        ((null lists) (lbuild-list lb))
 400
 401     ;; The candidate items are the ones at the front of the input lists.
 402     ;; Gather them up, removing duplicates.  If a candidate is somewhere in
 403     ;; one of the other lists other than at the front then we reject it.  If
 404     ;; we've just rejected everything, then we can make no more progress and
 405     ;; the input lists were inconsistent.
 406     (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
 407            (leasts (remove-if (lambda (item)
 408                                 (some (lambda (list)
 409                                         (member item (cdr list) :test test))
 410                                       lists))
 411                               candidates))
 412            (winner (cond ((null leasts)
 413                           (error 'inconsistent-merge-error
 414                                  :candidates candidates))
 415                          ((null (cdr leasts))
 416                           (car leasts))
 417                          (pick
 418                           (funcall pick leasts (lbuild-list lb)))
 419                          (t (car leasts)))))
 420
 421       ;; Check that the PICK function isn't conning us.
 422       (assert (member winner leasts :test test))
 423
 424       ;; Update the output list and remove the winning item from the input
 425       ;; lists.  We know that it must be at the front of each input list
 426       ;; containing it.  At this point, we discard input lists entirely when
 427       ;; they run out of entries.  The loop ends when there are no more input
 428       ;; lists left, i.e., when we've munched all of the input items.
 429       (lbuild-add lb winner)
 430       (setf lists (delete nil (mapcar (lambda (list)
 431                                         (if (funcall test winner (car list))
 432                                             (cdr list)
 433                                             list))
 434                                       lists))))))
 435
 436 (export 'categorize)
 437 (defmacro categorize ((itemvar items &key bind) categories &body body)
 438   "Categorize ITEMS into lists and invoke BODY.
 439
 440    The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
 441    will contain the current item.  The BIND argument is a list of LET*-like
 442    clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
 443    PREDICATE).
 444
 445    The behaviour of the macro is as follows.  ITEMVAR is assigned (not
 446    bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
 447    CATEGORIES list are evaluated in turn, in an environment containing
 448    ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
 449    At this point, the item is assigned to the category named by the
 450    corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
 451    error is signalled; a PREDICATE consisting only of T will (of course)
 452    match anything; it is detected specially so as to avoid compiler warnings.
 453
 454    Once all of the ITEMS have been categorized in this fashion, the BODY is
 455    evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
 456    variable named after that symbol will be bound in the BODY's environment
 457    to a list of the items in that category, in the same order in which they
 458    were found in the list ITEMS.  The final values of the macro are the final
 459    values of the BODY."
 460
 461   (let* ((cat-names (mapcar #'car categories))
 462          (cat-match-forms (mapcar #'cadr categories))
 463          (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string
 464                                                    (symbol-name name) "-")))
 465                            cat-names))
 466          (items-var (gensym "ITEMS-")))
 467     `(let ((,items-var ,items)
 468            ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
 469        (dolist (,itemvar ,items-var)
 470          (let* ,bind
 471            (cond ,@(mapcar (lambda (cat-match-form cat-var)
 472                              `(,cat-match-form
 473                                (push ,itemvar ,cat-var)))
 474                            cat-match-forms cat-vars)
 475                  ,@(and (not (member t cat-match-forms))
 476                         `((t (error "Failed to categorize ~A" ,itemvar)))))))
 477        (let ,(mapcar (lambda (name var)
 478                        `(,name (nreverse ,var)))
 479                      cat-names cat-vars)
 480          ,@body))))
 481
 482 ;;;--------------------------------------------------------------------------
 483 ;;; Strings and characters.
 484
 485 (export 'frob-identifier)
 486 (defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
 487   "Twiddles the case of STRING.
 488
 489    If all the letters in STRING are uppercase, and SWAP-CASE is true, then
 490    switch them to lowercase; if they're all lowercase then switch them to
 491    uppercase.  If there's a mix then leave them all alone.  At the same time,
 492    if there are underscores but no hyphens, and SWAP-HYPHEN is true, then
 493    switch them to hyphens, if there are hyphens and no underscores, switch
 494    them underscores, and if there are both then leave them alone.
 495
 496    This is an invertible transformation, which turns vaguely plausible Lisp
 497    names into vaguely plausible C names and vice versa.  Lisp names with
 498    `funny characters' like stars and percent signs won't be any use, of
 499    course."
 500
 501   ;; Work out what kind of a job we've got to do.  Gather flags: bit 0 means
 502   ;; there are upper-case letters; bit 1 means there are lower-case letters;
 503   ;; bit 2 means there are hyphens; bit 3 means there are underscores.
 504   ;;
 505   ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set
 506   ;; if we have to frob case; bit 3 is set if we have to swap hyphens and
 507   ;; underscores.  So use this to select functions which do bits of the
 508   ;; mapping, and then compose them together.
 509   (let* ((flags (reduce (lambda (state ch)
 510                           (logior state
 511                                   (cond ((upper-case-p ch) 1)
 512                                         ((lower-case-p ch) 2)
 513                                         ((char= ch #\-) 4)
 514                                         ((char= ch #\_) 8)
 515                                         (t 0))))
 516                         string
 517                         :initial-value 0))
 518          (mask (logxor flags (ash flags 1)))
 519          (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
 520                         (constantly nil))
 521                        ((logbitp 0 flags)
 522                         (lambda (ch)
 523                           (and (alpha-char-p ch) (char-downcase ch))))
 524                        (t
 525                         (lambda (ch)
 526                           (and (alpha-char-p ch) (char-upcase ch))))))
 527          (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
 528                                (constantly nil))
 529                               ((logbitp 2 flags)
 530                                (lambda (ch) (and (char= ch #\-) #\_)))
 531                               (t
 532                                (lambda (ch) (and (char= ch #\_) #\-))))))
 533
 534     (if (logbitp 3 (logior mask (ash mask 2)))
 535         (map 'string (lambda (ch)
 536                        (or (funcall letter ch)
 537                            (funcall uscore-hyphen ch)
 538                            ch))
 539              string)
 540         string)))
 541
 542 (export 'whitespace-char-p)
 543 (declaim (inline whitespace-char-p))
 544 (defun whitespace-char-p (char)
 545   "Returns whether CHAR is a whitespace character.
 546
 547    Whitespaceness is determined relative to the compile-time readtable, which
 548    is probably good enough for most purposes."
 549   (case char
 550     (#.(loop for i below char-code-limit
 551              for ch = (code-char i)
 552              unless (with-input-from-string (in (string ch))
 553                       (peek-char t in nil))
 554              collect ch) t)
 555     (t nil)))
 556
 557 (export 'update-position)
 558 (declaim (inline update-position))
 559 (defun update-position (char line column)
 560   "Updates LINE and COLUMN appropriately for having read the character CHAR.
 561
 562    Returns the new LINE and COLUMN numbers."
 563   (case char
 564     ((#\newline #\vt #\page)
 565      (values (1+ line) 0))
 566     ((#\tab)
 567      (values line (logandc2 (+ column 8) 7)))
 568     (t
 569      (values line (1+ column)))))
 570
 571 (export 'backtrack-position)
 572 (declaim (inline backtrack-position))
 573 (defun backtrack-position (char line column)
 574   "Updates LINE and COLUMN appropriately for having unread CHAR.
 575
 576    Well, actually an approximation for it; it will likely be wrong if the
 577    last character was a tab.  But when the character is read again, it will
 578    be correct."
 579
 580   ;; This isn't perfect: if the character doesn't actually match what was
 581   ;; really read then it might not actually be possible: for example, if we
 582   ;; push back a newline while in the middle of a line, or a tab while not at
 583   ;; a tab stop.  In that case, we'll just lose, but hopefully not too badly.
 584   (case char
 585
 586     ;; In the absence of better ideas, I'll set the column number to zero.
 587     ;; This is almost certainly wrong, but with a little luck nobody will ask
 588     ;; and it'll be all right soon.
 589     ((#\newline #\vt #\page) (values (1- line) 0))
 590
 591     ;; Winding back a single space is sufficient.  If the position is
 592     ;; currently on a tab stop then it'll advance back here next time.  If
 593     ;; not, we're going to lose anyway because the previous character
 594     ;; certainly couldn't have been a tab.
 595     (#\tab (values line (1- column)))
 596
 597     ;; Anything else: just decrement the column and cross fingers.
 598     (t (values line (1- column)))))
 599
 600 ;;;--------------------------------------------------------------------------
 601 ;;; Functions.
 602
 603 (export 'compose)
 604 (defun compose (function &rest more-functions)
 605   "Composition of functions.  Functions are applied left-to-right.
 606
 607    This is the reverse order of the usual mathematical notation, but I find
 608    it easier to read.  It's also slightly easier to work with in programs.
 609    That is, (compose F1 F2 ... Fn) is what a category theorist might write as
 610    F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn."
 611
 612   (labels ((compose1 (func-a func-b)
 613              (lambda (&rest args)
 614                (multiple-value-call func-b (apply func-a args)))))
 615     (reduce #'compose1 more-functions :initial-value function)))
 616
 617 ;;;--------------------------------------------------------------------------
 618 ;;; Symbols.
 619
 620 (export 'symbolicate)
 621 (defun symbolicate (&rest symbols)
 622   "Return a symbol named after the concatenation of the names of the SYMBOLS.
 623
 624    The symbol is interned in the current `*package*'.  Trad."
 625   (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
 626
 627 ;;;--------------------------------------------------------------------------
 628 ;;; Object printing.
 629
 630 (export 'maybe-print-unreadable-object)
 631 (defmacro maybe-print-unreadable-object
 632     ((object stream &rest args) &body body)
 633   "Print helper for usually-unreadable objects.
 634
 635    If `*print-escape*' is set then print OBJECT unreadably using BODY.
 636    Otherwise just print using BODY."
 637   (with-gensyms (print)
 638     `(flet ((,print () ,@body))
 639        (if *print-escape*
 640            (print-unreadable-object (,object ,stream ,@args)
 641              (,print))
 642            (,print)))))
 643
 644 ;;;--------------------------------------------------------------------------
 645 ;;; Iteration macros.
 646
 647 (export 'dosequence)
 648 (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
 649                       &body body
 650                       &environment env)
 651   "Macro for iterating over general sequences.
 652
 653    Iterates over a (sub)sequence SEQ, delimited by START and END (which are
 654    evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
 655    item, and INDEXVAR (if requested) bound to the item's index.  (Note that
 656    this is different from most iteration constructs in Common Lisp, which
 657    work by mutating the variable.)
 658
 659    The loop is surrounded by an anonymous BLOCK and the loop body forms an
 660    implicit TAGBODY, as is usual.  There is no result-form, however."
 661
 662   (once-only (:environment env seq start end)
 663     (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
 664
 665       (flet ((loopguts (indexp listp endvar)
 666                ;; Build a DO-loop to do what we want.
 667                (let* ((do-vars nil)
 668                       (end-condition (if endvar
 669                                          `(>= ,ivar ,endvar)
 670                                          `(endp ,seq)))
 671                       (item (if listp
 672                                 `(car ,seq)
 673                                 `(aref ,seq ,ivar)))
 674                       (body-call `(,bodyfunc ,item)))
 675                  (when listp
 676                    (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
 677                          do-vars))
 678                  (when indexp
 679                    (push `(,ivar ,start (1+ ,ivar)) do-vars))
 680                  (when indexvar
 681                    (setf body-call (append body-call (list ivar))))
 682                  `(do ,do-vars (,end-condition) ,body-call))))
 683
 684         `(block nil
 685            (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
 686                     (tagbody ,@body)))
 687                (etypecase ,seq
 688                  (vector
 689                   (let ((,endvar (or ,end (length ,seq))))
 690                     ,(loopguts t nil endvar)))
 691                  (list
 692                   (if ,end
 693                       ,(loopguts t t end)
 694                       ,(loopguts indexvar t nil))))))))))
 695
 696 ;;;--------------------------------------------------------------------------
 697 ;;; CLOS hacking.
 698
 699 (export 'default-slot)
 700 (defmacro default-slot ((instance slot &optional (slot-names t))
 701                           &body value
 702                           &environment env)
 703   "If INSTANCE's slot named SLOT is unbound, set it to VALUE.
 704
 705    Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we
 706    obey the `shared-initialize' protocol).  SLOT-NAMES defaults to `t', so
 707    you can use it in `initialize-instance' or similar without ill effects.
 708    Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
 709    evaluated if it's needed."
 710
 711   (once-only (:environment env instance slot slot-names)
 712     `(when ,(if (eq slot-names t)
 713                   `(not (slot-boundp ,instance ,slot))
 714                   `(and (not (slot-boundp ,instance ,slot))
 715                         (or (eq ,slot-names t)
 716                             (member ,slot ,slot-names))))
 717        (setf (slot-value ,instance ,slot)
 718              (progn ,@value)))))
 719
 720 ;;;----- That's all, folks --------------------------------------------------