ld/amix-vimrc-mirror
1
0
Fork 0
mirror of https://github.com/amix/vimrc synced 2025-07-09 02:25:00 +08:00
Code Issues Packages Projects Releases Wiki Activity

Add support for Scheme and Racket language.

Browse Source
This commit is contained in:
Kurtis Moxley
2022-06-05 18:14:25 +08:00
parent ea73a5a99d
commit e371e16382
129 changed files with 67865 additions and 587 deletions
Download Patch File Download Diff File Expand all files Collapse all files

227
sources_non_forked/slimv/swank-clojure/COPYING Normal file
View File

@ -0,0 +1,227 @@
Eclipse Public License - v 1.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF
THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial code and
documentation distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from and
are distributed by that particular Contributor. A Contribution
'originates' from a Contributor if it was added to the Program by such
Contributor itself or anyone acting on such Contributor's
behalf. Contributions do not include additions to the Program which:
(i) are separate modules of software distributed in conjunction with
the Program under their own license agreement, and (ii) are not
derivative works of the Program.
"Contributor" means any person or entity that distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor
which are necessarily infringed by the use or sale of its Contribution
alone or when combined with the Program.
"Program" means the Contributions distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this
Agreement, including all Contributors.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare derivative works of, publicly display,
publicly perform, distribute and sublicense the Contribution of such
Contributor, if any, and such derivative works, in source code and
object code form.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent
license under Licensed Patents to make, use, sell, offer to sell,
import and otherwise transfer the Contribution of such Contributor, if
any, in source code and object code form. This patent license shall
apply to the combination of the Contribution and the Program if, at
the time the Contribution is added by the Contributor, such addition
of the Contribution causes such combination to be covered by the
Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity. Each
Contributor disclaims any liability to Recipient for claims brought by
any other entity based on infringement of intellectual property rights
or otherwise. As a condition to exercising the rights and licenses
granted hereunder, each Recipient hereby assumes sole responsibility
to secure any other intellectual property rights needed, if any. For
example, if a third party patent license is required to allow
Recipient to distribute the Program, it is Recipient's responsibility
to acquire that license before distributing the Program.
d) Each Contributor represents that to its knowledge it has sufficient
copyright rights in its Contribution, if any, to grant the copyright
license set forth in this Agreement.
3. REQUIREMENTS
A Contributor may choose to distribute the Program in object code form
under its own license agreement, provided that:
a) it complies with the terms and conditions of this Agreement; and
b) its license agreement:
i) effectively disclaims on behalf of all Contributors all warranties
and conditions, express and implied, including warranties or
conditions of title and non-infringement, and implied warranties or
conditions of merchantability and fitness for a particular purpose;
ii) effectively excludes on behalf of all Contributors all liability
for damages, including direct, indirect, special, incidental and
consequential damages, such as lost profits;
iii) states that any provisions which differ from this Agreement are
offered by that Contributor alone and not by any other party; and
iv) states that source code for the Program is available from such
Contributor, and informs licensees how to obtain it in a reasonable
manner on or through a medium customarily used for software exchange.
When the Program is made available in source code form:
a) it must be made available under this Agreement; and
b) a copy of this Agreement must be included with each copy of the Program.
Contributors may not remove or alter any copyright notices contained
within the Program.
Each Contributor must identify itself as the originator of its
Contribution, if any, in a manner that reasonably allows subsequent
Recipients to identify the originator of the Contribution.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain
responsibilities with respect to end users, business partners and the
like. While this license is intended to facilitate the commercial use
of the Program, the Contributor who includes the Program in a
commercial product offering should do so in a manner which does not
create potential liability for other Contributors. Therefore, if a
Contributor includes the Program in a commercial product offering,
such Contributor ("Commercial Contributor") hereby agrees to defend
and indemnify every other Contributor ("Indemnified Contributor")
against any losses, damages and costs (collectively "Losses") arising
from claims, lawsuits and other legal actions brought by a third party
against the Indemnified Contributor to the extent caused by the acts
or omissions of such Commercial Contributor in connection with its
distribution of the Program in a commercial product offering. The
obligations in this section do not apply to any claims or Losses
relating to any actual or alleged intellectual property
infringement. In order to qualify, an Indemnified Contributor must: a)
promptly notify the Commercial Contributor in writing of such claim,
and b) allow the Commercial Contributor tocontrol, and cooperate with
the Commercial Contributor in, the defense and any related settlement
negotiations. The Indemnified Contributor may participate in any such
claim at its own expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those
performance claims and warranties, and if a court requires any other
Contributor to pay any damages as a result, the Commercial Contributor
must pay those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY
WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
responsible for determining the appropriateness of using and
distributing the Program and assumes all risks associated with its
exercise of rights under this Agreement , including but not limited to
the risks and costs of program errors, compliance with applicable
laws, damage to or loss of data, programs or equipment, and
unavailability or interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR
ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further
action by the parties hereto, such provision shall be reformed to the
minimum extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that
the Program itself (excluding combinations of the Program with other
software or hardware) infringes such Recipient's patent(s), then such
Recipient's rights granted under Section 2(b) shall terminate as of
the date such litigation is filed.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of
time after becoming aware of such noncompliance. If all Recipient's
rights under this Agreement terminate, Recipient agrees to cease use
and distribution of the Program as soon as reasonably
practicable. However, Recipient's obligations under this Agreement and
any licenses granted by Recipient relating to the Program shall
continue and survive.
Everyone is permitted to copy and distribute copies of this Agreement,
but in order to avoid inconsistency the Agreement is copyrighted and
may only be modified in the following manner. The Agreement Steward
reserves the right to publish new versions (including revisions) of
this Agreement from time to time. No one other than the Agreement
Steward has the right to modify this Agreement. The Eclipse Foundation
is the initial Agreement Steward. The Eclipse Foundation may assign
the responsibility to serve as the Agreement Steward to a suitable
separate entity. Each new version of the Agreement will be given a
distinguishing version number. The Program (including Contributions)
may always be distributed subject to the version of the Agreement
under which it was received. In addition, after a new version of the
Agreement is published, Contributor may elect to distribute the
Program (including its Contributions) under the new version. Except as
expressly stated in Sections 2(a) and 2(b) above, Recipient receives
no rights or licenses to the intellectual property of any Contributor
under this Agreement, whether expressly, by implication, estoppel or
otherwise. All rights in the Program not expressly granted under this
Agreement are reserved.
This Agreement is governed by the laws of the State of Washington and
the intellectual property laws of the United States of America. No
party to this Agreement will bring a legal action under this Agreement
more than one year after the cause of action arose. Each party waives
its rights to a jury trial in any resulting litigation.

