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