tests/slot-value.impure.lisp

   1 ;;;; Tests of SLOT-VALUE
   2
   3 (load "compiler-test-util.lisp")
   4 (defpackage "SLOT-VALUE-TEST"
   5   (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL"))
   6
   7 (in-package "SLOT-VALUE-TEST")
   8
   9 (defclass a-class ()
  10   ((x :initform 123)))
  11
  12 (defun a-class-x-0 (a)
  13   (slot-value a 'x))
  14
  15 (defmethod a-class-x-1 ((a a-class))
  16   (slot-value a 'x))
  17
  18 (defmethod a-class-x-2 ((a a-class))
  19   (let ((%a a))
  20     (slot-value %a 'x)))
  21
  22 (defmethod a-class-x-3 ((a t))
  23   (slot-value a 'x))
  24
  25 (with-test (:name (slot-value defun))
  26   (assert (= (a-class-x-0 (make-instance 'a-class)) 123)))
  27
  28 (with-test (:name (slot-value defmethod))
  29   (assert (= (a-class-x-1 (make-instance 'a-class)) 123)))
  30
  31 (with-test (:name (slot-value defmethod let))
  32   (assert (= (a-class-x-2 (make-instance 'a-class)) 123)))
  33
  34 (with-test (:name (slot-value defmethod t))
  35   (assert (= (a-class-x-3 (make-instance 'a-class)) 123)))
  36
  37 (defun read-slot-way1 (instance slot)
  38   (slot-value instance slot))
  39 (defun read-slot-way2 (instance slot)
  40   (slot-value (the structure-object instance) slot))
  41 (compile 'read-slot-way1)
  42 (compile 'read-slot-way2)
  43
  44 ;;; Collect up a bunch of instances that are subtypes of STRUCTURE-OBJECT
  45 (with-test (:name :fast-structure-slot-value)
  46   (let ((instances
  47          (sb-vm:list-allocated-objects
  48           :all :type sb-vm:instance-widetag
  49           :test (lambda (x)
  50                   (and (typep x 'structure-object)
  51                        ;; want to ensure the instances under test are mostly immutable.
  52                        ;; This is no guarantee, but it works.
  53                        (eq (sb-kernel:generation-of x)
  54                            sb-vm:+pseudo-static-generation+)))
  55           :count 10000)))
  56     (dolist (x instances)
  57       (let* ((layout (sb-kernel:%instance-layout x))
  58              (dd (sb-kernel:layout-dd layout)))
  59         (dolist (dsd (sb-kernel:dd-slots dd))
  60           (let ((slot-name (sb-kernel:dsd-name dsd)))
  61             ;; some slots may be raw, don't worry about being EQ
  62             (assert (eql (read-slot-way1 x slot-name)
  63                          (read-slot-way2 x slot-name)))))))))