File: mop-4.impure-cload.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (97 lines) | stat: -rw-r--r-- 3,270 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
;;;; miscellaneous side-effectful tests of the MOP

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
;;; subclasses of generic functions.

(defpackage "MOP-4"
  (:use "CL" "SB-MOP"))

(in-package "MOP-4")

;;; bug 343
(defclass my-generic-function1 (standard-generic-function) ()
  (:metaclass funcallable-standard-class))

(defmethod compute-discriminating-function ((gf my-generic-function1))
  (let ((dfun (call-next-method)))
    (lambda (&rest args)
      (1+ (apply dfun args)))))

(defgeneric foo (x)
  (:generic-function-class my-generic-function1))

(defmethod foo (x) (+ x x))

(assert (= (foo 5) 11))

;;; from PCL sources

(defclass my-generic-function-pcl1 (standard-generic-function) ()
  (:metaclass funcallable-standard-class))

(defmethod compute-discriminating-function ((gf my-generic-function-pcl1))
  (let ((std (call-next-method)))
    (lambda (arg)
      (print (list 'call-to-gf gf arg))
      (funcall std arg))))

(defgeneric pcl1 (x)
  (:generic-function-class my-generic-function-pcl1))

(defmethod pcl1 ((x integer)) (1+ x))

(let ((output (with-output-to-string (*standard-output*)
                (pcl1 3))))
  (assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 PCL1 (1)> 3)" output)))

#|
(defclass my-generic-function-pcl2 (standard-generic-function) ()
  (:metaclass funcallable-standard-class))
(defmethod compute-discriminating-function ((gf my-generic-function-pcl2))
  (lambda (arg)
   (cond (<some condition>
          <store some info in the generic function>
          (set-funcallable-instance-function
            gf
            (compute-discriminating-function gf))
          (funcall gf arg))
         (t
          <call-a-method-of-gf>))))
|#

;;; from clisp's test suite

(progn
  (defclass traced-generic-function (standard-generic-function)
    ()
    (:metaclass funcallable-standard-class))
  (defvar *last-traced-arguments* nil)
  (defvar *last-traced-values* nil)
  (defmethod compute-discriminating-function ((gf traced-generic-function))    (let ((orig-df (call-next-method))
          (name (generic-function-name gf)))
      #'(lambda (&rest arguments)
          (format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
          (setq *last-traced-arguments* arguments)
          (let ((values (multiple-value-list (apply orig-df arguments))))
            (format *trace-output* "~%<= ~S values: ~:S" name values)
            (setq *last-traced-values* values)
            (values-list values)))))
  (defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
     (:method ((x number)) (values x (- x) (* x x) (/ x))))
  (testgf15 5)
  (assert (equal (list *last-traced-arguments* *last-traced-values*)
                 '((5) (5 -5 25 1/5)))))

;;; also we might be in a position to run the "application example"
;;; from mop.tst in clisp's test suite