tests/clos.impure-cload.lisp

   1 ;;;; miscellaneous side-effectful tests of CLOS and file-compiler
   2 ;;;; optimizations
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 ;;; Fix due to pmai, ported from CMUCL, regarding
  16 ;;; MAKE-INSTANCES-OBSOLETE:
  17 (defclass mio-test ()
  18   ((test :initarg :test)))
  19
  20 (defun mio-demo ()
  21   (let ((x (make-instance 'mio-test :test 42)))
  22     (incf (slot-value x 'test))))
  23
  24 (defun mio-test ()
  25   (mio-demo)
  26   (make-instances-obsolete 'mio-test)
  27   (mio-demo))
  28
  29 (mio-test)
  30 \f
  31 ;;; Some tests of bits of optimized MAKE-INSTANCE that were hopelessly
  32 ;;; wrong until Gerd's ctor MAKE-INSTANCE optimization was ported.
  33 (defvar *d-i-s-e-count* 0)
  34 (defclass default-initargs-side-effect ()
  35   ((x :initarg :x))
  36   (:default-initargs :x (incf *d-i-s-e-count*)))
  37 (defun default-initargs-side-effect ()
  38   (make-instance 'default-initargs-side-effect))
  39 (assert (= *d-i-s-e-count* 0))
  40 (default-initargs-side-effect)
  41 (assert (= *d-i-s-e-count* 1))
  42 (make-instance 'default-initargs-side-effect)
  43 (assert (= *d-i-s-e-count* 2))
  44 (make-instance 'default-initargs-side-effect :x 3)
  45 (assert (= *d-i-s-e-count* 2))
  46
  47 (defclass class-allocation ()
  48   ((x :allocation :class :initarg :x :initform 3)))
  49 (defun class-allocation-reader ()
  50   (slot-value (make-instance 'class-allocation) 'x))
  51 (defun class-allocation-writer (value)
  52   (setf (slot-value (make-instance 'class-allocation) 'x) value))
  53 (assert (= (class-allocation-reader) 3))
  54 (class-allocation-writer 4)
  55 (assert (= (class-allocation-reader) 4))
  56 \f
  57 ;;; success
  58 (sb-ext:quit :unix-status 104)