From f6f5570c55c5dc382a7d64a77a9af2ad2e16ce04 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 18 Feb 2014 12:31:14 +0000 Subject: [PATCH] improve generic function encapsulation Perform the encapsulation in an :AROUND method specialized on STANDARD-GENERIC-FUNCTION, so that subclasses transparently inherit encapsulation handling while still being able to override the standard COMPUTE-DISCRIMINATING-FUNCTION behaviour. (This is method structure that AMOP allows implementations, as the :AROUND method is an extending one -- it calls CALL-NEXT-METHOD) --- src/pcl/methods.lisp | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 6d3756984..4398a2c80 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1642,11 +1642,11 @@ (reinitialize-instance gf)) (defun sb-impl::encapsulated-generic-function-p (gf type) (position type (generic-function-encapsulations gf) :key #'car)) -(defun standard-compute-discriminating-function-with-encapsulations (gf encs) +(defun maybe-encapsulate-discriminating-function (gf encs std) (if (null encs) - (standard-compute-discriminating-function gf) - (let ((inner (standard-compute-discriminating-function-with-encapsulations - gf (cdr encs))) + std + (let ((inner (maybe-encapsulate-discriminating-function + gf (cdr encs) std)) (body (cdar encs))) (lambda (&rest args) (let ((sb-int:arg-list args) @@ -1654,8 +1654,10 @@ (declare (special sb-int:arg-list sb-int:basic-definition)) (eval body)))))) (defmethod compute-discriminating-function ((gf standard-generic-function)) - (standard-compute-discriminating-function-with-encapsulations - gf (generic-function-encapsulations gf))) + (standard-compute-discriminating-function gf)) +(defmethod compute-discriminating-function :around ((gf standard-generic-function)) + (maybe-encapsulate-discriminating-function + gf (generic-function-encapsulations gf) (call-next-method))) (defmethod (setf class-name) (new-value class) (let ((classoid (wrapper-classoid (class-wrapper class)))) -- 2.11.4.GIT