tests/clos-1.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of CLOS
   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 ;;; clos.impure.lisp was getting too big and confusing
  15
  16 (load "assertoid.lisp")
  17
  18 (defpackage "CLOS-1"
  19   (:use "CL" "ASSERTOID" "TEST-UTIL"))
  20
  21 ;;; tests that various optimization paths for slot-valuish things
  22 ;;; respect class redefinitions.
  23 (defclass foo ()
  24   ((a :initarg :a)))
  25
  26 (defvar *foo* (make-instance 'foo :a 1))
  27
  28 (defmethod a-of ((x foo))
  29   (slot-value x 'a))
  30 (defmethod b-of ((x foo))
  31   (slot-value x 'b))
  32 (defmethod c-of ((x foo))
  33   (slot-value x 'c))
  34
  35 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
  36   (dotimes (i 4) ; KLUDGE: get caches warm
  37     (assert (= 1 (slot-value *foo* 'a)))
  38     (assert (= 1 (a-of *foo*)))
  39     (assert (= 1 (funcall fun *foo*)))
  40     (assert (raises-error? (b-of *foo*)))
  41     (assert (raises-error? (c-of *foo*)))))
  42
  43 (defclass foo ()
  44   ((b :initarg :b :initform 3) (a :initarg :a)))
  45
  46 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
  47   (dotimes (i 4) ; KLUDGE: get caches warm
  48     (assert (= 1 (slot-value *foo* 'a)))
  49     (assert (= 1 (a-of *foo*)))
  50     (assert (= 1 (funcall fun *foo*)))
  51     (assert (= 3 (b-of *foo*)))
  52     (assert (raises-error? (c-of *foo*)))))
  53
  54 (defclass foo ()
  55   ((c :initarg :c :initform t :allocation :class)
  56    (b :initarg :b :initform 3)
  57    (a :initarg :a)))
  58
  59 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
  60   (dotimes (i 4) ; KLUDGE: get caches warm
  61     (assert (= 1 (slot-value *foo* 'a)))
  62     (assert (= 1 (a-of *foo*)))
  63     (assert (= 1 (funcall fun *foo*)))
  64     (assert (= 3 (b-of *foo*)))
  65     (assert (eq t (c-of *foo*)))))
  66
  67 (defclass foo ()
  68   ((a :initarg :a)
  69    (b :initarg :b :initform 3)
  70    (c :initarg :c :initform t)))
  71
  72 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
  73   (dotimes (i 4) ; KLUDGE: get caches warm
  74     (assert (= 1 (slot-value *foo* 'a)))
  75     (assert (= 1 (a-of *foo*)))
  76     (assert (= 1 (funcall fun *foo*)))
  77     (assert (= 3 (b-of *foo*)))
  78     (assert (eq t (c-of *foo*)))))
  79
  80 (defclass foo ()
  81   ((b :initarg :b :initform 3)))
  82
  83 (let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
  84   (dotimes (i 4) ; KLUDGE: get caches warm
  85     (assert (raises-error? (slot-value *foo* 'a)))
  86     (assert (raises-error? (a-of *foo*)))
  87     (assert (raises-error? (funcall fun *foo*)))
  88     (assert (= 3 (b-of *foo*)))
  89     (assert (raises-error? (c-of *foo*)))))