Add support for Scheme and Racket language.

sources_non_forked/slimv/swank-clojure/swank/clj_contrib/macroexpand.clj

@@ -0,0 +1,17 @@
+(ns swank.clj-contrib.macroexpand)
+
+(def
+ #^{:private true}
+ walk-enabled?
+ (.getResource (clojure.lang.RT/baseLoader) "clojure/contrib/macro_utils.clj"))
+
+(when walk-enabled?
+  (require 'clojure.contrib.macro-utils))
+
+(defmacro macroexpand-all* [form]
+  (if walk-enabled?
+    `(clojure.contrib.macro-utils/mexpand-all ~form)
+    `(macroexpand ~form)))
+
+(defn macroexpand-all [form]
+  (macroexpand-all* form))

sources_non_forked/slimv/swank-clojure/swank/clj_contrib/pprint.clj

@@ -0,0 +1,34 @@
+(ns swank.clj-contrib.pprint)
+
+(def #^{:private true} pprint-enabled?
+  (try ;; 1.2+
+    (.getResource (clojure.lang.RT/baseLoader) "clojure/pprint")
+    (require '[clojure.pprint :as pp])
+    (defmacro #^{:private true} pretty-pr-code*
+      ([code]
+         (if pprint-enabled?
+           `(binding [pp/*print-suppress-namespaces* true]
+              (pp/with-pprint-dispatch pp/code-dispatch
+                (pp/write ~code :pretty true :stream nil)))
+           `(pr-str ~code))))
+    true
+    (catch Exception e
+      (try ;; 1.0, 1.1
+        (.loadClass (clojure.lang.RT/baseLoader)
+                    "clojure.contrib.pprint.PrettyWriter")
+        (require '[clojure.contrib.pprint :as pp])
+        (defmacro #^{:private true} pretty-pr-code*
+          ([code]
+             (if pprint-enabled?
+               `(binding [pp/*print-suppress-namespaces* true]
+                  (pp/with-pprint-dispatch pp/*code-dispatch*
+                    (pp/write ~code :pretty true :stream nil)))
+               `(pr-str ~code))))
+        true
+        ;; if you just don't have contrib, be silent.
+        (catch ClassNotFoundException _)
+        (catch Exception e
+          (println e))))))
+
+(defn pretty-pr-code [code]
+  (pretty-pr-code* code))

sources_non_forked/slimv/swank-clojure/swank/commands.clj

@@ -0,0 +1,14 @@
+(ns swank.commands)
+
+(defonce slime-fn-map {})
+
+(defmacro defslimefn
+  ([fname & body]
+     `(alter-var-root #'slime-fn-map
+                      assoc
+                      (symbol "swank" ~(name fname))
+		      (defn ~fname ~@body)))
+  {:indent 'defun})
+
+(defn slime-fn [sym]
+  (slime-fn-map (symbol "swank" (name sym))))

sources_non_forked/slimv/swank-clojure/swank/commands/basic.clj

@@ -0,0 +1,608 @@
+(ns swank.commands.basic
+  (:refer-clojure :exclude [load-file print-doc])
+  (:use (swank util commands core)
+        (swank.util.concurrent thread)
+        (swank.util string clojure)
+        (swank.clj-contrib pprint macroexpand))
+  (:require (swank.util [sys :as sys])
+            (swank.commands [xref :as xref]))
+  (:import (java.io StringReader File)
+           (java.util.zip ZipFile)
+           (clojure.lang LineNumberingPushbackReader)))
+
+;;;; Connection
+
+(defslimefn connection-info []
+  `(:pid ~(sys/get-pid)
+         :style :spawn
+         :lisp-implementation (:type "Clojure"
+                                     :name "clojure"
+                                     :version ~(clojure-version))
+         :package (:name ~(name (ns-name *ns*))
+                         :prompt ~(name (ns-name *ns*)))
+         :version ~(deref protocol-version)))
+
+(defslimefn quit-lisp []
+  (System/exit 0))
+
+(defslimefn toggle-debug-on-swank-error []
+  (alter-var-root #'swank.core/debug-swank-clojure not))
+
+;;;; Evaluation
+
+(defn- eval-region
+  "Evaluate string, return the results of the last form as a list and
+   a secondary value the last form."
+  ([string]
+     (eval-region string "NO_SOURCE_FILE" 1))
+  ([string file line]
+     (with-open [rdr (proxy [LineNumberingPushbackReader]
+                         ((StringReader. string))
+                       (getLineNumber [] line))]
+       (binding [*file* file]
+         (loop [form (read rdr false rdr), value nil, last-form nil]
+           (if (= form rdr)
+             [value last-form]
+             (recur (read rdr false rdr)
+                    (eval (with-env-locals form))
+                    form)))))))
+
+(defn- compile-region
+  "Compile region."
+  ([string file line]
+     (with-open [rdr1 (proxy [LineNumberingPushbackReader]
+                          ((StringReader. string)))
+                 rdr (proxy [LineNumberingPushbackReader] (rdr1)
+                       (getLineNumber [] (+ line (.getLineNumber rdr1) -1)))]
+       (clojure.lang.Compiler/load rdr file (.getName (File. file))))))
+
+
+(defslimefn interactive-eval-region [string]
+  (with-emacs-package
+    (pr-str (first (eval-region string)))))
+
+(defslimefn interactive-eval [string]
+  (with-emacs-package
+    (pr-str (first (eval-region string)))))
+
+(defslimefn listener-eval [form]
+  (with-emacs-package
+    (with-package-tracking
+      (let [[value last-form] (eval-region form)]
+        (when (and last-form (not (one-of? last-form '*1 '*2 '*3 '*e)))
+          (set! *3 *2)
+          (set! *2 *1)
+          (set! *1 value))
+        (send-repl-results-to-emacs value)))))
+
+(defslimefn eval-and-grab-output [string]
+  (with-emacs-package
+    (let [retval (promise)]
+      (list (with-out-str
+              (deliver retval (pr-str (first (eval-region string)))))
+            @retval))))
+
+(defslimefn pprint-eval [string]
+  (with-emacs-package
+    (pretty-pr-code (first (eval-region string)))))
+
+;;;; Macro expansion
+
+(defn- apply-macro-expander [expander string]
+  (pretty-pr-code (expander (read-string string))))
+
+(defslimefn swank-macroexpand-1 [string]
+  (apply-macro-expander macroexpand-1 string))
+
+(defslimefn swank-macroexpand [string]
+  (apply-macro-expander macroexpand string))
+
+;; not implemented yet, needs walker
+(defslimefn swank-macroexpand-all [string]
+  (apply-macro-expander macroexpand-all string))
+
+;;;; Compiler / Execution
+
+(def compiler-exception-location-re #"Exception:.*\(([^:]+):([0-9]+)(:[0-9]+)?\)")
+(defn- guess-compiler-exception-location [#^Throwable t]
+  (when (instance? clojure.lang.Compiler$CompilerException t)
+    (let [[match file line] (re-find compiler-exception-location-re (str t))]
+      (when (and file line)
+        `(:location (:file ~file) (:line ~(Integer/parseInt line)) nil)))))
+
+;; TODO: Make more and better guesses
+(defn- exception-location [#^Throwable t]
+  (or (guess-compiler-exception-location t)
+      '(:error "No error location available")))
+
+;; plist of message, severity, location, references, short-message
+(defn- exception-to-message [#^Throwable t]
+  `(:message ~(.toString t)
+             :severity :error
+             :location ~(exception-location t)
+             :references nil
+             :short-message ~(.toString t)))
+
+(defn- compile-file-for-emacs*
+  "Compiles a file for emacs. Because clojure doesn't compile, this is
+   simple an alias for load file w/ timing and messages. This function
+   is to reply with the following:
+     (:swank-compilation-unit notes results durations)"
+  ([file-name]
+     (let [start (System/nanoTime)]
+       (try
+         (let [ret (clojure.core/load-file file-name)
+               delta (- (System/nanoTime) start)]
+           `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0)))
+         (catch Throwable t
+           (let [delta (- (System/nanoTime) start)
+                 causes (exception-causes t)
+                 num (count causes)]
+             (.printStackTrace t) ;; prints to *inferior-lisp*
+             `(:compilation-result
+               ~(map exception-to-message causes) ;; notes
+               nil ;; results
+               ~(/ delta 1000000000.0) ;; durations
+               )))))))
+
+(defslimefn compile-file-for-emacs
+  ([file-name load? & compile-options]
+     (when load?
+       (compile-file-for-emacs* file-name))))
+
+(defslimefn load-file [file-name]
+  (let [libs-ref @(resolve 'clojure.core/*loaded-libs*)
+        libs @libs-ref]
+    (try
+      (dosync (ref-set libs-ref #{}))
+      (pr-str (clojure.core/load-file file-name))
+         (finally
+          (dosync (alter libs-ref into libs))))))
+
+(defn- line-at-position [file position]
+  (try
+    (with-open [f (java.io.LineNumberReader. (java.io.FileReader. file))]
+      (.skip f position)
+      (.getLineNumber f))
+    (catch Exception e 1)))
+
+(defmacro compiler-exception [directory line ex]
+  `(eval (if (>= (:minor *clojure-version*) 5)
+           '(clojure.lang.Compiler$CompilerException.
+             ~directory ~line 0 ~ex)
+           '(clojure.lang.Compiler$CompilerException.
+             ~directory ~line ~ex))))
+
+(defslimefn compile-string-for-emacs [string buffer position directory debug]
+  (let [start (System/nanoTime)
+        line (line-at-position directory position)
+        ret (with-emacs-package
+              (when-not (= (name (ns-name *ns*)) *current-package*)
+                (throw (compiler-exception
+                        directory line
+                        (Exception. (str "No such namespace: "
+                                         *current-package*)))))
+              (compile-region string directory line))
+        delta (- (System/nanoTime) start)]
+    `(:compilation-result nil ~(pr-str ret) ~(/ delta 1000000000.0))))
+
+;;;; Describe
+
+(defn- maybe-resolve-sym [symbol-name]
+  (try
+    (ns-resolve (maybe-ns *current-package*) (symbol symbol-name))
+    (catch ClassNotFoundException e nil)))
+
+(defn- maybe-resolve-ns [sym-name]
+  (let [sym (symbol sym-name)]
+    (or ((ns-aliases (maybe-ns *current-package*)) sym)
+        (find-ns sym))))
+
+(defn- print-doc* [m]
+  (println "-------------------------")
+  (println (str (when-let [ns (:ns m)] (str (ns-name ns) "/")) (:name m)))
+  (cond
+   (:forms m) (doseq [f (:forms m)]
+                (print "  ")
+                (prn f))
+   (:arglists m) (prn (:arglists m)))
+  (if (:special-form m)
+    (do
+      (println "Special Form")
+      (println " " (:doc m))
+      (if (contains? m :url)
+        (when (:url m)
+          (println (str "\n  Please see http://clojure.org/" (:url m))))
+        (println (str "\n  Please see http://clojure.org/special_forms#"
+                      (:name m)))))
+    (do
+      (when (:macro m)
+        (println "Macro"))
+      (println " " (:doc m)))))
+
+(def print-doc (let [print-doc (resolve 'clojure.core/print-doc)]
+                 (if (or (nil? print-doc) (-> print-doc meta :private))
+                   (comp print-doc* meta)
+                   print-doc)))
+
+(defn- describe-to-string [var]
+  (with-out-str
+    (print-doc var)))
+
+(defn- describe-symbol* [symbol-name]
+  (with-emacs-package
+    (if-let [v (maybe-resolve-sym symbol-name)]
+      (if-not (class? v)
+        (describe-to-string v)))))
+
+(defslimefn describe-symbol [symbol-name]
+  (describe-symbol* symbol-name))
+
+(defslimefn describe-function [symbol-name]
+  (describe-symbol* symbol-name))
+
+;; Only one namespace... so no kinds
+(defslimefn describe-definition-for-emacs [name kind]
+  (describe-symbol* name))
+
+;; Only one namespace... so only describe symbol
+(defslimefn documentation-symbol
+  ([symbol-name default] (documentation-symbol symbol-name))
+  ([symbol-name] (describe-symbol* symbol-name)))
+
+;;;; Documentation
+
+(defn- briefly-describe-symbol-for-emacs [var]
+  (let [lines (fn [s] (.split #^String s (System/getProperty "line.separator")))
+        [_ symbol-name arglists d1 d2 & __] (lines (describe-to-string var))
+        macro? (= d1 "Macro")]
+    (list :designator symbol-name
+          (cond
+           macro? :macro
+           (:arglists (meta var)) :function
+           :else :variable)
+          (apply str (concat arglists (if macro? d2 d1))))))
+
+(defn- make-apropos-matcher [pattern case-sensitive?]
+  (let [pattern (java.util.regex.Pattern/quote pattern)
+        pat (re-pattern (if case-sensitive?
+                          pattern
+                          (format "(?i:%s)" pattern)))]
+    (fn [var] (re-find pat (pr-str var)))))
+
+(defn- apropos-symbols [string external-only? case-sensitive? package]
+  (let [packages (or (when package [package]) (all-ns))
+        matcher (make-apropos-matcher string case-sensitive?)
+        lister (if external-only? ns-publics ns-interns)]
+    (filter matcher
+            (apply concat (map (comp (partial map second) lister)
+                               packages)))))
+
+(defn- present-symbol-before
+  "Comparator such that x belongs before y in a printed summary of symbols.
+Sorted alphabetically by namespace name and then symbol name, except
+that symbols accessible in the current namespace go first."
+  [x y]
+  (let [accessible?
+        (fn [var] (= (maybe-resolve-sym (:name (meta var)))
+                     var))
+        ax (accessible? x) ay (accessible? y)]
+    (cond
+     (and ax ay) (compare (:name (meta x)) (:name (meta y)))
+     ax -1
+     ay 1
+     :else (let [nx (str (:ns (meta x))) ny (str (:ns (meta y)))]
+             (if (= nx ny)
+               (compare (:name (meta x)) (:name (meta y)))
+               (compare nx ny))))))
+
+(defslimefn apropos-list-for-emacs
+  ([name]
+     (apropos-list-for-emacs name nil))
+  ([name external-only?]
+     (apropos-list-for-emacs name external-only? nil))
+  ([name external-only? case-sensitive?]
+     (apropos-list-for-emacs name external-only? case-sensitive? nil))
+  ([name external-only? case-sensitive? package]
+     (let [package (when package
+                     (maybe-ns package))]
+       (map briefly-describe-symbol-for-emacs
+            (sort present-symbol-before
+                  (apropos-symbols name external-only? case-sensitive?
+                                   package))))))
+
+;;;; Operator messages
+(defslimefn operator-arglist [name package]
+  (try
+    (let [f (read-string name)]
+      (cond
+       (keyword? f) "([map])"
+       (symbol? f) (let [var (ns-resolve (maybe-ns package) f)]
+                     (if-let [args (and var (:arglists (meta var)))]
+                       (pr-str args)
+                       nil))
+       :else nil))
+    (catch Throwable t nil)))
+
+;;;; Package Commands
+
+(defslimefn list-all-package-names
+  ([] (map (comp str ns-name) (all-ns)))
+  ([nicknames?] (list-all-package-names)))
+
+(defslimefn set-package [name]
+  (let [ns (maybe-ns name)]
+    (in-ns (ns-name ns))
+    (list (str (ns-name ns))
+          (str (ns-name ns)))))
+
+;;;; Tracing
+
+(defonce traced-fn-map {})
+
+(def #^{:dynamic true} *trace-level* 0)
+
+(defn- indent [num]
+  (dotimes [x (+ 1 num)]
+    (print "  ")))
+
+(defn- trace-fn-call [sym f args]
+  (let [fname (symbol (str (.name (.ns sym)) "/" (.sym sym)))]
+    (indent *trace-level*)
+    (println (str *trace-level* ":")
+             (apply str (take 240 (pr-str (when fname (cons fname args)) ))))
+    (let [result (binding [*trace-level* (+ *trace-level* 1)] (apply f args))]
+      (indent *trace-level*)
+      (println (str *trace-level* ": " fname " returned " (apply str (take 240 (pr-str result)))))
+      result)))
+
+(defslimefn swank-toggle-trace [fname]
+  (when-let [sym (maybe-resolve-sym fname)]
+    (if-let [f# (get traced-fn-map sym)]
+      (do
+        (alter-var-root #'traced-fn-map dissoc sym)
+        (alter-var-root sym (constantly f#))
+        (str " untraced."))
+      (let [f# @sym]
+        (alter-var-root #'traced-fn-map assoc sym f#)
+        (alter-var-root sym
+                        (constantly
+                         (fn [& args]
+                           (trace-fn-call sym f# args))))
+        (str " traced.")))))
+
+(defslimefn untrace-all []
+  (doseq [sym (keys traced-fn-map)]
+    (swank-toggle-trace (.sym sym))))
+
+;;;; Source Locations
+(comment
+  "Sets the default directory (java's user.dir). Note, however, that
+   this will not change the search path of load-file. ")
+(defslimefn set-default-directory
+  ([directory & ignore]
+     (System/setProperty "user.dir" directory)
+     directory))
+
+
+;;;; 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)
+        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 (clean-windows-path (.getFile resource))))
+
+(defn- slime-find-resource [#^String file]
+  (if-let [resource (.getResource (clojure.lang.RT/baseLoader) file)]
+    (if (= (.getProtocol resource) "jar")
+      (slime-zip-resource resource)
+      (slime-file-resource resource))))
+
+(defn- slime-find-file [#^String file]
+  (if (.isAbsolute (File. file))
+    (list :file file)
+    (slime-find-resource file)))
+
+(defn- namespace-to-path [ns]
+  (let [#^String ns-str (name (ns-name ns))
+        last-dot-index (.lastIndexOf ns-str ".")]
+    (if (pos? last-dot-index)
+      (-> (.substring ns-str 0 last-dot-index)
+          (.replace \- \_)
+          (.replace \. \/)))))
+
+(defn- classname-to-path [class-name]
+  (namespace-to-path
+   (symbol (.replace class-name \_ \-))))
+
+
+(defn- location-in-file [path line]
+  `(:location ~path (:line ~line) nil))
+
+(defn- location-label [name type]
+  (if type
+    (str "(" type " " name ")")
+    (str name)))
+
+(defn- location [name type path line]
+  `((~(location-label name type)
+     ~(if path
+        (location-in-file path line)
+        (list :error (format "%s - definition not found." name))))))
+
+(defn- location-not-found [name type]
+  (location name type nil nil))
+
+(defn source-location-for-frame [#^StackTraceElement frame]
+  (let [line     (.getLineNumber frame)
+        filename (if (.. frame getFileName (endsWith ".java"))
+                   (.. frame getClassName (replace \. \/)
+                       (substring 0 (.lastIndexOf (.getClassName frame) "."))
+                       (concat (str File/separator (.getFileName frame))))
+                   (let [ns-path (classname-to-path
+                                  ((re-find #"(.*?)\$"
+                                            (.getClassName frame)) 1))]
+                     (if ns-path
+                       (str ns-path File/separator (.getFileName frame))
+                       (.getFileName frame))))
+        path     (slime-find-file filename)]
+    (location-in-file path line)))
+
+(defn- namespace-to-filename [ns]
+  (str (-> (str ns)
+           (.replaceAll "\\." File/separator)
+           (.replace \- \_ ))
+       ".clj"))
+
+(defn- source-location-for-meta [meta xref-type-name]
+  (location (:name meta)
+            xref-type-name
+            (slime-find-file (:file meta))
+            (:line meta)))
+
+(defn- find-ns-definition [sym-name]
+  (if-let [ns (maybe-resolve-ns sym-name)]
+    (when-let [path (slime-find-file (namespace-to-filename ns))]
+      (location ns nil path 1))))
+
+(defn- find-var-definition [sym-name]
+  (if-let [meta (meta (maybe-resolve-sym sym-name))]
+    (source-location-for-meta meta "defn")))
+
+(defslimefn find-definitions-for-emacs [name]
+  (let [sym-name (read-string name)]
+    (or (find-var-definition sym-name)
+        (find-ns-definition sym-name)
+        (location name nil nil nil))))
+
+(defn who-specializes [class]
+  (letfn [(xref-lisp [sym] ; see find-definitions-for-emacs
+                     (if-let [meta (meta sym)]
+                       (source-location-for-meta meta "method")
+                       (location-not-found (.getName sym) "method")))]
+    (let [methods (try (. class getMethods)
+                       (catch java.lang.IllegalArgumentException e nil)
+                       (catch java.lang.NullPointerException e nil))]
+      (map xref-lisp methods))))
+
+(defn who-calls [name]
+  (letfn [(xref-lisp [sym-var]        ; see find-definitions-for-emacs
+                     (when-let [meta (meta sym-var)]
+                       (source-location-for-meta meta nil)))]
+    (let [callers (xref/all-vars-who-call name) ]
+      (map first (map xref-lisp callers)))))
+
+(defslimefn xref [type name]
+  (let [sexp (maybe-resolve-sym name)]
+       (condp = type
+              :specializes (who-specializes sexp)
+              :calls   (who-calls (symbol name))
+              :callers nil
+              :not-implemented)))
+
+(defslimefn throw-to-toplevel []
+  (throw debug-quit-exception))
+
+(defn invoke-restart [restart]
+  ((nth restart 2)))
+
+(defslimefn invoke-nth-restart-for-emacs [level n]
+  ((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]
+  (build-backtrace start end))
+
+(defslimefn buffer-first-change [file-name] nil)
+
+(defn locals-for-emacs [m]
+  (sort-by second
+           (map #(list :name (name (first %)) :id 0
+                       :value (pr-str (second %))) m)))
+
+(defslimefn frame-catch-tags-for-emacs [n] nil)
+(defslimefn frame-locals-for-emacs [n]
+  (if (and (zero? n) (seq *current-env*))
+    (locals-for-emacs *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
+   (nth (.getStackTrace *current-exception*) n)))
+
+;; Older versions of slime use this instead of the above.
+(defslimefn frame-source-location-for-emacs [n]
+  (source-location-for-frame
+   (nth (.getStackTrace *current-exception*) n)))
+
+(defslimefn create-repl [target] '("user" "user"))
+
+;;; Threads
+
+(def #^{:private true} thread-list (atom []))
+
+(defn- get-root-group [#^java.lang.ThreadGroup tg]
+  (if-let [parent (.getParent tg)]
+    (recur parent)
+    tg))
+
+(defn- get-thread-list []
+  (let [rg (get-root-group (.getThreadGroup (Thread/currentThread)))
+        arr (make-array Thread (.activeCount rg))]
+    (.enumerate rg arr true)
+    (seq arr)))
+
+(defn- extract-info [#^Thread t]
+  (map str [(.getId t) (.getName t) (.getPriority t) (.getState t)]))
+
+(defslimefn list-threads
+  "Return a list (LABELS (ID NAME STATUS ATTRS ...) ...).
+LABELS is a list of attribute names and the remaining lists are the
+corresponding attribute values per thread."
+  []
+  (reset! thread-list (get-thread-list))
+  (let [labels '(id name priority state)]
+    (cons labels (map extract-info @thread-list))))
+
+;;; TODO: Find a better way, as Thread.stop is deprecated
+(defslimefn kill-nth-thread [index]
+  (when index
+    (when-let [thread (nth @thread-list index nil)]
+      (println "Thread: " thread)
+      (.stop thread))))
+
+(defslimefn quit-thread-browser []
+  (reset! thread-list []))

sources_non_forked/slimv/swank-clojure/swank/commands/completion.clj

@@ -0,0 +1,103 @@
+(ns swank.commands.completion
+  (:use (swank util core commands)
+        (swank.util string clojure java class-browse)))
+
+(defn potential-ns
+  "Returns a list of potential namespace completions for a given
+   namespace"
+  ([] (potential-ns *ns*))
+  ([ns]
+     (for [ns-sym (concat (keys (ns-aliases (ns-name ns)))
+                          (map ns-name (all-ns)))]
+       (name ns-sym))))
+
+(defn potential-var-public
+  "Returns a list of potential public var name completions for a
+   given namespace"
+  ([] (potential-var-public *ns*))
+  ([ns]
+     (for [var-sym (keys (ns-publics ns))]
+       (name var-sym))))
+
+(defn potential-var
+  "Returns a list of all potential var name completions for a given
+   namespace"
+  ([] (potential-var *ns*))
+  ([ns]
+     (for [[key v] (ns-map ns)
+           :when (var? v)]
+       (name key))))
+
+(defn potential-classes
+  "Returns a list of potential class name completions for a given
+   namespace"
+  ([] (potential-classes *ns*))
+  ([ns]
+     (for [class-sym (keys (ns-imports ns))]
+       (name class-sym))))
+
+(defn potential-dot
+  "Returns a list of potential dot method name completions for a given
+   namespace"
+  ([] (potential-dot *ns*))
+  ([ns]
+     (map #(str "." %) (set (map member-name (mapcat instance-methods (vals (ns-imports ns))))))))
+
+(defn potential-static
+  "Returns a list of potential static members for a given namespace"
+  ([#^Class class]
+     (concat (map member-name (static-methods class))
+	     (map member-name (static-fields class)))))
+
+
+(defn potential-classes-on-path
+  "Returns a list of Java class and Clojure package names found on the current
+  classpath. To minimize noise, list is nil unless a '.' is present in the search
+  string, and nested classes are only shown if a '$' is present."
+  ([symbol-string]
+	 (when (.contains symbol-string ".")
+	   (if (.contains symbol-string "$")
+		 @nested-classes
+		 @top-level-classes))))
+
+(defn resolve-class
+  "Attempts to resolve a symbol into a java Class. Returns nil on
+   failure."
+  ([sym]
+     (try
+      (let [res (resolve sym)]
+        (when (class? res)
+          res))
+      (catch Throwable t
+        nil))))
+
+
+(defn- maybe-alias [sym ns]
+  (or (resolve-ns sym (maybe-ns ns))
+      (maybe-ns ns)))
+
+(defn potential-completions [symbol-ns ns]
+  (if symbol-ns
+    (map #(str symbol-ns "/" %)
+         (if-let [class (resolve-class symbol-ns)]
+           (potential-static class)
+           (potential-var-public (maybe-alias symbol-ns ns))))
+    (concat (potential-var ns)
+            (when-not symbol-ns
+              (potential-ns))
+            (potential-classes ns)
+            (potential-dot ns))))
+
+
+(defslimefn simple-completions [symbol-string package]
+  (try
+   (let [[sym-ns sym-name] (symbol-name-parts symbol-string)
+		 potential         (concat (potential-completions (when sym-ns (symbol sym-ns)) (ns-name (maybe-ns package)))
+								   (potential-classes-on-path symbol-string))
+         matches           (seq (sort (filter #(.startsWith #^String % symbol-string) potential)))]
+     (list matches
+           (if matches
+             (reduce largest-common-prefix matches)
+             symbol-string)))
+   (catch java.lang.Throwable t
+     (list nil symbol-string))))

sources_non_forked/slimv/swank-clojure/swank/commands/contrib.clj

@@ -0,0 +1,9 @@
+(ns swank.commands.contrib
+  (:use (swank util core commands)))
+
+(defslimefn swank-require [keys]
+  (binding [*ns* (find-ns 'swank.commands.contrib)]
+    (doseq [k (if (seq? keys) keys (list keys))]
+      (try
+       (require (symbol (str "swank.commands.contrib." (name k))))
+       (catch java.io.FileNotFoundException fne nil)))))

sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj

@@ -0,0 +1,123 @@
+(ns swank.commands.contrib.swank-arglists
+  (:use (swank util core commands)))
+
+((slime-fn 'swank-require) :swank-c-p-c)
+
+;;; pos starts at 1 bc 0 is function name
+(defn position-in-arglist? [arglist pos]
+  (or (some #(= '& %) arglist)
+      (<= pos (count arglist))))
+
+;; (position-in-arglist? '[x y] 2)
+;; => true
+
+(defn highlight-position [arglist pos]
+  (if (zero? pos)
+    arglist
+    ;; i.e. not rest args
+    (let [num-normal-args (count (take-while #(not= % '&) arglist))]
+      (if (<= pos num-normal-args)
+        (into [] (concat (take (dec pos) arglist)
+                         '(===>)
+                         (list (nth arglist (dec pos)))
+                         '(<===)
+                         (drop pos arglist)))
+        (let [rest-arg? (some #(= % '&) arglist)]
+          (if rest-arg?
+            (into [] (concat (take-while #(not= % '&) arglist)
+                             '(===>)
+                             '(&)
+                             (list (last arglist))
+                             '(<===)))))))))
+
+;; (highlight-position '[x y] 0)
+;; => [===> x <=== y]
+
+(defn highlight-arglists [arglists pos]
+  (let [arglists (read-string arglists)]
+    (loop [checked []
+           current (first arglists)
+           remaining (rest arglists)]
+      (if (position-in-arglist? current pos)
+        (apply list (concat checked
+                            [(highlight-position current pos)]
+                            remaining))
+        (when (seq remaining)
+          (recur (conj checked current)
+                 (first remaining)
+                 (rest remaining)))))))
+
+;; (highlight-arglists "([x] [x & more])" 1)
+;; => ([===> x <===] [x & more])
+
+;;(defmacro dbg[x] `(let [x# ~x] (println '~x "->" x#) x#))
+
+(defn defnk-arglists? [arglists]
+  (and (not (nil? arglists ))
+       (not (vector? (first (read-string arglists))))))
+
+(defn fix-defnk-arglists [arglists]
+  (str (list (into [] (read-string arglists)))))
+
+(defn arglists-for-fname-lookup [fname]
+  ((slime-fn 'operator-arglist) fname *current-package*))
+
+(defn arglists-for-fname [fname]
+  (let [arglists (arglists-for-fname-lookup fname)]
+    ;; defnk's arglists format is (a b) instead of ([a b])
+    (if (defnk-arglists? arglists)
+      (fix-defnk-arglists arglists)
+      arglists)))
+
+(defn message-format [cmd arglists pos]
+  (str (when cmd (str cmd ": "))
+       (when arglists
+         (if pos
+           (highlight-arglists arglists pos)
+           arglists))))
+
+(defn handle-apply [raw-specs pos]
+  (let [fname (second (first raw-specs))]
+    (message-format fname (arglists-for-fname fname) (dec pos))))
+
+(defslimefn arglist-for-echo-area [raw-specs & options]
+  (let [{:keys [arg-indices
+                print-right-margin
+                print-lines]} (apply hash-map options)]
+    (if-not (and raw-specs
+                 (seq? raw-specs)
+                 (seq? (first raw-specs)))
+      nil ;; problem?
+      (let [pos (first (second options))
+            top-level? (= 1 (count raw-specs))
+            parent-pos (when-not top-level?
+                         (second (second options)))
+            fname (ffirst raw-specs)
+            parent-fname (when-not top-level?
+                           (first (second raw-specs)))
+            arglists (arglists-for-fname fname)
+            inside-binding? (and (not top-level?)
+                                 (#{"let" "binding" "doseq" "for" "loop"}
+                                  parent-fname)
+                                 (= 1 parent-pos))]
+;;         (dbg raw-specs)
+;;         (dbg options)
+        (cond
+         ;; display arglists for function being applied unless on top of apply
+         (and (= fname "apply") (not= pos 0)) (handle-apply raw-specs pos)              
+         ;; highlight binding inside binding forms unless >1 level deep
+         inside-binding? (message-format parent-fname
+                                         (arglists-for-fname parent-fname)
+                                         1)
+         :else  (message-format fname arglists pos))))))
+
+(defslimefn variable-desc-for-echo-area [variable-name]
+  (with-emacs-package
+   (or 
+    (try
+     (when-let [sym (read-string variable-name)]
+       (when-let [var (resolve sym)]
+         (when (.isBound #^clojure.lang.Var var)
+           (str variable-name " => " (var-get var)))))
+     (catch Exception e nil))
+    "")))

sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj

@@ -0,0 +1,21 @@
+(ns swank.commands.contrib.swank-c-p-c
+  (:use (swank util core commands)
+        (swank.commands completion)
+        (swank.util string clojure)
+        (swank.commands.contrib.swank-c-p-c internal)))
+
+(defslimefn completions [symbol-string package]
+  (try
+   (let [[sym-ns sym-name] (symbol-name-parts symbol-string)
+         potential         (concat
+			    (potential-completions
+			     (when sym-ns (symbol sym-ns))
+			     (ns-name (maybe-ns package)))
+			    (potential-classes-on-path symbol-string))
+         matches           (seq (sort (filter #(split-compound-prefix-match? symbol-string %) potential)))]
+     (list matches
+           (if matches
+             (reduce largest-common-prefix matches)
+             symbol-string)))
+   (catch java.lang.Throwable t
+     (list nil symbol-string))))

sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c/internal.clj

@@ -0,0 +1,59 @@
+(ns swank.commands.contrib.swank-c-p-c.internal
+  (:use (swank util core commands)
+        (swank.commands completion)
+        (swank.util string clojure)))
+
+(defn compound-prefix-match?
+  "Takes a `prefix' and a `target' string and returns whether `prefix'
+  is a compound-prefix of `target'.
+
+  Viewing each of `prefix' and `target' as a series of substrings
+  split by `split', if each substring of `prefix' is a prefix of the
+  corresponding substring in `target' then we call `prefix' a
+  compound-prefix of `target'."
+  ([split #^String prefix #^String target]
+     (let [prefixes (split prefix)
+           targets  (split target)]
+       (when (<= (count prefixes) (count targets))
+         (every? true? (map #(.startsWith #^String %1 %2) targets prefixes))))))
+
+(defn unacronym
+  "Interposes delimiter between each character of string."
+  ([delimiter #^String string]
+     (apply str (interpose delimiter string)))
+  {:tag String})
+
+(defn delimited-compound-prefix-match?
+  "Uses a delimiter as the `split' for a compound prefix match check.
+  See also: `compound-prefix-match?'"
+  ([delimiter prefix target]
+     (compound-prefix-match? #(.split #^String % (str "[" (java.util.regex.Pattern/quote delimiter) "]") -1)
+                             prefix
+                             target)))
+
+
+(defn delimited-compound-prefix-match-acronym?
+  ([delimiter prefix target]
+     (or (delimited-compound-prefix-match? delimiter prefix target)
+         (delimited-compound-prefix-match? delimiter (unacronym (first delimiter) prefix) target))))
+
+(defn camel-compound-prefix-match?
+  "Uses camel case as a delimiter for a compound prefix match check.
+
+   See also: `compound-prefix-match?'"
+  ([#^String prefix #^String target]
+     (compound-prefix-match? #(re-seq #"(?:^.|[A-Z])[^A-Z]*" %)
+                             prefix
+                             target)))
+
+(defn split-compound-prefix-match? [#^String symbol-string #^String potential]
+  (if (.startsWith symbol-string ".")
+    (and (.startsWith potential ".")
+         (camel-compound-prefix-match? symbol-string potential))
+    (let [[sym-ns sym-name] (symbol-name-parts symbol-string)
+          [pot-ns pot-name] (symbol-name-parts potential)]
+      (and (or (= sym-ns pot-ns)
+               (and sym-ns pot-ns
+                    (delimited-compound-prefix-match-acronym? "." sym-ns pot-ns)))
+           (or (delimited-compound-prefix-match-acronym? "-." sym-name pot-name)
+               (camel-compound-prefix-match? sym-name pot-name))))))

sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj

@@ -0,0 +1,428 @@
+;;; swank_fuzzy.clj --- fuzzy symbol completion, Clojure implementation.
+
+;; Original CL implementation authors (from swank-fuzzy.lisp) below,
+;; Authors: Brian Downing <bdowning@lavos.net>
+;;          Tobias C. Rittweiler <tcr@freebits.de>
+;;          and others
+
+;; This progam is based on the swank-fuzzy.lisp.
+;; Thanks the CL implementation authors for that useful software.
+
+(ns swank.commands.contrib.swank-fuzzy
+  (:use (swank util core commands))
+  (:use (swank.util clojure)))
+
+(def #^{:dynamic true} *fuzzy-recursion-soft-limit* 30)
+(defn- compute-most-completions [short full]
+  (let [collect-chunk (fn [[pcur [[pa va] ys]] [pb vb]]
+                        (let [xs (if (= (dec pb) pcur)
+                                   [[pa (str va vb)]]
+                                   [[pb vb] [pa va]])]
+                          [pb (if ys (conj xs ys) xs)]))
+        step (fn step [short full pos chunk seed limit?]
+               (cond
+                 (and (empty? full) (not (empty? short)))
+                 nil
+                 (or (empty? short) limit?)
+                 (if chunk
+                   (conj seed
+                         (second (reduce collect-chunk
+                                         [(ffirst chunk) [(first chunk)]]
+                                         (rest chunk))))
+                   seed)
+                 (= (first short) (first full))
+                 (let [seed2
+                       (step short (rest full) (inc pos) chunk seed
+                             (< *fuzzy-recursion-soft-limit* (count seed)))]
+                   (recur (rest short) (rest full) (inc pos)
+                          (conj chunk [pos (str (first short))])
+                          (if (and seed2 (not (empty? seed2)))
+                            seed2
+                            seed)
+                          false))
+                 :else
+                 (recur short (rest full) (inc pos) chunk seed false)))]
+    (map reverse (step short full 0 [] () false))))
+
+(def fuzzy-completion-symbol-prefixes "*+-%&?<")
+(def fuzzy-completion-word-separators "-/.")
+(def fuzzy-completion-symbol-suffixes "*+->?!")
+(defn- score-completion [completion short full]
+  (let [find1
+        (fn [c s]
+          (re-find (re-pattern (java.util.regex.Pattern/quote (str c))) s))
+        at-beginning? zero?
+        after-prefix?
+        (fn [pos]
+          (and (= pos 1)
+               (find1 (nth full 0) fuzzy-completion-symbol-prefixes)))
+        word-separator?
+        (fn [pos]
+          (find1 (nth full pos) fuzzy-completion-word-separators))
+        after-word-separator?
+        (fn [pos]
+          (find1 (nth full (dec pos)) fuzzy-completion-word-separators))
+        at-end?
+        (fn [pos]
+          (= pos (dec (count full))))
+        before-suffix?
+        (fn [pos]
+          (and (= pos (- (count full) 2))
+               (find1 (nth full (dec (count full)))
+                      fuzzy-completion-symbol-suffixes)))]
+    (letfn [(score-or-percentage-of-previous
+             [base-score pos chunk-pos]
+             (if (zero? chunk-pos)
+               base-score
+               (max base-score
+                    (+ (* (score-char (dec pos) (dec chunk-pos)) 0.85)
+                       (Math/pow 1.2 chunk-pos)))))
+            (score-char
+             [pos chunk-pos]
+             (score-or-percentage-of-previous
+              (cond (at-beginning? pos)         10
+                    (after-prefix? pos)         10
+                    (word-separator? pos)       1
+                    (after-word-separator? pos) 8
+                    (at-end? pos)               6
+                    (before-suffix? pos)        6
+                    :else                       1)
+              pos chunk-pos))
+            (score-chunk
+             [chunk]
+             (let [chunk-len (count (second chunk))]
+               (apply +
+                      (map score-char
+                           (take chunk-len (iterate inc (first chunk)))
+                           (reverse (take chunk-len
+                                          (iterate dec (dec chunk-len))))))))]
+      (let [chunk-scores (map score-chunk completion)
+            length-score (/ 10.0 (inc (- (count full) (count short))))]
+        [(+ (apply + chunk-scores) length-score)
+         (list (map list chunk-scores completion) length-score)]))))
+
+(defn- compute-highest-scoring-completion [short full]
+  (let [scored-results
+        (map (fn [result]
+               [(first (score-completion result short full))
+                result])
+             (compute-most-completions short full))
+        winner (first (sort (fn [[av _] [bv _]] (> av bv))
+                            scored-results))]
+    [(second winner) (first winner)]))
+
+(defn- call-with-timeout [time-limit-in-msec proc]
+  "Create a thunk that returns true if given time-limit-in-msec has been
+  elapsed and calls proc with the thunk as an argument. Returns a 3 elements
+  vec: A proc result, given time-limit-in-msec has been elapsed or not,
+  elapsed time in millisecond."
+  (let [timed-out (atom false)
+        start! (fn []
+                 (future (do
+                           (Thread/sleep time-limit-in-msec)
+                           (swap! timed-out (constantly true)))))
+        timed-out? (fn [] @timed-out)
+        started-at (System/nanoTime)]
+    (start!)
+    [(proc timed-out?)
+     @timed-out
+     (/ (double (- (System/nanoTime) started-at)) 1000000.0)]))
+
+(defmacro with-timeout
+  "Create a thunk that returns true if given time-limit-in-msec has been
+  elapsed and bind it to timed-out?. Then execute body."
+  #^{:private true}
+  [[timed-out? time-limit-in-msec] & body]
+  `(call-with-timeout ~time-limit-in-msec (fn [~timed-out?] ~@body)))
+
+(defstruct fuzzy-matching
+  :var :ns :symbol :ns-name :score :ns-chunks :var-chunks)
+
+(defn- fuzzy-extract-matching-info [matching string]
+  (let [[user-ns-name _] (symbol-name-parts string)]
+    (cond
+      (:var matching)
+      [(str (:symbol matching))
+       (cond (nil? user-ns-name) nil
+             :else (:ns-name matching))]
+      :else
+      [""
+       (str (:symbol matching))])))
+
+(defn- fuzzy-find-matching-vars
+  [string ns var-filter external-only?]
+  (let [compute (partial compute-highest-scoring-completion string)
+        ns-maps (cond
+                  external-only? ns-publics
+                  (= ns *ns*)    ns-map
+                  :else          ns-interns)]
+    (map (fn [[match-result score var sym]]
+           (if (var? var)
+             (struct fuzzy-matching
+                     var nil (or (:name (meta var))
+                                 (symbol (pr-str var)))
+                     nil
+                     score nil match-result)
+             (struct fuzzy-matching
+                     nil nil sym
+                     nil
+                     score nil match-result)))
+         (filter (fn [[match-result & _]]
+                   (or (= string "")
+                       (not-empty match-result)))
+                 (map (fn [[k v]]
+                        (if (= string "")
+                          (conj [nil 0.0] v k)
+                          (conj (compute (.toLowerCase (str k))) v k)))
+                      (filter var-filter (seq (ns-maps ns))))))))
+(defn- fuzzy-find-matching-nss
+  [string]
+  (let [compute (partial compute-highest-scoring-completion string)]
+    (map (fn [[match-result score ns ns-sym]]
+           (struct fuzzy-matching nil ns ns-sym (str ns-sym)
+                   score match-result nil))
+         (filter (fn [[match-result & _]] (not-empty match-result))
+                 (map (fn [[ns-sym ns]]
+                        (conj (compute (str ns-sym)) ns ns-sym))
+                      (concat
+                       (map (fn [ns] [(symbol (str ns)) ns]) (all-ns))
+                       (ns-aliases *ns*)))))))
+
+(defn- fuzzy-generate-matchings
+  [string default-ns timed-out?]
+  (let [take* (partial take-while (fn [_] (not (timed-out?))))
+        [parsed-ns-name parsed-symbol-name] (symbol-name-parts string)
+        find-vars
+        (fn find-vars
+          ([designator ns]
+             (find-vars designator ns identity))
+          ([designator ns var-filter]
+             (find-vars designator ns var-filter nil))
+          ([designator ns var-filter external-only?]
+             (take* (fuzzy-find-matching-vars designator
+                                              ns
+                                              var-filter
+                                              external-only?))))
+        find-nss (comp take* fuzzy-find-matching-nss)
+        make-duplicate-var-filter
+        (fn [fuzzy-ns-matchings]
+          (let [nss (set (map :ns-name fuzzy-ns-matchings))]
+            (comp not nss str :ns meta second)))
+        matching-greater
+        (fn [a b]
+          (cond
+            (> (:score a) (:score b)) -1
+            (< (:score a) (:score b)) 1
+            :else (compare (:symbol a) (:symbol b))))
+        fix-up
+        (fn [matchings parent-package-matching]
+          (map (fn [m]
+                 (assoc m
+                   :ns-name (:ns-name parent-package-matching)
+                   :ns-chunks (:ns-chunks parent-package-matching)
+                   :score (if (= parsed-ns-name "")
+                            (/ (:score parent-package-matching) 100)
+                            (+ (:score parent-package-matching)
+                               (:score m)))))
+               matchings))]
+    (sort matching-greater
+          (cond
+            (nil? parsed-ns-name)
+            (concat
+             (find-vars parsed-symbol-name (maybe-ns default-ns))
+             (find-nss parsed-symbol-name))
+            ;; (apply concat
+            ;;        (let [ns *ns*]
+            ;;          (pcalls #(binding [*ns* ns]
+            ;;                     (find-vars parsed-symbol-name
+            ;;                                (maybe-ns default-ns)))
+            ;;                  #(binding [*ns* ns]
+            ;;                     (find-nss parsed-symbol-name)))))
+            (= "" parsed-ns-name)
+            (find-vars parsed-symbol-name (maybe-ns default-ns))
+            :else
+            (let [found-nss (find-nss parsed-ns-name)
+                  find-vars1 (fn [ns-matching]
+                               (fix-up
+                                (find-vars parsed-symbol-name
+                                           (:ns ns-matching)
+                                           (make-duplicate-var-filter
+                                            (filter (partial = ns-matching)
+                                                    found-nss))
+                                           true)
+                                ns-matching))]
+              (concat
+               (apply concat
+                      (map find-vars1 (sort matching-greater found-nss)))
+               found-nss))))))
+
+(defn- fuzzy-format-matching [string matching]
+  (let [[symbol package] (fuzzy-extract-matching-info matching string)
+        result (str package (when package "/") symbol)]
+    [result (.indexOf #^String result #^String symbol)]))
+
+(defn- classify-matching [m]
+  (let [make-var-meta (fn [m]
+                        (fn [key]
+                          (when-let [var (:var m)]
+                            (when-let [var-meta (meta var)]
+                              (get var-meta key)))))
+        vm (make-var-meta m)]
+    (set
+     (filter
+      identity
+      [(when-not (or (vm :macro) (vm :arglists))
+         :boundp)
+       (when (vm :arglists) :fboundp)
+       ;; (:typespec)
+       ;; (:class)
+       (when (vm :macro)    :macro)
+       (when (special-symbol? (:symbol m)) :special-operator)
+       (when (:ns-name m)   :package)
+       (when (= clojure.lang.MultiFn (vm :tag))
+         :generic-function)]))))
+(defn- classification->string [flags]
+  (format (apply str (replicate 8 "%s"))
+          (if (or (:boundp flags)
+                  (:constant flags)) "b" "-")
+          (if (:fboundp flags) "f" "-")
+          (if (:generic-function flags) "g" "-")
+          (if (:class flags) "c" "-")
+          (if (:typespec flags) "t" "-")
+          (if (:macro flags) "m" "-")
+          (if (:special-operator flags) "s" "-")
+          (if (:package flags) "p" "-")))
+
+(defn- fuzzy-convert-matching-for-emacs [string matching]
+  (let [[name added-length] (fuzzy-format-matching string matching)]
+    [name
+     (format "%.2f" (:score matching))
+     (concat (:ns-chunks matching)
+             (map (fn [[offset string]] [(+ added-length offset) string])
+                  (:var-chunks matching)))
+     (classification->string (classify-matching matching))
+     ]))
+
+(defn- fuzzy-completion-set
+  [string default-ns limit time-limit-in-msec]
+  (let [[matchings interrupted? _]
+        (with-timeout [timed-out? time-limit-in-msec]
+          (vec (fuzzy-generate-matchings string default-ns timed-out?)))
+        subvec1 (if (and limit
+                         (> limit 0)
+                         (< limit (count matchings)))
+                  (fn [v] (subvec v 0 limit))
+                  identity)]
+    [(subvec1 (vec (map (partial fuzzy-convert-matching-for-emacs string)
+                        matchings)))
+     interrupted?]))
+
+(defslimefn fuzzy-completions
+  [string default-package-name
+   _limit limit _time-limit-in-msec time-limit-in-msec]
+  (let [[xs x] (fuzzy-completion-set string default-package-name
+                                     limit time-limit-in-msec)]
+    (list
+     (map (fn [[symbol score chunks class]]
+            (list symbol score (map (partial apply list) chunks) class))
+          xs)
+     (when x 't))))
+
+(defslimefn fuzzy-completion-selected [_ _] nil)
+
+(comment
+  (do
+    (use '[clojure.test])
+
+    (is (= '(([0 "m"] [9 "v"] [15 "b"]))
+           (compute-most-completions "mvb" "multiple-value-bind")))
+    (is (= '(([0 "zz"]) ([0 "z"] [2 "z"]) ([1 "zz"]))
+           (compute-most-completions "zz" "zzz")))
+    (is (= 103
+           (binding [*fuzzy-recursion-soft-limit* 2]
+             (count
+              (compute-most-completions "ZZZZZZ" "ZZZZZZZZZZZZZZZZZZZZZZZ")))))
+
+    (are [x p s] (= x (score-completion [[p s]] s "*multiple-value+"))
+         '[10.625 (((10 [0 "*"])) 0.625)] 0  "*"  ;; at-beginning
+         '[10.625 (((10 [1 "m"])) 0.625)] 1  "m"  ;; after-prefix
+         '[1.625 (((1 [9 "-"])) 0.625)]   9  "-"  ;; word-sep
+         '[8.625 (((8 [10 "v"])) 0.625)]  10 "v"  ;; after-word-sep
+         '[6.625 (((6 [15 "+"])) 0.625)]  15 "+"  ;; at-end
+         '[6.625 (((6 [14 "e"])) 0.625)]  14 "e"  ;; before-suffix
+         '[1.625 (((1 [2 "u"])) 0.625)]   2  "u"  ;; other
+         )
+    (is (= (+ 10 ;; m's score
+              (+ (* 10 0.85) (Math/pow 1.2 1))) ;; u's score
+           (let [[_ x]
+                 (score-completion [[1 "mu"]] "mu" "*multiple-value+")]
+             ((comp first ffirst) x)))
+        "`m''s score + `u''s score (percentage of previous which is 'm''s)")
+
+    (is (= '[([0 "zz"]) 24.7]
+           (compute-highest-scoring-completion "zz" "zzz")))
+
+    (are [to? ret to proc] (= [ret to?]
+                              (let [[x y _] (call-with-timeout to proc)]
+                                [x y]))
+         false "r" 10 (fn [_] "r")
+         true  nil 1 (fn [_] (Thread/sleep 10) nil))
+
+    (are [symbol package input] (= [symbol package]
+                                   (fuzzy-extract-matching-info
+                                    (struct fuzzy-matching
+                                            true nil
+                                            "symbol" "ns-name"
+                                            nil nil nil)
+                                    input))
+         "symbol" "ns-name" "p/*"
+         "symbol" nil "*")
+    (is (= ["" "ns-name"]
+           (fuzzy-extract-matching-info
+            (struct fuzzy-matching
+                    nil nil
+                    "ns-name" ""
+                    nil nil nil)
+            "")))
+
+    (defmacro try! #^{:private true}
+      [& body]
+      `(do
+         ~@(map (fn [x] `(try ~x (catch Throwable ~'_ nil)))
+                body)))
+
+    (try
+     (def testing-testing0 't)
+     (def #^{:private true} testing-testing1 't)
+     (are [x external-only?] (= x
+                                (vec
+                                 (sort
+                                  (map (comp str :symbol)
+                                       (fuzzy-find-matching-vars
+                                        "testing" *ns*
+                                        (fn [[k v]]
+                                          (and (= ((comp :ns meta) v) *ns*)
+                                               (re-find #"^testing-"
+                                                        (str k))))
+                                        external-only?)))))
+          ["testing-testing0" "testing-testing1"] nil
+          ["testing-testing0"] true)
+     (finally
+      (try!
+        (ns-unmap *ns* 'testing-testing0)
+        (ns-unmap *ns* 'testing-testing1))))
+
+    (try
+     (create-ns 'testing-testing0)
+     (create-ns 'testing-testing1)
+     (is (= '["testing-testing0" "testing-testing1"]
+            (vec
+             (sort
+              (map (comp str :symbol)
+                   (fuzzy-find-matching-nss "testing-"))))))
+     (finally
+      (try!
+        (remove-ns 'testing-testing0)
+        (remove-ns 'testing-testing1))))
+    )
+  )

sources_non_forked/slimv/swank-clojure/swank/commands/indent.clj

@@ -0,0 +1,100 @@
+(ns swank.commands.indent
+  (:use (swank util core)
+        (swank.core hooks connection)
+        (swank.util hooks)))
+
+(defn- need-full-indentation-update?
+  "Return true if the indentation cache should be updated for all
+   namespaces. 
+
+   This is a heuristic so as to avoid scanning all symbols from all
+   namespaces. Instead, we only check whether the set of namespaces in
+   the cache match the set of currently defined namespaces."
+  ([connection]
+     (not= (hash (all-ns))
+           (hash @(connection :indent-cache-pkg)))))
+
+(defn- find-args-body-position
+  "Given an arglist, return the number of arguments before 
+     [... & body]
+   If no & body is found, nil will be returned"
+  ([args]
+     (when (coll? args)
+       (when-let [amp-position (position '#{&} args)]
+         (when-let [body-position (position '#{body clauses} args)]
+           (when (= (inc amp-position) body-position)
+             amp-position))))))
+
+(defn- find-arglists-body-position
+  "Find the smallest body position from an arglist"
+  ([arglists]
+     (let [positions (remove nil? (map find-args-body-position arglists))]
+       (when-not (empty? positions)
+         (apply min positions)))))
+
+(defn- find-var-body-position
+  "Returns a var's :indent override or the smallest body position of a
+   var's arglists"
+  ([var]
+     (let [var-meta (meta var)]
+       (or (:indent var-meta)
+           (find-arglists-body-position (:arglists var-meta))))))
+
+(defn- var-indent-representation
+  "Returns the slime indentation representation (name . position) for
+   a given var. If there is no indentation representation, nil is
+   returned."
+  ([var]
+     (when-let [body-position (find-var-body-position var)]
+       (when (or (= body-position 'defun)
+                 (not (neg? body-position)))
+         (list (name (:name (meta var)))
+               '.
+               body-position)))))
+
+(defn- get-cache-update-for-var
+  "Checks whether a given var needs to be updated in a cache. If it
+   needs updating, return [var-name var-indentation-representation].
+   Otherwise return nil"
+  ([find-in-cache var]
+     (when-let [indent (var-indent-representation var)]
+       (let [name (:name (meta var))]
+         (when-not (= (find-in-cache name) indent)
+           [name indent])))))
+
+(defn- get-cache-updates-in-namespace
+  "Finds all cache updates needed within a namespace"
+  ([find-in-cache ns]
+     (remove nil? (map (partial get-cache-update-for-var find-in-cache) (vals (ns-interns ns))))))
+
+(defn- update-indentation-delta
+  "Update the cache and return the changes in a (symbol '. indent) list.
+   If FORCE is true then check all symbols, otherwise only check
+   symbols belonging to the buffer package"
+  ([cache-ref load-all-ns?]
+     (let [find-in-cache @cache-ref]
+       (let [namespaces (if load-all-ns? (all-ns) [(maybe-ns *current-package*)])
+             updates (mapcat (partial get-cache-updates-in-namespace find-in-cache) namespaces)]
+         (when (seq updates)
+           (dosync (alter cache-ref into updates))
+           (map second updates))))))
+
+(defn- perform-indentation-update
+  "Update the indentation cache in connection and update emacs.
+   If force is true, then start again without considering the old cache."
+  ([conn force]
+     (let [cache (conn :indent-cache)]
+       (let [delta (update-indentation-delta cache force)]
+         (dosync
+          (ref-set (conn :indent-cache-pkg) (hash (all-ns)))
+          (when (seq delta)
+            (send-to-emacs `(:indentation-update ~delta))))))))
+
+(defn- sync-indentation-to-emacs
+  "Send any indentation updates to Emacs via emacs-connection"
+  ([]
+     (perform-indentation-update
+      *current-connection*
+      (need-full-indentation-update? *current-connection*))))
+
+(add-hook pre-reply-hook #'sync-indentation-to-emacs)

sources_non_forked/slimv/swank-clojure/swank/commands/inspector.clj

@@ -0,0 +1,323 @@
+(ns swank.commands.inspector
+  (:use (swank util core commands)
+        (swank.core connection)))
+
+;;;; Inspector for basic clojure data structures
+
+;; This a mess, I'll clean up this code after I figure out exactly
+;; what I need for debugging support.
+
+(def inspectee (ref nil))
+(def inspectee-content (ref nil))
+(def inspectee-parts (ref nil))
+(def inspectee-actions (ref nil))
+(def inspector-stack (ref nil))
+(def inspector-history (ref nil))
+
+(defn reset-inspector []
+  (dosync
+   (ref-set inspectee nil)
+   (ref-set inspectee-content nil)
+   (ref-set inspectee-parts [])
+   (ref-set inspectee-actions [])
+   (ref-set inspector-stack nil)
+   (ref-set inspector-history [])))
+
+(defn inspectee-title [obj]
+  (cond
+   (instance? clojure.lang.LazySeq obj) (str "clojure.lang.LazySeq@...")
+   :else (str obj)))
+
+(defn print-part-to-string [value]
+  (let [s (inspectee-title value)
+        pos (position #{value} @inspector-history)]
+    (if pos
+      (str "#" pos "=" s)
+      s)))
+
+(defn assign-index [o dest]
+  (dosync
+   (let [index (count @dest)]
+     (alter dest conj o)
+     index)))
+
+(defn value-part [obj s]
+  (list :value (or s (print-part-to-string obj))
+        (assign-index obj inspectee-parts)))
+
+(defn action-part [label lambda refresh?]
+  (list :action label
+        (assign-index (list lambda refresh?)
+                      inspectee-actions)))
+
+(defn label-value-line
+  ([label value] (label-value-line label value true))
+  ([label value newline?]
+     (list* (str label) ": " (list :value value)
+            (if newline? '((:newline)) nil))))
+
+(defmacro label-value-line* [& label-values]
+  `(concat ~@(map (fn [[label value]]
+                    `(label-value-line ~label ~value))
+                  label-values)))
+
+;; Inspection
+
+;; This is the simple version that only knows about clojure stuff.
+;; Many of these will probably be redefined by swank-clojure-debug
+(defmulti emacs-inspect
+  (fn known-types [obj]
+    (cond
+     (map? obj) :map
+     (vector? obj) :vector
+     (var? obj) :var
+     (string? obj) :string
+     (seq? obj) :seq
+     (instance? Class obj) :class
+     (instance? clojure.lang.Namespace obj) :namespace
+     (instance? clojure.lang.ARef obj) :aref
+     (.isArray (class obj)) :array)))
+
+(defn inspect-meta-information [obj]
+  (when (> (count (meta obj)) 0)
+    (concat
+     '("Meta Information: " (:newline))
+     (mapcat (fn [[key val]]
+               `("  " (:value ~key) " = " (:value ~val) (:newline)))
+             (meta obj)))))
+
+(defmethod emacs-inspect :map [obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj))
+    ("Count" (count obj)))
+   '("Contents: " (:newline))
+   (inspect-meta-information obj)
+   (mapcat (fn [[key val]]
+             `("  " (:value ~key) " = " (:value ~val)
+               (:newline)))
+           obj)))
+
+(defmethod emacs-inspect :vector [obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj))
+    ("Count" (count obj)))
+   '("Contents: " (:newline))
+   (inspect-meta-information obj)
+   (mapcat (fn [i val]
+             `(~(str "  " i ". ") (:value ~val) (:newline)))
+           (iterate inc 0)
+           obj)))
+
+(defmethod emacs-inspect :array [obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj))
+    ("Count" (alength obj))
+    ("Component Type" (.getComponentType (class obj))))
+   '("Contents: " (:newline))
+   (mapcat (fn [i val]
+	     `(~(str "  " i ". ") (:value ~val) (:newline)))
+	   (iterate inc 0)
+	   obj)))
+
+(defmethod emacs-inspect :var [#^clojure.lang.Var obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj)))
+   (inspect-meta-information obj)
+   (when (.isBound obj)
+     `("Value: " (:value ~(var-get obj))))))
+
+(defmethod emacs-inspect :string [obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj)))
+   (inspect-meta-information obj)
+   (list (str "Value: " (pr-str obj)))))
+
+(defmethod emacs-inspect :seq [obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj)))
+   '("Contents: " (:newline))
+   (inspect-meta-information obj)
+   (mapcat (fn [i val]
+             `(~(str "   " i ". ") (:value ~val) (:newline)))
+           (iterate inc 0)
+           obj)))
+
+(defmethod emacs-inspect :default [obj]
+  (let [fields (. (class obj) getDeclaredFields)
+	names (map (memfn getName) fields)
+	get (fn [f]
+	      (try (.setAccessible f true)
+		   (catch java.lang.SecurityException e))
+	      (try (.get f obj)
+		   (catch java.lang.IllegalAccessException e
+		     "Access denied.")))
+	vals (map get fields)]
+    (concat
+     `("Type: " (:value ~(class obj)) (:newline)
+       "Value: " (:value ~obj) (:newline)
+       "---" (:newline)
+       "Fields: " (:newline))
+     (mapcat
+      (fn [name val]
+	`(~(str "  " name ": ") (:value ~val) (:newline))) names vals))))
+
+(defmethod emacs-inspect :class [#^Class obj]
+  (let [meths (. obj getMethods)
+        fields (. obj getFields)]
+    (concat
+     `("Type: " (:value ~(class obj)) (:newline)
+       "---" (:newline)
+       "Fields: " (:newline))
+     (mapcat (fn [f]
+               `("  " (:value ~f) (:newline))) fields)
+     '("---" (:newline)
+       "Methods: " (:newline))
+     (mapcat (fn [m]
+               `("  " (:value ~m) (:newline))) meths))))
+
+(defmethod emacs-inspect :aref [#^clojure.lang.ARef obj]
+  `("Type: " (:value ~(class obj)) (:newline)
+    "Value: " (:value ~(deref obj)) (:newline)))
+
+(defn ns-refers-by-ns [#^clojure.lang.Namespace ns]
+  (group-by (fn [#^clojure.lang.Var v] (. v ns))
+            (map val (ns-refers ns))))
+
+(defmethod emacs-inspect :namespace [#^clojure.lang.Namespace obj]
+  (concat
+   (label-value-line*
+    ("Class" (class obj))
+    ("Count" (count (ns-map obj))))
+   '("---" (:newline)
+     "Refer from: " (:newline))
+   (mapcat (fn [[ns refers]]
+             `("  "(:value ~ns) " = " (:value ~refers) (:newline)))
+           (ns-refers-by-ns obj))
+   (label-value-line*
+    ("Imports" (ns-imports obj))
+    ("Interns" (ns-interns obj)))))
+
+(defn inspector-content [specs]
+  (letfn [(spec-seq [seq]
+            (let [[f & args] seq]
+              (cond
+                (= f :newline) (str \newline)
+
+                (= f :value)
+                (let [[obj & [str]] args]
+                  (value-part obj str))
+
+                (= f :action)
+                (let [[label lambda & options] args
+                      {:keys [refresh?]} (apply hash-map options)]
+                  (action-part label lambda refresh?)))))
+          (spec-value [val]
+            (cond
+              (string? val) val
+              (seq? val) (spec-seq val)))]
+    (map spec-value specs)))
+
+;; Works for infinite sequences, but it lies about length. Luckily, emacs doesn't
+;; care.
+(defn content-range [lst start end]
+    (let [amount-wanted (- end start)
+          shifted (drop start lst)
+          taken (take amount-wanted shifted)
+          amount-taken (count taken)]
+      (if (< amount-taken amount-wanted)
+        (list taken (+ amount-taken start) start end)
+        ;; There's always more until we know there isn't
+        (list taken (+ end 500) start end))))
+
+(defn inspect-object [o]
+  (dosync
+   (ref-set inspectee o)
+   (alter inspector-stack conj o)
+   (when-not (filter #(identical? o %) @inspector-history)
+     (alter inspector-history conj o))
+   (ref-set inspectee-content (inspector-content (emacs-inspect o)))
+   (list :title (inspectee-title o)
+         :id (assign-index o inspectee-parts)
+         :content (content-range @inspectee-content 0 500))))
+
+(defslimefn init-inspector [string]
+  (with-emacs-package
+    (reset-inspector)
+    (inspect-object (eval (read-string string)))))
+
+(defn inspect-in-emacs [what]
+  (letfn [(send-it []
+            (with-emacs-package
+              (reset-inspector)
+              (send-to-emacs `(:inspect ~(inspect-object what)))))]
+    (cond
+      *current-connection* (send-it)
+      (comment (first @connections))
+      ;; TODO: take a second look at this, will probably need garbage collection on connections
+      (comment
+        (binding [*current-connection* (first @connections)]
+          (send-it))))))
+
+(defslimefn inspect-frame-var [frame index]
+  (if (and (zero? frame) *current-env*)
+    (let [locals *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))
+
+(defslimefn inspect-nth-part [index]
+  (with-emacs-package
+   (inspect-object ((slime-fn 'inspector-nth-part) index))))
+
+(defslimefn inspector-range [from to]
+  (content-range @inspectee-content from to))
+
+(defn ref-pop [ref]
+  (let [[f & r] @ref]
+    (ref-set ref r)
+    f))
+
+(defslimefn inspector-call-nth-action [index & args]
+  (let [[fn refresh?] (get @inspectee-actions index)]
+    (apply fn args)
+    (if refresh?
+      (inspect-object (dosync (ref-pop inspector-stack)))
+      nil)))
+
+(defslimefn inspector-pop []
+  (with-emacs-package
+   (cond
+    (rest @inspector-stack)
+    (inspect-object
+     (dosync
+      (ref-pop inspector-stack)
+      (ref-pop inspector-stack)))
+    :else nil)))
+
+(defslimefn inspector-next []
+  (with-emacs-package
+    (let [pos (position #{@inspectee} @inspector-history)]
+      (cond
+       (= (inc pos) (count @inspector-history)) nil
+       :else (inspect-object (get @inspector-history (inc pos)))))))
+
+(defslimefn inspector-reinspect []
+  (inspect-object @inspectee))
+
+(defslimefn quit-inspector []
+  (reset-inspector)
+  nil)
+
+(defslimefn describe-inspectee []
+  (with-emacs-package
+   (str @inspectee)))

sources_non_forked/slimv/swank-clojure/swank/commands/xref.clj

@@ -0,0 +1,51 @@
+(ns swank.commands.xref
+  (:use clojure.walk swank.util)
+  (:import (clojure.lang RT)
+           (java.io LineNumberReader InputStreamReader PushbackReader)))
+
+;; Yoinked and modified from clojure.contrib.repl-utils.
+;; Now takes a var instead of a sym in the current ns
+(defn- get-source-from-var
+  "Returns a string of the source code for the given symbol, if it can
+find it. This requires that the symbol resolve to a Var defined in
+a namespace for which the .clj is in the classpath. Returns nil if
+it can't find the source.
+Example: (get-source-from-var 'filter)"
+  [v] (when-let [filepath (:file (meta v))]
+        (when-let [strm (.getResourceAsStream (RT/baseLoader) filepath)]
+          (with-open [rdr (LineNumberReader. (InputStreamReader. strm))]
+            (dotimes [_ (dec (:line (meta v)))] (.readLine rdr))
+            (let [text (StringBuilder.)
+                  pbr (proxy [PushbackReader] [rdr]
+                        (read [] (let [i (proxy-super read)]
+                                   (.append text (char i))
+                                   i)))]
+              (read (PushbackReader. pbr))
+              (str text))))))
+
+(defn- recursive-contains? [coll obj]
+  "True if coll contains obj. Obj can't be a seq"
+  (not (empty? (filter #(= obj %) (flatten coll)))))
+
+(defn- does-var-call-fn [var fn]
+  "Checks if a var calls a function named 'fn"
+  (if-let [source (get-source-from-var var)]
+    (let [node (read-string source)]
+     (if (recursive-contains? node fn)
+       var
+       false))))
+
+(defn- does-ns-refer-to-var? [ns var]
+  (ns-resolve ns var))
+
+(defn all-vars-who-call [sym]
+  (filter
+   ifn?
+   (filter
+    #(identity %)
+    (map #(does-var-call-fn % sym)
+         (flatten
+          (map vals
+               (map ns-interns
+                    (filter #(does-ns-refer-to-var? % sym)
+                            (all-ns)))))))))

sources_non_forked/slimv/swank-clojure/swank/core.clj

@@ -0,0 +1,388 @@
+(ns swank.core
+  (:use (swank util commands)
+        (swank.util hooks)
+        (swank.util.concurrent thread)
+        (swank.core connection hooks threadmap))
+  (:require (swank.util.concurrent [mbox :as mb])))
+
+;; Protocol version
+(defonce protocol-version (atom "20100404"))
+
+;; Emacs packages
+(def #^{:dynamic true} *current-package*)
+
+;; current emacs eval id
+(def #^{:dynamic true} *pending-continuations* '())
+
+(def sldb-stepping-p nil)
+(def sldb-initial-frames 10)
+(def #^{:dynamic true} #^{:doc "The current level of recursive debugging."}
+  *sldb-level* 0)
+(def #^{:dynamic true} #^{:doc "The current restarts."}
+  *sldb-restarts* 0)
+
+(def #^{:doc "Include swank-clojure thread in stack trace for debugger."}
+     debug-swank-clojure false)
+
+(defonce active-threads (ref ()))
+
+(defn maybe-ns [package]
+  (cond
+   (symbol? package) (or (find-ns package) (maybe-ns 'user))
+   (string? package) (maybe-ns (symbol package))
+   (keyword? package) (maybe-ns (name package))
+   (instance? clojure.lang.Namespace package) package
+   :else (maybe-ns 'user)))
+
+(defmacro with-emacs-package [& body]
+  `(binding [*ns* (maybe-ns *current-package*)]
+     ~@body))
+
+(defmacro with-package-tracking [& body]
+  `(let [last-ns# *ns*]
+     (try
+      ~@body
+      (finally
+       (when-not (= last-ns# *ns*)
+         (send-to-emacs `(:new-package ~(str (ns-name *ns*))
+                                       ~(str (ns-name *ns*)))))))))
+
+(defmacro dothread-swank [& body]
+  `(dothread-keeping-clj [*current-connection*]
+     ~@body))
+
+;; Exceptions for debugging
+(defonce debug-quit-exception (Exception. "Debug quit"))
+(defonce debug-continue-exception (Exception. "Debug continue"))
+(defonce debug-abort-exception (Exception. "Debug abort"))
+
+(def #^{:dynamic true} #^Throwable *current-exception* nil)
+
+;; Local environment
+(def #^{:dynamic true} *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)))))
+
+;; Handle Evaluation
+(defn send-to-emacs
+    "Sends a message (msg) to emacs."
+    ([msg]
+       (mb/send @(*current-connection* :control-thread) msg)))
+
+(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]
+  (if (seq *current-env*)
+    `(let ~(vec (mapcat #(list % `(*current-env* '~%)) (keys *current-env*)))
+       ~form)
+    form))
+
+(defn eval-in-emacs-package [form]
+  (with-emacs-package
+   (eval form)))
+
+
+(defn eval-from-control
+  "Blocks for a mbox message from the control thread and executes it
+   when received. The mbox message is expected to be a slime-fn."
+  ([] (let [form (mb/receive (current-thread))]
+        (apply (ns-resolve *ns* (first form)) (rest form)))))
+
+(defn eval-loop
+  "A loop which continuosly reads actions from the control thread and
+   evaluates them (will block if no mbox message is available)."
+  ([] (continuously (eval-from-control))))
+
+(defn exception-causes [#^Throwable t]
+  (lazy-seq
+    (cons t (when-let [cause (.getCause t)]
+              (exception-causes cause)))))
+
+(defn- debug-quit-exception? [t]
+  (some #(identical? debug-quit-exception %) (exception-causes 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))))
+
+(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
+                  (and (.getMessage thrown)
+                       (.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)
+    (doall coll)
+    coll))
+
+(defn eval-for-emacs [form buffer-package id]
+  (try
+   (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))]
+         (run-hook pre-reply-hook)
+         (send-to-emacs `(:return ~(thread-name (current-thread))
+                                  (:ok ~result) ~id)))
+       ;; swank function not defined, abort
+       (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))
+   (catch Throwable t
+     ;; Thread/interrupted clears this thread's interrupted status; if
+     ;; 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)
+
+     ;; (.printStackTrace t #^java.io.PrintWriter *err*)
+
+     (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)
+      (do
+        (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
+        (throw t))
+
+      :else
+      (do
+        (set! *e t)
+        (try
+         (sldb-debug
+          nil
+          (if debug-swank-clojure t (or (.getCause t) t))
+          id)
+         ;; reply with abort
+         (finally (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))))))))
+
+(defn- add-active-thread [thread]
+  (dosync
+   (commute active-threads conj thread)))
+
+(defn- remove-active-thread [thread]
+  (dosync
+   (commute active-threads (fn [threads] (remove #(= % thread) threads)))))
+
+(defn spawn-worker-thread
+  "Spawn an thread that blocks for a single command from the control
+   thread, executes it, then terminates."
+  ([conn]
+     (dothread-swank
+       (try
+        (add-active-thread (current-thread))
+        (thread-set-name "Swank Worker Thread")
+        (eval-from-control)
+        (finally
+         (remove-active-thread (current-thread)))))))
+
+(defn spawn-repl-thread
+  "Spawn an thread that sets itself as the current
+   connection's :repl-thread and then enters an eval-loop"
+  ([conn]
+     (dothread-swank
+      (thread-set-name "Swank REPL Thread")
+      (with-connection conn
+        (eval-loop)))))
+
+(defn find-or-spawn-repl-thread
+  "Returns the current connection's repl-thread or create a new one if
+   the existing one does not exist."
+  ([conn]
+     ;; TODO - check if an existing repl-agent is still active & doesn't have errors
+     (dosync
+      (or (when-let [conn-repl-thread @(conn :repl-thread)]
+            (when (.isAlive #^Thread conn-repl-thread)
+              conn-repl-thread))
+          (ref-set (conn :repl-thread)
+                   (spawn-repl-thread conn))))))
+
+(defn thread-for-evaluation
+  "Given an id and connection, find or create the appropiate agent."
+  ([id conn]
+     (cond
+      (= id true) (spawn-worker-thread conn)
+      (= id :repl-thread) (find-or-spawn-repl-thread conn)
+      :else (find-thread id))))
+
+;; Handle control
+(defn read-loop
+  "A loop that reads from the socket (will block when no message
+   available) and dispatches the message to the control thread."
+  ([conn control]
+     (with-connection conn
+       (continuously (mb/send control (read-from-connection conn))))))
+
+(defn dispatch-event
+   "Dispatches/executes an event in the control thread's mailbox queue."
+   ([ev conn]
+      (let [[action & args] ev]
+        (cond
+         (= action :emacs-rex)
+         (let [[form-string package thread id] args
+               thread (thread-for-evaluation thread conn)]
+           (mb/send thread `(eval-for-emacs ~form-string ~package ~id)))
+
+         (= action :return)
+         (let [[thread & ret] args]
+           (binding [*print-level* nil, *print-length* nil]
+             (write-to-connection conn `(:return ~@ret))))
+
+         (one-of? action
+                  :presentation-start :presentation-end
+                  :new-package :new-features :ed :percent-apply
+                  :indentation-update
+                  :eval-no-wait :background-message :inspect)
+         (binding [*print-level* nil, *print-length* nil]
+           (write-to-connection conn ev))
+
+         (= action :write-string)
+         (write-to-connection conn ev)
+
+         (one-of? action
+                  :debug :debug-condition :debug-activate :debug-return)
+         (let [[thread & args] args]
+           (write-to-connection conn `(~action ~(thread-map-id thread) ~@args)))
+
+         (= action :emacs-interrupt)
+         (let [[thread & args] args]
+           (dosync
+            (cond
+             (and (true? thread) (seq @active-threads))
+             (.stop #^Thread (first @active-threads))
+              (= thread :repl-thread) (.stop #^Thread @(conn :repl-thread)))))
+         :else
+         nil))))
+
+;; Main loop definitions
+(defn control-loop
+  "A loop that reads from the mbox queue and runs dispatch-event on
+   it (will block if no mbox control message is available). This is
+   intended to only be run on the control thread."
+  ([conn]
+     (binding [*1 nil, *2 nil, *3 nil, *e nil]
+       (with-connection conn
+         (continuously (dispatch-event (mb/receive (current-thread)) conn))))))

sources_non_forked/slimv/swank-clojure/swank/core/connection.clj

@@ -0,0 +1,68 @@
+(ns swank.core.connection
+  (:use (swank util)
+        (swank.util sys)
+        (swank.core protocol))
+  (:import (java.net ServerSocket Socket InetAddress)
+           (java.io InputStreamReader OutputStreamWriter)))
+
+(def #^{:dynamic true} *current-connection*)
+(def default-encoding "iso-8859-1")
+
+(defmacro with-connection [conn & body]
+  `(binding [*current-connection* ~conn] ~@body))
+
+(def encoding-map
+     {"latin-1" "iso-8859-1"
+      "latin-1-unix" "iso-8859-1"
+      "iso-latin-1-unix" "iso-8859-1"
+      "iso-8859-1" "iso-8859-1"
+      "iso-8859-1-unix" "iso-8859-1"
+
+      "utf-8" "utf-8"
+      "utf-8-unix" "utf-8"
+
+      "euc-jp" "euc-jp"
+      "euc-jp-unix" "euc-jp"
+
+      "us-ascii" "us-ascii" 
+      "us-ascii-unix" "us-ascii"})
+
+(defn make-connection ;; rename to make-swank-connection
+  "Given a `socket', creates a swank connection. Accepts an optional
+   argument `encoding' to define the encoding of the connection. If
+   encoding is nil, then the default encoding will be used.
+
+   See also: `default-encoding', `start-server-socket!'"
+  ([#^Socket socket] (make-connection socket default-encoding))
+  ([#^Socket socket encoding]
+     (let [#^String
+           encoding (or (encoding-map encoding encoding) default-encoding)]
+       {:socket socket
+        :reader (InputStreamReader. (.getInputStream socket) encoding)
+        :writer (OutputStreamWriter. (.getOutputStream socket) encoding)
+        :writer-redir (ref nil)
+        
+        :indent-cache (ref {})
+        :indent-cache-pkg (ref nil)
+        
+        :control-thread (ref nil)
+        :read-thread (ref nil)
+        :repl-thread (ref nil)})))
+
+(defn read-from-connection
+  "Reads a single message from a swank-connection.
+
+   See also: `write-to-connection', `read-swank-message',
+     `make-swank-connection'"
+  ([] (read-from-connection *current-connection*))
+  ([conn]
+     (read-swank-message (conn :reader))))
+
+(defn write-to-connection
+  "Writes a single message to a swank-connection.
+
+  See also: `read-from-connection', `write-swank-message',
+    `make-swank-connection'"
+  ([msg] (write-to-connection *current-connection* msg))
+  ([conn msg]
+     (write-swank-message (conn :writer) msg)))

sources_non_forked/slimv/swank-clojure/swank/core/hooks.clj

@@ -0,0 +1,4 @@
+(ns swank.core.hooks
+  (:use (swank.util hooks)))
+
+(defhook pre-reply-hook)

sources_non_forked/slimv/swank-clojure/swank/core/protocol.clj

@@ -0,0 +1,50 @@
+(ns swank.core.protocol
+  (:use (swank util)
+        (swank.util io))
+  (:require swank.rpc))
+
+;; Read forms
+(def #^{:private true}
+     namespace-re #"(^\(:emacs-rex \([a-zA-Z][a-zA-Z0-9]+):")
+
+(defn- fix-namespace
+  "Changes the namespace of a function call from pkg:fn to ns/fn. If
+   no pkg exists, then nothing is done."
+  ([text] (.replaceAll (re-matcher namespace-re text) "$1/")))
+
+(defn write-swank-message
+  "Given a `writer' (java.io.Writer) and a `message' (typically an
+   sexp), encode the message according to the swank protocol and
+   write the message into the writer."
+  ([#^java.io.Writer writer message]
+     (swank.rpc/encode-message writer message)) 
+  {:tag String})
+
+(def read-fail-exception (Exception. "Error reading swank message"))
+
+(defn read-swank-message
+  "Given a `reader' (java.io.Reader), read the message as a clojure
+   form (typically a sexp). This method will block until a message is
+   completely transfered.
+
+   Note: This function will do some amount of Common Lisp -> clojure
+   conversions. This is due to the fact that several slime functions
+   like to treat everything it's talking to as a common lisp
+   implementation.
+     - If an :emacs-rex form is received and the first form contains a
+       common lisp package designation, this will convert it to use a
+       clojure designation.
+     - t will be converted to true
+
+   See also `write-swank-message'."
+  ([#^java.io.Reader reader]
+     (let [len  (Integer/parseInt (read-chars reader 6 read-fail-exception) 16)
+           msg  (read-chars reader len read-fail-exception)
+           form (try
+                  (read-string (fix-namespace msg))
+                  (catch Exception ex
+                    (.println System/err (format "unreadable message: %s" msg))
+                    (throw ex)))]
+       (if (seq? form)
+         (deep-replace {'t true} form)
+         form))))

sources_non_forked/slimv/swank-clojure/swank/core/server.clj

@@ -0,0 +1,102 @@
+(ns swank.core.server
+  (:use (swank util core)
+        (swank.util sys io)
+        (swank.util.concurrent thread)
+        (swank.util.net sockets)
+        (swank.core connection protocol))
+  (:import (java.io File FileReader BufferedReader InputStreamReader OutputStreamWriter)
+           (java.net Socket)))
+
+;; The swank.core.server is the layer above swank.util.net.sockets
+;;  - Manages the socket server
+;;  - Accepts and authenticates incoming connections
+;;  - Creates swank.core.connections
+;;  - Spins up new threads
+
+(defonce connections (ref []))
+
+(def slime-secret-path (str (user-home-path) File/separator ".slime-secret"))
+
+(defn- slime-secret
+  "Returns the first line from the slime-secret file, path found in
+   slime-secret-path (default: .slime-secret in the user's home
+   directory).
+
+   See also: `accept-authenticated-connection'"
+  ([] (failing-gracefully
+        (let [slime-secret-file (File. (str (user-home-path) File/separator ".slime-secret"))]
+          (when (and (.isFile slime-secret-file) (.canRead slime-secret-file))
+            (with-open [secret (BufferedReader. (FileReader. slime-secret-file))]
+              (.readLine secret)))))))
+
+(defn- accept-authenticated-connection ;; rename to authenticate-socket, takes in a connection
+  "Accepts and returns new connection if it is from an authenticated
+   machine. Otherwise, return nil.
+
+   Authentication depends on the contents of a slime-secret file on
+   both the server (swank) and the client (emacs slime). If no
+   slime-secret file is provided on the server side, all connections
+   are accepted.
+
+   See also: `slime-secret'"
+  ([#^Socket socket opts]
+     (returning [conn (make-connection socket (get opts :encoding default-encoding))]
+       (if-let [secret (slime-secret)]
+         (when-not (= (read-from-connection conn) secret)
+           (close-socket! socket))
+         conn))))
+
+(defn- make-output-redirection
+  ([conn]
+     (call-on-flush-stream
+      #(with-connection conn
+         (send-to-emacs `(:write-string ~%)))))
+  {:tag java.io.StringWriter})
+
+(defn- socket-serve [connection-serve socket opts]
+  (with-connection (accept-authenticated-connection socket opts)
+    (let [out-redir (java.io.PrintWriter. (make-output-redirection
+                                           *current-connection*))]
+      (binding [*out* out-redir
+                *err* out-redir]
+        (dosync (ref-set (*current-connection* :writer-redir) *out*))
+        (dosync (alter connections conj *current-connection*))
+        (connection-serve *current-connection*)))))
+
+;; Setup frontent
+(defn start-swank-socket-server!
+  "Starts and returns the socket server as a swank host. Takes an
+   optional set of options as a map:
+
+    :announce - an fn that will be called and provided with the
+    listening port of the newly established server. Default: none."
+  ([server connection-serve] (start-swank-socket-server! connection-serve {}))
+  ([server connection-serve options]
+     (start-server-socket! server connection-serve)
+     (when-let [announce (options :announce)]
+       (announce (.getLocalPort server)))
+     server))
+
+(defn setup-server
+  "The port it started on will be called as an argument to (announce-fn
+   port). A connection will then be created and (connection-serve conn)
+   will then be called."
+  [port announce-fn connection-serve opts]
+  (start-swank-socket-server!
+   (make-server-socket {:port    port
+                        :host    (opts :host "localhost")
+                        :backlog (opts :backlog 0)})
+   #(socket-serve connection-serve % opts)
+   {:announce announce-fn}))
+
+;; Announcement functions
+(defn simple-announce [port]
+  (println "Connection opened on local port " port))
+
+(defn announce-port-to-file
+  "Writes the given port number into a file."
+  ([#^String file port]
+     (with-open [out (new java.io.FileWriter file)]
+       (doto out
+         (.write (str port "\n"))
+         (.flush)))))

sources_non_forked/slimv/swank-clojure/swank/core/threadmap.clj

@@ -0,0 +1,29 @@
+(ns swank.core.threadmap
+  (:use (swank util)
+        (swank.util.concurrent thread)))
+
+(defonce thread-map-next-id (ref 1))
+(defonce thread-map (ref {}))
+
+(defn- thread-map-clean []
+  (doseq [[id t] @thread-map]
+    (when (or (nil? t)
+              (not (thread-alive? t)))
+      (dosync
+       (alter thread-map dissoc id)))))
+
+(defn- get-thread-id [thread]
+  (if-let [entry (find-first #(= (val %) thread) @thread-map)]
+    (key entry)
+    (let [next-id @thread-map-next-id]
+      (alter thread-map assoc next-id thread)
+      (alter thread-map-next-id inc)
+      next-id)))
+
+(defn thread-map-id [thread]
+  (returning [id (dosync (get-thread-id thread))]
+    (thread-map-clean)))
+
+(defn find-thread [id]
+  (@thread-map id))
+

sources_non_forked/slimv/swank-clojure/swank/dev.clj

@@ -0,0 +1,6 @@
+(ns swank.dev
+  (:use (swank util)))
+
+(defmacro with-swank-io [& body]
+  `(binding [*out* @(:writer-redir (first @swank.core.server/connections))]
+     ~@body))

sources_non_forked/slimv/swank-clojure/swank/loader.clj

@@ -0,0 +1,101 @@
+(ns swank.loader
+  (:require [swank.util.sys :as sys]
+            [swank.util.clojure :as clj])
+  (:import [java.io File]))
+
+(defonce #^File *swank-source-path*
+  (if-let [resource (.getResource (clojure.lang.RT/baseLoader)
+                                  #^String *file*)]
+    (.getParentFile (File. (.getFile resource)))))
+
+(defonce #^File *swank-compile-path*
+  (File. (str (sys/user-home-path)
+              File/separator
+              ".slime"
+              File/separator
+              "cljclass")))
+
+(defn file-directory? [#^File f]
+  (.isDirectory f))
+
+(defn file-last-modified [#^File f]
+  (.lastModified f))
+
+(defn all-files-in-directory [#^File f]
+  (let [list-files  (.listFiles f)
+        files       (remove file-directory? list-files)
+        directories (filter file-directory? list-files)]
+    (concat files (mapcat all-files-in-directory directories))))
+
+(defn clj-file? [#^File f]
+  (.endsWith (str f) ".clj"))
+
+(defn swank-source-files [#^File path]
+  (filter clj-file? (all-files-in-directory path)))
+
+(defn relative-path-name [#^File parent #^File file]
+  (let [file-name (str file)
+        parent-name (str parent)]
+    (when (.startsWith file-name parent-name)
+      (.substring file-name (inc (.length parent-name))))))
+
+(defn file-name-to-swank-package-sym [#^String file-name]
+  (assert (clj-file? file-name))
+  (symbol
+   (str "swank."
+        (clj/unmunge
+         (.replaceAll (.substring file-name 0 (- (.length file-name) 4))
+                      File/separator
+                      ".")))))
+
+(defn swank-packages []
+  (map #(file-name-to-swank-package-sym (relative-path-name *swank-source-path* %))
+       (swank-source-files *swank-source-path*)))
+
+(defn swank-version
+  "A likely bad way of calculating a version number for swank clojure"
+  ([]
+     (str (reduce + (map file-last-modified (swank-source-files *swank-source-path*)))
+	  "+" (clojure-version))))
+
+(defn delete-file-recursive [& paths]
+  (when-not (empty? paths)
+    (let [f #^File (first paths)]
+      (if (and f (.exists f))
+        (if (.isDirectory f)
+          (if-let [files (seq (.listFiles f))]
+            (recur (concat files paths))
+            (do
+              (.delete f)
+              (recur (rest paths))))
+          (do
+            (.delete f)
+            (recur (rest paths))))
+        (recur (rest paths))))))
+
+(defn clean-up []
+  (let [current-path (File. *swank-compile-path* (str (swank-version)))]
+    (doseq [compiled-path (.listFiles *swank-compile-path*)
+            :when (not= current-path compiled-path)]
+      (delete-file-recursive compiled-path))))
+
+(defn swank-ns? [ns]
+  (.startsWith (name (ns-name ns)) "swank."))
+
+(defn all-swank-ns []
+  (filter swank-ns? (all-ns)))
+
+(defn compile-swank [#^String path]
+  (binding [*compile-path* path]
+    (doseq [sym (swank-packages)]
+      (println "Compiling" (name sym))
+      (compile sym))))
+
+(defn init []
+  (let [path (File. *swank-compile-path* (str (swank-version)))
+        path-already-exists? (.exists path)]
+    (when-not path-already-exists?
+      (.mkdirs path))
+    (add-classpath (-> path .toURI .toURL))
+    (when-not path-already-exists?
+      (compile-swank (str path)))))

sources_non_forked/slimv/swank-clojure/swank/rpc.clj

@@ -0,0 +1,159 @@
+;;; This code has been placed in the Public Domain.  All warranties are disclaimed.
+(ns #^{:doc "Pass remote calls and responses between lisp systems using the swank-rpc protocol."
+       :author "Terje Norderhaug <terje@in-progress.com>"}
+  swank.rpc
+  (:use (swank util)
+        (swank.util io))
+  (:import (java.io Writer Reader PushbackReader StringReader)))
+
+;; ERROR HANDLING
+
+(def swank-protocol-error (Exception. "Swank protocol error."))
+
+;; LOGGING
+
+(def log-events false)
+
+(def log-output nil)
+
+(defn log-event [format-string & args]
+  (when log-events
+    (.write (or log-output *out*) (apply format format-string args))
+    (.flush (or log-output *out*))
+    nil))
+
+;; INPUT
+
+(defn- read-form
+   "Read a form that conforms to the swank rpc protocol"
+  ([#^Reader rdr]
+    (let [c (.read rdr)]
+      (condp = (char c)
+          \" (let [sb (StringBuilder.)]
+               (loop []
+                (let [c (.read rdr)]
+                 (if (= c -1)
+                   (throw (java.io.EOFException. "Incomplete reading of quoted string."))
+                   (condp = (char c)
+                     \" (str sb)
+                     \\ (do (.append sb (char (.read rdr)))
+                            (recur))
+                    (do (.append sb (char c))
+                        (recur)))))))
+          \( (loop [result []]
+               (let [form (read-form rdr)]
+                     (let [c (.read rdr)]
+                       (if (= c -1)
+                         (throw (java.io.EOFException. "Incomplete reading of list."))
+                         (condp = (char c)
+                           \) (sequence (conj result form))
+                           \space (recur (conj result form)))))))
+          \' (list 'quote (read-form rdr))
+          (let [sb (StringBuilder.)]
+            (loop [c c]
+              (if (not= c -1)
+                (condp = (char c)
+                  \\ (do (.append sb (char (.read rdr)))
+                         (recur (.read rdr)))
+                  \space (.unread rdr c)
+                  \) (.unread rdr c)
+                  (do (.append sb (char c))
+                      (recur (.read rdr))))))
+            (let [str (str sb)]
+              (cond
+                (. Character isDigit c) (Integer/parseInt str)
+                (= "nil" str) nil
+                (= "t" str) true
+                :else (symbol str))))))))
+
+(defn- read-packet
+  ([#^Reader reader]
+     (let [len (Integer/parseInt (read-chars reader 6 swank-protocol-error) 16)]
+       (read-chars reader len swank-protocol-error))))
+
+(defn decode-message
+   "Read an rpc message encoded using the swank rpc protocol."
+  ([#^Reader rdr]
+    (let [packet (read-packet rdr)]
+       (log-event "READ: %s\n" packet)
+       (try
+         (with-open [rdr (PushbackReader. (StringReader. packet))]
+           (read-form rdr))
+         (catch Exception e
+           (list :reader-error packet e))))))
+
+; (with-open [rdr (StringReader. "00001f(swank:a 123 (%b% (t nil) \"c\"))")] (decode-message rdr))
+
+
+;; OUTPUT
+
+(defmulti print-object (fn [x writer] (type x)))
+
+(defmethod print-object :default [o, #^Writer w]
+  (print-method o w))
+
+(defmethod print-object Boolean [o, #^Writer w]
+  (.write w (if o "t" "nil")))
+
+(defmethod print-object String [#^String s, #^Writer w]
+  (let [char-escape-string {\" "\\\""
+                            \\  "\\\\"}]
+    (do (.append w \")
+      (dotimes [n (count s)]
+        (let [c (.charAt s n)
+              e (char-escape-string c)]
+          (if e (.write w e) (.append w c))))
+      (.append w \"))
+  nil))
+
+(defmethod print-object clojure.lang.ISeq [o, #^Writer w]
+  (.write w "(")
+  (print-object (first o) w)
+  (doseq [item (rest o)]
+    (.write w " ")
+    (print-object item w))
+  (.write w ")"))
+
+(defn- write-form
+  ([#^Writer writer message]
+    (print-object message writer)))
+
+(defn- write-packet
+  ([#^Writer writer str]
+   (let [len (.length str)]
+    (doto writer
+          (.write (format "%06x" len))
+          (.write str)
+          (.flush)))))
+
+(defn encode-message
+  "Write an rpc message encoded using the swank rpc protocol."
+  ([#^Writer writer message]
+     (let [str (with-out-str
+                  (write-form *out* message)) ]
+       (log-event "WRITE: %s\n" str)
+       (write-packet writer str))))
+
+; (with-out-str (encode-message *out* "hello"))
+; (with-out-str (encode-message *out* '(a 123 (swank:b (true false) "c"))))
+
+
+;; DISPATCH
+
+(defonce rpc-fn-map {})
+
+(defn register-dispatch
+  ([name fn]
+    (register-dispatch name fn #'rpc-fn-map))
+  ([name fn fn-map]
+    (alter-var-root fn-map assoc name fn)))
+
+(defn dispatch-message
+  ([message fn-map]
+    (let [operation (first message)
+          operands (rest message)
+          fn (fn-map operation)]
+        (assert fn)
+        (apply fn operands)))
+  ([message]
+   (dispatch-message message rpc-fn-map)))

sources_non_forked/slimv/swank-clojure/swank/swank.clj

@@ -0,0 +1,92 @@
+;;;; swank-clojure.clj --- Swank server for Clojure
+;;;
+;;; Copyright (C) 2008 Jeffrey Chu
+;;;
+;;; This file is licensed under the terms of the GNU General Public
+;;; License as distributed with Emacs (press C-h C-c to view it).
+;;;
+;;; See README file for more information about installation
+;;;
+
+(ns swank.swank
+  (:use [swank.core]
+        [swank.core connection server]
+        [swank.util.concurrent thread]
+        [swank.util.net sockets]
+        [clojure.main :only [repl]])
+  (:require [swank.commands]
+            [swank.commands basic indent completion
+             contrib inspector])
+  (:import [java.lang System]
+           [java.io File])
+  (:gen-class))
+
+(defn ignore-protocol-version [version]
+  (reset! protocol-version version))
+
+(defn- connection-serve [conn]
+  (let [control
+        (dothread-swank
+          (thread-set-name "Swank Control Thread")
+          (try
+           (control-loop conn)
+           (catch Exception e
+             ;; fail silently
+             nil))
+          (close-socket! (conn :socket)))
+        read
+        (dothread-swank
+          (thread-set-name "Read Loop Thread")
+          (try
+           (read-loop conn control)
+           (catch Exception e
+             ;; This could be put somewhere better
+             (.println System/err "exception in read loop")
+             (.printStackTrace e)
+             (.interrupt control)
+             (dosync (alter connections (partial remove #{conn}))))))]
+    (dosync
+     (ref-set (conn :control-thread) control)
+     (ref-set (conn :read-thread) read))))
+
+(defn start-server
+  "Start the server and write the listen port number to
+   PORT-FILE. This is the entry point for Emacs."
+  [port-file & opts]
+  (let [opts (apply hash-map opts)]
+    (setup-server (get opts :port 0)
+                  (fn announce-port [port]
+                    (announce-port-to-file port-file port)
+                    (simple-announce port))
+                  connection-serve
+                  opts)))
+
+(def #^{:private true} encodings-map
+  {"UTF-8" "utf-8-unix"
+   })
+
+(defn- get-system-encoding []
+  (when-let [enc-name (.name (java.nio.charset.Charset/defaultCharset))]
+    (encodings-map enc-name)))
+
+(defn start-repl
+  "Start the server wrapped in a repl. Use this to embed swank in your code."
+  ([port & opts]
+     (let [stop (atom false)
+           opts (merge {:port (Integer. port)
+                        :encoding (or (System/getProperty "swank.encoding")
+                                      (get-system-encoding)
+                                      "iso-latin-1-unix")}
+                       (apply hash-map opts))]
+       (repl :read (fn [rprompt rexit]
+                     (if @stop rexit
+                         (do (reset! stop true)
+                             `(start-server (-> "java.io.tmpdir"
+                                                (System/getProperty)
+                                                (File. "slime-port.txt")
+                                                (.getCanonicalPath))
+                                            ~@(apply concat opts)))))
+             :need-prompt (constantly false))))
+  ([] (start-repl 4005)))
+
+(def -main start-repl)

sources_non_forked/slimv/swank-clojure/swank/util.clj

@@ -0,0 +1,72 @@
+(ns swank.util
+  (:import (java.io StringReader)
+           (clojure.lang LineNumberingPushbackReader)))
+
+(defmacro one-of?
+  "Short circuiting value comparison."
+  ([val & possible]
+     (let [v (gensym)]
+       `(let [~v ~val]
+          (or ~@(map (fn [p] `(= ~v ~p)) possible))))))
+
+(defn find-first
+  "Returns the first entry in a coll matches a given predicate."
+  ([coll] (find-first identity coll))
+  ([pred coll]
+     (first (filter pred coll))))
+
+(defn position
+  "Finds the first position of an item that matches a given predicate
+   within col. Returns nil if not found. Optionally provide a start
+   offset to search from."
+  ([pred coll] (position pred coll 0))
+  ([pred coll start]
+     (loop [coll (drop start coll), i start]
+       (when (seq coll)
+         (if (pred (first coll))
+           i
+           (recur (rest coll) (inc i))))))
+  {:tag Integer})
+
+(when-not (ns-resolve 'clojure.core 'group-by)
+  ;; TODO: not sure why eval is necessary here; breaks without it.
+  (eval '(defn group-by
+           "Categorizes elements within a coll into a map based on a function."
+           ([f coll]
+              (reduce
+               (fn [ret x]
+                 (let [k (f x)]
+                   (assoc ret k (conj (get ret k []) x))))
+               {})))))
+
+(when-not (ns-resolve 'clojure.core 'flatten)
+  (eval '(defn flatten [x]
+           (filter (complement sequential?)
+                   (rest (tree-seq sequential? seq x))))))
+
+(defmacro returning [[var ret] & body]
+  `(let [~var ~ret]
+     ~@body
+     ~var))
+
+
+(defn deep-replace [smap coll]
+  (map #(if (or (seq? %) (vector? %))
+          (deep-replace smap %)
+          %)
+       (replace smap coll)))
+
+(defmacro keep-bindings [bindings f]
+  (let [bind-vars (take (count bindings) (repeatedly gensym))]
+    `(let [~@(interleave bind-vars bindings)]
+       (fn [& args#]
+         (binding [~@(interleave bindings bind-vars)]
+           (apply ~f args#))))))
+
+(defmacro continuously [& body]
+  `(loop [] ~@body (recur)))
+
+(defmacro failing-gracefully [& body]
+  `(try
+    ~@body
+    (catch Throwable _# nil)))

sources_non_forked/slimv/swank-clojure/swank/util/class_browse.clj

@@ -0,0 +1,149 @@
+;;; class-browse.clj -- Java classpath and Clojure namespace browsing
+
+;; by Jeff Valk
+;; created 2009-10-14
+
+;; Scans the classpath for all class files, and provides functions for
+;; categorizing them.
+
+;; See the following for JVM classpath and wildcard expansion rules:
+;;   http://java.sun.com/javase/6/docs/technotes/tools/findingclasses.html
+;;   http://java.sun.com/javase/6/docs/technotes/tools/solaris/classpath.html
+
+(ns swank.util.class-browse
+  "Provides Java classpath and (compiled) Clojure namespace browsing.
+  Scans the classpath for all class files, and provides functions for
+  categorizing them. Classes are resolved on the start-up classpath only.
+  Calls to 'add-classpath', etc are not considered.
+
+  Class information is built as a list of maps of the following keys:
+    :name  Java class or Clojure namespace name
+    :loc   Classpath entry (directory or jar) on which the class is located
+    :file  Path of the class file, relative to :loc"
+  (:import [java.io File FilenameFilter]
+           [java.util StringTokenizer]
+           [java.util.jar JarFile JarEntry]
+           [java.util.regex Pattern]))
+
+;;; Class file naming, categorization
+
+(defn jar-file? [#^String n] (.endsWith n ".jar"))
+(defn class-file? [#^String n] (.endsWith n ".class"))
+(defn clojure-ns-file? [#^String n] (.endsWith n "__init.class"))
+(defn clojure-fn-file? [#^String n] (re-find #"\$.*__\d+\.class" n))
+(defn top-level-class-file? [#^String n] (re-find #"^[^\$]+\.class" n))
+(defn nested-class-file? [#^String n]
+  ;; ^ excludes anonymous classes
+  (re-find #"^[^\$]+(\$[^\d]\w*)+\.class" n))
+
+(def clojure-ns? (comp clojure-ns-file? :file))
+(def clojure-fn? (comp clojure-fn-file? :file))
+(def top-level-class? (comp top-level-class-file? :file))
+(def nested-class? (comp nested-class-file? :file))
+
+(defn class-or-ns-name
+  "Returns the Java class or Clojure namespace name for a class relative path."
+  [#^String n]
+  (.replace
+   (if (clojure-ns-file? n)
+     (-> n (.replace "__init.class" "") (.replace "_" "-"))
+     (.replace n ".class" ""))
+   File/separator "."))
+
+;;; Path scanning
+
+(defmulti path-class-files
+  "Returns a list of classes found on the specified path location
+  (jar or directory), each comprised of a map with the following keys:
+    :name  Java class or Clojure namespace name
+    :loc   Classpath entry (directory or jar) on which the class is located
+    :file  Path of the class file, relative to :loc"
+  (fn [#^ File f _]
+    (cond (.isDirectory f)           :dir
+          (jar-file? (.getName f))   :jar
+          (class-file? (.getName f)) :class)))
+
+(defmethod path-class-files :default
+  [& _] [])
+
+(defmethod path-class-files :jar
+  ;; Build class info for all jar entry class files.
+  [#^File f #^File loc]
+  (let [lp (.getPath loc)]
+    (try
+     (map (fn [fp] {:loc lp :file fp :name (class-or-ns-name fp)})
+          (filter class-file?
+                  (map #(.getName #^JarEntry %)
+                       (enumeration-seq (.entries (JarFile. f))))))
+     (catch Exception e []))))          ; fail gracefully if jar is unreadable
+
+(defmethod path-class-files :dir
+  ;; Dispatch directories and files (excluding jars) recursively.
+  [#^File d #^File loc]
+  (let [fs (.listFiles d (proxy [FilenameFilter] []
+                           (accept [d n] (not (jar-file? n)))))]
+    (reduce concat (for [f fs] (path-class-files f loc)))))
+
+(defmethod path-class-files :class
+  ;; Build class info using file path relative to parent classpath entry
+  ;; location. Make sure it decends; a class can't be on classpath directly.
+  [#^File f #^File loc]
+  (let [fp (.getPath f), lp (.getPath loc)
+        m (re-matcher (re-pattern (Pattern/quote
+                                   (str "^" lp File/separator))) fp)]
+    (if (not (.find m))                 ; must be descendent of loc
+      []
+      (let [fpr (.substring fp (.end m))]
+        [{:loc lp :file fpr :name (class-or-ns-name fpr)}]))))
+
+;;; Classpath expansion
+
+(def java-version
+     (Float/parseFloat (.substring (System/getProperty "java.version") 0 3)))
+
+(defn expand-wildcard
+  "Expands a wildcard path entry to its matching .jar files (JDK 1.6+).
+  If not expanding, returns the path entry as a single-element vector."
+  [#^String path]
+  (let [f (File. path)]
+    (if (and (= (.getName f) "*") (>= java-version 1.6))
+      (-> f .getParentFile
+          (.list (proxy [FilenameFilter] []
+                   (accept [d n] (jar-file? n)))))
+      [f])))
+
+(defn scan-paths
+  "Takes one or more classpath strings, scans each classpath entry location, and
+  returns a list of all class file paths found, each relative to its parent
+  directory or jar on the classpath."
+  ([cp]
+     (if cp
+       (let [entries (enumeration-seq
+                      (StringTokenizer. cp File/pathSeparator))
+             locs (mapcat expand-wildcard entries)]
+         (reduce concat (for [loc locs] (path-class-files loc loc))))
+       ()))
+  ([cp & more]
+     (reduce #(concat %1 (scan-paths %2)) (scan-paths cp) more)))
+
+;;; Class browsing
+
+(def available-classes
+     (filter (complement clojure-fn?)  ; omit compiled clojure fns
+             (scan-paths (System/getProperty "sun.boot.class.path")
+                         (System/getProperty "java.ext.dirs")
+                         (System/getProperty "java.class.path"))))
+
+;; Force lazy seqs before any user calls, and in background threads; there's
+;; no sense holding up SLIME init. (It's usually quick, but a monstrous
+;; classpath could concievably take a while.)
+
+(def top-level-classes
+     (future (doall (map (comp class-or-ns-name :name)
+                         (filter top-level-class?
+                                 available-classes)))))
+
+(def nested-classes
+     (future (doall (map (comp class-or-ns-name :name)
+                         (filter nested-class?
+                                 available-classes)))))

sources_non_forked/slimv/swank-clojure/swank/util/clojure.clj

@@ -0,0 +1,33 @@
+(ns swank.util.clojure)
+
+(defn unmunge
+  "Converts a javafied name to a clojure symbol name"
+  ([#^String name]
+     (reduce (fn [#^String s [to from]]
+               (.replaceAll s from (str to)))
+             name
+             clojure.lang.Compiler/CHAR_MAP)))
+
+(defn ns-path
+  "Returns the path form of a given namespace"
+  ([#^clojure.lang.Namespace ns]
+     (let [#^String ns-str (name (ns-name ns))]
+       (-> ns-str
+           (.substring 0 (.lastIndexOf ns-str "."))
+           (.replace \- \_)
+           (.replace \. \/)))))
+
+(defn symbol-name-parts
+  "Parses a symbol name into a namespace and a name. If name doesn't
+   contain a namespace, the default-ns is used (nil if none provided)."
+  ([symbol]
+     (symbol-name-parts symbol nil))
+  ([#^String symbol default-ns]
+     (let [ns-pos (.indexOf symbol (int \/))]
+       (if (= ns-pos -1) ;; namespace found? 
+         [default-ns symbol] 
+         [(.substring symbol 0 ns-pos) (.substring symbol (inc ns-pos))]))))
+
+(defn resolve-ns [sym ns]
+  (or (find-ns sym)
+      (get (ns-aliases ns) sym))) 

sources_non_forked/slimv/swank-clojure/swank/util/concurrent/mbox.clj

@@ -0,0 +1,31 @@
+(ns swank.util.concurrent.mbox
+  (:refer-clojure :exclude [send get]))
+
+;; Holds references to the mailboxes (message queues)
+(defonce mailboxes (ref {}))
+
+(defn get
+  "Returns the mailbox for a given id. Creates one if one does not
+   already exist."
+  ([id]
+     (dosync
+      (when-not (@mailboxes id)
+        (alter mailboxes assoc
+               id (java.util.concurrent.LinkedBlockingQueue.))))
+     (@mailboxes id))
+  {:tag java.util.concurrent.LinkedBlockingQueue})
+
+(defn send
+  "Sends a message to a given id."
+  ([id message]
+     (let [mbox (get id)]
+       (.put mbox message))))
+
+(defn receive
+  "Blocking recieve for messages for the given id."
+  ([id]
+     (let [mb (get id)]
+       (.take mb))))
+
+(defn clean []
+  )

sources_non_forked/slimv/swank-clojure/swank/util/concurrent/thread.clj

@@ -0,0 +1,50 @@
+(ns swank.util.concurrent.thread
+  (:use (swank util)))
+
+(defn- gen-name []
+  (name (gensym "Thread-")))
+
+(defn start-thread
+  "Starts a thread that run the given function f"
+  ([#^Runnable f]
+     (doto (Thread. f)
+       (.start))))
+
+(defmacro dothread [& body]
+  `(start-thread (fn [] ~@body)))
+
+(defmacro dothread-keeping [bindings & body]
+  `(start-thread (keep-bindings ~bindings (fn [] ~@body))))
+
+(defmacro dothread-keeping-clj [more-bindings & body]
+  (let [clj-star-syms (filter #(or (= (name %) "*e")
+                                   (= (name %) "*1")
+                                   (= (name %) "*2")
+                                   (= (name %) "*3")
+                                   (and (.startsWith #^String (name %) "*")
+                                        (.endsWith #^String (name %) "*")
+                                        (> (count (name %)) 1)))
+                              (keys (ns-publics (find-ns 'clojure.core))))]
+    `(dothread-keeping [~@clj-star-syms ~@more-bindings]
+       ~@body)))
+
+(defn current-thread []
+  (Thread/currentThread))
+
+(defn thread-set-name
+  ([name] (thread-set-name (current-thread) name))
+  ([#^Thread thread name]
+     (.setName thread name)))
+
+(defn thread-name
+  ([] (thread-name (current-thread)))
+  ([#^Thread thread]
+     (.getName thread)))
+
+(defn thread-id
+  ([] (thread-id (current-thread)))
+  ([#^Thread thread]
+     (.getId thread)))
+
+(defn thread-alive? [#^Thread t]
+  (.isAlive t))

sources_non_forked/slimv/swank-clojure/swank/util/hooks.clj

@@ -0,0 +1,12 @@
+(ns swank.util.hooks)
+
+(defmacro defhook [name & hooks]
+  `(defonce ~name (ref (list ~@hooks))))
+
+;;;; Hooks
+(defn add-hook [place function]
+  (dosync (alter place conj function)))
+
+(defn run-hook [functions & arguments]
+  (doseq [f @functions]
+    (apply f arguments)))

sources_non_forked/slimv/swank-clojure/swank/util/io.clj

@@ -0,0 +1,40 @@
+(ns swank.util.io
+  (:use [swank util]
+        [swank.util.concurrent thread])
+  (:import [java.io StringWriter Reader PrintWriter]))
+
+(defn read-chars
+  ([rdr n] (read-chars rdr n false))
+  ([#^Reader rdr n throw-exception]
+     (let [cbuf (make-array Character/TYPE n)]
+       (loop [i 0]
+	 (let [size (.read rdr cbuf i (- n i))]
+	   (cond
+	    (neg? size) (if throw-exception
+			  (throw throw-exception)
+			  (String. cbuf 0 i))
+	    (= (+ i size) n) (String. cbuf)
+	    :else (recur (+ i size))))))))
+
+(defn call-on-flush-stream
+  "Creates a stream that will call a given function when flushed."
+  ([flushf]
+     (let [closed? (atom false)
+           #^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
+         (Thread/sleep 200)
+         (when-not @closed?
+           (.flush stream))))
+       stream))
+  {:tag PrintWriter})

sources_non_forked/slimv/swank-clojure/swank/util/java.clj

@@ -0,0 +1,16 @@
+(ns swank.util.java)
+
+(defn member-name [#^java.lang.reflect.Member member]
+  (.getName member))
+
+(defn member-static? [#^java.lang.reflect.Member member]
+  (java.lang.reflect.Modifier/isStatic (.getModifiers member)))
+
+(defn static-methods [#^Class class]
+  (filter member-static? (.getMethods class)))
+
+(defn static-fields [#^Class class]
+  (filter member-static? (.getDeclaredFields class)))
+
+(defn instance-methods [#^Class class]
+  (remove member-static? (.getMethods class)))

sources_non_forked/slimv/swank-clojure/swank/util/net/sockets.clj

@@ -0,0 +1,57 @@
+(ns swank.util.net.sockets
+  (:use (swank util)
+        (swank.util.concurrent thread))
+  (:import (java.net ServerSocket Socket SocketException InetAddress)))
+
+(defn make-server-socket
+  "Create a java.net.ServerSocket. A map of `options':
+
+    :port - The port which this ServerSocket will listen on. It must
+       be a number between 0-65535. If 0 or not provided, the server
+       will be created on any free port.
+
+    :host - The address the server will bind to, can be used on multi
+      homed hosts. This can be an InetAddress or a hostname string. If
+      not provided or nil, it will listen on all addresses.
+
+    :backlog - The maximum queue length of incoming connection
+      indications (ie. connection requests). If the queue is full, new
+      indications will be refused. If set to less than or equal to 0,
+      the default value will be used."
+  ([] (ServerSocket.))
+  ([options] (ServerSocket. (options :port 0)
+                            (options :backlog 0)
+                            (when-let [host (options :host)]
+                              (if (instance? InetAddress host)
+                                host
+                                (InetAddress/getByName host))))))
+
+(defn start-server-socket!
+  "Given a `server-socket' (java.net.ServerSocket), call
+   `handle-socket' for each new connection and provide current
+   socket.
+
+   This will return immediately with the Thread that is blocking for
+   new connections. Use Thread.join() if you need to wait for the
+   server to close."
+  ([server-socket handle-socket]
+     (dothread-keeping-clj nil
+       (thread-set-name (str "Socket Server [" (thread-id) "]"))
+       (with-open [#^ServerSocket server server-socket]
+         (while (not (.isClosed server))
+           (handle-socket (.accept server)))))))
+
+(defn close-socket!
+  "Cleanly shutdown and close a java.net.Socket. This will not affect
+   an already running instance of SocketServer."
+  ([#^Socket socket]
+     (doto socket
+       (.shutdownInput)
+       (.shutdownOutput)
+       (.close))))
+
+(defn close-server-socket!
+  "Shutdown a java.net.SocketServer. Existing connections will
+  persist."
+  ([#^ServerSocket server]
+     (.close server)))

sources_non_forked/slimv/swank-clojure/swank/util/string.clj

@@ -0,0 +1,16 @@
+(ns swank.util.string)
+
+(defn largest-common-prefix
+  "Returns the largest common prefix of two strings."
+  ([#^String a, #^String b]
+     (apply str (take-while (comp not nil?) (map #(when (= %1 %2) %1) a b))))
+  {:tag String})
+
+(defn char-position
+  "Finds the position of a character within a string, optionally
+   provide a starting index. Returns nil if none is found."
+  ([c str] (char-position c str 0))
+  ([#^Character c #^String str #^Integer start]
+     (let [idx (.indexOf str (int c) start)]
+       (when (not= -1 idx)
+         idx))))

sources_non_forked/slimv/swank-clojure/swank/util/sys.clj

@@ -0,0 +1,13 @@
+(ns swank.util.sys)
+
+(defn get-pid
+  "Returns the PID of the JVM. This is largely a hack and may or may
+   not be accurate depending on the JVM in which clojure is running
+   off of."
+  ([]
+     (or (first (.. java.lang.management.ManagementFactory (getRuntimeMXBean) (getName) (split "@")))
+         (System/getProperty "pid")))
+  {:tag String})
+
+(defn user-home-path []
+  (System/getProperty "user.home"))