[Sbcl-commits] master: improve generic function encapsulation

[Christophe R. <cr...@us...>]

The branch "master" has been updated in SBCL:
       via  f6f5570c55c5dc382a7d64a77a9af2ad2e16ce04 (commit)
      from  1f555ba30b0571d6d8515d481682c550afe76e4b (commit)

- Log -----------------------------------------------------------------
commit f6f5570c55c5dc382a7d64a77a9af2ad2e16ce04
Author: Christophe Rhodes <cs...@ca...>
Date:   Tue Feb 18 12:31:14 2014 +0000

    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 files changed, 8 insertions(+), 6 deletions(-)

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 6d37569..4398a2c 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))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL