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 ;;; from James Anderson via Gerd Moellmann: defining methods with
  58 ;;; specializers with forward-referenced superclasses used not to
  59 ;;; work.
  60 (defclass specializer1 () ())
  61 (defclass specializer2 (forward-ref1) ())
  62 (defmethod baz ((x specializer2)) x)
  63 (defmethod baz ((x specializer1)) x)
  64 (assert (typep (baz (make-instance 'specializer1)) 'specializer1))
  65
  66 ;;; ... and from McCLIM, another test case:
  67 (defclass specializer1a (specializer2a specializer2b) ())
  68 (defclass specializer2a () ())
  69 (defmethod initialize-instance :after
  70     ((obj specializer2a) &key &allow-other-keys)
  71   (print obj))
  72
  73 ;;; in a similar vein, we should be able to define methods on classes
  74 ;;; that are effectively unknown to the type system:
  75 (sb-mop:ensure-class 'unknown-type)
  76 (defmethod method-on-unknown ((x unknown-type)) x)
  77 ;;; (we can't call it without defining methods on allocate-instance
  78 ;;; etc., but we should be able to define it).
  79 \f
  80 ;;; the ctor MAKE-INSTANCE optimizer used not to handle duplicate
  81 ;;; initargs...
  82 (defclass dinitargs-class1 ()
  83   ((a :initarg :a)))
  84 (assert (= (slot-value (make-instance 'dinitargs-class1 :a 1 :a 2) 'a) 1))
  85
  86 (defclass dinitargs-class2 ()
  87   ((b :initarg :b1 :initarg :b2)))
  88 (assert (= (slot-value (make-instance 'dinitargs-class2 :b2 3 :b1 4) 'b) 3))
  89 ;;; ... or default-initargs when the location was already initialized
  90 (defvar *definitargs-counter* 0)
  91 (defclass definitargs-class ()
  92   ((a :initarg :a :initarg :a2))
  93   (:default-initargs :a2 (incf *definitargs-counter*)))
  94 (assert (= (slot-value (make-instance 'definitargs-class) 'a) 1))
  95 (assert (= (slot-value (make-instance 'definitargs-class :a 0) 'a) 0))
  96 (assert (= *definitargs-counter* 2))
  97
  98 ;;; inherited local -> shared slot initforms
  99 ;;  (adapted from Paul F. Dietz's test suite DEFCLASS-0211.1)
 100 (defclass shared-to-local-initform-super ()
 101   ((redefined :allocation :instance :initform 'orig-initform)))
 102 (defclass shared-to-local-initform-sub (shared-to-local-initform-super)
 103   ((redefined :allocation :class)))
 104 (assert (slot-boundp (make-instance 'shared-to-local-initform-sub) 'redefined))
 105 (assert (eq 'orig-initform
 106             (slot-value (make-instance 'shared-to-local-initform-sub) 'redefined)))
 107 \f
 108 (defgeneric no-ignored-warnings (x y))
 109 (handler-case
 110     (eval '(defmethod no-ignored-warnings ((x t) (y t))
 111             (declare (ignore x y)) nil))
 112   (style-warning (c) (error c)))
 113 (handler-case
 114     (eval '(defmethod no-ignored-warnings ((x number) (y t))
 115             (declare (ignore x y)) (setq *print-level* nil)))
 116   (style-warning (c) (error c)))
 117 (handler-case
 118     (eval '(defmethod no-ignored-warnings ((x fixnum) (y t))
 119             (declare (ignore x)) (setq y 'foo)))
 120   (style-warning (c) (error c)))
 121 \f
 122 ;;; ctor optimization bugs:
 123 ;;;
 124 ;;; :DEFAULT-INITARGS not checked for validity
 125 (defclass invalid-default-initargs ()
 126   ((foo :initarg :foo))
 127   (:default-initargs :invalid-initarg 2))
 128 (multiple-value-bind (result condition)
 129     (ignore-errors (make-instance 'invalid-default-initargs :foo 1))
 130   (assert (null result))
 131   (assert (typep condition 'program-error)))
 132 ;;; :DEFAULT-INITARGS not passed to INITIALIZE-INSTANCE or
 133 ;;; SHARED-INITIALIZE :BEFORE methods.
 134 (defclass default-initargs-with-method ()
 135   ((foo :initarg :valid-initarg))
 136   (:default-initargs :valid-initarg 2))
 137 (defmethod shared-initialize :before ((thing default-initargs-with-method)
 138                                       slot-names &key valid-initarg)
 139   (assert (= valid-initarg 2)))
 140 (make-instance 'default-initargs-with-method)
 141 ;;; and a test with a non-constant initarg
 142 (defvar *d-i-w-m-2* 0)
 143 (defclass default-initargs-with-method2 ()
 144   ((foo :initarg :valid-initarg))
 145   (:default-initargs :valid-initarg (incf *d-i-w-m-2*)))
 146 (defmethod shared-initialize :before ((thing default-initargs-with-method2)
 147                                       slot-names &key valid-initarg)
 148   (assert (= valid-initarg 1)))
 149 (make-instance 'default-initargs-with-method2)
 150 (assert (= *d-i-w-m-2* 1))
 151 \f
 152 ;;; from Axel Schairer on cmucl-imp 2004-08-05
 153 (defclass class-with-symbol-initarg ()
 154   ((slot :initarg slot)))
 155 (defmethod initialize-instance :after
 156     ((x class-with-symbol-initarg) &rest initargs &key &allow-other-keys)
 157   (unless (or (null initargs)
 158               (eql (getf initargs 'slot)
 159                    (slot-value x 'slot)))
 160     (error "bad bad bad")))
 161 (defun make-thing (arg)
 162   (make-instance 'class-with-symbol-initarg 'slot arg))
 163 (defun make-other-thing (slot arg)
 164   (make-instance 'class-with-symbol-initarg slot arg))
 165 (assert (eql (slot-value (make-thing 1) 'slot) 1))
 166 (assert (eql (slot-value (make-other-thing 'slot 2) 'slot) 2))
 167 \f
 168 ;;; test that ctors can be used with the literal class
 169 (eval-when (:compile-toplevel)
 170   (defclass ctor-literal-class () ())
 171   (defclass ctor-literal-class2 () ()))
 172 (defun ctor-literal-class ()
 173   (make-instance #.(find-class 'ctor-literal-class)))
 174 (defun ctor-literal-class2 ()
 175   (make-instance '#.(find-class 'ctor-literal-class2)))
 176 (with-test (:name (:ctor :literal-class-unquoted))
 177   (assert (typep (ctor-literal-class) 'ctor-literal-class)))
 178 (with-test (:name (:ctor :literal-class-quoted))
 179   (assert (typep (ctor-literal-class2) 'ctor-literal-class2)))
 180 \f
 181 ;;; test that call-next-method and eval-when doesn't cause an
 182 ;;; undumpable method object to arise in the effective source code.
 183 ;;; (from Sascha Wilde sbcl-devel 2007-07-15)
 184 (eval-when (:compile-toplevel :load-toplevel :execute)
 185   (defmethod just-call-next-method (thing)
 186     (call-next-method)))