-;; defines a slot-unbound method for class and slot-name, fills\r
-;; the slot by calling reader function with the slot values of\r
-;; the instance's reader-keys\r
-(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)\r
- (let* ((the-slot-name (gensym))\r
- (the-class (gensym))\r
- (the-instance (gensym))\r
- (keys '()))\r
- (dolist (key reader-keys)\r
- (push (list 'slot-value the-instance (list 'quote key)) keys))\r
- (setq keys (nreverse keys))\r
- `(defmethod slot-unbound (,the-class (,the-instance ,class)\r
- (,the-slot-name (eql ',slot-name)))\r
- (declare (ignore ,the-class))\r
- (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))\r
-\r
-\r
-#+lispworks\r
-(defun intern-eql-specializer (slot)\r
- `(eql ,slot))\r
-\r
-#+(or sbcl cmu lispworks)\r
-(defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)\r
- (let ((keys nil)\r
- (gf (ensure-generic-function 'slot-unbound)))\r
- (dolist (key reader-keys)\r
- (push (list 'slot-value 'the-instance (list 'quote key)) keys))\r
- (setq keys (nreverse keys))\r
- (multiple-value-bind (method-lambda init-args-values)\r
- (make-method-lambda\r
- gf\r
- (class-prototype (generic-function-method-class gf))\r
- #-lispworks\r
- `(lambda (the-class the-instance the-slot-name)\r
- (declare (ignore the-class))\r
- (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))\r
- #+lispworks\r
- '(the-class the-instance the-slot-name)\r
- #+lispworks\r
- nil\r
- #+lispworks\r
- `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))\r
- nil)\r
- (add-method gf\r
- (apply\r
- #'make-instance (generic-function-method-class gf)\r
- ':specializers (list (class-of (find-class class-name))\r
- (find-class class-name)\r
- (intern-eql-specializer slot-name))\r
- ':lambda-list '(the-class the-instance the-slot-name)\r
- ':function (compile nil method-lambda)\r
- init-args-values)))))\r
-\r
-#+(or allegro scl)\r
-(progn\r
- ;; One entry for each class with lazy readers defined. The value is a plist mapping\r
- ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.\r
- (defvar *lazy-readers* (make-hash-table))\r
-\r
-(defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)\r
- (let ((lazy-reader (loop for super in (class-precedence-list class)\r
- as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)\r
- when lazy-reader return it)))\r