1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / mop-5.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 simple tests for
15 ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION on FUNCALLABLE-INSTANCEs
16
17
18 ;;; from Justin Dubs on comp.lang.lisp
19 (defclass fn ()
20   ()
21   (:metaclass sb-mop:funcallable-standard-class))
22
23 (defvar *fn*)
24
25 (defmethod initialize-instance :after ((fn fn) &rest initargs &key
26                                        &allow-other-keys)
27   (declare (ignore initargs))
28   (sb-mop:set-funcallable-instance-function fn
29                                             (lambda (x)
30                                               (setf *fn* fn)
31                                               (1+ x))))
32
33 (let ((fun (make-instance 'fn)))
34   (assert (= (funcall fun 42) 43))
35   (assert (eq *fn* fun)))
36
37 ;;; from Tony Martinez sbcl-devel
38 (defclass counter ()
39   ((number :initarg :start :accessor counter))
40   (:metaclass sb-pcl::funcallable-standard-class))
41
42 (defun make-counter (&key (start 0))
43   (let ((instance (make-instance 'counter :start start)))
44     (sb-mop:set-funcallable-instance-function
45      instance
46      ;; When run, this function doesn't print the instance, but (what
47      ;; I think is) itself.
48      (lambda () (print instance)))
49     instance))
50
51 (defparameter *counter* (make-counter :start 666))
52
53 (assert (eq (funcall *counter*) *counter*))