(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))
(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
(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
(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
(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
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))))
(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)
(backtrace)))))))
(step (fib 3))))
+(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 (lambda (c)
- (funcall *stepper-hook* c))))
+ (handler-bind ((step-condition #'sb-impl::invoke-stepper))
(test-step-into)))
(with-test (:name :step-next)
- (handler-bind ((step-condition (lambda (c)
- (funcall *stepper-hook* c))))
+ (handler-bind ((step-condition #'sb-impl::invoke-stepper))
(test-step-next)))
(with-test (:name :step-out)
- (handler-bind ((step-condition (lambda (c)
- (funcall *stepper-hook* c))))
+ (handler-bind ((step-condition #'sb-impl::invoke-stepper))
(test-step-out)))
(with-test (:name :step-start-from-break)
- (handler-bind ((step-condition (lambda (c)
- (funcall *stepper-hook* c))))
+ (handler-bind ((step-condition #'sb-impl::invoke-stepper))
(test-step-start-from-break)))
(with-test (:name :step-frame)
- (handler-bind ((step-condition (lambda (c)
- (funcall *stepper-hook* c))))
+ (handler-bind ((step-condition #'sb-impl::invoke-stepper))
(test-step-frame)))
(with-test (:name :step-backtrace)
- (handler-bind ((step-condition (lambda (c)
- (funcall *stepper-hook* c))))
+ (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)))
+