diff --git a/src/swank/commands/basic.clj b/src/swank/commands/basic.clj index 83d4fbf..3595b37 100644 --- a/src/swank/commands/basic.clj +++ b/src/swank/commands/basic.clj @@ -37,7 +37,7 @@ (if (= form rdr) [value last-form] (recur (read rdr false rdr) - (eval form) + (eval (with-env-locals form)) form))))))) (defslimefn interactive-eval-region [string] @@ -339,20 +339,49 @@ that symbols accessible in the current namespace go first." (defslimefn throw-to-toplevel [] (throw *debug-quit-exception*)) +(defn invoke-restart [restart] + ((nth restart 2))) + (defslimefn invoke-nth-restart-for-emacs [level n] - (if (= n 1) - (let [cause (.getCause *current-exception*)] - (invoke-debugger cause *debug-thread-id*) - (.getMessage cause)) - (throw *debug-quit-exception*))) + ((invoke-restart (*sldb-restarts* (nth (keys *sldb-restarts*) n))))) + +(defslimefn throw-to-toplevel [] + (if-let [restart (*sldb-restarts* :quit)] + (invoke-restart restart))) + +(defslimefn sldb-continue [] + (if-let [restart (*sldb-restarts* :continue)] + (invoke-restart restart))) + +(defslimefn sldb-abort [] + (if-let [restart (*sldb-restarts* :abort)] + (invoke-restart restart))) + (defslimefn backtrace [start end] - (doall (take (- end start) (drop start (exception-stacktrace *current-exception*))))) + (build-backtrace start end)) (defslimefn buffer-first-change [file-name] nil) +(defn locals-for-emacs [m] + (map #(list :name (name (first %)) :id 0 :value (str (second %))) m)) + (defslimefn frame-catch-tags-for-emacs [n] nil) -(defslimefn frame-locals-for-emacs [n] nil) +(defslimefn frame-locals-for-emacs [n] + (if (and (zero? n) *current-env*) + (locals-for-emacs (local-non-functions *current-env*)))) + +(defslimefn frame-locals-and-catch-tags [n] + (list (frame-locals-for-emacs n) + (frame-catch-tags-for-emacs n))) + +(defslimefn debugger-info-for-emacs [start end] + (build-debugger-info-for-emacs start end)) + +(defslimefn eval-string-in-frame [expr n] + (if (and (zero? n) *current-env*) + (with-bindings *current-env* + (eval expr)))) (defslimefn frame-source-location [n] (source-location-for-frame diff --git a/src/swank/commands/inspector.clj b/src/swank/commands/inspector.clj index 3eff77a..3f55e61 100644 --- a/src/swank/commands/inspector.clj +++ b/src/swank/commands/inspector.clj @@ -264,6 +264,14 @@ (binding [*current-connection* (first @*connections*)] (send-it)))))) +(defslimefn inspect-frame-var [frame index] + (if (and (zero? frame) *current-env*) + (let [locals (local-non-functions *current-env*) + object (locals (nth (keys locals) index))] + (with-emacs-package + (reset-inspector) + (inspect-object object))))) + (defslimefn inspector-nth-part [index] (get @*inspectee-parts* index)) diff --git a/src/swank/core.clj b/src/swank/core.clj index 7d0db9f..bc9b8e0 100644 --- a/src/swank/core.clj +++ b/src/swank/core.clj @@ -11,6 +11,14 @@ ;; Emacs packages (def *current-package*) +;; current emacs eval id +(def *pending-continuations* '()) + +(def *sldb-stepping-p* nil) +(def *sldb-initial-frames* 10) +(def #^{:doc "The current level of recursive debugging."} *sldb-level* 0) +(def #^{:doc "The current restarts."} *sldb-restarts* 0) + (def #^{:doc "Include swank-clojure thread in stack trace for debugger."} *debug-swank-clojure* false) @@ -43,7 +51,24 @@ ;; Exceptions for debugging (defonce *debug-quit-exception* (Exception. "Debug quit")) -(def #^Throwable *current-exception*) +(defonce *debug-continue-exception* (Exception. "Debug continue")) +(defonce *debug-abort-exception* (Exception. "Debug abort")) + +(def #^Throwable *current-exception* nil) + +;; Local environment +(def *current-env* nil) + +(let [&env :unavailable] + (defmacro local-bindings + "Produces a map of the names of local bindings to their values." + [] + (if-not (= &env :unavailable) + (let [symbols (keys &env)] + (zipmap (map (fn [sym] `(quote ~sym)) symbols) symbols))))) + +(defn local-non-functions [m] + (select-keys m (filter #(or (coll? (m %)) (not (ifn? (m %)))) (keys m)))) ;; Handle Evaluation (defn send-to-emacs @@ -54,6 +79,16 @@ (defn send-repl-results-to-emacs [val] (send-to-emacs `(:write-string ~(str (pr-str val) "\n") :repl-result))) +(defn with-env-locals + "Evals a form with given locals. The locals should be a map of symbols to +values." + [form] + (let [m (local-non-functions *current-env*)] + (if (first m) + `(let ~(vec (mapcat #(list % (m %)) (keys m))) + ~form) + form))) + (defn eval-in-emacs-package [form] (with-emacs-package (eval form))) @@ -78,42 +113,118 @@ (defn- debug-quit-exception? [t] (some #(identical? *debug-quit-exception* %) (exception-causes t))) -(defn debug-loop - "A loop that is intented to take over an eval thread when a debug is - encountered (an continue to perform the same thing). It will - continue until a *debug-quit* exception is encountered." - ([] (try - (eval-loop) - (catch Throwable t - ;; exit loop when not a debug quit - (when-not (debug-quit-exception? t) - (throw t)))))) - -(defn exception-stacktrace [#^Throwable t] +(defn- debug-continue-exception? [t] + (some #(identical? *debug-continue-exception* %) (exception-causes t))) + +(defn- debug-abort-exception? [t] + (some #(identical? *debug-abort-exception* %) (exception-causes t))) + +(defn exception-stacktrace [t] (map #(list %1 %2 '(:restartable nil)) (iterate inc 0) (map str (.getStackTrace t)))) -(def *debug-thread-id*) -(defn invoke-debugger [#^Throwable thrown id] - (dothread-swank - (thread-set-name "Swank Debugger Thread") - (binding [*current-exception* thrown - *debug-thread-id* id] - (let [level 1 - message (list (or (.getMessage thrown) "No message.") - (str " [Thrown " (class thrown) "]") - nil) - options `(("ABORT" "Return to SLIME's top level.") - ~@(when-let [cause (.getCause thrown)] - '(("CAUSE" "Throw cause of this exception")))) - error-stack (exception-stacktrace thrown) - continuations (list id)] - (send-to-emacs (list :debug (current-thread) level message - options error-stack continuations)) - (send-to-emacs (list :debug-activate (current-thread) level true)) - (debug-loop) - (send-to-emacs (list :debug-return (current-thread) level nil)))))) +(defn debugger-condition-for-emacs [] + (list (or (.getMessage *current-exception*) "No message.") + (str " [Thrown " (class *current-exception*) "]") + nil)) + +(defn make-restart [kw name description f] + [kw [name description f]]) + +(defn add-restart-if [condition restarts kw name description f] + (if condition + (conj restarts (make-restart kw name description f)) + restarts)) + +(declare sldb-debug) +(defn cause-restart-for [thrown depth] + (make-restart + (keyword (str "cause" depth)) + (str "CAUSE" depth) + (str "Invoke debugger on cause " + (apply str (take depth (repeat " "))) + (.getMessage thrown) + " [Thrown " (class thrown) "]") + (partial sldb-debug nil thrown *pending-continuations*))) + +(defn add-cause-restarts [restarts thrown] + (loop [restarts restarts + cause (.getCause thrown) + level 1] + (if cause + (recur + (conj restarts (cause-restart-for cause level)) + (.getCause cause) + (inc level)) + restarts))) + +(defn calculate-restarts [thrown] + (let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level" + (fn [] (throw *debug-quit-exception*)))] + restarts (add-restart-if + (pos? *sldb-level*) + restarts + :abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*)) + (fn [] (throw *debug-abort-exception*))) + restarts (add-restart-if + (.contains (.getMessage thrown) "BREAK") + restarts + :continue "CONTINUE" (str "Continue from breakpoint") + (fn [] (throw *debug-continue-exception*))) + restarts (add-cause-restarts restarts thrown)] + (into (array-map) restarts))) + +(defn format-restarts-for-emacs [] + (doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*))) + +(defn build-backtrace [start end] + (doall (take (- end start) (drop start (exception-stacktrace *current-exception*))))) + +(defn build-debugger-info-for-emacs [start end] + (list (debugger-condition-for-emacs) + (format-restarts-for-emacs) + (build-backtrace start end) + *pending-continuations*)) + +(defn sldb-loop + "A loop that is intented to take over an eval thread when a debug is + encountered (an continue to perform the same thing). It will + continue until a *debug-quit* exception is encountered." + [level] + (try + (send-to-emacs + (list* :debug (current-thread) level + (build-debugger-info-for-emacs 0 *sldb-initial-frames*))) + ([] (continuously + (do + (send-to-emacs `(:debug-activate ~(current-thread) ~level nil)) + (eval-from-control)))) + (catch Throwable t + (send-to-emacs + `(:debug-return ~(current-thread) ~*sldb-level* ~*sldb-stepping-p*)) + (if-not (debug-continue-exception? t) + (throw t))))) + +(defn invoke-debugger + [locals #^Throwable thrown id] + (binding [*current-env* locals + *current-exception* thrown + *sldb-restarts* (calculate-restarts thrown) + *sldb-level* (inc *sldb-level*)] + (sldb-loop *sldb-level*))) + +(defn sldb-debug [locals thrown id] + (try + (invoke-debugger nil thrown id) + (catch Throwable t + (when (and (pos? *sldb-level*) + (not (debug-abort-exception? t))) + (throw t))))) + +(defmacro break + [] + `(invoke-debugger (local-bindings) (Exception. "BREAK:") *pending-continuations*)) (defn doall-seq [coll] (if (seq? coll) @@ -122,7 +233,8 @@ (defn eval-for-emacs [form buffer-package id] (try - (binding [*current-package* buffer-package] + (binding [*current-package* buffer-package + *pending-continuations* (cons id *pending-continuations*)] (if-let [f (slime-fn (first form))] (let [form (cons f (rest form)) result (doall-seq (eval-in-emacs-package form))] @@ -136,22 +248,34 @@ ;; Thread.stop was called on us it may be set and will cause an ;; InterruptedException in one of the send-to-emacs calls below (Thread/interrupted) - (set! *e t) ;; (.printStackTrace t #^java.io.PrintWriter *err*) - ;; Throwing to top level, let emacs know we're aborting - (when (debug-quit-exception? t) - (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) - (throw t)) - - ;; start sldb, don't bother here because you can't actually - ;; recover with java - (invoke-debugger (if *debug-swank-clojure* - t - (.getCause t)) - id) - ;; reply with abort - (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))) + + (cond + (debug-quit-exception? t) + (do + (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) + (if-not (zero? *sldb-level*) + (throw t))) + + (debug-abort-exception? t) + (do + (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)) + (if-not (zero? *sldb-level*) + (throw *debug-abort-exception*))) + + (debug-continue-exception? t) + (throw t) + + :else + (do + (set! *e t) + (sldb-debug + nil + (if *debug-swank-clojure* t (.getCause t)) + id) + ;; reply with abort + (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))))) (defn- add-active-thread [thread] (dosync