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*))