1 ;;;; This file is for testing debugging functionality, using
2 ;;;; test machinery which might have side effects (e.g.
5 ;;;; This software is part of the SBCL system. See the README file for
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
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.
16 (cl:in-package
:cl-user
)
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))
23 ;;;; Check that we get debug arglists right.
25 (defvar *p
* (namestring *load-truename
*))
27 ;;; FIXME: This should use some get-argslist like functionality that
28 ;;; we actually export.
30 ;;; Return the debug arglist of the function object FUN as a list, or
31 ;;; punt with :UNKNOWN.
32 (defun get-arglist (fun)
33 (declare (type function fun
))
34 ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
35 (case (sb-kernel:widetag-of fun
)
36 (#.sb-vm
:simple-fun-header-widetag
37 (sb-kernel:%simple-fun-arglist fun
))
38 (#.sb-vm
:closure-header-widetag
(get-arglist
39 (sb-kernel:%closure-fun fun
)))
40 ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
41 ;; like above, and it seems to work. -- MNA 2001-06-12
43 ;; (There might be other cases with arglist info also.
44 ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
45 ;; happen to be the two case that I had my nose rubbed in when
46 ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
47 ;; a closure. -- WHN 2001-06-05)
50 (if (typep fun
'sb-eval
::interpreted-function
)
51 (sb-eval::interpreted-function-lambda-list fun
)
56 (defun zoop (zeep &key beep
)
58 (assert (equal (get-arglist #'zoop
) '(zeep &key beep
)))
60 ;;; Check some predefined functions too.
62 ;;; (We don't know exactly what the arguments are, e.g. the first
63 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
64 ;;; whatever. But we do know the general structure that a correct
65 ;;; answer should have, so we can safely do a lot of checks.)
66 (with-test (:name
:predefined-functions-1
)
67 (destructuring-bind (object-sym &optional-sym stream-sym
) (get-arglist #'print
)
68 (assert (symbolp object-sym
))
69 (assert (eql &optional-sym
'&optional
))
70 (assert (symbolp stream-sym
))))
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
))))
79 ;;; Check for backtraces generally being correct. Ensure that the
80 ;;; actual backtrace finishes (doesn't signal any errors on its own),
81 ;;; and that it contains the frames we expect, doesn't contain any
82 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
83 ;;; and hasn't been cut off anywhere.
84 (defun verify-backtrace (test-function frame-specs
&key
(allow-stunted nil
) details
)
85 (labels ((args-equal (want real
)
86 (cond ((eq '&rest
(car want
))
90 ((or (eq '?
(car want
)) (equal (car want
) (car real
)))
91 (args-equal (cdr want
) (cdr real
)))
97 ((error (lambda (condition)
98 ;; find the part of the backtrace we're interested in
100 (sb-debug::map-backtrace
102 (multiple-value-bind (name args info
)
103 (sb-debug::frame-call frame
#+nil
#+nil
104 :replace-dynamic-extent-objects t
)
106 (push (list (cons name args
) info
) full-backtrace
)
107 (push (cons name args
) full-backtrace
)))))
109 (setf full-backtrace
(nreverse full-backtrace
))
110 (let ((backtrace (if details
111 (member (caaar frame-specs
)
115 (member (caar frame-specs
)
120 (setf result condition
)
123 (format t
"~&//~S not in backtrace:~% ~S~%"
127 ;; check that we have all the frames we wanted
130 (unless (or (not spec
)
133 (and (args-equal (car spec
)
135 (equal (cdr spec
) (cdr frame
)))
137 (print (list :spec spec
:frame frame
))
139 (and (equal (car spec
) (car frame
))
140 (args-equal (cdr spec
)
142 (print (list :wanted spec
:got frame
))
147 ;; Make sure the backtrace isn't stunted in
148 ;; any way. (Depends on running in the main
149 ;; thread.) FIXME: On Windows we get two
150 ;; extra foreign frames below regular frames.
151 (unless (find (if details
152 '((sb-impl::toplevel-init
) ())
153 '(sb-impl::toplevel-init
))
156 (print (list :backtrace-stunted backtrace
))
158 (return-from outer-handler
))))))
159 (funcall test-function
)))
162 (defvar *undefined-function-frame
*
164 '("undefined function"))
166 ;;; Test for "undefined function" (undefined_tramp) working properly.
167 ;;; Try it with and without tail call elimination, since they can have
168 ;;; different effects. (Specifically, if undefined_tramp is incorrect
169 ;;; a stunted stack can result from the tail call variant.)
171 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
172 (#:undefined-function
42))
174 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
175 (#:undefined-function
42))
177 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
180 (with-test (:name
(:undefined-function
:bug-346
)
181 ;; Failures on ALPHA, SPARC, MIPS, and probably
182 ;; HPPA are due to not having a full and valid
183 ;; stack frame for the undefined function frame.
184 ;; See PPC undefined_tramp for details.
185 :fails-on
'(or :alpha
:sparc
:mips
))
186 (assert (verify-backtrace
187 (lambda () (test #'optimized
))
188 (list *undefined-function-frame
*
189 (list `(flet test
:in
,*p
*) #'optimized
)))))
191 ;; bug 353: This test fails at least most of the time for x86/linux
192 ;; ca. 0.8.20.16. -- WHN
193 (with-test (:name
(:undefined-function
:bug-353
))
194 (assert (verify-backtrace
195 (lambda () (test #'not-optimized
))
196 (list *undefined-function-frame
*
197 (list `(flet not-optimized
:in
,*p
*))
198 (list `(flet test
:in
,*p
*) #'not-optimized
))))))
200 (with-test (:name
:backtrace-interrupted-condition-wait
201 :skipped-on
'(not :sb-thread
)
202 ;; For some unfathomable reason the backtrace becomes
203 ;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to
204 ;; the frame we expect. If we leave it out, the backtrace is
205 ;; fine -- but the test fails. I can only boggle right now.
206 :fails-on
`(or (and :x86
:linux
)
208 (let ((m (sb-thread:make-mutex
))
209 (q (sb-thread:make-waitqueue
)))
210 (assert (verify-backtrace
212 (sb-thread:with-mutex
(m)
213 (handler-bind ((timeout (lambda (c)
216 (sb-thread:condition-wait q m
)))))
217 `((sb-thread:condition-wait
,q
,m
:timeout nil
))))))
219 ;;; Division by zero was a common error on PPC. It depended on the
220 ;;; return function either being before INTEGER-/-INTEGER in memory,
221 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
222 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
223 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
224 ;;; if SBCL does the same this test is probably not good for the
227 ;;; Disabling tail call elimination on this will probably ensure that
228 ;;; the return value (to the flet or the enclosing top level form) is
229 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
230 ;;; Enabling it might catch other problems, so do it anyway.
232 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
235 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
238 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
240 (with-test (:name
(:divide-by-zero
:bug-346
)
241 :fails-on
:alpha
) ; bug 346
242 (assert (verify-backtrace (lambda () (test #'optimized
))
244 (list `(flet test
:in
,*p
*) #'optimized
)))))
245 (with-test (:name
(:divide-by-zero
:bug-356
)
246 :fails-on
:alpha
) ; bug 356
247 (assert (verify-backtrace (lambda () (test #'not-optimized
))
249 `((flet not-optimized
:in
,*p
*))
250 (list `(flet test
:in
,*p
*) #'not-optimized
))))))
252 (with-test (:name
(:throw
:no-such-tag
)
259 (throw 'no-such-tag t
))
260 (assert (verify-backtrace #'throw-test
'((throw-test))))))
262 (defun bug-308926 (x)
270 (with-test (:name
:bug-308926
)
271 (assert (verify-backtrace (lambda () (bug-308926 13))
272 '(((flet bar
:in bug-308926
) 13)
273 (bug-308926 &rest t
)))))
275 ;;; Test backtrace through assembly routines
277 (macrolet ((test (predicate fun
279 (find-symbol (format nil
"TWO-ARG-~A" fun
)
281 (let ((test-name (make-symbol (format nil
"TEST-~A" fun
))))
282 `(flet ((,test-name
(x y
)
283 ;; make sure it's not in tail position
285 (with-test (:name
(:bug-800343
,fun
))
286 (assert (verify-backtrace
288 (eval `(funcall ,#',test-name
42 t
)))
292 '(("no debug information for frame")))
293 ((flet ,test-name
:in
,*p
*) 42 t
))))))))
294 (test-predicates (&rest functions
)
295 `(progn ,@(mapcar (lambda (function)
298 `(test t
,function
)))
300 (test-functions (&rest functions
)
301 `(progn ,@(mapcar (lambda (function)
303 `(test nil
,@function
)
304 `(test nil
,function
)))
306 (test-predicates = < >)
307 (test-functions + -
* /
309 (logand sb-kernel
:two-arg-and
)
310 (logior sb-kernel
:two-arg-ior
)
311 (logxor sb-kernel
:two-arg-xor
)))
313 ;;; test entry point handling in backtraces
318 (with-test (:name
:xep-too-many-arguments
)
319 (assert (verify-backtrace (lambda () (oops 1 2 3 4 5 6))
320 '((oops ? ? ? ? ? ?
)))))
322 (defmacro defbt
(n ll
&body body
)
323 ;; WTF is this? This is a way to make these tests not depend so much on the
324 ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
325 ;; slightly smarter, which meant that things which used to have xeps
326 ;; suddently had tl-xeps, etc. This takes care of that.
332 (defun ,(intern (format nil
"BT.~A.1" n
)) ,ll
334 ;; no arguments saved
335 (defun ,(intern (format nil
"BT.~A.2" n
)) ,ll
336 (declare (optimize (debug 1) (speed 3)))
338 ;; no lambda-list saved
339 (defun ,(intern (format nil
"BT.~A.3" n
)) ,ll
340 (declare (optimize (debug 0)))
349 (defbt 3 (&key
(key (oops)))
352 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
353 (defbt 4 (&optional opt
)
354 (list (error "error")))
356 (defbt 5 (&optional
(opt (oops)))
360 (error "XEPs in backtraces: ~S" x
))
362 (with-test (:name
:bug-354
)
363 (assert (not (verify-backtrace (lambda () (bug-354 354))
365 (((bug-354 &rest
) (:tl
:external
)) 354)))))
366 (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
368 ;;; FIXME: This test really should be broken into smaller pieces
369 (with-test (:name
(:backtrace
:tl-xep
))
370 (assert (verify-backtrace #'namestring
371 '(((namestring) (:tl
:external
)))
373 (assert (verify-backtrace #'namestring
376 (with-test (:name
(:backtrace
:more-processor
))
377 (assert (verify-backtrace (lambda () (bt.1.1 :key
))
378 '(((bt.1.1 :key
) (:more
:optional
)))
380 (assert (verify-backtrace (lambda () (bt.1.2 :key
))
381 '(((bt.1.2 ?
) (:more
:optional
)))
383 (assert (verify-backtrace (lambda () (bt.1.3 :key
))
384 '(((bt.1.3 &rest
) (:more
:optional
)))
386 (assert (verify-backtrace (lambda () (bt.1.1 :key
))
388 (assert (verify-backtrace (lambda () (bt.1.2 :key
))
390 (assert (verify-backtrace (lambda () (bt.1.3 :key
))
393 (with-test (:name
(:backtrace
:xep
))
394 (assert (verify-backtrace #'bt
.2.1
395 '(((bt.2.1) (:external
)))
397 (assert (verify-backtrace #'bt
.2.2
398 '(((bt.2.2 &rest
) (:external
)))
400 (assert (verify-backtrace #'bt
.2.3
401 '(((bt.2.3 &rest
) (:external
)))
403 (assert (verify-backtrace #'bt
.2.1
405 (assert (verify-backtrace #'bt
.2.2
407 (assert (verify-backtrace #'bt
.2.3
410 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
411 ;;; these functions used to have sb-c::varargs-entry debug names for their
413 (with-test (:name
(:backtrace
:varargs-entry
))
414 (assert (verify-backtrace #'bt
.3.1
415 '((bt.3.1 :key nil
))))
416 (assert (verify-backtrace #'bt
.3.2
418 (assert (verify-backtrace #'bt
.3.3
420 (assert (verify-backtrace #'bt
.3.1
421 '((bt.3.1 :key nil
))))
422 (assert (verify-backtrace #'bt
.3.2
424 (assert (verify-backtrace #'bt
.3.3
427 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
428 ;;; these functions used to have sb-c::hairy-args-processor debug names for
429 ;;; their main lambda.
430 (with-test (:name
(:backtrace
:hairy-args-processor
))
431 (assert (verify-backtrace #'bt
.4.1
433 (assert (verify-backtrace #'bt
.4.2
435 (assert (verify-backtrace #'bt
.4.3
437 (assert (verify-backtrace #'bt
.4.1
439 (assert (verify-backtrace #'bt
.4.2
441 (assert (verify-backtrace #'bt
.4.3
445 (with-test (:name
(:backtrace
:optional-processor
))
446 (assert (verify-backtrace #'bt
.5.1
447 '(((bt.5.1) (:optional
)))
449 (assert (verify-backtrace #'bt
.5.2
450 '(((bt.5.2 &rest
) (:optional
)))
452 (assert (verify-backtrace #'bt
.5.3
453 '(((bt.5.3 &rest
) (:optional
)))
455 (assert (verify-backtrace #'bt
.5.1
457 (assert (verify-backtrace #'bt
.5.2
459 (assert (verify-backtrace #'bt
.5.3
462 (write-line "//compile nil")
463 (defvar *compile-nil-error
* (compile nil
'(lambda (x) (cons (when x
(error "oops")) nil
))))
464 (defvar *compile-nil-non-tc
* (compile nil
'(lambda (y) (cons (funcall *compile-nil-error
* y
) nil
))))
465 (with-test (:name
(:compile nil
))
466 (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc
* 13))
467 `(((lambda (x) :in
,*p
*) 13)
468 ((lambda (y) :in
,*p
*) 13)))))
470 (with-test (:name
:clos-slot-typecheckfun-named
)
474 (eval `(locally (declare (optimize safety
))
475 (defclass clos-typecheck-test
()
476 ((slot :type fixnum
)))
477 (setf (slot-value (make-instance 'clos-typecheck-test
) 'slot
) t
))))
478 '(((sb-pcl::slot-typecheck fixnum
) t
)))))
480 (with-test (:name
:clos-emf-named
)
485 (defmethod clos-emf-named-test ((x symbol
)) x
)
486 (defmethod clos-emf-named-test :before
(x) (assert x
))
487 (clos-emf-named-test nil
))))
488 '(((sb-pcl::emf clos-emf-named-test
) ? ? nil
)))))
490 (with-test (:name
:bug-310173
)
492 (let* ((names '(a b
))
493 (req (loop repeat n collect
(pop names
))))
495 `(lambda (,@req
&rest rest
)
496 (let ((* *)) ; no tail-call
497 (apply '/ ,@req rest
)))))))
499 (verify-backtrace (lambda ()
500 (funcall (make-fun 0) 10 11 0))
501 `((sb-kernel:two-arg-
/ 10/11 0)
503 ((lambda (&rest rest
) :in
,*p
*) 10 11 0))))
505 (verify-backtrace (lambda ()
506 (funcall (make-fun 1) 10 11 0))
507 `((sb-kernel:two-arg-
/ 10/11 0)
509 ((lambda (a &rest rest
) :in
,*p
*) 10 11 0))))
511 (verify-backtrace (lambda ()
512 (funcall (make-fun 2) 10 11 0))
513 `((sb-kernel:two-arg-
/ 10/11 0)
515 ((lambda (a b
&rest rest
) :in
,*p
*) 10 11 0))))))
522 (defun trace-fact (n)
525 (* n
(trace-fact (1- n
)))))
527 (with-test (:name
(trace :simple
))
528 (let ((out (with-output-to-string (*trace-output
*)
530 (assert (eq 'ok
(trace-this)))
532 (assert (search "TRACE-THIS" out
))
533 (assert (search "returned OK" out
))))
536 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
537 ;;; suspicions that the breakpoint trace might corrupt the whole image
538 ;;; on that platform.
539 (with-test (:name
(trace :encapsulate nil
)
540 :fails-on
'(or (and :ppc
(not :linux
)) :sparc
:mips
)
541 :broken-on
'(or :darwin
:sunos
))
542 (let ((out (with-output-to-string (*trace-output
*)
543 (trace trace-this
:encapsulate nil
)
544 (assert (eq 'ok
(trace-this)))
546 (assert (search "TRACE-THIS" out
))
547 (assert (search "returned OK" out
))))
549 (with-test (:name
(:trace-recursive
:encapsulate nil
)
550 :fails-on
'(or (and :ppc
(not :linux
)) :sparc
:mips
:sunos
)
551 :broken-on
'(or :darwin
(and :x86
:sunos
)))
552 (let ((out (with-output-to-string (*trace-output
*)
553 (trace trace-fact
:encapsulate nil
)
554 (assert (= 120 (trace-fact 5)))
556 (assert (search "TRACE-FACT" out
))
557 (assert (search "returned 1" out
))
558 (assert (search "returned 120" out
))))
560 (defun trace-and-fmakunbound-this (x)
563 (with-test (:name
:bug-667657
)
564 (trace trace-and-fmakunbound-this
)
565 (fmakunbound 'trace-and-fmakunbound-this
)
567 (assert (not (trace))))
569 (with-test (:name
:bug-414
)
570 (handler-bind ((warning #'error
))
571 (load (compile-file "bug-414.lisp"))
572 (disassemble 'bug-414
)))
574 ;; A known function can be stored as a code constant in lieu of the
575 ;; usual mode of storing an #<fdefn> and looking up the function from it.
576 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
577 ;; Show that declaring the function locally notinline uses the #<fdefn>
578 ;; by first compiling a call that would have elided the #<fdefn>
580 (defun test-compile-then-load (filename junk
)
581 (declare (notinline compile-file load
))
582 (apply 'load
(apply 'compile-file filename junk
) junk
))
583 (compile 'test-compile-then-load
)
584 (with-test (:name
:traceable-known-fun
)
585 (let ((s (make-string-output-stream)))
586 (trace compile-file load
)
587 (let ((*trace-output
* s
))
588 (test-compile-then-load "bug-414.lisp" nil
))
590 (assert (>= (count #\Newline
(get-output-stream-string s
)) 4))))
592 (with-test (:name
:bug-310175
:fails-on
'(not :stack-allocatable-lists
))
593 ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
594 ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS. Therefore,
595 ;; use two-arg-LIST, which should get through to VOP LIST, and thus
596 ;; stack-allocate on a predictable set of machines.
597 (let ((dx-arg (list t t
)))
598 (declare (dynamic-extent dx-arg
))
599 (flet ((dx-arg-backtrace (x)
600 (declare (optimize (debug 2)))
601 (prog1 (sb-debug:list-backtrace
:count
10)
602 (assert (sb-debug::stack-allocated-p x
)))))
603 (declare (notinline dx-arg-backtrace
))
604 (assert (member-if (lambda (frame)
607 (equal '(flet dx-arg-backtrace
:in
) (butlast (car frame
)))
608 (notany #'sb-debug
::stack-allocated-p
(cdr frame
))))
609 (dx-arg-backtrace dx-arg
))))))
611 (with-test (:name
:bug-795245
)
619 (sb-debug:print-backtrace
:count
100
620 :stream
(make-broadcast-stream))
622 (throw 'done
:error
))
624 (throw 'done
:ok
))))))
625 (apply '/= nil
1 2 nil
))))))
627 ;;;; test infinite error protection
629 (defmacro nest-errors
(n-levels error-form
)
631 `(handler-bind ((error (lambda (condition)
632 (declare (ignore condition
))
634 (nest-errors ,(1- n-levels
) ,error-form
))
637 (defun erroring-debugger-hook (condition old-debugger-hook
)
638 (let ((*debugger-hook
* old-debugger-hook
))
639 (format t
"recursive condition: ~A~%" condition
) (force-output)
640 (error "recursive condition: ~A" condition
)))
642 (defun test-infinite-error-protection ()
643 ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
644 ;; to halt, it produces so much garbage that's hard to suppress that
645 ;; it is tested only once
646 (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
647 (let ((*debugger-hook
* #'erroring-debugger-hook
))
649 (let ((error-counter 0)
650 (*terminal-io
* (make-broadcast-stream)))
654 (catch 'sb-impl
::toplevel-catcher
655 (nest-errors 20 (error "infinite error ~s"
656 (incf error-counter
)))
658 (write-line "--END OF H-B-A-B--"))
660 (with-test (:name
:infinite-error-protection
)
662 (test-infinite-error-protection))
664 (with-test (:name
(:infinite-error-protection
:thread
)
665 :skipped-on
'(not :sb-thread
))
667 (let ((thread (sb-thread:make-thread
#'test-infinite-error-protection
)))
668 (loop while
(sb-thread:thread-alive-p thread
))))
670 ;; unconditional, in case either previous left it enabled
673 ;;;; test some limitations of MAKE-LISP-OBJ
675 ;;; Older GENCGC systems had a bug in the pointer validation used by
676 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
678 (with-test (:name
(:make-lisp-obj
:simple-funs
))
679 (sb-sys:without-gcing
680 (assert (eq #'identity
681 (sb-kernel:make-lisp-obj
682 (sb-kernel:get-lisp-obj-address
685 ;;; Older CHENEYGC systems didn't perform any real pointer validity
686 ;;; checks beyond "is this pointer to somewhere in heap space".
687 (with-test (:name
(:make-lisp-obj
:pointer-validation
))
688 ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
689 ;; address, but we also need the GC to not pitch a fit if it sees an
690 ;; object with said bogus address. Thus, construct our known-bogus
691 ;; object within an area of unboxed storage (a vector) in static
692 ;; space. We'll make it a simple object, (CONS 0 0), which has an
693 ;; in-memory representation of two consecutive zero words. We
694 ;; allocate a three-word vector so that we can guarantee a
695 ;; double-word aligned double-word of zeros no matter what happens
696 ;; with the vector-data-offset (currently double-word aligned).
697 (let* ((memory (sb-int:make-static-vector
3 :element-type
`(unsigned-byte ,sb-vm
:n-word-bits
)
699 (vector-data-address (sb-sys:sap-int
(sb-kernel::vector-sap memory
)))
700 (object-base-address (logandc2 (+ vector-data-address sb-vm
:lowtag-mask
) sb-vm
:lowtag-mask
))
701 (object-tagged-address (+ object-base-address sb-vm
:list-pointer-lowtag
)))
702 (multiple-value-bind (object valid-p
)
703 (sb-kernel:make-lisp-obj object-tagged-address nil
)
704 (declare (ignore object
))
705 (assert (not valid-p
)))))
707 (defun test-debugger (control form
&rest targets
)
708 (let ((out (make-string-output-stream))
712 (with-simple-restart (debugger-test-done! "Debugger Test Done!")
713 (let* ((*debug-io
* (make-two-way-stream
714 (make-string-input-stream control
)
715 (make-broadcast-stream out
#+nil
*standard-output
*)))
716 ;; Initial announcement goes to *ERROR-OUTPUT*
717 (*error-output
* *debug-io
*)
718 (*invoke-debugger-hook
* nil
))
719 (handler-bind ((error #'invoke-debugger
))
723 (error "Uncontrolled unwind from debugger test.")))
724 ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
725 ;; it could swallow our asserts!
726 (with-input-from-string (s (get-output-stream-string out
))
727 (loop for line
= (read-line s nil
)
731 (format *error-output
* "Got: ~A~%" line
)
732 (let ((match (pop targets
)))
734 ;; Whatever, till the next line matches.
735 (let ((text (pop targets
)))
737 (format *error-output
* "Looking for: ~A~%" text
)
738 (unless (search text line
)
740 (push match targets
)))
741 (unless (search match line
)
742 (format *error-output
* "~&Wanted: ~S~% Got: ~S~%" match line
)
744 ;; Check that we saw everything we wanted
746 (error "Missed: ~S" targets
))
747 (assert (not oops
))))
749 (with-test (:name
(:debugger
:source
1))
755 (defun this-will-break (x)
756 (declare (optimize debug
))
768 "(THIS-WILL-BREAK 1)"
773 (with-test (:name
(:debugger
:source
2))
778 `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
779 (let ((f #'(lambda (x cont
)
780 (print x
(make-broadcast-stream))
783 (funcall cont
(1- x
) cont
)))))
790 "source: (ERROR \"~%foo\")"
794 "(FUNCALL CONT (1- X) CONT)"
797 (with-test (:name
(disassemble :high-debug-eval
))
798 (eval `(defun this-will-be-disassembled (x)
799 (declare (optimize debug
))
801 (let* ((oopses (make-string-output-stream))
803 (let ((*error-output
* oopses
))
804 (with-output-to-string (*standard-output
*)
805 (disassemble 'this-will-be-disassembled
)))))
806 (with-input-from-string (s disassembly
)
807 (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
809 (let ((problems (get-output-stream-string oopses
)))
810 (unless (zerop (length problems
))
813 (defun this-too-will-be-disasssembled (x)
814 (declare (optimize debug
))
817 (with-test (:name
(disassemble :high-debug-load
))
818 (let* ((oopses (make-string-output-stream))
820 (let ((*error-output
* oopses
))
821 (with-output-to-string (*standard-output
*)
822 (disassemble 'this-too-will-be-disasssembled
)))))
823 (with-input-from-string (s disassembly
)
824 (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
826 (let ((problems (get-output-stream-string oopses
)))
827 (unless (zerop (length problems
))
830 ;; The test named :GF-dispatch-backtrace depends on the fact that renaming
831 ;; a closure works, and that the debugger can extract a closure name.
832 ;; First things first: verify that a closure can be named.
833 (defun make-adder (x)
834 (sb-impl::set-closure-name
(lambda (y) (+ x y
)) `(adder ,x
)))
835 (with-test (:name
:closure-renaming-really-works
)
836 (let ((f1 (make-adder 5))
837 (expect "#<CLOSURE (ADDER 5)"))
838 (assert (= (mismatch (write-to-string (make-adder 5)) expect
)
840 (assert (and (eq (sb-impl::set-closure-name f1
"ADD5") f1
)
841 (string= (sb-impl::%fun-name f1
) "ADD5")))))
843 (defgeneric gf-dispatch-test
/gf
(x y
)
846 (defun gf-dispatch-test/f
(z)
847 (gf-dispatch-test/gf z
))
849 (with-test (:name
:gf-dispatch-backtrace
)
851 (gf-dispatch-test/gf
1 1)
852 ;; Wrong argument count
853 (assert (verify-backtrace (lambda () (gf-dispatch-test/f
42))
854 '(((sb-pcl::gf-dispatch gf-dispatch-test
/gf
) 42)))))
856 (with-test (:name
(:xep-arglist-clean-up
:bug-1192929
))
859 (handler-bind ((error (lambda (e)
861 (return (< (length (car (sb-debug:backtrace-as-list
1))) 10)))))
862 (funcall (compile nil
`(lambda (i) (declare ((mod 65536) i
)) i
)) nil
)))))
866 (defun print-backtrace-to-string/debug-print-variable-alist
(x)
868 (with-output-to-string (stream)
869 (let ((*debug-print-variable-alist
* '((*print-length
* .
5)
870 (*print-level
* .
3))))
871 (sb-debug:print-backtrace
:stream stream
:count
5)))
872 x
)) ; Force use of X to prevent flushing
874 (with-test (:name
(:print-frame-call
:respect
*debug-print-variable-alist
*
875 *print-length
* :bug-1261646
))
876 (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
(make-array 200)))
877 (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
878 (position (+ (search call printed
) (length call
))))
879 (assert (eql position
(search "#(0 0 0 0 0 ...)" printed
:start2 position
)))))
881 (with-test (:name
(:print-frame-call
:respect
*debug-print-variable-alist
*
882 *print-level
* :bug-1261646
))
883 (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
885 (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
886 (position (+ (search call printed
) (length call
))))
887 (assert (eql position
(search "((#))" printed
:start2 position
)))))
893 (with-test (:name
:trace-debug-arg
)
894 (trace foo
:print-after
(setf *x
* (sb-debug:arg
0)))
898 (trace foo
:print
(setf *x
* (sb-debug:arg
0)))
902 (trace foo
:condition
(eql (setf *x
* (sb-debug:arg
0)) 0))
906 (trace foo
:condition-after
(setf *x
* (sb-debug:arg
0)))
910 (trace foo
:break
(and (setf *x
* (sb-debug:arg
0)) nil
))
914 (trace foo
:break-all
(and (setf *x
* (sb-debug:arg
0)) nil
))
917 (trace foo
:break-after
(and (setf *x
* (sb-debug:arg
0)) nil
))
920 (defun frobbleize (arg) (sb-debug:print-backtrace
) 'win
)
921 (defmethod low-debug-method ((self t
))
922 (declare (optimize (debug 0)))
923 (frobbleize 'me
) ; make this not a tail call, so it remains on stack
925 (with-test (:name
:clean-fast-method-frame-lossage
)
926 (low-debug-method 42)) ; no need to assert. it either crashes or doesn't