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-debug::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                                                             error)
 129   (labels ((find-frame (function-name frames)
 130              (member function-name frames
 131                      :key (if details #'caar #'car)
 132                      :test #'equal))
 133            (fail (datum &rest arguments)
 134              (return-from verify-backtrace
 135                (let ((c (apply #'sb-kernel:coerce-to-condition datum 'simple-error 'error arguments)))
 136                  (if error
 137                      (error c)
 138                      (values nil c))))))
 139     (call-with-backtrace
 140      (lambda (backtrace condition)
 141        (declare (ignore condition))
 142        (let* ((test-function-name (if details
 143                                       (caaar expected-frames)
 144                                       (caar expected-frames)))
 145               (frames (or (find-frame test-function-name backtrace)
 146                           (fail "~@<~S (expected name ~S) not found in ~
 147                                 backtrace:~@:_~a~@:>"
 148                                 test-function test-function-name
 149                                 (princ-to-string backtrace)))))
 150          ;; Check that we have all the frames we wanted.
 151          (multiple-value-bind (successp condition)
 152              (check-backtrace frames expected-frames :details details)
 153            (unless successp (fail condition)))
 154          ;; Make sure the backtrace isn't stunted in any way.
 155          ;; (Depends on running in the main thread.) FIXME: On Windows
 156          ;; we get two extra foreign frames below regular frames.
 157          (unless (find-frame 'sb-impl::toplevel-init frames)
 158            (fail "~@<Backtrace stunted:~@:_~a~@:>" (princ-to-string backtrace))))
 159        (return-from verify-backtrace t))
 160      test-function :details details)))
 161
 162 (defun assert-backtrace (test-function expected-frames &key details)
 163   (verify-backtrace test-function expected-frames :details details
 164                                                   :error t))
 165
 166 (defvar *p* (namestring (if sb-c::*merge-pathnames* *load-truename* *load-pathname*)))
 167
 168 (defvar *undefined-function-frame*
 169   '("undefined function"))
 170
 171 (defun oops ()
 172   (error "oops"))
 173
 174 ;;; Test for "undefined function" (undefined_tramp) working properly.
 175 ;;; Try it with and without tail call elimination, since they can have
 176 ;;; different effects.  (Specifically, if undefined_tramp is incorrect
 177 ;;; a stunted stack can result from the tail call variant.)
 178 (flet ((optimized ()
 179          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 180          (declare (muffle-conditions style-warning))
 181          (#:undefined-function 42))
 182        (not-optimized ()
 183          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 184          (declare (muffle-conditions style-warning))
 185          (#:undefined-function 42))
 186        (test (fun)
 187          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 188          (funcall fun)))
 189
 190   (with-test (:name (:backtrace :undefined-function :bug-346)
 191               :skipped-on :interpreter
 192               ;; Failures on SPARC are due to
 193               ;; not having a full and valid stack frame for the
 194               ;; undefined function frame.  See PPC
 195               ;; undefined_tramp for details.
 196               :fails-on :sparc)
 197     (assert-backtrace
 198      (lambda () (test #'optimized))
 199      (list (append *undefined-function-frame* '(42))
 200            (list `(flet test :in ,*p*) #'optimized))))
 201
 202   ;; bug 353: This test fails at least most of the time for x86/linux
 203   ;; ca. 0.8.20.16. -- WHN
 204   (with-test (:name (:backtrace :undefined-function :bug-353)
 205               :skipped-on :interpreter)
 206     (assert-backtrace
 207      (lambda () (test #'not-optimized))
 208      (list (append *undefined-function-frame* '(42))
 209            (list `(flet not-optimized :in ,*p*))
 210            (list `(flet test :in ,*p*) #'not-optimized)))))
 211
 212 (with-test (:name (:backtrace :interrupted-condition-wait)
 213             :skipped-on (not :sb-thread)
 214             :broken-on :sb-safepoint) ;; unreliable
 215   (let ((m (sb-thread:make-mutex))
 216         (q (sb-thread:make-waitqueue)))
 217     (assert-backtrace
 218      (lambda ()
 219        (sb-thread:with-mutex (m)
 220          (handler-bind ((timeout (lambda (condition)
 221                                    (declare (ignore condition))
 222                                    (error "foo"))))
 223            (with-timeout 0.1
 224              (sb-thread:condition-wait q m)))))
 225      `((sb-thread::%condition-wait ,q ,m t nil nil nil nil nil nil)))))
 226
 227 ;;; Division by zero was a common error on PPC. It depended on the
 228 ;;; return function either being before INTEGER-/-INTEGER in memory,
 229 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
 230 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
 231 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
 232 ;;; if SBCL does the same this test is probably not good for the
 233 ;;; Sparc.
 234 ;;;
 235 ;;; Disabling tail call elimination on this will probably ensure that
 236 ;;; the return value (to the flet or the enclosing top level form) is
 237 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
 238 ;;; Enabling it might catch other problems, so do it anyway.
 239 (flet ((optimized ()
 240          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 241          (declare (muffle-conditions style-warning))
 242          (/ 42 0))
 243        (not-optimized ()
 244          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 245          (declare (muffle-conditions style-warning))
 246          (/ 42 0))
 247        (test (fun)
 248          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 249          (funcall fun)))
 250
 251   (with-test (:name (:backtrace :divide-by-zero :bug-346)
 252                     :skipped-on :interpreter)
 253     (assert-backtrace (lambda () (test #'optimized))
 254                       `((sb-kernel::integer-/-integer 42 &rest)
 255                         ((flet test :in ,*p*) ,#'optimized))))
 256
 257   (with-test (:name (:backtrace :divide-by-zero :bug-356)
 258                     :skipped-on :interpreter)
 259     (assert-backtrace (lambda () (test #'not-optimized))
 260                       `((sb-kernel::integer-/-integer 42 &rest)
 261                         ((flet not-optimized :in ,*p*))
 262                         ((flet test :in ,*p*) ,#'not-optimized)))))
 263
 264 (defun throw-test ()
 265   (throw 'no-such-tag t))
 266 (with-test (:name (:backtrace :throw :no-such-tag)
 267                   :fails-on (or :mips (and :sparc :linux)))
 268   (assert-backtrace #'throw-test '((throw-test))))
 269
 270 (funcall (checked-compile
 271           '(lambda ()
 272             (defun bug-308926 (x)
 273               (let ((v "foo"))
 274                 (flet ((bar (z)
 275                          (oops v z)
 276                          (oops z v)))
 277                   (bar x)
 278                   (bar v)))))
 279           :allow-style-warnings t))
 280 (with-test (:name (:backtrace :bug-308926) :skipped-on :interpreter)
 281   (assert-backtrace (lambda () (bug-308926 13))
 282                     '(((flet bar :in bug-308926) 13)
 283                       (bug-308926 &rest t))))
 284
 285 ;;; Test backtrace through assembly routines
 286 ;;; :bug-800343
 287 (macrolet ((test (predicate fun
 288                             &optional (two-arg
 289                                        (find-symbol (format nil "TWO-ARG-~A" fun)
 290                                                     "SB-KERNEL")))
 291              (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
 292                `(flet ((,test-name (x y)
 293                          ;; make sure it's not in tail position
 294                          (list (,fun x y))))
 295                   (with-test (:name (:backtrace :bug-800343 ,fun)
 296                               :skipped-on :interpreter)
 297                     (assert-backtrace
 298                      (lambda ()
 299                        (eval `(funcall ,#',test-name 42 t)))
 300                      '((,two-arg 42 t)
 301                        #+(or x86 x86-64)
 302                        ,@(and predicate
 303                               `((,(find-symbol (format nil "GENERIC-~A" fun) "SB-VM"))))
 304                        ((flet ,(string test-name) :in ,*p*) 42 t)))))))
 305            (test-predicates (&rest functions)
 306              `(progn ,@(mapcar (lambda (function)
 307                                  `(test t ,@(sb-int:ensure-list function)))
 308                                functions)))
 309            (test-functions (&rest functions)
 310              `(progn ,@(mapcar (lambda (function)
 311                                  `(test nil ,@(sb-int:ensure-list function)))
 312                                functions))))
 313   (test-predicates = < >)
 314   (test-functions + - * /
 315                   gcd lcm
 316                   (logand sb-kernel:two-arg-and)
 317                   (logior sb-kernel:two-arg-ior)
 318                   (logxor sb-kernel:two-arg-xor)))
 319
 320 ;;; test entry point handling in backtraces
 321
 322 (with-test (:name (:backtrace :xep-too-many-arguments)
 323             :skipped-on :interpreter)
 324   ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
 325   (assert-backtrace (checked-compile '(lambda () (oops 1 2 3 4 5 6))
 326                                      :allow-style-warnings t)
 327                     '((oops ? ? ? ? ? ?))))
 328
 329 (defmacro defbt (n ll &body body)
 330   ;; WTF is this? This is a way to make these tests not depend so much on the
 331   ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
 332   ;; slightly smarter, which meant that things which used to have xeps
 333   ;; suddenly had tl-xeps, etc. This takes care of that.
 334   `(funcall
 335     (checked-compile
 336      '(lambda ()
 337         (progn
 338           ;; normal debug info
 339           (defun ,(intern (format nil "BT.~A.1" n)) ,ll
 340             ,@body)
 341           ;; no arguments saved
 342           (defun ,(intern (format nil "BT.~A.2" n)) ,ll
 343             (declare (optimize (debug 1) (speed 3)))
 344             ,@body)
 345           ;; no lambda-list saved
 346           (defun ,(intern (format nil "BT.~A.3" n)) ,ll
 347             (declare (optimize (debug 0)))
 348             (let (*) ;; disable tail calls enabled by debug-0
 349               ,@body))))
 350      :allow-style-warnings t)))
 351
 352 (defbt 1 (&key key)
 353   (list key))
 354
 355 (defbt 2 (x)
 356   (list x))
 357
 358 (defbt 3 (&key (key (oops)))
 359   (list key))
 360
 361 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
 362 (defbt 4 (&optional opt)
 363   (list (error "error")))
 364
 365 (defbt 5 (&optional (opt (oops)))
 366   (list opt))
 367
 368 (defbt 6 (&optional (opt nil opt-p))
 369   (declare (ignore opt))
 370   (list (error "error ~A" opt-p))) ; use OPT-P
 371
 372 (defbt 7 (&key (key nil key-p))
 373   (declare (ignore key))
 374   (list (error "error ~A" key-p))) ; use KEY-P
 375
 376 (defun bug-354 (x)
 377   (error "XEPs in backtraces: ~S" x))
 378
 379 (with-test (:name (:backtrace :bug-354))
 380   (assert (not (verify-backtrace (lambda () (bug-354 354))
 381                                  '((bug-354 354)
 382                                    (((bug-354 &rest) (:tl :external)) 354)))))
 383   (assert-backtrace (lambda () (bug-354 354)) '((bug-354 354))))
 384
 385 ;;; FIXME: This test really should be broken into smaller pieces
 386 (with-test (:name (:backtrace :tl-xep))
 387   (assert-backtrace #'namestring '(((namestring) (:external))) :details t)
 388   (assert-backtrace #'namestring '((namestring))))
 389
 390 (with-test (:name (:backtrace :more-processor))
 391   ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
 392   (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key))
 393                                      :allow-style-warnings t)
 394                     '(((bt.1.1 :key) (:more)))
 395                     :details t)
 396   (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key))
 397                                      :allow-style-warnings t)
 398                     '(((bt.1.2 ?) (:more)))
 399                     :details t)
 400   (assert-backtrace (lambda () (bt.1.3 :key))
 401                     `(((bt.1.3  ,*unavailable-more*) (:more)))
 402                     :details t)
 403   (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key))
 404                                      :allow-style-warnings t)
 405                     '((bt.1.1 :key)))
 406   (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key))
 407                                      :allow-style-warnings t)
 408                     '((bt.1.2 &rest)))
 409   (assert-backtrace (lambda () (bt.1.3 :key))
 410                     '((bt.1.3 &rest))))
 411
 412 (with-test (:name (:backtrace :xep))
 413   (assert-backtrace #'bt.2.1 '(((bt.2.1) (:external))) :details t)
 414   (assert-backtrace #'bt.2.2 '(((bt.2.2) (:external))) :details t)
 415   (assert-backtrace #'bt.2.3 `(((bt.2.3) (:external))) :details t)
 416   (assert-backtrace #'bt.2.1 '((bt.2.1)))
 417   (assert-backtrace #'bt.2.2 '((bt.2.2)))
 418   (assert-backtrace #'bt.2.3 `((bt.2.3))))
 419
 420 ;;; This test is somewhat deceptively named. Due to confusion in debug
 421 ;;; naming these functions used to have sb-c::varargs-entry debug
 422 ;;; names for their main lambda.
 423 (with-test (:name (:backtrace :varargs-entry))
 424   (assert-backtrace #'bt.3.1 '((bt.3.1 :key nil)))
 425   (assert-backtrace #'bt.3.2 '((bt.3.2 :key ?)))
 426   (assert-backtrace #'bt.3.3 `((bt.3.3 :key ,*unavailable-argument*)))
 427   (assert-backtrace #'bt.3.1 '((bt.3.1 :key nil)))
 428   (assert-backtrace #'bt.3.2 '((bt.3.2 :key ?)))
 429   (assert-backtrace #'bt.3.3 `((bt.3.3 :key ,*unavailable-argument*))))
 430
 431 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 432 ;;; these functions used to have sb-c::hairy-args-processor debug names for
 433 ;;; their main lambda.
 434 (with-test (:name (:backtrace :hairy-args-processor))
 435   (assert-backtrace #'bt.4.1 '((bt.4.1 ?)))
 436   (assert-backtrace #'bt.4.2 '((bt.4.2 ?)))
 437   (assert-backtrace #'bt.4.3 `((bt.4.3 ,*unused-argument*)))
 438   (assert-backtrace #'bt.4.1 '((bt.4.1 ?)))
 439   (assert-backtrace #'bt.4.2 '((bt.4.2 ?)))
 440   (assert-backtrace #'bt.4.3 `((bt.4.3 ,*unused-argument*))))
 441
 442 (with-test (:name (:backtrace :optional-processor))
 443   (assert-backtrace #'bt.5.1 '(((bt.5.1) (:optional))) :details t)
 444   (assert-backtrace #'bt.5.2 '(((bt.5.2) (:optional))) :details t)
 445   (assert-backtrace #'bt.5.3 `(((bt.5.3) (:optional)))
 446                     :details t)
 447   (assert-backtrace #'bt.5.1 '((bt.5.1)))
 448   (assert-backtrace #'bt.5.2 '((bt.5.2)))
 449   (assert-backtrace #'bt.5.3 `((bt.5.3))))
 450
 451 (with-test (:name (:backtrace :unused-optional-with-supplied-p :bug-1498644))
 452   (assert-backtrace (lambda () (bt.6.1 :opt))
 453                     `(((bt.6.1 ,*unused-argument*) ()))
 454                     :details t)
 455   (assert-backtrace (lambda () (bt.6.2 :opt))
 456                     `(((bt.6.2 ,*unused-argument*) ()))
 457                     :details t)
 458   (assert-backtrace (lambda () (bt.6.3 :opt))
 459                     `(((bt.6.3 ,*unused-argument*) ()))
 460                     :details t)
 461   (assert-backtrace (lambda () (bt.6.1 :opt))
 462                     `((bt.6.1 ,*unused-argument*)))
 463   (assert-backtrace (lambda () (bt.6.2 :opt))
 464                     `((bt.6.2 ,*unused-argument*)))
 465   (assert-backtrace (lambda () (bt.6.3 :opt))
 466                     `((bt.6.3 ,*unused-argument*))))
 467
 468 (with-test (:name (:backtrace :unused-key-with-supplied-p))
 469   (assert-backtrace (lambda () (bt.7.1 :key :value))
 470                     `(((bt.7.1 :key ,*unused-argument*) ()))
 471                     :details t)
 472   (assert-backtrace (lambda () (bt.7.2 :key :value))
 473                     `(((bt.7.2 :key ,*unused-argument*) ()))
 474                     :details t)
 475   (assert-backtrace (lambda () (bt.7.3 :key :value))
 476                     `(((bt.7.3 :key ,*unused-argument*) ()))
 477                     :details t)
 478   (assert-backtrace (lambda () (bt.7.1 :key :value))
 479                     `((bt.7.1 :key ,*unused-argument*)))
 480   (assert-backtrace (lambda () (bt.7.2 :key :value))
 481                     `((bt.7.2 :key ,*unused-argument*)))
 482   (assert-backtrace (lambda () (bt.7.3 :key :value))
 483                     `((bt.7.3 :key ,*unused-argument*))))
 484
 485 (defvar *compile-nil-error*
 486   (checked-compile '(lambda (x)
 487                       (cons (when x (error "oops")) nil))))
 488 (defvar *compile-nil-non-tc*
 489   (checked-compile '(lambda (y)
 490                       (cons (funcall *compile-nil-error* y) nil))))
 491 (with-test (:name (:backtrace compile nil))
 492   (assert-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
 493                     `(((lambda (x) :in ,*p*) 13)
 494                       ((lambda (y) :in ,*p*) 13))))
 495
 496 (with-test (:name (:backtrace :clos-slot-typecheckfun-named))
 497   (assert-backtrace
 498    (checked-compile
 499     `(lambda ()
 500        (locally (declare (optimize safety))
 501          (defclass clos-typecheck-test ()
 502            ((slot :type fixnum)))
 503          (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
 504    '(((sb-pcl::slot-typecheck fixnum) t))))
 505
 506 (with-test (:name (:backtrace :clos-emf-named))
 507   (assert-backtrace
 508    (checked-compile
 509     `(lambda ()
 510        (progn
 511          (defgeneric clos-emf-named-test (x)
 512            (:method ((x symbol)) x)
 513            (:method :before (x) (assert x)))
 514          (clos-emf-named-test nil)))
 515     :allow-style-warnings t)
 516    '(((sb-pcl::emf clos-emf-named-test) ? ? nil))))
 517
 518 (with-test (:name (:backtrace :bug-310173))
 519   (flet ((make-fun (n)
 520            (let* ((names '(a b))
 521                   (req (loop repeat n collect (pop names))))
 522              (checked-compile
 523               `(lambda (,@req &rest rest)
 524                  (let ((* *)) ; no tail-call
 525                    (apply '/ ,@req rest)))))))
 526     (assert-backtrace (lambda ()
 527                         (funcall (make-fun 0) 10 11 0))
 528                       `((sb-kernel:two-arg-/ 10/11 0)
 529                         (/ 10 11 0)
 530                         ((lambda (&rest rest) :in ,*p*) 10 11 0)))
 531     (assert-backtrace (lambda ()
 532                         (funcall (make-fun 1) 10 11 0))
 533                       `((sb-kernel:two-arg-/ 10/11 0)
 534                         (/ 10 11 0)
 535                         ((lambda (a &rest rest) :in ,*p*) 10 11 0)))
 536     (assert-backtrace (lambda ()
 537                         (funcall (make-fun 2) 10 11 0))
 538                       `((sb-kernel:two-arg-/ 10/11 0)
 539                         (/ 10 11 0)
 540                         ((lambda (a b &rest rest) :in ,*p*) 10 11 0)))))
 541
 542 (defgeneric gf-dispatch-test/gf (x y)
 543   (:method ((x integer) (y integer))
 544     (+ x y)))
 545 (defun gf-dispatch-test/f (z)
 546   (declare (muffle-conditions style-warning))
 547   (gf-dispatch-test/gf z))
 548 (with-test (:name (:backtrace :gf-dispatch))
 549   ;; Fill the cache
 550   (gf-dispatch-test/gf 1 1)
 551   ;; Wrong argument count
 552   (assert-backtrace (lambda () (gf-dispatch-test/f 42))
 553                     '((gf-dispatch-test/gf 42))))
 554
 555 (defgeneric gf-default-only-test/gf (x y)
 556   (:method (x y) (+ x y)))
 557 (defun gf-default-only-test/f (z)
 558   (declare (muffle-conditions style-warning))
 559   (gf-default-only-test/gf z))
 560 (with-test (:name (:backtrace :default-only))
 561   (gf-default-only-test/gf 1 1)
 562   (assert-backtrace (lambda () (gf-default-only-test/f 42))
 563                     '(((sb-pcl::default-only gf-default-only-test/gf) 42))))
 564
 565 (with-test (:name (:backtrace :local-tail-call))
 566   (assert-backtrace
 567    (lambda () (funcall (compile nil `(sb-int:named-lambda test ()
 568                                        (signal 'error)
 569                                        (flet ((tail ()))
 570                                          (declare (notinline tail))
 571                                          (tail))))))
 572    '((test))))
 573
 574 (defun fact (n) (if (zerop n) (error "nope") (* n (fact (1- n)))))
 575
 576 #+sb-fasteval
 577 (with-test (:name (:backtrace :interpreted-factorial)
 578             :skipped-on (not :interpreter))
 579   (assert-backtrace
 580    (lambda () (fact 5))
 581    '((fact 0)
 582      (sb-interpreter::2-arg-* &rest)
 583      (fact 1)
 584      (sb-interpreter::2-arg-* &rest)
 585      (fact 2)
 586      (sb-interpreter::2-arg-* &rest)
 587      (fact 3)
 588      (sb-interpreter::2-arg-* &rest)
 589      (fact 4)
 590      (sb-interpreter::2-arg-* &rest)
 591      (fact 5))))
 592
 593 (with-test (:name :deleted-args)
 594   (let ((fun (checked-compile `(lambda (&rest ignore)
 595                                  (declare (ignore ignore))
 596                                  (error "x")))))
 597     (assert (typep (block nil
 598                      (handler-bind ((error
 599                                       (lambda (c)
 600                                         (return (values c
 601                                                         (sb-debug:list-backtrace))))))
 602                        (funcall fun)))
 603                    'simple-error))))
 604
 605 (defun mega-string-replace-fail (x)
 606   (let ((string (make-string 10000 :initial-element #\z))
 607         (stream (make-string-output-stream)))
 608     (block nil
 609       (handler-bind
 610           ((condition (lambda (c)
 611                         (declare (ignore c))
 612                         (sb-debug:print-backtrace :stream stream)
 613                         (return-from nil))))
 614         (replace string x)))
 615     (get-output-stream-string stream)))
 616
 617 (with-test (:name :long-string-abbreviation)
 618   (let ((backtrace (mega-string-replace-fail '(#\- 1))))
 619     (assert (search (concatenate 'string
 620                                  "-"
 621                                  (make-string 199 :initial-element #\z)
 622                                  "...")
 623                     backtrace))))
 624
 625 (defclass cannot-print-this () ())
 626 (defmethod print-object ((object cannot-print-this) stream)
 627   (error "No go!"))
 628
 629 (with-test (:name (sb-debug:print-backtrace :no-error print-object))
 630   ;; Errors during printing objects used to be suppressed in a way
 631   ;; that required outer condition handlers to behave in a specific
 632   ;; way.
 633   (handler-bind ((error (lambda (condition)
 634                           (error "~@<~S signaled ~A.~@:>"
 635                                  'sb-debug:print-backtrace condition))))
 636     (with-output-to-string (stream)
 637       (labels ((foo (n x)
 638                  (when (plusp n)
 639                    (foo (1- n) x))
 640                  (when (zerop n)
 641                    (sb-debug:print-backtrace :count 100 :stream stream
 642                                              :emergency-best-effort t))))
 643         (foo 100 (make-instance 'cannot-print-this))))))
 644
 645 (with-test (:name (sb-debug:print-backtrace :no-error :circles))
 646   ;; Errors during printing objects used to be suppressed in a way
 647   ;; that required outer condition handlers to behave in a specific
 648   ;; way.
 649   (handler-bind ((error (lambda (condition)
 650                           (error "~@<~S signaled ~A.~@:>"
 651                                  'sb-debug:print-backtrace condition))))
 652     (with-output-to-string (stream)
 653       (labels ((foo (n x)
 654                  (when (plusp n)
 655                    (foo (1- n) x))
 656                  (when (zerop n)
 657                    (sb-debug:print-backtrace :count 100 :stream stream))))
 658         (foo 100 (let ((list (list t)))
 659                    (nconc list list)))))))
 660
 661 (with-test (:name :uninitialized-optionals)
 662   (let ((fun (checked-compile
 663               `(lambda (l &optional m n)
 664                  (declare (fixnum l))
 665                  (values l m n)))))
 666     (checked-compile-and-assert
 667         ()
 668         `(lambda (fun &rest args)
 669            (block nil
 670              (handler-bind ((error
 671                               (lambda (c)
 672                                 c
 673                                 (return (cdar (sb-debug:list-backtrace :count 1))))))
 674                (apply fun args))))
 675       ((fun t) (list t *unavailable-argument* *unavailable-argument*) :test #'equalp)
 676       ((fun t 1) (list t 1 *unavailable-argument*) :test #'equalp)
 677       ((fun t 1 2) (list t 1 2) :test #'equalp)
 678       ((fun 1 2 3) (values 1 2 3)))))