tests/inspect.impure.lisp

   1 ;;;; tests for the INSPECT function
   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 (defun test-inspect (object &optional (control '("q")))
  15   (let* ((control (if (listp control)
  16                       (format nil "~{~A~%~}" control)
  17                       control))
  18          (*standard-input* (make-string-input-stream control))
  19          (output (make-string-output-stream))
  20          (*standard-output* output))
  21     (inspect object)
  22     (get-output-stream-string output)))
  23
  24 (defclass class-with-prototype-print-error ()
  25   ((will-be-unbound)))
  26
  27 (defmethod print-object ((object class-with-prototype-print-error) stream)
  28   (print-unreadable-object (object stream :type t)
  29     (princ (slot-value object 'will-be-unbound) stream)))
  30
  31 (with-test (:name (inspect :no-error print-object :lp-454682))
  32   (let ((class (find-class 'class-with-prototype-print-error)))
  33     ;; Prototype may not be initialized at this point.
  34     (assert (search "PROTOTYPE: " (test-inspect class)))
  35     ;; Force protocol initialization and test again.
  36     (sb-mop:class-prototype class)
  37     (assert (search "PROTOTYPE: " (test-inspect class)))))
  38
  39 (with-test (:name (inspect array :element-type :lp-1835934))
  40   (let* ((array (make-array '() :initial-element 0))
  41          (result (test-inspect array)))
  42     (assert (search "an ARRAY of T" result))
  43     (assert (search "dimensions are ()" result)))
  44
  45   (let ((array (make-array '() :element-type 'fixnum :initial-element 0)))
  46     (assert (search "an ARRAY of FIXNUM" (test-inspect array))))
  47
  48   (let ((array (let ((a (make-array () :initial-element 0)))
  49                  (make-array '() :displaced-to a))))
  50     (assert (search "a displaced ARRAY of T" (test-inspect array)))))
  51
  52 (with-test (:name (inspect vector :*inspect-length*))
  53   (let* ((array (make-array 100 :initial-element t))
  54          (result (test-inspect array)))
  55     (assert (search "(VECTOR T) of length 100." result))
  56     (assert (search "0. T" result))
  57     (assert (search "9. T" result))
  58     (assert (not (search "10. T" result)))))
  59
  60 (with-test (:name (inspect array :*inspect-length*))
  61   (let* ((array (make-array '(100 100) :initial-element t))
  62          (result (test-inspect array)))
  63     (assert (search "dimensions are (100 100)." result))
  64     (assert (search "0. [0,0] : T" result))
  65     (assert (search "9. [0,9] : T" result))
  66     (assert (not (search "10." result)))))
  67
  68 (with-test (:name (inspect vector fill-pointer))
  69   (let* ((array (make-array 3 :fill-pointer 2 :initial-element 0))
  70          (result (test-inspect array)))
  71     (assert (search "(VECTOR T) of length 2" result))))
  72
  73 (with-test (:name (inspect array nil))
  74   (let* ((array (make-array 3 :element-type nil))
  75          (result (test-inspect array)))
  76     (assert (search "(VECTOR NIL) of length 3" result)))
  77   (let* ((array (make-array '(3 3) :element-type nil))
  78          (result (test-inspect array)))
  79     (assert (search "ARRAY of NIL" result))))
  80
  81 (defclass standard-object-with-unbound-slot ()
  82   (foo))
  83
  84 (with-test (:name (inspect standard-object unbound-slot))
  85   (let* ((object (make-instance 'standard-object-with-unbound-slot))
  86          (result (test-inspect object)))
  87     (assert (search "#<unbound slot>" result))))
  88
  89 (defstruct (structure-with-unbound-slot
  90              (:constructor make-structure-with-unbound-slot (&aux foo)))
  91   foo)
  92
  93 (with-test (:name (inspect standard-object unbound-slot))
  94   (let* ((object (make-structure-with-unbound-slot))
  95          (result (test-inspect object)))
  96     (assert (search "#<unbound slot>" result))))
  97
  98 (define-condition condition-with-unbound-slot ()
  99   (foo))
 100
 101 (with-test (:name (inspect condition unbound-slot))
 102   (let* ((object (make-condition 'condition-with-unbound-slot))
 103          (result (test-inspect object)))
 104     (assert (search "#<unbound slot>" result))))