152
sources_non_forked/slimv/swank-clojure/README.md Normal file
View File

@ -0,0 +1,152 @@
# Swank Clojure
[Swank Clojure](http://github.com/technomancy/swank-clojure) is a
server that allows [SLIME](http://common-lisp.net/project/slime/) (the
Superior Lisp Interaction Mode for Emacs) to connect to Clojure
projects. To use it you must launch a swank server, then connect to it
from within Emacs.
## Usage
If you just want a standalone swank server with no third-party
libraries, you can just install swank-clojure using Leiningen.
$ lein plugin install swank-clojure 1.3.0-SNAPSHOT
$ ~/.lein/bin/swank-clojure
M-x slime-connect
If you put ~/.lein/bin on your $PATH it's even more convenient.
You can also start a swank server from inside your project:
$ lein swank # you can specify PORT and HOST optionally
Note that the lein-swank plugin now comes with Swank Clojure; it does
not need to be specified as a separate dependency any more.
If you're using Maven, add this to your pom.xml under the
\<dependencies\> section:
<dependency>
<groupId>swank-clojure</groupId>
<artifactId>swank-clojure</artifactId>
<version>1.2.1</version>
</dependency>
Then you can launch a swank server like so:
$ mvn -o clojure:swank
Note that due to a bug in clojure-maven-plugin, you currently cannot
include it as a test-scoped dependency; it must be compile-scoped. You
also cannot change the port from Maven; it's hard-coded to 4005.
Put this in your Emacs configuration to get syntax highlighting in the
slime repl:
(add-hook 'slime-repl-mode-hook 'clojure-mode-font-lock-setup)
## Connecting with SLIME
Install the "slime-repl" package using package.el. If you are using
Emacs 23, it's best to get [the latest version of package.el from
Emacs
trunk](http://bit.ly/pkg-el). Then
add Marmalade as an archive source:
(add-to-list 'package-archives
'("marmalade" . "http://marmalade-repo.org/packages/") t)
Then you can do <kbd>M-x package-list-packages</kbd>. Go down to
slime-repl and mark it with <kbd>i</kbd>. Execute the installation by
pressing <kbd>x</kbd>.
When you perform the installation, you will see warnings related to
the byte-compilation of the packages. This is **normal**; the packages
will work just fine even if there are problems byte-compiling it upon
installation.
Then you should be able to connect to the swank server you launched:
M-x slime-connect
It will prompt you for your host (usually localhost) and port. It may
also warn you that your SLIME version doesn't match your Swank
version; this should be OK.
Having old versions of SLIME either manually installed or installed
using a system-wide package manager like apt-get may cause issues.
## SLIME Commands
Commonly-used SLIME commands:
* **C-c TAB**: Autocomplete symbol at point
* **C-x C-e**: Eval the form under the point
* **C-c C-k**: Compile the current buffer
* **C-c C-l**: Load current buffer and force dependent namespaces to reload
* **M-.**: Jump to the definition of a var
* **C-c S-i**: Inspect a value
* **C-c C-m**: Macroexpand the call under the point
* **C-c C-d C-d**: Look up documentation for a var
* **C-c C-z**: Switch from a Clojure buffer to the repl buffer
* **C-c M-p**: Switch the repl namespace to match the current buffer
* **C-c C-w c**: List all callers of a given function
Pressing "v" on a stack trace a debug buffer will jump to the file and
line referenced by that frame if possible.
Note that SLIME was designed to work with Common Lisp, which has a
distinction between interpreted code and compiled code. Clojure has no
such distinction, so the load-file functionality is overloaded to add
<code>:reload-all</code> behaviour.
## Embedding
You can embed Swank Clojure in your project, start the server from
within your own code, and connect via Emacs to that instance:
(ns my-app
(:require [swank.swank]))
(swank.swank/start-repl) ;; optionally takes a port argument
Then use M-x slime-connect to connect from within Emacs.
You can also start the server directly from the "java" command-line
launcher if you AOT-compile it and specify "swank.swank" as your main
class.
## Debug Repl
For now, see [Hugo Duncan's
blog](http://hugoduncan.org/post/2010/swank_clojure_gets_a_break_with_the_local_environment.xhtml)
for an explanation of this excellent feature. Further documentation to come.
## swank-clojure.el
Previous versions of Swank Clojure bundled an Elisp library called
swank-clojure.el that provided ways to launch your swank server from
within your Emacs process. It's much more reliable to launch the
server from your build tool, so this has been removed.
## Community
The [mailing list](http://groups.google.com/group/swank-clojure) and
clojure channel on Freenode are the best places to bring up
questions/issues.
Contributions are preferred as either Github pull requests or using
"git format-patch". Please use standard indentation with no tabs,
trailing whitespace, or lines longer than 80 columns. See [this post
on submitting good patches](http://technomancy.us/135) for some
tips. If you've got some time on your hands, reading this [style
guide](http://mumble.net/~campbell/scheme/style.txt) wouldn't hurt
either.
## License
Copyright (C) 2008-2011 Jeffrey Chu, Phil Hagelberg, Hugo Duncan, and
contributors
Licensed under the EPL. (See the file COPYING.)

30
sources_non_forked/slimv/swank-clojure/leiningen/swank.clj Normal file
View File

@ -0,0 +1,30 @@
(ns leiningen.swank
"Launch swank server for Emacs to connect."
(:use [leiningen.compile :only [eval-in-project]])
(:import [java.io File]))
(defn swank-form [project port host opts]
;; bootclasspath workaround: http://dev.clojure.org/jira/browse/CLJ-673
(when (:eval-in-leiningen project)
(require '[clojure walk template stacktrace]))
`(do
(let [is# ~(:repl-init-script project)]
(when (.exists (File. (str is#)))
(load-file is#)))
(require '~'swank.swank)
(require '~'swank.commands.basic)
(@(ns-resolve '~'swank.swank '~'start-repl)
(Integer. ~port) ~@(concat (map read-string opts)
[:host host]))
;; This exits immediately when using :eval-in-leiningen; must block
(when ~(:eval-in-leiningen project)
(doseq [t# ((ns-resolve '~'swank.commands.basic
'~'get-thread-list))]
(.join t#)))))
(defn swank
"Launch swank server for Emacs to connect. Optionally takes PORT and HOST."
([project port host & opts]
(eval-in-project project (swank-form project port host opts)))
([project port] (swank project port "localhost"))
([project] (swank project 4005)))

9
sources_non_forked/slimv/swank-clojure/project.clj Normal file
View File

@ -0,0 +1,9 @@
(defproject swank-clojure "1.3.0"
:description "Swank server connecting Clojure to Emacs SLIME"
:url "http://github.com/technomancy/swank-clojure"
:dependencies [[org.clojure/clojure "1.2.0"]]
:dev-dependencies [[lein-multi "1.0.0"]]
:multi-deps {"1.1" [[org.clojure/clojure "1.1.0"]
[org.clojure/clojure-contrib "1.1.0"]]
"1.3" [[org.clojure/clojure "1.3.0-master-SNAPSHOT"]]}
:shell-wrapper {:main swank.swank})

17
sources_non_forked/slimv/swank-clojure/swank/clj_contrib/macroexpand.clj Normal file
View File

@ -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))

34
sources_non_forked/slimv/swank-clojure/swank/clj_contrib/pprint.clj Normal file
View File

@ -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))

14
sources_non_forked/slimv/swank-clojure/swank/commands.clj Normal file
View File

@ -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))))

608
sources_non_forked/slimv/swank-clojure/swank/commands/basic.clj Normal file
View File

@ -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 []))

103
sources_non_forked/slimv/swank-clojure/swank/commands/completion.clj Normal file
View File

@ -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))))

9
sources_non_forked/slimv/swank-clojure/swank/commands/contrib.clj Normal file
View File

@ -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)))))

123
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_arglists.clj Normal file
View File

@ -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))
"")))

21
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c.clj Normal file
View File

@ -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))))

59
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_c_p_c/internal.clj Normal file
View File

@ -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))))))

428
sources_non_forked/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj Normal file
View File

@ -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))))
)
)

100
sources_non_forked/slimv/swank-clojure/swank/commands/indent.clj Normal file
View File

@ -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)

323
sources_non_forked/slimv/swank-clojure/swank/commands/inspector.clj Normal file
View File

@ -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)))

51
sources_non_forked/slimv/swank-clojure/swank/commands/xref.clj Normal file
View File

@ -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)))))))))

388
sources_non_forked/slimv/swank-clojure/swank/core.clj Normal file
View File

@ -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))))))

68
sources_non_forked/slimv/swank-clojure/swank/core/connection.clj Normal file
View File

@ -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)))

4
sources_non_forked/slimv/swank-clojure/swank/core/hooks.clj Normal file
View File

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

50
sources_non_forked/slimv/swank-clojure/swank/core/protocol.clj Normal file
View File

@ -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))))

102
sources_non_forked/slimv/swank-clojure/swank/core/server.clj Normal file
View File

@ -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)))))

29
sources_non_forked/slimv/swank-clojure/swank/core/threadmap.clj Normal file
View File

@ -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))

6
sources_non_forked/slimv/swank-clojure/swank/dev.clj Normal file
View File

@ -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))

101
sources_non_forked/slimv/swank-clojure/swank/loader.clj Normal file
View File

@ -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)))))

159
sources_non_forked/slimv/swank-clojure/swank/rpc.clj Normal file
View File

@ -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)))

92
sources_non_forked/slimv/swank-clojure/swank/swank.clj Normal file
View File

@ -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)

72
sources_non_forked/slimv/swank-clojure/swank/util.clj Normal file
View File

@ -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)))

149
sources_non_forked/slimv/swank-clojure/swank/util/class_browse.clj Normal file
View File

@ -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)))))

33
sources_non_forked/slimv/swank-clojure/swank/util/clojure.clj Normal file
View File

@ -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)))

31
sources_non_forked/slimv/swank-clojure/swank/util/concurrent/mbox.clj Normal file
View File

@ -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 []
)

50
sources_non_forked/slimv/swank-clojure/swank/util/concurrent/thread.clj Normal file
View File

@ -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))

12
sources_non_forked/slimv/swank-clojure/swank/util/hooks.clj Normal file
View File

@ -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)))

40
sources_non_forked/slimv/swank-clojure/swank/util/io.clj Normal file
View File

@ -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})

16
sources_non_forked/slimv/swank-clojure/swank/util/java.clj Normal file
View File

@ -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)))

57
sources_non_forked/slimv/swank-clojure/swank/util/net/sockets.clj Normal file
View File

@ -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)))

16
sources_non_forked/slimv/swank-clojure/swank/util/string.clj Normal file
View File

@ -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))))

13
sources_non_forked/slimv/swank-clojure/swank/util/sys.clj Normal file
View File

@ -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"))