tests/mop-20.impure-cload.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; this file tests that user-defined methods can be used in
  15 ;;; combination (ahem) with hairy bits of method-combination.
  16
  17 ;;; Simple test case from Pascal Costanza
  18 (defgeneric test (arg)
  19   (:method (arg) (format t "~D" arg) arg))
  20
  21 (defun define-around-test ()
  22   (multiple-value-bind
  23         (method-lambda method-args)
  24       (sb-mop:make-method-lambda
  25        #'test (sb-mop:class-prototype (sb-mop:generic-function-method-class #'test))
  26        '(lambda (arg) (call-next-method)) ())
  27     (let ((method (apply #'make-instance
  28                          (sb-mop:generic-function-method-class #'test)
  29                          :qualifiers '(:around)
  30                          :lambda-list '(arg)
  31                          :specializers (list (find-class 't))
  32                          :function (compile nil method-lambda)
  33                          method-args)))
  34       (sb-mop:add-method #'test method))))
  35
  36 (defun run-test ()
  37   (define-around-test)
  38   (test 42))
  39
  40 (with-test (:name (:mop-20 1))
  41   (assert (string= (with-output-to-string (*standard-output*)
  42                      (assert (= (run-test) 42)))
  43                    "42")))
  44 \f
  45 ;;; Slightly more complex test cases, from Bruno Haible (sbcl-devel
  46 ;;; 2004-06-11).  First the setup.
  47 (defclass user-method (standard-method) (myslot))
  48
  49 (defmacro def-user-method (name &rest rest)
  50   (let* ((lambdalist-position (position-if #'listp rest))
  51          (qualifiers (subseq rest 0 lambdalist-position))
  52          (lambdalist (elt rest lambdalist-position))
  53          (body (subseq rest (+ lambdalist-position 1)))
  54          (required-part
  55           (subseq lambdalist 0
  56                   (or (position-if #'(lambda (x)
  57                                        (member x lambda-list-keywords))
  58                                    lambdalist)
  59                       (length lambdalist))))
  60          (specializers
  61           (mapcar #'find-class
  62                   (mapcar #'(lambda (x) (if (consp x) (second x) 't))
  63                           required-part)))
  64          (unspecialized-required-part
  65           (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
  66          (unspecialized-lambdalist
  67           (append unspecialized-required-part
  68                   (subseq required-part (length required-part)))))
  69     `(progn
  70       (sb-mop:add-method #',name
  71        (make-instance 'user-method
  72         :qualifiers ',qualifiers
  73         :lambda-list ',unspecialized-lambdalist
  74         :specializers ',specializers
  75         :function
  76         #'(lambda (arguments next-methods-list)
  77             (flet ((next-method-p () next-methods-list)
  78                    (call-next-method (&rest new-arguments)
  79                      (unless new-arguments (setq new-arguments arguments))
  80                      (if (null next-methods-list)
  81                          (error "no next method for arguments ~:s" arguments)
  82                          (funcall (sb-mop:method-function (first next-methods-list))
  83                                   new-arguments (rest next-methods-list)))))
  84               (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
  85       ',name)))
  86
  87 ;;; this one has always worked, as it does not involve MAKE-METHOD in
  88 ;;; its effective method.
  89 (progn
  90   (defgeneric test-um03 (x))
  91   (defmethod test-um03 ((x integer))
  92     (list* 'integer x (not (null (next-method-p))) (call-next-method)))
  93   (def-user-method test-um03 ((x rational))
  94     (list* 'rational x (not (null (next-method-p))) (call-next-method)))
  95   (defmethod test-um03 ((x real))
  96     (list 'real x (not (null (next-method-p))))))
  97
  98 (with-test (:name (:mop-20 2))
  99   (assert (equal (test-um03 17) '(integer 17 t rational 17 t real 17 nil))))
 100
 101 ;;; these two used to fail in slightly different ways
 102 (progn
 103   (defgeneric test-um10 (x))
 104   (defmethod test-um10 ((x integer))
 105     (list* 'integer x (not (null (next-method-p))) (call-next-method)))
 106   (defmethod test-um10 ((x rational))
 107     (list* 'rational x (not (null (next-method-p))) (call-next-method)))
 108   (defmethod test-um10 ((x real))
 109     (list 'real x (not (null (next-method-p)))))
 110   (defmethod test-um10 :after ((x real)))
 111   (def-user-method test-um10 :around ((x integer))
 112     (list* 'around-integer x (not (null (next-method-p))) (call-next-method)))
 113   (defmethod test-um10 :around ((x rational))
 114     (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
 115   (defmethod test-um10 :around ((x real))
 116     (list* 'around-real x (not (null (next-method-p))) (call-next-method))))
 117
 118 (with-test (:name (:mop-20 3))
 119   (assert (equal (test-um10 17)
 120                  '(around-integer 17 t
 121                    around-rational 17 t
 122                    around-real 17 t
 123                    integer 17 t
 124                    rational 17 t
 125                    real 17 nil))))
 126
 127 (progn
 128   (defgeneric test-um12 (x))
 129   (defmethod test-um12 ((x integer))
 130     (list* 'integer x (not (null (next-method-p))) (call-next-method)))
 131   (defmethod test-um12 ((x rational))
 132     (list* 'rational x (not (null (next-method-p))) (call-next-method)))
 133   (defmethod test-um12 ((x real))
 134     (list 'real x (not (null (next-method-p)))))
 135   (defmethod test-um12 :after ((x real)))
 136   (defmethod test-um12 :around ((x integer))
 137     (list* 'around-integer x (not (null (next-method-p))) (call-next-method)))
 138   (defmethod test-um12 :around ((x rational))
 139     (list* 'around-rational x (not (null (next-method-p))) (call-next-method)))
 140   (def-user-method test-um12 :around ((x real))
 141     (list* 'around-real x (not (null (next-method-p))) (call-next-method))))
 142
 143 (with-test (:name (:mop-20 4))
 144   (assert (equal (test-um12 17)
 145                  '(around-integer 17 t
 146                    around-rational 17 t
 147                    around-real 17 t
 148                    integer 17 t
 149                    rational 17 t
 150                    real 17 nil))))