Skip to content
This repository
Browse code

added exception level handling, and calculate-restarts function

  • Loading branch information...
commit df43b2f4e3b0d0eef20d991311b5c2157248b780 1 parent 2a9d02e
Hugo Duncan hugoduncan authored

Showing 2 changed files with 83 additions and 38 deletions. Show diff stats Hide diff stats

  1. +1 8 src/swank/commands/basic.clj
  2. +82 30 src/swank/core.clj
9 src/swank/commands/basic.clj
@@ -339,14 +339,7 @@ that symbols accessible in the current namespace go first."
339 339 (throw *debug-quit-exception*))
340 340
341 341 (defslimefn invoke-nth-restart-for-emacs [level n]
342   - (if (= n 1)
343   - (if (and *current-exception*
344   - (not (.contains (.getMessage *current-exception*) "BREAK:")))
345   - (let [cause (.getCause *current-exception*)]
346   - (invoke-debugger nil cause *pending-continuations*)
347   - (.getMessage cause))
348   - (throw *debug-continue-exception*))
349   - (throw *debug-quit-exception*)))
  342 + ((nth (*sldb-restarts* (nth (keys *sldb-restarts*) n)) 2)))
350 343
351 344 (defslimefn backtrace [start end]
352 345 (build-backtrace start end))
112 src/swank/core.clj
@@ -17,6 +17,7 @@
17 17 (def *sldb-stepping-p* nil)
18 18 (def *sldb-initial-frames* 10)
19 19 (def #^{:doc "The current level of recursive debugging."} *sldb-level* 0)
  20 +(def #^{:doc "The current restarts."} *sldb-restarts* 0)
20 21
21 22 (def #^{:doc "Include swank-clojure thread in stack trace for debugger."}
22 23 *debug-swank-clojure* false)
@@ -128,12 +129,54 @@ values."
128 129 (str " [Thrown " (class *current-exception*) "]")
129 130 nil))
130 131
  132 +(defn make-restart [kw name description f]
  133 + [kw [name description f]])
  134 +
  135 +(defn add-restart-if [condition restarts kw name description f]
  136 + (if condition
  137 + (conj restarts (make-restart kw name description f))
  138 + restarts))
  139 +
  140 +(declare sldb-debug)
  141 +(defn cause-restart-for [thrown depth]
  142 + (make-restart
  143 + (keyword (str "cause" depth))
  144 + (str "CAUSE" depth)
  145 + (str "Invoke debugger on cause "
  146 + (apply str (take depth (repeat " ")))
  147 + (.getMessage thrown)
  148 + " [Thrown " (class thrown) "]")
  149 + (partial sldb-debug nil thrown *pending-continuations*)))
  150 +
  151 +(defn add-cause-restarts [restarts thrown]
  152 + (loop [restarts restarts
  153 + cause (.getCause thrown)
  154 + level 1]
  155 + (if cause
  156 + (recur
  157 + (conj restarts (cause-restart-for cause level))
  158 + (.getCause cause)
  159 + (inc level))
  160 + restarts)))
  161 +
  162 +(defn calculate-restarts [thrown]
  163 + (let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level"
  164 + (fn [] (throw *debug-quit-exception*)))]
  165 + restarts (add-restart-if
  166 + (pos? *sldb-level*)
  167 + restarts
  168 + :abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*))
  169 + (fn [] (throw *debug-abort-exception*)))
  170 + restarts (add-restart-if
  171 + (.contains (.getMessage thrown) "BREAK")
  172 + restarts
  173 + :continue "CONTINUE" (str "Continue from breakpoint")
  174 + (fn [] (throw *debug-continue-exception*)))
  175 + restarts (add-cause-restarts restarts thrown)]
  176 + (into (array-map) restarts)))
  177 +
