`(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
;;;--------------------------------------------------------------------------
;;; 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
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.
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.
"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)))))
(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))))
;;;--------------------------------------------------------------------------
((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))
,(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.
(export 'default-slot)
~mdw / sod / blobdiff