tests/mop-3.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 contains two tests for COMPUTE-APPLICABLE-METHODS on
  15 ;;; subclasses of generic functions.
  16
  17 ;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
  18
  19 (defclass msl-generic-function (standard-generic-function)
  20   ()
  21   (:metaclass sb-mop:funcallable-standard-class))
  22
  23 (defun reverse-method-list (methods)
  24   (let ((result '()))
  25     (dolist (method methods)
  26       (if (and (consp result)
  27                (equal (sb-mop:method-qualifiers method)
  28                       (sb-mop:method-qualifiers (caar result))))
  29           (push method (car result))
  30           (push (list method) result)))
  31     (reduce #'append result)))
  32
  33 (defmethod sb-mop:compute-applicable-methods ((gf msl-generic-function) arguments)
  34   (reverse-method-list (call-next-method)))
  35 (defmethod sb-mop:compute-applicable-methods-using-classes
  36     ((gf msl-generic-function) classes)
  37   (reverse-method-list (call-next-method)))
  38
  39 (defgeneric testgf07 (x)
  40   (:generic-function-class msl-generic-function)
  41   (:method ((x integer))
  42     (cons 'integer (if (next-method-p) (call-next-method))))
  43   (:method ((x real))
  44     (cons 'real (if (next-method-p) (call-next-method))))
  45   (:method ((x number))
  46     (cons 'number (if (next-method-p) (call-next-method))))
  47   (:method :around ((x integer))
  48     (coerce (call-next-method) 'vector)))
  49
  50 (with-test (:name (:mop-3 1))
  51   (assert (equalp (list (testgf07 5.0) (testgf07 17))
  52                   '((number real) #(number real integer)))))
  53
  54 (defclass nonumber-generic-function (standard-generic-function)
  55   ()
  56   (:metaclass sb-mop:funcallable-standard-class))
  57
  58 (defun nonumber-method-list (methods)
  59   (remove-if #'(lambda (method)
  60                  (member (find-class 'number)
  61                          (sb-mop:method-specializers method)))
  62              methods))
  63
  64 (defmethod sb-mop:compute-applicable-methods
  65     ((gf nonumber-generic-function) arguments)
  66   (nonumber-method-list (call-next-method)))
  67 (defmethod sb-mop:compute-applicable-methods-using-classes
  68     ((gf nonumber-generic-function) classes)
  69   (nonumber-method-list (call-next-method)))
  70
  71 (defgeneric testgf08 (x)
  72   (:generic-function-class nonumber-generic-function)
  73   (:method ((x integer))
  74     (cons 'integer (if (next-method-p) (call-next-method))))
  75   (:method ((x real))
  76     (cons 'real (if (next-method-p) (call-next-method))))
  77   (:method ((x number))
  78     (cons 'number (if (next-method-p) (call-next-method))))
  79   (:method :around ((x integer))
  80     (coerce (call-next-method) 'vector)))
  81
  82 (with-test (:name (:mop-3 2))
  83   (assert (equalp (list (testgf08 5.0) (testgf08 17))
  84                   '((real) #(integer real)))))