src/: Introduce a macro for defining on-demand slots.

This is a surprisingly major win.

diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp
index 26782e2..8edfcf6 100644 (file)
--- a/src/class-layout-impl.lisp
+++ b/src/class-layout-impl.lisp
@@ -129,11 +129,8 @@
                    (sod-class-messages super)))
          (sod-class-precedence-list class)))
 
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
-  (declare (ignore clos-class))
-  (setf (slot-value class 'effective-methods)
-       (compute-effective-methods class)))
+(define-on-demand-slot sod-class effective-methods (class)
+  (compute-effective-methods class))
 
 ;;;--------------------------------------------------------------------------
 ;;; Instance layout.
@@ -207,10 +204,8 @@
                                                    (reverse chain)))
                                  (sod-class-chains class))))
 
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql '%ilayout)))
-  (declare (ignore clos-class))
-  (setf (slot-value class '%ilayout) (compute-ilayout class)))
+(define-on-demand-slot sod-class %ilayout (class)
+  (compute-ilayout class))
 
 ;;;--------------------------------------------------------------------------
 ;;; Vtable layout.
@@ -389,10 +384,7 @@
            (compute-vtable class (reverse chain)))
          (sod-class-chains class)))
 
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql 'vtables)))
-  (declare (ignore clos-class))
-  (setf (slot-value class 'vtables)
-       (compute-vtables class)))
+(define-on-demand-slot sod-class vtables (class)
+  (compute-vtables class))
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/classes.lisp b/src/classes.lisp
index 6a48698..afbb485 100644 (file)
--- a/src/classes.lisp
+++ b/src/classes.lisp
@@ -194,7 +194,7 @@
        specific) for the class and all of its superclasses.
 
    Finally, slots concerning the instance and vtable layout of the class are
-   computed on demand via methods on `slot-unbound'.
+   computed on demand (see `define-on-demand-slot').
 
      * The ILAYOUT describes the layout for an instance of the class.  It's
        quite complicated; see the documentation of the `ilayout' class for

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 4a8249b..6c9b28d 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -40,33 +40,24 @@
    inheriting its default behaviour.
 
    The function type protocol is implemented on `basic-message' using slot
-   reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   reader methods.  The actual values are computed on demand."))
 
