tests/step.impure.lisp

   1 ;;;; This file is for testing the single-stepper.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 ;; No stepper support on some platforms.
  17 #-(or x86 x86-64 ppc)
  18 (sb-ext:quit :unix-status 104)
  19
  20 (defun fib (x)
  21   (declare (optimize debug))
  22   (if (< x 2)
  23       1
  24       (+ (fib (1- x))
  25          (fib (- x 2)))))
  26
  27 (defvar *cerror-called* nil)
  28
  29 (defun fib-break (x)
  30   (declare (optimize debug))
  31   (if (< x 2)
  32       (progn
  33         (unless *cerror-called*
  34           (cerror "a" "b")
  35           (setf *cerror-called* t))
  36         1)
  37       (+ (fib-break (1- x))
  38          (fib-break (- x 2)))))
  39
  40 (defun in ()
  41   (declare (optimize debug))
  42   (print 1)
  43   (print 2)
  44   (print 3)
  45   (print 4))
  46
  47 (defun out ()
  48   (declare (optimize debug))
  49   (in))
  50
  51 (defun test-step-into ()
  52   (let* ((results nil)
  53          (expected '(("(< X 2)" :unknown)
  54                      ("(- X 1)" :unknown)
  55                      ("(FIB (1- X))" (2))
  56                      ("(< X 2)" :unknown)
  57                      ("(- X 1)" :unknown)
  58                      ("(FIB (1- X))" (1))
  59                      ("(< X 2)" :unknown)
  60                      ("(- X 2)" :unknown)
  61                      ("(FIB (- X 2))" (0))
  62                      ("(< X 2)" :unknown)
  63                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  64                      ("(- X 2)" :unknown)
  65                      ("(FIB (- X 2))" (1))
  66                      ("(< X 2)" :unknown)
  67                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  68          (*stepper-hook* (lambda (condition)
  69                            (typecase condition
  70                              (step-form-condition
  71                               (push (list (step-condition-form condition)
  72                                           (step-condition-args condition))
  73                                     results)
  74                               (invoke-restart 'step-into))))))
  75     (step (fib 3))
  76     (assert (equal expected (reverse results)))))
  77
  78 (defun test-step-next ()
  79   (let* ((results nil)
  80          (expected '(("(< X 2)" :unknown)
  81                      ("(- X 1)" :unknown)
  82                      ("(FIB (1- X))" (2))
  83                      ("(< X 2)" :unknown)
  84                      ("(- X 1)" :unknown)
  85                      ("(FIB (1- X))" (1))
  86                      ("(- X 2)" :unknown)
  87                      ("(FIB (- X 2))" (0))
  88                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  89                      ("(- X 2)" :unknown)
  90                      ("(FIB (- X 2))" (1))
  91                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  92          (count 0)
  93          (*stepper-hook* (lambda (condition)
  94                            (typecase condition
  95                              (step-form-condition
  96                               (push (list (step-condition-form condition)
  97                                           (step-condition-args condition))
  98                                     results)
  99                               (if (< (incf count) 4)
 100                                   (invoke-restart 'step-into)
 101                                   (invoke-restart 'step-next)))))))
 102     (step (fib 3))
 103     (assert (equal expected (reverse results)))))
 104
 105 (defun test-step-out ()
 106   (let* ((results nil)
 107          (expected '(("(< X 2)" :unknown)
 108                      ("(- X 1)" :unknown)
 109                      ("(FIB (1- X))" (2))
 110                      ("(< X 2)" :unknown)
 111                      ("(- X 2)" :unknown)
 112                      ("(FIB (- X 2))" (1))
 113                      ("(< X 2)" :unknown)
 114                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 115          (count 0)
 116          (*stepper-hook* (lambda (condition)
 117                            (typecase condition
 118                              (step-form-condition
 119                               (push (list (step-condition-form condition)
 120                                           (step-condition-args condition))
 121                                     results)
 122                               (if (= (incf count) 4)
 123                                   (invoke-restart 'step-out)
 124                                   (invoke-restart 'step-into)))))))
 125     (step (fib 3))
 126     (assert (equal expected (reverse results)))))
 127
 128 (defun test-step-start-from-break ()
 129   (let* ((results nil)
 130          (expected '(("(- X 2)" :unknown)
 131                      ("(FIB-BREAK (- X 2))" (0))
 132                      ("(< X 2)" :unknown)
 133                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 134                      ("(- X 2)" :unknown)
 135                      ("(FIB-BREAK (- X 2))" (1))
 136                      ("(< X 2)" :unknown)
 137                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
 138          (count 0)
 139          (*stepper-hook* (lambda (condition)
 140                            (typecase condition
 141                              (step-form-condition
 142                               (push (list (step-condition-form condition)
 143                                           (step-condition-args condition))
 144                                     results)
 145                               (invoke-restart 'step-into))))))
 146     (setf *cerror-called* nil)
 147     (handler-bind ((error
 148                     (lambda (c)
 149                       (sb-impl::enable-stepping)
 150                       (invoke-restart 'continue))))
 151       (fib-break 3))
 152     (assert (equal expected (reverse results)))))
 153
 154 (defun test-step-frame ()
 155   (let* ((count 0)
 156          (*stepper-hook* (lambda (condition)
 157                            (typecase condition
 158                              (step-form-condition
 159                               (let* ((frame (sb-di::find-stepped-frame))
 160                                      (dfun (sb-di::frame-debug-fun frame))
 161                                      (name (sb-di::debug-fun-name dfun)))
 162                                 (assert (equal name 'fib))
 163                                 (incf count)
 164                                 (invoke-restart 'step-next)))))))
 165     (step (fib 3))
 166     (assert (= count 6))))
 167
 168 (defun test-step-backtrace ()
 169   (let* ((*stepper-hook* (lambda (condition)
 170                            (typecase condition
 171                              (step-form-condition
 172                               (let ((*debug-io* (make-broadcast-stream)))
 173                                 (backtrace)))))))
 174     (step (fib 3))))
 175
 176 (defun test-step-next/2 ()
 177   (let* ((results nil)
 178          (expected '(("(IN)" ())
 179                      ("(PRINT 1)" (1))
 180                      ("(PRINT 2)" (2))
 181                      ("(PRINT 3)" (3))
 182                      ("(PRINT 4)" (4))))
 183          (count 0)
 184          (*stepper-hook* (lambda (condition)
 185                            (typecase condition
 186                              (step-form-condition
 187                               (push (list (step-condition-form condition)
 188                                           (step-condition-args condition))
 189                                     results)
 190                               (if (>= (incf count) 3)
 191                                   (invoke-restart 'step-into)
 192                                   (invoke-restart 'step-into)))))))
 193     (step (out))
 194     (assert (equal expected (reverse results)))))
 195
 196 (defun test-step-out/2 ()
 197   (let* ((results nil)
 198          (expected '(("(IN)" ())
 199                      ("(PRINT 1)" (1))
 200                      ("(PRINT 2)" (2))))
 201          (count 0)
 202          (*stepper-hook* (lambda (condition)
 203                            (typecase condition
 204                              (step-form-condition
 205                               (push (list (step-condition-form condition)
 206                                           (step-condition-args condition))
 207                                     results)
 208                               (if (>= (incf count) 3)
 209                                   (invoke-restart 'step-out)
 210                                   (invoke-restart 'step-into)))))))
 211     (step (out))
 212     (assert (equal expected (reverse results)))))
 213
 214 (with-test (:name :step-into)
 215   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 216     (test-step-into)))
 217
 218 (with-test (:name :step-next)
 219   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 220       (test-step-next)))
 221
 222 (with-test (:name :step-out)
 223   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 224     (test-step-out)))
 225
 226 (with-test (:name :step-start-from-break)
 227   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 228     (test-step-start-from-break)))
 229
 230 (with-test (:name :step-frame)
 231   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 232     (test-step-frame)))
 233
 234 (with-test (:name :step-backtrace)
 235   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 236     (test-step-backtrace)))
 237
 238 (with-test (:name :step-next/2)
 239   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 240     (test-step-next/2)))
 241
 242 (with-test (:name :step-out/2)
 243   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 244     (test-step-out/2)))
 245