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