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 (defpackage "MOP-23"
  18   (:use "CL" "SB-MOP"))
  19
  20 (in-package "MOP-23")
  21
  22 (defclass verbose-generic-function (standard-generic-function) ()
  23   (:metaclass funcallable-standard-class))
  24 (defmethod make-method-lambda
  25     ((gf verbose-generic-function) method lambda env)
  26   (multiple-value-bind (lambda initargs)
  27       (call-next-method)
  28     (values
  29      `(lambda (args next-methods)
  30        (format *trace-output* "Called a method!")
  31        (,lambda args next-methods))
  32      initargs)))
  33
  34 (defgeneric foo (x)
  35   (:generic-function-class verbose-generic-function))
  36
  37 (handler-bind ((warning #'error))
  38   (eval '(defmethod foo ((x integer)) (1+ x))))
  39
  40 (assert (string= (with-output-to-string (*trace-output*)
  41                    (assert (= (foo 3) 4)))
  42                  "Called a method!"))
  43
  44 (defclass super () ((a :initarg :a)))
  45 (defclass sub (super) (b))
  46
  47 (handler-bind ((warning #'error))
  48   (eval '(defmethod foo ((x sub)) (slot-boundp x 'b)))
  49   (eval '(defmethod foo :around ((x super))
  50           (list (slot-value x 'a) (call-next-method)))))
  51
  52 (assert (string= (with-output-to-string (*trace-output*)
  53                    (assert (equal (foo (make-instance 'sub :a 4))
  54                                   '(4 nil))))
  55                  "Called a method!Called a method!"))