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 (define-condition cerror-break (error) ())
  30
  31 (defun fib-break (x)
  32   (declare (optimize debug))
  33   (if (< x 2)
  34       (progn
  35         (unless *cerror-called*
  36           (cerror "a" 'cerror-break)
  37           (setf *cerror-called* t))
  38         1)
  39       (+ (fib-break (1- x))
  40          (fib-break (- x 2)))))
  41
  42 (defun in ()
  43   (declare (optimize debug))
  44   (print 1)
  45   (print 2)
  46   (print 3)
  47   (print 4))
  48
  49 (defun out ()
  50   (declare (optimize debug))
  51   (in))
  52
  53 (defun test-step-into ()
  54   (let* ((results nil)
  55          (expected '(("(< X 2)" :unknown)
  56                      ("(- X 1)" :unknown)
  57                      ("(FIB (1- X))" (2))
  58                      ("(< X 2)" :unknown)
  59                      ("(- X 1)" :unknown)
  60                      ("(FIB (1- X))" (1))
  61                      ("(< X 2)" :unknown)
  62                      ("(- X 2)" :unknown)
  63                      ("(FIB (- X 2))" (0))
  64                      ("(< X 2)" :unknown)
  65                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  66                      ("(- X 2)" :unknown)
  67                      ("(FIB (- X 2))" (1))
  68                      ("(< X 2)" :unknown)
  69                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  70          (*stepper-hook* (lambda (condition)
  71                            (typecase condition
  72                              (step-form-condition
  73                               (push (list (step-condition-form condition)
  74                                           (step-condition-args condition))
  75                                     results)
  76                               (invoke-restart 'step-into))))))
  77     (step (fib 3))
  78     (assert (equal expected (reverse results)))))
  79
  80 (defun test-step-next ()
  81   (let* ((results nil)
  82          (expected '(("(< X 2)" :unknown)
  83                      ("(- X 1)" :unknown)
  84                      ("(FIB (1- X))" (2))
  85                      ("(< X 2)" :unknown)
  86                      ("(- X 1)" :unknown)
  87                      ("(FIB (1- X))" (1))
  88                      ("(- X 2)" :unknown)
  89                      ("(FIB (- X 2))" (0))
  90                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  91                      ("(- X 2)" :unknown)
  92                      ("(FIB (- X 2))" (1))
  93                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  94          (count 0)
  95          (*stepper-hook* (lambda (condition)
  96                            (typecase condition
  97                              (step-form-condition
  98                               (push (list (step-condition-form condition)
  99                                           (step-condition-args condition))
 100                                     results)
 101                               (if (< (incf count) 4)
 102                                   (invoke-restart 'step-into)
 103                                   (invoke-restart 'step-next)))))))
 104     (step (fib 3))
 105     (assert (equal expected (reverse results)))))
 106
 107 (defun test-step-out ()
 108   (let* ((results nil)
 109          (expected '(("(< X 2)" :unknown)
 110                      ("(- X 1)" :unknown)
 111                      ("(FIB (1- X))" (2))
 112                      ("(< X 2)" :unknown)
 113                      ("(- X 2)" :unknown)
 114                      ("(FIB (- X 2))" (1))
 115                      ("(< X 2)" :unknown)
 116                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 117          (count 0)
 118          (*stepper-hook* (lambda (condition)
 119                            (typecase condition
 120                              (step-form-condition
 121                               (push (list (step-condition-form condition)
 122                                           (step-condition-args condition))
 123                                     results)
 124                               (if (= (incf count) 4)
 125                                   (invoke-restart 'step-out)
 126                                   (invoke-restart 'step-into)))))))
 127     (step (fib 3))
 128     (assert (equal expected (reverse results)))))
 129
 130 (defun test-step-start-from-break ()
 131   (let* ((results nil)
 132          (expected '(("(- X 2)" :unknown)
 133                      ("(FIB-BREAK (- X 2))" (0))
 134                      ("(< X 2)" :unknown)
 135                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 136                      ("(- X 2)" :unknown)
 137                      ("(FIB-BREAK (- X 2))" (1))
 138                      ("(< X 2)" :unknown)
 139                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
 140          (count 0)
 141          (*stepper-hook* (lambda (condition)
 142                            (typecase condition
 143                              (step-form-condition
 144                               (push (list (step-condition-form condition)
 145                                           (step-condition-args condition))
 146                                     results)
 147                               (invoke-restart 'step-into))))))
 148     (setf *cerror-called* nil)
 149     (handler-bind ((cerror-break
 150                     (lambda (c)
 151                       (sb-impl::enable-stepping)
 152                       (invoke-restart 'continue))))
 153       (fib-break 3))
 154     (assert (equal expected (reverse results)))))
 155
 156 (defun test-step-frame ()
 157   (let* ((count 0)
 158          (*stepper-hook* (lambda (condition)
 159                            (typecase condition
 160                              (step-form-condition
 161                               (let* ((frame (sb-di::find-stepped-frame))
 162                                      (dfun (sb-di::frame-debug-fun frame))
 163                                      (name (sb-di::debug-fun-name dfun)))
 164                                 (assert (equal name 'fib))
 165                                 (incf count)
 166                                 (invoke-restart 'step-next)))))))
 167     (step (fib 3))
 168     (assert (= count 6))))
 169
 170 (defun test-step-backtrace ()
 171   (let* ((*stepper-hook* (lambda (condition)
 172                            (typecase condition
 173                              (step-form-condition
 174                               (let ((*debug-io* (make-broadcast-stream)))
 175                                 (backtrace)))))))
 176     (step (fib 3))))
 177
 178 (defun test-step-next/2 ()
 179   (let* ((results nil)
 180          (expected '(("(IN)" ())
 181                      ("(PRINT 1)" (1))
 182                      ("(PRINT 2)" (2))
 183                      ("(PRINT 3)" (3))
 184                      ("(PRINT 4)" (4))))
 185          (count 0)
 186          (*stepper-hook* (lambda (condition)
 187                            (typecase condition
 188                              (step-form-condition
 189                               (push (list (step-condition-form condition)
 190                                           (step-condition-args condition))
 191                                     results)
 192                               (if (>= (incf count) 3)
 193                                   (invoke-restart 'step-into)
 194                                   (invoke-restart 'step-into)))))))
 195     (step (out))
 196     (assert (equal expected (reverse results)))))
 197
 198 (defun test-step-out/2 ()
 199   (let* ((results nil)
 200          (expected '(("(IN)" ())
 201                      ("(PRINT 1)" (1))
 202                      ("(PRINT 2)" (2))))
 203          (count 0)
 204          (*stepper-hook* (lambda (condition)
 205                            (typecase condition
 206                              (step-form-condition
 207                               (push (list (step-condition-form condition)
 208                                           (step-condition-args condition))
 209                                     results)
 210                               (if (>= (incf count) 3)
 211                                   (invoke-restart 'step-out)
 212                                   (invoke-restart 'step-into)))))))
 213     (step (out))
 214     (assert (equal expected (reverse results)))))
 215
 216 (with-test (:name :step-into)
 217   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 218     (test-step-into)))
 219
 220 (with-test (:name :step-next)
 221   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 222       (test-step-next)))
 223
 224 (with-test (:name :step-out)
 225   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 226     (test-step-out)))
 227
 228 (with-test (:name :step-start-from-break)
 229   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 230     (test-step-start-from-break)))
 231
 232 (with-test (:name :step-frame)
 233   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 234     (test-step-frame)))
 235
 236 (with-test (:name :step-backtrace)
 237   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 238     (test-step-backtrace)))
 239
 240 (with-test (:name :step-next/2)
 241   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 242     (test-step-next/2)))
 243
 244 (with-test (:name :step-out/2)
 245   (handler-bind ((step-condition #'sb-impl::invoke-stepper))
 246     (test-step-out/2)))
 247