contrib/sb-aclrepl/aclrepl-tests.lisp

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