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.  However, at present it is
  16 ;;; impossible to have both of these in the same image, because of a
  17 ;;; vicious metacircle.  Once the vicious metacircle is dealt with,
  18 ;;; uncomment the second test case.
  19
  20 ;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
  21
  22 (defpackage "MOP-3"
  23   (:use "CL" "SB-MOP"))
  24
  25 (in-package "MOP-3")
  26
  27 (defclass msl-generic-function (standard-generic-function)
  28   ()
  29   (:metaclass funcallable-standard-class))
  30
  31 (defun reverse-method-list (methods)
  32   (let ((result '()))
  33     (dolist (method methods)
  34       (if (and (consp result)
  35                (equal (method-qualifiers method)
  36                       (method-qualifiers (caar result))))
  37           (push method (car result))
  38           (push (list method) result)))
  39     (reduce #'append result)))
  40
  41 (defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
  42   (reverse-method-list (call-next-method)))
  43 (defmethod compute-applicable-methods-using-classes
  44     ((gf msl-generic-function) classes)
  45   (reverse-method-list (call-next-method)))
  46
  47 (defgeneric testgf07 (x)
  48   (:generic-function-class msl-generic-function)
  49   (:method ((x integer))
  50     (cons 'integer (if (next-method-p) (call-next-method))))
  51   (:method ((x real))
  52     (cons 'real (if (next-method-p) (call-next-method))))
  53   (:method ((x number))
  54     (cons 'number (if (next-method-p) (call-next-method))))
  55   (:method :around ((x integer))
  56     (coerce (call-next-method) 'vector)))
  57
  58 (assert (equalp (list (testgf07 5.0) (testgf07 17))
  59                 '((number real) #(number real integer))))
  60
  61 #|
  62 (defclass nonumber-generic-function (standard-generic-function)
  63   ()
  64   (:metaclass funcallable-standard-class))
  65
  66 (defun nonumber-method-list (methods)
  67   (remove-if #'(lambda (method)
  68                  (member (find-class 'number)
  69                          (sb-pcl:method-specializers method)))
  70              methods))
  71
  72 (defmethod compute-applicable-methods
  73     ((gf nonumber-generic-function) arguments)
  74   (nonumber-method-list (call-next-method)))
  75 (defmethod compute-applicable-methods-using-classes
  76     ((gf nonumber-generic-function) classes)
  77   (nonumber-method-list (call-next-method)))
  78
  79 (defgeneric testgf08 (x)
  80   (:generic-function-class nonumber-generic-function)
  81   (:method ((x integer))
  82     (cons 'integer (if (next-method-p) (call-next-method))))
  83   (:method ((x real))
  84     (cons 'real (if (next-method-p) (call-next-method))))
  85   (:method ((x number))
  86     (cons 'number (if (next-method-p) (call-next-method))))
  87   (:method :around ((x integer))
  88     (coerce (call-next-method) 'vector)))
  89
  90 (assert (equalp (list (testgf08 5.0) (testgf08 17))
  91                 '((real) #(integer real))))
  92 |#