-(defmethod slot-unbound (class
-                        (message basic-message)
-                        (slot-name (eql 'argument-tail)))
-  (declare (ignore class))
+(define-on-demand-slot basic-message argument-tail (message)
   (let ((seq 0))
-    (setf (slot-value message 'argument-tail)
-         (mapcar (lambda (arg)
-                   (if (or (eq arg :ellipsis) (argument-name arg)) arg
-                       (make-argument (make-instance 'temporary-argument
-                                                     :tag (prog1 seq
-                                                            (incf seq)))
-                                      (argument-type arg))))
-                 (c-function-arguments (sod-message-type message))))))
-
-(defmethod slot-unbound (class
-                        (message basic-message)
-                        (slot-name (eql 'no-varargs-tail)))
-  (declare (ignore class))
-  (setf (slot-value message 'no-varargs-tail)
-       (mapcar (lambda (arg)
-                 (if (eq arg :ellipsis)
-                     (make-argument *sod-ap* (c-type va-list))
-                     arg))
-               (sod-message-argument-tail message))))
+    (mapcar (lambda (arg)
+             (if (or (eq arg :ellipsis) (argument-name arg)) arg
+                 (make-argument (make-instance 'temporary-argument
+                                               :tag (prog1 seq
+                                                      (incf seq)))
+                                (argument-type arg))))
+           (c-function-arguments (sod-message-type message)))))
+
+(define-on-demand-slot basic-message no-varargs-tail (message)
+  (mapcar (lambda (arg)
+           (if (eq arg :ellipsis)
+               (make-argument *sod-ap* (c-type va-list))
+               arg))
+         (sod-message-argument-tail message)))
 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
@@ -120,22 +111,18 @@
    categorization.
 
    The function type protocol is implemented on `basic-direct-method' using
-   slot reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   slot reader methods."))
 
 (defmethod shared-initialize :after
     ((method basic-direct-method) slot-names &key pset)
   (declare (ignore slot-names))
   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 
-(defmethod slot-unbound
-    (class (method basic-direct-method) (slot-name (eql 'function-type)))
-  (declare (ignore class))
+(define-on-demand-slot basic-direct-method function-type (method)
   (let ((type (sod-method-type method)))
-    (setf (slot-value method 'function-type)
-         (c-type (fun (lisp (c-type-subtype type))
-                      ("me" (* (class (sod-method-class method))))
-                      . (c-function-arguments type))))))
+    (c-type (fun (lisp (c-type-subtype type))
+                ("me" (* (class (sod-method-class method))))
+                . (c-function-arguments type)))))
 
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method
@@ -184,13 +171,9 @@
    its `next_method' function if necessary.)
 
    The function type protocol is implemented on `delegating-direct-method'
-   using slot reader methods.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using slot reader methods.."))
 
-(defmethod slot-unbound (class
-                        (method delegating-direct-method)
-                        (slot-name (eql 'next-method-type)))
-  (declare (ignore class))
+(define-on-demand-slot delegating-direct-method next-method-type (method)
   (let* ((message (sod-method-message method))
         (return-type (c-type-subtype (sod-message-type message)))
         (msgargs (sod-message-argument-tail message))
@@ -199,30 +182,25 @@
                                             (c-type va-list))
                              (butlast msgargs))
                        msgargs)))
-    (setf (slot-value method 'next-method-type)
-         (c-type (fun (lisp return-type)
-                      ("me" (* (class (sod-method-class method))))
-                      . arguments)))))
-
-(defmethod slot-unbound (class
-                        (method delegating-direct-method)
-                        (slot-name (eql 'function-type)))
-  (declare (ignore class))
+    (c-type (fun (lisp return-type)
+                ("me" (* (class (sod-method-class method))))
+                . arguments))))
+
+(define-on-demand-slot delegating-direct-method function-type (method)
   (let* ((message (sod-method-message method))
         (type (sod-method-type method))
         (method-args (c-function-arguments type)))
-    (setf (slot-value method 'function-type)
-         (c-type (fun (lisp (c-type-subtype type))
-                      ("me" (* (class (sod-method-class method))))
-                      ("next_method" (* (lisp (commentify-function-type
-                                               (sod-method-next-method-type
-                                                method)))))
-                      .
-                      (if (varargs-message-p message)
-                          (cons (make-argument *sod-master-ap*
-                                               (c-type va-list))
-                                method-args)
-                          method-args))))))
+    (c-type (fun (lisp (c-type-subtype type))
+                ("me" (* (class (sod-method-class method))))
+                ("next_method" (* (lisp (commentify-function-type
+                                         (sod-method-next-method-type
+                                          method)))))
+                .
+                (if (varargs-message-p message)
+                    (cons (make-argument *sod-master-ap*
+                                         (c-type va-list))
+                          method-args)
+                    method-args)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
@@ -246,17 +224,12 @@
    correctly.
 
    The argument names protocol is implemented on `basic-effective-method'
-   using a slot reader method.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using a slot reader method."))
 
-(defmethod slot-unbound (class
-                        (method basic-effective-method)
-                        (slot-name (eql 'basic-argument-names)))
-  (declare (ignore class))
+(define-on-demand-slot basic-effective-method basic-argument-names (method)
   (let ((message (effective-method-message method)))
-    (setf (slot-value method 'basic-argument-names)
-         (mapcar #'argument-name
-                 (sod-message-no-varargs-tail message)))))
+    (mapcar #'argument-name
+           (sod-message-no-varargs-tail message))))
 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))
@@ -267,11 +240,8 @@
            (sod-class-nickname message-class)
            (sod-message-name message))))
 
-(defmethod slot-unbound
-    (class (method basic-effective-method) (slot-name (eql 'functions)))
-  (declare (ignore class))
-  (setf (slot-value method 'functions)
-       (compute-method-entry-functions method)))
+(define-on-demand-slot basic-effective-method functions (method)
+  (compute-method-entry-functions method))
 
 (export 'simple-effective-method)
 (defclass simple-effective-method (basic-effective-method)

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 099c4ba..98d314a 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -713,6 +713,18 @@
            `((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.