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.  However, at present it is
  16 ;;; impossible to have more than one of these in the same image,
  17 ;;; because of a vicious metacircle.  Once the vicious metacircle is
  18 ;;; dealt with, uncomment the test cases.
  19
  20 (defpackage "MOP-4"
  21   (:use "CL" "SB-MOP"))
  22
  23 (in-package "MOP-4")
  24
  25 ;;; bug 343
  26 (defclass my-generic-function1 (standard-generic-function) ()
  27   (:metaclass funcallable-standard-class))
  28
  29 (defmethod compute-discriminating-function ((gf my-generic-function1))
  30   (let ((dfun (call-next-method)))
  31     (lambda (&rest args)
  32       (1+ (apply dfun args)))))
  33
  34 (defgeneric foo (x)
  35   (:generic-function-class my-generic-function1))
  36
  37 (defmethod foo (x) (+ x x))
  38
  39 (assert (= (foo 5) 11))
  40
  41 #|
  42
  43 ;;; from PCL sources
  44
  45 (defmethod compute-discriminating-function ((gf my-generic-function))
  46   (let ((std (call-next-method)))
  47     (lambda (arg)
  48       (print (list 'call-to-gf gf arg))
  49       (funcall std arg))))
  50
  51 and
  52
  53 (defmethod compute-discriminating-function ((gf my-generic-function))
  54   (lambda (arg)
  55    (cond (<some condition>
  56           <store some info in the generic function>
  57           (set-funcallable-instance-function
  58             gf
  59             (compute-discriminating-function gf))
  60           (funcall gf arg))
  61          (t
  62           <call-a-method-of-gf>))))
  63
  64 |#
  65
  66 #|
  67
  68 ;;; from clisp's test suite
  69
  70 (progn
  71   (defclass traced-generic-function (standard-generic-function)
  72     ()
  73     (:metaclass clos:funcallable-standard-class))
  74   (defvar *last-traced-arguments* nil)
  75   (defvar *last-traced-values* nil)
  76   (defmethod clos:compute-discriminating-function ((gf traced-generic-function))    (let ((orig-df (call-next-method))
  77           (name (clos:generic-function-name gf)))
  78       #'(lambda (&rest arguments)
  79           (declare (compile))
  80           (format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
  81           (setq *last-traced-arguments* arguments)
  82           (let ((values (multiple-value-list (apply orig-df arguments))))
  83             (format *trace-output* "~%<= ~S values: ~:S" name values)
  84             (setq *last-traced-values* values)
  85             (values-list values)))))
  86   (defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
  87      (:method ((x number)) (values x (- x) (* x x) (/ x))))
  88   (testgf15 5)
  89   (list *last-traced-arguments* *last-traced-values*))
  90
  91 ;;; also we might be in a position to run the "application example"
  92 ;;; from mop.tst in clisp's test suite
  93
  94 |#