contrib/sb-aclrepl/tests.lisp

   1 ;; Tests for sb-aclrepl
   2
   3 (defpackage #:aclrepl-tests
   4   (:use #:sb-aclrepl #:cl #:sb-rt))
   5 (in-package #:aclrepl-tests)
   6
   7 (declaim (special sb-aclrepl::*skip-address-display*
   8                   sb-aclrepl::*inspect-unbound-object-marker*))
   9
  10 (setf sb-rt::*catch-errors* nil)
  11
  12 (rem-all-tests)
  13
  14 (deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t)
  15 (deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t)
  16 (deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t)
  17 ;(deftest (boundp 'sb-debug::*invoke-debugger-fun*) t)
  18
  19 ;;; Inspector tests
  20
  21 (defclass empty-class ()
  22   ())
  23 (defparameter *empty-class* (make-instance 'empty-class))
  24
  25 (defclass empty-class ()
  26   ())
  27
  28 (defclass simple-class ()
  29   ((a)
  30    (second :initform 0)
  31    (really-long-slot-name :initform "abc")))
  32
  33 (defstruct empty-struct
  34   )
  35
  36 (defstruct tiny-struct
  37   (first 10))
  38
  39 (defstruct simple-struct
  40   (first)
  41   (slot-2 'a-value)
  42   (really-long-struct-slot-name "defg"))
  43
  44 (defparameter *empty-class* (make-instance 'empty-class))
  45 (defparameter *simple-class* (make-instance 'simple-class))
  46 (defparameter *empty-struct* (make-empty-struct))
  47 (defparameter *tiny-struct* (make-tiny-struct))
  48 (defparameter *simple-struct* (make-simple-struct))
  49 (defparameter *normal-list* '(a b 3))
  50 (defparameter *dotted-list* '(a b . 3))
  51 (defparameter *cons-pair* '(#c(1 2) . a-symbol))
  52 (defparameter *complex* #c(1 2))
  53 (defparameter *ratio* 22/7)
  54 (defparameter *double* 5.5d0)
  55 (defparameter *bignum* 4938271560493827156)
  56 (defparameter *array* (make-array '(3 3 2) :initial-element nil))
  57 (defparameter *vector* (make-array '(20):initial-contents
  58                              '(0 1 2 3 4 5 6 7 8 9
  59                                10 11 12 13 14 15 16 17 18 19)))
  60 (eval-when (:compile-toplevel :load-toplevel :execute)
  61   (defparameter *circle-list1* '(a))
  62   (setf (car *circle-list1*) *circle-list1*)
  63   (defparameter *circle-list2* '(b))
  64   (setf (cdr *circle-list2*) *circle-list2*)
  65   (defparameter *circle-list3* '(a b c))
  66   (setf (car *circle-list3*) *circle-list3*)
  67   (defparameter *circle-list4* '(a b c))
  68   (setf (second *circle-list4*) *circle-list4*)
  69   (defparameter *circle-list5* '(a b c))
  70   (setf (cddr *circle-list5*) *circle-list5*))
  71
  72 (defun find-position (object id)
  73     (nth-value 0 (sb-aclrepl::find-part-id object id)))
  74 (defun parts (object)
  75   (let ((sb-aclrepl::*skip-address-display* t))
  76     (sb-aclrepl::inspected-parts object)))
  77 (defun description (object)
  78   (let ((sb-aclrepl::*skip-address-display* t))
  79     (sb-aclrepl::inspected-description object)))
  80 (defun elements (object &optional print (skip 0))
  81   (let ((sb-aclrepl::*skip-address-display* t))
  82     (sb-aclrepl::inspected-elements object print skip)))
  83 (defun elements-components (object &optional print (skip 0))
  84     (nth-value 0 (elements object print skip )))
  85 (defun elements-labels (object &optional print (skip 0))
  86     (nth-value 1 (elements object print skip)))
  87 (defun elements-count (object &optional print (skip 0))
  88   (nth-value 2 (elements object print skip)))
  89
  90 (defun labeled-element (object pos &optional print (skip 0))
  91   (with-output-to-string (strm)
  92     (let ((sb-aclrepl::*skip-address-display* t))
  93       (sb-aclrepl::display-labeled-element
  94        (aref (the simple-vector (elements-components object print skip)) pos)
  95        (aref (the simple-vector (elements-labels object print skip)) pos)
  96        strm))))
  97
  98 (defun display (object &optional print (skip 0))
  99   (with-output-to-string (strm)
 100     (let ((sb-aclrepl::*skip-address-display* t))
 101       (sb-aclrepl::display-inspect object strm print skip))))
 102
 103 (defun istep (args)
 104   (with-output-to-string (strm)
 105     (let ((sb-aclrepl::*skip-address-display* t))
 106       (sb-aclrepl::istep args strm))))
 107
 108 (deftest find.list.0 (find-position *normal-list* 0) 0)
 109 (deftest find.list.1 (find-position *normal-list* 0) 0)
 110 (deftest find.list.2 (find-position *normal-list* 1) 1)
 111 (deftest find.list.3 (find-position *normal-list* 2) 2)
 112 (deftest parts.list.1 (sb-aclrepl::parts-count (parts *normal-list*)) 3)
 113 (deftest parts.list.2 (sb-aclrepl::component-at (parts *normal-list*) 0) a)
 114 (deftest parts.list.3 (sb-aclrepl::component-at (parts *normal-list*) 1) b)
 115 (deftest parts.list.4 (sb-aclrepl::component-at (parts *normal-list*) 2) 3)
 116 (deftest parts.list.5 (sb-aclrepl::label-at (parts *normal-list*) 0) 0)
 117 (deftest parts.list.6 (sb-aclrepl::label-at (parts *normal-list*) 1) 1)
 118 (deftest parts.list.7 (sb-aclrepl::label-at (parts *normal-list*) 2) 2)
 119 (deftest parts.list.8 (sb-aclrepl::parts-seq-type (parts *normal-list*)) :list)
 120
 121 (eval-when (:compile-toplevel :load-toplevel :execute)
 122   (defun basename (id &optional print (skip 0))
 123     (let ((name (typecase id
 124                   (symbol (symbol-name id))
 125                   (string (string-upcase id))
 126                   (t (format nil "~A" id)))))
 127       (format nil "~A~A~A"
 128               (string-left-trim "*" (string-right-trim "*" name))
 129               (if print (format nil ".P~D" print) "")
 130               (if (not (zerop skip)) (format nil ".S~D" skip) ""))))
 131
 132   (defun elements-tests-name (id ext print skip)
 133     (intern (format nil "ELEM.~A.~A" (basename id print skip) ext))))
 134
 135 (defmacro def-elements-tests (object count components labels
 136                           &optional (print nil) (skip 0))
 137   `(progn
 138     (deftest ,(elements-tests-name object "COUNT" print skip)
 139         (elements-count ,object ,print ,skip) ,count)
 140     (unless (eq ,components :dont-check)
 141       (deftest ,(elements-tests-name object "COMPONENTS" print skip)
 142           (elements-components ,object ,print ,skip) ,components))
 143     (deftest ,(elements-tests-name object "LABELS" print skip)
 144         (elements-labels ,object ,print ,skip) ,labels)))
 145
 146 (def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2))
 147 (def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail))
 148
 149 (def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr")))
 150 (def-elements-tests *circle-list2* 2 :dont-check #(0 :tail))
 151 (def-elements-tests *circle-list3* 3 :dont-check #(0 1 2))
 152 (def-elements-tests *circle-list4* 3 :dont-check #(0 1 2))
 153 (def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail))
 154
 155 (deftest circle-list1-components
 156     (aref (elements-components *circle-list1*) 0) #.*circle-list1*)
 157 (deftest circle-list2-components.0
 158     (aref (elements-components *circle-list2*) 0) b)
 159 (deftest circle-list2-components.1
 160     (aref (elements-components *circle-list2*) 1) #.*circle-list2*)
 161 (deftest circle-list3-components.0
 162     (aref (elements-components *circle-list3*) 0) #.*circle-list3*)
 163 (deftest circle-list3-components.1
 164     (aref (elements-components *circle-list3*) 1) b)
 165 (deftest circle-list3-components.2
 166     (aref (elements-components *circle-list3*) 2) c)
 167 (deftest circle-list4-components.0
 168     (aref (elements-components *circle-list4*) 0) a)
 169 (deftest circle-list4-components.1
 170     (aref (elements-components *circle-list4*) 1) #.*circle-list4*)
 171 (deftest circle-list4-components.2
 172     (aref (elements-components *circle-list4*) 2) c)
 173 (deftest circle-list5-components.0
 174     (aref (elements-components *circle-list5*) 0) a)
 175 (deftest circle-list5-components.1
 176     (aref (elements-components *circle-list5*) 1) b)
 177 (deftest circle-list5-components.2
 178     (aref (elements-components *circle-list5*) 2) #.*circle-list5*)
 179
 180 (def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol)
 181                 #((0 . "car") (1 . "cdr")))
 182 (def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag")))
 183 (def-elements-tests *ratio* 2 #(22 7)
 184                 #((0 . "numerator") (1 . "denominator")))
 185 (case sb-vm::n-word-bits
 186   (32
 187    (def-elements-tests *bignum* 2
 188      #(4154852436 1149780945)
 189      #((0 . :HEX32) (1 . :HEX32))))
 190   (64
 191    (def-elements-tests *bignum* 1
 192      #(4938271560493827156)
 193      #((0 . :HEX64)))))
 194
 195 (def-elements-tests *vector* 20
 196                 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
 197                 #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19))
 198 (def-elements-tests *vector* 18
 199   #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
 200   #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)
 201   nil 3)
 202 (def-elements-tests *vector* 13
 203   #(nil 3 4 5 6 7 8 9 10 11 12 nil 19)
 204   #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19)
 205   10 3)
 206 (def-elements-tests *vector* 5
 207   #(nil 16 17 18 19)
 208   #(:ellipses 16 17 18 19)
 209   5 16)
 210 (def-elements-tests *vector* 5
 211   #(nil 16 17 18 19)
 212   #(:ellipses 16 17 18 19)
 213   2 16)
 214 (def-elements-tests *vector* 5
 215   #(nil 15 16 nil 19)
 216   #(:ellipses 15 16 :ellipses 19)
 217   2 15)
 218 (def-elements-tests *array* 18
 219    #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
 220                 NIL NIL)
 221   #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]")
 222     (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]")
 223     (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]")
 224     (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]")
 225     (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]")
 226     (17 . "[2,2,1]")))
 227
 228 (def-elements-tests *empty-class* 0 nil nil)
 229 #+ignore ;; FIXME
 230 (def-elements-tests *simple-class* 3
 231   #(#.sb-aclrepl::*inspect-unbound-object-marker* 0 "abc")
 232   #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME")))
 233 (def-elements-tests *empty-struct* 0 nil nil)
 234 (def-elements-tests *simple-struct* 3
 235   #(nil a-value "defg")
 236   #((0 . "FIRST") (1 . "SLOT-2")
 237     (2 . "REALLY-LONG-STRUCT-SLOT-NAME")))
 238
 239 (eval-when (:compile-toplevel :load-toplevel :execute)
 240   (defun label-test-name (name pos &optional print (skip 0))
 241     (intern (format nil "LABEL.~A.~D" (basename name print skip) pos))))
 242
 243 (defmacro def-label-test (object pos label &optional print (skip 0))
 244   `(deftest ,(label-test-name object pos print skip)
 245     (labeled-element ,object ,pos ,print ,skip) ,label))
 246
 247 (def-label-test *simple-struct* 0
 248   "   0 FIRST ----------> the symbol NIL")
 249 (def-label-test *simple-struct* 1
 250   "   1 SLOT-2 ---------> the symbol A-VALUE")
 251 (def-label-test *simple-struct* 2
 252  "   2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
 253 (def-label-test *simple-class* 0
 254   "   0 A --------------> ..unbound..")
 255 (def-label-test *simple-class* 1
 256   "   1 SECOND ---------> fixnum 0")
 257 (def-label-test *simple-class* 2
 258   "   2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"")
 259
 260 (def-label-test *complex* 0 "   0 real -----------> fixnum 1")
 261 (def-label-test *complex* 1 "   1 imag -----------> fixnum 2")
 262
 263 (def-label-test *ratio* 0 "   0 numerator ------> fixnum 22")
 264 (def-label-test *ratio* 1 "   1 denominator ----> fixnum 7")
 265
 266 (def-label-test *dotted-list* 0 "   0-> the symbol A")
 267 (def-label-test *dotted-list* 1 "   1-> the symbol B")
 268 (def-label-test *dotted-list* 2 "tail-> fixnum 3")
 269
 270 (def-label-test *normal-list* 0 "   0-> the symbol A")
 271 (def-label-test *normal-list* 1 "   1-> the symbol B")
 272 (def-label-test *normal-list* 2 "   2-> fixnum 3")
 273
 274 (def-label-test *vector* 0 "   0-> fixnum 0")
 275 (def-label-test *vector* 1 "   1-> fixnum 1")
 276 (def-label-test *vector* 0 "   ..." nil 2)
 277 (def-label-test *vector* 1"   2-> fixnum 2" nil 2)
 278
 279 (def-label-test *cons-pair* 0
 280     "   0 car ------------> complex number #C(1 2)")
 281 (def-label-test *cons-pair* 1
 282   "   1 cdr ------------> the symbol A-SYMBOL")
 283
 284 (deftest nil.parts.0 (elements-count nil) 5)
 285
 286 (def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST")))
 287 (def-elements-tests *tiny-struct* 1
 288                     #(nil) #(:ellipses) nil 1)
 289 (def-elements-tests *tiny-struct* 1
 290                     #(nil) #(:ellipses) nil 2)
 291
 292 (def-elements-tests *double* 0 nil nil)
 293 (def-elements-tests *double* 0 nil nil nil 1)
 294
 295 (eval-when (:compile-toplevel :load-toplevel :execute)
 296   (defun display-test-name (name print skip)
 297     (intern (format nil "DISPLAY.~A" (basename name print skip)))))
 298
 299 (defmacro def-display-test (object string &optional print (skip 0))
 300   `(deftest ,(display-test-name object print skip)
 301     (display ,object ,print ,skip) ,string))
 302
 303 (def-display-test *cons-pair*
 304   "a cons cell
 305    0 car ------------> complex number #C(1 2)
 306    1 cdr ------------> the symbol A-SYMBOL")
 307
 308 (def-display-test *simple-struct*
 309  "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
 310    0 FIRST ----------> the symbol NIL
 311    1 SLOT-2 ---------> the symbol A-VALUE
 312    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
 313
 314 (def-display-test *simple-struct*
 315   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
 316    ...
 317    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\""
 318   nil 2)
 319
 320 (case sb-vm::n-word-bits
 321   (32
 322    (def-display-test *bignum*
 323        "bignum 4938271560493827156 with 2 32-bit words
 324    0-> #xF7A60454
 325    1-> #x448843D1"))
 326   (64
 327    (def-display-test *bignum*
 328        "bignum 4938271560493827156 with 1 64-bit word
 329    0-> #x448843D1F7A60454"
 330      )))
 331
 332 (def-display-test *vector*
 333   "a simple T vector (20)
 334    ...
 335    6-> fixnum 6
 336    7-> fixnum 7
 337    8-> fixnum 8
 338    9-> fixnum 9
 339   10-> fixnum 10
 340    ...
 341   19-> fixnum 19"
 342   5 6)
 343
 344 (def-display-test *circle-list1*
 345 "a cons cell
 346    0 car ------------> a cons cell
 347    1 cdr ------------> the symbol NIL")
 348 (def-display-test *circle-list2*
 349 "a cyclic list with 1 element+tail
 350    0-> the symbol B
 351 tail-> a cyclic list with 1 element+tail")
 352 (def-display-test *circle-list3*
 353 "a normal list with 3 elements
 354    0-> a normal list with 3 elements
 355    1-> the symbol B
 356    2-> the symbol C")
 357 (def-display-test *circle-list4*
 358 "a normal list with 3 elements
 359    0-> the symbol A
 360    1-> a normal list with 3 elements
 361    2-> the symbol C")
 362 (def-display-test *circle-list5*
 363   "a cyclic list with 2 elements+tail
 364    0-> the symbol A
 365    1-> the symbol B
 366 tail-> a cyclic list with 2 elements+tail")
 367
 368
 369 ;;; Inspector traversal tests
 370 (deftest inspect.0 (progn (setq * *simple-struct*)
 371                           (istep '("*")))
 372   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
 373    0 FIRST ----------> the symbol NIL
 374    1 SLOT-2 ---------> the symbol A-VALUE
 375    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
 376
 377 (deftest istep.0 (progn (setq * *simple-struct*)
 378                           (istep '("*"))
 379                           (istep '("=")))
 380   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
 381    0 FIRST ----------> the symbol NIL
 382    1 SLOT-2 ---------> the symbol A-VALUE
 383    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
 384
 385
 386 (deftest istep.1 (progn (setq * *simple-struct*)
 387                         (istep '("*"))
 388                         (istep '("first")))
 389 "the symbol NIL
 390    0 NAME -----------> a simple-string (3) \"NIL\"
 391    1 PACKAGE --------> the COMMON-LISP package
 392    2 VALUE ----------> the symbol NIL
 393    3 FUNCTION -------> ..unbound..
 394    4 PLIST ----------> the symbol NIL")
 395
 396
 397 (deftest istep.2  (progn (setq * *simple-struct*)
 398                          (istep '("*"))
 399                          (istep '("first"))
 400                          (istep '(">")))
 401 "the symbol A-VALUE
 402    0 NAME -----------> a simple-string (7) \"A-VALUE\"
 403    1 PACKAGE --------> the ACLREPL-TESTS package
 404    2 VALUE ----------> ..unbound..
 405    3 FUNCTION -------> ..unbound..
 406    4 PLIST ----------> the symbol NIL")
 407
 408 (deftest istep.3  (progn (setq * *simple-struct*)
 409                          (istep '("*"))
 410                          (istep '("first"))
 411                          (istep '(">"))
 412                          (istep '("<")))
 413 "the symbol NIL
 414    0 NAME -----------> a simple-string (3) \"NIL\"
 415    1 PACKAGE --------> the COMMON-LISP package
 416    2 VALUE ----------> the symbol NIL
 417    3 FUNCTION -------> ..unbound..
 418    4 PLIST ----------> the symbol NIL")
 419
 420 (deftest istep.4  (progn (setq * *simple-struct*)
 421                          (istep '("*"))
 422                          (istep '("first"))
 423                          (istep '(">"))
 424                          (istep '("<"))
 425                          (istep '("tree")))
 426 "The current object is:
 427 the symbol NIL, which was selected by FIRST
 428 #<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>, which was selected by (inspect *)
 429 ")
 430
 431 (deftest istep.5  (progn (setq * *simple-struct*)
 432                          (istep '("*"))
 433                          (istep '("first"))
 434                          (istep '(">"))
 435                          (istep '("<"))
 436                          (istep '("-")))
 437   "#<STRUCTURE-CLASS ACLREPL-TESTS::SIMPLE-STRUCT>
 438    0 FIRST ----------> the symbol NIL
 439    1 SLOT-2 ---------> the symbol A-VALUE
 440    2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"")
 441
 442 (deftest istep.6 (progn (setq * *dotted-list*)
 443                         (istep '("*"))
 444                         (istep '("tail")))
 445 "fixnum 3")
 446
 447 (deftest istep.7 (progn (setq * *dotted-list*)
 448                         (istep '("*"))
 449                         (istep '("2")))
 450 "fixnum 3")
 451
 452 (deftest istep.8 (progn (setq * 5.5d0)
 453                         (istep '("*")))
 454   "double-float 5.5d0")
 455
 456 (deftest istep.9 (progn (setq * 5.5d0)
 457                         (istep '("-")))
 458   "Object has no parent
 459 ")