doc/sod.sty: Hack underscores in the labels generated by `describe'.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 15f9091d380cd39d2e2e1df839d9fe9c9cf107a1..98d314aff7ba4a5b4ae9e3edafcb02a3d78e7e09 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -213,7 +213,7 @@ (defmacro awhen (cond &body body)
   `(let ((it ,cond)) (when it ,@body)))
 
 (export 'acond)
-(defmacro acond (&rest clauses &environment env)
+(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
@@ -271,6 +271,30 @@ (defmacro asetf (&rest places-and-values &environment env)
 ;;;--------------------------------------------------------------------------
 ;;; 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
@@ -289,6 +313,9 @@ (defun copy-instance (object &rest initargs)
    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.
 
@@ -354,7 +381,7 @@ (defun merge-lists (lists &key pick (test #'eql))
    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.
+   by A) then an error of type `inconsistent-merge-error' is signalled.
 
    Item equality is determined by TEST.
 
@@ -578,7 +605,10 @@ (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."
+   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)))))
@@ -591,7 +621,7 @@ (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."
+   The symbol is interned in the current `*package*'.  Trad."
   (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
 
 ;;;--------------------------------------------------------------------------
@@ -602,7 +632,7 @@ (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.
+   If `*print-escape*' is set then print OBJECT unreadably using BODY.
    Otherwise just print using BODY."
   (with-gensyms (print)
     `(flet ((,print () ,@body))
@@ -663,6 +693,38 @@ (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
                      ,(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))))))
+
+(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'."
+  (with-gensyms (classvar slotvar)
+    `(defmethod slot-unbound
+        (,classvar (,instance ,class) (,slotvar (eql ',slot)))
+       (declare (ignore ,classvar))
+       (setf (slot-value ,instance ',slot) (progn ,@body)))))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.