tests/mop-23.impure.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 ;;; Extending MAKE-METHOD-LAMBDA, and making sure that the resulting
  15 ;;; method functions compile without warnings.
  16
  17 (defclass verbose-generic-function (standard-generic-function) ()
  18   (:metaclass sb-mop:funcallable-standard-class))
  19 (defmethod sb-mop:make-method-lambda
  20     ((gf verbose-generic-function) method lambda env)
  21   (multiple-value-bind (lambda initargs)
  22       (call-next-method)
  23     (values
  24      `(lambda (args next-methods)
  25        (format *trace-output* "Called a method!")
  26        (,lambda args next-methods))
  27      initargs)))
  28
  29 (defgeneric foo (x)
  30   (:generic-function-class verbose-generic-function))
  31
  32 (handler-bind ((warning #'error))
  33   (eval '(defmethod foo ((x integer)) (1+ x))))
  34
  35 (with-test (:name (:mop-23 sb-mop:make-method-lambda  1))
  36   (assert (string= (with-output-to-string (*trace-output*)
  37                      (assert (= (foo 3) 4)))
  38                    "Called a method!")))
  39
  40 (defclass super () ((a :initarg :a)))
  41 (defclass sub (super) (b))
  42
  43 (handler-bind ((warning #'error))
  44   (eval '(defmethod foo ((x sub)) (slot-boundp x 'b)))
  45   (eval '(defmethod foo :around ((x super))
  46           (list (slot-value x 'a) (call-next-method)))))
  47
  48 (with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
  49   (assert (string= (with-output-to-string (*trace-output*)
  50                      (assert (equal (foo (make-instance 'sub :a 4))
  51                                     '(4 nil))))
  52                    "Called a method!Called a method!")))
  53
  54 (defclass super ()
  55   ((b :initform 3)
  56    (a :initarg :a)))
  57
  58 (with-test (:name (:mop-23 sb-mop:make-method-lambda 3))
  59   (assert (string= (with-output-to-string (*trace-output*)
  60                      (assert (equal (foo (make-instance 'sub :a 5))
  61                                     '(5 t))))
  62                    "Called a method!Called a method!")))