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 test-step-into ()
  41   (let* ((results nil)
  42          (expected '(("(< X 2)" :unknown)
  43                      ("(- X 1)" :unknown)
  44                      ("(FIB (1- X))" (2))
  45                      ("(< X 2)" :unknown)
  46                      ("(- X 1)" :unknown)
  47                      ("(FIB (1- X))" (1))
  48                      ("(< X 2)" :unknown)
  49                      ("(- X 2)" :unknown)
  50                      ("(FIB (- X 2))" (0))
  51                      ("(< X 2)" :unknown)
  52                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  53                      ("(- X 2)" :unknown)
  54                      ("(FIB (- X 2))" (1))
  55                      ("(< X 2)" :unknown)
  56                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  57          (*stepper-hook* (lambda (condition)
  58                            (typecase condition
  59                              (step-form-condition
  60                               (push (list (step-condition-form condition)
  61                                           (step-condition-args condition))
  62                                     results)
  63                               (invoke-restart 'step-into))))))
  64     (step (fib 3))
  65     (assert (equal expected (reverse results)))))
  66
  67 (defun test-step-next ()
  68   (let* ((results nil)
  69          (expected '(("(< X 2)" :unknown)
  70                      ("(- X 1)" :unknown)
  71                      ("(FIB (1- X))" (2))
  72                      ("(< X 2)" :unknown)
  73                      ("(- X 1)" :unknown)
  74                      ("(FIB (1- X))" (1))
  75                      ("(- X 2)" :unknown)
  76                      ("(FIB (- X 2))" (0))
  77                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
  78                      ("(- X 2)" :unknown)
  79                      ("(FIB (- X 2))" (1))
  80                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
  81          (count 0)
  82          (*stepper-hook* (lambda (condition)
  83                            (typecase condition
  84                              (step-form-condition
  85                               (push (list (step-condition-form condition)
  86                                           (step-condition-args condition))
  87                                     results)
  88                               (if (< (incf count) 4)
  89                                   (invoke-restart 'step-into)
  90                                   (invoke-restart 'step-next)))))))
  91     (step (fib 3))
  92     (assert (equal expected (reverse results)))))
  93
  94 (defun test-step-out ()
  95   (let* ((results nil)
  96          (expected '(("(< X 2)" :unknown)
  97                      ("(- X 1)" :unknown)
  98                      ("(FIB (1- X))" (2))
  99                      ("(< X 2)" :unknown)
 100                      ("(- X 2)" :unknown)
 101                      ("(FIB (- X 2))" (1))
 102                      ("(< X 2)" :unknown)
 103                      ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
 104          (count 0)
 105          (*stepper-hook* (lambda (condition)
 106                            (typecase condition
 107                              (step-form-condition
 108                               (push (list (step-condition-form condition)
 109                                           (step-condition-args condition))
 110                                     results)
 111                               (if (= (incf count) 4)
 112                                   (invoke-restart 'step-out)
 113                                   (invoke-restart 'step-into)))))))
 114     (step (fib 3))
 115     (assert (equal expected (reverse results)))))
 116
 117 (defun test-step-start-from-break ()
 118   (let* ((results nil)
 119          (expected '(("(- X 2)" :unknown)
 120                      ("(FIB-BREAK (- X 2))" (0))
 121                      ("(< X 2)" :unknown)
 122                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
 123                      ("(- X 2)" :unknown)
 124                      ("(FIB-BREAK (- X 2))" (1))
 125                      ("(< X 2)" :unknown)
 126                      ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
 127          (count 0)
 128          (*stepper-hook* (lambda (condition)
 129                            (typecase condition
 130                              (step-form-condition
 131                               (push (list (step-condition-form condition)
 132                                           (step-condition-args condition))
 133                                     results)
 134                               (invoke-restart 'step-into))))))
 135     (setf *cerror-called* nil)
 136     (handler-bind ((error
 137                     (lambda (c)
 138                       (sb-impl::enable-stepping)
 139                       (invoke-restart 'continue))))
 140       (fib-break 3))
 141     (assert (equal expected (reverse results)))))
 142
 143 (defun test-step-frame ()
 144   (let* ((count 0)
 145          (*stepper-hook* (lambda (condition)
 146                            (typecase condition
 147                              (step-form-condition
 148                               (let* ((frame (sb-di::find-stepped-frame))
 149                                      (dfun (sb-di::frame-debug-fun frame))
 150                                      (name (sb-di::debug-fun-name dfun)))
 151                                 (assert (equal name 'fib))
 152                                 (incf count)))))))
 153     (step (fib 3))
 154     (assert (= count 6))))
 155
 156 (defun test-step-backtrace ()
 157   (let* ((*stepper-hook* (lambda (condition)
 158                            (typecase condition
 159                              (step-form-condition
 160                               (let ((*debug-io* (make-broadcast-stream)))
 161                                 (backtrace)))))))
 162     (step (fib 3))))
 163
 164 (handler-bind ((step-condition (lambda (c)
 165                                  (funcall *stepper-hook* c))))
 166   (with-test (:name :step-into)
 167     (test-step-into))
 168   (with-test (:name :step-next)
 169     (test-step-next))
 170   (with-test (:name :step-out)
 171     (test-step-out))
 172   (with-test (:name :step-start-from-break)
 173     (test-step-start-from-break))
 174   (with-test (:name :step-frame)
 175     (test-step-frame))
 176   (with-test (:name :step-backtrace)
 177     (test-step-backtrace)))
 178
 179
 180