tests/backtrace.impure.lisp

   1 ;;;; This file is for testing backtraces, using test machinery which
   2 ;;;; might have side effects (e.g. executing DEFUN).
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 (cl:in-package :cl-user)
  16
  17 ;;; The following objects should be EQUALP to the respective markers
  18 ;;; produced by the backtrace machinery.
  19
  20 (defvar *unused-argument*
  21   (sb-debug::make-unprintable-object "unused argument"))
  22
  23 (defvar *unavailable-argument*
  24   (sb-debug::make-unprintable-object "unavailable argument"))
  25
  26 (defvar *unavailable-more*
  27   (sb-debug::make-unprintable-object "more unavailable arguments"))
  28
  29 (defvar *unavailable-lambda-list*
  30   (sb-debug::make-unprintable-object "unavailable lambda list"))
  31
  32 ;;; TEST-FUNCTION is called and has to signal an error at which point
  33 ;;; the backtrace will be captured.
  34 ;;;
  35 ;;; If DETAILS is true, the returned backtrace description is of the
  36 ;;; form:
  37 ;;;
  38 ;;;   (((NAME1 . ARGS1) INFO1)
  39 ;;;    ((NAME2 . ARGS2) INFO2)
  40 ;;;    ...)
  41 ;;;
  42 ;;; Otherwise it is of the form
  43 ;;;
  44 ;;;   ((NAME1 . ARGS1)
  45 ;;;    (NAME2 . ARGS2)
  46 ;;;    ...)
  47 ;;;
  48 (defun call-with-backtrace (cont test-function &key details)
  49   (flet ((capture-it (condition)
  50            (let (backtrace)
  51              (sb-debug::map-backtrace
  52               (lambda (frame)
  53                 (multiple-value-bind (name args info)
  54                     (sb-debug::frame-call frame)
  55                   (push (if details
  56                             (list (cons name args) info)
  57                             (cons name args))
  58                         backtrace))))
  59              (funcall cont (nreverse backtrace) condition))))
  60     (handler-bind ((error #'capture-it))
  61       (funcall test-function))))
  62
  63 ;;; Check the backtrace FRAMES against the list of frame
  64 ;;; specifications EXPECTED signaling an error if they do not match.
  65 ;;;
  66 ;;; If DETAILS is true, EXPECTED is a list with elements of the form
  67 ;;;
  68 ;;;   ((FUNCTION ARGS) INFO)
  69 ;;;
  70 ;;; Otherwise elements are of the form
  71 ;;;
  72 ;;;   (FUNCTION ARGS)
  73 ;;;
  74 ;;; ARGS is a list of expected argument values, but can also contain
  75 ;;; the following symbols
  76 ;;;
  77 ;;;   &REST The corresponding frame in FRAMES can contain an arbitrary
  78 ;;;         number of arguments starting at the corresponding
  79 ;;;         position.
  80 ;;;
  81 ;;;   ?     The corresponding frame in FRAMES can have an arbitrary
  82 ;;;         argument at the corresponding position.
  83 (defun check-backtrace (frames expected &key details)
  84   (labels ((args-equal (want actual)
  85              (cond ((eq want *unavailable-lambda-list*)
  86                     (equalp want actual))
  87                    ((eq '&rest (car want))
  88                     t)
  89                    ((endp want)
  90                     (endp actual))
  91                    ((or (eq '? (car want)) (equal (car want) (car actual)))
  92                     (args-equal (cdr want) (cdr actual)))
  93                    ((typep (car want) 'sb-impl::unprintable-object)
  94                     (equalp (car want) (car actual)))
  95                    (t
  96                     nil)))
  97            (fail (datum &rest arguments)
  98              (return-from check-backtrace
  99                (values nil (apply #'sb-kernel:coerce-to-condition
 100                                   datum 'simple-error 'error arguments)))))
 101     (mapc (lambda (frame spec)
 102             (unless (cond
 103                       ((not spec)
 104                        t)
 105                       (details
 106                        (and (args-equal (car spec)
 107                                         (car frame))
 108                             (equal (cdr spec) (cdr frame))))
 109                       (t
 110                        (and (equal (car spec) (car frame))
 111                             (args-equal (cdr spec) (cdr frame)))))
 112               (fail "~@<Unexpected frame during ~
 113                     ~:[non-detailed~:;detailed~] check: wanted ~S, got ~
 114                     ~S~@:>"
 115                     details spec frame)))
 116           frames expected))
 117   t)
 118
 119 ;;; Check for backtraces generally being correct.  Ensure that the
 120 ;;; actual backtrace finishes (doesn't signal any errors on its own),
 121 ;;; and that it contains the frames we expect, doesn't contain any
 122 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
 123 ;;; and hasn't been cut off anywhere.
 124 ;;;
 125 ;;; See CHECK-BACKTRACE for an explanation of the structure
 126 ;;; EXPECTED-FRAMES.
 127 (defun verify-backtrace (test-function expected-frames &key details)
 128   (labels ((find-frame (function-name frames)
 129              (member function-name frames
 130                      :key (if details #'caar #'car)
 131                      :test #'equal))
 132            (fail (datum &rest arguments)
 133              (return-from verify-backtrace
 134                (values nil (apply #'sb-kernel:coerce-to-condition
 135                                   datum 'simple-error 'error arguments)))))
 136     (call-with-backtrace
 137      (lambda (backtrace condition)
 138        (declare (ignore condition))
 139        (let* ((test-function-name (if details
 140                                       (caaar expected-frames)
 141                                       (caar expected-frames)))
 142               (frames (or (find-frame test-function-name backtrace)
 143                           (fail "~@<~S (expected name ~S) not found in ~
 144                                 backtrace:~@:_~S~@:>"
 145                                 test-function test-function-name backtrace))))
 146          ;; Check that we have all the frames we wanted.
 147          (multiple-value-bind (successp condition)
 148              (check-backtrace frames expected-frames :details details)
 149            (unless successp (fail condition)))
 150          ;; Make sure the backtrace isn't stunted in any way.
 151          ;; (Depends on running in the main thread.) FIXME: On Windows
 152          ;; we get two extra foreign frames below regular frames.
 153          (unless (find-frame 'sb-impl::toplevel-init frames)
 154            (fail "~@<Backtrace stunted:~@:_~S~@:>" backtrace)))
 155        (return-from verify-backtrace t))
 156      test-function :details details)))
 157
 158 (defun assert-backtrace (test-function expected-frames &key details)
 159   (multiple-value-bind (successp condition)
 160       (verify-backtrace test-function expected-frames :details details)
 161     (or successp (error condition))))
 162
 163 (defvar *p* (namestring *load-truename*))
 164
 165 (defvar *undefined-function-frame*
 166   '("undefined function"))
 167
 168 (defun oops ()
 169   (error "oops"))
 170
 171 ;;; Test for "undefined function" (undefined_tramp) working properly.
 172 ;;; Try it with and without tail call elimination, since they can have
 173 ;;; different effects.  (Specifically, if undefined_tramp is incorrect
 174 ;;; a stunted stack can result from the tail call variant.)
 175 (flet ((optimized ()
 176          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 177          (declare (muffle-conditions style-warning))
 178          (#:undefined-function 42))
 179        (not-optimized ()
 180          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 181          (declare (muffle-conditions style-warning))
 182          (#:undefined-function 42))
 183        (test (fun)
 184          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 185          (funcall fun)))
 186
 187   (with-test (:name (:backtrace :undefined-function :bug-346)
 188               :skipped-on :interpreter
 189               ;; Failures on SPARC, and probably HPPA are due to
 190               ;; not having a full and valid stack frame for the
 191               ;; undefined function frame.  See PPC
 192               ;; undefined_tramp for details.
 193               :fails-on :sparc)
 194     (assert-backtrace
 195      (lambda () (test #'optimized))
 196      (list (append *undefined-function-frame* '(42))
 197            (list `(flet test :in ,*p*) #'optimized))))
 198
 199   ;; bug 353: This test fails at least most of the time for x86/linux
 200   ;; ca. 0.8.20.16. -- WHN
 201   (with-test (:name (:backtrace :undefined-function :bug-353)
 202               :skipped-on :interpreter)
 203     (assert-backtrace
 204      (lambda () (test #'not-optimized))
 205      (list (append *undefined-function-frame* '(42))
 206            (list `(flet not-optimized :in ,*p*))
 207            (list `(flet test :in ,*p*) #'not-optimized)))))
 208
 209 (with-test (:name (:backtrace :interrupted-condition-wait)
 210                   :skipped-on (not :sb-thread))
 211   (let ((m (sb-thread:make-mutex))
 212         (q (sb-thread:make-waitqueue)))
 213     (assert-backtrace
 214      (lambda ()
 215        (sb-thread:with-mutex (m)
 216          (handler-bind ((timeout (lambda (condition)
 217                                    (declare (ignore condition))
 218                                    (error "foo"))))
 219            (with-timeout 0.1
 220              (sb-thread:condition-wait q m)))))
 221      `((sb-thread:condition-wait ,q ,m :timeout nil)))))
 222
 223 ;;; Division by zero was a common error on PPC. It depended on the
 224 ;;; return function either being before INTEGER-/-INTEGER in memory,
 225 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
 226 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
 227 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
 228 ;;; if SBCL does the same this test is probably not good for the
 229 ;;; Sparc.
 230 ;;;
 231 ;;; Disabling tail call elimination on this will probably ensure that
 232 ;;; the return value (to the flet or the enclosing top level form) is
 233 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
 234 ;;; Enabling it might catch other problems, so do it anyway.
 235 (flet ((optimized ()
 236          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 237          (declare (muffle-conditions style-warning))
 238          (/ 42 0))
 239        (not-optimized ()
 240          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 241          (declare (muffle-conditions style-warning))
 242          (/ 42 0))
 243        (test (fun)
 244          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 245          (funcall fun)))
 246
 247   (with-test (:name (:backtrace :divide-by-zero :bug-346)
 248                     :skipped-on :interpreter)
 249     (assert-backtrace (lambda () (test #'optimized))
 250                       `((sb-kernel::integer-/-integer 42 &rest)
 251                         ((flet test :in ,*p*) ,#'optimized))))
 252
 253   (with-test (:name (:backtrace :divide-by-zero :bug-356)
 254                     :skipped-on :interpreter)
 255     (assert-backtrace (lambda () (test #'not-optimized))
 256                       `((sb-kernel::integer-/-integer 42 &rest)
 257                         ((flet not-optimized :in ,*p*))
 258                         ((flet test :in ,*p*) ,#'not-optimized)))))
 259
 260 (defun throw-test ()
 261   (throw 'no-such-tag t))
 262 (with-test (:name (:backtrace :throw :no-such-tag)
 263                   :fails-on (and :sparc :linux))
 264   (assert-backtrace #'throw-test '((throw-test))))
 265
 266 (funcall (checked-compile
 267           '(lambda ()
 268             (defun bug-308926 (x)
 269               (let ((v "foo"))
 270                 (flet ((bar (z)
 271                          (oops v z)
 272                          (oops z v)))
 273                   (bar x)
 274                   (bar v)))))
 275           :allow-style-warnings t))
 276 (with-test (:name (:backtrace :bug-308926) :skipped-on :interpreter)
 277   (assert-backtrace (lambda () (bug-308926 13))
 278                     '(((flet bar :in bug-308926) 13)
 279                       (bug-308926 &rest t))))
 280
 281 ;;; Test backtrace through assembly routines
 282 ;;; :bug-800343
 283 (macrolet ((test (predicate fun
 284                             &optional (two-arg
 285                                        (find-symbol (format nil "TWO-ARG-~A" fun)
 286                                                     "SB-KERNEL")))
 287              (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
 288                `(flet ((,test-name (x y)
 289                          ;; make sure it's not in tail position
 290                          (list (,fun x y))))
 291                   (with-test (:name (:backtrace :bug-800343 ,fun)
 292                               :skipped-on :interpreter)
 293                     (assert-backtrace
 294                      (lambda ()
 295                        (eval `(funcall ,#',test-name 42 t)))
 296                      '((,two-arg 42 t)
 297                        #+(or x86 x86-64)
 298                        ,@(and predicate
 299                               `((,(find-symbol (format nil "GENERIC-~A" fun) "SB-VM"))))
 300                        ((flet ,(string test-name) :in ,*p*) 42 t)))))))
 301            (test-predicates (&rest functions)
 302              `(progn ,@(mapcar (lambda (function)
 303                                  `(test t ,@(sb-int:ensure-list function)))
 304                                functions)))
 305            (test-functions (&rest functions)
 306              `(progn ,@(mapcar (lambda (function)
 307                                  `(test nil ,@(sb-int:ensure-list function)))
 308                                functions))))
 309   (test-predicates = < >)
 310   (test-functions + - * /
 311                   gcd lcm
 312                   (logand sb-kernel:two-arg-and)
 313                   (logior sb-kernel:two-arg-ior)
 314                   (logxor sb-kernel:two-arg-xor)))
 315
 316 ;;; test entry point handling in backtraces
 317
 318 (with-test (:name (:backtrace :xep-too-many-arguments)
 319             :skipped-on :interpreter)
 320   ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
 321   (assert-backtrace (checked-compile '(lambda () (oops 1 2 3 4 5 6))
 322                                      :allow-style-warnings t)
 323                     '((oops ? ? ? ? ? ?))))
 324
 325 (defmacro defbt (n ll &body body)
 326   ;; WTF is this? This is a way to make these tests not depend so much on the
 327   ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
 328   ;; slightly smarter, which meant that things which used to have xeps
 329   ;; suddently had tl-xeps, etc. This takes care of that.
 330   `(funcall
 331     (checked-compile
 332      '(lambda ()
 333         (progn
 334           ;; normal debug info
 335           (defun ,(intern (format nil "BT.~A.1" n)) ,ll
 336             ,@body)
 337           ;; no arguments saved
 338           (defun ,(intern (format nil "BT.~A.2" n)) ,ll
 339             (declare (optimize (debug 1) (speed 3)))
 340             ,@body)
 341           ;; no lambda-list saved
 342           (defun ,(intern (format nil "BT.~A.3" n)) ,ll
 343             (declare (optimize (debug 0)))
 344             ,@body)))
 345      :allow-style-warnings t)))
 346
 347 (defbt 1 (&key key)
 348   (list key))
 349
 350 (defbt 2 (x)
 351   (list x))
 352
 353 (defbt 3 (&key (key (oops)))
 354   (list key))
 355
 356 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
 357 (defbt 4 (&optional opt)
 358   (list (error "error")))
 359
 360 (defbt 5 (&optional (opt (oops)))
 361   (list opt))
 362
 363 (defbt 6 (&optional (opt nil opt-p))
 364   (declare (ignore opt))
 365   (list (error "error ~A" opt-p))) ; use OPT-P
 366
 367 (defbt 7 (&key (key nil key-p))
 368   (declare (ignore key))
 369   (list (error "error ~A" key-p))) ; use KEY-P
 370
 371 (defun bug-354 (x)
 372   (error "XEPs in backtraces: ~S" x))
 373
 374 (with-test (:name (:backtrace :bug-354))
 375   (assert (not (verify-backtrace (lambda () (bug-354 354))
 376                                  '((bug-354 354)
 377                                    (((bug-354 &rest) (:tl :external)) 354)))))
 378   (assert-backtrace (lambda () (bug-354 354)) '((bug-354 354))))
 379
 380 ;;; FIXME: This test really should be broken into smaller pieces
 381 (with-test (:name (:backtrace :tl-xep))
 382   (assert-backtrace #'namestring '(((namestring) (:external))) :details t)
 383   (assert-backtrace #'namestring '((namestring))))
 384
 385 (with-test (:name (:backtrace :more-processor))
 386   ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
 387   (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key))
 388                                      :allow-style-warnings t)
 389                     '(((bt.1.1 :key) (:more)))
 390                     :details t)
 391   (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key))
 392                                      :allow-style-warnings t)
 393                     '(((bt.1.2 ?) (:more)))
 394                     :details t)
 395   (assert-backtrace (lambda () (bt.1.3 :key))
 396                     `(((bt.1.3  ,*unavailable-more*) (:more)))
 397                     :details t)
 398   (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key))
 399                                      :allow-style-warnings t)
 400                     '((bt.1.1 :key)))
 401   (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key))
 402                                      :allow-style-warnings t)
 403                     '((bt.1.2 &rest)))
 404   (assert-backtrace (lambda () (bt.1.3 :key))
 405                     '((bt.1.3 &rest))))
 406
 407 (with-test (:name (:backtrace :xep))
 408   (assert-backtrace #'bt.2.1 '(((bt.2.1) (:external))) :details t)
 409   (assert-backtrace #'bt.2.2 '(((bt.2.2) (:external))) :details t)
 410   (assert-backtrace #'bt.2.3 `(((bt.2.3) (:external))) :details t)
 411   (assert-backtrace #'bt.2.1 '((bt.2.1)))
 412   (assert-backtrace #'bt.2.2 '((bt.2.2)))
 413   (assert-backtrace #'bt.2.3 `((bt.2.3))))
 414
 415 ;;; This test is somewhat deceptively named. Due to confusion in debug
 416 ;;; naming these functions used to have sb-c::varargs-entry debug
 417 ;;; names for their main lambda.
 418 (with-test (:name (:backtrace :varargs-entry))
 419   (assert-backtrace #'bt.3.1 '((bt.3.1 :key nil)))
 420   (assert-backtrace #'bt.3.2 '((bt.3.2 :key ?)))
 421   (assert-backtrace #'bt.3.3 `((bt.3.3 :key ,*unavailable-argument*)))
 422   (assert-backtrace #'bt.3.1 '((bt.3.1 :key nil)))
 423   (assert-backtrace #'bt.3.2 '((bt.3.2 :key ?)))
 424   (assert-backtrace #'bt.3.3 `((bt.3.3 :key ,*unavailable-argument*))))
 425
 426 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 427 ;;; these functions used to have sb-c::hairy-args-processor debug names for
 428 ;;; their main lambda.
 429 (with-test (:name (:backtrace :hairy-args-processor))
 430   (assert-backtrace #'bt.4.1 '((bt.4.1 ?)))
 431   (assert-backtrace #'bt.4.2 '((bt.4.2 ?)))
 432   (assert-backtrace #'bt.4.3 `((bt.4.3 ,*unused-argument*)))
 433   (assert-backtrace #'bt.4.1 '((bt.4.1 ?)))
 434   (assert-backtrace #'bt.4.2 '((bt.4.2 ?)))
 435   (assert-backtrace #'bt.4.3 `((bt.4.3 ,*unused-argument*))))
 436
 437 (with-test (:name (:backtrace :optional-processor))
 438   (assert-backtrace #'bt.5.1 '(((bt.5.1) (:optional))) :details t)
 439   (assert-backtrace #'bt.5.2 '(((bt.5.2) (:optional))) :details t)
 440   (assert-backtrace #'bt.5.3 `(((bt.5.3) (:optional)))
 441                     :details t)
 442   (assert-backtrace #'bt.5.1 '((bt.5.1)))
 443   (assert-backtrace #'bt.5.2 '((bt.5.2)))
 444   (assert-backtrace #'bt.5.3 `((bt.5.3))))
 445
 446 (with-test (:name (:backtrace :unused-optional-with-supplied-p :bug-1498644))
 447   (assert-backtrace (lambda () (bt.6.1 :opt))
 448                     `(((bt.6.1 ,*unused-argument*) ()))
 449                     :details t)
 450   (assert-backtrace (lambda () (bt.6.2 :opt))
 451                     `(((bt.6.2 ,*unused-argument*) ()))
 452                     :details t)
 453   (assert-backtrace (lambda () (bt.6.3 :opt))
 454                     `(((bt.6.3 ,*unused-argument*) ()))
 455                     :details t)
 456   (assert-backtrace (lambda () (bt.6.1 :opt))
 457                     `((bt.6.1 ,*unused-argument*)))
 458   (assert-backtrace (lambda () (bt.6.2 :opt))
 459                     `((bt.6.2 ,*unused-argument*)))
 460   (assert-backtrace (lambda () (bt.6.3 :opt))
 461                     `((bt.6.3 ,*unused-argument*))))
 462
 463 (with-test (:name (:backtrace :unused-key-with-supplied-p))
 464   (assert-backtrace (lambda () (bt.7.1 :key :value))
 465                     `(((bt.7.1 :key ,*unused-argument*) ()))
 466                     :details t)
 467   (assert-backtrace (lambda () (bt.7.2 :key :value))
 468                     `(((bt.7.2 :key ,*unused-argument*) ()))
 469                     :details t)
 470   (assert-backtrace (lambda () (bt.7.3 :key :value))
 471                     `(((bt.7.3 :key ,*unused-argument*) ()))
 472                     :details t)
 473   (assert-backtrace (lambda () (bt.7.1 :key :value))
 474                     `((bt.7.1 :key ,*unused-argument*)))
 475   (assert-backtrace (lambda () (bt.7.2 :key :value))
 476                     `((bt.7.2 :key ,*unused-argument*)))
 477   (assert-backtrace (lambda () (bt.7.3 :key :value))
 478                     `((bt.7.3 :key ,*unused-argument*))))
 479
 480 (defvar *compile-nil-error*
 481   (checked-compile '(lambda (x)
 482                       (cons (when x (error "oops")) nil))))
 483 (defvar *compile-nil-non-tc*
 484   (checked-compile '(lambda (y)
 485                       (cons (funcall *compile-nil-error* y) nil))))
 486 (with-test (:name (:backtrace compile nil))
 487   (assert-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
 488                     `(((lambda (x) :in ,*p*) 13)
 489                       ((lambda (y) :in ,*p*) 13))))
 490
 491 (with-test (:name (:backtrace :clos-slot-typecheckfun-named))
 492   (assert-backtrace
 493    (checked-compile
 494     `(lambda ()
 495        (locally (declare (optimize safety))
 496          (defclass clos-typecheck-test ()
 497            ((slot :type fixnum)))
 498          (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
 499    '(((sb-pcl::slot-typecheck fixnum) t))))
 500
 501 (with-test (:name (:backtrace :clos-emf-named))
 502   (assert-backtrace
 503    (checked-compile
 504     `(lambda ()
 505        (progn
 506          (defgeneric clos-emf-named-test (x)
 507            (:method ((x symbol)) x)
 508            (:method :before (x) (assert x)))
 509          (clos-emf-named-test nil)))
 510     :allow-style-warnings t)
 511    '(((sb-pcl::emf clos-emf-named-test) ? ? nil))))
 512
 513 (with-test (:name (:backtrace :bug-310173))
 514   (flet ((make-fun (n)
 515            (let* ((names '(a b))
 516                   (req (loop repeat n collect (pop names))))
 517              (checked-compile
 518               `(lambda (,@req &rest rest)
 519                  (let ((* *)) ; no tail-call
 520                    (apply '/ ,@req rest)))))))
 521     (assert-backtrace (lambda ()
 522                         (funcall (make-fun 0) 10 11 0))
 523                       `((sb-kernel:two-arg-/ 10/11 0)
 524                         (/ 10 11 0)
 525                         ((lambda (&rest rest) :in ,*p*) 10 11 0)))
 526     (assert-backtrace (lambda ()
 527                         (funcall (make-fun 1) 10 11 0))
 528                       `((sb-kernel:two-arg-/ 10/11 0)
 529                         (/ 10 11 0)
 530                         ((lambda (a &rest rest) :in ,*p*) 10 11 0)))
 531     (assert-backtrace (lambda ()
 532                         (funcall (make-fun 2) 10 11 0))
 533                       `((sb-kernel:two-arg-/ 10/11 0)
 534                         (/ 10 11 0)
 535                         ((lambda (a b &rest rest) :in ,*p*) 10 11 0)))))
 536
 537 (defgeneric gf-dispatch-test/gf (x y)
 538   (:method (x y)
 539     (+ x y)))
 540 (defun gf-dispatch-test/f (z)
 541   (declare (muffle-conditions style-warning))
 542   (gf-dispatch-test/gf z))
 543 (with-test (:name (:backtrace :gf-dispatch))
 544   ;; Fill the cache
 545   (gf-dispatch-test/gf 1 1)
 546   ;; Wrong argument count
 547   (assert-backtrace (lambda () (gf-dispatch-test/f 42))
 548                     '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42))))
 549
 550 (with-test (:name (:backtrace :local-tail-call))
 551   (assert-backtrace
 552    (lambda () (funcall (compile nil `(sb-int:named-lambda test ()
 553                                        (signal 'error)
 554                                        (flet ((tail ()))
 555                                          (declare (notinline tail))
 556                                          (tail))))))
 557    '((test))))
 558
 559 (defun fact (n) (if (zerop n) (error "nope") (* n (fact (1- n)))))
 560
 561 #+sb-fasteval
 562 (with-test (:name (:backtrace :interpreted-factorial)
 563             :skipped-on (not :interpreter))
 564   (assert-backtrace
 565    (lambda () (fact 5))
 566    '((fact 0)
 567      (sb-interpreter::2-arg-* &rest)
 568      (fact 1)
 569      (sb-interpreter::2-arg-* &rest)
 570      (fact 2)
 571      (sb-interpreter::2-arg-* &rest)
 572      (fact 3)
 573      (sb-interpreter::2-arg-* &rest)
 574      (fact 4)
 575      (sb-interpreter::2-arg-* &rest)
 576      (fact 5))))
 577
 578 (with-test (:name :deleted-args)
 579   (let ((fun (checked-compile `(lambda (&rest ignore)
 580                                  (declare (ignore ignore))
 581                                  (error "x")))))
 582     (assert (typep (block nil
 583                      (handler-bind ((error
 584                                       (lambda (c)
 585                                         (return (values c
 586                                                         (sb-debug:list-backtrace))))))
 587                        (funcall fun)))
 588                    'simple-error))))
 589
 590 (defun mega-string-replace-fail (x)
 591   (let ((string (make-string 10000 :initial-element #\z))
 592         (stream (make-string-output-stream)))
 593     (block nil
 594       (handler-bind
 595           ((condition (lambda (c)
 596                         (declare (ignore c))
 597                         (sb-debug:print-backtrace :stream stream)
 598                         (return-from nil))))
 599         (replace string x)))
 600     (get-output-stream-string stream)))
 601
 602 (with-test (:name :long-string-abbreviation)
 603   (let ((backtrace (mega-string-replace-fail '(#\- 1))))
 604     (assert (search (concatenate 'string
 605                                  "-"
 606                                  (make-string 199 :initial-element #\z)
 607                                  "...")
 608                     backtrace))))
 609
 610 (defclass cannot-print-this () ())
 611 (defmethod print-object ((object cannot-print-this) stream)
 612   (error "No go!"))
 613
 614 (with-test (:name (sb-debug:print-backtrace :no-error print-object))
 615   ;; Errors during printing objects used to be suppressed in a way
 616   ;; that required outer condition handlers to behave in a specific
 617   ;; way.
 618   (handler-bind ((error (lambda (condition)
 619                           (error "~@<~S signaled ~A.~@:>"
 620                                  'sb-debug:print-backtrace condition))))
 621     (with-output-to-string (stream)
 622       (labels ((foo (n x)
 623                  (when (plusp n)
 624                    (foo (1- n) x))
 625                  (when (zerop n)
 626                    (sb-debug:print-backtrace :count 100 :stream stream
 627                                              :emergency-best-effort t))))
 628         (foo 100 (make-instance 'cannot-print-this))))))
 629
 630 (with-test (:name (sb-debug:print-backtrace :no-error :circles))
 631   ;; Errors during printing objects used to be suppressed in a way
 632   ;; that required outer condition handlers to behave in a specific
 633   ;; way.
 634   (handler-bind ((error (lambda (condition)
 635                           (error "~@<~S signaled ~A.~@:>"
 636                                  'sb-debug:print-backtrace condition))))
 637     (with-output-to-string (stream)
 638       (labels ((foo (n x)
 639                  (when (plusp n)
 640                    (foo (1- n) x))
 641                  (when (zerop n)
 642                    (sb-debug:print-backtrace :count 100 :stream stream))))
 643         (foo 100 (let ((list (list t)))
 644                    (nconc list list)))))))