Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' into compile-file

  • Loading branch information...
commit 3f25f3ea0bb7ab7900193be9d8c21def30c8a0a9 2 parents b1a155a + 63d9545
@hugoduncan hugoduncan authored
View
6 src/swank/clj_contrib/macroexpand.clj
@@ -3,14 +3,14 @@
(def
#^{:private true}
walk-enabled?
- (.getResource (clojure.lang.RT/baseLoader) "clojure/contrib/walk.clj"))
+ (.getResource (clojure.lang.RT/baseLoader) "clojure/contrib/macro_utils.clj"))
(when walk-enabled?
- (require 'clojure.contrib.walk))
+ (require 'clojure.contrib.macro-utils))
(defmacro macroexpand-all* [form]
(if walk-enabled?
- `(clojure.contrib.walk/macroexpand-all ~form)
+ `(clojure.contrib.macro-utils/mexpand-all ~form)
`(macroexpand ~form)))
(defn macroexpand-all [form]
View
64 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]
@@ -276,19 +276,20 @@ that symbols accessible in the current namespace go first."
;;;; meta dot find
+(defn- clean-windows-path [#^String path]
+ ;; Decode file URI encoding and remove an opening slash from
+ ;; /c:/program%20files/... in jar file URLs and file resources.
+ (or (and (.startsWith (System/getProperty "os.name") "Windows")
+ (second (re-matches #"^/([a-zA-Z]:/.*)$" path)))
+ path))
+
(defn- slime-zip-resource [#^java.net.URL resource]
(let [jar-connection #^java.net.JarURLConnection (.openConnection resource)
- ;; All kinds of hacking to decode jar file URI encoding and remove
- ;; an opening slash from /c:/program%20files/...
- jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))
- zip (if (and (.startsWith (System/getProperty "os.name") "Windows")
- (re-seq #"^/[a-zA-Z]:/" jar-file))
- (apply str (rest jar-file))
- jar-file)]
- (list :zip zip (.getEntryName jar-connection))))
+ jar-file (.getPath (.toURI (.getJarFileURL jar-connection)))]
+ (list :zip (clean-windows-path jar-file) (.getEntryName jar-connection))))
(defn- slime-file-resource [#^java.net.URL resource]
- (list :file (.getFile resource)))
+ (list :file (clean-windows-path (.getFile resource))))
(defn- slime-find-resource [#^String file]
(let [resource (.getResource (clojure.lang.RT/baseLoader) file)]
@@ -338,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
View
8 src/swank/commands/completion.clj
@@ -41,12 +41,14 @@
namespace"
([] (potential-dot *ns*))
([ns]
- (map #(str "." %) (set (map method-name (mapcat instance-methods (vals (ns-imports ns))))))))
+ (map #(str "." %) (set (map member-name (mapcat instance-methods (vals (ns-imports ns))))))))
(defn potential-static
- "Returns a list of potential static methods for a given namespace"
+ "Returns a list of potential static members for a given namespace"
([#^Class class]
- (map method-name (static-methods class))))
+ (concat (map member-name (static-methods class))
+ (map member-name (static-fields class)))))
+
(defn potiential-classes-on-path
"Returns a list of Java class and Clojure package names found on the current
View
8 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))
View
220 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
View
11 src/swank/swank.clj
@@ -61,8 +61,11 @@
"Start the server wrapped in a repl. Use this to embed swank in your code."
([port & opts]
(let [stop (atom false)
- opts (merge {:port port :encoding "iso-latin-1-unix"}
- (apply hash-map opts))]
+ opts (merge {:port port
+ :encoding (or (System/getProperty
+ "swank.encoding")
+ "iso-latin-1-unix")}
+ (apply hash-map opts))]
(repl :read (fn [rprompt rexit]
(if @stop rexit
(do (swap! stop (fn [_] true))
@@ -70,8 +73,8 @@
(start-server (-> "java.io.tmpdir"
(System/getProperty)
(File. "slime-port.txt")
- (.getCanonicalPath)))
- ~@(apply concat opts)))))
+ (.getCanonicalPath))
+ ~@(apply concat opts))))))
:need-prompt #(identity false))))
([] (start-repl 4005)))
View
23 src/swank/util/io.clj
@@ -1,7 +1,7 @@
(ns swank.util.io
(:use [swank util]
[swank.util.concurrent thread])
- (:import [java.io StringWriter Reader]))
+ (:import [java.io StringWriter Reader PrintWriter]))
(defn read-chars
([rdr n] (read-chars rdr n false))
@@ -19,15 +19,16 @@
"Creates a stream that will call a given function when flushed."
([flushf]
(let [closed? (atom false)
- #^StringWriter stream
- (proxy [StringWriter] []
- (close [] (reset! closed? true))
- (flush []
- (let [#^StringWriter me this
- len (.. me getBuffer length)]
- (when (> len 0)
- (flushf (.. me getBuffer (substring 0 len)))
- (.. me getBuffer (delete 0 len))))))]
+ #^PrintWriter stream
+ (PrintWriter.
+ (proxy [StringWriter] []
+ (close [] (reset! closed? true))
+ (flush []
+ (let [#^StringWriter me this
+ len (.. me getBuffer length)]
+ (when (> len 0)
+ (flushf (.. me getBuffer (substring 0 len)))
+ (.. me getBuffer (delete 0 len)))))))]
(dothread
(thread-set-name "Call-on-write Stream")
(continuously
@@ -35,4 +36,4 @@
(when-not @closed?
(.flush stream))))
stream))
- {:tag StringWriter})
+ {:tag PrintWriter})
View
15 src/swank/util/java.clj
@@ -1,13 +1,16 @@
(ns swank.util.java)
-(defn method-name [#^java.lang.reflect.Method method]
- (.getName method))
+(defn member-name [#^java.lang.reflect.Member member]
+ (.getName member))
-(defn method-static? [#^java.lang.reflect.Method method]
- (java.lang.reflect.Modifier/isStatic (.getModifiers method)))
+(defn member-static? [#^java.lang.reflect.Member member]
+ (java.lang.reflect.Modifier/isStatic (.getModifiers member)))
(defn static-methods [#^Class class]
- (filter method-static? (.getMethods class)))
+ (filter member-static? (.getMethods class)))
+
+(defn static-fields [#^Class class]
+ (filter member-static? (.getDeclaredFields class)))
(defn instance-methods [#^Class class]
- (remove method-static? (.getMethods class)))
+ (remove member-static? (.getMethods class)))
View
22 swank-clojure.el
@@ -159,7 +159,7 @@ this, keep that in mind."
(format "%s" (slime-coding-system-cl-name encoding)))))
(defun swank-clojure-find-package ()
- (let ((regexp "^(\\(clojure.core/\\)?\\(in-\\)?ns[ \t\n\r]+\\(#\\^{[^}]+}[ \t\n\r]+\\)?[:']?\\([^()\" \t\n]+\\>\\)"))
+ (let ((regexp "^(\\(clojure.core/\\)?\\(in-\\)?ns\\+?[ \t\n\r]+\\(#\\^{[^}]+}[ \t\n\r]+\\)?[:']?\\([^()\" \t\n]+\\>\\)"))
(save-excursion
(when (or (re-search-backward regexp nil t)
(re-search-forward regexp nil t))
@@ -246,27 +246,24 @@ will be used over paths too.)"
init-opts)
(list "--repl")))))
+(defun swank-clojure-reset-implementation ()
+ "Redefines the clojure entry in `slime-lisp-implementations'."
+ (aput 'slime-lisp-implementations 'clojure
+ (list (swank-clojure-cmd) :init 'swank-clojure-init)))
+
;;;###autoload
(defadvice slime-read-interactive-args (before add-clojure)
;; Unfortunately we need to construct our Clojure-launching command
;; at slime-launch time to reflect changes in the classpath. Slime
;; has no mechanism to support this, so we must resort to advice.
(require 'assoc)
- (aput 'slime-lisp-implementations 'clojure
- (list (swank-clojure-cmd) :init 'swank-clojure-init)))
+ (swank-clojure-reset-implementation))
;; Change the repl to be more clojure friendly
(defun swank-clojure-slime-repl-modify-syntax ()
(when (string-match "\\*slime-repl clojure\\*" (buffer-name))
;; modify syntax
- (modify-syntax-entry ?~ "' ")
- (modify-syntax-entry ?, " ")
- (modify-syntax-entry ?\{ "(}")
- (modify-syntax-entry ?\} "){")
- (modify-syntax-entry ?\[ "(]")
- (modify-syntax-entry ?\] ")[")
- (modify-syntax-entry ?^ "'")
- (modify-syntax-entry ?= "'")
+ (set-syntax-table clojure-mode-syntax-table)
;; set indentation function (already local)
(setq lisp-indent-function 'clojure-indent-function)
@@ -323,6 +320,8 @@ The `path' variable is bound to the project root when these functions run.")
(if (functionp 'locate-dominating-file) ; Emacs 23 only
(locate-dominating-file default-directory "src")
default-directory))))
+ (when (functionp 'locate-dominating-file)
+ (cd (locate-dominating-file default-directory "project.clj")))
;; TODO: allow multiple SLIME sessions per Emacs instance
(when (get-buffer "*inferior-lisp*") (kill-buffer "*inferior-lisp*"))
@@ -353,6 +352,7 @@ The `path' variable is bound to the project root when these functions run.")
(add-to-list 'swank-clojure-extra-vm-args
(format "-Dclojure.compile.path=%s"
(expand-file-name "target/classes/" path))))
+ (swank-clojure-reset-implementation)
(run-hooks 'swank-clojure-project-hook)
(save-window-excursion
Please sign in to comment.
Something went wrong with that request. Please try again.