131 178 (defn format-restarts-for-emacs []
132   - `(("ABORT" "Return to SLIME's top level.")
133   - ~@(when-let [cause (.getCause *current-exception*)]
134   - '(("CAUSE" "Throw cause of this exception")))
135   - ~@(when (.contains (.getMessage *current-exception*) "BREAK:")
136   - '(("CONTINUE" "Continue execution")))))
  179 + (doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*)))
137 180
138 181 (defn build-backtrace [start end]
139 182 (doall (take (- end start) (drop start (exception-stacktrace *current-exception*)))))
@@ -144,31 +187,40 @@ values."
144 187 (build-backtrace start end)
145 188 *pending-continuations*))
146 189
147   -(defn debug-loop
  190 +(defn sldb-loop
148 191 "A loop that is intented to take over an eval thread when a debug is
149 192 encountered (an continue to perform the same thing). It will
150 193 continue until a *debug-quit* exception is encountered."
151   - []
  194 + [level]
152 195 (try
153   - (eval-loop)
  196 + ([] (continuously
  197 + (do
  198 + (send-to-emacs
  199 + (list* :debug (current-thread) level
  200 + (build-debugger-info-for-emacs 0 *sldb-initial-frames*)))
  201 + (send-to-emacs `(:debug-activate ~(current-thread) ~level nil))
  202 + (eval-from-control))))
154 203 (catch Throwable t
155   - (send-to-emacs (list :debug-return (current-thread) *sldb-level* nil))
156   - (cond
157   - (debug-quit-exception? t) (throw *debug-abort-exception*)
158   - (not (debug-continue-exception? t)) (throw t)))))
  204 + (send-to-emacs
  205 + `(:debug-return ~(current-thread) ~*sldb-level* ~*sldb-stepping-p*))
  206 + (if-not (debug-continue-exception? t)
  207 + (throw t)))))
159 208
160 209 (defn invoke-debugger
161 210 [locals #^Throwable thrown id]
162 211 (binding [*current-env* locals
163 212 *current-exception* thrown
  213 + *sldb-restarts* (calculate-restarts thrown)
164 214 *sldb-level* (inc *sldb-level*)]
165   - (let [level *sldb-level*
166   - thread (current-thread)]
167   - (send-to-emacs
168   - (list* :debug thread level
169   - (build-debugger-info-for-emacs 0 *sldb-initial-frames*)))
170   - (send-to-emacs (list :debug-activate thread level true))
171   - (debug-loop))))
  215 + (sldb-loop *sldb-level*)))
  216 +
  217 +(defn sldb-debug [locals thrown id]
  218 + (try
  219 + (invoke-debugger nil thrown id)
  220 + (catch Throwable t
  221 + (when (and (pos? *sldb-level*)
  222 + (not (debug-abort-exception? t)))
  223 + (throw t)))))
172 224
173 225 (defmacro break
174 226 []
@@ -200,28 +252,28 @@ values."
200 252 ;; (.printStackTrace t #^java.io.PrintWriter *err*)
201 253
202 254 (cond
203   - (debug-continue-exception? t)
  255 + (debug-quit-exception? t)
204 256 (do
205   - (send-to-emacs `(:return ~(thread-name (current-thread)) (:ok nil) ~id))
  257 + (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
206 258 (if-not (zero? *sldb-level*)
207 259 (throw t)))
208 260
209   - (or (debug-quit-exception? t) (debug-abort-exception? t))
  261 + (debug-abort-exception? t)
210 262 (do
211 263 (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
212 264 (if-not (zero? *sldb-level*)
213   - (throw t)))
  265 + (throw *debug-abort-exception*)))
  266 +
  267 + (debug-continue-exception? t)
  268 + (throw t)
214 269
215 270 :else
216 271 (do
217 272 (set! *e t)
218   - (try
219   - (invoke-debugger
220   - nil
221   - (if *debug-swank-clojure* t (.getCause t))
222   - id)
223   - (catch Throwable t))
224   -
  273 + (sldb-debug
  274 + nil
  275 + (if *debug-swank-clojure* t (.getCause t))
  276 + id)
225 277 ;; reply with abort
226 278 (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))))))
227 279

0 comments on commit df43b2f

Please sign in to comment.
Something went wrong with that request. Please try again.