From 2c5f75a29a473cd9878c706e824bf4c7741dd826 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Tue, 18 Feb 2014 04:14:36 +0100 Subject: [PATCH] added dumb mechanism for extra args in generalizers --- src/specializable.lisp | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/src/specializable.lisp b/src/specializable.lisp index 02e8f18..7da3104 100644 --- a/src/specializable.lisp +++ b/src/specializable.lisp @@ -116,6 +116,11 @@ ((gf specializable-generic-function) (g class)) (sb-pcl::class-wrapper g)) +(defgeneric generalizer-args (generic-function generalizer)) ; TODO add a subclass of specializable generic-function for this? +(defmethod generalizer-args ((generic-function specializable-generic-function) + (generalizer t)) + '()) + (defun first-arg-only-special-case (gf) (let ((arg-info (sb-pcl::gf-arg-info gf))) (and (slot-value gf 'single-arg-cacheing-p) @@ -141,21 +146,26 @@ (lambda (&rest args) (let* ((generalizer (generalizer-of-using-class gf (first args))) (key (generalizer-equal-hash-key gf generalizer)) + (extra-args (generalizer-args gf generalizer)) (emfun (gethash key (emf-table gf) nil))) (if emfun - (sb-pcl::invoke-emf emfun args) + (sb-pcl::invoke-emf emfun (append args extra-args)) ; TODO conses (slow-method-lookup-and-call - gf args (list* generalizer - (mapcar (lambda (x) (generalizer-of-using-class gf x)) - (rest (required-portion gf args))))))))) + gf (append args extra-args) + (list* generalizer + (mapcar (lambda (x) (generalizer-of-using-class gf x)) + (rest (required-portion gf args))))))))) (t (lambda (&rest args) (let* ((generalizers (generalizers-of-using-class gf args)) (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)) + (extra-args (mapcan (lambda (x) (generalizer-args gf x)) generalizers)) ; TODO destructive? (emfun (gethash keys (emf-table gf) nil))) (if emfun - (sb-pcl::invoke-emf emfun args) - (slow-method-lookup-and-call gf args generalizers))))))) + (sb-pcl::invoke-emf emfun (append args extra-args)) ; TODO conses + (slow-method-lookup-and-call + gf (append args extra-args) + generalizers))))))) (defmethod reinitialize-instance :after ((gf specializable-generic-function) &key) (clrhash (emf-table gf))) -- 2.39.5