-;; defines a slot-unbound method for class and slot-name, fills
-;; the slot by calling reader function with the slot values of
-;; the instance's reader-keys
-(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
- (let* ((the-slot-name (gensym))
- (the-class (gensym))
- (the-instance (gensym))
- (keys '()))
- (dolist (key reader-keys)
- (push (list 'slot-value the-instance (list 'quote key)) keys))
- (setq keys (nreverse keys))
- `(defmethod slot-unbound (,the-class (,the-instance ,class)
- (,the-slot-name (eql ',slot-name)))
- (declare (ignore ,the-class))
- (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))
-
-
-#+lispworks
-(defun intern-eql-specializer (slot)
- `(eql ,slot))
-
-#+(or sbcl cmu lispworks)
-(defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)
- (let ((keys nil)
- (gf (ensure-generic-function 'slot-unbound)))
- (dolist (key reader-keys)
- (push (list 'slot-value 'the-instance (list 'quote key)) keys))
- (setq keys (nreverse keys))
- (multiple-value-bind (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)))
+;; 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 ((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)))