Fix make-array transforms.

[sbcl.git] / tests / debug.impure.lisp

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index cfa16d6..33b3861 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -273,6 +273,44 @@
                             '(((flet bar :in bug-308926) 13)
                               (bug-308926 &rest t)))))
 
+;;; Test backtrace through assembly routines
+;;; :bug-800343
+(macrolet ((test (predicate fun
+                    &optional (two-arg
+                               (find-symbol (format nil "TWO-ARG-~A" fun)
+                                            "SB-KERNEL")))
+               (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
+                 `(flet ((,test-name (x y)
+                           ;; make sure it's not in tail position
+                           (list (,fun x y))))
+                    (with-test (:name (:bug-800343 ,fun))
+                      (assert (verify-backtrace
+                               (lambda ()
+                                 (eval `(funcall ,#',test-name 42 t)))
+                               '((,two-arg 42 t)
+                                 #+(or x86 x86-64)
+                                 ,@(and predicate
+                                    '(("no debug information for frame")))
+                                 ((flet ,test-name :in ,*p*) 42 t))))))))
+             (test-predicates (&rest functions)
+               `(progn ,@(mapcar (lambda (function)
+                                   (if (consp function)
+                                       `(test t ,@function)
+                                       `(test t ,function)))
+                                 functions)))
+             (test-functions (&rest functions)
+               `(progn ,@(mapcar (lambda (function)
+                                   (if (consp function)
+                                       `(test nil ,@function)
+                                       `(test nil ,function)))
+                                 functions))))
+    (test-predicates = < >)
+    (test-functions + - * /
+                    gcd lcm
+                    (logand sb-kernel:two-arg-and)
+                    (logior sb-kernel:two-arg-ior)
+                    (logxor sb-kernel:two-arg-xor)))
+
 ;;; test entry point handling in backtraces
 
 (defun oops ()
@@ -509,7 +547,7 @@
     (assert (search "TRACE-THIS" out))
     (assert (search "returned OK" out))))
 
-(with-test (:name (trace-recursive :encapsulate nil)
+(with-test (:name (:trace-recursive :encapsulate nil)
             :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos)
             :broken-on '(or :darwin (and :x86 :sunos)))
   (let ((out (with-output-to-string (*trace-output*)
@@ -584,7 +622,7 @@
     (format t "recursive condition: ~A~%" condition) (force-output)
     (error "recursive condition: ~A" condition)))
 
-(defun test-inifinite-error-protection ()
+(defun test-infinite-error-protection ()
   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
   ;; to halt, it produces so much garbage that's hard to suppress that
   ;; it is tested only once
@@ -602,14 +640,14 @@
                      :normal-exit)))))))
   (write-line "--END OF H-B-A-B--"))
 
-(with-test (:name infinite-error-protection)
+(with-test (:name :infinite-error-protection)
   (enable-debugger)
-  (test-inifinite-error-protection))
+  (test-infinite-error-protection))
 
-(with-test (:name (infinite-error-protection :thread)
+(with-test (:name (:infinite-error-protection :thread)
                   :skipped-on '(not :sb-thread))
   (enable-debugger)
-  (let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
+  (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
     (loop while (sb-thread:thread-alive-p thread))))
 
 ;; unconditional, in case either previous left it enabled
@@ -620,7 +658,7 @@
 ;;; Older GENCGC systems had a bug in the pointer validation used by
 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
 ;;; validate.
-(with-test (:name (make-lisp-obj :simple-funs))
+(with-test (:name (:make-lisp-obj :simple-funs))
   (sb-sys:without-gcing
     (assert (eq #'identity
                 (sb-kernel:make-lisp-obj
@@ -629,7 +667,7 @@
 
 ;;; Older CHENEYGC systems didn't perform any real pointer validity
 ;;; checks beyond "is this pointer to somewhere in heap space".
-(with-test (:name (make-lisp-obj :pointer-validation))
+(with-test (:name (:make-lisp-obj :pointer-validation))
   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
   ;; address, but we also need the GC to not pitch a fit if it sees an
   ;; object with said bogus address.  Thus, construct our known-bogus
@@ -785,4 +823,12 @@
   (assert (verify-backtrace (lambda () (gf-dispatch-test/f 42))
                             '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42)))))
 
+(with-test (:name (:xep-arglist-clean-up :bug-1192929))
+  (assert
+   (block nil
+     (handler-bind ((error (lambda (e)
+                             (declare (ignore e))
+                             (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
+       (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
+
 (write-line "/debug.impure.lisp done")