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 ;;; Locatives.
 199
 200 (export '(loc locp))
 201 (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
 202   "Locative data type.  See `locf' and `ref'."
 203   (reader nil :type function)
 204   (writer nil :type function))
 205
 206 (export 'locf)
 207 (defmacro locf (place &environment env)
 208   "Slightly cheesy locatives.
 209
 210    (locf PLACE) returns an object which, using the `ref' function, can be
 211    used to read or set the value of PLACE.  It's cheesy because it uses
 212    closures rather than actually taking the address of something.  Also,
 213    unlike Zetalisp, we don't overload `car' to do our dirty work."
 214   (multiple-value-bind
 215       (valtmps valforms newtmps setform getform)
 216       (get-setf-expansion place env)
 217     `(let* (,@(mapcar #'list valtmps valforms))
 218        (make-loc (lambda () ,getform)
 219                  (lambda (,@newtmps) ,setform)))))
 220
 221 (export 'ref)
 222 (declaim (inline ref (setf ref)))
 223 (defun ref (loc)
 224   "Fetch the value referred to by a locative."
 225   (funcall (loc-reader loc)))
 226 (defun (setf ref) (new loc)
 227   "Store a new value in the place referred to by a locative."
 228   (funcall (loc-writer loc) new))
 229
 230 (export 'with-locatives)
 231 (defmacro with-locatives (locs &body body)
 232   "Evaluate BODY with implicit locatives.
 233
 234    LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
 235    symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
 236    defaults to SYM.  As an abbreviation for a common case, LOCS may be a
 237    symbol instead of a list.
 238
 239    The BODY is evaluated in an environment where each SYM is a symbol macro
 240    which expands to (ref LOC-EXPR) -- or, in fact, something similar which
 241    doesn't break if LOC-EXPR has side-effects.  Thus, references, including
 242    `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
 243    Useful for covering over where something uses a locative."
 244   (setf locs (mapcar (lambda (item)
 245                        (cond ((atom item) (list item item))
 246                              ((null (cdr item)) (list (car item) (car item)))
 247                              (t item)))
 248                      (if (listp locs) locs (list locs))))
 249   (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
 250         (ll (mapcar #'cadr locs))
 251         (ss (mapcar #'car locs)))
 252     `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
 253        (symbol-macrolet (,@(mapcar (lambda (sym tmp)
 254                                      `(,sym (ref ,tmp))) ss tt))
 255          ,@body))))
 256
 257 ;;;--------------------------------------------------------------------------
 258 ;;; Anaphorics.
 259
 260 (export 'it)
 261
 262 (export 'aif)
 263 (defmacro aif (cond cons &optional (alt nil altp))
 264   "If COND is not nil, evaluate CONS with `it' bound to the value of COND.
 265
 266    Otherwise, if given, evaluate ALT; `it' isn't bound in ALT."
 267   (once-only (cond)
 268     `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt)))))
 269
 270 (export 'awhen)
 271 (defmacro awhen (cond &body body)
 272   "If COND, evaluate BODY as a progn with `it' bound to the value of COND."
 273   `(let ((it ,cond)) (when it ,@body)))
 274
 275 (export 'acond)
 276 (defmacro acond (&body clauses &environment env)
 277   "Like COND, but with `it' bound to the value of the condition.
 278
 279    Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is
 280    non-nil then evaluate the FORMs with `it' bound to the non-nil value, and
 281    return the value of the last FORM; if there are no FORMs, then return `it'
 282    itself.  If the CONDITION is nil then continue with the next clause; if
 283    all clauses evaluate to nil then the result is nil."
 284   (labels ((walk (clauses)
 285              (if (null clauses)
 286                  `nil
 287                  (once-only (:environment env (cond (caar clauses)))
 288                    (if (and (constantp cond)
 289                             (if (and (consp cond) (eq (car cond) 'quote))
 290                                 (cadr cond) cond))
 291                        (if (cdar clauses)
 292                            `(let ((it ,cond))
 293                               (declare (ignorable it))
 294                               ,@(cdar clauses))
 295                            cond)
 296                        `(if ,cond
 297                             ,(if (cdar clauses)
 298                                  `(let ((it ,cond))
 299                                     (declare (ignorable it))
 300                                     ,@(cdar clauses))
 301                                  cond)
 302                             ,(walk (cdr clauses))))))))
 303     (walk clauses)))
 304
 305 (export '(acase aecase atypecase aetypecase))
 306 (defmacro acase (value &body clauses)
 307   `(let ((it ,value)) (case it ,@clauses)))
 308 (defmacro aecase (value &body clauses)
 309   `(let ((it ,value)) (ecase it ,@clauses)))
 310 (defmacro atypecase (value &body clauses)
 311   `(let ((it ,value)) (typecase it ,@clauses)))
 312 (defmacro aetypecase (value &body clauses)
 313   `(let ((it ,value)) (etypecase it ,@clauses)))
 314
 315 (export 'asetf)
 316 (defmacro asetf (&rest places-and-values &environment env)
 317   "Anaphoric update of places.
 318
 319    The PLACES-AND-VALUES are alternating PLACEs and VALUEs.  Each VALUE is
 320    evaluated with IT bound to the current value stored in the corresponding
 321    PLACE."
 322   `(progn ,@(loop for (place value) on places-and-values by #'cddr
 323                   collect (multiple-value-bind
 324                               (temps inits newtemps setform getform)
 325                               (get-setf-expansion place env)
 326                             `(let* (,@(mapcar #'list temps inits)
 327                                     (it ,getform))
 328                                (multiple-value-bind ,newtemps ,value
 329                                  ,setform))))))
 330
 331 ;;;--------------------------------------------------------------------------
 332 ;;; MOP hacks (not terribly demanding).
 333
 334 (export 'instance-initargs)
 335 (defgeneric instance-initargs (instance)
 336   (:documentation
 337    "Return a plausble list of initargs for INSTANCE.
 338
 339    The idea is that you can make a copy of INSTANCE by invoking
 340
 341         (apply #'make-instance (class-of INSTANCE)
 342                (instance-initargs INSTANCE))
 343
 344    The default implementation works by inspecting the slot definitions and
 345    extracting suitable initargs, so this will only succeed if enough slots
 346    actually have initargs specified that `initialize-instance' can fill in
 347    the rest correctly.
 348
 349    The list returned is freshly consed, and you can destroy it if you like.")
 350   (:method ((instance standard-object))
 351     (mapcan (lambda (slot)
 352               (aif (slot-definition-initargs slot)
 353                    (list (car it)
 354                          (slot-value instance (slot-definition-name slot)))
 355                    nil))
 356             (class-slots (class-of instance)))))
 357
 358 (export '(copy-instance copy-instance-using-class))
 359 (defgeneric copy-instance-using-class (class instance &rest initargs)
 360   (:documentation
 361    "Metaobject protocol hook for `copy-instance'.")
 362   (:method ((class standard-class) instance &rest initargs)
 363     (let ((copy (allocate-instance class)))
 364       (dolist (slot (class-slots class))
 365         (let ((name (slot-definition-name slot)))
 366           (when (slot-boundp instance name)
 367             (setf (slot-value copy name) (slot-value instance name)))))
 368       (apply #'shared-initialize copy nil initargs))))
 369 (defun copy-instance (object &rest initargs)
 370   "Construct and return a copy of OBJECT.
 371
 372    The new object has the same class as OBJECT, and the same slot values
 373    except where overridden by INITARGS."
 374   (apply #'copy-instance-using-class (class-of object) object initargs))
 375
 376 (export '(generic-function-methods method-specializers
 377           eql-specializer eql-specializer-object))
 378
 379 ;;;--------------------------------------------------------------------------
 380 ;;; List utilities.
 381
 382 (export 'make-list-builder)
 383 (defun make-list-builder (&optional initial)
 384   "Return a simple list builder."
 385
 386   ;; The `builder' is just a cons cell whose cdr will be the list that's
 387   ;; wanted.  Effectively, then, we have a list that's one item longer than
 388   ;; we actually want.  The car of this extra initial cons cell is always the
 389   ;; last cons in the list -- which is now well defined because there's
 390   ;; always at least one.
 391
 392   (let ((builder (cons nil initial)))
 393     (setf (car builder) (last builder))
 394     builder))
 395
 396 (export 'lbuild-add)
 397 (defun lbuild-add (builder item)
 398   "Add an ITEM to the end of a list BUILDER."
 399   (let ((new (cons item nil)))
 400     (setf (cdar builder) new
 401           (car builder) new))
 402   builder)
 403
 404 (export 'lbuild-add-list)
 405 (defun lbuild-add-list (builder list)
 406   "Add a LIST to the end of a list BUILDER.  The LIST will be clobbered."
 407   (when list
 408     (setf (cdar builder) list
 409           (car builder) (last list)))
 410   builder)
 411
 412 (export 'lbuild-list)
 413 (defun lbuild-list (builder)
 414   "Return the constructed list."
 415   (cdr builder))
 416
 417 (export 'mappend)
 418 (defun mappend (function list &rest more-lists)
 419   "Like a nondestructive MAPCAN.
 420
 421    Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
 422    and return the result of appending all of the resulting lists."
 423   (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
 424
 425 (export '(inconsistent-merge-error merge-error-candidates))
 426 (define-condition inconsistent-merge-error (error)
 427   ((candidates :initarg :candidates
 428                :reader merge-error-candidates))
 429   (:documentation
 430    "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
 431   (:report (lambda (condition stream)
 432              (format stream "Merge inconsistency: failed to decide among ~A."
 433                      (merge-error-candidates condition)))))
 434
 435 (export 'merge-lists)
 436 (defun merge-lists (lists &key pick (test #'eql))
 437   "Return a merge of the given LISTS.
 438
 439    The resulting LIST contains the items of the given lists, with duplicates
 440    removed.  The order of the resulting list is consistent with the orders of
 441    the input LISTS in the sense that if A precedes B in some input list then
 442    A will also precede B in the output list.  If the lists aren't consistent
 443    (e.g., some list contains A followed by B, and another contains B followed
 444    by A) then an error of type `inconsistent-merge-error' is signalled.
 445
 446    Item equality is determined by TEST.
 447
 448    If there is an ambiguity at any point -- i.e., a choice between two or
 449    more possible next items to emit -- then PICK is called to arbitrate.
 450    PICK is called with two arguments: the list of candidate next items, and
 451    the current output list.  It should return one of the candidate items.  If
 452    PICK is omitted then an arbitrary choice is made.
 453
 454    The primary use of this function is in computing class precedence lists.
 455    By building the input lists and selecting the PICK function appropriately,
 456    a variety of different CPL algorithms can be implemented."
 457
 458   (do* ((lb (make-list-builder)))
 459        ((null lists) (lbuild-list lb))
 460
 461     ;; The candidate items are the ones at the front of the input lists.
 462     ;; Gather them up, removing duplicates.  If a candidate is somewhere in
 463     ;; one of the other lists other than at the front then we reject it.  If
 464     ;; we've just rejected everything, then we can make no more progress and
 465     ;; the input lists were inconsistent.
 466     (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
 467            (leasts (remove-if (lambda (item)
 468                                 (some (lambda (list)
 469                                         (member item (cdr list) :test test))
 470                                       lists))
 471                               candidates))
 472            (winner (cond ((null leasts)
 473                           (error 'inconsistent-merge-error
 474                                  :candidates candidates))
 475                          ((null (cdr leasts))
 476                           (car leasts))
 477                          (pick
 478                           (funcall pick leasts (lbuild-list lb)))
 479                          (t (car leasts)))))
 480
 481       ;; Check that the PICK function isn't conning us.
 482       (assert (member winner leasts :test test))
 483
 484       ;; Update the output list and remove the winning item from the input
 485       ;; lists.  We know that it must be at the front of each input list
 486       ;; containing it.  At this point, we discard input lists entirely when
 487       ;; they run out of entries.  The loop ends when there are no more input
 488       ;; lists left, i.e., when we've munched all of the input items.
 489       (lbuild-add lb winner)
 490       (setf lists (delete nil (mapcar (lambda (list)
 491                                         (if (funcall test winner (car list))
 492                                             (cdr list)
 493                                             list))
 494                                       lists))))))
 495
 496 (export 'categorize)
 497 (defmacro categorize ((itemvar items &key bind) categories &body body)
 498   "Categorize ITEMS into lists and invoke BODY.
 499
 500    The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
 501    will contain the current item.  The BIND argument is a list of LET*-like
 502    clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
 503    PREDICATE).
 504
 505    The behaviour of the macro is as follows.  ITEMVAR is assigned (not
 506    bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
 507    CATEGORIES list are evaluated in turn, in an environment containing
 508    ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
 509    At this point, the item is assigned to the category named by the
 510    corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
 511    error is signalled; a PREDICATE consisting only of T will (of course)
 512    match anything; it is detected specially so as to avoid compiler warnings.
 513
 514    Once all of the ITEMS have been categorized in this fashion, the BODY is
 515    evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
 516    variable named after that symbol will be bound in the BODY's environment
 517    to a list of the items in that category, in the same order in which they
 518    were found in the list ITEMS.  The final values of the macro are the final
 519    values of the BODY."
 520
 521   (let* ((cat-names (mapcar #'car categories))
 522          (cat-match-forms (mapcar #'cadr categories))
 523          (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string
 524                                                    (symbol-name name) "-")))
 525                            cat-names))
 526          (items-var (gensym "ITEMS-")))
 527     `(let ((,items-var ,items)
 528            ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
 529        (dolist (,itemvar ,items-var)
 530          (let* ,bind
 531            (cond ,@(mapcar (lambda (cat-match-form cat-var)
 532                              `(,cat-match-form
 533                                (push ,itemvar ,cat-var)))
 534                            cat-match-forms cat-vars)
 535                  ,@(and (not (member t cat-match-forms))
 536                         `((t (error "Failed to categorize ~A" ,itemvar)))))))
 537        (let ,(mapcar (lambda (name var)
 538                        `(,name (nreverse ,var)))
 539                      cat-names cat-vars)
 540          ,@body))))
 541
 542 ;;;--------------------------------------------------------------------------
 543 ;;; Strings and characters.
 544
 545 (export 'frob-identifier)
 546 (defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
 547   "Twiddles the case of STRING.
 548
 549    If all the letters in STRING are uppercase, and SWAP-CASE is true, then
 550    switch them to lowercase; if they're all lowercase then switch them to
 551    uppercase.  If there's a mix then leave them all alone.  At the same time,
 552    if there are underscores but no hyphens, and SWAP-HYPHEN is true, then
 553    switch them to hyphens, if there are hyphens and no underscores, switch
 554    them underscores, and if there are both then leave them alone.
 555
 556    This is an invertible transformation, which turns vaguely plausible Lisp
 557    names into vaguely plausible C names and vice versa.  Lisp names with
 558    `funny characters' like stars and percent signs won't be any use, of
 559    course."
 560
 561   ;; Work out what kind of a job we've got to do.  Gather flags: bit 0 means
 562   ;; there are upper-case letters; bit 1 means there are lower-case letters;
 563   ;; bit 2 means there are hyphens; bit 3 means there are underscores.
 564   ;;
 565   ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set
 566   ;; if we have to frob case; bit 3 is set if we have to swap hyphens and
 567   ;; underscores.  So use this to select functions which do bits of the
 568   ;; mapping, and then compose them together.
 569   (let* ((flags (reduce (lambda (state ch)
 570                           (logior state
 571                                   (cond ((upper-case-p ch) 1)
 572                                         ((lower-case-p ch) 2)
 573                                         ((char= ch #\-) 4)
 574                                         ((char= ch #\_) 8)
 575                                         (t 0))))
 576                         string
 577                         :initial-value 0))
 578          (mask (logxor flags (ash flags 1)))
 579          (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
 580                         (constantly nil))
 581                        ((logbitp 0 flags)
 582                         (lambda (ch)
 583                           (and (alpha-char-p ch) (char-downcase ch))))
 584                        (t
 585                         (lambda (ch)
 586                           (and (alpha-char-p ch) (char-upcase ch))))))
 587          (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
 588                                (constantly nil))
 589                               ((logbitp 2 flags)
 590                                (lambda (ch) (and (char= ch #\-) #\_)))
 591                               (t
 592                                (lambda (ch) (and (char= ch #\_) #\-))))))
 593
 594     (if (logbitp 3 (logior mask (ash mask 2)))
 595         (map 'string (lambda (ch)
 596                        (or (funcall letter ch)
 597                            (funcall uscore-hyphen ch)
 598                            ch))
 599              string)
 600         string)))
 601
 602 (export 'whitespace-char-p)
 603 (declaim (inline whitespace-char-p))
 604 (defun whitespace-char-p (char)
 605   "Returns whether CHAR is a whitespace character.
 606
 607    Whitespaceness is determined relative to the compile-time readtable, which
 608    is probably good enough for most purposes."
 609   (case char
 610     (#.(loop for i below char-code-limit
 611              for ch = (code-char i)
 612              unless (with-input-from-string (in (string ch))
 613                       (peek-char t in nil))
 614              collect ch) t)
 615     (t nil)))
 616
 617 (export 'update-position)
 618 (declaim (inline update-position))
 619 (defun update-position (char line column)
 620   "Updates LINE and COLUMN appropriately for having read the character CHAR.
 621
 622    Returns the new LINE and COLUMN numbers."
 623   (case char
 624     ((#\newline #\vt #\page)
 625      (values (1+ line) 0))
 626     ((#\tab)
 627      (values line (logandc2 (+ column 8) 7)))
 628     (t
 629      (values line (1+ column)))))
 630
 631 (export 'backtrack-position)
 632 (declaim (inline backtrack-position))
 633 (defun backtrack-position (char line column)
 634   "Updates LINE and COLUMN appropriately for having unread CHAR.
 635
 636    Well, actually an approximation for it; it will likely be wrong if the
 637    last character was a tab.  But when the character is read again, it will
 638    be correct."
 639
 640   ;; This isn't perfect: if the character doesn't actually match what was
 641   ;; really read then it might not actually be possible: for example, if we
 642   ;; push back a newline while in the middle of a line, or a tab while not at
 643   ;; a tab stop.  In that case, we'll just lose, but hopefully not too badly.
 644   (case char
 645
 646     ;; In the absence of better ideas, I'll set the column number to zero.
 647     ;; This is almost certainly wrong, but with a little luck nobody will ask
 648     ;; and it'll be all right soon.
 649     ((#\newline #\vt #\page) (values (1- line) 0))
 650
 651     ;; Winding back a single space is sufficient.  If the position is
 652     ;; currently on a tab stop then it'll advance back here next time.  If
 653     ;; not, we're going to lose anyway because the previous character
 654     ;; certainly couldn't have been a tab.
 655     (#\tab (values line (1- column)))
 656
 657     ;; Anything else: just decrement the column and cross fingers.
 658     (t (values line (1- column)))))
 659
 660 ;;;--------------------------------------------------------------------------
 661 ;;; Functions.
 662
 663 (export 'compose)
 664 (defun compose (function &rest more-functions)
 665   "Composition of functions.  Functions are applied left-to-right.
 666
 667    This is the reverse order of the usual mathematical notation, but I find
 668    it easier to read.  It's also slightly easier to work with in programs.
 669    That is, (compose F1 F2 ... Fn) is what a category theorist might write as
 670    F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn."
 671
 672   (labels ((compose1 (func-a func-b)
 673              (lambda (&rest args)
 674                (multiple-value-call func-b (apply func-a args)))))
 675     (reduce #'compose1 more-functions :initial-value function)))
 676
 677 ;;;--------------------------------------------------------------------------
 678 ;;; Symbols.
 679
 680 (export 'symbolicate)
 681 (defun symbolicate (&rest symbols)
 682   "Return a symbol named after the concatenation of the names of the SYMBOLS.
 683
 684    The symbol is interned in the current `*package*'.  Trad."
 685   (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
 686
 687 ;;;--------------------------------------------------------------------------
 688 ;;; Object printing.
 689
 690 (export 'maybe-print-unreadable-object)
 691 (defmacro maybe-print-unreadable-object
 692     ((object stream &rest args) &body body)
 693   "Print helper for usually-unreadable objects.
 694
 695    If `*print-escape*' is set then print OBJECT unreadably using BODY.
 696    Otherwise just print using BODY."
 697   (with-gensyms (print)
 698     `(flet ((,print () ,@body))
 699        (if *print-escape*
 700            (print-unreadable-object (,object ,stream ,@args)
 701              (,print))
 702            (,print)))))
 703
 704 ;;;--------------------------------------------------------------------------
 705 ;;; Iteration macros.
 706
 707 (export 'dosequence)
 708 (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
 709                       &body body
 710                       &environment env)
 711   "Macro for iterating over general sequences.
 712
 713    Iterates over a (sub)sequence SEQ, delimited by START and END (which are
 714    evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
 715    item, and INDEXVAR (if requested) bound to the item's index.  (Note that
 716    this is different from most iteration constructs in Common Lisp, which
 717    work by mutating the variable.)
 718
 719    The loop is surrounded by an anonymous BLOCK and the loop body forms an
 720    implicit TAGBODY, as is usual.  There is no result-form, however."
 721
 722   (once-only (:environment env seq start end)
 723     (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
 724
 725       (flet ((loopguts (indexp listp endvar)
 726                ;; Build a DO-loop to do what we want.
 727                (let* ((do-vars nil)
 728                       (end-condition (if endvar
 729                                          `(>= ,ivar ,endvar)
 730                                          `(endp ,seq)))
 731                       (item (if listp
 732                                 `(car ,seq)
 733                                 `(aref ,seq ,ivar)))
 734                       (body-call `(,bodyfunc ,item)))
 735                  (when listp
 736                    (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
 737                          do-vars))
 738                  (when indexp
 739                    (push `(,ivar ,start (1+ ,ivar)) do-vars))
 740                  (when indexvar
 741                    (setf body-call (append body-call (list ivar))))
 742                  `(do ,do-vars (,end-condition) ,body-call))))
 743
 744         `(block nil
 745            (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
 746                     (tagbody ,@body)))
 747                (etypecase ,seq
 748                  (vector
 749                   (let ((,endvar (or ,end (length ,seq))))
 750                     ,(loopguts t nil endvar)))
 751                  (list
 752                   (if ,end
 753                       ,(loopguts t t end)
 754                       ,(loopguts indexvar t nil))))))))))
 755
 756 ;;;--------------------------------------------------------------------------
 757 ;;; Structure accessor hacks.
 758
 759 (export 'define-access-wrapper)
 760 (defmacro define-access-wrapper (from to &key read-only)
 761   "Make (FROM THING) work like (TO THING).
 762
 763    If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like
 764    (setf (TO THING) VALUE).
 765
 766    This is mostly useful for structure slot accessors where the slot has to
 767    be given an unpleasant name to avoid it being an external symbol."
 768   `(progn
 769      (declaim (inline ,from ,@(and (not read-only) `((setf ,from)))))
 770      (defun ,from (object)
 771        (,to object))
 772      ,@(and (not read-only)
 773             `((defun (setf ,from) (value object)
 774                 (setf (,to object) value))))))
 775
 776 ;;;--------------------------------------------------------------------------
 777 ;;; CLOS hacking.
 778
 779 (export 'default-slot)
 780 (defmacro default-slot ((instance slot &optional (slot-names t))
 781                           &body value
 782                           &environment env)
 783   "If INSTANCE's slot named SLOT is unbound, set it to VALUE.
 784
 785    Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we
 786    obey the `shared-initialize' protocol).  SLOT-NAMES defaults to `t', so
 787    you can use it in `initialize-instance' or similar without ill effects.
 788    Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
 789    evaluated if it's needed."
 790
 791   (once-only (:environment env instance slot slot-names)
 792     `(when ,(if (eq slot-names t)
 793                   `(not (slot-boundp ,instance ,slot))
 794                   `(and (not (slot-boundp ,instance ,slot))
 795                         (or (eq ,slot-names t)
 796                             (member ,slot ,slot-names))))
 797        (setf (slot-value ,instance ,slot)
 798              (progn ,@value)))))
 799
 800 (export 'define-on-demand-slot)
 801 (defmacro define-on-demand-slot (class slot (instance) &body body)
 802   "Defines a slot which computes its initial value on demand.
 803
 804    Sets up the named SLOT of CLASS to establish its value as the implicit
 805    progn BODY, by defining an appropriate method on `slot-unbound'."
 806   (with-gensyms (classvar slotvar)
 807     `(defmethod slot-unbound
 808          (,classvar (,instance ,class) (,slotvar (eql ',slot)))
 809        (declare (ignore ,classvar))
 810        (setf (slot-value ,instance ',slot) (progn ,@body)))))
 811
 812 ;;;----- That's all, folks --------------------------------------------------