tests/debug.impure.lisp

   1 ;;;; This file is for testing debugging functionality, using
   2 ;;;; test machinery which might have side effects (e.g.
   3 ;;;; executing DEFUN).
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (cl:in-package :cl-user)
  17
  18 ;;; The debugger doesn't have any native knowledge of the interpreter
  19 (when (eq sb-ext:*evaluator-mode* :interpret)
  20   (sb-ext:exit :code 104))
  21
  22 \f
  23 ;;;; Check that we get debug arglists right.
  24
  25 ;;; FIXME: This should use some get-argslist like functionality that
  26 ;;; we actually export.
  27 ;;;
  28 ;;; Return the debug arglist of the function object FUN as a list, or
  29 ;;; punt with :UNKNOWN.
  30 (defun get-arglist (fun)
  31   (declare (type function fun))
  32   ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
  33   (case (sb-kernel:widetag-of fun)
  34     (#.sb-vm:simple-fun-widetag
  35       (sb-kernel:%simple-fun-arglist fun))
  36     (#.sb-vm:closure-widetag
  37      (get-arglist (sb-kernel:%closure-fun fun)))
  38     ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
  39     ;; like above, and it seems to work. -- MNA 2001-06-12
  40     ;;
  41     ;; (There might be other cases with arglist info also.
  42     ;; SIMPLE-FUN-WIDETAG and CLOSURE-WIDETAG just
  43     ;; happen to be the two case that I had my nose rubbed in when
  44     ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
  45     ;; a closure. -- WHN 2001-06-05)
  46     (t
  47      ;; FIXME: what about #+sb-fasteval ?
  48      #+sb-eval
  49      (if (typep fun 'sb-eval::interpreted-function)
  50          (sb-eval::interpreted-function-lambda-list fun)
  51          :unknown)
  52      #-sb-eval
  53      :unknown)))
  54
  55 (defun zoop (zeep &key beep)
  56   blurp)
  57 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
  58
  59 ;;; Check some predefined functions too.
  60 ;;;
  61 ;;; (We don't know exactly what the arguments are, e.g. the first
  62 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
  63 ;;; whatever. But we do know the general structure that a correct
  64 ;;; answer should have, so we can safely do a lot of checks.)
  65 (with-test (:name :predefined-functions-1)
  66   (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
  67     (assert (symbolp object-sym))
  68     (assert (eql &optional-sym '&optional))
  69     (assert (symbolp stream-sym))))
  70
  71 (with-test (:name :predefined-functions-2)
  72   (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
  73       (get-arglist #'format)
  74     (assert (symbolp dest-sym))
  75     (assert (symbolp control-sym))
  76     (assert (eql &rest-sym '&rest))
  77     (assert (symbolp format-args-sym))))
  78
  79 ;;;; test TRACE
  80
  81 (defmacro with-traced-function ((name &rest options) &body body)
  82   `(with-output-to-string (*trace-output*)
  83      (unwind-protect
  84           (progn
  85             (trace ,name ,@options)
  86             ,@body)
  87        (ignore-errors (untrace ,name)))))
  88
  89 (defun trace-this ()
  90   'ok)
  91
  92 (defun trace-fact (n)
  93   (if (zerop n)
  94       1
  95       (* n (trace-fact (1- n)))))
  96
  97 (with-test (:name (trace :simple))
  98   (let ((output (with-traced-function (trace-this)
  99                   (assert (eq 'ok (trace-this))))))
 100     (assert (search "TRACE-THIS" output))
 101     (assert (search "returned OK" output))))
 102
 103 ;;; bug 379
 104 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
 105 ;;; suspicions that the breakpoint trace might corrupt the whole image
 106 ;;; on that platform.
 107 (with-test (:name (trace :encapsulate nil)
 108             :fails-on '(or (and :ppc (not :linux)) :sparc :arm64)
 109             :broken-on '(or :darwin :sunos :hppa))
 110   (let ((output (with-traced-function (trace-this :encapsulate nil)
 111                   (assert (eq 'ok (trace-this))))))
 112     (assert (search "TRACE-THIS" output))
 113     (assert (search "returned OK" output))))
 114
 115 (with-test (:name (:trace :encapsulate nil :recursive)
 116             :fails-on '(or (and :ppc (not :linux)) :sparc :sunos :arm64)
 117             :broken-on '(or :darwin (and :x86 :sunos) :hppa))
 118   (let ((output (with-traced-function (trace-fact :encapsulate nil)
 119                   (assert (= 120 (trace-fact 5))))))
 120     (assert (search "TRACE-FACT" output))
 121     (assert (search "returned 1" output))
 122     (assert (search "returned 120" output))))
 123
 124 (defun trace-and-fmakunbound-this (x)
 125   x)
 126
 127 (with-test (:name (trace fmakunbound :bug-667657))
 128   (trace trace-and-fmakunbound-this)
 129   (fmakunbound 'trace-and-fmakunbound-this)
 130   (untrace)
 131   (assert (not (trace))))
 132
 133 (with-test (:name (trace :report nil :smoke))
 134   (let ((output (with-traced-function (trace-this :report nil)
 135                   (assert (eq 'ok (trace-this))))))
 136     (assert (sequence:emptyp output))))
 137
 138 (with-test (:name (trace :report nil :print))
 139   (let ((output (with-traced-function
 140                     (trace-fact :report nil :print (sb-debug:arg 0))
 141                   (assert (eq '2 (trace-fact 2))))))
 142     (assert (string= output (format nil "2~@
 143                                          1~@
 144                                          0~%")))))
 145
 146 (with-test (:name :bug-414)
 147   (handler-bind ((warning #'error))
 148     (load (compile-file "bug-414.lisp"))
 149     (disassemble 'bug-414)))
 150
 151 ;; A known function can be stored as a code constant in lieu of the
 152 ;; usual mode of storing an #<fdefn> and looking up the function from it.
 153 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
 154 ;; Show that declaring the function locally notinline uses the #<fdefn>
 155 ;; by first compiling a call that would have elided the #<fdefn>
 156 ;; and then TRACE.
 157 (defun test-compile-then-load (filename junk)
 158   (declare (notinline compile-file load))
 159   (apply 'load (apply 'compile-file filename junk) junk))
 160 (compile 'test-compile-then-load)
 161 (with-test (:name :traceable-known-fun)
 162   (let ((s (make-string-output-stream)))
 163     (trace compile-file load)
 164     (let ((*trace-output* s))
 165       (test-compile-then-load "bug-414.lisp" nil))
 166     (untrace)
 167     (assert (>= (count #\Newline (get-output-stream-string s)) 4))))
 168
 169 (with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
 170   ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
 171   ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
 172   ;; use two-arg-LIST, which should get through to VOP LIST, and thus
 173   ;; stack-allocate on a predictable set of machines.
 174   (let ((dx-arg (list t t)))
 175     (declare (dynamic-extent dx-arg))
 176     (flet ((dx-arg-backtrace (x)
 177              (declare (optimize (debug 2)))
 178              (prog1 (sb-debug:list-backtrace :count 10)
 179                (assert (sb-debug::stack-allocated-p x)))))
 180       (declare (notinline dx-arg-backtrace))
 181       (assert (member-if (lambda (frame)
 182                            (and (consp frame)
 183                                 (consp (car frame))
 184                                 (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
 185                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
 186                          (dx-arg-backtrace dx-arg))))))
 187
 188 (with-test (:name :bug-795245)
 189   (assert
 190    (eq :ok
 191        (catch 'done
 192          (handler-bind
 193              ((error (lambda (e)
 194                        (declare (ignore e))
 195                        (handler-case
 196                            (sb-debug:print-backtrace :count 100
 197                                                      :stream (make-broadcast-stream))
 198                          (error ()
 199                            (throw 'done :error))
 200                          (:no-error ()
 201                            (throw 'done :ok))))))
 202            (apply '/= nil 1 2 nil))))))
 203
 204 ;;;; test infinite error protection
 205
 206 (defmacro nest-errors (n-levels error-form)
 207   (if (< 0 n-levels)
 208       `(handler-bind ((error (lambda (condition)
 209                                (declare (ignore condition))
 210                                ,error-form)))
 211         (nest-errors ,(1- n-levels) ,error-form))
 212       error-form))
 213
 214 (defun erroring-debugger-hook (condition old-debugger-hook)
 215   (let ((*debugger-hook* old-debugger-hook))
 216     (format t "recursive condition: ~A~%" condition) (force-output)
 217     (error "recursive condition: ~A" condition)))
 218
 219 (defun test-infinite-error-protection ()
 220   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
 221   ;; to halt, it produces so much garbage that's hard to suppress that
 222   ;; it is tested only once
 223   (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
 224   (let ((*debugger-hook* #'erroring-debugger-hook))
 225     (loop repeat 1 do
 226           (let ((error-counter 0)
 227                 (*terminal-io* (make-broadcast-stream)))
 228             (assert
 229              (not (eq
 230                    :normal-exit
 231                    (catch 'sb-impl::toplevel-catcher
 232                      (nest-errors 20 (error "infinite error ~s"
 233                                             (incf error-counter)))
 234                      :normal-exit)))))))
 235   (write-line "--END OF H-B-A-B--"))
 236
 237 (with-test (:name :infinite-error-protection)
 238   (enable-debugger)
 239   (test-infinite-error-protection))
 240
 241 (with-test (:name (:infinite-error-protection :thread)
 242                   :skipped-on '(not :sb-thread))
 243   (enable-debugger)
 244   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
 245     (loop while (sb-thread:thread-alive-p thread))))
 246
 247 ;; unconditional, in case either previous left it enabled
 248 (disable-debugger)
 249 \f
 250 ;;;; test some limitations of MAKE-LISP-OBJ
 251
 252 ;;; Older GENCGC systems had a bug in the pointer validation used by
 253 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
 254 ;;; validate.
 255 (with-test (:name (:make-lisp-obj :simple-funs))
 256   (sb-sys:without-gcing
 257     (assert (eq #'identity
 258                 (sb-kernel:make-lisp-obj
 259                  (sb-kernel:get-lisp-obj-address
 260                   #'identity))))))
 261
 262 ;;; Older CHENEYGC systems didn't perform any real pointer validity
 263 ;;; checks beyond "is this pointer to somewhere in heap space".
 264 (with-test (:name (:make-lisp-obj :pointer-validation))
 265   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
 266   ;; address, but we also need the GC to not pitch a fit if it sees an
 267   ;; object with said bogus address.  Thus, construct our known-bogus
 268   ;; object within an area of unboxed storage (a vector) in static
 269   ;; space.  We'll make it a simple object, (CONS 0 0), which has an
 270   ;; in-memory representation of two consecutive zero words.  We
 271   ;; allocate a three-word vector so that we can guarantee a
 272   ;; double-word aligned double-word of zeros no matter what happens
 273   ;; with the vector-data-offset (currently double-word aligned).
 274   (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
 275                                             :initial-element 0))
 276          (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
 277          (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
 278          (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
 279     (multiple-value-bind (object valid-p)
 280         (sb-kernel:make-lisp-obj object-tagged-address nil)
 281       (declare (ignore object))
 282       (assert (not valid-p)))))
 283
 284 (defun test-debugger (control form &rest targets)
 285   (let ((out (make-string-output-stream))
 286         (oops t))
 287     (unwind-protect
 288          (progn
 289            (with-simple-restart (debugger-test-done! "Debugger Test Done!")
 290              (let* ((*debug-io* (make-two-way-stream
 291                                  (make-string-input-stream control)
 292                                  (make-broadcast-stream out #+nil *standard-output*)))
 293                     ;; Initial announcement goes to *ERROR-OUTPUT*
 294                     (*error-output* *debug-io*)
 295                     (*invoke-debugger-hook* nil))
 296                (handler-bind ((error #'invoke-debugger))
 297                  (eval form))))
 298            (setf oops nil))
 299       (when oops
 300         (error "Uncontrolled unwind from debugger test.")))
 301     ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
 302     ;; it could swallow our asserts!
 303     (with-input-from-string (s (get-output-stream-string out))
 304       (loop for line = (read-line s nil)
 305             while line
 306             do (assert targets nil "Line = ~a" line)
 307                #+nil
 308                (format *error-output* "Got: ~A~%" line)
 309                (let ((match (pop targets)))
 310                  (if (eq '* match)
 311                      ;; Whatever, till the next line matches.
 312                      (let ((text (pop targets)))
 313                        #+nil
 314                        (format *error-output* "Looking for: ~A~%" text)
 315                        (unless (search text line)
 316                          (push text targets)
 317                          (push match targets)))
 318                      (unless (search match line)
 319                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
 320                        (setf oops t))))))
 321     ;; Check that we saw everything we wanted
 322     (when targets
 323       (error "Missed: ~S" targets))
 324     (assert (not oops))))
 325
 326 (with-test (:name (:debugger :source 1)
 327             ;; Division is done by an assembly routine on ppc
 328             ;; and it can't locate the div-by-zero error there
 329             :fails-on :ppc)
 330   (test-debugger
 331    "d
 332     source 0
 333     debugger-test-done!"
 334    `(progn
 335       (defun this-will-break (x)
 336                (declare (optimize debug))
 337                (let* ((y (- x x))
 338                       (z (/ x y)))
 339                  (+ x z)))
 340       (this-will-break 1))
 341    '*
 342    "debugger invoked"
 343    '*
 344    "DIVISION-BY-ZERO"
 345    "Operation was (/ 1 0)"
 346    '*
 347    "INTEGER-/-INTEGER"
 348    "(THIS-WILL-BREAK 1)"
 349    "1]"
 350    "(/ X Y)"
 351    "1]"))
 352
 353 (with-test (:name (:debugger :source 2))
 354   (test-debugger
 355    "d
 356     source 0
 357     debugger-test-done!"
 358    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
 359       (let ((f #'(lambda (x cont)
 360                    (print x (make-broadcast-stream))
 361                    (if (zerop x)
 362                        (error "~%foo")
 363                        (funcall cont (1- x) cont)))))
 364         (funcall f 10 f)))
 365    '*
 366    "debugger"
 367    '*
 368    "foo"
 369    '*
 370    "source: (ERROR \"~%foo\")"
 371    '*
 372    "(LAMBDA (X CONT)"
 373    '*
 374    "(FUNCALL CONT (1- X) CONT)"
 375    "1]"))
 376
 377 (with-test (:name (:debugger :bogus-debug-fun :source))
 378   (test-debugger
 379    "d
 380     debugger-test-done!"
 381    `(let ()
 382       (#.(gensym)))
 383    '*
 384    "undefined function"
 385    '*
 386    "1]"))
 387
 388 (with-test (:name (disassemble :high-debug-eval))
 389   (eval `(defun this-will-be-disassembled (x)
 390            (declare (optimize debug))
 391            (+ x x)))
 392   (let* ((oopses (make-string-output-stream))
 393          (disassembly
 394            (let ((*error-output* oopses))
 395              (with-output-to-string (*standard-output*)
 396                (disassemble 'this-will-be-disassembled)))))
 397     (with-input-from-string (s disassembly)
 398       (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
 399                       (read-line s))))
 400     (let ((problems (get-output-stream-string oopses)))
 401       (unless (zerop (length problems))
 402         (error problems)))))
 403
 404 (defun this-too-will-be-disasssembled (x)
 405   (declare (optimize debug))
 406   (+ x x))
 407
 408 (with-test (:name (disassemble :high-debug-load))
 409   (let* ((oopses (make-string-output-stream))
 410          (disassembly
 411            (let ((*error-output* oopses))
 412              (with-output-to-string (*standard-output*)
 413                (disassemble 'this-too-will-be-disasssembled)))))
 414     (with-input-from-string (s disassembly)
 415       (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
 416                      (read-line s))))
 417     (let ((problems (get-output-stream-string oopses)))
 418       (unless (zerop (length problems))
 419         (error problems)))))
 420
 421 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
 422   (assert
 423    (block nil
 424      (handler-bind ((error (lambda (e)
 425                              (declare (ignore e))
 426                              (return (< (length (car (sb-debug:list-backtrace :count 1)))
 427                                         10)))))
 428        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
 429
 430 ;;; bug-1261646
 431
 432 (defun print-backtrace-to-string/debug-print-variable-alist (x)
 433   (values
 434    (with-output-to-string (stream)
 435      (let ((*debug-print-variable-alist* '((*print-length* . 5)
 436                                            (*print-level* . 3))))
 437        (sb-debug:print-backtrace :stream stream :count 5)))
 438    x)) ; Force use of X to prevent flushing
 439
 440 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 441                    *print-length* :bug-1261646))
 442   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist (make-array 200)))
 443          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 444          (position (+ (search call printed) (length call))))
 445     (assert (eql position (search "#(0 0 0 0 0 ...)" printed :start2 position)))))
 446
 447 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 448                    *print-level* :bug-1261646))
 449   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
 450                    '(((((1)))))))
 451          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 452          (position (+ (search call printed) (length call))))
 453     (assert (eql position (search "((#))" printed :start2 position)))))
 454
 455
 456 (defvar *x* nil)
 457 (defun foo (a) a)
 458
 459 (with-test (:name :trace-debug-arg)
 460   (trace foo :print-after (setf *x* (sb-debug:arg 0)))
 461   (foo 1)
 462   (assert (eql *x* 1))
 463
 464   (trace foo :print (setf *x* (sb-debug:arg 0)))
 465   (foo 2)
 466   (assert (eql *x* 2))
 467
 468   (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
 469   (foo 3)
 470   (assert (eql *x* 3))
 471
 472   (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
 473   (foo 4)
 474   (assert (eql *x* 4))
 475
 476   (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
 477   (foo 5)
 478   (assert (eql *x* 5))
 479
 480   (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
 481   (foo 6)
 482   (assert (eql *x* 6))
 483   (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
 484   (foo 7))
 485
 486 (defun frobbleize (arg) (declare (ignore arg)) (sb-debug:list-backtrace) 'win)
 487 (defmethod low-debug-method ((self t))
 488   (declare (optimize (debug 0)))
 489   (frobbleize 'me) ; make this not a tail call, so it remains on stack
 490   5)
 491 (with-test (:name :clean-fast-method-frame-lossage)
 492   (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
 493
 494 (defun return-65535 ()
 495   65535)
 496
 497 (with-test (:name :indirect-closure-values)
 498   (let ((count 0))
 499     (block nil
 500       (handler-bind ((error (lambda (c)
 501                               (declare (ignore c))
 502                               (sb-debug::map-backtrace
 503                                (lambda (frame)
 504                                  (let ((sb-debug::*current-frame* frame)
 505                                        (name (sb-debug::frame-call frame)))
 506                                    (when (or (eq name 'test)
 507                                              (and (consp name)
 508                                                   (or (eql (search '(labels f1) name) 0)
 509                                                       (eql (search '(labels f2) name) 0))))
 510                                      (incf count)
 511                                      (assert (eql (var 'a) 2))))))
 512                               (return))))
 513         (funcall
 514          (compile nil
 515                   `(sb-int:named-lambda test ()
 516                      (declare (optimize debug))
 517                      (let ((a 1))
 518                        (labels
 519                            ((f1 ()
 520                               (incf a)
 521                               (signal 'error))
 522                             (f2 ()
 523                               (f1)))
 524                          (f2))))))))
 525     (assert (= count 3))))
 526
 527 (with-test (:name :indirect-closure-values.2)
 528   (let ((count 0))
 529     (block nil
 530       (handler-bind ((error (lambda (c)
 531                               (declare (ignore c))
 532                               (sb-debug::map-backtrace
 533                                (lambda (frame)
 534                                  (let ((sb-debug::*current-frame* frame)
 535                                        (name (sb-debug::frame-call frame)))
 536                                    (when (or (eq name 'test)
 537                                              (and (consp name)
 538                                                   (or (eql (search '(labels f1) name) 0)
 539                                                       (eql (search '(labels f2) name) 0))))
 540                                      (incf count)
 541                                      (assert (eql (var 'a) 65535))))))
 542                               (return))))
 543         (funcall
 544          (compile nil
 545                   `(sb-int:named-lambda test ()
 546                      (declare (optimize debug))
 547                      (let ((a (return-65535)))
 548                        (declare ((unsigned-byte 16) a))
 549                        (labels
 550                            ((f1 ()
 551                               (incf a)
 552                               (signal 'error))
 553                             (f2 ()
 554                               (f1)))
 555                          (f2))))))))
 556     (assert (= count 3))))
 557
 558 (with-test (:name :non-tail-self-call-bad-variables)
 559   (let ((count 0))
 560     (block nil
 561       (handler-bind ((error (lambda (c)
 562                               (declare (ignore c))
 563                               (sb-debug::map-backtrace
 564                                (lambda (frame)
 565                                  (let ((sb-debug::*current-frame* frame))
 566                                    (multiple-value-bind (name args)
 567                                        (sb-debug::frame-call frame)
 568                                      (when (eq name 'test)
 569                                        (assert (or (null args)
 570                                                    (equal args '(nil))))
 571                                        (incf count))))))
 572                               (return))))
 573         (funcall
 574          (compile nil `(sb-int:named-lambda test (&optional x)
 575                          (declare (optimize sb-c::recognize-self-calls))
 576                          (signal 'error :format-control "~a" :format-arguments (list x))
 577                          (test 1)
 578                          1)))))
 579     (assert (= count 1))))
 580
 581 (with-test (:name :local-tail-call-variables)
 582   (let ((count 0))
 583     (block nil
 584       (handler-bind ((error (lambda (c)
 585                               (declare (ignore c))
 586                               (sb-debug::map-backtrace
 587                                (lambda (frame)
 588                                  (let ((sb-debug::*current-frame* frame))
 589                                    (multiple-value-bind (name args)
 590                                        (sb-debug::frame-call frame)
 591                                      (when (eq name 'test)
 592                                        (assert (equal args '(error)))
 593                                        (incf count))))))
 594                               (return))))
 595         (funcall
 596          (compile nil `(sb-int:named-lambda test (x)
 597                          (signal x)
 598                          ;; If :local-tail-call fails, this will fail
 599                          ;; too, because there's no jump between
 600                          ;; SIGNAL and the call to TAIL and it will
 601                          ;; show (flet tail) in the backtrace.
 602                          (flet ((tail ()))
 603                            (declare (notinline tail))
 604                            (tail))))
 605          'error)))
 606     (assert (= count 1))))
 607
 608 (with-test (:name :variables-surrounding-inlined-code)
 609   (let ((count 0))
 610     (block nil
 611       (handler-bind ((error (lambda (c)
 612                               (declare (ignore c))
 613                               (sb-debug::map-backtrace
 614                                (lambda (frame)
 615                                  (let ((sb-debug::*current-frame* frame))
 616                                    (multiple-value-bind (name)
 617                                        (sb-debug::frame-call frame)
 618                                      (when (eq name 'test)
 619                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
 620                                        (incf count))))))
 621                               (return))))
 622         (funcall
 623          (compile nil `(sb-int:named-lambda test (a i)
 624                          (declare (optimize (debug 3)))
 625                          (let ((l (list 1 2 3)))
 626                            (aref a i)
 627                            l)))
 628          #(1) 2)))
 629     (assert (= count 1))))
 630
 631 (with-test (:name :variables-surrounding-inlined-code.2)
 632   (let ((count 0))
 633     (block nil
 634       (handler-bind ((error (lambda (c)
 635                               (declare (ignore c))
 636                               (sb-debug::map-backtrace
 637                                (lambda (frame)
 638                                  (let ((sb-debug::*current-frame* frame))
 639                                    (multiple-value-bind (name)
 640                                        (sb-debug::frame-call frame)
 641                                      (when (eq name 'test)
 642                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
 643                                        (incf count))))))
 644                               (return))))
 645         (funcall
 646          (compile nil `(sb-int:named-lambda test (c)
 647                          (declare (optimize (debug 3)))
 648                          (let ((l (list 1 2 3)))
 649                            (map 'list #'signal c)
 650                            l)))
 651          '(error))))
 652     (assert (= count 1))))