[armedbear-cvs] r13566 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sat Sep  3 15:57:09 2011
New Revision: 13566

Log:
More D-M-C tests and fixes.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/test/lisp/abcl/mop-tests.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Sep  3 12:18:23 2011	(r13565)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sat Sep  3 15:57:09 2011	(r13566)
@@ -1941,6 +1941,22 @@
 (defun around-method-p (method)
   (equal '(:around) (method-qualifiers method)))
 
+(defun process-next-method-list (gf next-method-list)
+  (mapcar #'(lambda (next-method-form)
+              (cond
+                ((listp next-method-form)
+                 (assert (eq (first next-method-form) 'make-method))
+                 (let* ((rest-sym (gensym)))
+                   (make-instance-standard-method
+                    nil ;; ignored
+                    :lambda-list (list '&rest rest-sym)
+                    :function (compute-method-function `(lambda (&rest ,rest-sym)
+                                                          ,(second next-method-form))))))
+                (t
+                 (assert (typep next-method-form 'method))
+                 next-method-form)))
+          next-method-list))
+
 (defun std-compute-effective-method-function (gf methods)
   (let* ((mc (generic-function-method-combination gf))
          (mc-name (if (atom mc) mc (%car mc)))
@@ -1950,7 +1966,7 @@
          (arounds '())
          around
          emf-form
-         (long-method-combination-p 
+         (long-method-combination-p
           (typep (get mc-name 'method-combination-object) 'long-method-combination)))
     (unless long-method-combination-p
       (dolist (m methods)
@@ -2021,14 +2037,34 @@
               (arguments (rest (slot-value gf 'method-combination))))
          (assert (typep mc-obj 'long-method-combination))
          (assert function)
-         (setf emf-form 
+         (setf emf-form
                (let ((result (if arguments
                                  (apply function gf methods arguments)
                                  (funcall function gf methods))))
                  `(lambda (args)
                     (let ((gf-args-var args))
                       (macrolet ((call-method (method &optional next-method-list)
-                                   `(funcall ,(%method-function method) args nil)))
+                                   `(funcall
+                                     ,(cond
+                                       ((listp method)
+                                        (assert (eq (first method) 'make-method))
+                                        ;; by generating an inline expansion we prevent allocation
+                                        ;; of a method instance which will be discarded immediately
+                                        ;; after reading the METHOD-FUNCTION slot
+                                        (compute-method-function `(lambda (&rest ,(gensym))
+                                                   ;;### FIXME
+                                                   ;; the MAKE-METHOD body form gets evaluated in
+                                                   ;; the null lexical environment augmented
+                                                   ;; with a binding for CALL-METHOD
+                                                   ;; ... it's the latter we're not doing here...
+                                                                    ,(second method))))
+                                       (t (%method-function method)))
+                                     args
+                                     ,(unless (null next-method-list)
+                                        ;; by not generating an emf when there are no next methods,
+                                        ;; we ensure next-method-p returns NIL
+                                        (compute-effective-method-function ,gf
+                                           (process-next-method-list ,gf next-method-list))))))
                         ,result)))))))
       (t
        (let ((mc-obj (get mc-name 'method-combination-object)))

Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/mop-tests.lisp	Sat Sep  3 12:18:23 2011	(r13565)
+++ trunk/abcl/test/lisp/abcl/mop-tests.lisp	Sat Sep  3 15:57:09 2011	(r13566)
@@ -360,6 +360,58 @@
   1)
 
 
+;; Completely DIY -- also taken from SBCL:
+(define-method-combination dmc-test-mc.2 ()
+  ((all-methods *))
+  (do ((methods all-methods (rest methods))
+       (primary nil)
+       (around nil))
+      ((null methods)
+       (let ((primary (nreverse primary))
+             (around (nreverse around)))
+         (if primary
+              (let ((form (if (rest primary)
+                             `(call-method ,(first primary) ,(rest primary))
+                             `(call-method ,(first primary)))))
+                (if around
+                    `(call-method ,(first around) (,@(rest around)
+                                                   (make-method ,form)))
+                    form))
+              `(make-method (error "No primary methods")))))
+    (let* ((method (first methods))
+           (qualifier (first (method-qualifiers method))))
+      (cond
+        ((equal :around qualifier)
+         (push method around))
+        ((null qualifier)
+         (push method primary))))))
+
+(defgeneric dmc-test-mc.2a (val)
+  (:method-combination dmc-test-mc.2))
+
+(defmethod dmc-test-mc.2a ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(deftest dmc-test-mc.2a
+    (= (dmc-test-mc.2a 13) 13)
+  T)
+
+(defgeneric dmc-test-mc.2b (val)
+  (:method-combination dmc-test-mc.2))
+
+(defmethod dmc-test-mc.2b ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(defmethod dmc-test-mc.2b :around ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(deftest dmc-test-mc.2b
+    (= 26 (dmc-test-mc.2b 13))
+  T)
+
+
+
+
 (defclass foo-class (standard-class))
 (defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))
   t)