Abandoned atoms work: hardly any performance benefit.

[sod] / src / utilities.lisp

;;; -*-lisp-*-
;;;
;;; Various handy utilities
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:defpackage #:sod-utilities
  (:use #:common-lisp

	;; MOP from somewhere.
	#+sbcl #:sb-mop
	#+(or cmu clisp) #:mop
	#+ecl #:clos))

(cl:in-package #:sod-utilities)

;;;--------------------------------------------------------------------------
;;; Macro hacks.

(export 'with-gensyms)
(defmacro with-gensyms ((&rest binds) &body body)
  "Evaluate BODY with variables bound to fresh symbols.

   The BINDS are a list of entries (VAR [NAME]), and a singleton list can be
   replaced by just a symbol; each VAR is bound to a fresh symbol generated
   by (gensym NAME), where NAME defaults to the symbol-name of VAR."
  `(let (,@(mapcar (lambda (bind)
		     (multiple-value-bind (var name)
			 (if (atom bind)
			     (values bind (concatenate 'string
					   (symbol-name bind) "-"))
			     (destructuring-bind
				 (var &optional
				      (name (concatenate 'string
					     (symbol-name var) "-")))
				 bind
			       (values var name)))
		       `(,var (gensym ,name))))
		   binds))
     ,@body))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun strip-quote (form)
    "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO.

   If FORM is a symbol whose constant value is `nil' then return `nil'.
   Otherwise return FORM unchanged.  This makes it easier to inspect constant
   things.  This is a utility for `once-only'."

    (cond ((and (consp form)
		(eq (car form) 'quote)
		(cdr form)
		(null (cddr form)))
	   (let ((body (cadr form)))
	     (if (or (not (or (consp body) (symbolp body)))
		     (member body '(t nil))
		     (keywordp body))
		 body
		 form)))
	  ((and (symbolp form) (boundp form) (null (symbol-value form)))
	   nil)
	  (t
	   form))))

(export 'once-only)
(defmacro once-only ((&rest binds) &body body)
  "Macro helper for preventing repeated evaluation.

   The syntax is actually hairier than shown:

	once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* )
	  { FORM }*

   So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list
   can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR.
   But before them you can have keyword arguments.  Only one is defined so
   far.  See below for the crazy things that does.

   The result of evaluating a ONCE-ONLY form is a form with the structure

	(let ((#:GS1 VALUE-FORM1)
	      ...
	      (#:GSn VALUE-FORMn))
	  STUFF)

   where STUFF is the value of the BODY forms, as an implicit progn, in an
   environment with the VARs bound to the corresponding gensyms.

   As additional magic, if any of the VALUE-FORMs is actually constant (as
   determined by inspection, and aided by `constantp' if an :environment is
   supplied, then no gensym is constructed for it, and the VAR is bound
   directly to the constant form.  Moreover, if the constant form looks like
   (quote FOO) for a self-evaluating FOO then the outer layer of quoting is
   stripped away."

  ;; We need an extra layer of gensyms in our expansion: we'll want the
  ;; expansion to examine the various VALUE-FORMs to find out whether they're
  ;; constant without evaluating them repeatedly.  This also helps with
  ;; another problem: we explicitly encourage the rebinding of a VAR
  ;; (probably a macro argument) to a gensym which will be bound to the value
  ;; of the form previously held in VAR itself -- so the gensym and value
  ;; form must exist at the same time and we need two distinct variables.

  (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-"))
    (let ((env nil))

      ;; First things first: let's pick up the keywords.
      (loop
	(unless (and binds (keywordp (car binds)))
	  (return))
	(ecase (pop binds)
	  (:environment (setf env (pop binds)))))

      ;; Now we'll investigate the bindings.  Turn each one into a list (VAR
      ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note
      ;; above.
      (let ((canon (mapcar (lambda (bind)
			     (multiple-value-bind (var form)
				 (if (atom bind)
				     (values bind bind)
				     (destructuring-bind
					 (var &optional (form var)) bind
				       (values var form)))
			       (list var form
				     (gensym (format nil "T-~A-"
						     (symbol-name var))))))
			   binds)))

	`(let* (,@(and env `((,envvar ,env)))
		(,lets nil)
		,@(mapcar (lambda (bind)
			    (destructuring-bind (var form temp) bind
			      (declare (ignore var))
			      `(,temp ,form)))
			  canon)
		,@(mapcar (lambda (bind)
			    (destructuring-bind (var form temp) bind
			      (declare (ignore form))
			      `(,var
				(cond ((constantp ,temp
						  ,@(and env `(,envvar)))
				       (strip-quote ,temp))
				      ((symbolp ,temp)
				       ,temp)
				      (t
				       (let ((,sym (gensym
						    ,(concatenate 'string
						      (symbol-name var)
						      "-"))))
					 (push (list ,sym ,temp) ,lets)
					 ,sym))))))
			  canon))
	   (flet ((,bodyfunc () ,@body))
	     (if ,lets
		 `(let (,@(nreverse ,lets)) ,(,bodyfunc))
		 (,bodyfunc))))))))

(export 'parse-body)
(defun parse-body (body &key (docp t) (declp t))
  "Parse the BODY into a docstring, declarations and the body forms.

   These are returned as three lists, so that they can be spliced into a
   macro expansion easily.  The declarations are consolidated into a single
   `declare' form.  If DOCP is nil then a docstring is not permitted; if
   DECLP is nil, then declarations are not permitted."
  (let ((decls nil)
	(doc nil))
    (loop
      (cond ((null body) (return))
	    ((and declp (consp (car body)) (eq (caar body) 'declare))
	     (setf decls (append decls (cdr (pop body)))))
	    ((and docp (stringp (car body)) (not doc) (cdr body))
	     (setf doc (pop body)))
	    (t (return))))
    (values (and doc (list doc))
	    (and decls (list (cons 'declare decls)))
	    body)))

;;;--------------------------------------------------------------------------
;;; Locatives.

(export '(loc locp))
(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
  "Locative data type.  See `locf' and `ref'."
  (reader nil :type function)
  (writer nil :type function))

(export 'locf)
(defmacro locf (place &environment env)
  "Slightly cheesy locatives.

   (locf PLACE) returns an object which, using the `ref' function, can be
   used to read or set the value of PLACE.  It's cheesy because it uses
   closures rather than actually taking the address of something.  Also,
   unlike Zetalisp, we don't overload `car' to do our dirty work."
  (multiple-value-bind
      (valtmps valforms newtmps setform getform)
      (get-setf-expansion place env)
    `(let* (,@(mapcar #'list valtmps valforms))
       (make-loc (lambda () ,getform)
		 (lambda (,@newtmps) ,setform)))))

(export 'ref)
(declaim (inline ref (setf ref)))
(defun ref (loc)
  "Fetch the value referred to by a locative."
  (funcall (loc-reader loc)))
(defun (setf ref) (new loc)
  "Store a new value in the place referred to by a locative."
  (funcall (loc-writer loc) new))

(export 'with-locatives)
(defmacro with-locatives (locs &body body)
  "Evaluate BODY with implicit locatives.

   LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
   symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
   defaults to SYM.  As an abbreviation for a common case, LOCS may be a
   symbol instead of a list.

   The BODY is evaluated in an environment where each SYM is a symbol macro
   which expands to (ref LOC-EXPR) -- or, in fact, something similar which
   doesn't break if LOC-EXPR has side-effects.  Thus, references, including
   `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
   Useful for covering over where something uses a locative."
  (setf locs (mapcar (lambda (item)
		       (cond ((atom item) (list item item))
			     ((null (cdr item)) (list (car item) (car item)))
			     (t item)))
		     (if (listp locs) locs (list locs))))
  (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
	(ll (mapcar #'cadr locs))
	(ss (mapcar #'car locs)))
    `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
       (symbol-macrolet (,@(mapcar (lambda (sym tmp)
				     `(,sym (ref ,tmp))) ss tt))
	 ,@body))))

;;;--------------------------------------------------------------------------
;;; Anaphorics.

(export 'it)

(export 'aif)
(defmacro aif (cond cons &optional (alt nil altp))
  "If COND is not nil, evaluate CONS with `it' bound to the value of COND.

   Otherwise, if given, evaluate ALT; `it' isn't bound in ALT."
  (once-only (cond)
    `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt)))))

(export 'awhen)
(defmacro awhen (cond &body body)
  "If COND, evaluate BODY as a progn with `it' bound to the value of COND."
  `(let ((it ,cond)) (when it ,@body)))

(export 'aand)
(defmacro aand (&rest forms)
  "Like `and', but anaphoric.

   Each FORM except the first is evaluated with `it' bound to the value of
   the previous one.  If there are no forms, then the result it `t'; if there
   is exactly one, then wrapping it in `aand' is pointless."
  (labels ((doit (first rest)
	     (if (null rest)
		 first
		 `(let ((it ,first))
		    (if it ,(doit (car rest) (cdr rest)) nil)))))
    (if (null forms)
	't
	(doit (car forms) (cdr forms)))))

(export 'acond)
(defmacro acond (&body clauses &environment env)
  "Like COND, but with `it' bound to the value of the condition.

   Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is
   non-nil then evaluate the FORMs with `it' bound to the non-nil value, and
   return the value of the last FORM; if there are no FORMs, then return `it'
   itself.  If the CONDITION is nil then continue with the next clause; if
   all clauses evaluate to nil then the result is nil."
  (labels ((walk (clauses)
	     (if (null clauses)
		 `nil
		 (once-only (:environment env (cond (caar clauses)))
		   (if (and (constantp cond)
			    (if (and (consp cond) (eq (car cond) 'quote))
				(cadr cond) cond))
		       (if (cdar clauses)
			   `(let ((it ,cond))
			      (declare (ignorable it))
			      ,@(cdar clauses))
			   cond)
		       `(if ,cond
			    ,(if (cdar clauses)
				 `(let ((it ,cond))
				    (declare (ignorable it))
				    ,@(cdar clauses))
				 cond)
			    ,(walk (cdr clauses))))))))
    (walk clauses)))

(export '(acase aecase atypecase aetypecase))
(defmacro acase (value &body clauses)
  `(let ((it ,value)) (case it ,@clauses)))
(defmacro aecase (value &body clauses)
  `(let ((it ,value)) (ecase it ,@clauses)))
(defmacro atypecase (value &body clauses)
  `(let ((it ,value)) (typecase it ,@clauses)))
(defmacro aetypecase (value &body clauses)
  `(let ((it ,value)) (etypecase it ,@clauses)))

(export 'asetf)
(defmacro asetf (&rest places-and-values &environment env)
  "Anaphoric update of places.

   The PLACES-AND-VALUES are alternating PLACEs and VALUEs.  Each VALUE is
   evaluated with IT bound to the current value stored in the corresponding
   PLACE."
  `(progn ,@(loop for (place value) on places-and-values by #'cddr
		  collect (multiple-value-bind
			      (temps inits newtemps setform getform)
			      (get-setf-expansion place env)
			    `(let* (,@(mapcar #'list temps inits)
				    (it ,getform))
			       (multiple-value-bind ,newtemps ,value
				 ,setform))))))

