Really restore clisp cross-compilation.
[sbcl.git] / 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 (defvar *p* (namestring *load-truename*))
26
27 ;;; FIXME: This should use some get-argslist like functionality that
28 ;;; we actually export.
29 ;;;
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
42     ;;
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)
48     (t
49      #+sb-eval
50      (if (typep fun 'sb-eval::interpreted-function)
51          (sb-eval::interpreted-function-lambda-list fun)
52          :unknown)
53      #-sb-eval
54      :unknown)))
55
56 (defun zoop (zeep &key beep)
57   blurp)
58 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
59
60 ;;; Check some predefined functions too.
61 ;;;
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))))
78
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))
87                     t)
88                    ((endp want)
89                     (endp real))
90                    ((or (eq '? (car want)) (equal (car want) (car real)))
91                     (args-equal (cdr want) (cdr real)))
92                    (t
93                     nil))))
94     (let ((result nil))
95       (block outer-handler
96         (handler-bind
97             ((error (lambda (condition)
98                       ;; find the part of the backtrace we're interested in
99                       (let (full-backtrace)
100                         (sb-debug::map-backtrace
101                          (lambda (frame)
102                            (multiple-value-bind (name args info)
103                                (sb-debug::frame-call frame #+nil #+nil
104                                                            :replace-dynamic-extent-objects t)
105                              (if details
106                                  (push (list (cons name args) info) full-backtrace)
107                                  (push (cons name args) full-backtrace)))))
108
109                         (setf full-backtrace (nreverse full-backtrace))
110                         (let ((backtrace (if details
111                                              (member (caaar frame-specs)
112                                                      full-backtrace
113                                                      :key #'caar
114                                                      :test #'equal)
115                                              (member (caar frame-specs)
116                                                      full-backtrace
117                                                      :key #'car
118                                                      :test #'equal))))
119
120                           (setf result condition)
121
122                           (unless backtrace
123                             (format t "~&//~S not in backtrace:~%   ~S~%"
124                                     (caar frame-specs)
125                                     full-backtrace)
126                             (setf result nil))
127                           ;; check that we have all the frames we wanted
128                           (mapcar
129                            (lambda (spec frame)
130                              (unless (or (not spec)
131                                          (if details
132                                              (handler-case
133                                                  (and (args-equal (car spec)
134                                                                   (car frame))
135                                                       (equal (cdr spec) (cdr frame)))
136                                                (error (e)
137                                                  (print (list :spec spec :frame frame))
138                                                  (error e)))
139                                              (and (equal (car spec) (car frame))
140                                                   (args-equal (cdr spec)
141                                                               (cdr frame)))))
142                                (print (list :wanted spec :got frame))
143                                (setf result nil)))
144                            frame-specs
145                            backtrace)
146
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))
154                                         backtrace
155                                         :test #'equal)
156                             (print (list :backtrace-stunted backtrace))
157                             (setf result nil))
158                           (return-from outer-handler))))))
159           (funcall test-function)))
160       result)))
161
162 (defvar *undefined-function-frame*
163   ;; bug 353
164   '("undefined function"))
165
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.)
170 (flet ((optimized ()
171          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
172          (#:undefined-function 42))
173        (not-optimized ()
174          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
175          (#:undefined-function 42))
176        (test (fun)
177          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
178          (funcall fun)))
179
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                           (and :x86-64 :freebsd)))
187     (assert (verify-backtrace
188              (lambda () (test #'optimized))
189              (list *undefined-function-frame*
190                    (list `(flet test :in ,*p*) #'optimized)))))
191
192   ;; bug 353: This test fails at least most of the time for x86/linux
193   ;; ca. 0.8.20.16. -- WHN
194   (with-test (:name (:undefined-function :bug-353))
195     (assert (verify-backtrace
196              (lambda () (test #'not-optimized))
197              (list *undefined-function-frame*
198                    (list `(flet not-optimized :in ,*p*))
199                    (list `(flet test :in ,*p*) #'not-optimized))))))
200
201 (with-test (:name :backtrace-interrupted-condition-wait
202             :skipped-on '(not :sb-thread)
203                   ;; For some unfathomable reason the backtrace becomes
204                   ;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to
205                   ;; the frame we expect. If we leave it out, the backtrace is
206                   ;; fine -- but the test fails. I can only boggle right now.
207             :fails-on `(or (and :x86 :linux)
208                            :win32))
209   (let ((m (sb-thread:make-mutex))
210         (q (sb-thread:make-waitqueue)))
211     (assert (verify-backtrace
212              (lambda ()
213               (sb-thread:with-mutex (m)
214                 (handler-bind ((timeout (lambda (c)
215                                           (error "foo"))))
216                   (with-timeout 0.1
217                     (sb-thread:condition-wait q m)))))
218             `((sb-thread:condition-wait ,q ,m :timeout nil))))))
219
220 ;;; Division by zero was a common error on PPC. It depended on the
221 ;;; return function either being before INTEGER-/-INTEGER in memory,
222 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
223 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
224 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
225 ;;; if SBCL does the same this test is probably not good for the
226 ;;; Sparc.
227 ;;;
228 ;;; Disabling tail call elimination on this will probably ensure that
229 ;;; the return value (to the flet or the enclosing top level form) is
230 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
231 ;;; Enabling it might catch other problems, so do it anyway.
232 (flet ((optimized ()
233          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
234          (/ 42 0))
235        (not-optimized ()
236          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
237          (/ 42 0))
238        (test (fun)
239          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
240          (funcall fun)))
241   (with-test (:name (:divide-by-zero :bug-346)
242               :fails-on :alpha)  ; bug 346
243     (assert (verify-backtrace (lambda () (test #'optimized))
244                               (list '(/ 42 &rest)
245                                     (list `(flet test :in ,*p*) #'optimized)))))
246   (with-test (:name (:divide-by-zero :bug-356)
247               :fails-on :alpha)  ; bug 356
248     (assert (verify-backtrace (lambda () (test #'not-optimized))
249                               (list '(/ 42 &rest)
250                                     `((flet not-optimized :in ,*p*))
251                                     (list `(flet test :in ,*p*) #'not-optimized))))))
252
253 (with-test (:name (:throw :no-such-tag)
254             :fails-on '(or
255                         (and :sparc :linux)
256                         :alpha
257                         :mips))
258   (progn
259     (defun throw-test ()
260       (throw 'no-such-tag t))
261     (assert (verify-backtrace #'throw-test '((throw-test))))))
262
263 (defun bug-308926 (x)
264   (let ((v "foo"))
265     (flet ((bar (z)
266              (oops v z)
267              (oops z v)))
268       (bar x)
269       (bar v))))
270
271 (with-test (:name :bug-308926)
272   (assert (verify-backtrace (lambda () (bug-308926 13))
273                             '(((flet bar :in bug-308926) 13)
274                               (bug-308926 &rest t)))))
275
276 ;;; Test backtrace through assembly routines
277 ;;; :bug-800343
278 (macrolet ((test (predicate fun
279                     &optional (two-arg
280                                (find-symbol (format nil "TWO-ARG-~A" fun)
281                                             "SB-KERNEL")))
282                (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
283                  `(flet ((,test-name (x y)
284                            ;; make sure it's not in tail position
285                            (list (,fun x y))))
286                     (with-test (:name (:bug-800343 ,fun))
287                       (assert (verify-backtrace
288                                (lambda ()
289                                  (eval `(funcall ,#',test-name 42 t)))
290                                '((,two-arg 42 t)
291                                  #+(or x86 x86-64)
292                                  ,@(and predicate
293                                     '(("no debug information for frame")))
294                                  ((flet ,test-name :in ,*p*) 42 t))))))))
295              (test-predicates (&rest functions)
296                `(progn ,@(mapcar (lambda (function)
297                                    (if (consp function)
298                                        `(test t ,@function)
299                                        `(test t ,function)))
300                                  functions)))
301              (test-functions (&rest functions)
302                `(progn ,@(mapcar (lambda (function)
303                                    (if (consp function)
304                                        `(test nil ,@function)
305                                        `(test nil ,function)))
306                                  functions))))
307     (test-predicates = < >)
308     (test-functions + - * /
309                     gcd lcm
310                     (logand sb-kernel:two-arg-and)
311                     (logior sb-kernel:two-arg-ior)
312                     (logxor sb-kernel:two-arg-xor)))
313
314 ;;; test entry point handling in backtraces
315
316 (defun oops ()
317   (error "oops"))
318
319 (with-test (:name :xep-too-many-arguments)
320   (assert (verify-backtrace (lambda () (oops 1 2 3 4 5 6))
321                             '((oops ? ? ? ? ? ?)))))
322
323 (defmacro defbt (n ll &body body)
324   ;; WTF is this? This is a way to make these tests not depend so much on the
325   ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
326   ;; slightly smarter, which meant that things which used to have xeps
327   ;; suddently had tl-xeps, etc. This takes care of that.
328   `(funcall
329     (compile nil
330              '(lambda ()
331                (progn
332                  ;; normal debug info
333                  (defun ,(intern (format nil "BT.~A.1" n)) ,ll
334                    ,@body)
335                  ;; no arguments saved
336                  (defun ,(intern (format nil "BT.~A.2" n)) ,ll
337                    (declare (optimize (debug 1) (speed 3)))
338                    ,@body)
339                  ;; no lambda-list saved
340                  (defun ,(intern (format nil "BT.~A.3" n)) ,ll
341                    (declare (optimize (debug 0)))
342                    ,@body))))))
343
344 (defbt 1 (&key key)
345   (list key))
346
347 (defbt 2 (x)
348   (list x))
349
350 (defbt 3 (&key (key (oops)))
351   (list key))
352
353 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
354 (defbt 4 (&optional opt)
355   (list (error "error")))
356
357 (defbt 5 (&optional (opt (oops)))
358   (list opt))
359
360 (defun bug-354 (x)
361   (error "XEPs in backtraces: ~S" x))
362
363 (with-test (:name :bug-354)
364   (assert (not (verify-backtrace (lambda () (bug-354 354))
365                                  '((bug-354 354)
366                                    (((bug-354 &rest) (:tl :external)) 354)))))
367   (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
368
369 ;;; FIXME: This test really should be broken into smaller pieces
370 (with-test (:name (:backtrace :tl-xep))
371   (assert (verify-backtrace #'namestring
372                             '(((namestring) (:tl :external)))
373                             :details t))
374   (assert (verify-backtrace #'namestring
375                             '((namestring)))))
376
377 (with-test (:name (:backtrace :more-processor))
378   (assert (verify-backtrace (lambda () (bt.1.1 :key))
379                             '(((bt.1.1 :key) (:more :optional)))
380                             :details t))
381   (assert (verify-backtrace (lambda () (bt.1.2 :key))
382                             '(((bt.1.2 ?) (:more :optional)))
383                             :details t))
384   (assert (verify-backtrace (lambda () (bt.1.3 :key))
385                             '(((bt.1.3 &rest) (:more :optional)))
386                             :details t))
387   (assert (verify-backtrace (lambda () (bt.1.1 :key))
388                             '((bt.1.1 :key))))
389   (assert (verify-backtrace (lambda () (bt.1.2 :key))
390                             '((bt.1.2 &rest))))
391   (assert (verify-backtrace (lambda () (bt.1.3 :key))
392                             '((bt.1.3 &rest)))))
393
394 (with-test (:name (:backtrace :xep))
395   (assert (verify-backtrace #'bt.2.1
396                             '(((bt.2.1) (:external)))
397                             :details t))
398   (assert (verify-backtrace #'bt.2.2
399                             '(((bt.2.2 &rest) (:external)))
400                             :details t))
401   (assert (verify-backtrace #'bt.2.3
402                             '(((bt.2.3 &rest) (:external)))
403                             :details t))
404   (assert (verify-backtrace #'bt.2.1
405                             '((bt.2.1))))
406   (assert (verify-backtrace #'bt.2.2
407                             '((bt.2.2 &rest))))
408   (assert (verify-backtrace #'bt.2.3
409                             '((bt.2.3 &rest)))))
410
411 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
412 ;;; these functions used to have sb-c::varargs-entry debug names for their
413 ;;; main lambda.
414 (with-test (:name (:backtrace :varargs-entry))
415   (assert (verify-backtrace #'bt.3.1
416                             '((bt.3.1 :key nil))))
417   (assert (verify-backtrace #'bt.3.2
418                             '((bt.3.2 :key ?))))
419   (assert (verify-backtrace #'bt.3.3
420                             '((bt.3.3 &rest))))
421   (assert (verify-backtrace #'bt.3.1
422                             '((bt.3.1 :key nil))))
423   (assert (verify-backtrace #'bt.3.2
424                             '((bt.3.2 :key ?))))
425   (assert (verify-backtrace #'bt.3.3
426                             '((bt.3.3 &rest)))))
427
428 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
429 ;;; these functions used to have sb-c::hairy-args-processor debug names for
430 ;;; their main lambda.
431 (with-test (:name (:backtrace :hairy-args-processor))
432   (assert (verify-backtrace #'bt.4.1
433                             '((bt.4.1 ?))))
434   (assert (verify-backtrace #'bt.4.2
435                             '((bt.4.2 ?))))
436   (assert (verify-backtrace #'bt.4.3
437                             '((bt.4.3 &rest))))
438   (assert (verify-backtrace #'bt.4.1
439                             '((bt.4.1 ?))))
440   (assert (verify-backtrace #'bt.4.2
441                             '((bt.4.2 ?))))
442   (assert (verify-backtrace #'bt.4.3
443                             '((bt.4.3 &rest)))))
444
445
446 (with-test (:name (:backtrace :optional-processor))
447   (assert (verify-backtrace #'bt.5.1
448                             '(((bt.5.1) (:optional)))
449                             :details t))
450   (assert (verify-backtrace #'bt.5.2
451                             '(((bt.5.2 &rest) (:optional)))
452                             :details t))
453   (assert (verify-backtrace #'bt.5.3
454                             '(((bt.5.3 &rest) (:optional)))
455                             :details t))
456   (assert (verify-backtrace #'bt.5.1
457                             '((bt.5.1))))
458   (assert (verify-backtrace #'bt.5.2
459                             '((bt.5.2 &rest))))
460   (assert (verify-backtrace #'bt.5.3
461                             '((bt.5.3 &rest)))))
462
463 (write-line "//compile nil")
464 (defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
465 (defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil))))
466 (with-test (:name (:compile nil))
467   (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
468                             `(((lambda (x) :in ,*p*) 13)
469                               ((lambda (y) :in ,*p*) 13)))))
470
471 (with-test (:name :clos-slot-typecheckfun-named)
472   (assert
473    (verify-backtrace
474     (lambda ()
475       (eval `(locally (declare (optimize safety))
476                (defclass clos-typecheck-test ()
477                  ((slot :type fixnum)))
478                (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
479     '(((sb-pcl::slot-typecheck fixnum) t)))))
480
481 (with-test (:name :clos-emf-named)
482   (assert
483    (verify-backtrace
484     (lambda ()
485       (eval `(progn
486                (defmethod clos-emf-named-test ((x symbol)) x)
487                (defmethod clos-emf-named-test :before (x) (assert x))
488                (clos-emf-named-test nil))))
489     '(((sb-pcl::emf clos-emf-named-test) ? ? nil)))))
490
491 (with-test (:name :bug-310173)
492   (flet ((make-fun (n)
493            (let* ((names '(a b))
494                   (req (loop repeat n collect (pop names))))
495              (compile nil
496                       `(lambda (,@req &rest rest)
497                          (let ((* *)) ; no tail-call
498                            (apply '/ ,@req rest)))))))
499     (assert
500      (verify-backtrace (lambda ()
501                          (funcall (make-fun 0) 10 11 0))
502                        `((sb-kernel:two-arg-/ 10/11 0)
503                          (/ 10 11 0)
504                          ((lambda (&rest rest) :in ,*p*) 10 11 0))))
505     (assert
506      (verify-backtrace (lambda ()
507                          (funcall (make-fun 1) 10 11 0))
508                        `((sb-kernel:two-arg-/ 10/11 0)
509                          (/ 10 11 0)
510                          ((lambda (a &rest rest) :in ,*p*) 10 11 0))))
511     (assert
512      (verify-backtrace (lambda ()
513                          (funcall (make-fun 2) 10 11 0))
514                        `((sb-kernel:two-arg-/ 10/11 0)
515                          (/ 10 11 0)
516                          ((lambda (a b &rest rest) :in ,*p*) 10 11 0))))))
517
518 ;;;; test TRACE
519
520 (defun trace-this ()
521   'ok)
522
523 (defun trace-fact (n)
524   (if (zerop n)
525       1
526       (* n (trace-fact (1- n)))))
527
528 (with-test (:name (trace :simple))
529   (let ((out (with-output-to-string (*trace-output*)
530                (trace trace-this)
531                (assert (eq 'ok (trace-this)))
532                (untrace))))
533     (assert (search "TRACE-THIS" out))
534     (assert (search "returned OK" out))))
535
536 ;;; bug 379
537 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
538 ;;; suspicions that the breakpoint trace might corrupt the whole image
539 ;;; on that platform.
540 (with-test (:name (trace :encapsulate nil)
541             :fails-on '(or (and :ppc (not :linux)) :sparc :mips)
542             :broken-on '(or :darwin :sunos))
543   (let ((out (with-output-to-string (*trace-output*)
544                (trace trace-this :encapsulate nil)
545                (assert (eq 'ok (trace-this)))
546                (untrace))))
547     (assert (search "TRACE-THIS" out))
548     (assert (search "returned OK" out))))
549
550 (with-test (:name (:trace-recursive :encapsulate nil)
551             :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos)
552             :broken-on '(or :darwin (and :x86 :sunos)))
553   (let ((out (with-output-to-string (*trace-output*)
554                (trace trace-fact :encapsulate nil)
555                (assert (= 120 (trace-fact 5)))
556                (untrace))))
557     (assert (search "TRACE-FACT" out))
558     (assert (search "returned 1" out))
559     (assert (search "returned 120" out))))
560
561 (defun trace-and-fmakunbound-this (x)
562   x)
563
564 (with-test (:name :bug-667657)
565   (trace trace-and-fmakunbound-this)
566   (fmakunbound 'trace-and-fmakunbound-this)
567   (untrace)
568   (assert (not (trace))))
569
570 (with-test (:name :bug-414)
571   (handler-bind ((warning #'error))
572     (load (compile-file "bug-414.lisp"))
573     (disassemble 'bug-414)))
574
575 (with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
576   ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
577   ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
578   ;; use two-arg-LIST, which should get through to VOP LIST, and thus
579   ;; stack-allocate on a predictable set of machines.
580   (let ((dx-arg (list t t)))
581     (declare (dynamic-extent dx-arg))
582     (flet ((dx-arg-backtrace (x)
583              (declare (optimize (debug 2)))
584              (prog1 (sb-debug:list-backtrace :count 10)
585                (assert (sb-debug::stack-allocated-p x)))))
586       (declare (notinline dx-arg-backtrace))
587       (assert (member-if (lambda (frame)
588                            (and (consp frame)
589                                 (consp (car frame))
590                                 (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
591                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
592                          (dx-arg-backtrace dx-arg))))))
593
594 (with-test (:name :bug-795245)
595   (assert
596    (eq :ok
597        (catch 'done
598          (handler-bind
599              ((error (lambda (e)
600                        (declare (ignore e))
601                        (handler-case
602                            (sb-debug:print-backtrace :count 100
603                                                      :stream (make-broadcast-stream))
604                          (error ()
605                            (throw 'done :error))
606                          (:no-error ()
607                            (throw 'done :ok))))))
608            (apply '/= nil 1 2 nil))))))
609
610 ;;;; test infinite error protection
611
612 (defmacro nest-errors (n-levels error-form)
613   (if (< 0 n-levels)
614       `(handler-bind ((error (lambda (condition)
615                                (declare (ignore condition))
616                                ,error-form)))
617         (nest-errors ,(1- n-levels) ,error-form))
618       error-form))
619
620 (defun erroring-debugger-hook (condition old-debugger-hook)
621   (let ((*debugger-hook* old-debugger-hook))
622     (format t "recursive condition: ~A~%" condition) (force-output)
623     (error "recursive condition: ~A" condition)))
624
625 (defun test-infinite-error-protection ()
626   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
627   ;; to halt, it produces so much garbage that's hard to suppress that
628   ;; it is tested only once
629   (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
630   (let ((*debugger-hook* #'erroring-debugger-hook))
631     (loop repeat 1 do
632           (let ((error-counter 0)
633                 (*terminal-io* (make-broadcast-stream)))
634             (assert
635              (not (eq
636                    :normal-exit
637                    (catch 'sb-impl::toplevel-catcher
638                      (nest-errors 20 (error "infinite error ~s"
639                                             (incf error-counter)))
640                      :normal-exit)))))))
641   (write-line "--END OF H-B-A-B--"))
642
643 (with-test (:name :infinite-error-protection)
644   (enable-debugger)
645   (test-infinite-error-protection))
646
647 (with-test (:name (:infinite-error-protection :thread)
648                   :skipped-on '(not :sb-thread))
649   (enable-debugger)
650   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
651     (loop while (sb-thread:thread-alive-p thread))))
652
653 ;; unconditional, in case either previous left it enabled
654 (disable-debugger)
655 \f
656 ;;;; test some limitations of MAKE-LISP-OBJ
657
658 ;;; Older GENCGC systems had a bug in the pointer validation used by
659 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
660 ;;; validate.
661 (with-test (:name (:make-lisp-obj :simple-funs))
662   (sb-sys:without-gcing
663     (assert (eq #'identity
664                 (sb-kernel:make-lisp-obj
665                  (sb-kernel:get-lisp-obj-address
666                   #'identity))))))
667
668 ;;; Older CHENEYGC systems didn't perform any real pointer validity
669 ;;; checks beyond "is this pointer to somewhere in heap space".
670 (with-test (:name (:make-lisp-obj :pointer-validation))
671   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
672   ;; address, but we also need the GC to not pitch a fit if it sees an
673   ;; object with said bogus address.  Thus, construct our known-bogus
674   ;; object within an area of unboxed storage (a vector) in static
675   ;; space.  We'll make it a simple object, (CONS 0 0), which has an
676   ;; in-memory representation of two consecutive zero words.  We
677   ;; allocate a three-word vector so that we can guarantee a
678   ;; double-word aligned double-word of zeros no matter what happens
679   ;; with the vector-data-offset (currently double-word aligned).
680   (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
681                                             :initial-element 0))
682          (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
683          (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
684          (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
685     (multiple-value-bind (object valid-p)
686         (sb-kernel:make-lisp-obj object-tagged-address nil)
687       (declare (ignore object))
688       (assert (not valid-p)))))
689
690 (defun test-debugger (control form &rest targets)
691   (let ((out (make-string-output-stream))
692         (oops t))
693     (unwind-protect
694          (progn
695            (with-simple-restart (debugger-test-done! "Debugger Test Done!")
696              (let* ((*debug-io* (make-two-way-stream
697                                  (make-string-input-stream control)
698                                  (make-broadcast-stream out #+nil *standard-output*)))
699                     ;; Initial announcement goes to *ERROR-OUTPUT*
700                     (*error-output* *debug-io*)
701                     (*invoke-debugger-hook* nil))
702                (handler-bind ((error #'invoke-debugger))
703                  (eval form))))
704            (setf oops nil))
705       (when oops
706         (error "Uncontrolled unwind from debugger test.")))
707     ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
708     ;; it could swallow our asserts!
709     (with-input-from-string (s (get-output-stream-string out))
710       (loop for line = (read-line s nil)
711             while line
712             do (assert targets)
713                #+nil
714                (format *error-output* "Got: ~A~%" line)
715                (let ((match (pop targets)))
716                  (if (eq '* match)
717                      ;; Whatever, till the next line matches.
718                      (let ((text (pop targets)))
719                        #+nil
720                        (format *error-output* "Looking for: ~A~%" text)
721                        (unless (search text line)
722                          (push text targets)
723                          (push match targets)))
724                      (unless (search match line)
725                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
726                        (setf oops t))))))
727     ;; Check that we saw everything we wanted
728     (when targets
729       (error "Missed: ~S" targets))
730     (assert (not oops))))
731
732 (with-test (:name (:debugger :source 1))
733   (test-debugger
734    "d
735     source 0
736     debugger-test-done!"
737    `(progn
738       (defun this-will-break (x)
739                (declare (optimize debug))
740                (let* ((y (- x x))
741                       (z (/ x y)))
742                  (+ x z)))
743       (this-will-break 1))
744    '*
745    "debugger invoked"
746    '*
747    "DIVISION-BY-ZERO"
748    "operands (1 0)"
749    '*
750    "INTEGER-/-INTEGER"
751    "(THIS-WILL-BREAK 1)"
752    "1]"
753    "(/ X Y)"
754    "1]"))
755
756 (with-test (:name (:debugger :source 2))
757   (test-debugger
758    "d
759     source 0
760     debugger-test-done!"
761    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
762       (let ((f #'(lambda (x cont)
763                    (print x (make-broadcast-stream))
764                    (if (zerop x)
765                        (error "~%foo")
766                        (funcall cont (1- x) cont)))))
767         (funcall f 10 f)))
768    '*
769    "debugger"
770    '*
771    "foo"
772    '*
773    "source: (ERROR \"~%foo\")"
774    '*
775    "(LAMBDA (X CONT)"
776    '*
777    "(FUNCALL CONT (1- X) CONT)"
778    "1]"))
779
780 (with-test (:name (disassemble :high-debug-eval))
781   (eval `(defun this-will-be-disassembled (x)
782            (declare (optimize debug))
783            (+ x x)))
784   (let* ((oopses (make-string-output-stream))
785          (disassembly
786            (let ((*error-output* oopses))
787              (with-output-to-string (*standard-output*)
788                (disassemble 'this-will-be-disassembled)))))
789     (with-input-from-string (s disassembly)
790       (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
791                       (read-line s))))
792     (let ((problems (get-output-stream-string oopses)))
793       (unless (zerop (length problems))
794         (error problems)))))
795
796 (defun this-too-will-be-disasssembled (x)
797   (declare (optimize debug))
798   (+ x x))
799
800 (with-test (:name (disassemble :high-debug-load))
801   (let* ((oopses (make-string-output-stream))
802          (disassembly
803            (let ((*error-output* oopses))
804              (with-output-to-string (*standard-output*)
805                (disassemble 'this-too-will-be-disasssembled)))))
806     (with-input-from-string (s disassembly)
807       (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
808                      (read-line s))))
809     (let ((problems (get-output-stream-string oopses)))
810       (unless (zerop (length problems))
811         (error problems)))))
812
813 (defgeneric gf-dispatch-test/gf (x y)
814   (:method (x y)
815     (+ x y)))
816 (defun gf-dispatch-test/f (z)
817   (gf-dispatch-test/gf z))
818
819 (with-test (:name :gf-dispatch-backtrace)
820   ;; Fill the cache
821   (gf-dispatch-test/gf 1 1)
822   ;; Wrong argument count
823   (assert (verify-backtrace (lambda () (gf-dispatch-test/f 42))
824                             '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42)))))
825
826 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
827   (assert
828    (block nil
829      (handler-bind ((error (lambda (e)
830                              (declare (ignore e))
831                              (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
832        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
833
834 (write-line "/debug.impure.lisp done")