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 ;;; from Justin Dubs on comp.lang.lisp
  18 (defclass fn ()
  19   ()
  20   (:metaclass sb-mop:funcallable-standard-class))
  21
  22 (defvar *fn*)
  23
  24 (defmethod initialize-instance :after ((fn fn) &rest initargs &key
  25                                        &allow-other-keys)
  26   (declare (ignore initargs))
  27   (sb-mop:set-funcallable-instance-function fn
  28                                             (lambda (x)
  29                                               (setf *fn* fn)
  30                                               (1+ x))))
  31
  32 (with-test (:name (:mop-5 1))
  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 (make-broadcast-stream))))
  49     instance))
  50
  51 (defparameter *counter* (make-counter :start 666))
  52
  53 (with-test (:name (:mop-5 2))
  54   (assert (eq (funcall *counter*) *counter*)))