X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fstep.impure.lisp;h=9b48dc2214b7c044a3a20409cbaf84cc7493a1b2;hb=587c903b0601dfd6763b5acc05778f793172c915;hp=f02f148d512d3c5c8b27feb0bed313aefef782d8;hpb=b66385e2031fc2cac17dd129df0af400beb48a22;p=sbcl.git

diff --git a/tests/step.impure.lisp b/tests/step.impure.lisp
index f02f148..9b48dc2 100644
--- a/tests/step.impure.lisp
+++ b/tests/step.impure.lisp
@@ -14,8 +14,8 @@
 (in-package :cl-user)
 
 ;; No stepper support on some platforms.
-#-(or x86 x86-64 ppc)
-(sb-ext:quit :unix-status 104)
+#-(or x86 x86-64 ppc sparc mips)
+(sb-ext:exit :code 104)
 
 (defun fib (x)
   (declare (optimize debug))
@@ -26,34 +26,61 @@
 
 (defvar *cerror-called* nil)
 
+(define-condition cerror-break (error) ())
+
 (defun fib-break (x)
   (declare (optimize debug))
   (if (< x 2)
       (progn
         (unless *cerror-called*
-          (cerror "a" "b")
+          (cerror "a" 'cerror-break)
           (setf *cerror-called* t))
         1)
       (+ (fib-break (1- x))
          (fib-break (- x 2)))))
 
+(defun in ()
+  (declare (optimize debug))
+  (print 1)
+  (print 2)
+  (print 3)
+  (print 4))
+
+(defun out ()
+  (declare (optimize debug))
+  (in))
+
 (defun test-step-into ()
   (let* ((results nil)
-         (expected '(("(< X 2)" :unknown)
-                     ("(- X 1)" :unknown)
-                     ("(FIB (1- X))" (2))
-                     ("(< X 2)" :unknown)
-                     ("(- X 1)" :unknown)
-                     ("(FIB (1- X))" (1))
-                     ("(< X 2)" :unknown)
-                     ("(- X 2)" :unknown)
-                     ("(FIB (- X 2))" (0))
-                     ("(< X 2)" :unknown)
-                     ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
-                     ("(- X 2)" :unknown)
-                     ("(FIB (- X 2))" (1))
-                     ("(< X 2)" :unknown)
-                     ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+         ;; The generic-< VOP on x86oids doesn't emit a full call
+         (expected
+          #-(or x86 x86-64)
+           '(("(< X 2)" :unknown)
+             ("(- X 1)" :unknown)
+             ("(FIB (1- X))" (2))
+             ("(< X 2)" :unknown)
+             ("(- X 1)" :unknown)
+             ("(FIB (1- X))" (1))
+             ("(< X 2)" :unknown)
+             ("(- X 2)" :unknown)
+             ("(FIB (- X 2))" (0))
+             ("(< X 2)" :unknown)
+             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+             ("(- X 2)" :unknown)
+             ("(FIB (- X 2))" (1))
+             ("(< X 2)" :unknown)
+             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
+           #+(or x86 x86-64)
+           '(("(- X 1)" :unknown)
+             ("(FIB (1- X))" (2))
+             ("(- X 1)" :unknown)
+             ("(FIB (1- X))" (1))
+             ("(- X 2)" :unknown)
+             ("(FIB (- X 2))" (0))
+             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+             ("(- X 2)" :unknown)
+             ("(FIB (- X 2))" (1))
+             ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
          (*stepper-hook* (lambda (condition)
                            (typecase condition
                              (step-form-condition
@@ -66,18 +93,31 @@
 
 (defun test-step-next ()
   (let* ((results nil)
-         (expected '(("(< X 2)" :unknown)
-                     ("(- X 1)" :unknown)
-                     ("(FIB (1- X))" (2))
-                     ("(< X 2)" :unknown)
-                     ("(- X 1)" :unknown)
-                     ("(FIB (1- X))" (1))
-                     ("(- X 2)" :unknown)
-                     ("(FIB (- X 2))" (0))
-                     ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
-                     ("(- X 2)" :unknown)
-                     ("(FIB (- X 2))" (1))
-                     ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+         (expected
+          #-(or x86 x86-64)
+          '(("(< X 2)" :unknown)
+            ("(- X 1)" :unknown)
+            ("(FIB (1- X))" (2))
+            ("(< X 2)" :unknown)
+            ("(- X 1)" :unknown)
+            ("(FIB (1- X))" (1))
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (0))
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (1))
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
+          #+(or x86 x86-64)
+          '(("(- X 1)" :unknown)
+            ("(FIB (1- X))" (2))
+            ("(- X 1)" :unknown)
+            ("(FIB (1- X))" (1))
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (0))
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (1))
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
          (count 0)
          (*stepper-hook* (lambda (condition)
                            (typecase condition
@@ -93,14 +133,24 @@
 
 (defun test-step-out ()
   (let* ((results nil)
-         (expected '(("(< X 2)" :unknown)
-                     ("(- X 1)" :unknown)
-                     ("(FIB (1- X))" (2))
-                     ("(< X 2)" :unknown)
-                     ("(- X 2)" :unknown)
-                     ("(FIB (- X 2))" (1))
-                     ("(< X 2)" :unknown)
-                     ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+         (expected
+          #-(or x86 x86-64)
+          '(("(< X 2)" :unknown)
+            ("(- X 1)" :unknown)
+            ("(FIB (1- X))" (2))
+            ("(< X 2)" :unknown)
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (1))
+            ("(< X 2)" :unknown)
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown))
+          #+(or x86 x86-64)
+          '(("(- X 1)" :unknown)
+            ("(FIB (1- X))" (2))
+            ("(- X 1)" :unknown)
+            ("(FIB (1- X))" (1))
+            ("(- X 2)" :unknown)
+            ("(FIB (- X 2))" (1))
+            ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
          (count 0)
          (*stepper-hook* (lambda (condition)
                            (typecase condition
@@ -116,14 +166,23 @@
 
 (defun test-step-start-from-break ()
   (let* ((results nil)
-         (expected '(("(- X 2)" :unknown)
-                     ("(FIB-BREAK (- X 2))" (0))
-                     ("(< X 2)" :unknown)
-                     ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
-                     ("(- X 2)" :unknown)
-                     ("(FIB-BREAK (- X 2))" (1))
-                     ("(< X 2)" :unknown)
-                     ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
+         (expected
+          #-(or x86 x86-64)
+          '(("(- X 2)" :unknown)
+            ("(FIB-BREAK (- X 2))" (0))
+            ("(< X 2)" :unknown)
+            ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
+            ("(- X 2)" :unknown)
+            ("(FIB-BREAK (- X 2))" (1))
+            ("(< X 2)" :unknown)
+            ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown))
+          #+(or x86 x86-64)
+          '(("(- X 2)" :unknown)
+            ("(FIB-BREAK (- X 2))" (0))
+            ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
+            ("(- X 2)" :unknown)
+            ("(FIB-BREAK (- X 2))" (1))
+            ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
          (count 0)
          (*stepper-hook* (lambda (condition)
                            (typecase condition
@@ -133,7 +192,7 @@
                                     results)
                               (invoke-restart 'step-into))))))
     (setf *cerror-called* nil)
-    (handler-bind ((error
+    (handler-bind ((cerror-break
                     (lambda (c)
                       (sb-impl::enable-stepping)
                       (invoke-restart 'continue))))
@@ -149,9 +208,10 @@
                                      (dfun (sb-di::frame-debug-fun frame))
                                      (name (sb-di::debug-fun-name dfun)))
                                 (assert (equal name 'fib))
-                                (incf count)))))))
+                                (incf count)
+                                (invoke-restart 'step-next)))))))
     (step (fib 3))
-    (assert (= count 6))))
+    (assert (= count #-(or x86 x86-64) 6 #+(or x86 x86-64) 5))))
 
 (defun test-step-backtrace ()
   (let* ((*stepper-hook* (lambda (condition)
@@ -161,20 +221,73 @@
                                 (backtrace)))))))
     (step (fib 3))))
 
-(handler-bind ((step-condition (lambda (c)
-                                 (funcall *stepper-hook* c))))
-  (with-test (:name :step-into)
-    (test-step-into))
-  (with-test (:name :step-next)
-    (test-step-next))
-  (with-test (:name :step-out)
-    (test-step-out))
-  (with-test (:name :step-start-from-break)
-    (test-step-start-from-break))
-  (with-test (:name :step-frame)
-    (test-step-frame))
-  (with-test (:name :step-backtrace)
+(defun test-step-next/2 ()
+  (let* ((results nil)
+         (expected '(("(IN)" ())
+                     ("(PRINT 1)" (1))
+                     ("(PRINT 2)" (2))
+                     ("(PRINT 3)" (3))
+                     ("(PRINT 4)" (4))))
+         (count 0)
+         (*stepper-hook* (lambda (condition)
+                           (typecase condition
+                             (step-form-condition
+                              (push (list (step-condition-form condition)
+                                          (step-condition-args condition))
+                                    results)
+                              (if (>= (incf count) 3)
+                                  (invoke-restart 'step-into)
+                                  (invoke-restart 'step-into)))))))
+    (step (out))
+    (assert (equal expected (reverse results)))))
+
+(defun test-step-out/2 ()
+  (let* ((results nil)
+         (expected '(("(IN)" ())
+                     ("(PRINT 1)" (1))
+                     ("(PRINT 2)" (2))))
+         (count 0)
+         (*stepper-hook* (lambda (condition)
+                           (typecase condition
+                             (step-form-condition
+                              (push (list (step-condition-form condition)
+                                          (step-condition-args condition))
+                                    results)
+                              (if (>= (incf count) 3)
+                                  (invoke-restart 'step-out)
+                                  (invoke-restart 'step-into)))))))
+    (step (out))
+    (assert (equal expected (reverse results)))))
+
+(with-test (:name :step-into)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-into)))
+
+(with-test (:name :step-next)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+      (test-step-next)))
+
+(with-test (:name :step-out)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-out)))
+
+(with-test (:name :step-start-from-break)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-start-from-break)))
+
+(with-test (:name :step-frame)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-frame)))
+
+(with-test (:name :step-backtrace)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
     (test-step-backtrace)))
 
+(with-test (:name :step-next/2)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-next/2)))
 
+(with-test (:name :step-out/2)
+  (handler-bind ((step-condition #'sb-impl::invoke-stepper))
+    (test-step-out/2)))