Changeset 13566


Ignore:
Timestamp:
09/03/11 22:57:09 (10 years ago)
Author:
ehuelsmann
Message:

More D-M-C tests and fixes.

Location:
trunk/abcl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13376 r13566  
    19421942  (equal '(:around) (method-qualifiers method)))
    19431943
     1944(defun process-next-method-list (gf next-method-list)
     1945  (mapcar #'(lambda (next-method-form)
     1946              (cond
     1947                ((listp next-method-form)
     1948                 (assert (eq (first next-method-form) 'make-method))
     1949                 (let* ((rest-sym (gensym)))
     1950                   (make-instance-standard-method
     1951                    nil ;; ignored
     1952                    :lambda-list (list '&rest rest-sym)
     1953                    :function (compute-method-function `(lambda (&rest ,rest-sym)
     1954                                                          ,(second next-method-form))))))
     1955                (t
     1956                 (assert (typep next-method-form 'method))
     1957                 next-method-form)))
     1958          next-method-list))
     1959
    19441960(defun std-compute-effective-method-function (gf methods)
    19451961  (let* ((mc (generic-function-method-combination gf))
     
    19511967         around
    19521968         emf-form
    1953          (long-method-combination-p 
     1969         (long-method-combination-p
    19541970          (typep (get mc-name 'method-combination-object) 'long-method-combination)))
    19551971    (unless long-method-combination-p
     
    20222038         (assert (typep mc-obj 'long-method-combination))
    20232039         (assert function)
    2024          (setf emf-form 
     2040         (setf emf-form
    20252041               (let ((result (if arguments
    20262042                                 (apply function gf methods arguments)
     
    20292045                    (let ((gf-args-var args))
    20302046                      (macrolet ((call-method (method &optional next-method-list)
    2031                                    `(funcall ,(%method-function method) args nil)))
     2047                                   `(funcall
     2048                                     ,(cond
     2049                                       ((listp method)
     2050                                        (assert (eq (first method) 'make-method))
     2051                                        ;; by generating an inline expansion we prevent allocation
     2052                                        ;; of a method instance which will be discarded immediately
     2053                                        ;; after reading the METHOD-FUNCTION slot
     2054                                        (compute-method-function `(lambda (&rest ,(gensym))
     2055                                                   ;;### FIXME
     2056                                                   ;; the MAKE-METHOD body form gets evaluated in
     2057                                                   ;; the null lexical environment augmented
     2058                                                   ;; with a binding for CALL-METHOD
     2059                                                   ;; ... it's the latter we're not doing here...
     2060                                                                    ,(second method))))
     2061                                       (t (%method-function method)))
     2062                                     args
     2063                                     ,(unless (null next-method-list)
     2064                                        ;; by not generating an emf when there are no next methods,
     2065                                        ;; we ensure next-method-p returns NIL
     2066                                        (compute-effective-method-function ,gf
     2067                                           (process-next-method-list ,gf next-method-list))))))
    20322068                        ,result)))))))
    20332069      (t
  • trunk/abcl/test/lisp/abcl/mop-tests.lisp

    r13376 r13566  
    361361
    362362
     363;; Completely DIY -- also taken from SBCL:
     364(define-method-combination dmc-test-mc.2 ()
     365  ((all-methods *))
     366  (do ((methods all-methods (rest methods))
     367       (primary nil)
     368       (around nil))
     369      ((null methods)
     370       (let ((primary (nreverse primary))
     371             (around (nreverse around)))
     372         (if primary
     373              (let ((form (if (rest primary)
     374                             `(call-method ,(first primary) ,(rest primary))
     375                             `(call-method ,(first primary)))))
     376                (if around
     377                    `(call-method ,(first around) (,@(rest around)
     378                                                   (make-method ,form)))
     379                    form))
     380              `(make-method (error "No primary methods")))))
     381    (let* ((method (first methods))
     382           (qualifier (first (method-qualifiers method))))
     383      (cond
     384        ((equal :around qualifier)
     385         (push method around))
     386        ((null qualifier)
     387         (push method primary))))))
     388
     389(defgeneric dmc-test-mc.2a (val)
     390  (:method-combination dmc-test-mc.2))
     391
     392(defmethod dmc-test-mc.2a ((val number))
     393  (+ val (if (next-method-p) (call-next-method) 0)))
     394
     395(deftest dmc-test-mc.2a
     396    (= (dmc-test-mc.2a 13) 13)
     397  T)
     398
     399(defgeneric dmc-test-mc.2b (val)
     400  (:method-combination dmc-test-mc.2))
     401
     402(defmethod dmc-test-mc.2b ((val number))
     403  (+ val (if (next-method-p) (call-next-method) 0)))
     404
     405(defmethod dmc-test-mc.2b :around ((val number))
     406  (+ val (if (next-method-p) (call-next-method) 0)))
     407
     408(deftest dmc-test-mc.2b
     409    (= 26 (dmc-test-mc.2b 13))
     410  T)
     411
     412
     413
     414
    363415(defclass foo-class (standard-class))
    364416(defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))
Note: See TracChangeset for help on using the changeset viewer.