From 6e6b09589b6f6d0b260fd022e6a3b189f7f7d352 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Sun, 30 Aug 2015 10:58:38 +0100 Subject: [PATCH] src/: Introduce a macro for defining on-demand slots. This is a surprisingly major win. --- src/class-layout-impl.lisp | 20 +++----- src/classes.lisp | 2 +- src/method-impl.lisp | 120 +++++++++++++++++---------------------------- src/utilities.lisp | 12 +++++ 4 files changed, 64 insertions(+), 90 deletions(-) diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 26782e2..8edfcf6 100644 --- 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 --- 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 --- 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 --- 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. -- 2.11.0