- (make-method-lambda
- gf
- (class-prototype (generic-function-method-class gf))
- `(lambda (the-class the-instance the-slot-name)
- (declare (ignore the-class))
- (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))
- nil)
- (add-method gf
- (apply
- #'make-instance (generic-function-method-class gf)
- ':specializers (list (intern-eql-specializer class-name)
- (find-class class-name)
- (intern-eql-specializer slot-name))
- ':lambda-list '(the-class the-instance the-slot-name)
- ':function (compile nil method-lambda)
- init-args-values)))))
+ (make-method-lambda
+ gf
+ (class-prototype (generic-function-method-class gf))
+ #-lispworks
+ `(lambda (the-class the-instance the-slot-name)
+ (declare (ignore the-class))
+ (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))
+ #+lispworks
+ '(the-class the-instance the-slot-name)
+ #+lispworks
+ nil
+ #+lispworks
+ `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))
+ nil)
+ (add-method gf
+ (apply
+ #'make-instance (generic-function-method-class gf)
+ ':specializers (list (class-of (find-class class-name))
+ (find-class class-name)
+ (intern-eql-specializer slot-name))
+ ':lambda-list '(the-class the-instance the-slot-name)
+ ':function (compile nil method-lambda)
+ init-args-values)))))
+
+#+(or allegro scl)
+(progn
+ ;; One entry for each class with lazy readers defined. The value is a plist mapping
+ ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.
+ (defvar *lazy-readers* (make-hash-table))
+
+(defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)
+ (let ((lazy-reader (loop for super in (class-precedence-list class)
+ as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)
+ when lazy-reader return it)))
+ (if lazy-reader
+ (setf (slot-value instance slot-name)
+ (apply (car lazy-reader)
+ (loop for arg-slot-name in (cdr lazy-reader)
+ collect (slot-value instance arg-slot-name))))
+ ;; No lazy reader -- defer to regular slot-unbound handling.
+ (call-next-method))))
+
+ ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to
+ ;; the result of applying the function to the slot-values of those slots, and that value
+ ;; is also returned.
+ (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)
+ (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
+ (list* reader (copy-list reader-keys))))
+
+ (defun remove-lazy-reader (class-name slot-name)
+ (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)
+ nil))
+
+ ) ;; #+(or allegro scl)
+