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)))
 
                    (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Instance layout.


@@ -207,10 +204,8 @@
                                                    (reverse chain)))
                                  (sod-class-chains class))))
 
                                                    (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Vtable layout.


@@ -389,10 +384,7 @@
            (compute-vtable class (reverse chain)))
          (sod-class-chains class)))
 
            (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 --------------------------------------------------
 
 ;;;----- 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
        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
 
      * 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
    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))
   (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)
 
 (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
    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 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)))
   (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
 
 (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'
    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))
   (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)))
                                             (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)))
   (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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.


@@ -246,17 +224,12 @@
    correctly.
 
    The argument names protocol is implemented on `basic-effective-method'
    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)))
   (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))
 
 (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))))
 
            (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)
 
 (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))))))
 
            `((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.
 
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.