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