X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3109662aca9c06495ac22c5c58b46e1c036aca5c..64d1ecf751f542782b5ffb9c9469c70d92f423de:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index aabc067..98d314a 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -313,6 +313,9 @@
    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.
 
@@ -691,6 +694,38 @@
 		      ,(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)