Changeset 14048


Ignore:
Timestamp:
08/03/12 20:06:25 (8 years ago)
Author:
ehuelsmann
Message:

Move CLOS D-M-C tests to a separate file clos-tests.lisp,
because D-M-C isn't MOP... Also define many more tests (more to come)
to test our D-M-C implementation.

Location:
trunk/abcl/test/lisp/abcl
Files:
1 added
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/test/lisp/abcl/mop-tests.lisp

    r14047 r14048  
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
     20;;; CLOS related tests go clos-tssts.lisp
     21
    2022(in-package #:abcl.test.lisp)
    2123
     
    302304
    303305
    304 
    305 ;; tests for D-M-C, long form, taken from SBCL
    306 
    307 ;; D-M-C should return the name of the new method combination, nothing else.
    308 
    309 (deftest dmc-return.1
    310     (define-method-combination dmc-test-return-foo)
    311   dmc-test-return-foo)
    312 
    313 (deftest dmc-return.2
    314     (define-method-combination dmc-test-return-bar :operator and)
    315   dmc-test-return-bar)
    316 
    317 (deftest dmc-return.3
    318     (define-method-combination dmc-test-return
    319         (&optional (order :most-specific-first))
    320       ((around (:around))
    321        (primary (dmc-test-return) :order order :required t))
    322       (let ((form (if (rest primary)
    323                       `(and ,@(mapcar #'(lambda (method)
    324                                           `(call-method ,method))
    325                                       primary))
    326                       `(call-method ,(first primary)))))
    327         (if around
    328             `(call-method ,(first around)
    329                           (,@(rest around)
    330                              (make-method ,form)))
    331             form)))
    332   dmc-test-return)
    333 
    334 ;; A method combination which originally failed;
    335 ;;   for different reasons in SBCL than in ABCL (hence leaving out
    336 ;;   the original comment)
    337 
    338 (define-method-combination dmc-test-mc.1
    339     (&optional (order :most-specific-first))
    340   ((around (:around))
    341    (primary (dmc-test-mc) :order order :required t))
    342   (let ((form (if (rest primary)
    343                   `(and ,@(mapcar #'(lambda (method)
    344                                       `(call-method ,method))
    345                                   primary))
    346                   `(call-method ,(first primary)))))
    347     (if around
    348         `(call-method ,(first around)
    349                       (,@(rest around)
    350                          (make-method ,form)))
    351         form)))
    352 
    353 (defgeneric dmc-test-mc.1 (&key k) (:method-combination dmc-test-mc.1))
    354 
    355 (defmethod dmc-test-mc.1 dmc-test-mc (&key k)
    356   k)
    357 
    358 (deftest dmc-test-mc.1
    359     (dmc-test-mc.1 :k 1)
    360   1)
    361 
    362 
    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 ;;; Taken from SBCL: error when method sorting is ambiguous
    414 ;;;  with multiple method groups
    415 
    416 (define-method-combination dmc-test-mc.3a ()
    417   ((around (:around))
    418    (primary * :required t))
    419   (let ((form (if (rest primary)
    420                   `(call-method ,(first primary) ,(rest primary))
    421                   `(call-method ,(first primary)))))
    422     (if around
    423         `(call-method ,(first around) (,@(rest around)
    424                                        (make-method ,form)))
    425         form)))
    426 
    427 (defgeneric dmc-test-mc.3a (val)
    428   (:method-combination dmc-test-mc.3a))
    429 
    430 (defmethod dmc-test-mc.3a ((val number))
    431   (+ val (if (next-method-p) (call-next-method) 0)))
    432 
    433 (defmethod dmc-test-mc.3a :around ((val number))
    434   (+ val (if (next-method-p) (call-next-method) 0)))
    435 
    436 (defmethod dmc-test-mc.3a :somethingelse ((val number))
    437   (+ val (if (next-method-p) (call-next-method) 0)))
    438 
    439 (deftest dmc-test-mc.3a
    440     (multiple-value-bind
    441           (value error)
    442         (ignore-errors (wam-test-mc.3a 13))
    443       (declare (ignore value))
    444       (typep error 'error))
    445   T)
    446 
    447 ;;; Taken from SBCL: error when method sorting is ambiguous
    448 ;;;  with a single (non *) method group
    449 
    450 
    451 (define-method-combination dmc-test-mc.3b ()
    452   ((methods listp :required t))
    453   (if (rest methods)
    454       `(call-method ,(first methods) ,(rest methods))
    455       `(call-method ,(first methods))))
    456 
    457 (defgeneric dmc-test-mc.3b (val)
    458   (:method-combination dmc-test-mc.3b))
    459 
    460 (defmethod dmc-test-mc.3b :foo ((val number))
    461   (+ val (if (next-method-p) (call-next-method) 0)))
    462 
    463 (defmethod dmc-test-mc.3b :bar ((val number))
    464   (+ val (if (next-method-p) (call-next-method) 0)))
    465 
    466 (deftest dmc-test-mc.3b
    467     (multiple-value-bind
    468           (value error)
    469         (ignore-errors (dmc-test-mc.3b 13))
    470       (declare (ignore value))
    471       (typep error 'error))
    472   T)
    473 
    474 
    475 ;; Taken from SBCL: test that GF invocation arguments
    476 ;;   are correctly bound using the (:arguments ...) form
    477 
    478 (defparameter *dmc-test-4* nil)
    479 
    480 (defun object-lock (obj)
    481   (push "object-lock" *dmc-test-4*)
    482   obj)
    483 (defun unlock (obj)
    484   (push "unlock" *dmc-test-4*)
    485   obj)
    486 (defun lock (obj)
    487   (push "lock" *dmc-test-4*)
    488   obj)
    489 
    490 
    491 (define-method-combination dmc-test-mc.4 ()
    492   ((methods *))
    493   (:arguments object)
    494   `(unwind-protect
    495         (progn (lock (object-lock ,object))
    496                ,@(mapcar #'(lambda (method)
    497                              `(call-method ,method))
    498                          methods))
    499      (unlock (object-lock ,object))))
    500 
    501 (defgeneric dmc-test.4 (x)
    502   (:method-combination dmc-test-mc.4))
    503 (defmethod dmc-test.4 ((x symbol))
    504   (push "primary" *dmc-test-4*))
    505 (defmethod dmc-test.4 ((x number))
    506   (error "foo"))
    507 
    508 (deftest dmc-test.4a
    509     (progn
    510       (setq *dmc-test-4* nil)
    511       (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock"))
    512               (equal *dmc-test-4* '("unlock" "object-lock"
    513                                     "primary" "lock" "object-lock"))))
    514   T T)
    515 
    516 (deftest dmc-test.4b
    517     (progn
    518       (setq *dmc-test-4* nil)
    519       (ignore-errors (dmc-test.4 1))
    520       (equal *dmc-test-4* '("unlock" "object-lock" "lock" "object-lock")))
    521   T)
    522 
    523 
    524 ;; From SBCL: method combination (long form) with arguments
    525 
    526 (define-method-combination dmc-test.5 ()
    527   ((method-list *))
    528   (:arguments arg1 arg2 &aux (extra :extra))
    529   `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list)))
    530 
    531 (defgeneric dmc-test-mc.5 (p1 p2 s)
    532   (:method-combination dmc-test.5)
    533   (:method ((p1 number) (p2 t) s)
    534     (vector-push-extend (list 'number p1 p2) s))
    535   (:method ((p1 string) (p2 t) s)
    536     (vector-push-extend (list 'string p1 p2) s))
    537   (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s)))
    538 
    539 (deftest dmc-test.5a
    540     (let ((v (make-array 0 :adjustable t :fill-pointer t)))
    541       (values (dmc-test-mc.5 1 2 v)
    542               (equal (aref v 0) '(number 1 2))
    543               (equal (aref v 1) '(t 1 2))))
    544   1 T T)
    545 
    546 
    547 
    548 (define-method-combination dmc-test.6 ()
    549   ((normal ())
    550    (ignored (:ignore :unused)))
    551   `(list 'result
    552     ,@(mapcar #'(lambda (method) `(call-method ,method)) normal)))
    553 
    554 (defgeneric dmc-test-mc.6 (x)
    555   (:method-combination dmc-test.6)
    556   (:method :ignore ((x number)) (/ 0)))
    557 
    558 (deftest dmc-test-mc.6a
    559     (multiple-value-bind
    560           (value error)
    561         (ignore-errors (dmc-test-mc.6 7))
    562       (values (null value)
    563               (typep error 'error)))
    564   T T)
    565 
    566 
    567 (define-method-combination dmc-test.7 ()
    568   ((methods *))
    569   (:arguments x &rest others)
    570   `(progn
    571      ,@(mapcar (lambda (method)
    572                  `(call-method ,method))
    573                methods)
    574      (list ,x (length ,others))))
    575 
    576 (defgeneric dmc-test-mc.7 (x &rest others)
    577   (:method-combination dmc-test.7))
    578 
    579 (defmethod dmc-test-mc.7 (x &rest others)
    580   (declare (ignore others))
    581   nil)
    582 
    583 (deftest dmc-test-mc.7a
    584     (equal (apply #'dmc-test-mc.7 :foo (list 1 2 3 4 5 6 7 8))
    585            '(:foo 8))
    586   T)
    587 
    588 
    589 (defclass foo-class (standard-class))
    590 (defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))
    591   t)
    592 
    593 (deftest validate-superclass.1
    594     (mop:validate-superclass
    595      (make-instance 'foo-class)
    596      (make-instance 'standard-object))
    597   t)
    598 
    599 
    600 (defgeneric apply-rule (rule))
    601 (defmethod apply-rule ((rule t) &aux (context (format nil "~A" rule)))
    602   (format nil "Applying rule '~A' in context '~A'" rule context))
    603 
    604 ;;; See ticket # 199
    605 (deftest defmethod-&aux.1
    606     (apply-rule "1")
    607   "Applying rule '1' in context '1'")
    608    
Note: See TracChangeset for help on using the changeset viewer.