tests/ctor.impure.lisp

   1 ;;;; gray-box testing of the constructor optimization machinery
   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 (defpackage "CTOR-TEST"
  15   (:use "CL"))
  16
  17 (in-package "CTOR-TEST")
  18 \f
  19 (defclass no-slots () ())
  20
  21 (defun make-no-slots ()
  22   (make-instance 'no-slots))
  23 (compile 'make-no-slots)
  24
  25 (defmethod update-instance-for-redefined-class
  26     ((object no-slots) added discarded plist &rest initargs)
  27   (declare (ignore initargs))
  28   (error "Called U-I-F-R-C on ~A" object))
  29
  30 (assert (typep (make-no-slots) 'no-slots))
  31
  32 (make-instances-obsolete 'no-slots)
  33
  34 (assert (typep (make-no-slots) 'no-slots))
  35 (assert (typep (funcall #'(sb-pcl::ctor no-slots nil)) 'no-slots))
  36 \f
  37 (defclass one-slot ()
  38   ((a :initarg :a)))
  39
  40 (defun make-one-slot-a (a)
  41   (make-instance 'one-slot :a a))
  42 (compile 'make-one-slot-a)
  43 (defun make-one-slot-noa ()
  44   (make-instance 'one-slot))
  45 (compile 'make-one-slot-noa)
  46
  47 (defmethod update-instance-for-redefined-class
  48     ((object one-slot) added discarded plist &rest initargs)
  49   (declare (ignore initargs))
  50   (error "Called U-I-F-R-C on ~A" object))
  51
  52 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  53 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  54
  55 (make-instances-obsolete 'one-slot)
  56
  57 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  58 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) 4) 'a) 4))
  59 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  60 (assert (not (slot-boundp (funcall #'(sb-pcl::ctor one-slot nil)) 'a)))
  61 \f
  62 (defclass one-slot-superclass ()
  63   ((b :initarg :b)))
  64 (defclass one-slot-subclass (one-slot-superclass)
  65   ())
  66
  67 (defun make-one-slot-subclass (b)
  68   (make-instance 'one-slot-subclass :b b))
  69 (compile 'make-one-slot-subclass)
  70
  71 (defmethod update-instance-for-redefined-class
  72     ((object one-slot-superclass) added discarded plist &rest initargs)
  73   (declare (ignore initargs))
  74   (error "Called U-I-F-R-C on ~A" object))
  75
  76 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  77
  78 (make-instances-obsolete 'one-slot-subclass)
  79
  80 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  81 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 3) 'b) 3))
  82 (make-instances-obsolete 'one-slot-superclass)
  83
  84 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  85 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4))
  86 \f
  87 ;;;; success