summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
de2944d)
We need arbitrary generalizer objects, not least so as to have
composable specializer functions (if we want generic functions
which can have more than one extended specializer class, we need
to be sure that our generalizers won't stomp on each other).
But that means that cacheing effective methods depends totally on
interning generalizers, which is a bit lame, unless we ask the
extended specializer implementor to provide a subkey to be used
in the key to the emf cache. This new protocol function is a hook
for exactly that purpose.
(Minimally update the cons specializer example: it's still bad, in
that it uses symbols as the generalizer for conses, but the protocol
in principle at least doesn't leak now.)
(define-extended-specializer cons (gf car)
(make-instance 'cons-specializer :car car))
(define-extended-specializer cons (gf car)
(make-instance 'cons-specializer :car car))
(defmethod sb-pcl:unparse-specializer-using-class
((gf cons-generic-function) (specializer cons-specializer))
`(cons ,(%car specializer)))
(defmethod sb-pcl:unparse-specializer-using-class
((gf cons-generic-function) (specializer cons-specializer))
`(cons ,(%car specializer)))
((s1 cons-specializer) (s2 cons-specializer))
(eql (%car s1) (%car s2)))
((s1 cons-specializer) (s2 cons-specializer))
(eql (%car s1) (%car s2)))
+(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
+ g)
+
(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
(typecase arg
((cons symbol) (car arg))
(defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
(typecase arg
((cons symbol) (car arg))
"GENERALIZER-OF-USING-CLASS"
"COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
"GENERALIZER-OF-USING-CLASS"
"COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
+ "GENERALIZER-EQUAL-HASH-KEY"
"DEFINE-EXTENDED-SPECIALIZER"))
"DEFINE-EXTENDED-SPECIALIZER"))
(error "Too few arguments to generic function ~S." gf))
(subseq args 0 number-required)))
(error "Too few arguments to generic function ~S." gf))
(subseq args 0 number-required)))
+(defgeneric generalizer-equal-hash-key (generic-function generalizer))
+(defmethod generalizer-equal-hash-key
+ ((gf specializable-generic-function) (g class))
+ (sb-pcl::class-wrapper g))
+
;;; FIXME: in some kind of order, the discriminating function needs to handle:
;;; - argument count checking;
;;; - keyword argument validity;
;;; - DONE flushing the emf cache on method addition/removal
;;; FIXME: in some kind of order, the discriminating function needs to handle:
;;; - argument count checking;
;;; - keyword argument validity;
;;; - DONE flushing the emf cache on method addition/removal
-;;; - flushing the cache on class redefinition;
+;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
;;; - cache thread-safety.
(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
(lambda (&rest args)
(let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
(required-portion gf args)))
;;; - cache thread-safety.
(defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
(lambda (&rest args)
(let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
(required-portion gf args)))
- (emfun (gethash generalizers (emf-table gf) nil)))
+ (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
+ (emfun (gethash keys (emf-table gf) nil)))
(if emfun
(sb-pcl::invoke-emf emfun args)
(slow-method-lookup gf args generalizers)))))
(if emfun
(sb-pcl::invoke-emf emfun args)
(slow-method-lookup gf args generalizers)))))
(compute-applicable-methods-using-generalizers gf generalizers)
(if definitivep
(let* ((emfun
(compute-applicable-methods-using-generalizers gf generalizers)
(if definitivep
(let* ((emfun
- (compute-effective-method-function gf applicable-methods)))
- (setf (gethash generalizers (emf-table gf)) emfun)
+ (compute-effective-method-function gf applicable-methods))
+ (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+ (setf (gethash keys (emf-table gf)) emfun)
(sb-pcl::invoke-emf emfun args))
(sb-pcl::invoke-emf (compute-effective-method-function
gf (sb-mop:compute-applicable-methods gf args))
(sb-pcl::invoke-emf emfun args))
(sb-pcl::invoke-emf (compute-effective-method-function
gf (sb-mop:compute-applicable-methods gf args))
(let ((cpl (sb-mop:class-precedence-list generalizer)))
(if (find s2 (cdr (member s1 cpl)))
'<
(let ((cpl (sb-mop:class-precedence-list generalizer)))
(if (find s2 (cdr (member s1 cpl)))
'<
(defmethod specializer<
((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
(declare (ignore generalizer))
(defmethod specializer<
((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
(declare (ignore generalizer))