chiark - git - mdw - 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 ;;;--------------------------------------------------------------------------
 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
 381    by A) then an error of type `inconsistent-merge-error' is signalled.
 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
 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
 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
 621    The symbol is interned in the current `*package*'.  Trad."
 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
 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))
 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 --------------------------------------------------