tests/mop-4.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 tests for COMPUTE-DISCRIMINATING-FUNCTION on
  15 ;;; subclasses of generic functions.
  16
  17 (defpackage "MOP-4"
  18   (:use "CL" "SB-MOP"))
  19
  20 (in-package "MOP-4")
  21
  22 ;;; bug 343
  23 (defclass my-generic-function1 (standard-generic-function) ()
  24   (:metaclass funcallable-standard-class))
  25
  26 (defmethod compute-discriminating-function ((gf my-generic-function1))
  27   (let ((dfun (call-next-method)))
  28     (lambda (&rest args)
  29       (1+ (apply dfun args)))))
  30
  31 (defgeneric foo (x)
  32   (:generic-function-class my-generic-function1))
  33
  34 (defmethod foo (x) (+ x x))
  35
  36 (assert (= (foo 5) 11))
  37
  38 ;;; from PCL sources
  39
  40 (defclass my-generic-function-pcl1 (standard-generic-function) ()
  41   (:metaclass funcallable-standard-class))
  42
  43 (defmethod compute-discriminating-function ((gf my-generic-function-pcl1))
  44   (let ((std (call-next-method)))
  45     (lambda (arg)
  46       (print (list 'call-to-gf gf arg))
  47       (funcall std arg))))
  48
  49 (defgeneric pcl1 (x)
  50   (:generic-function-class my-generic-function-pcl1))
  51
  52 (defmethod pcl1 ((x integer)) (1+ x))
  53
  54 (let ((output (with-output-to-string (*standard-output*)
  55                 (pcl1 3))))
  56   (assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 PCL1 (1)> 3)" output)))
  57
  58 #|
  59 (defclass my-generic-function-pcl2 (standard-generic-function) ()
  60   (:metaclass funcallable-standard-class))
  61 (defmethod compute-discriminating-function ((gf my-generic-function-pcl2))
  62   (lambda (arg)
  63    (cond (<some condition>
  64           <store some info in the generic function>
  65           (set-funcallable-instance-function
  66             gf
  67             (compute-discriminating-function gf))
  68           (funcall gf arg))
  69          (t
  70           <call-a-method-of-gf>))))
  71 |#
  72
  73 ;;; from clisp's test suite
  74
  75 (progn
  76   (defclass traced-generic-function (standard-generic-function)
  77     ()
  78     (:metaclass funcallable-standard-class))
  79   (defvar *last-traced-arguments* nil)
  80   (defvar *last-traced-values* nil)
  81   (defmethod compute-discriminating-function ((gf traced-generic-function))    (let ((orig-df (call-next-method))
  82           (name (generic-function-name gf)))
  83       #'(lambda (&rest arguments)
  84           (format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
  85           (setq *last-traced-arguments* arguments)
  86           (let ((values (multiple-value-list (apply orig-df arguments))))
  87             (format *trace-output* "~%<= ~S values: ~:S" name values)
  88             (setq *last-traced-values* values)
  89             (values-list values)))))
  90   (defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
  91      (:method ((x number)) (values x (- x) (* x x) (/ x))))
  92   (testgf15 5)
  93   (assert (equal (list *last-traced-arguments* *last-traced-values*)
  94                  '((5) (5 -5 25 1/5)))))
  95
  96 ;;; also we might be in a position to run the "application example"
  97 ;;; from mop.tst in clisp's test suite