;;;--------------------------------------------------------------------------
;;; MOP hacks (not terribly demanding).

(export 'instance-initargs)
(defgeneric instance-initargs (instance)
  (:documentation
   "Return a plausble list of initargs for INSTANCE.

   The idea is that you can make a copy of INSTANCE by invoking

	(apply #'make-instance (class-of INSTANCE)
	       (instance-initargs INSTANCE))

   The default implementation works by inspecting the slot definitions and
   extracting suitable initargs, so this will only succeed if enough slots
   actually have initargs specified that `initialize-instance' can fill in
   the rest correctly.

   The list returned is freshly consed, and you can destroy it if you like.")
  (:method ((instance standard-object))
    (mapcan (lambda (slot)
	      (aif (slot-definition-initargs slot)
		   (list (car it)
			 (slot-value instance (slot-definition-name slot)))
		   nil))
	    (class-slots (class-of instance)))))

(export '(copy-instance copy-instance-using-class))
(defgeneric copy-instance-using-class (class instance &rest initargs)
  (:documentation
   "Metaobject protocol hook for `copy-instance'.")
  (:method ((class standard-class) instance &rest initargs)
    (let ((copy (allocate-instance class)))
      (dolist (slot (class-slots class))
	(let ((name (slot-definition-name slot)))
	  (when (slot-boundp instance name)
	    (setf (slot-value copy name) (slot-value instance name)))))
      (apply #'shared-initialize copy nil initargs))))
(defun copy-instance (object &rest initargs)
  "Construct and return a copy of OBJECT.

   The new object has the same class as OBJECT, and the same slot values
   except where overridden by INITARGS."
  (apply #'copy-instance-using-class (class-of object) object initargs))

(export '(generic-function-methods method-specializers
	  eql-specializer eql-specializer-object))

;;;--------------------------------------------------------------------------
;;; List utilities.

(export 'make-list-builder)
(defun make-list-builder (&optional initial)
  "Return a simple list builder."

  ;; The `builder' is just a cons cell whose cdr will be the list that's
  ;; wanted.  Effectively, then, we have a list that's one item longer than
  ;; we actually want.  The car of this extra initial cons cell is always the
  ;; last cons in the list -- which is now well defined because there's
  ;; always at least one.

  (let ((builder (cons nil initial)))
    (setf (car builder) (last builder))
    builder))

(export 'lbuild-add)
(defun lbuild-add (builder item)
  "Add an ITEM to the end of a list BUILDER."
  (let ((new (cons item nil)))
    (setf (cdar builder) new
	  (car builder) new))
  builder)

(export 'lbuild-add-list)
(defun lbuild-add-list (builder list)
  "Add a LIST to the end of a list BUILDER.  The LIST will be clobbered."
  (when list
    (setf (cdar builder) list
	  (car builder) (last list)))
  builder)

(export 'lbuild-list)
(defun lbuild-list (builder)
  "Return the constructed list."
  (cdr builder))

(export 'mappend)
(defun mappend (function list &rest more-lists)
  "Like a nondestructive `mapcan'.

   Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
   and return the result of appending all of the resulting lists."
  (reduce #'append (apply #'mapcar function list more-lists) :from-end t))

(export 'distinguished-point-shortest-paths)
(defun distinguished-point-shortest-paths (root neighbours-func)
  "Moderately efficient shortest-paths-from-root computation.

   The ROOT is a distinguished vertex in a graph.  The NEIGHBOURS-FUNC
   accepts a VERTEX as its only argument, and returns a list of conses (V .
   C) for each of the VERTEX's neighbours, indicating that there is an edge
   from VERTEX to V, with cost C.

   The return value is a list of entries (COST . REV-PATH) for each vertex
   reachable from the ROOT; the COST is the total cost of the shortest path,
   and REV-PATH is the path from the ROOT, in reverse order -- so the first
   element is the vertex itself and the last element is the ROOT.

   The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
   produce its output list.  The computation as a whole takes O(N^2) time,
   where N is the number of vertices in the graph, assuming there is at most
   one edge between any pair of vertices."

  ;; This is a listish version of Dijkstra's shortest-path algorithm.  It
  ;; could be made more efficient by using a fancy priority queue rather than
  ;; a linear search for finding the nearest live element (see below), but it
  ;; still runs pretty well.

  (let ((map (make-hash-table))
	(dead nil)
	(live (list (list 0 root))))
    (setf (gethash root map) (cons :live (car live)))
    (loop
      ;; The dead list contains a record, in output format (COST . PATH), for
      ;; each vertex whose shortest path has been finally decided.  The live
      ;; list contains a record for the vertices of current interest, also in
      ;; output format; the COST for a live record shows the best cost for a
      ;; path using only dead vertices.
      ;;
      ;; Each time through here, we pull an item off the live list and
      ;; push it onto the dead list, so we do at most N iterations total.

      ;; If there are no more live items, then we're done; the remaining
      ;; vertices, if any, are unreachable from the ROOT.
      (when (null live) (return))

      ;; Find the closest live vertex to the root.  The linear scan through
      ;; the live list costs at most N time.
      (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
	     (best-cost (car best))
	     (best-path (cdr best))
	     (best-vertex (car best-path)))

	;; Remove the chosen vertex from the LIVE list, and add the
	;; appropriate record to the dead list.  We must have the shortest
	;; path to this vertex now: we have the shortest path using currently
	;; dead vertices; any other path must use at least one live vertex,
	;; and, by construction, the path through any such vertex must be
	;; further than the path we already have.
	;;
	;; Removal from the live list uses a linear scan which costs N time.
	(setf live (delete best live))
	(push best dead)
	(setf (car (gethash best-vertex map)) :dead)

	;; Work through the chosen vertex's neighbours, adding each of them
	;; to the live list if they're not already there.  If a neighbour is
	;; already live, and we find a shorter path to it through our chosen
	;; vertex, then update the neighbour's record.
	;;
	;; The chosen vertex obviously has at most N neighbours.  There's no
	;; more looping in here, so performance is as claimed.
	(dolist (neigh (funcall neighbours-func best-vertex))
	  (let* ((neigh-vertex (car neigh))
		 (neigh-cost (+ best-cost (cdr neigh)))
		 (neigh-record (gethash neigh-vertex map)))
	    (cond ((null neigh-record)
		   ;; If the neighbour isn't known, then now's the time to
		   ;; make a fresh live record for it.
		   (let ((new-record (list* :live neigh-cost
					    neigh-vertex best-path)))
		     (push (cdr new-record) live)
		     (setf (gethash neigh-vertex map) new-record)))
		  ((and (eq (car neigh-record) :live)
			(< neigh-cost (cadr neigh-record)))
		   ;; If the neighbour is live, and we've found a better path
		   ;; to it, then update its record.
		   (setf (cadr neigh-record) neigh-cost
			 (cdddr neigh-record) best-path)))))))
    dead))

(export '(inconsistent-merge-error
	  merge-error-candidates merge-error-present-function))
(define-condition inconsistent-merge-error (error)
  ((candidates :initarg :candidates
	       :reader merge-error-candidates)
   (present :initarg :present :initform #'identity
	    :reader merge-error-present-function))
  (:documentation
   "Reports an inconsistency in the arguments passed to `merge-lists'.")
  (:report (lambda (condition stream)
	     (format stream "Merge inconsistency: failed to decide between ~
			     ~{~#[~;~A~;~A and ~A~:;~
				  ~@{~A, ~#[~;and ~A~]~}~]~}"
		     (mapcar (merge-error-present-function condition)
			     (merge-error-candidates condition))))))

(export 'merge-lists)
(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
  "Return a merge of the given LISTS.

   The resulting list contains the items of the given LISTS, with duplicates
   removed.  The order of the resulting list is consistent with the orders of
   the input LISTS in the sense that if A precedes B in some input list then
   A will also precede B in the output list.  If the lists aren't consistent
   (e.g., some list contains A followed by B, and another contains B followed
   by A) then an error of type `inconsistent-merge-error' is signalled.  The
   offending items are filtered for presentation through the PRESENT function
   before being attached to the condition, so as to produce a more useful
   diagnostic message.

   Item equality is determined by TEST.

   If there is an ambiguity at any point -- i.e., a choice between two or
   more possible next items to emit -- then PICK is called to arbitrate.
   PICK is called with two arguments: the list of candidate next items, and
   the current output list.  It should return one of the candidate items.
   The order of the candidates in the list given to the PICK function
   reflects their order in the input LISTS: item A will precede item B in the
   candidates list if and only if an occurrence of A appears in an earlier
   input list than any occurrence of item B.  (This completely determines the
   order of the candidates: it is not possible that two candidates appear in
   the same input list, since that would resolve the ambiguity between them.)
   If PICK is omitted then the item chosen is the one appearing in the
   earliest of the input lists: i.e., effectively, the default PICK function
   is

	(lambda (candidates output-so-far)
	  (declare (ignore output-so-far))
	  (car candidates))

   The primary use of this function is in computing class precedence lists.
   By building the input lists and selecting the PICK function appropriately,
   a variety of different CPL algorithms can be implemented."

  (do ((lb (make-list-builder)))
      ((null lists) (lbuild-list lb))

    ;; The candidate items are the ones at the front of the input lists.
    ;; Gather them up, removing duplicates.  If a candidate is somewhere in
    ;; one of the other lists other than at the front then we reject it.  If
    ;; we've just rejected everything, then we can make no more progress and
    ;; the input lists were inconsistent.
    (let* ((candidates (delete-duplicates (mapcar #'car lists)
					  :test test :from-end t))
	   (leasts (remove-if (lambda (item)
				(some (lambda (list)
					(member item (cdr list) :test test))
				      lists))
			      candidates))
	   (winner (cond ((null leasts)
			  (error 'inconsistent-merge-error
				 :candidates candidates
				 :present present))
			 ((null (cdr leasts))
			  (car leasts))
			 (pick
			  (funcall pick leasts (lbuild-list lb)))
			 (t (car leasts)))))

      ;; Check that the PICK function isn't conning us.
      (assert (member winner leasts :test test))

      ;; Update the output list and remove the winning item from the input
      ;; lists.  We know that it must be at the front of each input list
      ;; containing it.  At this point, we discard input lists entirely when
      ;; they run out of entries.  The loop ends when there are no more input
      ;; lists left, i.e., when we've munched all of the input items.
      (lbuild-add lb winner)
      (setf lists (delete nil (mapcar (lambda (list)
					(if (funcall test winner (car list))
					    (cdr list)
					    list))
				      lists))))))

(export 'categorize)
(defmacro categorize ((itemvar items &key bind) categories &body body)
  "Categorize ITEMS into lists and invoke BODY.

   The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
   will contain the current item.  The BIND argument is a list of LET*-like
   clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
   PREDICATE).

   The behaviour of the macro is as follows.  ITEMVAR is assigned (not
   bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
   CATEGORIES list are evaluated in turn, in an environment containing
   ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
   At this point, the item is assigned to the category named by the
   corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
   error is signalled; a PREDICATE consisting only of T will (of course)
   match anything; it is detected specially so as to avoid compiler warnings.

   Once all of the ITEMS have been categorized in this fashion, the BODY is
   evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
   variable named after that symbol will be bound in the BODY's environment
   to a list of the items in that category, in the same order in which they
   were found in the list ITEMS.  The final values of the macro are the final
   values of the BODY."

  (let* ((cat-names (mapcar #'car categories))
	 (cat-match-forms (mapcar #'cadr categories))
	 (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string
						   (symbol-name name) "-")))
			   cat-names))
	 (items-var (gensym "ITEMS-")))
    `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
       (let ((,items-var ,items))
	 (dolist (,itemvar ,items-var)
	   (let* ,bind
	     (cond ,@(mapcar (lambda (cat-match-form cat-var)
			       `(,cat-match-form
				 (push ,itemvar ,cat-var)))
			     cat-match-forms cat-vars)
		   ,@(and (not (member t cat-match-forms))
			  `((t (error "Failed to categorize ~A"
				      ,itemvar))))))))
       (let ,(mapcar (lambda (name var)
		       `(,name (nreverse ,var)))
		     cat-names cat-vars)
	 ,@body))))

(export 'partial-order-minima)
(defun partial-order-minima (items order)
  "Return a list of minimal items according to the non-strict partial ORDER.

   The ORDER function describes the partial order: (funcall ORDER X Y) should
   return true if X precedes or is equal to Y in the order."
  (reduce (lambda (tops this)
	    (let ((new nil) (keep t))
	      (dolist (top tops)
		(cond ((funcall order top this)
		       (setf keep nil)
		       (push top new))
		      ((not (funcall order this top))
		       (push top new))))
	      (nreverse (if keep (cons this new) new))))
	  items
	  :initial-value nil))

(export 'find-duplicates)
(defun find-duplicates (report sequence &key (key #'identity) (test #'eql))
  "Call REPORT on each pair of duplicate items in SEQUENCE.

   Duplicates are determined according to the KEY and TEST funcitons."
  (when (symbolp test) (setf test (symbol-function test)))
  (cond ((zerop (length sequence)) nil)
	((or (eq test #'eq)
	     (eq test #'eql)
	     (eq test #'equal)
	     (eq test #'equalp))
	 (let ((seen (make-hash-table :test test)))
	   (map nil (lambda (item)
		      (let ((k (funcall key item)))
			(multiple-value-bind (previous matchp)
			    (gethash k seen)
			  (if matchp (funcall report item previous)
			      (setf (gethash k seen) item)))))
		sequence)))
	((listp sequence)
	 (mapl (lambda (tail)
		 (let* ((item (car tail))
			(rest (cdr tail))
			(match (member (funcall key item) rest
				       :test test :key key)))
		   (when match (funcall report item (car match)))))
	       sequence))
	((vectorp sequence)
	 (dotimes (i (length sequence))
	   (let* ((item (aref sequence i))
		  (pos (position (funcall key item) sequence
				 :key key :test test :start (1+ i))))
	     (when pos (funcall report item (aref sequence pos))))))
	(t
	 (error 'type-error :datum sequence :expected-type 'sequence))))

;;;--------------------------------------------------------------------------
;;; Strings and characters.

(export 'frob-identifier)
(defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
  "Twiddles the case of STRING.

   If all the letters in STRING are uppercase, and SWAP-CASE is true, then
   switch them to lowercase; if they're all lowercase then switch them to
   uppercase.  If there's a mix then leave them all alone.  At the same time,
   if there are underscores but no hyphens, and SWAP-HYPHEN is true, then
   switch them to hyphens, if there are hyphens and no underscores, switch
   them underscores, and if there are both then leave them alone.

   This is an invertible transformation, which turns vaguely plausible Lisp
   names into vaguely plausible C names and vice versa.  Lisp names with
   `funny characters' like stars and percent signs won't be any use, of
   course."

  ;; Work out what kind of a job we've got to do.  Gather flags: bit 0 means
  ;; there are upper-case letters; bit 1 means there are lower-case letters;
  ;; bit 2 means there are hyphens; bit 3 means there are underscores.
  ;;
  ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set
  ;; if we have to frob case; bit 3 is set if we have to swap hyphens and
  ;; underscores.  So use this to select functions which do bits of the
  ;; mapping, and then compose them together.
  (let* ((flags (reduce (lambda (state ch)
			  (logior state
				  (cond ((upper-case-p ch) 1)
					((lower-case-p ch) 2)
					((char= ch #\-) 4)
					((char= ch #\_) 8)
					(t 0))))
			string
			:initial-value 0))
	 (mask (logxor flags (ash flags 1)))
	 (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
			(constantly nil))
		       ((logbitp 0 flags)
			(lambda (ch)
			  (and (alpha-char-p ch) (char-downcase ch))))
		       (t
			(lambda (ch)
			  (and (alpha-char-p ch) (char-upcase ch))))))
	 (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
			       (constantly nil))
			      ((logbitp 2 flags)
			       (lambda (ch) (and (char= ch #\-) #\_)))
			      (t
			       (lambda (ch) (and (char= ch #\_) #\-))))))

    (if (logbitp 3 (logior mask (ash mask 2)))
	(map 'string (lambda (ch)
		       (or (funcall letter ch)
			   (funcall uscore-hyphen ch)
			   ch))
	     string)
	string)))

(export 'whitespace-char-p)
(declaim (inline whitespace-char-p))
(defun whitespace-char-p (char)
  "Returns whether CHAR is a whitespace character.

   Whitespaceness is determined relative to the compile-time readtable, which
   is probably good enough for most purposes."
  (case char
    (#.(loop for i below char-code-limit
	     for ch = (code-char i)
	     unless (with-input-from-string (in (string ch))
		      (peek-char t in nil))
	     collect ch) t)
    (t nil)))

(export 'update-position)
(declaim (inline update-position))
(defun update-position (char line column)
  "Updates LINE and COLUMN appropriately for having read the character CHAR.

   Returns the new LINE and COLUMN numbers."
  (case char
    ((#\newline #\vt #\page)
     (values (1+ line) 0))
    ((#\tab)
     (values line (logandc2 (+ column 8) 7)))
    (t
     (values line (1+ column)))))

(export 'backtrack-position)
(declaim (inline backtrack-position))
(defun backtrack-position (char line column)
  "Updates LINE and COLUMN appropriately for having unread CHAR.

   Well, actually an approximation for it; it will likely be wrong if the
   last character was a tab.  But when the character is read again, it will
   be correct."

  ;; This isn't perfect: if the character doesn't actually match what was
  ;; really read then it might not actually be possible: for example, if we
  ;; push back a newline while in the middle of a line, or a tab while not at
  ;; a tab stop.  In that case, we'll just lose, but hopefully not too badly.
  (case char

    ;; In the absence of better ideas, I'll set the column number to zero.
    ;; This is almost certainly wrong, but with a little luck nobody will ask
    ;; and it'll be all right soon.
    ((#\newline #\vt #\page) (values (1- line) 0))

    ;; Winding back a single space is sufficient.  If the position is
    ;; currently on a tab stop then it'll advance back here next time.  If
    ;; not, we're going to lose anyway because the previous character
    ;; certainly couldn't have been a tab.
    (#\tab (values line (1- column)))

    ;; Anything else: just decrement the column and cross fingers.
    (t (values line (1- column)))))

;;;--------------------------------------------------------------------------
;;; Functions.

(export 'compose)
(defun compose (function &rest more-functions)
  "Composition of functions.  Functions are applied left-to-right.

   This is the reverse order of the usual mathematical notation, but I find
   it easier to read.  It's also slightly easier to work with in programs.
   That is, (compose F1 F2 ... Fn) is what a category theorist might write as
   F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn."

  (labels ((compose1 (func-a func-b)
	     (lambda (&rest args)
	       (multiple-value-call func-b (apply func-a args)))))
    (reduce #'compose1 more-functions :initial-value function)))

;;;--------------------------------------------------------------------------
;;; Variables.

(export 'defvar-unbound)
(defmacro defvar-unbound (var doc)
  "Make VAR a special variable with documentation DOC, but leave it unbound."
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (defvar ,var)
     (setf (documentation ',var 'variable) ',doc)
     ',var))

;;;--------------------------------------------------------------------------
;;; Symbols.

(export 'symbolicate)
(defun symbolicate (&rest symbols)
  "Return a symbol named after the concatenation of the names of the SYMBOLS.

   The symbol is interned in the current `*package*'.  Trad."
  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))

;;;--------------------------------------------------------------------------
;;; Object printing.

(export 'maybe-print-unreadable-object)
(defmacro maybe-print-unreadable-object
    ((object stream &rest args) &body body)
  "Print helper for usually-unreadable objects.

   If `*print-escape*' is set then print OBJECT unreadably using BODY.
   Otherwise just print using BODY."
  (with-gensyms (print)
    `(flet ((,print () ,@body))
       (if *print-escape*
	   (print-unreadable-object (,object ,stream ,@args)
	     (,print))
	   (,print)))))

(export 'print-ugly-stuff)
(defun print-ugly-stuff (stream func)
  "Print not-pretty things to the stream underlying STREAM.

   The Lisp pretty-printing machinery, notably `pprint-logical-block', may
   interpose additional streams between its body and the original target
   stream.  This makes it difficult to make use of the underlying stream's
   special features, whatever they might be."

  ;; This is unpleasant.  Hacky hacky.
  #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream)
		  (let ((target (sb-pretty::pretty-stream-target stream)))
		    (pprint-newline :mandatory stream)
		    (funcall func target))
		  (funcall func stream))
	#+cmu '(if (typep stream 'pp:pretty-stream)
		  (let ((target (pp::pretty-stream-target stream)))
		    (pprint-newline :mandatory stream)
		    (funcall func target))
		  (funcall func stream))
	'(funcall func stream)))

;;;--------------------------------------------------------------------------
;;; Iteration macros.

(export 'dosequence)
(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
		      &body body
		      &environment env)
  "Macro for iterating over general sequences.

   Iterates over a (sub)sequence SEQ, delimited by START and END (which are
   evaluated).  For each item of SEQ, BODY is invoked with VAR bound to the
   item, and INDEXVAR (if requested) bound to the item's index.  (Note that
   this is different from most iteration constructs in Common Lisp, which
   work by mutating the variable.)

   The loop is surrounded by an anonymous BLOCK and the loop body forms an
   implicit TAGBODY, as is usual.  There is no result-form, however."

  (once-only (:environment env seq start end)
    (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
      (multiple-value-bind (docs decls body) (parse-body body :docp nil)
	(declare (ignore docs))

	(flet ((loopguts (indexp listp endvar)
		 ;; Build a DO-loop to do what we want.
		 (let* ((do-vars nil)
			(end-condition (if endvar
					   `(>= ,ivar ,endvar)
					   `(endp ,seq)))
			(item (if listp
				  `(car ,seq)
				  `(aref ,seq ,ivar)))
			(body-call `(,bodyfunc ,item)))
		   (when listp
		     (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
			   do-vars))
		   (when indexp
		     (push `(,ivar ,start (1+ ,ivar)) do-vars))
		   (when indexvar
		     (setf body-call (append body-call (list ivar))))
		   `(do ,do-vars (,end-condition) ,body-call))))

	  `(block nil
	     (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
		      ,@decls
		      (tagbody ,@body)))
	       (etypecase ,seq
		 (vector
		  (let ((,endvar (or ,end (length ,seq))))
		    ,(loopguts t nil endvar)))
		 (list
		  (if ,end
		      ,(loopguts t t end)
		      ,(loopguts indexvar t nil)))))))))))

;;;--------------------------------------------------------------------------
;;; Structure accessor hacks.

(export 'define-access-wrapper)
(defmacro define-access-wrapper (from to &key read-only)
  "Make (FROM THING) work like (TO THING).

   If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like
   (setf (TO THING) VALUE).

   This is mostly useful for structure slot accessors where the slot has to
   be given an unpleasant name to avoid it being an external symbol."
  `(progn
     (declaim (inline ,from ,@(and (not read-only) `((setf ,from)))))
     (defun ,from (object)
       (,to object))
     ,@(and (not read-only)
	    `((defun (setf ,from) (value object)
		(setf (,to object) value))))))

;;;--------------------------------------------------------------------------
;;; Condition and error utilities.

(export 'designated-condition)
(defun designated-condition (default-type datum arguments
			     &key allow-pointless-arguments)
  "Return the condition designated by DATUM and ARGUMENTS.

   DATUM and ARGUMENTS together are a `condition designator' of (some
   supertype of) DEFAULT-TYPE; return the condition so designated."
  (typecase datum
    (condition
     (unless (or allow-pointless-arguments (null arguments))
       (error "Argument list provided with specific condition"))
     datum)
    (symbol
     (apply #'make-condition datum arguments))
    ((or string function)
     (make-condition default-type
		     :format-control datum
		     :format-arguments arguments))
    (t
     (error "Unexpected condition designator datum ~S" datum))))

(export 'simple-control-error)
(define-condition simple-control-error (control-error simple-error)
  ())

(export 'invoke-associated-restart)
(defun invoke-associated-restart (restart condition &rest arguments)
  "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.

   Find an active restart designated by RESTART; if CONDITION is not nil,
   then restrict the search to restarts associated with CONDITION, and
   restarts not associated with any condition.  If no such restart is found
   then signal an error of type `control-error'; otherwise invoke the restart
   with the given ARGUMENTS."
  (apply #'invoke-restart
	 (or (find-restart restart condition)
	     (error 'simple-control-error
		    :format-control "~:[Restart ~S is not active~;~
					No active `~(~A~)' restart~]~
				     ~@[ for condition ~S~]"
		    :format-arguments (list (symbolp restart)
					    restart
					    condition)))
	 arguments))

(export '(enclosing-condition enclosed-condition))
(define-condition enclosing-condition (condition)
  ((%enclosed-condition :initarg :condition :type condition
			:reader enclosed-condition))
  (:documentation
   "A condition which encloses another condition

   This is useful if one wants to attach additional information to an
   existing condition.  The enclosed condition can be obtained using the
   `enclosed-condition' function.")
  (:report (lambda (condition stream)
	     (princ (enclosed-condition condition) stream))))

(export 'information)
(define-condition information (condition)
  ())

(export 'simple-information)
(define-condition simple-information (simple-condition information)
  ())

(export 'info)
(defun info (datum &rest arguments)
  "Report some useful diagnostic information.

   Establish a simple restart named `noted', and signal the condition of type
   `information' designated by DATUM and ARGUMENTS.  Return non-nil if the
   restart was invoked, otherwise nil."
  (restart-case
      (signal (designated-condition 'simple-information datum arguments))
    (noted () :report "Noted." t)))

(export 'noted)
(defun noted (&optional condition)
  "Invoke the `noted' restart, possibly associated with the given CONDITION."
  (invoke-associated-restart 'noted condition))

(export 'promiscuous-cerror)
(defun promiscuous-cerror (continue-string datum &rest arguments)
  "Like standard `cerror', but robust against sneaky changes of conditions.

   It seems that `cerror' (well, at least the version in SBCL) is careful
   to limit its restart to the specific condition it signalled.  But that's
   annoying, because `sod-parser:with-default-error-location' substitutes
   different conditions carrying the error-location information."
  (restart-case (apply #'error datum arguments)
    (continue ()
      :report (lambda (stream)
		(apply #'format stream continue-string datum arguments))
      nil)))

(export 'cerror*)
(defun cerror* (datum &rest arguments)
  (apply #'promiscuous-cerror "Continue" datum arguments))

;;;--------------------------------------------------------------------------
;;; CLOS hacking.

(export 'default-slot)
(defmacro default-slot ((instance slot &optional (slot-names t))
			  &body value
			  &environment env)
  "If INSTANCE's slot named SLOT is unbound, set it to VALUE.

   Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we
   obey the `shared-initialize' protocol).  SLOT-NAMES defaults to `t', so
   you can use it in `initialize-instance' or similar without ill effects.
   Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
   evaluated if it's needed."

  (once-only (:environment env instance slot slot-names)
    `(when ,(if (eq slot-names t)
		  `(not (slot-boundp ,instance ,slot))
		  `(and (not (slot-boundp ,instance ,slot))
			(or (eq ,slot-names t)
			    (member ,slot ,slot-names))))
       (setf (slot-value ,instance ,slot)
	     (progn ,@value)))))

(export 'define-on-demand-slot)
(defmacro define-on-demand-slot (class slot (instance) &body body)
  "Defines a slot which computes its initial value on demand.

   Sets up the named SLOT of CLASS to establish its value as the implicit
   progn BODY, by defining an appropriate method on `slot-unbound'."
  (multiple-value-bind (docs decls body) (parse-body body)
    (with-gensyms (classvar slotvar)
      `(defmethod slot-unbound
	   (,classvar (,instance ,class) (,slotvar (eql ',slot)))
	 ,@docs ,@decls
	 (declare (ignore ,classvar))
	 (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))

;;;----- That's all, folks --------------------------------------------------