X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fdebug.impure.lisp;h=94241bebb0eac4de6f830ab0c9be2dd5c23ce975;hb=ab5427d31da2bd95805cccc8e47b8f43d3dd606d;hp=74aec924926979178c6ae609fa9de07abaa32205;hpb=d27eb12b08a7eb445729bc339c9bedf0aeeaa4fa;p=sbcl.git

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 74aec92..94241be 100644
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -106,7 +106,6 @@
                                   (caar frame-specs)
                                   full-backtrace)
                           (setf result nil))
-
                         ;; check that we have all the frames we wanted
                         (mapcar
                          (lambda (spec frame)
@@ -173,6 +172,25 @@
                    (list '(flet not-optimized))
                    (list '(flet test) #'not-optimized))))))
 
+(with-test (:name :backtrace-interrupted-condition-wait
+            :skipped-on '(not :sb-thread)
+                  ;; For some unfathomable reason the backtrace becomes
+                  ;; stunted on Darwin, ending at _sigtramp, when we add
+                  ;; :TIMEOUT NIL to the frame we expect. If we leave it out,
+                  ;; the backtrace is fine -- but the test fails. I can only
+                  ;; boggle right now.
+            :fails-on :darwin)
+  (let ((m (sb-thread:make-mutex))
+        (q (sb-thread:make-waitqueue)))
+    (assert (verify-backtrace
+            (lambda ()
+              (sb-thread:with-mutex (m)
+                (handler-bind ((timeout (lambda (c)
+                                          (error "foo"))))
+                  (with-timeout 0.1
+                    (sb-thread:condition-wait q m)))))
+            `((sb-thread:condition-wait ,q ,m :timeout nil))))))
+
 ;;; Division by zero was a common error on PPC. It depended on the
 ;;; return function either being before INTEGER-/-INTEGER in memory,
 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
@@ -467,8 +485,12 @@
     (load (compile-file "bug-414.lisp"))
     (disassemble 'bug-414)))
 
-(with-test (:name :bug-310175)
-  (let ((dx-arg (cons t t)))
+(with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
+  ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
+  ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
+  ;; use two-arg-LIST, which should get through to VOP LIST, and thus
+  ;; stack-allocate on a predictable set of machines.
+  (let ((dx-arg (list t t)))
     (declare (dynamic-extent dx-arg))
     (flet ((dx-arg-backtrace (x)
              (declare (optimize (debug 2)))
@@ -541,5 +563,39 @@
 
 ;; unconditional, in case either previous left it enabled
 (disable-debugger)
+
+;;;; test some limitations of MAKE-LISP-OBJ
+
+;;; 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))
+  (sb-sys:without-gcing
+    (assert (eq #'identity
+                (sb-kernel:make-lisp-obj
+                 (sb-kernel:get-lisp-obj-address
+                  #'identity))))))
+
+;;; 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))
+  ;; 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
+  ;; object within an area of unboxed storage (a vector) in static
+  ;; space.  We'll make it a simple object, (CONS 0 0), which has an
+  ;; in-memory representation of two consecutive zero words.  We
+  ;; allocate a three-word vector so that we can guarantee a
+  ;; double-word aligned double-word of zeros no matter what happens
+  ;; with the vector-data-offset (currently double-word aligned).
+  (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
+                                            :initial-element 0))
+         (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
+         (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
+         (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
+    (multiple-value-bind
+          (object valid-p)
+        (sb-kernel:make-lisp-obj object-tagged-address nil)
+      (assert (not valid-p)))))
 
 (write-line "/debug.impure.lisp done")