diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..03c8081
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,20 @@
+*.iml
+*init.clj
+.idea
+out-simp
+out-simp-node
+out-adv
+out-adv-node
+/target
+/lib
+/classes
+/checkouts
+*.jar
+*.class
+.lein-deps-sum
+.lein-failures
+.lein-plugins
+.lein-repl-history
+tests.js
+tests.js.map
+pom.xml.versionsBackup
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
new file mode 100644
index 0000000..06b2fc0
--- /dev/null
+++ b/CONTRIBUTING.md
@@ -0,0 +1 @@
+If you'd like to submit a patch, please follow the [contributing guidelines](http://clojure.org/contributing).
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..f05e9e6
--- /dev/null
+++ b/README.md
@@ -0,0 +1,119 @@
+# core.async
+
+A Clojure library providing facilities for async programming and communication.
+
+
+## Releases and Dependency Information
+
+Latest release: 0.3.442
+
+* [All Released Versions](http://search.maven.org/#search%7Cgav%7C1%7Cg%3A%22org.clojure%22%20AND%20a%3A%22core.async%22)
+
+[Leiningen](https://github.com/technomancy/leiningen) dependency information:
+
+```clj
+ [org.clojure/clojure "1.6.0"]
+ [org.clojure/core.async "0.3.442"]
+```
+
+[Maven](http://maven.apache.org/) dependency information:
+
+```xml
+
+ org.clojure
+ core.async
+ 0.3.442
+
+```
+
+## Documentation
+
+* [Rationale](http://clojure.com/blog/2013/06/28/clojure-core-async-channels.html)
+* [API docs](http://clojure.github.io/core.async/)
+* [Code walkthrough](https://github.com/clojure/core.async/blob/master/examples/walkthrough.clj)
+
+## Presentations
+
+* [Rich Hickey on core.async](http://www.infoq.com/presentations/clojure-core-async)
+* [Tim Baldridge on core.async](http://www.youtube.com/watch?v=enwIIGzhahw) from Clojure/conj 2013 ([code](https://github.com/halgari/clojure-conj-2013-core.async-examples)).
+* Tim Baldridge on go macro internals - [part 1](https://www.youtube.com/watch?v=R3PZMIwXN_g) [part 2](https://www.youtube.com/watch?v=SI7qtuuahhU)
+* David Nolen [core.async webinar](http://go.cognitect.com/core_async_webinar_recording)
+
+## Contributing
+
+[Contributing to Clojure projects](http://clojure.org/contributing) requires a signed Contributor Agreement. Pull requests and GitHub issues are not accepted; please use the [core.async JIRA project](http://dev.clojure.org/jira/browse/ASYNC) to report problems or enhancements.
+
+To run the ClojureScript tests:
+
+* lein cljsbuild once
+* open script/runtests.html
+* View JavaScript console for test results
+
+## License
+
+Copyright © 2017 Rich Hickey and contributors
+
+Distributed under the Eclipse Public License, the same as Clojure.
+
+## Changelog
+
+* Release 0.3.xxx on 2017.05.26
+ *
+* Release 0.3.442 on 2017.03.14
+ * Fix bad `:refer-clojure` clause that violates new spec in Clojure 1.9.0-alpha15
+* Release 0.3.441 on 2017.02.23
+ * [ASYNC-187](http://dev.clojure.org/jira/browse/ASYNC-187) - Tag metadata is lost in local closed over by a loop
+ * Related: [ASYNC-188](http://dev.clojure.org/jira/browse/ASYNC-188)
+ * [ASYNC-185](http://dev.clojure.org/jira/browse/ASYNC-185) - `thread` prevents clearing of body locals
+ * [ASYNC-186](http://dev.clojure.org/jira/browse/ASYNC-186) - NPE when `go` closes over a local variable bound to nil
+* Release 0.3.426 on 2017.02.22
+ * [ASYNC-169](http://dev.clojure.org/jira/browse/ASYNC-169) - handling of catch and finally inside go blocks was broken, causing a number of issues. Related: [ASYNC-100](http://dev.clojure.org/jira/browse/ASYNC-100), [ASYNC-173](http://dev.clojure.org/jira/browse/ASYNC-173), [ASYNC-180](http://dev.clojure.org/jira/browse/ASYNC-180), [ASYNC-179](http://dev.clojure.org/jira/browse/ASYNC-179), [ASYNC-122](http://dev.clojure.org/jira/browse/ASYNC-122), [ASYNC-78](http://dev.clojure.org/jira/browse/ASYNC-78), [ASYNC-168](http://dev.clojure.org/jira/browse/ASYNC-168)
+ * [ASYNC-138](http://dev.clojure.org/jira/browse/ASYNC-138) - go blocks do not allow closed over locals to be cleared which can lead to a memory leak. Related: [ASYNC-32](http://dev.clojure.org/jira/browse/ASYNC-32)
+ * [ASYNC-155](http://dev.clojure.org/jira/browse/ASYNC-155) - preserve loop binding metadata when inside a go block
+ * [ASYNC-54](http://dev.clojure.org/jira/browse/ASYNC-54) - fix bad type hint on MAX-QUEUE-SIZE
+ * [ASYNC-177](http://dev.clojure.org/jira/browse/ASYNC-177) - fix typo in Buffer protocol full? method
+ * [ASYNC-70](http://dev.clojure.org/jira/browse/ASYNC-70) - docstring change in thread, thread-call
+ * [ASYNC-143](http://dev.clojure.org/jira/browse/ASYNC-143) - assert that fixed buffers must have size > 0
+ * Update tools.analyzer.jvm dependency
+* Release 0.2.395 on 2016.10.12
+ * Add async version of transduce
+* Release 0.2.391 on 2016.09.09
+ * Fix redefinition warning for bounded-count (added in Clojure 1.9)
+ * Add :deprecated meta to the deprecated functions
+* Release 0.2.385 on 2016.06.17
+ * Updated tools.analyzer.jvm version
+* Release 0.2.382 on 2016.06.13
+ * Important: Change default dispatch thread pool size to 8.
+ * Add Java system property `clojure.core.async.pool-size` to set the dispatch thread pool size
+ * [ASYNC-152](http://dev.clojure.org/jira/browse/ASYNC-152) - disable t.a.jvm's warn-on-reflection pass
+* Release 0.2.374 on 2015.11.11
+ * [ASYNC-149](http://dev.clojure.org/jira/browse/ASYNC-149) - fix error compiling recur inside case in a go block
+ * Updated tools.analyzer.jvm version (and other upstream deps)
+ * Updated to latest clojurescript and cljsbuild versions
+* Release 0.2.371 on 2015.10.28
+ * [ASYNC-124](http://dev.clojure.org/jira/browse/ASYNC-124) - dispatch multiple pending takers from expanding transducer
+ * [ASYNC-103](http://dev.clojure.org/jira/browse/ASYNC-103) - NEW promise-chan
+ * [ASYNC-104](http://dev.clojure.org/jira/browse/ASYNC-104) - NEW non-blocking offer!, poll!
+ * [ASYNC-101](http://dev.clojure.org/jira/browse/ASYNC-101) - async/reduce now respects reduced
+ * [ASYNC-112](http://dev.clojure.org/jira/browse/ASYNC-112) - replace "transformer" with "transducer" in deprecation messages
+ * [ASYNC-6](http://dev.clojure.org/jira/browse/ASYNC-6) - alts! docs updated to explicitly state ports is a vector
+ * Support (try (catch :default)) in CLJS exception handling
+ * Use cljs.test
+ * Updated tools.analyzer.jvm version (and other upstream deps)
+* Release 0.1.346.0-17112a-alpha on 2014.09.22
+ * cljs nextTick relies on goog.async.nextTick
+ * Updated docstring for put! re result on closed channel
+* Release 0.1.338.0-5c5012-alpha on 2014.08.19
+ * Add cljs transducers support
+* Release 0.1.319.0-6b1aca-alpha on 2014.08.06
+ * Add transducers support
+ * NEW pipeline
+* Release 0.1.303.0-886421-alpha on 2014.05.08
+* Release 0.1.301.0-deb34a-alpha on 2014.04.29
+* Release 0.1.298.0-2a82a1-alpha on 2014.04.25
+* Release 0.1.278.0-76b25b-alpha on 2014.02.07
+* Release 0.1.267.0-0d7780-alpha on 2013.12.11
+* Release 0.1.262.0-151b23-alpha on 2013.12.10
+* Release 0.1.256.0-1bf8cf-alpha on 2013.11.07
+* Release 0.1.242.0-44b1e3-alpha on 2013.09.27
+* Release 0.1.222.0-83d0c2-alpha on 2013.09.12
diff --git a/VERSION_TEMPLATE b/VERSION_TEMPLATE
new file mode 100755
index 0000000..70ca0c6
--- /dev/null
+++ b/VERSION_TEMPLATE
@@ -0,0 +1 @@
+0.3.GENERATED_VERSION
diff --git a/doc/intro.md b/doc/intro.md
new file mode 100644
index 0000000..3bccf64
--- /dev/null
+++ b/doc/intro.md
@@ -0,0 +1,2 @@
+# Introduction to core.async
+
diff --git a/epl.html b/epl.html
new file mode 100644
index 0000000..fd39122
--- /dev/null
+++ b/epl.html
@@ -0,0 +1,261 @@
+
+
+
+
+
+
+Eclipse Public License - Version 1.0
+
+
+
+
+
+
+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 to control, 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 New York 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.
+
+
+
+
diff --git a/examples/ex-alts.clj b/examples/ex-alts.clj
new file mode 100644
index 0000000..9907ba7
--- /dev/null
+++ b/examples/ex-alts.clj
@@ -0,0 +1,24 @@
+(require '[clojure.core.async :as async :refer [! !! timeout chan alt! alts!! go]])
+
+(defn fan-in [ins]
+ (let [c (chan)]
+ (future (while true
+ (let [[x] (alts!! ins)]
+ (>!! c x))))
+ c))
+
+(defn fan-out [in cs-or-n]
+ (let [cs (if (number? cs-or-n)
+ (repeatedly cs-or-n chan)
+ cs-or-n)]
+ (future (while true
+ (let [x (!! cout n)
+ (prn (! timeout chan alt! alts! go]])
+
+(defn fan-in [ins]
+ (let [c (chan)]
+ (go (while true
+ (let [[x] (alts! ins)]
+ (>! c x))))
+ c))
+
+(defn fan-out [in cs-or-n]
+ (let [cs (if (number? cs-or-n)
+ (repeatedly cs-or-n chan)
+ cs-or-n)]
+ (go (while true
+ (let [x (! cout n)
+ (prn (!! timeout chan alt!!]])
+
+(defn fake-search [kind]
+ (fn [c query]
+ (future
+ (!! c [kind query]))))
+
+(def web1 (fake-search :web1))
+(def web2 (fake-search :web2))
+(def image1 (fake-search :image1))
+(def image2 (fake-search :image2))
+(def video1 (fake-search :video1))
+(def video2 (fake-search :video2))
+
+(defn fastest [query & replicas]
+ (let [c (chan)]
+ (doseq [replica replicas]
+ (replica c query))
+ c))
+
+(defn google [query]
+ (let [c (chan)
+ t (timeout 80)]
+ (future (>!! c (!! c (!! c (! ! c [kind query]))))
+
+(def web1 (fake-search :web1))
+(def web2 (fake-search :web2))
+(def image1 (fake-search :image1))
+(def image2 (fake-search :image2))
+(def video1 (fake-search :video1))
+(def video2 (fake-search :video2))
+
+(defn fastest [query & replicas]
+ (let [c (chan)]
+ (doseq [replica replicas]
+ (replica c query))
+ c))
+
+(defn google [query]
+ (let [c (chan)
+ t (timeout 80)]
+ (go (>! c (! c (! c (!!` (blocking put) and `!! c "hello")
+ (assert (= "hello" (!! c "hello"))
+ (assert (= "hello" (!` (put) and `! c "hello"))
+ (assert (= "hello" (!! c1 "hi")
+ (>!! c2 "there"))
+
+;; Prints (on stdout, possibly not visible at your repl):
+;; Read hi from #
+;; Read there from #
+
+;; We can use alts! to do the same thing with go blocks:
+
+(let [c1 (chan)
+ c2 (chan)]
+ (go (while true
+ (let [[v ch] (alts! [c1 c2])]
+ (println "Read" v "from" ch))))
+ (go (>! c1 "hi"))
+ (go (>! c2 "there")))
+
+;; Since go blocks are lightweight processes not bound to threads, we
+;; can have LOTS of them! Here we create 1000 go blocks that say hi on
+;; 1000 channels. We use alts!! to read them as they're ready.
+
+(let [n 1000
+ cs (repeatedly n chan)
+ begin (System/currentTimeMillis)]
+ (doseq [c cs] (go (>! c "hi")))
+ (dotimes [i n]
+ (let [[v c] (alts!! cs)]
+ (assert (= "hi" v))))
+ (println "Read" n "msgs in" (- (System/currentTimeMillis) begin) "ms"))
+
+;; `timeout` creates a channel that waits for a specified ms, then closes:
+
+(let [t (timeout 100)
+ begin (System/currentTimeMillis)]
+ (
+ 4.0.0
+ org.clojure
+ core.async
+
+ 0.3.443
+ jar
+ core.async
+ Facilities for async programming and communication in Clojure
+ https://github.com/clojure/core.async
+
+
+
+ richhickey
+ Rich Hickey
+ http://clojure.org
+
+
+
+
+ org.clojure
+ pom.contrib
+ 0.2.2
+
+
+
+ scm:git:git://github.com/clojure/core.async.git
+ scm:git:git@github.com:clojure/core.async.git
+ https://github.com/clojure/core.async
+ core.async-0.3.443
+
+
+
+ 1.7.0
+
+
+
+
+ org.clojure
+ clojurescript
+ 0.0-2311
+ provided
+
+
+ org.clojure
+ tools.analyzer.jvm
+ 0.7.0
+
+
+
+
+
+
+ org.codehaus.mojo
+ versions-maven-plugin
+ 2.3
+
+
+
+
diff --git a/project.clj b/project.clj
new file mode 100644
index 0000000..20d307a
--- /dev/null
+++ b/project.clj
@@ -0,0 +1,62 @@
+(defproject org.clojure/core.async "0.1.0-SNAPSHOT"
+ :description "Facilities for async programming and communication in Clojure"
+ :url "https://github.com/clojure/core.async"
+ :license {:name "Eclipse Public License"
+ :url "http://www.eclipse.org/legal/epl-v10.html"}
+ :parent [org.clojure/pom.contrib "0.1.2"]
+ :dependencies [[org.clojure/clojure "1.7.0"]
+ [org.clojure/tools.analyzer.jvm "0.7.0"]
+ [org.clojure/clojurescript "1.7.170" :scope "provided"]]
+ :global-vars {*warn-on-reflection* true}
+ :source-paths ["src/main/clojure"]
+ :test-paths ["src/test/clojure"]
+ :jvm-opts ^:replace ["-Xmx1g" "-server"]
+ :java-source-paths ["src/main/java"]
+ :profiles {:dev {:source-paths ["examples"]}}
+
+ :plugins [[lein-cljsbuild "1.1.2"]]
+
+ :clean-targets ["tests.js" "tests.js.map"
+ "out" "out-simp" "out-simp-node"
+ "out-adv" "out-adv-node"]
+
+ :cljsbuild
+ {:builds
+ [{:id "dev"
+ :source-paths ["src/test/cljs" "src/main/clojure/cljs"]
+ :compiler {:main cljs.core.async.test-runner
+ :asset-path "../out"
+ :optimizations :none
+ :output-to "tests.js"
+ :output-dir "out"}}
+ {:id "simple"
+ :source-paths ["src/test/cljs" "src/main/clojure/cljs"]
+ :compiler {:optimizations :simple
+ :pretty-print true
+ :static-fns true
+ :output-to "tests.js"
+ :output-dir "out-simp"}}
+ {:id "simple-node"
+ :source-paths ["src/test/cljs" "src/main/clojure/cljs"]
+ :notify-command ["node" "tests.js"]
+ :compiler {:optimizations :simple
+ :target :nodejs
+ :pretty-print true
+ :static-fns true
+ :output-to "tests.js"
+ :output-dir "out-simp-node"}}
+ {:id "adv"
+ :source-paths ["src/test/cljs" "src/main/clojure/cljs"]
+ :compiler {:optimizations :advanced
+ :pretty-print false
+ :output-dir "out-adv"
+ :output-to "tests.js"
+ :source-map "tests.js.map"}}
+ {:id "adv-node"
+ :source-paths ["src/test/cljs" "src/main/clojure/cljs"]
+ :compiler {:optimizations :advanced
+ :target :nodejs
+ :pretty-print false
+ :output-dir "out-adv-node"
+ :output-to "tests.js"
+ :source-map "tests.js.map"}}]})
diff --git a/script/build/branch_revision b/script/build/branch_revision
new file mode 100755
index 0000000..7753327
--- /dev/null
+++ b/script/build/branch_revision
@@ -0,0 +1,16 @@
+#!/usr/bin/env bash
+
+# If on a branch other than master, returns the number of commits made off of master
+# If on master, returns 0
+
+set -e
+
+master_tag=`git rev-parse --abbrev-ref HEAD`
+
+if [ "$master_tag" == "master" ]; then
+ echo "0"
+else
+ last_commit=`git rev-parse HEAD`
+ revision=`git rev-list master..$last_commit | wc -l`
+ echo $revision
+fi
diff --git a/script/build/git_revision b/script/build/git_revision
new file mode 100755
index 0000000..d4449c3
--- /dev/null
+++ b/script/build/git_revision
@@ -0,0 +1,13 @@
+#!/usr/bin/env bash
+
+# Return the portion of the version number generated from git
+#
+
+set -e
+
+trunk_basis=`script/build/trunk_revision`
+sha=`git rev-parse HEAD`
+
+sha=${sha:0:${#sha}-34} # drop the last 34 characters, keep 6
+
+echo $trunk_basis
diff --git a/script/build/revision b/script/build/revision
new file mode 100755
index 0000000..9da2d74
--- /dev/null
+++ b/script/build/revision
@@ -0,0 +1,19 @@
+#!/usr/bin/env bash
+
+# Return the complete revision number
+# ...-[-qualifier]
+
+set -e
+
+version_template=`cat VERSION_TEMPLATE`
+
+if [[ "$version_template" =~ ^[0-9]+\.[0-9]+\.GENERATED_VERSION(-[a-zA-Z0-9]+)?$ ]]; then
+
+ git_revision=`script/build/git_revision`
+ echo ${version_template/GENERATED_VERSION/$git_revision}
+
+else
+ echo "Invalid version template string: $version_template" >&2
+ exit -1
+fi
+
diff --git a/script/build/trunk_revision b/script/build/trunk_revision
new file mode 100755
index 0000000..ac557ff
--- /dev/null
+++ b/script/build/trunk_revision
@@ -0,0 +1,14 @@
+#!/usr/bin/env bash
+
+# Returns the number of commits made since the v0.0 tag
+
+set -e
+
+REVISION=`git --no-replace-objects describe --match v0.0`
+
+# Extract the version number from the string. Do this in two steps so
+# it is a little easier to understand.
+REVISION=${REVISION:5} # drop the first 5 characters
+REVISION=${REVISION:0:${#REVISION}-9} # drop the last 9 characters
+
+echo $REVISION
diff --git a/script/build/update_version b/script/build/update_version
new file mode 100755
index 0000000..8bd8098
--- /dev/null
+++ b/script/build/update_version
@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+set -e
+
+mvn versions:set -DnewVersion=`script/build/revision`-SNAPSHOT
diff --git a/script/runtests.html b/script/runtests.html
new file mode 100644
index 0000000..185c6a5
--- /dev/null
+++ b/script/runtests.html
@@ -0,0 +1,9 @@
+
+
+
+
+
+
+Open JavaScript Console to see the test results
+
+
diff --git a/src/main/clojure/cljs/core/async/impl/buffers.cljs b/src/main/clojure/cljs/core/async/impl/buffers.cljs
new file mode 100644
index 0000000..b981819
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/buffers.cljs
@@ -0,0 +1,159 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns cljs.core.async.impl.buffers
+ (:require [cljs.core.async.impl.protocols :as impl]))
+
+;; -----------------------------------------------------------------------------
+;; DO NOT USE, this is internal buffer representation
+
+(defn acopy [src src-start dest dest-start len]
+ (loop [cnt 0]
+ (when (< cnt len)
+ (aset dest
+ (+ dest-start cnt)
+ (aget src (+ src-start cnt)))
+ (recur (inc cnt)))))
+
+(deftype RingBuffer [^:mutable head ^:mutable tail ^:mutable length ^:mutable arr]
+ Object
+ (pop [_]
+ (when-not (zero? length)
+ (let [x (aget arr tail)]
+ (aset arr tail nil)
+ (set! tail (js-mod (inc tail) (alength arr)))
+ (set! length (dec length))
+ x)))
+
+ (unshift [_ x]
+ (aset arr head x)
+ (set! head (js-mod (inc head) (alength arr)))
+ (set! length (inc length))
+ nil)
+
+ (unbounded-unshift [this x]
+ (if (== (inc length) (alength arr))
+ (.resize this))
+ (.unshift this x))
+
+ ;; Doubles the size of the buffer while retaining all the existing values
+ (resize
+ [_]
+ (let [new-arr-size (* (alength arr) 2)
+ new-arr (make-array new-arr-size)]
+ (cond
+ (< tail head)
+ (do (acopy arr tail new-arr 0 length)
+ (set! tail 0)
+ (set! head length)
+ (set! arr new-arr))
+
+ (> tail head)
+ (do (acopy arr tail new-arr 0 (- (alength arr) tail))
+ (acopy arr 0 new-arr (- (alength arr) tail) head)
+ (set! tail 0)
+ (set! head length)
+ (set! arr new-arr))
+
+ (== tail head)
+ (do (set! tail 0)
+ (set! head 0)
+ (set! arr new-arr)))))
+
+ (cleanup [this keep?]
+ (dotimes [x length]
+ (let [v (.pop this)]
+ (when ^boolean (keep? v)
+ (.unshift this v))))))
+
+(defn ring-buffer [n]
+ (assert (> n 0) "Can't create a ring buffer of size 0")
+ (RingBuffer. 0 0 0 (make-array n)))
+
+;; -----------------------------------------------------------------------------
+
+(deftype FixedBuffer [buf n]
+ impl/Buffer
+ (full? [this]
+ (== (.-length buf) n))
+ (remove! [this]
+ (.pop buf))
+ (add!* [this itm]
+ (.unbounded-unshift buf itm)
+ this)
+ (close-buf! [this])
+ cljs.core/ICounted
+ (-count [this]
+ (.-length buf)))
+
+(defn fixed-buffer [n]
+ (FixedBuffer. (ring-buffer n) n))
+
+(deftype DroppingBuffer [buf n]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [this]
+ false)
+ (remove! [this]
+ (.pop buf))
+ (add!* [this itm]
+ (when-not (== (.-length buf) n)
+ (.unshift buf itm))
+ this)
+ (close-buf! [this])
+ cljs.core/ICounted
+ (-count [this]
+ (.-length buf)))
+
+(defn dropping-buffer [n]
+ (DroppingBuffer. (ring-buffer n) n))
+
+(deftype SlidingBuffer [buf n]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [this]
+ false)
+ (remove! [this]
+ (.pop buf))
+ (add!* [this itm]
+ (when (== (.-length buf) n)
+ (impl/remove! this))
+ (.unshift buf itm)
+ this)
+ (close-buf! [this])
+ cljs.core/ICounted
+ (-count [this]
+ (.-length buf)))
+
+(defn sliding-buffer [n]
+ (SlidingBuffer. (ring-buffer n) n))
+
+(defonce ^:private NO-VAL (js/Object.))
+(defn- undelivered? [val]
+ (identical? NO-VAL val))
+
+(deftype PromiseBuffer [^:mutable val]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [_]
+ false)
+ (remove! [_]
+ val)
+ (add!* [this itm]
+ (when (undelivered? val)
+ (set! val itm))
+ this)
+ (close-buf! [_]
+ (when (undelivered? val)
+ (set! val nil)))
+ cljs.core/ICounted
+ (-count [_]
+ (if (undelivered? val) 0 1)))
+
+(defn promise-buffer []
+ (PromiseBuffer. NO-VAL))
diff --git a/src/main/clojure/cljs/core/async/impl/channels.cljs b/src/main/clojure/cljs/core/async/impl/channels.cljs
new file mode 100644
index 0000000..ce9b2fd
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/channels.cljs
@@ -0,0 +1,192 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns cljs.core.async.impl.channels
+ (:require [cljs.core.async.impl.protocols :as impl]
+ [cljs.core.async.impl.dispatch :as dispatch]
+ [cljs.core.async.impl.buffers :as buffers]))
+
+
+
+(defn box [val]
+ (reify cljs.core/IDeref
+ (-deref [_] val)))
+
+(deftype PutBox [handler val])
+
+(defn put-active? [box]
+ (impl/active? (.-handler box)))
+
+(def ^:const MAX_DIRTY 64)
+
+(defprotocol MMC
+ (abort [this]))
+
+(deftype ManyToManyChannel [takes ^:mutable dirty-takes puts ^:mutable dirty-puts ^not-native buf ^:mutable closed add!]
+ MMC
+ (abort [this]
+ (loop []
+ (let [putter (.pop puts)]
+ (when-not (nil? putter)
+ (let [^not-native put-handler (.-handler putter)
+ val (.-val putter)]
+ (if ^boolean (impl/active? put-handler)
+ (let [put-cb (impl/commit put-handler)]
+ (dispatch/run #(put-cb true)))
+ (recur))))))
+ (.cleanup puts (constantly false))
+ (impl/close! this))
+ impl/WritePort
+ (put! [this val ^not-native handler]
+ (assert (not (nil? val)) "Can't put nil in on a channel")
+ ;; bug in CLJS compiler boolean inference - David
+ (let [^boolean closed closed]
+ (if (or closed (not ^boolean (impl/active? handler)))
+ (box (not closed))
+ (if (and buf (not (impl/full? buf)))
+ (do
+ (impl/commit handler)
+ (let [done? (reduced? (add! buf val))
+ take-cbs (loop [takers []]
+ (if (and (pos? (.-length takes)) (pos? (count buf)))
+ (let [^not-native taker (.pop takes)]
+ (if ^boolean (impl/active? taker)
+ (let [ret (impl/commit taker)
+ val (impl/remove! buf)]
+ (recur (conj takers (fn [] (ret val)))))
+ (recur takers)))
+ takers))]
+ (when done? (abort this))
+ (when (seq take-cbs)
+ (doseq [f take-cbs]
+ (dispatch/run f)))
+ (box true)))
+ (let [taker (loop []
+ (let [^not-native taker (.pop takes)]
+ (when taker
+ (if (impl/active? taker)
+ taker
+ (recur)))))]
+ (if taker
+ (let [take-cb (impl/commit taker)]
+ (impl/commit handler)
+ (dispatch/run (fn [] (take-cb val)))
+ (box true))
+ (do
+ (if (> dirty-puts MAX_DIRTY)
+ (do (set! dirty-puts 0)
+ (.cleanup puts put-active?))
+ (set! dirty-puts (inc dirty-puts)))
+ (when (impl/blockable? handler)
+ (assert (< (.-length puts) impl/MAX-QUEUE-SIZE)
+ (str "No more than " impl/MAX-QUEUE-SIZE
+ " pending puts are allowed on a single channel."
+ " Consider using a windowed buffer."))
+ (.unbounded-unshift puts (PutBox. handler val)))
+ nil)))))))
+ impl/ReadPort
+ (take! [this ^not-native handler]
+ (if (not ^boolean (impl/active? handler))
+ nil
+ (if (and (not (nil? buf)) (pos? (count buf)))
+ (do
+ (if-let [take-cb (impl/commit handler)]
+ (let [val (impl/remove! buf)
+ [done? cbs] (when (pos? (.-length puts))
+ (loop [cbs []]
+ (let [putter (.pop puts)
+ ^not-native put-handler (.-handler putter)
+ val (.-val putter)
+ cb (and ^boolean (impl/active? put-handler) (impl/commit put-handler))
+ cbs (if cb (conj cbs cb) cbs)
+ done? (when cb (reduced? (add! buf val)))]
+ (if (and (not done?) (not (impl/full? buf)) (pos? (.-length puts)))
+ (recur cbs)
+ [done? cbs]))))]
+ (when done?
+ (abort this))
+ (doseq [cb cbs]
+ (dispatch/run #(cb true)))
+ (box val))))
+ (let [putter (loop []
+ (let [putter (.pop puts)]
+ (when putter
+ (if ^boolean (impl/active? (.-handler putter))
+ putter
+ (recur)))))]
+ (if putter
+ (let [put-cb (impl/commit (.-handler putter))]
+ (impl/commit handler)
+ (dispatch/run #(put-cb true))
+ (box (.-val putter)))
+ (if closed
+ (do
+ (when buf (add! buf))
+ (if (and (impl/active? handler) (impl/commit handler))
+ (let [has-val (and buf (pos? (count buf)))]
+ (let [val (when has-val (impl/remove! buf))]
+ (box val)))
+ nil))
+ (do
+ (if (> dirty-takes MAX_DIRTY)
+ (do (set! dirty-takes 0)
+ (.cleanup takes impl/active?))
+ (set! dirty-takes (inc dirty-takes)))
+ (when (impl/blockable? handler)
+ (assert (< (.-length takes) impl/MAX-QUEUE-SIZE)
+ (str "No more than " impl/MAX-QUEUE-SIZE
+ " pending takes are allowed on a single channel."))
+ (.unbounded-unshift takes handler))
+ nil)))))))
+ impl/Channel
+ (closed? [_] closed)
+ (close! [this]
+ (if ^boolean closed
+ nil
+ (do (set! closed true)
+ (when (and buf (zero? (.-length puts)))
+ (add! buf))
+ (loop []
+ (let [^not-native taker (.pop takes)]
+ (when-not (nil? taker)
+ (when ^boolean (impl/active? taker)
+ (let [take-cb (impl/commit taker)
+ val (when (and buf (pos? (count buf))) (impl/remove! buf))]
+ (dispatch/run (fn [] (take-cb val)))))
+ (recur))))
+ (when buf (impl/close-buf! buf))
+ nil))))
+
+(defn- ex-handler [ex]
+ (.log js/console ex)
+ nil)
+
+(defn- handle [buf exh t]
+ (let [else ((or exh ex-handler) t)]
+ (if (nil? else)
+ buf
+ (impl/add! buf else))))
+
+(defn chan
+ ([buf] (chan buf nil))
+ ([buf xform] (chan buf xform nil))
+ ([buf xform exh]
+ (ManyToManyChannel. (buffers/ring-buffer 32) 0 (buffers/ring-buffer 32)
+ 0 buf false
+ (let [add! (if xform (xform impl/add!) impl/add!)]
+ (fn
+ ([buf]
+ (try
+ (add! buf)
+ (catch :default t
+ (handle buf exh t))))
+ ([buf val]
+ (try
+ (add! buf val)
+ (catch :default t
+ (handle buf exh t)))))))))
diff --git a/src/main/clojure/cljs/core/async/impl/dispatch.cljs b/src/main/clojure/cljs/core/async/impl/dispatch.cljs
new file mode 100644
index 0000000..468bbdf
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/dispatch.cljs
@@ -0,0 +1,37 @@
+(ns cljs.core.async.impl.dispatch
+ (:require [cljs.core.async.impl.buffers :as buffers]
+ [goog.async.nextTick]))
+
+(def tasks (buffers/ring-buffer 32))
+(def running? false)
+(def queued? false)
+
+(def TASK_BATCH_SIZE 1024)
+
+(declare queue-dispatcher)
+
+(defn process-messages []
+ (set! running? true)
+ (set! queued? false)
+ (loop [count 0]
+ (let [m (.pop tasks)]
+ (when-not (nil? m)
+ (m)
+ (when (< count TASK_BATCH_SIZE)
+ (recur (inc count))))))
+ (set! running? false)
+ (when (> (.-length tasks) 0)
+ (queue-dispatcher)))
+
+(defn queue-dispatcher []
+ (when-not (and queued? running?)
+ (set! queued? true)
+ (goog.async.nextTick process-messages)))
+
+(defn run [f]
+ (.unbounded-unshift tasks f)
+ (queue-dispatcher))
+
+(defn queue-delay [f delay]
+ (js/setTimeout f delay))
+
diff --git a/src/main/clojure/cljs/core/async/impl/ioc_helpers.cljs b/src/main/clojure/cljs/core/async/impl/ioc_helpers.cljs
new file mode 100644
index 0000000..c849acc
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/ioc_helpers.cljs
@@ -0,0 +1,146 @@
+(ns cljs.core.async.impl.ioc-helpers
+ (:require [cljs.core.async.impl.protocols :as impl])
+ (:require-macros [cljs.core.async.impl.ioc-macros :as ioc]))
+
+(def ^:const FN-IDX 0)
+(def ^:const STATE-IDX 1)
+(def ^:const VALUE-IDX 2)
+(def ^:const BINDINGS-IDX 3)
+(def ^:const EXCEPTION-FRAMES 4)
+(def ^:const CURRENT-EXCEPTION 5)
+(def ^:const USER-START-IDX 6)
+
+(defn aset-object [arr idx o]
+ (aget arr idx o))
+
+(defn aget-object [arr idx]
+ (aget arr idx))
+
+
+(defn finished?
+ "Returns true if the machine is in a finished state"
+ [state-array]
+ (keyword-identical? (aget state-array STATE-IDX) :finished))
+
+(defn- fn-handler
+ [f]
+ (reify
+ impl/Handler
+ (active? [_] true)
+ (blockable? [_] true)
+ (commit [_] f)))
+
+
+(defn run-state-machine [state]
+ ((aget-object state FN-IDX) state))
+
+(defn run-state-machine-wrapped [state]
+ (try
+ (run-state-machine state)
+ (catch js/Object ex
+ (impl/close! ^not-native (aget-object state USER-START-IDX))
+ (throw ex))))
+
+(defn take! [state blk ^not-native c]
+ (if-let [cb (impl/take! c (fn-handler
+ (fn [x]
+ (ioc/aset-all! state VALUE-IDX x STATE-IDX blk)
+ (run-state-machine-wrapped state))))]
+ (do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk)
+ :recur)
+ nil))
+
+(defn put! [state blk ^not-native c val]
+ (if-let [cb (impl/put! c val (fn-handler (fn [ret-val]
+ (ioc/aset-all! state VALUE-IDX ret-val STATE-IDX blk)
+ (run-state-machine-wrapped state))))]
+ (do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk)
+ :recur)
+ nil))
+
+(defn return-chan [state value]
+ (let [^not-native c (aget state USER-START-IDX)]
+ (when-not (nil? value)
+ (impl/put! c value (fn-handler (fn [] nil))))
+ (impl/close! c)
+ c))
+
+(defrecord ExceptionFrame [catch-block
+ ^Class catch-exception
+ finally-block
+ continue-block
+ prev])
+
+(defn add-exception-frame [state catch-block catch-exception finally-block continue-block]
+ (ioc/aset-all! state
+ EXCEPTION-FRAMES
+ (->ExceptionFrame catch-block
+ catch-exception
+ finally-block
+ continue-block
+ (aget-object state EXCEPTION-FRAMES))))
+
+(defn process-exception [state]
+ (let [exception-frame (aget-object state EXCEPTION-FRAMES)
+ catch-block (:catch-block exception-frame)
+ catch-exception (:catch-exception exception-frame)
+ exception (aget-object state CURRENT-EXCEPTION)]
+ (cond
+ (and exception
+ (not exception-frame))
+ (throw exception)
+
+ (and exception
+ catch-block
+ (or (= :default catch-exception)
+ (instance? catch-exception exception)))
+ (ioc/aset-all! state
+ STATE-IDX
+ catch-block
+ VALUE-IDX
+ exception
+ CURRENT-EXCEPTION
+ nil
+ EXCEPTION-FRAMES
+ (assoc exception-frame
+ :catch-block nil
+ :catch-exception nil))
+
+
+ (and exception
+ (not catch-block)
+ (not (:finally-block exception-frame)))
+
+ (do (ioc/aset-all! state
+ EXCEPTION-FRAMES
+ (:prev exception-frame))
+ (recur state))
+
+ (and exception
+ (not catch-block)
+ (:finally-block exception-frame))
+ (ioc/aset-all! state
+ STATE-IDX
+ (:finally-block exception-frame)
+ EXCEPTION-FRAMES
+ (assoc exception-frame
+ :finally-block nil))
+
+ (and (not exception)
+ (:finally-block exception-frame))
+ (do (ioc/aset-all! state
+ STATE-IDX
+ (:finally-block exception-frame)
+ EXCEPTION-FRAMES
+ (assoc exception-frame
+ :finally-block nil)))
+
+ (and (not exception)
+ (not (:finally-block exception-frame)))
+ (do (ioc/aset-all! state
+ STATE-IDX
+ (:continue-block exception-frame)
+ EXCEPTION-FRAMES
+ (:prev exception-frame)))
+
+ :else (throw (js/Error. "No matching clause")))))
diff --git a/src/main/clojure/cljs/core/async/impl/ioc_macros.clj b/src/main/clojure/cljs/core/async/impl/ioc_macros.clj
new file mode 100644
index 0000000..1108514
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/ioc_macros.clj
@@ -0,0 +1,883 @@
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; by Timothy Baldridge
+;; April 13, 2013
+
+(ns cljs.core.async.impl.ioc-macros
+ (:refer-clojure :exclude [all])
+ (:require [clojure.pprint :refer [pprint]]
+ [clojure.set :refer (intersection)]
+ [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [cljs.analyzer :as cljs])
+ (:import [java.util.concurrent.locks Lock]))
+
+(defn debug [x]
+ (binding [*out* *err*]
+ (pprint x))
+ x)
+
+(def ^:const FN-IDX 0)
+(def ^:const STATE-IDX 1)
+(def ^:const VALUE-IDX 2)
+(def ^:const BINDINGS-IDX 3)
+(def ^:const EXCEPTION-FRAMES 4)
+(def ^:const CURRENT-EXCEPTION 5)
+(def ^:const USER-START-IDX 6)
+
+(defmacro aset-all!
+ [arr & more]
+ (assert (even? (count more)) "Must give an even number of args to aset-all!")
+ (let [bindings (partition 2 more)
+ arr-sym (gensym "statearr-")]
+ `(let [~arr-sym ~arr]
+ ~@(map
+ (fn [[idx val]]
+ `(aset ~arr-sym ~idx ~val))
+ bindings)
+ ~arr-sym)))
+
+;; State monad stuff, used only in SSA construction
+
+(defmacro gen-plan
+ "Allows a user to define a state monad binding plan.
+
+ (gen-plan
+ [_ (assoc-in-plan [:foo :bar] 42)
+ val (get-in-plan [:foo :bar])]
+ val)"
+ [binds id-expr]
+ (let [binds (partition 2 binds)
+ psym (gensym "plan_")
+ forms (reduce
+ (fn [acc [id expr]]
+ (concat acc `[[~id ~psym] (~expr ~psym)]))
+ []
+ binds)]
+ `(fn [~psym]
+ (let [~@forms]
+ [~id-expr ~psym]))))
+
+(defn get-plan
+ "Returns the final [id state] from a plan. "
+ [f]
+ (f {}))
+
+(defn push-binding
+ "Sets the binding 'key' to value. This operation can be undone via pop-bindings.
+ Bindings are stored in the state hashmap."
+ [key value]
+ (fn [plan]
+ [nil (update-in plan [:bindings key] conj value)]))
+
+(defn push-alter-binding
+ "Pushes the result of (apply f old-value args) as current value of binding key"
+ [key f & args]
+ (fn [plan]
+ [nil (update-in plan [:bindings key]
+ #(conj % (apply f (first %) args)))]))
+
+(defn get-binding
+ "Gets the value of the current binding for key"
+ [key]
+ (fn [plan]
+ [(first (get-in plan [:bindings key])) plan]))
+
+(defn pop-binding
+ "Removes the most recent binding for key"
+ [key]
+ (fn [plan]
+ [(first (get-in plan [:bindings key]))
+ (update-in plan [:bindings key] pop)]))
+
+(defn no-op
+ "This function can be used inside a gen-plan when no operation is to be performed"
+ []
+ (fn [plan]
+ [nil plan]))
+
+(defn all
+ "Assumes that itms is a list of state monad function results, threads the state map
+ through all of them. Returns a vector of all the results."
+ [itms]
+ (fn [plan]
+ (reduce
+ (fn [[ids plan] f]
+ (let [[id plan] (f plan)]
+ [(conj ids id) plan]))
+ [[] plan]
+ itms)))
+
+(defn assoc-in-plan
+ "Same as assoc-in, but for state hash map"
+ [path val]
+ (fn [plan]
+ [val (assoc-in plan path val)]))
+
+(defn update-in-plan
+ "Same as update-in, but for a state hash map"
+ [path f & args]
+ (fn [plan]
+ [nil (apply update-in plan path f args)]))
+
+(defn get-in-plan
+ "Same as get-in, but for a state hash map"
+ [path]
+ (fn [plan]
+ [(get-in plan path) plan]))
+
+(defn print-plan []
+ (fn [plan]
+ (pprint plan)
+ [nil plan]))
+
+(defn set-block
+ "Sets the current block being written to by the functions. The next add-instruction call will append to this block"
+ [block-id]
+ (fn [plan]
+ [block-id (assoc plan :current-block block-id)]))
+
+(defn get-block
+ "Gets the current block"
+ []
+ (fn [plan]
+ [(:current-block plan) plan]))
+
+(defn add-block
+ "Adds a new block, returns its id, but does not change the current block (does not call set-block)."
+ []
+ (gen-plan
+ [_ (update-in-plan [:block-id] (fnil inc 0))
+ blk-id (get-in-plan [:block-id])
+ cur-blk (get-block)
+ _ (assoc-in-plan [:blocks blk-id] [])
+ catches (get-binding :catch)
+ _ (assoc-in-plan [:block-catches blk-id] catches)
+ _ (if-not cur-blk
+ (assoc-in-plan [:start-block] blk-id)
+ (no-op))]
+ blk-id))
+
+
+(defn instruction? [x]
+ (::instruction (meta x)))
+
+(defn add-instruction
+ "Appends an instruction to the current block. "
+ [inst]
+ (let [inst-id (with-meta (gensym "inst_")
+ {::instruction true})
+ inst (assoc inst :id inst-id)]
+ (gen-plan
+ [blk-id (get-block)
+ _ (update-in-plan [:blocks blk-id] (fnil conj []) inst)]
+ inst-id)))
+
+;;
+
+;; We're going to reduce Clojure expressions to a ssa format,
+;; and then translate the instructions for this
+;; virtual-virtual-machine back into Clojure data.
+
+;; Here we define the instructions:
+
+(defprotocol IInstruction
+ (reads-from [this] "Returns a list of instructions this instruction reads from")
+ (writes-to [this] "Returns a list of instructions this instruction writes to")
+ (block-references [this] "Returns all the blocks this instruction references"))
+
+(defprotocol IEmittableInstruction
+ (emit-instruction [this state-sym] "Returns the clojure code that this instruction represents"))
+
+(defprotocol ITerminator
+ (terminator-code [this] "Returns a unique symbol for this instruction")
+ (terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block"))
+
+(defrecord Const [value]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if (= value ::value)
+ `[~(:id this) (aget ~state-sym ~VALUE-IDX)]
+ `[~(:id this) ~value])))
+
+(defrecord CustomTerminator [f blk values]
+ IInstruction
+ (reads-from [this] values)
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(~f ~state-sym ~blk ~@values)))
+
+(defn- emit-clashing-binds
+ [recur-nodes ids clashes]
+ (let [temp-binds (reduce
+ (fn [acc i]
+ (assoc acc i (gensym "tmp")))
+ {} clashes)]
+ (concat
+ (mapcat (fn [i]
+ `[~(temp-binds i) ~i])
+ clashes)
+ (mapcat (fn [node id]
+ `[~node ~(get temp-binds id id)])
+ recur-nodes
+ ids))))
+
+(defrecord Recur [recur-nodes ids]
+ IInstruction
+ (reads-from [this] ids)
+ (writes-to [this] recur-nodes)
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if-let [overlap (seq (intersection (set recur-nodes) (set ids)))]
+ (emit-clashing-binds recur-nodes ids overlap)
+ (mapcat (fn [r i]
+ `[~r ~i]) recur-nodes ids))))
+
+(defrecord Call [refs]
+ IInstruction
+ (reads-from [this] refs)
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this) ~(seq refs)]))
+
+(defrecord Case [val-id test-vals jmp-blocks default-block]
+ IInstruction
+ (reads-from [this] [val-id])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (case ~val-id
+ ~@(concat (mapcat (fn [test blk]
+ `[~test (aset-all! ~state-sym
+ ~STATE-IDX ~blk)])
+ test-vals jmp-blocks)
+ (when default-block
+ `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block)
+ :recur)])))
+ :recur)))
+
+(defrecord Fn [fn-expr local-names local-refs]
+ IInstruction
+ (reads-from [this] local-refs)
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this)
+ (let [~@(interleave local-names local-refs)]
+ ~@fn-expr)]))
+
+(defrecord Dot [target method args]
+ IInstruction
+ (reads-from [this] `[~target ~method ~@args])
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if (.startsWith (name method) "-")
+ `[~(:id this) (. ~target ~method)]
+ `[~(:id this) (. ~target ~(cons method args))])))
+
+(defrecord Jmp [value block]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [])
+ (block-references [this] [block])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block)
+ :recur)))
+
+(defrecord Return [value]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminator-code [this] :Return)
+ (terminate-block [this state-sym custom-terminators]
+ (if-let [f (get custom-terminators (terminator-code this))]
+ `(~f ~state-sym ~value)
+ `(do (aset-all! ~state-sym
+ ~VALUE-IDX ~value
+ ~STATE-IDX :finished)
+ nil))))
+
+(defrecord Set! [field object val]
+ IInstruction
+ (reads-from [this] [object val])
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if field
+ `[~(:id this) (set! (~field ~object) ~val)]
+ `[~(:id this) (set! ~object ~val)])))
+
+(defrecord CondBr [test then-block else-block]
+ IInstruction
+ (reads-from [this] [test])
+ (writes-to [this] [])
+ (block-references [this] [then-block else-block])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (if ~test
+ (aset-all! ~state-sym
+ ~STATE-IDX ~then-block)
+ (aset-all! ~state-sym
+ ~STATE-IDX ~else-block))
+ :recur)))
+
+
+(defrecord Try [catch-block catch-exception finally-block continue-block]
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] [catch-block finally-block continue-block])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~'_ (cljs.core.async.impl.ioc-helpers/add-exception-frame ~state-sym
+ ~catch-block
+ ~catch-exception
+ ~finally-block
+ ~continue-block)]))
+
+(defrecord ProcessExceptionWithValue [value]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (aset-all! ~state-sym
+ ~VALUE-IDX
+ ~value)
+ (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
+ :recur)))
+
+(defrecord EndCatchFinally []
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
+ :recur)))
+
+
+
+;; Dispatch clojure forms based on data type
+(defmulti -item-to-ssa (fn [x]
+ (cond
+ (symbol? x) :symbol
+ (seq? x) :list
+ (map? x) :map
+ (set? x) :set
+ (vector? x) :vector
+ :else :default)))
+
+(defn item-to-ssa [x]
+ (-item-to-ssa x))
+
+;; given an sexpr, dispatch on the first item
+(defmulti sexpr-to-ssa (fn [[x & _]]
+ x))
+
+(defn is-special? [x]
+ (let [^clojure.lang.MultiFn mfn sexpr-to-ssa]
+ (.getMethod mfn x)))
+
+
+
+(defn default-sexpr [args]
+ (gen-plan
+ [args-ids (all (map item-to-ssa args))
+ inst-id (add-instruction (->Call args-ids))]
+ inst-id))
+
+(defn let-binding-to-ssa
+ [[sym bind]]
+ (gen-plan
+ [bind-id (item-to-ssa bind)
+ _ (push-alter-binding :locals assoc sym bind-id)]
+ bind-id))
+
+(defmethod sexpr-to-ssa 'let*
+ [[_ binds & body]]
+ (let [parted (partition 2 binds)]
+ (gen-plan
+ [let-ids (all (map let-binding-to-ssa parted))
+ body-ids (all (map item-to-ssa body))
+ _ (all (map (fn [x]
+ (pop-binding :locals))
+ (range (count parted))))]
+ (last body-ids))))
+
+(defmethod sexpr-to-ssa 'loop*
+ [[_ locals & body]]
+ (let [parted (partition 2 locals)
+ syms (map first parted)
+ inits (map second parted)]
+ (gen-plan
+ [local-val-ids (all (map ; parallel bind
+ (fn [sym init]
+ (gen-plan
+ [itm-id (item-to-ssa init)
+ _ (push-alter-binding :locals assoc sym itm-id)]
+ itm-id))
+ syms
+ inits))
+ _ (all (for [x syms]
+ (pop-binding :locals)))
+ local-ids (all (map (comp add-instruction ->Const) local-val-ids))
+ body-blk (add-block)
+ final-blk (add-block)
+ _ (add-instruction (->Jmp nil body-blk))
+
+ _ (set-block body-blk)
+ _ (push-alter-binding :locals merge (zipmap syms local-ids))
+ _ (push-binding :recur-point body-blk)
+ _ (push-binding :recur-nodes local-ids)
+
+ body-ids (all (map item-to-ssa body))
+
+ _ (pop-binding :recur-nodes)
+ _ (pop-binding :recur-point)
+ _ (pop-binding :locals)
+ _ (if (not= (last body-ids) ::terminated)
+ (add-instruction (->Jmp (last body-ids) final-blk))
+ (no-op))
+ _ (set-block final-blk)
+ ret-id (add-instruction (->Const ::value))]
+ ret-id)))
+
+(defmethod sexpr-to-ssa 'set!
+ [[_ assignee val]]
+ (let [target (cond
+ (symbol? assignee)
+ assignee
+ (and (list? assignee)
+ (= (count assignee) 2))
+ (second assignee))
+ field (if (list? assignee)
+ (first assignee))]
+ (gen-plan
+ [locals (get-binding :locals)
+
+ target-id (if (contains? locals target)
+ (fn [p]
+ [(get locals target) p])
+ (item-to-ssa target))
+ val-id (item-to-ssa val)
+
+ ret-id (add-instruction (->Set! field target-id val-id))]
+ ret-id)))
+
+(defmethod sexpr-to-ssa 'do
+ [[_ & body]]
+ (gen-plan
+ [ids (all (map item-to-ssa body))]
+ (last ids)))
+
+(defmethod sexpr-to-ssa 'case
+ [[_ val & body]]
+ (let [clauses (partition 2 body)
+ default (when (odd? (count body))
+ (last body))]
+ (gen-plan
+ [end-blk (add-block)
+ start-blk (get-block)
+ clause-blocks (all (map (fn [expr]
+ (gen-plan
+ [blk-id (add-block)
+ _ (set-block blk-id)
+ expr-id (item-to-ssa expr)
+ _ (if (not= expr-id ::terminated)
+ (add-instruction (->Jmp expr-id end-blk))
+ (no-op))]
+ blk-id))
+ (map second clauses)))
+ default-block (if (odd? (count body))
+ (gen-plan
+ [blk-id (add-block)
+ _ (set-block blk-id)
+ expr-id (item-to-ssa default)
+ _ (if (not= expr-id ::terminated)
+ (add-instruction (->Jmp expr-id end-blk))
+ (no-op))]
+ blk-id)
+ (no-op))
+ _ (set-block start-blk)
+ val-id (item-to-ssa val)
+ case-id (add-instruction (->Case val-id (map first clauses) clause-blocks default-block))
+ _ (set-block end-blk)
+ ret-id (add-instruction (->Const ::value))]
+ ret-id)))
+
+(defmethod sexpr-to-ssa 'quote
+ [expr]
+ (gen-plan
+ [ret-id (add-instruction (->Const expr))]
+ ret-id))
+
+(defmethod sexpr-to-ssa '.
+ [[_ target method & args]]
+ (let [args (if (seq? method)
+ (next method)
+ args)
+ method (if (seq? method)
+ (first method)
+ method)]
+ (gen-plan
+ [target-id (item-to-ssa target)
+ args-ids (all (map item-to-ssa args))
+ ret-id (add-instruction (->Dot target-id method args-ids))]
+ ret-id)))
+
+(defmethod sexpr-to-ssa 'try
+ [[_ & body]]
+ (let [finally-fn (every-pred seq? (comp (partial = 'finally) first))
+ catch-fn (every-pred seq? (comp (partial = 'catch) first))
+ finally (next (first (filter finally-fn body)))
+ body (remove finally-fn body)
+ catch (next (first (filter catch-fn body)))
+ [ex ex-bind & catch-body] catch
+ body (remove catch-fn body)]
+ (gen-plan
+ [end-blk (add-block)
+ finally-blk (if finally
+ (gen-plan
+ [cur-blk (get-block)
+ blk (add-block)
+ _ (set-block blk)
+ value-id (add-instruction (->Const ::value))
+ _ (all (map item-to-ssa finally))
+ _ (add-instruction (->EndCatchFinally))
+ _ (set-block cur-blk)]
+ blk)
+ (no-op))
+ catch-blk (if catch
+ (gen-plan
+ [cur-blk (get-block)
+ blk (add-block)
+ _ (set-block blk)
+ ex-id (add-instruction (->Const ::value))
+ _ (push-alter-binding :locals assoc ex-bind ex-id)
+ ids (all (map item-to-ssa catch-body))
+ _ (add-instruction (->ProcessExceptionWithValue (last ids)))
+ _ (pop-binding :locals)
+ _ (set-block cur-blk)
+ _ (push-alter-binding :catch (fnil conj []) [ex blk])]
+ blk)
+ (no-op))
+ body-blk (add-block)
+ _ (add-instruction (->Jmp nil body-blk))
+ _ (set-block body-blk)
+ _ (add-instruction (->Try catch-blk ex finally-blk end-blk))
+ ids (all (map item-to-ssa body))
+ _ (if catch
+ (pop-binding :catch)
+ (no-op))
+ _ (add-instruction (->ProcessExceptionWithValue (last ids)))
+ _ (set-block end-blk)
+ ret (add-instruction (->Const ::value))]
+ ret)))
+
+(defmethod sexpr-to-ssa 'recur
+ [[_ & vals]]
+ (gen-plan
+ [val-ids (all (map item-to-ssa vals))
+ recurs (get-binding :recur-nodes)
+ _ (do (assert (= (count val-ids)
+ (count recurs))
+ "Wrong number of arguments to recur")
+ (no-op))
+ _ (add-instruction (->Recur recurs val-ids))
+
+ recur-point (get-binding :recur-point)
+ _ (add-instruction (->Jmp nil recur-point))]
+ ::terminated))
+
+(defmethod sexpr-to-ssa 'if
+ [[_ test then else]]
+ (gen-plan
+ [test-id (item-to-ssa test)
+ then-blk (add-block)
+ else-blk (add-block)
+ final-blk (add-block)
+ _ (add-instruction (->CondBr test-id then-blk else-blk))
+
+ _ (set-block then-blk)
+ then-id (item-to-ssa then)
+ _ (if (not= then-id ::terminated)
+ (gen-plan
+ [_ (add-instruction (->Jmp then-id final-blk))]
+ then-id)
+ (no-op))
+
+ _ (set-block else-blk)
+ else-id (item-to-ssa else)
+ _ (if (not= else-id ::terminated)
+ (gen-plan
+ [_ (add-instruction (->Jmp else-id final-blk))]
+ then-id)
+ (no-op))
+
+ _ (set-block final-blk)
+ val-id (add-instruction (->Const ::value))]
+ val-id))
+
+(defmethod sexpr-to-ssa 'fn*
+ [& fn-expr]
+ ;; For fn expressions we just want to record the expression as well
+ ;; as a list of all known renamed locals
+ (gen-plan
+ [locals (get-binding :locals)
+ fn-id (add-instruction (->Fn fn-expr (keys locals) (vals locals)))]
+ fn-id))
+
+
+(def special-override? '#{case clojure.core/case
+ try clojure.core/try})
+
+(defn expand [locals env form]
+ (loop [form form]
+ (if-not (seq? form)
+ form
+ (let [[s & r] form]
+ (if (symbol? s)
+ (if (or (get locals s)
+ (special-override? s))
+ form
+ (let [new-env (update-in env [:locals] merge locals)
+ expanded (cljs/macroexpand-1 new-env form)]
+ (if (= expanded form)
+ form
+ (recur expanded))))
+ form)))))
+
+(defn terminate-custom [vals term]
+ (gen-plan
+ [blk (add-block)
+ vals (all (map item-to-ssa vals))
+ val (add-instruction (->CustomTerminator term blk vals))
+ _ (set-block blk)
+ res (add-instruction (->Const ::value))]
+ res))
+
+(defn fixup-aliases [sym env]
+ (let [aliases (ns-aliases *ns*)]
+ (if-not (namespace sym)
+ sym
+ (if-let [ns (or (get-in env [:ns :requires-macros (symbol (namespace sym))])
+ (get-in env [:ns :requires (symbol (namespace sym))]))]
+ (symbol (name ns) (name sym))
+ sym))))
+
+(defmethod -item-to-ssa :list
+ [lst]
+ (gen-plan
+ [env (get-binding :env)
+ locals (get-binding :locals)
+ terminators (get-binding :terminators)
+ val (let [exp (expand locals env lst)]
+ (if (seq? exp)
+ (if (symbol? (first exp))
+ (let [f (fixup-aliases (first exp) env)]
+ (cond
+ (is-special? f) (sexpr-to-ssa exp)
+ (get locals f) (default-sexpr exp)
+ (get terminators f) (terminate-custom (next exp) (get terminators f))
+ :else (default-sexpr exp)))
+ (default-sexpr exp))
+ (item-to-ssa exp)))]
+ val))
+
+(defmethod -item-to-ssa :default
+ [x]
+ (fn [plan]
+ [x plan]))
+
+(defmethod -item-to-ssa :symbol
+ [x]
+ (gen-plan
+ [locals (get-binding :locals)
+ inst-id (if (contains? locals x)
+ (fn [p]
+ [(locals x) p])
+ (fn [p]
+ [x p])
+ #_(add-instruction (->Const x)))]
+ inst-id))
+
+(defmethod -item-to-ssa :map
+ [x]
+ (-item-to-ssa `(hash-map ~@(mapcat identity x))))
+
+(defmethod -item-to-ssa :vector
+ [x]
+ (-item-to-ssa `(vector ~@x)))
+
+(defmethod -item-to-ssa :set
+ [x]
+ (-item-to-ssa `(hash-set ~@x)))
+
+(defn parse-to-state-machine
+ "Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as
+ a series of SSA style blocks."
+ [body env terminators]
+ (-> (gen-plan
+ [_ (push-binding :env env)
+ _ (push-binding :locals (zipmap (:locals (keys env)) (:locals (keys env))))
+ _ (push-binding :terminators terminators)
+ blk (add-block)
+ _ (set-block blk)
+ ids (all (map item-to-ssa body))
+ term-id (add-instruction (->Return (last ids)))
+ _ (pop-binding :terminators)
+ _ (pop-binding :locals)
+ _ (pop-binding :env)]
+ term-id)
+ get-plan))
+
+
+(defn index-instruction [blk-id idx inst]
+ (let [idx (reduce
+ (fn [acc id]
+ (update-in acc [id :read-in] (fnil conj #{}) blk-id))
+ idx
+ (filter instruction? (reads-from inst)))
+ idx (reduce
+ (fn [acc id]
+ (update-in acc [id :written-in] (fnil conj #{}) blk-id))
+ idx
+ (filter instruction? (writes-to inst)))]
+ idx))
+
+(defn index-block [idx [blk-id blk]]
+ (reduce (partial index-instruction blk-id) idx blk))
+
+(defn index-state-machine [machine]
+ (reduce index-block {} (:blocks machine)))
+
+(defn id-for-inst [m sym] ;; m :: symbols -> integers
+ (if-let [i (get @m sym)]
+ i
+ (let [next-idx (get @m ::next-idx)]
+ (swap! m assoc sym next-idx)
+ (swap! m assoc ::next-idx (inc next-idx))
+ next-idx)))
+
+(defn persistent-value?
+ "Returns true if this value should be saved in the state hash map"
+ [index value]
+ (or (not= (-> index value :read-in)
+ (-> index value :written-in))
+ (-> index value :read-in count (> 1))))
+
+(defn count-persistent-values
+ [index]
+ (->> (keys index)
+ (filter instruction?)
+ (filter (partial persistent-value? index))
+ count))
+
+(defn- build-block-preamble [local-map idx state-sym blk]
+ (let [args (->> (mapcat reads-from blk)
+ (filter instruction?)
+ (filter (partial persistent-value? idx))
+ set
+ vec)]
+ (if (empty? args)
+ []
+ (mapcat (fn [sym]
+ `[~sym (aget ~state-sym ~(id-for-inst local-map sym))])
+ args))))
+
+(defn- build-block-body [state-sym blk]
+ (mapcat
+ #(emit-instruction % state-sym)
+ (butlast blk)))
+
+(defn- build-new-state [local-map idx state-sym blk]
+ (let [results (->> blk
+ (mapcat writes-to)
+ (filter instruction?)
+ (filter (partial persistent-value? idx))
+ set
+ vec)
+ results (interleave (map (partial id-for-inst local-map) results) results)]
+ (if-not (empty? results)
+ `(aset-all! ~state-sym ~@results)
+ state-sym)))
+
+(defn- emit-state-machine [machine num-user-params custom-terminators]
+ (let [index (index-state-machine machine)
+ state-sym (with-meta (gensym "state_")
+ {:tag 'objects})
+ local-start-idx (+ num-user-params USER-START-IDX)
+ state-arr-size (+ local-start-idx (count-persistent-values index))
+ local-map (atom {::next-idx local-start-idx})
+ block-catches (:block-catches machine)
+ state-val-sym (gensym "state_val_")]
+ `(let [switch# (fn [~state-sym]
+ (let [~state-val-sym (aget ~state-sym ~STATE-IDX)]
+ (cond
+ ~@(mapcat
+ (fn [[id blk]]
+ [`(== ~state-val-sym ~id)
+ `(let [~@(concat (build-block-preamble local-map index state-sym blk)
+ (build-block-body state-sym blk))
+ ~state-sym ~(build-new-state local-map index state-sym blk)]
+ ~(terminate-block (last blk) state-sym custom-terminators))])
+ (:blocks machine)))))]
+ (fn state-machine#
+ ([] (aset-all! (make-array ~state-arr-size)
+ ~FN-IDX state-machine#
+ ~STATE-IDX ~(:start-block machine)))
+ ([~state-sym]
+ (let [ret-value# (try (loop []
+ (let [result# (switch# ~state-sym)]
+ (if (cljs.core/keyword-identical? result# :recur)
+ (recur)
+ result#)))
+ (catch js/Object ex#
+ (aset-all! ~state-sym ~CURRENT-EXCEPTION ex#)
+ (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
+ :recur))]
+ (if (cljs.core/keyword-identical? ret-value# :recur)
+ (recur ~state-sym)
+ ret-value#)))))))
+
+
+(def async-custom-terminators
+ {'! 'cljs.core.async.impl.ioc-helpers/put!
+ 'cljs.core.async/>! 'cljs.core.async.impl.ioc-helpers/put!
+ 'alts! 'cljs.core.async/ioc-alts!
+ 'cljs.core.async/alts! 'cljs.core.async/ioc-alts!
+ :Return 'cljs.core.async.impl.ioc-helpers/return-chan})
+
+
+(defn state-machine [body num-user-params env user-transitions]
+ (-> (parse-to-state-machine body env user-transitions)
+ second
+ (emit-state-machine num-user-params user-transitions)))
diff --git a/src/main/clojure/cljs/core/async/impl/protocols.cljs b/src/main/clojure/cljs/core/async/impl/protocols.cljs
new file mode 100644
index 0000000..793a3f1
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/protocols.cljs
@@ -0,0 +1,43 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns cljs.core.async.impl.protocols)
+
+(def ^:const MAX-QUEUE-SIZE 1024)
+
+(defprotocol ReadPort
+ (take! [port fn1-handler] "derefable val if taken, nil if take was enqueued"))
+
+(defprotocol WritePort
+ (put! [port val fn1-handler] "derefable boolean (false if already closed) if handled, nil if put was enqueued.
+ Must throw on nil val."))
+
+(defprotocol Channel
+ (close! [chan])
+ (closed? [chan]))
+
+(defprotocol Handler
+ (active? [h] "returns true if has callback. Must work w/o lock")
+ (blockable? [h] "returns true if this handler may be blocked, otherwise it must not block")
+ #_(lock-id [h] "a unique id for lock acquisition order, 0 if no lock")
+ (commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock"))
+
+(defprotocol Buffer
+ (full? [b] "returns true if buffer cannot accept put")
+ (remove! [b] "remove and return next item from buffer, called under chan mutex")
+ (add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex")
+ (close-buf! [b] "called on chan closed under chan mutex, return ignored"))
+
+(defn add!
+ ([b] b)
+ ([b itm]
+ (assert (not (nil? itm)))
+ (add!* b itm)))
+
+;; Defines a buffer that will never block (return true to full?)
+(defprotocol UnblockingBuffer)
diff --git a/src/main/clojure/cljs/core/async/impl/timers.cljs b/src/main/clojure/cljs/core/async/impl/timers.cljs
new file mode 100644
index 0000000..591e206
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/impl/timers.cljs
@@ -0,0 +1,167 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns cljs.core.async.impl.timers
+ (:require [cljs.core.async.impl.protocols :as impl]
+ [cljs.core.async.impl.channels :as channels]
+ [cljs.core.async.impl.dispatch :as dispatch]))
+
+(def MAX_LEVEL 15) ;; 16 levels
+(def P (/ 1 2))
+
+(defn random-level
+ ([] (random-level 0))
+ ([level]
+ (if (and (< (.random js/Math) P)
+ (< level MAX_LEVEL))
+ (recur (inc level))
+ level)))
+
+(deftype SkipListNode [key ^:mutable val forward]
+ ISeqable
+ (-seq [coll]
+ (list key val))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts]
+ (pr-sequential-writer writer pr-writer "[" " " "]" opts coll)))
+
+(defn skip-list-node
+ ([level] (skip-list-node nil nil level))
+ ([k v level]
+ (let [arr (make-array (inc level))]
+ (loop [i 0]
+ (when (< i (alength arr))
+ (aset arr i nil)
+ (recur (inc i))))
+ (SkipListNode. k v arr))))
+
+(defn least-greater-node
+ ([x k level] (least-greater-node x k level nil))
+ ([x k level update]
+ (if-not (neg? level)
+ (let [x (loop [x x]
+ (if-let [x' (aget (.-forward x) level)]
+ (if (< (.-key x') k)
+ (recur x')
+ x)
+ x))]
+ (when-not (nil? update)
+ (aset update level x))
+ (recur x k (dec level) update))
+ x)))
+
+(deftype SkipList [header ^:mutable level]
+ Object
+ (put [coll k v]
+ (let [update (make-array MAX_LEVEL)
+ x (least-greater-node header k level update)
+ x (aget (.-forward x) 0)]
+ (if (and (not (nil? x)) (== (.-key x) k))
+ (set! (.-val x) v)
+ (let [new-level (random-level)]
+ (when (> new-level level)
+ (loop [i (inc level)]
+ (when (<= i (inc new-level))
+ (aset update i header)
+ (recur (inc i))))
+ (set! level new-level))
+ (let [x (skip-list-node k v (make-array new-level))]
+ (loop [i 0]
+ (when (<= i level)
+ (let [links (.-forward (aget update i))]
+ (aset (.-forward x) i (aget links i))
+ (aset links i x)))))))))
+
+ (remove [coll k]
+ (let [update (make-array MAX_LEVEL)
+ x (least-greater-node header k level update)
+ x (aget (.-forward x) 0)]
+ (when (and (not (nil? x)) (== (.-key x) k))
+ (loop [i 0]
+ (when (<= i level)
+ (let [links (.-forward (aget update i))]
+ (if (identical? (aget links i) x)
+ (do
+ (aset links i (aget (.-forward x) i))
+ (recur (inc i)))
+ (recur (inc i))))))
+ (while (and (> level 0)
+ (nil? (aget (.-forward header) level)))
+ (set! level (dec level))))))
+
+ (ceilingEntry [coll k]
+ (loop [x header level level]
+ (if-not (neg? level)
+ (let [nx (loop [x x]
+ (let [x' (aget (.-forward x) level)]
+ (when-not (nil? x')
+ (if (>= (.-key x') k)
+ x'
+ (recur x')))))]
+ (if-not (nil? nx)
+ (recur nx (dec level))
+ (recur x (dec level))))
+ (when-not (identical? x header)
+ x))))
+
+ (floorEntry [coll k]
+ (loop [x header level level]
+ (if-not (neg? level)
+ (let [nx (loop [x x]
+ (let [x' (aget (.-forward x) level)]
+ (if-not (nil? x')
+ (if (> (.-key x') k)
+ x
+ (recur x'))
+ (when (zero? level)
+ x))))]
+ (if nx
+ (recur nx (dec level))
+ (recur x (dec level))))
+ (when-not (identical? x header)
+ x))))
+
+ ISeqable
+ (-seq [coll]
+ (letfn [(iter [node]
+ (lazy-seq
+ (when-not (nil? node)
+ (cons [(.-key node) (.-val node)]
+ (iter (aget (.-forward node) 0))))))]
+ (iter (aget (.-forward header) 0))))
+
+ IPrintWithWriter
+ (-pr-writer [coll writer opts]
+ (let [pr-pair (fn [keyval]
+ (pr-sequential-writer writer pr-writer "" " " "" opts keyval))]
+ (pr-sequential-writer writer pr-pair "{" ", " "}" opts coll))))
+
+(defn skip-list []
+ (SkipList. (skip-list-node 0) 0))
+
+(def timeouts-map (skip-list))
+
+(def TIMEOUT_RESOLUTION_MS 10)
+
+(defn timeout
+ "returns a channel that will close after msecs"
+ [msecs]
+ (let [timeout (+ (.valueOf (js/Date.)) msecs)
+ me (.ceilingEntry timeouts-map timeout)]
+ (or (when (and me (< (.-key me) (+ timeout TIMEOUT_RESOLUTION_MS)))
+ (.-val me))
+ (let [timeout-channel (channels/chan nil)]
+ (.put timeouts-map timeout timeout-channel)
+ (dispatch/queue-delay
+ (fn []
+ (.remove timeouts-map timeout)
+ (impl/close! timeout-channel))
+ msecs)
+ timeout-channel))))
+
diff --git a/src/main/clojure/cljs/core/async/macros.clj b/src/main/clojure/cljs/core/async/macros.clj
new file mode 100644
index 0000000..6c6a557
--- /dev/null
+++ b/src/main/clojure/cljs/core/async/macros.clj
@@ -0,0 +1,98 @@
+(ns cljs.core.async.macros
+ (:require [cljs.core.async.impl.ioc-macros :as ioc]))
+
+(defmacro go
+ "Asynchronously executes the body, returning immediately to the
+ calling thread. Additionally, any visible calls to ! and alt!/alts!
+ channel operations within the body will block (if necessary) by
+ 'parking' the calling thread rather than tying up an OS thread (or
+ the only JS thread when in ClojureScript). Upon completion of the
+ operation, the body will be resumed.
+
+ Returns a channel which will receive the result of the body when
+ completed"
+ [& body]
+ `(let [c# (cljs.core.async/chan 1)]
+ (cljs.core.async.impl.dispatch/run
+ (fn []
+ (let [f# ~(ioc/state-machine body 1 &env ioc/async-custom-terminators)
+ state# (-> (f#)
+ (ioc/aset-all! cljs.core.async.impl.ioc-helpers/USER-START-IDX c#))]
+ (cljs.core.async.impl.ioc-helpers/run-state-machine-wrapped state#))))
+ c#))
+
+
+(defn do-alt [alts clauses]
+ (assert (even? (count clauses)) "unbalanced clauses")
+ (let [clauses (partition 2 clauses)
+ opt? #(keyword? (first %))
+ opts (filter opt? clauses)
+ clauses (remove opt? clauses)
+ [clauses bindings]
+ (reduce
+ (fn [[clauses bindings] [ports expr]]
+ (let [ports (if (vector? ports) ports [ports])
+ [ports bindings]
+ (reduce
+ (fn [[ports bindings] port]
+ (if (vector? port)
+ (let [[port val] port
+ gp (gensym)
+ gv (gensym)]
+ [(conj ports [gp gv]) (conj bindings [gp port] [gv val])])
+ (let [gp (gensym)]
+ [(conj ports gp) (conj bindings [gp port])])))
+ [[] bindings] ports)]
+ [(conj clauses [ports expr]) bindings]))
+ [[] []] clauses)
+ gch (gensym "ch")
+ gret (gensym "ret")]
+ `(let [~@(mapcat identity bindings)
+ [val# ~gch :as ~gret] (~alts [~@(apply concat (map first clauses))] ~@(apply concat opts))]
+ (cond
+ ~@(mapcat (fn [[ports expr]]
+ [`(or ~@(map (fn [port]
+ `(= ~gch ~(if (vector? port) (first port) port)))
+ ports))
+ (if (and (seq? expr) (vector? (first expr)))
+ `(let [~(first expr) ~gret] ~@(rest expr))
+ expr)])
+ clauses)
+ (= ~gch :default) val#))))
+
+(defmacro alt!
+ "Makes a single choice between one of several channel operations,
+ as if by alts!, returning the value of the result expr corresponding
+ to the operation completed. Must be called inside a (go ...) block.
+
+ Each clause takes the form of:
+
+ channel-op[s] result-expr
+
+ where channel-ops is one of:
+
+ take-port - a single port to take
+ [take-port | [put-port put-val] ...] - a vector of ports as per alts!
+ :default | :priority - an option for alts!
+
+ and result-expr is either a list beginning with a vector, whereupon that
+ vector will be treated as a binding for the [val port] return of the
+ operation, else any other expression.
+
+ (alt!
+ [c t] ([val ch] (foo ch val))
+ x ([v] v)
+ [[out val]] :wrote
+ :default 42)
+
+ Each option may appear at most once. The choice and parking
+ characteristics are those of alts!."
+
+ [& clauses]
+ (do-alt 'alts! clauses))
+
+
+(defmacro go-loop
+ "Like (go (loop ...))"
+ [bindings & body]
+ `(go (loop ~bindings ~@body)))
diff --git a/src/main/clojure/cljs/core/async.cljs b/src/main/clojure/cljs/core/async.cljs
new file mode 100644
index 0000000..9cf8510
--- /dev/null
+++ b/src/main/clojure/cljs/core/async.cljs
@@ -0,0 +1,929 @@
+(ns cljs.core.async
+ (:refer-clojure :exclude [reduce transduce into merge map take partition partition-by])
+ (:require [cljs.core.async.impl.protocols :as impl]
+ [cljs.core.async.impl.channels :as channels]
+ [cljs.core.async.impl.buffers :as buffers]
+ [cljs.core.async.impl.timers :as timers]
+ [cljs.core.async.impl.dispatch :as dispatch]
+ [cljs.core.async.impl.ioc-helpers :as helpers])
+ (:require-macros [cljs.core.async.impl.ioc-macros :as ioc]
+ [cljs.core.async.macros :refer [go go-loop]]))
+
+(defn- fn-handler
+ ([f] (fn-handler f true))
+ ([f blockable]
+ (reify
+ impl/Handler
+ (active? [_] true)
+ (blockable? [_] blockable)
+ (commit [_] f))))
+
+(defn buffer
+ "Returns a fixed buffer of size n. When full, puts will block/park."
+ [n]
+ (buffers/fixed-buffer n))
+
+(defn dropping-buffer
+ "Returns a buffer of size n. When full, puts will complete but
+ val will be dropped (no transfer)."
+ [n]
+ (buffers/dropping-buffer n))
+
+(defn sliding-buffer
+ "Returns a buffer of size n. When full, puts will complete, and be
+ buffered, but oldest elements in buffer will be dropped (not
+ transferred)."
+ [n]
+ (buffers/sliding-buffer n))
+
+(defn unblocking-buffer?
+ "Returns true if a channel created with buff will never block. That is to say,
+ puts into this buffer will never cause the buffer to be full. "
+ [buff]
+ (satisfies? impl/UnblockingBuffer buff))
+
+(defn chan
+ "Creates a channel with an optional buffer, an optional transducer (like (map f),
+ (filter p) etc or a composition thereof), and an optional exception handler.
+ If buf-or-n is a number, will create and use a fixed buffer of that size. If a
+ transducer is supplied a buffer must be specified. ex-handler must be a
+ fn of one argument - if an exception occurs during transformation it will be called
+ with the thrown value as an argument, and any non-nil return value will be placed
+ in the channel."
+ ([] (chan nil))
+ ([buf-or-n] (chan buf-or-n nil nil))
+ ([buf-or-n xform] (chan buf-or-n xform nil))
+ ([buf-or-n xform ex-handler]
+ (let [buf-or-n (if (= buf-or-n 0)
+ nil
+ buf-or-n)]
+ (when xform (assert buf-or-n "buffer must be supplied when transducer is"))
+ (channels/chan (if (number? buf-or-n)
+ (buffer buf-or-n)
+ buf-or-n)
+ xform
+ ex-handler))))
+
+(defn promise-chan
+ "Creates a promise channel with an optional transducer, and an optional
+ exception-handler. A promise channel can take exactly one value that consumers
+ will receive. Once full, puts complete but val is dropped (no transfer).
+ Consumers will block until either a value is placed in the channel or the
+ channel is closed. See chan for the semantics of xform and ex-handler."
+ ([] (promise-chan nil))
+ ([xform] (promise-chan xform nil))
+ ([xform ex-handler]
+ (chan (buffers/promise-buffer) xform ex-handler)))
+
+(defn timeout
+ "Returns a channel that will close after msecs"
+ [msecs]
+ (timers/timeout msecs))
+
+(defn !
+ "puts a val into port. nil values are not allowed. Must be called
+ inside a (go ...) block. Will park if no buffer space is available.
+ Returns true unless port is already closed."
+ [port val]
+ (throw (js/Error. ">! used not in (go ...) block")))
+
+(defn put!
+ "Asynchronously puts a val into port, calling fn0 (if supplied) when
+ complete. nil values are not allowed. Will throw if closed. If
+ on-caller? (default true) is true, and the put is immediately
+ accepted, will call fn0 on calling thread. Returns nil."
+ ([port val]
+ (if-let [ret (impl/put! port val fhnop)]
+ @ret
+ true))
+ ([port val fn1] (put! port val fn1 true))
+ ([port val fn1 on-caller?]
+ (if-let [retb (impl/put! port val (fn-handler fn1))]
+ (let [ret @retb]
+ (if on-caller?
+ (fn1 ret)
+ (dispatch/run #(fn1 ret)))
+ ret)
+ true)))
+
+(defn close!
+ ([port]
+ (impl/close! port)))
+
+
+(defn- random-array
+ [n]
+ (let [a (make-array n)]
+ (dotimes [x n]
+ (aset a x 0))
+ (loop [i 1]
+ (if (= i n)
+ a
+ (do
+ (let [j (rand-int i)]
+ (aset a i (aget a j))
+ (aset a j i)
+ (recur (inc i))))))))
+
+(defn- alt-flag []
+ (let [flag (atom true)]
+ (reify
+ impl/Handler
+ (active? [_] @flag)
+ (blockable? [_] true)
+ (commit [_]
+ (reset! flag nil)
+ true))))
+
+(defn- alt-handler [flag cb]
+ (reify
+ impl/Handler
+ (active? [_] (impl/active? flag))
+ (blockable? [_] true)
+ (commit [_]
+ (impl/commit flag)
+ cb)))
+
+(defn do-alts
+ "returns derefable [val port] if immediate, nil if enqueued"
+ [fret ports opts]
+ (let [flag (alt-flag)
+ n (count ports)
+ idxs (random-array n)
+ priority (:priority opts)
+ ret
+ (loop [i 0]
+ (when (< i n)
+ (let [idx (if priority i (aget idxs i))
+ port (nth ports idx)
+ wport (when (vector? port) (port 0))
+ vbox (if wport
+ (let [val (port 1)]
+ (impl/put! wport val (alt-handler flag #(fret [% wport]))))
+ (impl/take! port (alt-handler flag #(fret [% port]))))]
+ (if vbox
+ (channels/box [@vbox (or wport port)])
+ (recur (inc i))))))]
+ (or
+ ret
+ (when (contains? opts :default)
+ (when-let [got (and (impl/active? flag) (impl/commit flag))]
+ (channels/box [(:default opts) :default]))))))
+
+(defn alts!
+ "Completes at most one of several channel operations. Must be called
+ inside a (go ...) block. ports is a vector of channel endpoints,
+ which can be either a channel to take from or a vector of
+ [channel-to-put-to val-to-put], in any combination. Takes will be
+ made as if by !. Unless
+ the :priority option is true, if more than one port operation is
+ ready a non-deterministic choice will be made. If no operation is
+ ready and a :default value is supplied, [default-val :default] will
+ be returned, otherwise alts! will park until the first operation to
+ become ready completes. Returns [val port] of the completed
+ operation, where val is the value taken for takes, and a
+ boolean (true unless already closed, as per put!) for puts.
+
+ opts are passed as :key val ... Supported options:
+
+ :default val - the value to use if none of the operations are immediately ready
+ :priority true - (default nil) when true, the operations will be tried in order.
+
+ Note: there is no guarantee that the port exps or val exprs will be
+ used, nor in what order should they be, so they should not be
+ depended upon for side effects."
+
+ [ports & {:as opts}]
+ (throw (js/Error. "alts! used not in (go ...) block")))
+
+(defn offer!
+ "Puts a val into port if it's possible to do so immediately.
+ nil values are not allowed. Never blocks. Returns true if offer succeeds."
+ [port val]
+ (let [ret (impl/put! port val (fn-handler nop false))]
+ (when ret @ret)))
+
+(defn poll!
+ "Takes a val from port if it's possible to do so immediately.
+ Never blocks. Returns value if successful, nil otherwise."
+ [port]
+ (let [ret (impl/take! port (fn-handler nop false))]
+ (when ret @ret)))
+
+;;;;;;; channel ops
+
+(defn pipe
+ "Takes elements from the from channel and supplies them to the to
+ channel. By default, the to channel will be closed when the from
+ channel closes, but can be determined by the close? parameter. Will
+ stop consuming the from channel if the to channel closes"
+
+ ([from to] (pipe from to true))
+ ([from to close?]
+ (go-loop []
+ (let [v (! to v)
+ (recur)))))
+ to))
+
+(defn- pipeline*
+ ([n to xf from close? ex-handler type]
+ (assert (pos? n))
+ (let [jobs (chan n)
+ results (chan n)
+ process (fn [[v p :as job]]
+ (if (nil? job)
+ (do (close! results) nil)
+ (let [res (chan 1 xf ex-handler)]
+ (go
+ (>! res v)
+ (close! res))
+ (put! p res)
+ true)))
+ async (fn [[v p :as job]]
+ (if (nil? job)
+ (do (close! results) nil)
+ (let [res (chan 1)]
+ (xf v res)
+ (put! p res)
+ true)))]
+ (dotimes [_ n]
+ (case type
+ :compute (go-loop []
+ (let [job (! jobs [v p])
+ (>! results p)
+ (recur)))))
+ (go-loop []
+ (let [p (! to v))
+ (recur))))
+ (recur))))))))
+
+(defn pipeline-async
+ "Takes elements from the from channel and supplies them to the to
+ channel, subject to the async function af, with parallelism n. af
+ must be a function of two arguments, the first an input value and
+ the second a channel on which to place the result(s). af must close!
+ the channel before returning. The presumption is that af will
+ return immediately, having launched some asynchronous operation
+ whose completion/callback will manipulate the result channel. Outputs
+ will be returned in order relative to the inputs. By default, the to
+ channel will be closed when the from channel closes, but can be
+ determined by the close? parameter. Will stop consuming the from
+ channel if the to channel closes."
+ ([n to af from] (pipeline-async n to af from true))
+ ([n to af from close?] (pipeline* n to af from close? nil :async)))
+
+(defn pipeline
+ "Takes elements from the from channel and supplies them to the to
+ channel, subject to the transducer xf, with parallelism n. Because
+ it is parallel, the transducer will be applied independently to each
+ element, not across elements, and may produce zero or more outputs
+ per input. Outputs will be returned in order relative to the
+ inputs. By default, the to channel will be closed when the from
+ channel closes, but can be determined by the close? parameter. Will
+ stop consuming the from channel if the to channel closes.
+
+ Note this is supplied for API compatibility with the Clojure version.
+ Values of N > 1 will not result in actual concurrency in a
+ single-threaded runtime."
+ ([n to xf from] (pipeline n to xf from true))
+ ([n to xf from close?] (pipeline n to xf from close? nil))
+ ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute)))
+
+(defn split
+ "Takes a predicate and a source channel and returns a vector of two
+ channels, the first of which will contain the values for which the
+ predicate returned true, the second those for which it returned
+ false.
+
+ The out channels will be unbuffered by default, or two buf-or-ns can
+ be supplied. The channels will close after the source channel has
+ closed."
+ ([p ch] (split p ch nil nil))
+ ([p ch t-buf-or-n f-buf-or-n]
+ (let [tc (chan t-buf-or-n)
+ fc (chan f-buf-or-n)]
+ (go-loop []
+ (let [v (! (if (p v) tc fc) v)
+ (recur)))))
+ [tc fc])))
+
+(defn reduce
+ "f should be a function of 2 arguments. Returns a channel containing
+ the single result of applying f to init and the first item from the
+ channel, then applying f to that result and the 2nd item, etc. If
+ the channel closes without yielding items, returns init and f is not
+ called. ch must close before reduce produces a result."
+ [f init ch]
+ (go-loop [ret init]
+ (let [v (! ch (first vs)))
+ (recur (next vs))
+ (when close?
+ (close! ch))))))
+
+
+(defn to-chan
+ "Creates and returns a channel which contains the contents of coll,
+ closing when exhausted."
+ [coll]
+ (let [ch (chan (bounded-count 100 coll))]
+ (onto-chan ch coll)
+ ch))
+
+
+(defprotocol Mux
+ (muxch* [_]))
+
+(defprotocol Mult
+ (tap* [m ch close?])
+ (untap* [m ch])
+ (untap-all* [m]))
+
+(defn mult
+ "Creates and returns a mult(iple) of the supplied channel. Channels
+ containing copies of the channel can be created with 'tap', and
+ detached with 'untap'.
+
+ Each item is distributed to all taps in parallel and synchronously,
+ i.e. each tap must accept before the next item is distributed. Use
+ buffering/windowing to prevent slow taps from holding up the mult.
+
+ Items received when there are no taps get dropped.
+
+ If a tap puts to a closed channel, it will be removed from the mult."
+ [ch]
+ (let [cs (atom {}) ;;ch->close?
+ m (reify
+ Mux
+ (muxch* [_] ch)
+
+ Mult
+ (tap* [_ ch close?] (swap! cs assoc ch close?) nil)
+ (untap* [_ ch] (swap! cs dissoc ch) nil)
+ (untap-all* [_] (reset! cs {}) nil))
+ dchan (chan 1)
+ dctr (atom nil)
+ done (fn [_] (when (zero? (swap! dctr dec))
+ (put! dchan true)))]
+ (go-loop []
+ (let [val (attrs-map
+ solo-modes #{:mute :pause}
+ attrs (conj solo-modes :solo)
+ solo-mode (atom :mute)
+ change (chan)
+ changed #(put! change true)
+ pick (fn [attr chs]
+ (reduce-kv
+ (fn [ret c v]
+ (if (attr v)
+ (conj ret c)
+ ret))
+ #{} chs))
+ calc-state (fn []
+ (let [chs @cs
+ mode @solo-mode
+ solos (pick :solo chs)
+ pauses (pick :pause chs)]
+ {:solos solos
+ :mutes (pick :mute chs)
+ :reads (conj
+ (if (and (= mode :pause) (not (empty? solos)))
+ (vec solos)
+ (vec (remove pauses (keys chs))))
+ change)}))
+ m (reify
+ Mux
+ (muxch* [_] out)
+ Mix
+ (admix* [_ ch] (swap! cs assoc ch {}) (changed))
+ (unmix* [_ ch] (swap! cs dissoc ch) (changed))
+ (unmix-all* [_] (reset! cs {}) (changed))
+ (toggle* [_ state-map] (swap! cs (partial merge-with cljs.core/merge) state-map) (changed))
+ (solo-mode* [_ mode]
+ (assert (solo-modes mode) (str "mode must be one of: " solo-modes))
+ (reset! solo-mode mode)
+ (changed)))]
+ (go-loop [{:keys [solos mutes reads] :as state} (calc-state)]
+ (let [[v c] (alts! reads)]
+ (if (or (nil? v) (= c change))
+ (do (when (nil? v)
+ (swap! cs dissoc c))
+ (recur (calc-state)))
+ (if (or (solos c)
+ (and (empty? solos) (not (mutes c))))
+ (when (>! out v)
+ (recur state))
+ (recur state)))))
+ m))
+
+(defn admix
+ "Adds ch as an input to the mix"
+ [mix ch]
+ (admix* mix ch))
+
+(defn unmix
+ "Removes ch as an input to the mix"
+ [mix ch]
+ (unmix* mix ch))
+
+(defn unmix-all
+ "removes all inputs from the mix"
+ [mix]
+ (unmix-all* mix))
+
+(defn toggle
+ "Atomically sets the state(s) of one or more channels in a mix. The
+ state map is a map of channels -> channel-state-map. A
+ channel-state-map is a map of attrs -> boolean, where attr is one or
+ more of :mute, :pause or :solo. Any states supplied are merged with
+ the current state.
+
+ Note that channels can be added to a mix via toggle, which can be
+ used to add channels in a particular (e.g. paused) state."
+ [mix state-map]
+ (toggle* mix state-map))
+
+(defn solo-mode
+ "Sets the solo mode of the mix. mode must be one of :mute or :pause"
+ [mix mode]
+ (solo-mode* mix mode))
+
+
+(defprotocol Pub
+ (sub* [p v ch close?])
+ (unsub* [p v ch])
+ (unsub-all* [p] [p v]))
+
+(defn pub
+ "Creates and returns a pub(lication) of the supplied channel,
+ partitioned into topics by the topic-fn. topic-fn will be applied to
+ each value on the channel and the result will determine the 'topic'
+ on which that value will be put. Channels can be subscribed to
+ receive copies of topics using 'sub', and unsubscribed using
+ 'unsub'. Each topic will be handled by an internal mult on a
+ dedicated channel. By default these internal channels are
+ unbuffered, but a buf-fn can be supplied which, given a topic,
+ creates a buffer with desired properties.
+
+ Each item is distributed to all subs in parallel and synchronously,
+ i.e. each sub must accept before the next item is distributed. Use
+ buffering/windowing to prevent slow subs from holding up the pub.
+
+ Items received when there are no matching subs get dropped.
+
+ Note that if buf-fns are used then each topic is handled
+ asynchronously, i.e. if a channel is subscribed to more than one
+ topic it should not expect them to be interleaved identically with
+ the source."
+ ([ch topic-fn] (pub ch topic-fn (constantly nil)))
+ ([ch topic-fn buf-fn]
+ (let [mults (atom {}) ;;topic->mult
+ ensure-mult (fn [topic]
+ (or (get @mults topic)
+ (get (swap! mults
+ #(if (% topic) % (assoc % topic (mult (chan (buf-fn topic))))))
+ topic)))
+ p (reify
+ Mux
+ (muxch* [_] ch)
+
+ Pub
+ (sub* [p topic ch close?]
+ (let [m (ensure-mult topic)]
+ (tap m ch close?)))
+ (unsub* [p topic ch]
+ (when-let [m (get @mults topic)]
+ (untap m ch)))
+ (unsub-all* [_] (reset! mults {}))
+ (unsub-all* [_ topic] (swap! mults dissoc topic)))]
+ (go-loop []
+ (let [val (! (muxch* m) val)
+ (swap! mults dissoc topic)))
+ (recur)))))
+ p)))
+
+(defn sub
+ "Subscribes a channel to a topic of a pub.
+
+ By default the channel will be closed when the source closes,
+ but can be determined by the close? parameter."
+ ([p topic ch] (sub p topic ch true))
+ ([p topic ch close?] (sub* p topic ch close?)))
+
+(defn unsub
+ "Unsubscribes a channel from a topic of a pub"
+ [p topic ch]
+ (unsub* p topic ch))
+
+(defn unsub-all
+ "Unsubscribes all channels from a pub, or a topic of a pub"
+ ([p] (unsub-all* p))
+ ([p topic] (unsub-all* p topic)))
+
+
+;;;;
+
+(defn map
+ "Takes a function and a collection of source channels, and returns a
+ channel which contains the values produced by applying f to the set
+ of first items taken from each source channel, followed by applying
+ f to the set of second items from each channel, until any one of the
+ channels is closed, at which point the output channel will be
+ closed. The returned channel will be unbuffered by default, or a
+ buf-or-n can be supplied"
+ ([f chs] (map f chs nil))
+ ([f chs buf-or-n]
+ (let [chs (vec chs)
+ out (chan buf-or-n)
+ cnt (count chs)
+ rets (object-array cnt)
+ dchan (chan 1)
+ dctr (atom nil)
+ done (mapv (fn [i]
+ (fn [ret]
+ (aset rets i ret)
+ (when (zero? (swap! dctr dec))
+ (put! dchan (.slice rets 0)))))
+ (range cnt))]
+ (go-loop []
+ (reset! dctr cnt)
+ (dotimes [i cnt]
+ (try
+ (take! (chs i) (done i))
+ (catch js/Object e
+ (swap! dctr dec))))
+ (let [rets (! out (apply f rets))
+ (recur)))))
+ out)))
+
+(defn merge
+ "Takes a collection of source channels and returns a channel which
+ contains all values taken from them. The returned channel will be
+ unbuffered by default, or a buf-or-n can be supplied. The channel
+ will close after all the source channels have closed."
+ ([chs] (merge chs nil))
+ ([chs buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go-loop [cs (vec chs)]
+ (if (pos? (count cs))
+ (let [[v c] (alts! cs)]
+ (if (nil? v)
+ (recur (filterv #(not= c %) cs))
+ (do (>! out v)
+ (recur cs))))
+ (close! out)))
+ out)))
+
+(defn into
+ "Returns a channel containing the single (collection) result of the
+ items taken from the channel conjoined to the supplied
+ collection. ch must close before into produces a result."
+ [coll ch]
+ (reduce conj coll ch))
+
+(defn take
+ "Returns a channel that will return, at most, n items from ch. After n items
+ have been returned, or ch has been closed, the return chanel will close.
+
+ The output channel is unbuffered by default, unless buf-or-n is given."
+ ([n ch]
+ (take n ch nil))
+ ([n ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [x 0]
+ (when (< x n)
+ (let [v (! out v)
+ (recur (inc x))))))
+ (close! out))
+ out)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn map<
+ "Deprecated - this function will be removed. Use transducer instead"
+ [f ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+ (closed? [_] (impl/closed? ch))
+
+ impl/ReadPort
+ (take! [_ fn1]
+ (let [ret
+ (impl/take! ch
+ (reify
+ impl/Handler
+ (active? [_] (impl/active? fn1))
+ (blockable? [_] true)
+ #_(lock-id [_] (impl/lock-id fn1))
+ (commit [_]
+ (let [f1 (impl/commit fn1)]
+ #(f1 (if (nil? %) nil (f %)))))))]
+ (if (and ret (not (nil? @ret)))
+ (channels/box (f @ret))
+ ret)))
+
+ impl/WritePort
+ (put! [_ val fn1] (impl/put! ch val fn1))))
+
+(defn map>
+ "Deprecated - this function will be removed. Use transducer instead"
+ [f ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+
+ impl/ReadPort
+ (take! [_ fn1] (impl/take! ch fn1))
+
+ impl/WritePort
+ (put! [_ val fn1]
+ (impl/put! ch (f val) fn1))))
+
+(defn filter>
+ "Deprecated - this function will be removed. Use transducer instead"
+ [p ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+ (closed? [_] (impl/closed? ch))
+
+ impl/ReadPort
+ (take! [_ fn1] (impl/take! ch fn1))
+
+ impl/WritePort
+ (put! [_ val fn1]
+ (if (p val)
+ (impl/put! ch val fn1)
+ (channels/box (not (impl/closed? ch)))))))
+
+(defn remove>
+ "Deprecated - this function will be removed. Use transducer instead"
+ [p ch]
+ (filter> (complement p) ch))
+
+(defn filter<
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([p ch] (filter< p ch nil))
+ ([p ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go-loop []
+ (let [val (! out val))
+ (recur)))))
+ out)))
+
+(defn remove<
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([p ch] (remove< p ch nil))
+ ([p ch buf-or-n] (filter< (complement p) ch buf-or-n)))
+
+(defn- mapcat* [f in out]
+ (go-loop []
+ (let [val (! out v))
+ (when-not (impl/closed? out)
+ (recur)))))))
+
+(defn mapcat<
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([f in] (mapcat< f in nil))
+ ([f in buf-or-n]
+ (let [out (chan buf-or-n)]
+ (mapcat* f in out)
+ out)))
+
+(defn mapcat>
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([f out] (mapcat> f out nil))
+ ([f out buf-or-n]
+ (let [in (chan buf-or-n)]
+ (mapcat* f in out)
+ in)))
+
+(defn unique
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([ch]
+ (unique ch nil))
+ ([ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [last nil]
+ (let [v (! out v)
+ (recur v))))))
+ (close! out))
+ out)))
+
+(defn partition
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([n ch]
+ (partition n ch nil))
+ ([n ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [arr (make-array n)
+ idx 0]
+ (let [v (! out (vec arr))
+ (recur (make-array n) 0)))))
+ (do (when (> idx 0)
+ (>! out (vec arr)))
+ (close! out))))))
+ out)))
+
+
+(defn partition-by
+ "Deprecated - this function will be removed. Use transducer instead"
+ ([f ch]
+ (partition-by f ch nil))
+ ([f ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [lst (make-array 0)
+ last ::nothing]
+ (let [v (! out (vec lst))
+ (let [new-lst (make-array 0)]
+ (.push new-lst v)
+ (recur new-lst new-itm)))))
+ (do (when (> (alength lst) 0)
+ (>! out (vec lst)))
+ (close! out))))))
+ out)))
diff --git a/src/main/clojure/clojure/core/async/impl/buffers.clj b/src/main/clojure/clojure/core/async/impl/buffers.clj
new file mode 100644
index 0000000..9eeaba5
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/buffers.clj
@@ -0,0 +1,96 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.buffers
+ (:require [clojure.core.async.impl.protocols :as impl])
+ (:import [java.util LinkedList Queue]))
+
+(set! *warn-on-reflection* true)
+
+(deftype FixedBuffer [^LinkedList buf ^long n]
+ impl/Buffer
+ (full? [this]
+ (>= (.size buf) n))
+ (remove! [this]
+ (.removeLast buf))
+ (add!* [this itm]
+ (.addFirst buf itm)
+ this)
+ (close-buf! [this])
+ clojure.lang.Counted
+ (count [this]
+ (.size buf)))
+
+(defn fixed-buffer [^long n]
+ (FixedBuffer. (LinkedList.) n))
+
+
+(deftype DroppingBuffer [^LinkedList buf ^long n]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [this]
+ false)
+ (remove! [this]
+ (.removeLast buf))
+ (add!* [this itm]
+ (when-not (>= (.size buf) n)
+ (.addFirst buf itm))
+ this)
+ (close-buf! [this])
+ clojure.lang.Counted
+ (count [this]
+ (.size buf)))
+
+(defn dropping-buffer [n]
+ (DroppingBuffer. (LinkedList.) n))
+
+(deftype SlidingBuffer [^LinkedList buf ^long n]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [this]
+ false)
+ (remove! [this]
+ (.removeLast buf))
+ (add!* [this itm]
+ (when (= (.size buf) n)
+ (impl/remove! this))
+ (.addFirst buf itm)
+ this)
+ (close-buf! [this])
+ clojure.lang.Counted
+ (count [this]
+ (.size buf)))
+
+(defn sliding-buffer [n]
+ (SlidingBuffer. (LinkedList.) n))
+
+(defonce ^:private NO-VAL (Object.))
+(defn- undelivered? [val]
+ (identical? NO-VAL val))
+
+(deftype PromiseBuffer [^:unsynchronized-mutable val]
+ impl/UnblockingBuffer
+ impl/Buffer
+ (full? [_]
+ false)
+ (remove! [_]
+ val)
+ (add!* [this itm]
+ (when (undelivered? val)
+ (set! val itm))
+ this)
+ (close-buf! [_]
+ (when (undelivered? val)
+ (set! val nil)))
+ clojure.lang.Counted
+ (count [_]
+ (if (undelivered? val) 0 1)))
+
+(defn promise-buffer []
+ (PromiseBuffer. NO-VAL))
\ No newline at end of file
diff --git a/src/main/clojure/clojure/core/async/impl/channels.clj b/src/main/clojure/clojure/core/async/impl/channels.clj
new file mode 100644
index 0000000..063ffef
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/channels.clj
@@ -0,0 +1,303 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.channels
+ (:require [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [clojure.core.async.impl.mutex :as mutex])
+ (:import [java.util LinkedList Queue Iterator]
+ [java.util.concurrent.locks Lock]))
+
+(set! *warn-on-reflection* true)
+
+(defmacro assert-unlock [lock test msg]
+ `(when-not ~test
+ (.unlock ~lock)
+ (throw (new AssertionError (str "Assert failed: " ~msg "\n" (pr-str '~test))))))
+
+(defn box [val]
+ (reify clojure.lang.IDeref
+ (deref [_] val)))
+
+(defprotocol MMC
+ (cleanup [_])
+ (abort [_]))
+
+(deftype ManyToManyChannel [^LinkedList takes ^LinkedList puts ^Queue buf closed ^Lock mutex add!]
+ MMC
+ (cleanup
+ [_]
+ (when-not (.isEmpty takes)
+ (let [iter (.iterator takes)]
+ (loop [taker (.next iter)]
+ (when-not (impl/active? taker)
+ (.remove iter))
+ (when (.hasNext iter)
+ (recur (.next iter))))))
+ (when-not (.isEmpty puts)
+ (let [iter (.iterator puts)]
+ (loop [[putter] (.next iter)]
+ (when-not (impl/active? putter)
+ (.remove iter))
+ (when (.hasNext iter)
+ (recur (.next iter)))))))
+
+ (abort
+ [this]
+ (let [iter (.iterator puts)]
+ (when (.hasNext iter)
+ (loop [^Lock putter (.next iter)]
+ (.lock putter)
+ (let [put-cb (and (impl/active? putter) (impl/commit putter))]
+ (.unlock putter)
+ (when put-cb
+ (dispatch/run (fn [] (put-cb true))))
+ (when (.hasNext iter)
+ (recur (.next iter)))))))
+ (.clear puts)
+ (impl/close! this))
+
+ impl/WritePort
+ (put!
+ [this val handler]
+ (when (nil? val)
+ (throw (IllegalArgumentException. "Can't put nil on channel")))
+ (.lock mutex)
+ (cleanup this)
+ (if @closed
+ (do (.unlock mutex)
+ (box false))
+ (let [^Lock handler handler]
+ (if (and buf (not (impl/full? buf)) (not (.isEmpty takes)))
+ (do
+ (.lock handler)
+ (let [put-cb (and (impl/active? handler) (impl/commit handler))]
+ (.unlock handler)
+ (if put-cb
+ (let [done? (reduced? (add! buf val))]
+ (if (pos? (count buf))
+ (let [iter (.iterator takes)
+ take-cbs (loop [takers []]
+ (if (and (.hasNext iter) (pos? (count buf)))
+ (let [^Lock taker (.next iter)]
+ (.lock taker)
+ (let [ret (and (impl/active? taker) (impl/commit taker))]
+ (.unlock taker)
+ (if ret
+ (let [val (impl/remove! buf)]
+ (.remove iter)
+ (recur (conj takers (fn [] (ret val)))))
+ (recur takers))))
+ takers))]
+ (if (seq take-cbs)
+ (do
+ (when done?
+ (abort this))
+ (.unlock mutex)
+ (doseq [f take-cbs]
+ (dispatch/run f)))
+ (do
+ (when done?
+ (abort this))
+ (.unlock mutex))))
+ (do
+ (when done?
+ (abort this))
+ (.unlock mutex)))
+ (box true))
+ (do (.unlock mutex)
+ nil))))
+ (let [iter (.iterator takes)
+ [put-cb take-cb] (when (.hasNext iter)
+ (loop [^Lock taker (.next iter)]
+ (if (< (impl/lock-id handler) (impl/lock-id taker))
+ (do (.lock handler) (.lock taker))
+ (do (.lock taker) (.lock handler)))
+ (let [ret (when (and (impl/active? handler) (impl/active? taker))
+ [(impl/commit handler) (impl/commit taker)])]
+ (.unlock handler)
+ (.unlock taker)
+ (if ret
+ (do
+ (.remove iter)
+ ret)
+ (when (.hasNext iter)
+ (recur (.next iter)))))))]
+ (if (and put-cb take-cb)
+ (do
+ (.unlock mutex)
+ (dispatch/run (fn [] (take-cb val)))
+ (box true))
+ (if (and buf (not (impl/full? buf)))
+ (do
+ (.lock handler)
+ (let [put-cb (and (impl/active? handler) (impl/commit handler))]
+ (.unlock handler)
+ (if put-cb
+ (let [done? (reduced? (add! buf val))]
+ (when done?
+ (abort this))
+ (.unlock mutex)
+ (box true))
+ (do (.unlock mutex)
+ nil))))
+ (do
+ (when (and (impl/active? handler) (impl/blockable? handler))
+ (assert-unlock mutex
+ (< (.size puts) impl/MAX-QUEUE-SIZE)
+ (str "No more than " impl/MAX-QUEUE-SIZE
+ " pending puts are allowed on a single channel."
+ " Consider using a windowed buffer."))
+ (.add puts [handler val]))
+ (.unlock mutex)
+ nil))))))))
+
+ impl/ReadPort
+ (take!
+ [this handler]
+ (.lock mutex)
+ (cleanup this)
+ (let [^Lock handler handler
+ commit-handler (fn []
+ (.lock handler)
+ (let [take-cb (and (impl/active? handler) (impl/commit handler))]
+ (.unlock handler)
+ take-cb))]
+ (if (and buf (pos? (count buf)))
+ (do
+ (if-let [take-cb (commit-handler)]
+ (let [val (impl/remove! buf)
+ iter (.iterator puts)
+ [done? cbs]
+ (when (.hasNext iter)
+ (loop [cbs []
+ [^Lock putter val] (.next iter)]
+ (.lock putter)
+ (let [cb (and (impl/active? putter) (impl/commit putter))]
+ (.unlock putter)
+ (.remove iter)
+ (let [cbs (if cb (conj cbs cb) cbs)
+ done? (when cb (reduced? (add! buf val)))]
+ (if (and (not done?) (not (impl/full? buf)) (.hasNext iter))
+ (recur cbs (.next iter))
+ [done? cbs])))))]
+ (when done?
+ (abort this))
+ (.unlock mutex)
+ (doseq [cb cbs]
+ (dispatch/run #(cb true)))
+ (box val))
+ (do (.unlock mutex)
+ nil)))
+ (let [iter (.iterator puts)
+ [take-cb put-cb val]
+ (when (.hasNext iter)
+ (loop [[^Lock putter val] (.next iter)]
+ (if (< (impl/lock-id handler) (impl/lock-id putter))
+ (do (.lock handler) (.lock putter))
+ (do (.lock putter) (.lock handler)))
+ (let [ret (when (and (impl/active? handler) (impl/active? putter))
+ [(impl/commit handler) (impl/commit putter) val])]
+ (.unlock handler)
+ (.unlock putter)
+ (if ret
+ (do
+ (.remove iter)
+ ret)
+ (when-not (impl/active? putter)
+ (.remove iter)
+ (when (.hasNext iter)
+ (recur (.next iter))))))))]
+ (if (and put-cb take-cb)
+ (do
+ (.unlock mutex)
+ (dispatch/run #(put-cb true))
+ (box val))
+ (if @closed
+ (do
+ (when buf (add! buf))
+ (let [has-val (and buf (pos? (count buf)))]
+ (if-let [take-cb (commit-handler)]
+ (let [val (when has-val (impl/remove! buf))]
+ (.unlock mutex)
+ (box val))
+ (do
+ (.unlock mutex)
+ nil))))
+ (do
+ (when (impl/blockable? handler)
+ (assert-unlock mutex
+ (< (.size takes) impl/MAX-QUEUE-SIZE)
+ (str "No more than " impl/MAX-QUEUE-SIZE
+ " pending takes are allowed on a single channel."))
+ (.add takes handler))
+ (.unlock mutex)
+ nil)))))))
+
+ impl/Channel
+ (closed? [_] @closed)
+ (close!
+ [this]
+ (.lock mutex)
+ (cleanup this)
+ (if @closed
+ (do
+ (.unlock mutex)
+ nil)
+ (do
+ (reset! closed true)
+ (when (and buf (.isEmpty puts))
+ (add! buf))
+ (let [iter (.iterator takes)]
+ (when (.hasNext iter)
+ (loop [^Lock taker (.next iter)]
+ (.lock taker)
+ (let [take-cb (and (impl/active? taker) (impl/commit taker))]
+ (.unlock taker)
+ (when take-cb
+ (let [val (when (and buf (pos? (count buf))) (impl/remove! buf))]
+ (dispatch/run (fn [] (take-cb val)))))
+ (.remove iter)
+ (when (.hasNext iter)
+ (recur (.next iter)))))))
+ (when buf (impl/close-buf! buf))
+ (.unlock mutex)
+ nil))))
+
+(defn- ex-handler [ex]
+ (-> (Thread/currentThread)
+ .getUncaughtExceptionHandler
+ (.uncaughtException (Thread/currentThread) ex))
+ nil)
+
+(defn- handle [buf exh t]
+ (let [else ((or exh ex-handler) t)]
+ (if (nil? else)
+ buf
+ (impl/add! buf else))))
+
+(defn chan
+ ([buf] (chan buf nil))
+ ([buf xform] (chan buf xform nil))
+ ([buf xform exh]
+ (ManyToManyChannel.
+ (LinkedList.) (LinkedList.) buf (atom false) (mutex/mutex)
+ (let [add! (if xform (xform impl/add!) impl/add!)]
+ (fn
+ ([buf]
+ (try
+ (add! buf)
+ (catch Throwable t
+ (handle buf exh t))))
+ ([buf val]
+ (try
+ (add! buf val)
+ (catch Throwable t
+ (handle buf exh t)))))))))
+
diff --git a/src/main/clojure/clojure/core/async/impl/concurrent.clj b/src/main/clojure/clojure/core/async/impl/concurrent.clj
new file mode 100644
index 0000000..a197f03
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/concurrent.clj
@@ -0,0 +1,30 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.concurrent
+ (:import [java.util.concurrent ThreadFactory]))
+
+(set! *warn-on-reflection* true)
+
+(defn counted-thread-factory
+ "Create a ThreadFactory that maintains a counter for naming Threads.
+ name-format specifies thread names - use %d to include counter
+ daemon is a flag for whether threads are daemons or not"
+ [name-format daemon]
+ (let [counter (atom 0)]
+ (reify
+ ThreadFactory
+ (newThread [this runnable]
+ (doto (Thread. runnable)
+ (.setName (format name-format (swap! counter inc)))
+ (.setDaemon daemon))))))
+
+(defonce
+ ^{:doc "Number of processors reported by the JVM"}
+ processors (.availableProcessors (Runtime/getRuntime)))
diff --git a/src/main/clojure/clojure/core/async/impl/dispatch.clj b/src/main/clojure/clojure/core/async/impl/dispatch.clj
new file mode 100644
index 0000000..f31569a
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/dispatch.clj
@@ -0,0 +1,21 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.dispatch
+ (:require [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.exec.threadpool :as tp]))
+
+(set! *warn-on-reflection* true)
+
+(defonce executor (delay (tp/thread-pool-executor)))
+
+(defn run
+ "Runs Runnable r in a thread pool thread"
+ [^Runnable r]
+ (impl/exec @executor r))
diff --git a/src/main/clojure/clojure/core/async/impl/exec/threadpool.clj b/src/main/clojure/clojure/core/async/impl/exec/threadpool.clj
new file mode 100644
index 0000000..e4fa4f8
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/exec/threadpool.clj
@@ -0,0 +1,31 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns clojure.core.async.impl.exec.threadpool
+ (:require [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.concurrent :as conc])
+ (:import [java.util.concurrent Executors Executor]))
+
+(set! *warn-on-reflection* true)
+
+(def ^:private pool-size
+ "Value is set via clojure.core.async.pool-size system property; defaults to 8; uses a
+ delay so property can be set from code after core.async namespace is loaded but before
+ any use of the async thread pool."
+ (delay (or (when-let [prop (System/getProperty "clojure.core.async.pool-size")]
+ (Long/parseLong prop))
+ 8)))
+
+(defn thread-pool-executor
+ []
+ (let [executor-svc (Executors/newFixedThreadPool
+ @pool-size
+ (conc/counted-thread-factory "async-dispatch-%d" true))]
+ (reify impl/Executor
+ (impl/exec [this r]
+ (.execute executor-svc ^Runnable r)))))
diff --git a/src/main/clojure/clojure/core/async/impl/ioc_alt.clj b/src/main/clojure/clojure/core/async/impl/ioc_alt.clj
new file mode 100644
index 0000000..cfc9dc7
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/ioc_alt.clj
@@ -0,0 +1,7 @@
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.ioc-alt
+ (:require [clojure.core.async.impl.ioc-macros :refer :all :as m]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [clojure.core.async.impl.protocols :as impl]))
+
+
diff --git a/src/main/clojure/clojure/core/async/impl/ioc_macros.clj b/src/main/clojure/clojure/core/async/impl/ioc_macros.clj
new file mode 100644
index 0000000..d4d7e5e
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/ioc_macros.clj
@@ -0,0 +1,1114 @@
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; by Timothy Baldridge
+;; April 13, 2013
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.ioc-macros
+ (:refer-clojure :exclude [all])
+ (:require [clojure.pprint :refer [pprint]]
+ [clojure.tools.analyzer :as an]
+ [clojure.tools.analyzer.ast :as ast]
+ [clojure.tools.analyzer.env :as env]
+ [clojure.tools.analyzer.passes :refer [schedule]]
+ [clojure.tools.analyzer.passes.jvm.annotate-loops :refer [annotate-loops]]
+ [clojure.tools.analyzer.passes.jvm.warn-on-reflection :refer [warn-on-reflection]]
+ [clojure.tools.analyzer.jvm :as an-jvm]
+ [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [clojure.set :refer (intersection union difference)])
+ (:import [java.util.concurrent.locks Lock]
+ [java.util.concurrent.atomic AtomicReferenceArray]))
+
+(defn debug [x]
+ (pprint x)
+ x)
+
+
+(def ^:const FN-IDX 0)
+(def ^:const STATE-IDX 1)
+(def ^:const VALUE-IDX 2)
+(def ^:const BINDINGS-IDX 3)
+(def ^:const EXCEPTION-FRAMES 4)
+(def ^:const CURRENT-EXCEPTION 5)
+(def ^:const USER-START-IDX 6)
+
+(defn aset-object [^AtomicReferenceArray arr idx ^Object o]
+ (.set arr idx o))
+
+(defn aget-object [^AtomicReferenceArray arr idx]
+ (.get arr idx))
+
+(defmacro aset-all!
+ [arr & more]
+ (assert (even? (count more)) "Must give an even number of args to aset-all!")
+ (let [bindings (partition 2 more)
+ arr-sym (gensym "statearr-")]
+ `(let [~arr-sym ~arr]
+ ~@(map
+ (fn [[idx val]]
+ `(aset-object ~arr-sym ~idx ~val))
+ bindings)
+ ~arr-sym)))
+
+;; State monad stuff, used only in SSA construction
+
+(defmacro gen-plan
+ "Allows a user to define a state monad binding plan.
+
+ (gen-plan
+ [_ (assoc-in-plan [:foo :bar] 42)
+ val (get-in-plan [:foo :bar])]
+ val)"
+ [binds id-expr]
+ (let [binds (partition 2 binds)
+ psym (gensym "plan_")
+ forms (reduce
+ (fn [acc [id expr]]
+ (concat acc `[[~id ~psym] (~expr ~psym)]))
+ []
+ binds)]
+ `(fn [~psym]
+ (let [~@forms]
+ [~id-expr ~psym]))))
+
+(defn get-plan
+ "Returns the final [id state] from a plan. "
+ [f]
+ (f {}))
+
+(defn push-binding
+ "Sets the binding 'key' to value. This operation can be undone via pop-bindings.
+ Bindings are stored in the state hashmap."
+ [key value]
+ (fn [plan]
+ [nil (update-in plan [:bindings key] conj value)]))
+
+(defn push-alter-binding
+ "Pushes the result of (apply f old-value args) as current value of binding key"
+ [key f & args]
+ (fn [plan]
+ [nil (update-in plan [:bindings key]
+ #(conj % (apply f (first %) args)))]))
+
+(defn get-binding
+ "Gets the value of the current binding for key"
+ [key]
+ (fn [plan]
+ [(first (get-in plan [:bindings key])) plan]))
+
+(defn pop-binding
+ "Removes the most recent binding for key"
+ [key]
+ (fn [plan]
+ [(first (get-in plan [:bindings key]))
+ (update-in plan [:bindings key] pop)]))
+
+(defn no-op
+ "This function can be used inside a gen-plan when no operation is to be performed"
+ []
+ (fn [plan]
+ [nil plan]))
+
+(defn all
+ "Assumes that itms is a list of state monad function results, threads the state map
+ through all of them. Returns a vector of all the results."
+ [itms]
+ (fn [plan]
+ (reduce
+ (fn [[ids plan] f]
+ (let [[id plan] (f plan)]
+ [(conj ids id) plan]))
+ [[] plan]
+ itms)))
+
+(defn assoc-in-plan
+ "Same as assoc-in, but for state hash map"
+ [path val]
+ (fn [plan]
+ [val (assoc-in plan path val)]))
+
+(defn update-in-plan
+ "Same as update-in, but for a state hash map"
+ [path f & args]
+ (fn [plan]
+ [nil (apply update-in plan path f args)]))
+
+(defn get-in-plan
+ "Same as get-in, but for a state hash map"
+ [path]
+ (fn [plan]
+ [(get-in plan path) plan]))
+
+(defn print-plan []
+ (fn [plan]
+ (pprint plan)
+ [nil plan]))
+
+(defn set-block
+ "Sets the current block being written to by the functions. The next add-instruction call will append to this block"
+ [block-id]
+ (fn [plan]
+ [block-id (assoc plan :current-block block-id)]))
+
+(defn get-block
+ "Gets the current block"
+ []
+ (fn [plan]
+ [(:current-block plan) plan]))
+
+(defn add-block
+ "Adds a new block, returns its id, but does not change the current block (does not call set-block)."
+ []
+ (gen-plan
+ [_ (update-in-plan [:block-id] (fnil inc 0))
+ blk-id (get-in-plan [:block-id])
+ cur-blk (get-block)
+ _ (assoc-in-plan [:blocks blk-id] [])
+ catches (get-binding :catch)
+ _ (assoc-in-plan [:block-catches blk-id] catches)
+ _ (if-not cur-blk
+ (assoc-in-plan [:start-block] blk-id)
+ (no-op))]
+ blk-id))
+
+
+(defn instruction? [x]
+ (::instruction (meta x)))
+
+(defn add-instruction
+ "Appends an instruction to the current block. "
+ [inst]
+ (let [inst-id (with-meta (gensym "inst_")
+ {::instruction true})
+ inst (assoc inst :id inst-id)]
+ (gen-plan
+ [blk-id (get-block)
+ _ (update-in-plan [:blocks blk-id] (fnil conj []) inst)]
+ inst-id)))
+
+;;
+
+;; We're going to reduce Clojure expressions to a ssa format,
+;; and then translate the instructions for this
+;; virtual-virtual-machine back into Clojure data.
+
+;; Here we define the instructions:
+
+(defprotocol IInstruction
+ (reads-from [this] "Returns a list of instructions this instruction reads from")
+ (writes-to [this] "Returns a list of instructions this instruction writes to")
+ (block-references [this] "Returns all the blocks this instruction references"))
+
+(defprotocol IEmittableInstruction
+ (emit-instruction [this state-sym] "Returns the clojure code that this instruction represents"))
+
+(defprotocol ITerminator
+ (terminator-code [this] "Returns a unique symbol for this instruction")
+ (terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block"))
+
+(defrecord Const [value]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if (= value ::value)
+ `[~(:id this) (aget-object ~state-sym ~VALUE-IDX)]
+ `[~(:id this) ~value])))
+
+(defrecord RawCode [ast locals]
+ IInstruction
+ (reads-from [this]
+ (keep (or locals #{})
+ (map :name (-> ast :env :locals vals))))
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if (not-empty (reads-from this))
+ `[~@(->> (-> ast :env :locals vals)
+ (map #(select-keys % [:op :name :form]))
+ (filter (fn [local]
+ (when locals
+ (get locals (:name local)))))
+ set
+ (mapcat
+ (fn [local]
+ `[~(:form local) ~(get locals (:name local))])))
+ ~(:id this) ~(:form ast)]
+ `[~(:id this) ~(:form ast)])))
+
+(defrecord CustomTerminator [f blk values meta]
+ IInstruction
+ (reads-from [this] values)
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ (with-meta `(~f ~state-sym ~blk ~@values)
+ meta)))
+
+(defn- emit-clashing-binds
+ [recur-nodes ids clashes]
+ (let [temp-binds (reduce
+ (fn [acc i]
+ (assoc acc i (gensym "tmp")))
+ {} clashes)]
+ (concat
+ (mapcat (fn [i]
+ `[~(temp-binds i) ~i])
+ clashes)
+ (mapcat (fn [node id]
+ `[~node ~(get temp-binds id id)])
+ recur-nodes
+ ids))))
+
+(defrecord Recur [recur-nodes ids]
+ IInstruction
+ (reads-from [this] ids)
+ (writes-to [this] recur-nodes)
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ (if-let [overlap (seq (intersection (set recur-nodes) (set ids)))]
+ (emit-clashing-binds recur-nodes ids overlap)
+ (mapcat (fn [r i]
+ `[~r ~i]) recur-nodes ids))))
+
+(defrecord Call [refs]
+ IInstruction
+ (reads-from [this] refs)
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this) ~(seq refs)]))
+
+(defrecord StaticCall [class method refs]
+ IInstruction
+ (reads-from [this] refs)
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this) (. ~class ~method ~@(seq refs))]))
+
+(defrecord InstanceInterop [instance-id op refs]
+ IInstruction
+ (reads-from [this] (cons instance-id refs))
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this) (. ~instance-id ~op ~@(seq refs))]))
+
+(defrecord Case [val-id test-vals jmp-blocks default-block]
+ IInstruction
+ (reads-from [this] [val-id])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (case ~val-id
+ ~@(concat (mapcat (fn [test blk]
+ `[~test (aset-all! ~state-sym
+ ~STATE-IDX ~blk)])
+ test-vals jmp-blocks)
+ (when default-block
+ `[(do (aset-all! ~state-sym ~STATE-IDX ~default-block)
+ :recur)])))
+ :recur)))
+
+(defrecord Fn [fn-expr local-names local-refs]
+ IInstruction
+ (reads-from [this] local-refs)
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this)
+ (let [~@(interleave local-names local-refs)]
+ ~@fn-expr)]))
+
+(defrecord Dot [cls-or-instance method args]
+ IInstruction
+ (reads-from [this] `[~cls-or-instance ~method ~@args])
+ (writes-to [this] [(:id this)])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~(:id this) (. ~cls-or-instance ~method ~@args)]))
+
+(defrecord Jmp [value block]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [])
+ (block-references [this] [block])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block)
+ :recur)))
+
+(defrecord Return [value]
+ IInstruction
+ (reads-from [this] [value])
+ (writes-to [this] [])
+ (block-references [this] [])
+ ITerminator
+ (terminator-code [this] :Return)
+ (terminate-block [this state-sym custom-terminators]
+ (if-let [f (get custom-terminators (terminator-code this))]
+ `(~f ~state-sym ~value)
+ `(do (aset-all! ~state-sym
+ ~VALUE-IDX ~value
+ ~STATE-IDX ::finished)
+ nil))))
+
+(defrecord CondBr [test then-block else-block]
+ IInstruction
+ (reads-from [this] [test])
+ (writes-to [this] [])
+ (block-references [this] [then-block else-block])
+ ITerminator
+ (terminate-block [this state-sym _]
+ `(do (if ~test
+ (aset-all! ~state-sym
+ ~STATE-IDX ~then-block)
+ (aset-all! ~state-sym
+ ~STATE-IDX ~else-block))
+ :recur)))
+
+(defrecord PushTry [catch-block]
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] [catch-block])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (cons ~catch-block (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
+
+(defrecord PopTry []
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
+
+(defrecord CatchHandler [catches]
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] (map first catches))
+ ITerminator
+ (terminate-block [this state-sym _]
+ (let [ex (gensym 'ex)]
+ `(let [~ex (aget-object ~state-sym ~VALUE-IDX)]
+ (aset-all! ~state-sym ~CURRENT-EXCEPTION ~ex)
+ (cond
+ ~@(for [[handler-idx type] catches
+ i [`(instance? ~type ~ex) ` (aset-all! ~state-sym
+ ~STATE-IDX ~handler-idx
+ ~CURRENT-EXCEPTION nil)]]
+ i)
+ :else (throw ~ex))
+ :recur))))
+
+(defrecord EndFinally []
+ IInstruction
+ (reads-from [this] [])
+ (writes-to [this] [])
+ (block-references [this] [])
+ IEmittableInstruction
+ (emit-instruction [this state-sym]
+ `[~'_ (when-let [e# (aget-object ~state-sym ~CURRENT-EXCEPTION)]
+ (throw e#))]))
+
+;; Dispatch clojure forms based on :op
+(def -item-to-ssa nil) ;; for help in the repl
+(defmulti -item-to-ssa :op)
+
+(defmethod -item-to-ssa :default
+ [ast]
+ (gen-plan
+ [locals (get-binding :locals)
+ id (add-instruction (->RawCode ast locals))]
+ id))
+
+(defn item-to-ssa [ast]
+ (if (or (::transform? ast)
+ (contains? #{:local :const :quote} (:op ast)))
+ (-item-to-ssa ast)
+ (gen-plan
+ [locals (get-binding :locals)
+ id (add-instruction (->RawCode ast locals))]
+ id)))
+
+(defmethod -item-to-ssa :invoke
+ [{f :fn args :args}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa (cons f args)))
+ inst-id (add-instruction (->Call arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :keyword-invoke
+ [{f :keyword target :target}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa (list f target)))
+ inst-id (add-instruction (->Call arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :protocol-invoke
+ [{f :protocol-fn target :target args :args}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa (list* f target args)))
+ inst-id (add-instruction (->Call arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :instance?
+ [{:keys [class target]}]
+ (gen-plan
+ [arg-id (item-to-ssa target)
+ inst-id (add-instruction (->Call (list `instance? class arg-id)))]
+ inst-id))
+
+(defmethod -item-to-ssa :prim-invoke
+ [{f :fn args :args}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa (cons f args)))
+ inst-id (add-instruction (->Call arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :instance-call
+ [{:keys [instance method args]}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa args))
+ instance-id (item-to-ssa instance)
+ inst-id (add-instruction (->InstanceInterop instance-id method arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :instance-field
+ [{:keys [instance field]}]
+ (gen-plan
+ [instance-id (item-to-ssa instance)
+ inst-id (add-instruction (->InstanceInterop instance-id (symbol (str "-" field)) ()))]
+ inst-id))
+
+(defmethod -item-to-ssa :host-interop
+ [{:keys [target m-or-f]}]
+ (gen-plan
+ [instance-id (item-to-ssa target)
+ inst-id (add-instruction (->InstanceInterop instance-id m-or-f ()))]
+ inst-id))
+
+(defmethod -item-to-ssa :static-call
+ [{:keys [class method args]}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa args))
+ inst-id (add-instruction (->StaticCall class method arg-ids))]
+ inst-id))
+
+(defmethod -item-to-ssa :set!
+ [{:keys [val target]}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa (list target val)))
+ inst-id (add-instruction (->Call (cons 'set! arg-ids)))]
+ inst-id))
+
+(defn var-name [v]
+ (let [nm (:name (meta v))
+ nsp (.getName ^clojure.lang.Namespace (:ns (meta v)))]
+ (symbol (name nsp) (name nm))))
+
+
+(defmethod -item-to-ssa :var
+ [{:keys [var]}]
+ (gen-plan
+ []
+ (var-name var)))
+
+(defmethod -item-to-ssa :const
+ [{:keys [form]}]
+ (gen-plan
+ []
+ form))
+
+(defn let-binding-to-ssa
+ [{:keys [name init form]}]
+ (gen-plan
+ [bind-id (item-to-ssa init)
+ _ (push-alter-binding :locals assoc (vary-meta name merge (meta form)) bind-id)]
+ bind-id))
+
+(defmethod -item-to-ssa :let
+ [{:keys [bindings body]}]
+ (gen-plan
+ [let-ids (all (map let-binding-to-ssa bindings))
+ _ (all (map (fn [_] (pop-binding :locals)) bindings))
+
+ local-ids (all (map (comp add-instruction ->Const) let-ids))
+ _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}]
+ [name (vary-meta id merge (meta form))])
+ local-ids bindings)))
+
+ body-id (item-to-ssa body)
+ _ (pop-binding :locals)]
+ body-id))
+
+(defmethod -item-to-ssa :loop
+ [{:keys [body bindings] :as ast}]
+ (gen-plan
+ [local-val-ids (all (map let-binding-to-ssa bindings))
+ _ (all (for [_ bindings]
+ (pop-binding :locals)))
+ local-ids (all (map (comp add-instruction ->Const) local-val-ids))
+ body-blk (add-block)
+ final-blk (add-block)
+ _ (add-instruction (->Jmp nil body-blk))
+
+ _ (set-block body-blk)
+ _ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}]
+ [name (vary-meta id merge (meta form))])
+ local-ids bindings)))
+ _ (push-binding :recur-point body-blk)
+ _ (push-binding :recur-nodes local-ids)
+
+ ret-id (item-to-ssa body)
+
+ _ (pop-binding :recur-nodes)
+ _ (pop-binding :recur-point)
+ _ (pop-binding :locals)
+ _ (if (not= ret-id ::terminated)
+ (add-instruction (->Jmp ret-id final-blk))
+ (no-op))
+ _ (set-block final-blk)
+ ret-id (add-instruction (->Const ::value))]
+ ret-id))
+
+(defmethod -item-to-ssa :do
+ [{:keys [statements ret] :as ast}]
+ (gen-plan
+ [_ (all (map item-to-ssa statements))
+ ret-id (item-to-ssa ret)]
+ ret-id))
+
+(defmethod -item-to-ssa :case
+ [{:keys [test tests thens default] :as ast}]
+ (gen-plan
+ [end-blk (add-block)
+ start-blk (get-block)
+ clause-blocks (all (map (fn [expr]
+ (assert expr)
+ (gen-plan
+ [blk-id (add-block)
+ _ (set-block blk-id)
+ expr-id (item-to-ssa expr)
+ _ (if (not= expr-id ::terminated)
+ (add-instruction (->Jmp expr-id end-blk))
+ (no-op))]
+ blk-id))
+ (map :then thens)))
+ default-block (if default
+ (gen-plan
+ [blk-id (add-block)
+ _ (set-block blk-id)
+ expr-id (item-to-ssa default)
+ _ (if (not= expr-id ::terminated)
+ (add-instruction (->Jmp expr-id end-blk))
+ (no-op))]
+ blk-id)
+ (no-op))
+ _ (set-block start-blk)
+ val-id (item-to-ssa test)
+ case-id (add-instruction (->Case val-id (map (comp :form :test) tests)
+ clause-blocks
+ default-block))
+ _ (set-block end-blk)
+ ret-id (add-instruction (->Const ::value))]
+ ret-id))
+
+(defmethod -item-to-ssa :quote
+ [{:keys [form]}]
+ (gen-plan
+ [ret-id (add-instruction (->Const form))]
+ ret-id))
+
+(defmethod -item-to-ssa :try
+ [{:keys [catches body finally] :as ast}]
+ (gen-plan
+ [body-block (add-block)
+ exit-block (add-block)
+ ;; Two routes to the finally block, via normal execution and
+ ;; exception execution
+ finally-blk (if finally
+ (gen-plan
+ [cur-blk (get-block)
+ finally-blk (add-block)
+ _ (set-block finally-blk)
+ result-id (add-instruction (->Const ::value))
+ _ (item-to-ssa finally)
+ ;; rethrow exception on exception path
+ _ (add-instruction (->EndFinally))
+ _ (add-instruction (->Jmp result-id exit-block))
+ _ (set-block cur-blk)]
+ finally-blk)
+ (gen-plan [] exit-block))
+ catch-blocks (all
+ (for [{ex-bind :local {ex :val} :class catch-body :body} catches]
+ (gen-plan
+ [cur-blk (get-block)
+ catch-blk (add-block)
+ _ (set-block catch-blk)
+ ex-id (add-instruction (->Const ::value))
+ _ (push-alter-binding :locals assoc (:name ex-bind)
+ (vary-meta ex-id merge (when (:tag ex-bind)
+ {:tag (.getName ^Class (:tag ex-bind))})))
+ result-id (item-to-ssa catch-body)
+ ;; if there is a finally, jump to it after
+ ;; handling the exception, if not jump to exit
+ _ (add-instruction (->Jmp result-id finally-blk))
+ _ (pop-binding :locals)
+ _ (set-block cur-blk)]
+ [catch-blk ex])))
+ ;; catch block handler routes exceptions to the correct handler,
+ ;; rethrows if there is no match
+ catch-handler-block (add-block)
+ cur-blk (get-block)
+ _ (set-block catch-handler-block)
+ _ (add-instruction (->CatchHandler catch-blocks))
+ _ (set-block cur-blk)
+ _ (add-instruction (->Jmp nil body-block))
+ _ (set-block body-block)
+ ;; the finally gets pushed on to the exception handler stack, so
+ ;; it will be executed if there is an exception
+ _ (if finally
+ (add-instruction (->PushTry finally-blk))
+ (no-op))
+ _ (add-instruction (->PushTry catch-handler-block))
+ body (item-to-ssa body)
+ _ (add-instruction (->PopTry))
+ _ (if finally
+ (add-instruction (->PopTry))
+ (no-op))
+ ;; if the body finishes executing normally, jump to the finally
+ ;; block, if it exists
+ _ (add-instruction (->Jmp body finally-blk))
+ _ (set-block exit-block)
+ ret (add-instruction (->Const ::value))]
+ ret))
+
+(defmethod -item-to-ssa :throw
+ [{:keys [exception] :as ast}]
+ (gen-plan
+ [exception-id (item-to-ssa exception)
+ ret-id (add-instruction (->Call ['throw exception-id]))]
+ ret-id))
+
+(defmethod -item-to-ssa :new
+ [{:keys [args class] :as ast}]
+ (gen-plan
+ [arg-ids (all (map item-to-ssa args))
+ ret-id (add-instruction (->Call (list* 'new (:val class) arg-ids)))]
+ ret-id))
+
+(defmethod -item-to-ssa :recur
+ [{:keys [exprs] :as ast}]
+ (gen-plan
+ [val-ids (all (map item-to-ssa exprs))
+ recurs (get-binding :recur-nodes)
+ _ (do (assert (= (count val-ids)
+ (count recurs))
+ "Wrong number of arguments to recur")
+ (no-op))
+ _ (add-instruction (->Recur recurs val-ids))
+
+ recur-point (get-binding :recur-point)
+
+ _ (add-instruction (->Jmp nil recur-point))]
+ ::terminated))
+
+(defmethod -item-to-ssa :if
+ [{:keys [test then else]}]
+ (gen-plan
+ [test-id (item-to-ssa test)
+ then-blk (add-block)
+ else-blk (add-block)
+ final-blk (add-block)
+ _ (add-instruction (->CondBr test-id then-blk else-blk))
+
+ _ (set-block then-blk)
+ then-id (item-to-ssa then)
+ _ (if (not= then-id ::terminated)
+ (gen-plan
+ [_ (add-instruction (->Jmp then-id final-blk))]
+ then-id)
+ (no-op))
+
+ _ (set-block else-blk)
+ else-id (item-to-ssa else)
+ _ (if (not= else-id ::terminated)
+ (gen-plan
+ [_ (add-instruction (->Jmp else-id final-blk))]
+ then-id)
+ (no-op))
+
+ _ (set-block final-blk)
+ val-id (add-instruction (->Const ::value))]
+ val-id))
+
+(defmethod -item-to-ssa :transition
+ [{:keys [name args form]}]
+ (gen-plan
+ [blk (add-block)
+ vals (all (map item-to-ssa args))
+ val (add-instruction (->CustomTerminator name blk vals (meta form)))
+ _ (set-block blk)
+ res (add-instruction (->Const ::value))]
+ res))
+
+(defmethod -item-to-ssa :local
+ [{:keys [name form]}]
+ (gen-plan
+ [locals (get-binding :locals)
+ inst-id (if (contains? locals name)
+ (fn [p]
+ [(locals name) p])
+ (fn [p]
+ [form p]))]
+ inst-id))
+
+(defmethod -item-to-ssa :map
+ [{:keys [keys vals]}]
+ (gen-plan
+ [keys-ids (all (map item-to-ssa keys))
+ vals-ids (all (map item-to-ssa vals))
+ id (add-instruction (->Call (cons 'clojure.core/hash-map
+ (interleave keys-ids vals-ids))))]
+ id))
+
+(defmethod -item-to-ssa :with-meta
+ [{:keys [expr meta]}]
+ (gen-plan
+ [meta-id (item-to-ssa meta)
+ expr-id (item-to-ssa expr)
+ id (add-instruction (->Call (list 'clojure.core/with-meta expr-id meta-id)))]
+ id))
+
+(defmethod -item-to-ssa :record
+ [x]
+ (-item-to-ssa `(~(symbol (.getName (class x)) "create")
+ (hash-map ~@(mapcat identity x)))))
+
+(defmethod -item-to-ssa :vector
+ [{:keys [items]}]
+ (gen-plan
+ [item-ids (all (map item-to-ssa items))
+ id (add-instruction (->Call (cons 'clojure.core/vector
+ item-ids)))]
+ id))
+
+(defmethod -item-to-ssa :set
+ [{:keys [items]}]
+ (gen-plan
+ [item-ids (all (map item-to-ssa items))
+ id (add-instruction (->Call (cons 'clojure.core/hash-set
+ item-ids)))]
+ id))
+
+(defn parse-to-state-machine
+ "Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as
+ a series of SSA style blocks."
+ [body terminators]
+ (-> (gen-plan
+ [_ (push-binding :terminators terminators)
+ blk (add-block)
+ _ (set-block blk)
+ id (item-to-ssa body)
+ term-id (add-instruction (->Return id))
+ _ (pop-binding :terminators)]
+ term-id)
+ get-plan))
+
+
+(defn index-instruction [blk-id idx inst]
+ (let [idx (reduce
+ (fn [acc id]
+ (update-in acc [id :read-in] (fnil conj #{}) blk-id))
+ idx
+ (filter instruction? (reads-from inst)))
+ idx (reduce
+ (fn [acc id]
+ (update-in acc [id :written-in] (fnil conj #{}) blk-id))
+ idx
+ (filter instruction? (writes-to inst)))]
+ idx))
+
+(defn index-block [idx [blk-id blk]]
+ (reduce (partial index-instruction blk-id) idx blk))
+
+(defn index-state-machine [machine]
+ (reduce index-block {} (:blocks machine)))
+
+(defn id-for-inst [m sym] ;; m :: symbols -> integers
+ (if-let [i (get @m sym)]
+ i
+ (let [next-idx (get @m ::next-idx)]
+ (swap! m assoc sym next-idx)
+ (swap! m assoc ::next-idx (inc next-idx))
+ next-idx)))
+
+(defn persistent-value?
+ "Returns true if this value should be saved in the state hash map"
+ [index value]
+ (or (not= (-> index value :read-in)
+ (-> index value :written-in))
+ (-> index value :read-in count (> 1))))
+
+(defn count-persistent-values
+ [index]
+ (->> (keys index)
+ (filter instruction?)
+ (filter (partial persistent-value? index))
+ count))
+
+(defn- build-block-preamble [local-map idx state-sym blk]
+ (let [args (->> (mapcat reads-from blk)
+ (filter instruction?)
+ (filter (partial persistent-value? idx))
+ set
+ vec)]
+ (if (empty? args)
+ []
+ (mapcat (fn [sym]
+ `[~sym (aget-object ~state-sym ~(id-for-inst local-map sym))])
+ args))))
+
+(defn- build-block-body [state-sym blk]
+ (mapcat
+ #(emit-instruction % state-sym)
+ (butlast blk)))
+
+(defn- build-new-state [local-map idx state-sym blk]
+ (let [results (->> blk
+ (mapcat writes-to)
+ (filter instruction?)
+ (filter (partial persistent-value? idx))
+ set
+ vec)
+ results (interleave (map (partial id-for-inst local-map) results) results)]
+ (if-not (empty? results)
+ [state-sym `(aset-all! ~state-sym ~@results)]
+ [])))
+
+(defn- emit-state-machine [machine num-user-params custom-terminators]
+ (let [index (index-state-machine machine)
+ state-sym (with-meta (gensym "state_")
+ {:tag 'objects})
+ local-start-idx (+ num-user-params USER-START-IDX)
+ state-arr-size (+ local-start-idx (count-persistent-values index))
+ local-map (atom {::next-idx local-start-idx})
+ block-catches (:block-catches machine)]
+ `(fn state-machine#
+ ([] (aset-all! (AtomicReferenceArray. ~state-arr-size)
+ ~FN-IDX state-machine#
+ ~STATE-IDX ~(:start-block machine)))
+ ([~state-sym]
+ (let [old-frame# (clojure.lang.Var/getThreadBindingFrame)
+ ret-value# (try
+ (clojure.lang.Var/resetThreadBindingFrame (aget-object ~state-sym ~BINDINGS-IDX))
+ (loop []
+ (let [result# (case (int (aget-object ~state-sym ~STATE-IDX))
+ ~@(mapcat
+ (fn [[id blk]]
+ [id `(let [~@(concat (build-block-preamble local-map index state-sym blk)
+ (build-block-body state-sym blk))
+ ~@(build-new-state local-map index state-sym blk)]
+ ~(terminate-block (last blk) state-sym custom-terminators))])
+ (:blocks machine)))]
+ (if (identical? result# :recur)
+ (recur)
+ result#)))
+ (catch Throwable ex#
+ (aset-all! ~state-sym ~VALUE-IDX ex#)
+ (if (seq (aget-object ~state-sym ~EXCEPTION-FRAMES))
+ (aset-all! ~state-sym ~STATE-IDX (first (aget-object ~state-sym ~EXCEPTION-FRAMES))
+ ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))
+ (throw ex#))
+ :recur)
+ (finally
+ (clojure.lang.Var/resetThreadBindingFrame old-frame#)))]
+ (if (identical? ret-value# :recur)
+ (recur ~state-sym)
+ ret-value#))))))
+
+(defn finished?
+ "Returns true if the machine is in a finished state"
+ [state-array]
+ (identical? (aget-object state-array STATE-IDX) ::finished))
+
+(defn- fn-handler
+ [f]
+ (reify
+ Lock
+ (lock [_])
+ (unlock [_])
+
+ impl/Handler
+ (active? [_] true)
+ (blockable? [_] true)
+ (lock-id [_] 0)
+ (commit [_] f)))
+
+
+(defn run-state-machine [state]
+ ((aget-object state FN-IDX) state))
+
+(defn run-state-machine-wrapped [state]
+ (try
+ (run-state-machine state)
+ (catch Throwable ex
+ (impl/close! (aget-object state USER-START-IDX))
+ (throw ex))))
+
+(defn take! [state blk c]
+ (if-let [cb (impl/take! c (fn-handler
+ (fn [x]
+ (aset-all! state VALUE-IDX x STATE-IDX blk)
+ (run-state-machine-wrapped state))))]
+ (do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
+ :recur)
+ nil))
+
+(defn put! [state blk c val]
+ (if-let [cb (impl/put! c val (fn-handler (fn [ret-val]
+ (aset-all! state VALUE-IDX ret-val STATE-IDX blk)
+ (run-state-machine-wrapped state))))]
+ (do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
+ :recur)
+ nil))
+
+(defn return-chan [state value]
+ (let [c (aget-object state USER-START-IDX)]
+ (when-not (nil? value)
+ (impl/put! c value (fn-handler (fn [] nil))))
+ (impl/close! c)
+ c))
+
+
+(def async-custom-terminators
+ {'clojure.core.async/! `put!
+ 'clojure.core.async/alts! 'clojure.core.async/ioc-alts!
+ :Return `return-chan})
+
+(defn mark-transitions
+ {:pass-info {:walk :post :depends #{} :after an-jvm/default-passes}}
+ [{:keys [op fn] :as ast}]
+ (let [transitions (-> (env/deref-env) :passes-opts :mark-transitions/transitions)]
+ (if (and (= op :invoke)
+ (= (:op fn) :var)
+ (contains? transitions (var-name (:var fn))))
+ (merge ast
+ {:op :transition
+ :name (get transitions (var-name (:var fn)))})
+ ast)))
+
+(defn propagate-transitions
+ {:pass-info {:walk :post :depends #{#'mark-transitions}}}
+ [{:keys [op] :as ast}]
+ (if (or (= op :transition)
+ (some #(or (= (:op %) :transition)
+ (::transform? %))
+ (ast/children ast)))
+ (assoc ast ::transform? true)
+ ast))
+
+(defn propagate-recur
+ {:pass-info {:walk :post :depends #{#'annotate-loops #'propagate-transitions}}}
+ [ast]
+ (if (and (= (:op ast) :loop)
+ (::transform? ast))
+ ;; If we are a loop and we need to transform, and
+ ;; one of our children is a recur, then we must transform everything
+ ;; that has a recur
+ (let [loop-id (:loop-id ast)]
+ (ast/postwalk ast #(if (contains? (:loops %) loop-id)
+ (assoc % ::transform? true)
+ %)))
+ ast))
+
+(defn nested-go? [env]
+ (-> env vals first map?))
+
+(defn make-env [input-env crossing-env]
+ (assoc (an-jvm/empty-env)
+ :locals (into {}
+ (if (nested-go? input-env)
+ (for [[l expr] input-env
+ :let [local (get crossing-env l)]]
+ [local (-> expr
+ (assoc :form local)
+ (assoc :name local))])
+ (for [l (keys input-env)
+ :let [local (get crossing-env l)]]
+ [local {:op :local
+ :form local
+ :name local}])))))
+
+(defn pdebug [x]
+ (clojure.pprint/pprint x)
+ (println "----")
+ x)
+
+(def passes (into (disj an-jvm/default-passes #'warn-on-reflection)
+ #{#'propagate-recur
+ #'propagate-transitions
+ #'mark-transitions}))
+
+(def run-passes
+ (schedule passes))
+
+(defn emit-hinted [local tag env]
+ (let [tag (or tag (-> local meta :tag))
+ init (list (get env local))]
+ (if-let [prim-fn (case (cond-> tag (string? tag) symbol)
+ int `int
+ long `long
+ char `char
+ float `float
+ double `double
+ byte `byte
+ short `short
+ boolean `boolean
+ nil)]
+ [(vary-meta local dissoc :tag) (list prim-fn init)]
+ [(vary-meta local merge (when tag {:tag tag})) init])))
+
+(defn state-machine [body num-user-params [crossing-env env] user-transitions]
+ (binding [an-jvm/run-passes run-passes]
+ (-> (an-jvm/analyze `(let [~@(if (nested-go? env)
+ (mapcat (fn [[l {:keys [tag]}]]
+ (emit-hinted l tag crossing-env))
+ env)
+ (mapcat (fn [[l ^clojure.lang.Compiler$LocalBinding lb]]
+ (emit-hinted l (when (.hasJavaClass lb)
+ (some-> lb .getJavaClass .getName))
+ crossing-env))
+ env))]
+ ~body)
+ (make-env env crossing-env)
+ {:passes-opts (merge an-jvm/default-passes-opts
+ {:uniquify/uniquify-env true
+ :mark-transitions/transitions user-transitions})})
+ (parse-to-state-machine user-transitions)
+ second
+ (emit-state-machine num-user-params user-transitions))))
diff --git a/src/main/clojure/clojure/core/async/impl/mutex.clj b/src/main/clojure/clojure/core/async/impl/mutex.clj
new file mode 100644
index 0000000..524d05e
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/mutex.clj
@@ -0,0 +1,30 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.mutex
+ (:require [clojure.core.async.impl.protocols :as impl])
+ (:import [clojure.core.async Mutex]
+ [java.util.concurrent.locks Lock ReentrantLock]))
+
+(defn mutex []
+ (let [m (ReentrantLock.)]
+ (reify
+ Lock
+ (lock [_] (.lock m))
+ (unlock [_] (.unlock m)))))
+
+#_(defn mutex []
+ (let [cas (java.util.concurrent.atomic.AtomicInteger.)]
+ (reify
+ Lock
+ (lock [_] (loop [got (.compareAndSet cas 0 1)]
+ (if got
+ nil
+ (recur (.compareAndSet cas 0 1)))))
+ (unlock [_] (.set cas 0)))))
diff --git a/src/main/clojure/clojure/core/async/impl/protocols.clj b/src/main/clojure/clojure/core/async/impl/protocols.clj
new file mode 100644
index 0000000..f27cddf
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/protocols.clj
@@ -0,0 +1,47 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.protocols)
+
+
+(def ^:const ^{:tag 'int} MAX-QUEUE-SIZE 1024)
+
+(defprotocol ReadPort
+ (take! [port fn1-handler] "derefable val if taken, nil if take was enqueued"))
+
+(defprotocol WritePort
+ (put! [port val fn1-handler] "derefable boolean (false iff already closed) if handled, nil if put was enqueued. Must throw on nil val."))
+
+(defprotocol Channel
+ (close! [chan])
+ (closed? [chan]))
+
+(defprotocol Handler
+ (active? [h] "returns true if has callback. Must work w/o lock")
+ (blockable? [h] "returns true if this handler may be blocked, otherwise it must not block")
+ (lock-id [h] "a unique id for lock acquisition order, 0 if no lock")
+ (commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock"))
+
+(defprotocol Buffer
+ (full? [b] "returns true if buffer cannot accept put")
+ (remove! [b] "remove and return next item from buffer, called under chan mutex")
+ (add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex")
+ (close-buf! [b] "called on chan closed under chan mutex, return ignored"))
+
+(defn add!
+ ([b] b)
+ ([b itm]
+ (assert (not (nil? itm)))
+ (add!* b itm)))
+
+(defprotocol Executor
+ (exec [e runnable] "execute runnable asynchronously"))
+
+;; Defines a buffer that will never block (return true to full?)
+(defprotocol UnblockingBuffer)
diff --git a/src/main/clojure/clojure/core/async/impl/timers.clj b/src/main/clojure/clojure/core/async/impl/timers.clj
new file mode 100644
index 0000000..eaaf07c
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/impl/timers.clj
@@ -0,0 +1,68 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns ^{:skip-wiki true}
+ clojure.core.async.impl.timers
+ (:require [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.channels :as channels])
+ (:import [java.util.concurrent DelayQueue Delayed TimeUnit ConcurrentSkipListMap]))
+
+(set! *warn-on-reflection* true)
+
+(defonce ^:private ^DelayQueue timeouts-queue
+ (DelayQueue.))
+
+(defonce ^:private ^ConcurrentSkipListMap timeouts-map
+ (ConcurrentSkipListMap.))
+
+(def ^:const TIMEOUT_RESOLUTION_MS 10)
+
+(deftype TimeoutQueueEntry [channel ^long timestamp]
+ Delayed
+ (getDelay [this time-unit]
+ (.convert time-unit
+ (- timestamp (System/currentTimeMillis))
+ TimeUnit/MILLISECONDS))
+ (compareTo
+ [this other]
+ (let [ostamp (.timestamp ^TimeoutQueueEntry other)]
+ (if (< timestamp ostamp)
+ -1
+ (if (= timestamp ostamp)
+ 0
+ 1))))
+ impl/Channel
+ (close! [this]
+ (impl/close! channel)))
+
+(defn timeout
+ "returns a channel that will close after msecs"
+ [^long msecs]
+ (let [timeout (+ (System/currentTimeMillis) msecs)
+ me (.ceilingEntry timeouts-map timeout)]
+ (or (when (and me (< (.getKey me) (+ timeout TIMEOUT_RESOLUTION_MS)))
+ (.channel ^TimeoutQueueEntry (.getValue me)))
+ (let [timeout-channel (channels/chan nil)
+ timeout-entry (TimeoutQueueEntry. timeout-channel timeout)]
+ (.put timeouts-map timeout timeout-entry)
+ (.put timeouts-queue timeout-entry)
+ timeout-channel))))
+
+(defn- timeout-worker
+ []
+ (let [q timeouts-queue]
+ (loop []
+ (let [^TimeoutQueueEntry tqe (.take q)]
+ (.remove timeouts-map (.timestamp tqe) tqe)
+ (impl/close! tqe))
+ (recur))))
+
+(defonce timeout-daemon
+ (doto (Thread. ^Runnable timeout-worker "clojure.core.async.timers/timeout-daemon")
+ (.setDaemon true)
+ (.start)))
diff --git a/src/main/clojure/clojure/core/async/lab.clj b/src/main/clojure/clojure/core/async/lab.clj
new file mode 100644
index 0000000..616f9df
--- /dev/null
+++ b/src/main/clojure/clojure/core/async/lab.clj
@@ -0,0 +1,108 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns clojure.core.async.lab
+ "core.async HIGHLY EXPERIMENTAL feature exploration
+
+ Caveats:
+
+ 1. Everything defined in this namespace is experimental, and subject
+ to change or deletion without warning.
+
+ 2. Many features provided by this namespace are highly coupled to
+ implementation details of core.async. Potential features which
+ operate at higher levels of abstraction are suitable for inclusion
+ in the examples.
+
+ 3. Features provided by this namespace MAY be promoted to
+ clojure.core.async at a later point in time, but there is no
+ guarantee any of them will."
+ (:require [clojure.core.async :as async]
+ [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.mutex :as mutex]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [clojure.core.async.impl.channels :as channels])
+ (:import [java.util HashSet Set Collection]
+ [java.util.concurrent.locks Lock]))
+
+(deftype MultiplexingReadPort
+ [^Lock mutex ^Set read-ports]
+ impl/ReadPort
+ (take! [this handler]
+ (if (empty? read-ports)
+ (channels/box nil)
+ (do
+ (.lock mutex)
+ (let [^Lock handler handler
+ commit-handler (fn []
+ (.lock handler)
+ (let [take-cb (and (impl/active? handler) (impl/commit handler))]
+ (.unlock handler)
+ take-cb))
+ fret (fn [[val alt-port]]
+ (if (nil? val)
+ (do (.lock mutex)
+ (.remove read-ports alt-port)
+ (.unlock mutex)
+ (impl/take! this handler))
+ (when-let [take-cb (commit-handler)]
+ (dispatch/run #(take-cb val)))))
+ current-ports (seq read-ports)]
+ (if-let [alt-res (async/do-alts fret current-ports {})]
+ (let [[val alt-port] @alt-res]
+ (if (nil? val)
+ (do (.remove read-ports alt-port)
+ (.unlock mutex)
+ (recur handler))
+ (do (.unlock mutex)
+ (when-let [take-cb (commit-handler)]
+ (dispatch/run #(take-cb val))))))
+ (do
+ (.unlock mutex)
+ nil)))))))
+
+(defn multiplex
+ "Returns a multiplexing read port which, when read from, produces a
+ value from one of ports.
+
+ If at read time only one port is available to be read from, the
+ multiplexing port will return that value. If multiple ports are
+ available to be read from, the multiplexing port will return one
+ value from a port chosen non-deterministicly. If no port is
+ available to be read from, parks execution until a value is
+ available."
+ [& ports]
+ (->MultiplexingReadPort (mutex/mutex) (HashSet. ^Collection ports)))
+
+(defn- broadcast-write
+ [port-set val handler]
+ (if (= (count port-set) 1)
+ (impl/put! (first port-set) val handler)
+ (let [clauses (map (fn [port] [port val]) port-set)
+ recur-step (fn [[_ port]] (broadcast-write (disj port-set port) val handler))]
+ (when-let [alt-res (async/do-alts recur-step clauses {})]
+ (recur (disj port-set (second @alt-res))
+ val
+ handler)))))
+
+(deftype BroadcastingWritePort
+ [write-ports]
+ impl/WritePort
+ (put! [port val handler]
+ (broadcast-write write-ports val handler)))
+
+(defn broadcast
+ "Returns a broadcasting write port which, when written to, writes
+ the value to each of ports.
+
+ Writes to the broadcasting port will park until the value is written
+ to each of the ports used to create it. For this reason, it is
+ strongly advised that each of the underlying ports support buffered
+ writes."
+ [& ports]
+ (->BroadcastingWritePort (set ports)))
\ No newline at end of file
diff --git a/src/main/clojure/clojure/core/async.clj b/src/main/clojure/clojure/core/async.clj
new file mode 100644
index 0000000..93b79e6
--- /dev/null
+++ b/src/main/clojure/clojure/core/async.clj
@@ -0,0 +1,1187 @@
+;; Copyright (c) Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns clojure.core.async
+ "Facilities for async programming and communication.
+
+go blocks are dispatched over an internal thread pool, which
+defaults to 8 threads. The size of this pool can be modified using
+the Java system property `clojure.core.async.pool-size`."
+ (:refer-clojure :exclude [reduce transduce into merge map take partition
+ partition-by bounded-count])
+ (:require [clojure.core.async.impl.protocols :as impl]
+ [clojure.core.async.impl.channels :as channels]
+ [clojure.core.async.impl.buffers :as buffers]
+ [clojure.core.async.impl.timers :as timers]
+ [clojure.core.async.impl.dispatch :as dispatch]
+ [clojure.core.async.impl.ioc-macros :as ioc]
+ [clojure.core.async.impl.mutex :as mutex]
+ [clojure.core.async.impl.concurrent :as conc]
+ )
+ (:import [clojure.core.async ThreadLocalRandom]
+ [java.util.concurrent.locks Lock]
+ [java.util.concurrent Executors Executor]
+ [java.util ArrayList]))
+
+(alias 'core 'clojure.core)
+
+(set! *warn-on-reflection* false)
+
+(defn fn-handler
+ ([f]
+ (fn-handler f true))
+ ([f blockable]
+ (reify
+ Lock
+ (lock [_])
+ (unlock [_])
+
+ impl/Handler
+ (active? [_] true)
+ (blockable? [_] blockable)
+ (lock-id [_] 0)
+ (commit [_] f))))
+
+(defn buffer
+ "Returns a fixed buffer of size n. When full, puts will block/park."
+ [n]
+ (buffers/fixed-buffer n))
+
+(defn dropping-buffer
+ "Returns a buffer of size n. When full, puts will complete but
+ val will be dropped (no transfer)."
+ [n]
+ (buffers/dropping-buffer n))
+
+(defn sliding-buffer
+ "Returns a buffer of size n. When full, puts will complete, and be
+ buffered, but oldest elements in buffer will be dropped (not
+ transferred)."
+ [n]
+ (buffers/sliding-buffer n))
+
+(defn unblocking-buffer?
+ "Returns true if a channel created with buff will never block. That is to say,
+ puts into this buffer will never cause the buffer to be full. "
+ [buff]
+ (extends? impl/UnblockingBuffer (class buff)))
+
+(defn chan
+ "Creates a channel with an optional buffer, an optional transducer
+ (like (map f), (filter p) etc or a composition thereof), and an
+ optional exception-handler. If buf-or-n is a number, will create
+ and use a fixed buffer of that size. If a transducer is supplied a
+ buffer must be specified. ex-handler must be a fn of one argument -
+ if an exception occurs during transformation it will be called with
+ the Throwable as an argument, and any non-nil return value will be
+ placed in the channel."
+ ([] (chan nil))
+ ([buf-or-n] (chan buf-or-n nil))
+ ([buf-or-n xform] (chan buf-or-n xform nil))
+ ([buf-or-n xform ex-handler]
+ (when (and buf-or-n (number? buf-or-n)) (assert (pos? buf-or-n) "fixed buffers must have size > 0"))
+ (when xform (assert buf-or-n "buffer must be supplied when transducer is"))
+ (channels/chan (if (number? buf-or-n) (buffer buf-or-n) buf-or-n) xform ex-handler)))
+
+(defn promise-chan
+ "Creates a promise channel with an optional transducer, and an optional
+ exception-handler. A promise channel can take exactly one value that consumers
+ will receive. Once full, puts complete but val is dropped (no transfer).
+ Consumers will block until either a value is placed in the channel or the
+ channel is closed. See chan for the semantics of xform and ex-handler."
+ ([] (promise-chan nil))
+ ([xform] (promise-chan xform nil))
+ ([xform ex-handler]
+ (chan (buffers/promise-buffer) xform ex-handler)))
+
+(defn timeout
+ "Returns a channel that will close after msecs"
+ [^long msecs]
+ (timers/timeout msecs))
+
+(defn !!
+ "puts a val into port. nil values are not allowed. Will block if no
+ buffer space is available. Returns true unless port is already closed."
+ [port val]
+ (let [p (promise)
+ ret (impl/put! port val (fn-handler (fn [open?] (deliver p open?))))]
+ (if ret
+ @ret
+ (deref p))))
+
+(defn >!
+ "puts a val into port. nil values are not allowed. Must be called
+ inside a (go ...) block. Will park if no buffer space is available.
+ Returns true unless port is already closed."
+ [port val]
+ (assert nil ">! used not in (go ...) block"))
+
+(defn- nop [_])
+(def ^:private fhnop (fn-handler nop))
+
+(defn put!
+ "Asynchronously puts a val into port, calling fn1 (if supplied) when
+ complete, passing false iff port is already closed. nil values are
+ not allowed. If on-caller? (default true) is true, and the put is
+ immediately accepted, will call fn1 on calling thread. Returns
+ true unless port is already closed."
+ ([port val]
+ (if-let [ret (impl/put! port val fhnop)]
+ @ret
+ true))
+ ([port val fn1] (put! port val fn1 true))
+ ([port val fn1 on-caller?]
+ (if-let [retb (impl/put! port val (fn-handler fn1))]
+ (let [ret @retb]
+ (if on-caller?
+ (fn1 ret)
+ (dispatch/run #(fn1 ret)))
+ ret)
+ true)))
+
+(defn close!
+ "Closes a channel. The channel will no longer accept any puts (they
+ will be ignored). Data in the channel remains available for taking, until
+ exhausted, after which takes will return nil. If there are any
+ pending takes, they will be dispatched with nil. Closing a closed
+ channel is a no-op. Returns nil.
+
+ Logically closing happens after all puts have been delivered. Therefore, any
+ blocked or parked puts will remain blocked/parked until a taker releases them."
+
+ [chan]
+ (impl/close! chan))
+
+(defonce ^:private ^java.util.concurrent.atomic.AtomicLong id-gen (java.util.concurrent.atomic.AtomicLong.))
+
+(defn- random-array
+ [n]
+ (let [rand (ThreadLocalRandom/current)
+ a (int-array n)]
+ (loop [i 1]
+ (if (= i n)
+ a
+ (do
+ (let [j (.nextInt rand (inc i))]
+ (aset a i (aget a j))
+ (aset a j i)
+ (recur (inc i))))))))
+
+(defn- alt-flag []
+ (let [^Lock m (mutex/mutex)
+ flag (atom true)
+ id (.incrementAndGet id-gen)]
+ (reify
+ Lock
+ (lock [_] (.lock m))
+ (unlock [_] (.unlock m))
+
+ impl/Handler
+ (active? [_] @flag)
+ (blockable? [_] true)
+ (lock-id [_] id)
+ (commit [_]
+ (reset! flag nil)
+ true))))
+
+(defn- alt-handler [^Lock flag cb]
+ (reify
+ Lock
+ (lock [_] (.lock flag))
+ (unlock [_] (.unlock flag))
+
+ impl/Handler
+ (active? [_] (impl/active? flag))
+ (blockable? [_] true)
+ (lock-id [_] (impl/lock-id flag))
+ (commit [_]
+ (impl/commit flag)
+ cb)))
+
+(defn do-alts
+ "returns derefable [val port] if immediate, nil if enqueued"
+ [fret ports opts]
+ (let [flag (alt-flag)
+ n (count ports)
+ ^ints idxs (random-array n)
+ priority (:priority opts)
+ ret
+ (loop [i 0]
+ (when (< i n)
+ (let [idx (if priority i (aget idxs i))
+ port (nth ports idx)
+ wport (when (vector? port) (port 0))
+ vbox (if wport
+ (let [val (port 1)]
+ (impl/put! wport val (alt-handler flag #(fret [% wport]))))
+ (impl/take! port (alt-handler flag #(fret [% port]))))]
+ (if vbox
+ (channels/box [@vbox (or wport port)])
+ (recur (inc i))))))]
+ (or
+ ret
+ (when (contains? opts :default)
+ (.lock ^Lock flag)
+ (let [got (and (impl/active? flag) (impl/commit flag))]
+ (.unlock ^Lock flag)
+ (when got
+ (channels/box [(:default opts) :default])))))))
+
+(defn alts!!
+ "Like alts!, except takes will be made as if by !!, will block until completed, and not intended
+ for use in (go ...) blocks."
+ [ports & {:as opts}]
+ (let [p (promise)
+ ret (do-alts (partial deliver p) ports opts)]
+ (if ret
+ @ret
+ (deref p))))
+
+(defn alts!
+ "Completes at most one of several channel operations. Must be called
+ inside a (go ...) block. ports is a vector of channel endpoints,
+ which can be either a channel to take from or a vector of
+ [channel-to-put-to val-to-put], in any combination. Takes will be
+ made as if by !. Unless
+ the :priority option is true, if more than one port operation is
+ ready a non-deterministic choice will be made. If no operation is
+ ready and a :default value is supplied, [default-val :default] will
+ be returned, otherwise alts! will park until the first operation to
+ become ready completes. Returns [val port] of the completed
+ operation, where val is the value taken for takes, and a
+ boolean (true unless already closed, as per put!) for puts.
+
+ opts are passed as :key val ... Supported options:
+
+ :default val - the value to use if none of the operations are immediately ready
+ :priority true - (default nil) when true, the operations will be tried in order.
+
+ Note: there is no guarantee that the port exps or val exprs will be
+ used, nor in what order should they be, so they should not be
+ depended upon for side effects."
+
+ [ports & {:as opts}]
+ (assert nil "alts! used not in (go ...) block"))
+
+(defn do-alt [alts clauses]
+ (assert (even? (count clauses)) "unbalanced clauses")
+ (let [clauses (core/partition 2 clauses)
+ opt? #(keyword? (first %))
+ opts (filter opt? clauses)
+ clauses (remove opt? clauses)
+ [clauses bindings]
+ (core/reduce
+ (fn [[clauses bindings] [ports expr]]
+ (let [ports (if (vector? ports) ports [ports])
+ [ports bindings]
+ (core/reduce
+ (fn [[ports bindings] port]
+ (if (vector? port)
+ (let [[port val] port
+ gp (gensym)
+ gv (gensym)]
+ [(conj ports [gp gv]) (conj bindings [gp port] [gv val])])
+ (let [gp (gensym)]
+ [(conj ports gp) (conj bindings [gp port])])))
+ [[] bindings] ports)]
+ [(conj clauses [ports expr]) bindings]))
+ [[] []] clauses)
+ gch (gensym "ch")
+ gret (gensym "ret")]
+ `(let [~@(mapcat identity bindings)
+ [val# ~gch :as ~gret] (~alts [~@(apply concat (core/map first clauses))] ~@(apply concat opts))]
+ (cond
+ ~@(mapcat (fn [[ports expr]]
+ [`(or ~@(core/map (fn [port]
+ `(= ~gch ~(if (vector? port) (first port) port)))
+ ports))
+ (if (and (seq? expr) (vector? (first expr)))
+ `(let [~(first expr) ~gret] ~@(rest expr))
+ expr)])
+ clauses)
+ (= ~gch :default) val#))))
+
+(defmacro alt!!
+ "Like alt!, except as if by alts!!, will block until completed, and
+ not intended for use in (go ...) blocks."
+
+ [& clauses]
+ (do-alt `alts!! clauses))
+
+(defmacro alt!
+ "Makes a single choice between one of several channel operations,
+ as if by alts!, returning the value of the result expr corresponding
+ to the operation completed. Must be called inside a (go ...) block.
+
+ Each clause takes the form of:
+
+ channel-op[s] result-expr
+
+ where channel-ops is one of:
+
+ take-port - a single port to take
+ [take-port | [put-port put-val] ...] - a vector of ports as per alts!
+ :default | :priority - an option for alts!
+
+ and result-expr is either a list beginning with a vector, whereupon that
+ vector will be treated as a binding for the [val port] return of the
+ operation, else any other expression.
+
+ (alt!
+ [c t] ([val ch] (foo ch val))
+ x ([v] v)
+ [[out val]] :wrote
+ :default 42)
+
+ Each option may appear at most once. The choice and parking
+ characteristics are those of alts!."
+
+ [& clauses]
+ (do-alt `alts! clauses))
+
+(defn ioc-alts! [state cont-block ports & {:as opts}]
+ (ioc/aset-all! state ioc/STATE-IDX cont-block)
+ (when-let [cb (clojure.core.async/do-alts
+ (fn [val]
+ (ioc/aset-all! state ioc/VALUE-IDX val)
+ (ioc/run-state-machine-wrapped state))
+ ports
+ opts)]
+ (ioc/aset-all! state ioc/VALUE-IDX @cb)
+ :recur))
+
+(defn offer!
+ "Puts a val into port if it's possible to do so immediately.
+ nil values are not allowed. Never blocks. Returns true if offer succeeds."
+ [port val]
+ (let [ret (impl/put! port val (fn-handler nop false))]
+ (when ret @ret)))
+
+(defn poll!
+ "Takes a val from port if it's possible to do so immediately.
+ Never blocks. Returns value if successful, nil otherwise."
+ [port]
+ (let [ret (impl/take! port (fn-handler nop false))]
+ (when ret @ret)))
+
+(defmacro go
+ "Asynchronously executes the body, returning immediately to the
+ calling thread. Additionally, any visible calls to ! and alt!/alts!
+ channel operations within the body will block (if necessary) by
+ 'parking' the calling thread rather than tying up an OS thread (or
+ the only JS thread when in ClojureScript). Upon completion of the
+ operation, the body will be resumed.
+
+ Returns a channel which will receive the result of the body when
+ completed"
+ [& body]
+ (let [crossing-env (zipmap (keys &env) (repeatedly gensym))]
+ `(let [c# (chan 1)
+ captured-bindings# (clojure.lang.Var/getThreadBindingFrame)]
+ (dispatch/run
+ (^:once fn* []
+ (let [~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~(vary-meta l dissoc :tag))]) crossing-env)
+ f# ~(ioc/state-machine `(do ~@body) 1 [crossing-env &env] ioc/async-custom-terminators)
+ state# (-> (f#)
+ (ioc/aset-all! ioc/USER-START-IDX c#
+ ioc/BINDINGS-IDX captured-bindings#))]
+ (ioc/run-state-machine-wrapped state#))))
+ c#)))
+
+(defonce ^:private ^Executor thread-macro-executor
+ (Executors/newCachedThreadPool (conc/counted-thread-factory "async-thread-macro-%d" true)))
+
+(defn thread-call
+ "Executes f in another thread, returning immediately to the calling
+ thread. Returns a channel which will receive the result of calling
+ f when completed, then close."
+ [f]
+ (let [c (chan 1)]
+ (let [binds (clojure.lang.Var/getThreadBindingFrame)]
+ (.execute thread-macro-executor
+ (fn []
+ (clojure.lang.Var/resetThreadBindingFrame binds)
+ (try
+ (let [ret (f)]
+ (when-not (nil? ret)
+ (>!! c ret)))
+ (finally
+ (close! c))))))
+ c))
+
+(defmacro thread
+ "Executes the body in another thread, returning immediately to the
+ calling thread. Returns a channel which will receive the result of
+ the body when completed, then close."
+ [& body]
+ `(thread-call (^:once fn* [] ~@body)))
+
+;;;;;;;;;;;;;;;;;;;; ops ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmacro go-loop
+ "Like (go (loop ...))"
+ [bindings & body]
+ `(go (loop ~bindings ~@body)))
+
+(defn pipe
+ "Takes elements from the from channel and supplies them to the to
+ channel. By default, the to channel will be closed when the from
+ channel closes, but can be determined by the close? parameter. Will
+ stop consuming the from channel if the to channel closes"
+ ([from to] (pipe from to true))
+ ([from to close?]
+ (go-loop []
+ (let [v (! to v)
+ (recur)))))
+ to))
+
+(defn- pipeline*
+ ([n to xf from close? ex-handler type]
+ (assert (pos? n))
+ (let [ex-handler (or ex-handler (fn [ex]
+ (-> (Thread/currentThread)
+ .getUncaughtExceptionHandler
+ (.uncaughtException (Thread/currentThread) ex))
+ nil))
+ jobs (chan n)
+ results (chan n)
+ process (fn [[v p :as job]]
+ (if (nil? job)
+ (do (close! results) nil)
+ (let [res (chan 1 xf ex-handler)]
+ (>!! res v)
+ (close! res)
+ (put! p res)
+ true)))
+ async (fn [[v p :as job]]
+ (if (nil? job)
+ (do (close! results) nil)
+ (let [res (chan 1)]
+ (xf v res)
+ (put! p res)
+ true)))]
+ (dotimes [_ n]
+ (case type
+ :blocking (thread
+ (let [job (! jobs [v p])
+ (>! results p)
+ (recur)))))
+ (go-loop []
+ (let [p (! to v))
+ (recur))))
+ (recur))))))))
+
+;;todo - switch pipe arg order to match these (to/from)
+(defn pipeline
+ "Takes elements from the from channel and supplies them to the to
+ channel, subject to the transducer xf, with parallelism n. Because
+ it is parallel, the transducer will be applied independently to each
+ element, not across elements, and may produce zero or more outputs
+ per input. Outputs will be returned in order relative to the
+ inputs. By default, the to channel will be closed when the from
+ channel closes, but can be determined by the close? parameter. Will
+ stop consuming the from channel if the to channel closes. Note this
+ should be used for computational parallelism. If you have multiple
+ blocking operations to put in flight, use pipeline-blocking instead,
+ If you have multiple asynchronous operations to put in flight, use
+ pipeline-async instead."
+ ([n to xf from] (pipeline n to xf from true))
+ ([n to xf from close?] (pipeline n to xf from close? nil))
+ ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute)))
+
+(defn pipeline-blocking
+ "Like pipeline, for blocking operations."
+ ([n to xf from] (pipeline-blocking n to xf from true))
+ ([n to xf from close?] (pipeline-blocking n to xf from close? nil))
+ ([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :blocking)))
+
+(defn pipeline-async
+ "Takes elements from the from channel and supplies them to the to
+ channel, subject to the async function af, with parallelism n. af
+ must be a function of two arguments, the first an input value and
+ the second a channel on which to place the result(s). af must close!
+ the channel before returning. The presumption is that af will
+ return immediately, having launched some asynchronous operation
+ (i.e. in another thread) whose completion/callback will manipulate
+ the result channel. Outputs will be returned in order relative to
+ the inputs. By default, the to channel will be closed when the from
+ channel closes, but can be determined by the close? parameter. Will
+ stop consuming the from channel if the to channel closes. See also
+ pipeline, pipeline-blocking."
+ ([n to af from] (pipeline-async n to af from true))
+ ([n to af from close?] (pipeline* n to af from close? nil :async)))
+
+(defn split
+ "Takes a predicate and a source channel and returns a vector of two
+ channels, the first of which will contain the values for which the
+ predicate returned true, the second those for which it returned
+ false.
+
+ The out channels will be unbuffered by default, or two buf-or-ns can
+ be supplied. The channels will close after the source channel has
+ closed."
+ ([p ch] (split p ch nil nil))
+ ([p ch t-buf-or-n f-buf-or-n]
+ (let [tc (chan t-buf-or-n)
+ fc (chan f-buf-or-n)]
+ (go-loop []
+ (let [v (! (if (p v) tc fc) v)
+ (recur)))))
+ [tc fc])))
+
+(defn reduce
+ "f should be a function of 2 arguments. Returns a channel containing
+ the single result of applying f to init and the first item from the
+ channel, then applying f to that result and the 2nd item, etc. If
+ the channel closes without yielding items, returns init and f is not
+ called. ch must close before reduce produces a result."
+ [f init ch]
+ (go-loop [ret init]
+ (let [v (! ch (first vs)))
+ (recur (next vs))
+ (when close?
+ (close! ch))))))
+
+(defn to-chan
+ "Creates and returns a channel which contains the contents of coll,
+ closing when exhausted."
+ [coll]
+ (let [c (bounded-count 100 coll)]
+ (if (pos? c)
+ (let [ch (chan c)]
+ (onto-chan ch coll)
+ ch)
+ (let [ch (chan)]
+ (close! ch)
+ ch))))
+
+(defprotocol Mux
+ (muxch* [_]))
+
+(defprotocol Mult
+ (tap* [m ch close?])
+ (untap* [m ch])
+ (untap-all* [m]))
+
+(defn mult
+ "Creates and returns a mult(iple) of the supplied channel. Channels
+ containing copies of the channel can be created with 'tap', and
+ detached with 'untap'.
+
+ Each item is distributed to all taps in parallel and synchronously,
+ i.e. each tap must accept before the next item is distributed. Use
+ buffering/windowing to prevent slow taps from holding up the mult.
+
+ Items received when there are no taps get dropped.
+
+ If a tap puts to a closed channel, it will be removed from the mult."
+ [ch]
+ (let [cs (atom {}) ;;ch->close?
+ m (reify
+ Mux
+ (muxch* [_] ch)
+
+ Mult
+ (tap* [_ ch close?] (swap! cs assoc ch close?) nil)
+ (untap* [_ ch] (swap! cs dissoc ch) nil)
+ (untap-all* [_] (reset! cs {}) nil))
+ dchan (chan 1)
+ dctr (atom nil)
+ done (fn [_] (when (zero? (swap! dctr dec))
+ (put! dchan true)))]
+ (go-loop []
+ (let [val (attrs-map
+ solo-modes #{:mute :pause}
+ attrs (conj solo-modes :solo)
+ solo-mode (atom :mute)
+ change (chan)
+ changed #(put! change true)
+ pick (fn [attr chs]
+ (reduce-kv
+ (fn [ret c v]
+ (if (attr v)
+ (conj ret c)
+ ret))
+ #{} chs))
+ calc-state (fn []
+ (let [chs @cs
+ mode @solo-mode
+ solos (pick :solo chs)
+ pauses (pick :pause chs)]
+ {:solos solos
+ :mutes (pick :mute chs)
+ :reads (conj
+ (if (and (= mode :pause) (not (empty? solos)))
+ (vec solos)
+ (vec (remove pauses (keys chs))))
+ change)}))
+ m (reify
+ Mux
+ (muxch* [_] out)
+ Mix
+ (admix* [_ ch] (swap! cs assoc ch {}) (changed))
+ (unmix* [_ ch] (swap! cs dissoc ch) (changed))
+ (unmix-all* [_] (reset! cs {}) (changed))
+ (toggle* [_ state-map] (swap! cs (partial merge-with core/merge) state-map) (changed))
+ (solo-mode* [_ mode]
+ (assert (solo-modes mode) (str "mode must be one of: " solo-modes))
+ (reset! solo-mode mode)
+ (changed)))]
+ (go-loop [{:keys [solos mutes reads] :as state} (calc-state)]
+ (let [[v c] (alts! reads)]
+ (if (or (nil? v) (= c change))
+ (do (when (nil? v)
+ (swap! cs dissoc c))
+ (recur (calc-state)))
+ (if (or (solos c)
+ (and (empty? solos) (not (mutes c))))
+ (when (>! out v)
+ (recur state))
+ (recur state)))))
+ m))
+
+(defn admix
+ "Adds ch as an input to the mix"
+ [mix ch]
+ (admix* mix ch))
+
+(defn unmix
+ "Removes ch as an input to the mix"
+ [mix ch]
+ (unmix* mix ch))
+
+(defn unmix-all
+ "removes all inputs from the mix"
+ [mix]
+ (unmix-all* mix))
+
+(defn toggle
+ "Atomically sets the state(s) of one or more channels in a mix. The
+ state map is a map of channels -> channel-state-map. A
+ channel-state-map is a map of attrs -> boolean, where attr is one or
+ more of :mute, :pause or :solo. Any states supplied are merged with
+ the current state.
+
+ Note that channels can be added to a mix via toggle, which can be
+ used to add channels in a particular (e.g. paused) state."
+ [mix state-map]
+ (toggle* mix state-map))
+
+(defn solo-mode
+ "Sets the solo mode of the mix. mode must be one of :mute or :pause"
+ [mix mode]
+ (solo-mode* mix mode))
+
+(defprotocol Pub
+ (sub* [p v ch close?])
+ (unsub* [p v ch])
+ (unsub-all* [p] [p v]))
+
+(defn pub
+ "Creates and returns a pub(lication) of the supplied channel,
+ partitioned into topics by the topic-fn. topic-fn will be applied to
+ each value on the channel and the result will determine the 'topic'
+ on which that value will be put. Channels can be subscribed to
+ receive copies of topics using 'sub', and unsubscribed using
+ 'unsub'. Each topic will be handled by an internal mult on a
+ dedicated channel. By default these internal channels are
+ unbuffered, but a buf-fn can be supplied which, given a topic,
+ creates a buffer with desired properties.
+
+ Each item is distributed to all subs in parallel and synchronously,
+ i.e. each sub must accept before the next item is distributed. Use
+ buffering/windowing to prevent slow subs from holding up the pub.
+
+ Items received when there are no matching subs get dropped.
+
+ Note that if buf-fns are used then each topic is handled
+ asynchronously, i.e. if a channel is subscribed to more than one
+ topic it should not expect them to be interleaved identically with
+ the source."
+ ([ch topic-fn] (pub ch topic-fn (constantly nil)))
+ ([ch topic-fn buf-fn]
+ (let [mults (atom {}) ;;topic->mult
+ ensure-mult (fn [topic]
+ (or (get @mults topic)
+ (get (swap! mults
+ #(if (% topic) % (assoc % topic (mult (chan (buf-fn topic))))))
+ topic)))
+ p (reify
+ Mux
+ (muxch* [_] ch)
+
+ Pub
+ (sub* [p topic ch close?]
+ (let [m (ensure-mult topic)]
+ (tap m ch close?)))
+ (unsub* [p topic ch]
+ (when-let [m (get @mults topic)]
+ (untap m ch)))
+ (unsub-all* [_] (reset! mults {}))
+ (unsub-all* [_ topic] (swap! mults dissoc topic)))]
+ (go-loop []
+ (let [val (! (muxch* m) val)
+ (swap! mults dissoc topic)))
+ (recur)))))
+ p)))
+
+(defn sub
+ "Subscribes a channel to a topic of a pub.
+
+ By default the channel will be closed when the source closes,
+ but can be determined by the close? parameter."
+ ([p topic ch] (sub p topic ch true))
+ ([p topic ch close?] (sub* p topic ch close?)))
+
+(defn unsub
+ "Unsubscribes a channel from a topic of a pub"
+ [p topic ch]
+ (unsub* p topic ch))
+
+(defn unsub-all
+ "Unsubscribes all channels from a pub, or a topic of a pub"
+ ([p] (unsub-all* p))
+ ([p topic] (unsub-all* p topic)))
+
+;;; these are down here because they alias core fns, don't want accidents above
+
+(defn map
+ "Takes a function and a collection of source channels, and returns a
+ channel which contains the values produced by applying f to the set
+ of first items taken from each source channel, followed by applying
+ f to the set of second items from each channel, until any one of the
+ channels is closed, at which point the output channel will be
+ closed. The returned channel will be unbuffered by default, or a
+ buf-or-n can be supplied"
+ ([f chs] (map f chs nil))
+ ([f chs buf-or-n]
+ (let [chs (vec chs)
+ out (chan buf-or-n)
+ cnt (count chs)
+ rets (object-array cnt)
+ dchan (chan 1)
+ dctr (atom nil)
+ done (mapv (fn [i]
+ (fn [ret]
+ (aset rets i ret)
+ (when (zero? (swap! dctr dec))
+ (put! dchan (java.util.Arrays/copyOf rets cnt)))))
+ (range cnt))]
+ (go-loop []
+ (reset! dctr cnt)
+ (dotimes [i cnt]
+ (try
+ (take! (chs i) (done i))
+ (catch Exception e
+ (swap! dctr dec))))
+ (let [rets (! out (apply f rets))
+ (recur)))))
+ out)))
+
+(defn merge
+ "Takes a collection of source channels and returns a channel which
+ contains all values taken from them. The returned channel will be
+ unbuffered by default, or a buf-or-n can be supplied. The channel
+ will close after all the source channels have closed."
+ ([chs] (merge chs nil))
+ ([chs buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go-loop [cs (vec chs)]
+ (if (pos? (count cs))
+ (let [[v c] (alts! cs)]
+ (if (nil? v)
+ (recur (filterv #(not= c %) cs))
+ (do (>! out v)
+ (recur cs))))
+ (close! out)))
+ out)))
+
+(defn into
+ "Returns a channel containing the single (collection) result of the
+ items taken from the channel conjoined to the supplied
+ collection. ch must close before into produces a result."
+ [coll ch]
+ (reduce conj coll ch))
+
+
+(defn take
+ "Returns a channel that will return, at most, n items from ch. After n items
+ have been returned, or ch has been closed, the return channel will close.
+
+ The output channel is unbuffered by default, unless buf-or-n is given."
+ ([n ch]
+ (take n ch nil))
+ ([n ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [x 0]
+ (when (< x n)
+ (let [v (! out v)
+ (recur (inc x))))))
+ (close! out))
+ out)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;;
+(defn map<
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ [f ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+ (closed? [_] (impl/closed? ch))
+
+ impl/ReadPort
+ (take! [_ fn1]
+ (let [ret
+ (impl/take! ch
+ (reify
+ Lock
+ (lock [_] (.lock ^Lock fn1))
+ (unlock [_] (.unlock ^Lock fn1))
+
+ impl/Handler
+ (active? [_] (impl/active? fn1))
+ (blockable? [_] true)
+ (lock-id [_] (impl/lock-id fn1))
+ (commit [_]
+ (let [f1 (impl/commit fn1)]
+ #(f1 (if (nil? %) nil (f %)))))))]
+ (if (and ret (not (nil? @ret)))
+ (channels/box (f @ret))
+ ret)))
+
+ impl/WritePort
+ (put! [_ val fn1] (impl/put! ch val fn1))))
+
+(defn map>
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ [f ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+ (closed? [_] (impl/closed? ch))
+
+ impl/ReadPort
+ (take! [_ fn1] (impl/take! ch fn1))
+
+ impl/WritePort
+ (put! [_ val fn1]
+ (impl/put! ch (f val) fn1))))
+
+(defn filter>
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ [p ch]
+ (reify
+ impl/Channel
+ (close! [_] (impl/close! ch))
+ (closed? [_] (impl/closed? ch))
+
+ impl/ReadPort
+ (take! [_ fn1] (impl/take! ch fn1))
+
+ impl/WritePort
+ (put! [_ val fn1]
+ (if (p val)
+ (impl/put! ch val fn1)
+ (channels/box (not (impl/closed? ch)))))))
+
+(defn remove>
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ [p ch]
+ (filter> (complement p) ch))
+
+(defn filter<
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([p ch] (filter< p ch nil))
+ ([p ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go-loop []
+ (let [val (! out val))
+ (recur)))))
+ out)))
+
+(defn remove<
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([p ch] (remove< p ch nil))
+ ([p ch buf-or-n] (filter< (complement p) ch buf-or-n)))
+
+(defn- mapcat* [f in out]
+ (go-loop []
+ (let [val (! out v))
+ (when-not (impl/closed? out)
+ (recur)))))))
+
+(defn mapcat<
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([f in] (mapcat< f in nil))
+ ([f in buf-or-n]
+ (let [out (chan buf-or-n)]
+ (mapcat* f in out)
+ out)))
+
+(defn mapcat>
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([f out] (mapcat> f out nil))
+ ([f out buf-or-n]
+ (let [in (chan buf-or-n)]
+ (mapcat* f in out)
+ in)))
+
+(defn unique
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([ch]
+ (unique ch nil))
+ ([ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [last nil]
+ (let [v (! out v)
+ (recur v))))))
+ (close! out))
+ out)))
+
+
+(defn partition
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([n ch]
+ (partition n ch nil))
+ ([n ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [arr (make-array Object n)
+ idx 0]
+ (let [v (! out (vec arr))
+ (recur (make-array Object n) 0)))))
+ (do (when (> idx 0)
+ (let [narray (make-array Object idx)]
+ (System/arraycopy arr 0 narray 0 idx)
+ (>! out (vec narray))))
+ (close! out))))))
+ out)))
+
+
+(defn partition-by
+ "Deprecated - this function will be removed. Use transducer instead"
+ {:deprecated "0.1.319.0-6b1aca-alpha"}
+ ([f ch]
+ (partition-by f ch nil))
+ ([f ch buf-or-n]
+ (let [out (chan buf-or-n)]
+ (go (loop [lst (ArrayList.)
+ last ::nothing]
+ (let [v (! out (vec lst))
+ (let [new-lst (ArrayList.)]
+ (.add ^ArrayList new-lst v)
+ (recur new-lst new-itm)))))
+ (do (when (> (.size ^ArrayList lst) 0)
+ (>! out (vec lst)))
+ (close! out))))))
+ out)))
diff --git a/src/main/java/clojure/core/async/Mutex.java b/src/main/java/clojure/core/async/Mutex.java
new file mode 100644
index 0000000..10d4f8e
--- /dev/null
+++ b/src/main/java/clojure/core/async/Mutex.java
@@ -0,0 +1,41 @@
+/*
+ Copyright (c) Rich Hickey and contributors. All rights reserved.
+ The use and distribution terms for this software are covered by the
+ Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+ which can be found in the file epl-v10.html at the root of this distribution.
+ By using this software in any fashion, you are agreeing to be bound by
+ the terms of this license.
+ You must not remove this notice, or any other, from this software.
+*/
+
+package clojure.core.async;
+
+import java.util.concurrent.locks.AbstractQueuedSynchronizer;
+
+// non-recursive, non-reentrant mutex implementation based on example
+// from Doug Lea's "The java.util.concurrent Synchronizer Framework"
+// http://gee.cs.oswego.edu/dl/papers/aqs.pdf
+public class Mutex {
+ private static class Sync extends AbstractQueuedSynchronizer {
+ public boolean tryAcquire(int ignored) {
+ return compareAndSetState(0, 1);
+ }
+
+ public boolean tryRelease(int ignored) {
+ setState(0);
+ return true;
+ }
+ }
+
+ private final Sync sync = new Sync();
+
+ public Mutex() {}
+
+ public void lock() {
+ sync.acquire(1);
+ }
+
+ public void unlock() {
+ sync.release(1);
+ }
+}
diff --git a/src/main/java/clojure/core/async/ThreadLocalRandom.java b/src/main/java/clojure/core/async/ThreadLocalRandom.java
new file mode 100644
index 0000000..ed772bb
--- /dev/null
+++ b/src/main/java/clojure/core/async/ThreadLocalRandom.java
@@ -0,0 +1,48 @@
+/*
+ Copyright (c) Rich Hickey and contributors. All rights reserved.
+ The use and distribution terms for this software are covered by the
+ Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+ which can be found in the file epl-v10.html at the root of this distribution.
+ By using this software in any fashion, you are agreeing to be bound by
+ the terms of this license.
+ You must not remove this notice, or any other, from this software.
+*/
+
+package clojure.core.async;
+
+import java.util.Random;
+
+public class ThreadLocalRandom extends Random {
+
+ private static final long serialVersionUID = -2599376724352996934L;
+
+ private static ThreadLocal currentThreadLocalRandom = new ThreadLocal() {
+ protected ThreadLocalRandom initialValue() {
+ return new ThreadLocalRandom();
+ }
+ };
+
+
+ /**
+ * Returns the current ThreadLocalRandom for this thread. Clients must call current,
+ * rather than constructing instances themselves. The ThreadLocalRandom instance will
+ * be returned from a ThreadLocal variable.
+ *
+ * @return A ThreadLocalRandom for the current thread
+ *
+ * @see ThreadLocal
+ * @see Random
+ */
+ public static ThreadLocalRandom current() {
+ return currentThreadLocalRandom.get();
+ }
+
+ private ThreadLocalRandom() {
+ super();
+ }
+
+ private ThreadLocalRandom(long seed) {
+ super(seed);
+ }
+
+}
diff --git a/src/test/cljs/cljs/core/async/buffer_tests.cljs b/src/test/cljs/cljs/core/async/buffer_tests.cljs
new file mode 100644
index 0000000..f1dd19c
--- /dev/null
+++ b/src/test/cljs/cljs/core/async/buffer_tests.cljs
@@ -0,0 +1,111 @@
+(ns cljs.core.async.buffer-tests
+ (:require-macros [cljs.core.async.macros :as m :refer [go]])
+ (:require [cljs.core.async
+ :refer [unblocking-buffer? buffer dropping-buffer sliding-buffer
+ put! take! chan close!]]
+ [cljs.core.async.impl.dispatch :as dispatch]
+ [cljs.core.async.impl.buffers :as buff :refer [promise-buffer]]
+ [cljs.core.async.impl.protocols
+ :refer [full? add! remove! close-buf!]]
+ [cljs.core.async.test-helpers :refer-macros [throws?]]
+ [cljs.test :refer-macros [deftest testing is]]))
+
+(deftest unblocking-buffer-tests
+ (testing "buffers"
+ (is (not (unblocking-buffer? (buffer 1))))
+ (is (unblocking-buffer? (dropping-buffer 1)))
+ (is (unblocking-buffer? (sliding-buffer 1)))))
+
+(deftest buffer-tests
+ (testing "fixed-buffer"
+ (let [fb (buffer 2)]
+ (is (= 0 (count fb)))
+
+ (add! fb :1)
+ (is (= 1 (count fb)))
+
+ (add! fb :2)
+ (is (= 2 (count fb)))
+
+ (is (full? fb))
+ #_(assert (throws? (add! fb :3)))
+
+ (is (= :1 (remove! fb)))
+ (is (not (full? fb)))
+
+ (is (= 1 (count fb)))
+ (is (= :2 (remove! fb)))
+
+ (is (= 0 (count fb)))
+ #_(is (helpers/throws? (remove! fb)))))
+
+ (testing "dropping-buffer"
+ (let [fb (dropping-buffer 2)]
+ (is (= 0 (count fb)))
+
+ (add! fb :1)
+ (is (= 1 (count fb)))
+
+ (add! fb :2)
+ (is (= 2 (count fb)))
+
+ (is (not (full? fb)))
+ (add! fb :3)
+
+ (is (= 2 (count fb)))
+
+ (is (= :1 (remove! fb)))
+ (is (not (full? fb)))
+
+ (is (= 1 (count fb)))
+ (is (= :2 (remove! fb)))
+
+ (is (= 0 (count fb)))
+ #_(is (throws? (remove! fb)))))
+
+ (testing "sliding-buffer"
+ (let [fb (sliding-buffer 2)]
+ (is (= 0 (count fb)))
+
+ (add! fb :1)
+ (is (= 1 (count fb)))
+
+ (add! fb :2)
+ (is (= 2 (count fb)))
+
+ (is (not (full? fb)))
+ (add! fb :3)
+
+ (is (= 2 (count fb)))
+
+ (is (= :2 (remove! fb)))
+ (is (not (full? fb)))
+
+ (is (= 1 (count fb)))
+ (is (= :3 (remove! fb)))
+
+ (is (= 0 (count fb)))
+ #_(is (throws? (remove! fb))))))
+
+(deftest promise-buffer-tests
+ (let [pb (promise-buffer)]
+ (is (= 0 (count pb)))
+
+ (add! pb :1)
+ (is (= 1 (count pb)))
+
+ (add! pb :2)
+ (is (= 1 (count pb)))
+
+ (is (not (full? pb)))
+ (is (not (throws? (add! pb :3))))
+ (is (= 1 (count pb)))
+
+ (is (= :1 (remove! pb)))
+ (is (not (full? pb)))
+
+ (is (= 1 (count pb)))
+ (is (= :1 (remove! pb)))
+
+ (is (= nil (close-buf! pb)))
+ (is (= :1 (remove! pb)))))
diff --git a/src/test/cljs/cljs/core/async/pipeline_test.cljs b/src/test/cljs/cljs/core/async/pipeline_test.cljs
new file mode 100644
index 0000000..308ca75
--- /dev/null
+++ b/src/test/cljs/cljs/core/async/pipeline_test.cljs
@@ -0,0 +1,117 @@
+(ns cljs.core.async.pipeline-test
+ (:require-macros [cljs.core.async.macros :as m :refer [go go-loop]])
+ (:require [cljs.core.async.test-helpers :refer [latch inc!]]
+ [cljs.core.async :as a
+ :refer [! chan close! to-chan pipeline-async pipeline put!]]
+ [cljs.test :refer-macros [deftest is testing async]]))
+
+(defn pipeline-tester [pipeline-fn n inputs xf]
+ (let [cin (to-chan inputs)
+ cout (chan 1)]
+ (pipeline-fn n cout xf cin)
+ (go-loop [acc []]
+ (let [val (! ch v) (close! ch)))
+
+(defn test-size-async [n size]
+ (let [r (range size)]
+ (go (is (= r (! cout :more)
+ (is (= :more (! cout :more)
+ (is (= :more (! ch i))
+ (close! ch)))
+
+(deftest async-pipelines-af-multiplier
+ (async done
+ (go
+ (is (= [0 0 1 0 1 2 0 1 2 3]
+ (! ch (inc v))
+ (close! ch)))
+
+(deftest pipelines-async
+ (async done
+ (go
+ (is (= (range 1 101)
+ (! c# ::timeout)
+ (cljs.core.async/close! c#))
+ c#))]
+ (when (satisfies? cljs.core.async.impl.protocols.Channel body-chan#)
+ (cljs.core.async.macros/go
+ (let [[v# _] (cljs.core.async/alts! [body-chan# (timeout#)] :priority true)]
+ (assert (not= ::timeout v#)
+ (str "test timed out: " ~nm ))))
+ true)))
+
+(defmacro deftest
+ [nm & body]
+ `(do (.log js/console (str "Testing: " ~(str nm) "..."))
+ (assert-go-block-completes ~(str nm) ~@body)))
+
+(defmacro throws?
+ [& exprs]
+ `(try ~@exprs false
+ (catch ~'js/Object e# true)))
+
+(defmacro testing
+ [nm & body]
+ `(do (.log js/console (str " " ~nm "..."))
+ (assert-go-block-completes ~(str nm) ~@body)))
+
+(defmacro is=
+ [a b]
+ `(let [a# ~a
+ b# ~b]
+ (assert (= a# b#) (str a# " != " b#))))
+
+(defmacro is
+ [a]
+ `(assert ~a))
+
+(defmacro locals-test []
+ (if (get-in &env [:locals] 'x)
+ :pass
+ :fail))
diff --git a/src/test/cljs/cljs/core/async/test_helpers.cljs b/src/test/cljs/cljs/core/async/test_helpers.cljs
new file mode 100644
index 0000000..37d5ac4
--- /dev/null
+++ b/src/test/cljs/cljs/core/async/test_helpers.cljs
@@ -0,0 +1,11 @@
+(ns cljs.core.async.test-helpers)
+
+(defn latch [m f]
+ (let [r (atom 0)]
+ (add-watch r :latch
+ (fn [_ _ o n]
+ (when (== n m) (f))))
+ r))
+
+(defn inc! [r]
+ (swap! r inc))
diff --git a/src/test/cljs/cljs/core/async/test_runner.cljs b/src/test/cljs/cljs/core/async/test_runner.cljs
new file mode 100644
index 0000000..9b7c308
--- /dev/null
+++ b/src/test/cljs/cljs/core/async/test_runner.cljs
@@ -0,0 +1,10 @@
+(ns cljs.core.async.test-runner
+ (:require [cljs.test :refer-macros [run-tests]]
+ [cljs.core.async.buffer-tests]
+ [cljs.core.async.pipeline-test]
+ [cljs.core.async.tests]))
+
+(run-tests
+ 'cljs.core.async.pipeline-test
+ 'cljs.core.async.buffer-tests
+ 'cljs.core.async.tests)
diff --git a/src/test/cljs/cljs/core/async/tests.cljs b/src/test/cljs/cljs/core/async/tests.cljs
new file mode 100644
index 0000000..ba722ce
--- /dev/null
+++ b/src/test/cljs/cljs/core/async/tests.cljs
@@ -0,0 +1,469 @@
+(ns cljs.core.async.tests
+ (:require-macros
+ [cljs.core.async.macros :as m :refer [go alt!]])
+ (:require
+ [cljs.core.async :refer
+ [buffer dropping-buffer sliding-buffer put! take! chan promise-chan
+ close! take partition-by offer! poll! ! alts!] :as async]
+ [cljs.core.async.impl.dispatch :as dispatch]
+ [cljs.core.async.impl.buffers :as buff]
+ [cljs.core.async.impl.timers :as timers :refer [timeout]]
+ [cljs.core.async.impl.protocols :refer [full? add! remove!]]
+ [cljs.core.async.test-helpers :refer [latch inc!]]
+ [cljs.test :as test :refer-macros [deftest is run-tests async testing]]))
+
+(enable-console-print!)
+
+(deftest test-put-take-chan-1
+ (async done
+ (let [c (chan 1)
+ l (latch 2 done)]
+ (put! c 42 #(do (is true) (inc! l)))
+ (take! c #(do (is (= 42 %))) (inc! l)))))
+
+(deftest test-put-take-chan
+ (async done
+ (let [c (chan)
+ l (latch 2 done)]
+ (put! c 42 #(do (is true) (inc! l)))
+ (take! c #(do (is (= 42 %))) (inc! l)))))
+
+(defn identity-chan
+ [x]
+ (let [c (chan 1)]
+ (go (>! c x)
+ (close! c))
+ c))
+
+(defn debug [x]
+ (.log js/console x)
+ x)
+
+(deftest test-identity-chan
+ (async done
+ (go
+ (is (= (
+ (async done
+ (go
+ (is (= [2 3 4 5]
+ (let [out (chan)
+ in (async/map> inc out)]
+ (async/onto-chan in [1 2 3 4])
+ (
+ (async done
+ (go
+ (is (= [2 4 6]
+ (let [out (chan)
+ in (async/filter> even? out)]
+ (async/onto-chan in [1 2 3 4 5 6])
+ (
+ (async done
+ (go
+ (is (= [1 3 5]
+ (let [out (chan)
+ in (async/remove> even? out)]
+ (async/onto-chan in [1 2 3 4 5 6])
+ (
+ (async done
+ (go
+ (is (= [0 0 1 0 1 2]
+ (let [out (chan)
+ in (async/mapcat> range out)]
+ (async/onto-chan in [1 2 3])
+ (! take-out (! c i)
+ (recur (inc i)))
+ (close! c))))
+ c))
+
+(deftest test-transducers
+ (async done
+ (let [l (latch 6 done)]
+ (testing "base case without transducer"
+ (go (is (= (range 10)
+ (! c :val)
+ (is (= :val (! c :LOST))
+ (is (= :val (! c :val) ;; deliver
+ (is (= :val (!!]]))
+
+(defn with-default-uncaught-exception-handler [handler f]
+ (let [old-handler (Thread/getDefaultUncaughtExceptionHandler)]
+ (Thread/setDefaultUncaughtExceptionHandler
+ (reify Thread$UncaughtExceptionHandler
+ (uncaughtException [_ thread throwable]
+ (handler thread throwable))))
+ (f)
+ (Thread/setDefaultUncaughtExceptionHandler old-handler)))
+
+(deftest exception-in-go
+ (let [log (promise)]
+ (with-default-uncaught-exception-handler
+ (fn [_ throwable] (deliver log throwable))
+ #(let [ex (Exception. "This exception is expected")
+ ret (go (throw ex))]
+ (!! c :foo)
+ (is (identical? ex (root-cause @log)))))))
diff --git a/src/test/clojure/clojure/core/async/ioc_macros_test.clj b/src/test/clojure/clojure/core/async/ioc_macros_test.clj
new file mode 100644
index 0000000..f005b24
--- /dev/null
+++ b/src/test/clojure/clojure/core/async/ioc_macros_test.clj
@@ -0,0 +1,507 @@
+(ns clojure.core.async.ioc-macros-test
+ (:refer-clojure :exclude [map into reduce transduce merge take partition
+ partition-by])
+ (:require [clojure.core.async.impl.ioc-macros :as ioc]
+ [clojure.core.async :refer :all :as async]
+ [clojure.test :refer :all])
+ (:import [java.io FileInputStream ByteArrayOutputStream File]))
+
+(defn pause [x]
+ x)
+
+(defn pause-run [state blk val]
+ (ioc/aset-all! state ioc/STATE-IDX blk ioc/VALUE-IDX val)
+ :recur)
+
+
+(defmacro runner
+ "Creates a runner block. The code inside the body of this macro will be translated
+ into a state machine. At run time the body will be run as normal. This transform is
+ only really useful for testing."
+ [& body]
+ (let [terminators {`pause `pause-run}
+ crossing-env (zipmap (keys &env) (repeatedly gensym))]
+ `(let [captured-bindings# (clojure.lang.Var/getThreadBindingFrame)
+ ~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~l)]) crossing-env)
+ state# (~(ioc/state-machine `(do ~@body) 0 [crossing-env &env] terminators))]
+ (ioc/aset-all! state#
+ ~ioc/BINDINGS-IDX
+ captured-bindings#)
+ (ioc/run-state-machine state#)
+ (ioc/aget-object state# ioc/VALUE-IDX))))
+
+(deftest test-try-catch-finally
+ (testing "Don't endlessly loop when exceptions are thrown"
+ (is (thrown? Exception
+ (runner
+ (loop []
+ (try
+ (pause (throw (Exception. "Ex")))
+ (catch clojure.lang.ExceptionInfo ei
+ :retry))))))
+ (is (thrown? Throwable
+ (runner
+ (loop []
+ (try
+ (pause (throw (Throwable. "Ex")))
+ (catch clojure.lang.ExceptionInfo ei
+ :retry))))))
+ ;; (is (try ((fn [] (println "Hello") (pause 5))) (catch Exception e)))
+ (is (= :Throwable
+ (runner
+ (try
+ (pause 5)
+ (throw (new Throwable))
+ (catch Exception re
+ :Exception)
+ (catch Throwable t
+ :Throwable))))))
+ (testing "finally shouldn't change the return value"
+ (is (= 1 (runner (try 1 (finally (pause 2)))))))
+ (testing "exception handlers stack"
+ (is (= "eee"
+ (runner
+ (try
+ (try
+ (try
+ (throw (pause (Exception. "e")))
+ (catch Exception e
+ (pause (throw (Exception. (str (.getMessage e) "e"))))))
+ (catch Exception e
+ (throw (throw (Exception. (str (.getMessage e) "e"))))))
+ (catch Exception e
+ (.getMessage e)))))))
+ (testing "exception handlers and the class hierarchy"
+ (is
+ (runner
+ (try
+ (pause 10)
+ (throw (RuntimeException.))
+ (catch RuntimeException r
+ (pause true))
+ (catch Exception e
+ (pause false)))))
+ (is
+ (runner
+ (try
+ (pause 10)
+ (throw (RuntimeException.))
+ (catch Exception e
+ (pause true))))))
+ (testing "don't explode trying to compile this"
+ (is
+ (runner
+ (try
+ true
+ (catch Exception e
+ (pause 1)
+ e))))))
+
+
+(defmacro locals-test []
+ (if (if (contains? &env :locals)
+ (get (:locals &env) 'x)
+ (get &env 'x))
+ :pass
+ :fail))
+
+
+(deftest runner-tests
+ (testing "macros add locals to the env"
+ (is (= :pass
+ (runner (let [x 42]
+ (pause (locals-test)))))))
+ (testing "fn as first arg in sexpr"
+ (is (= 42
+ (runner ((fn [] 42))))))
+ (testing "do blocks"
+ (is (= 42
+ (runner (do (pause 42)))))
+ (is (= 42
+ (runner (do (pause 44)
+ (pause 42))))))
+ (testing "if expressions"
+ (is (= true
+ (runner (if (pause true)
+ (pause true)
+ (pause false)))))
+ (is (= false
+ (runner (if (pause false)
+ (pause true)
+ (pause false)))))
+ (is (= true
+ (runner (when (pause true)
+ (pause true)))))
+ (is (= nil
+ (runner (when (pause false)
+ (pause true))))))
+
+ (testing "dot forms"
+ (is (= 42 (runner (. Long (parseLong "42")))))
+ (is (= 42 (runner (. Long parseLong "42")))))
+
+ (testing "quote"
+ (is (= '(1 2 3)
+ (runner (pause '(1 2 3))))))
+
+ (testing "loop expressions"
+ (is (= 100
+ (runner (loop [x 0]
+ (if (< x 100)
+ (recur (inc (pause x)))
+ (pause x))))))
+ (is (= 100
+ (runner (loop [x (pause 0)]
+ (if (< x 100)
+ (recur (inc (pause x)))
+ (pause x))))))
+ (is (= [:b :a]
+ (runner (loop [a :a b :b n 1]
+ (if (pos? n)
+ (recur b a (dec n)) ;; swap bindings
+ [a b])))))
+ (is (= 1
+ (runner (loop [x 0
+ y (inc x)]
+ y)))))
+
+ (testing "let expressions"
+ (is (= 3
+ (runner (let [x 1 y 2]
+ (+ x y))))))
+
+ (testing "vector destructuring"
+ (is (= 3
+ (runner (let [[x y] [1 2]]
+ (+ x y))))))
+
+ (testing "hash-map destructuring"
+ (is (= 3
+ (runner (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}]
+ (assert (and foo (pause x) y x2 y2 foo))
+ (+ x y))))))
+
+ (testing "hash-map literals"
+ (is (= {:1 1 :2 2 :3 3}
+ (runner {:1 (pause 1)
+ :2 (pause 2)
+ :3 (pause 3)}))))
+ (testing "hash-set literals"
+ (is (= #{1 2 3}
+ (runner #{(pause 1)
+ (pause 2)
+ (pause 3)}))))
+ (testing "vector literals"
+ (is (= [1 2 3]
+ (runner [(pause 1)
+ (pause 2)
+ (pause 3)]))))
+
+ (testing "keywords as functions"
+ (is (= :bar
+ (runner (:foo (pause {:foo :bar}))))))
+
+ (testing "vectors as functions"
+ (is (= 2
+ (runner ([1 2] 1)))))
+
+ (testing "dotimes"
+ (is (= 42 (runner
+ (dotimes [x 10]
+ (pause x))
+ 42))))
+
+ (testing "fn closures"
+ (is (= 42
+ (runner
+ (let [x 42
+ _ (pause x)
+ f (fn [] x)]
+ (f))))))
+
+ (testing "lazy-seqs in bodies"
+ (is (= nil
+ (runner
+ (loop []
+ (when-let [x (pause 10)]
+ (pause (vec (for [i (range x)]
+ i)))
+ (if-not x
+ (recur))))))))
+
+ (testing "specials cannot be shadowed"
+ (is (= 3
+ (let [let* :foo] (runner (let* [x 3] x))))))
+
+ (testing "case"
+ (is (= 43
+ (runner
+ (let [value :bar]
+ (case value
+ :foo (pause 42)
+ :bar (pause 43)
+ :baz (pause 44))))))
+ (is (= :default
+ (runner
+ (case :baz
+ :foo 44
+ :default))))
+ (is (= nil
+ (runner
+ (case true
+ false false
+ nil))))
+ (is (= 42
+ (runner
+ (loop [x 0]
+ (case (int x)
+ 0 (recur (inc x))
+ 1 42))))))
+
+ (testing "try"
+ (is (= 42
+ (runner
+ (try 42
+ (catch Throwable ex ex)))))
+ (is (= 42
+ (runner
+ (try
+ (assert false)
+ (catch Throwable ex 42)))))
+
+ (let [a (atom false)
+ v (runner
+ (try
+ true
+ (catch Throwable ex false)
+ (finally (pause (reset! a true)))))]
+ (is (and @a v)))
+
+ (let [a (atom false)
+ v (runner
+ (try
+ (assert false)
+ (catch Throwable ex true)
+ (finally (reset! a true))))]
+ (is (and @a v)))
+
+ (let [a (atom false)
+ v (try (runner
+ (try
+ (assert false)
+ (finally (reset! a true))))
+ (catch Throwable ex ex))]
+ (is (and @a v)))
+
+
+ (let [a (atom 0)
+ v (runner
+ (try
+ (try
+ 42
+ (finally (swap! a inc)))
+ (finally (swap! a inc))))]
+ (is (= @a 2)))
+
+ (let [a (atom 0)
+ v (try (runner
+ (try
+ (try
+ (throw (AssertionError. 42))
+ (finally (swap! a inc)))
+ (finally (swap! a inc))))
+ (catch AssertionError ex ex))]
+ (is (= @a 2)))
+
+ (let [a (atom 0)
+ v (try (runner
+ (try
+ (try
+ (throw (AssertionError. 42))
+ (catch Throwable ex (throw ex))
+ (finally (swap! a inc)))
+ (catch Throwable ex (throw ex))
+ (finally (swap! a inc))))
+ (catch AssertionError ex ex))]
+ (is (= @a 2)))
+
+ (let [a (atom 0)
+ v (try (runner
+ (try
+ (try
+ (throw (AssertionError. (pause 42)))
+ (catch Throwable ex (pause (throw ex)))
+ (finally (pause (swap! a inc))))
+ (catch Throwable ex (pause (throw ex)))
+ (finally (pause (swap! a inc)))))
+ (catch AssertionError ex ex))]
+ (is (= @a 2)))))
+
+
+ (defn identity-chan
+ "Defines a channel that instantly writes the given value"
+ [x]
+ (let [c (chan 1)]
+ (>!! c x)
+ (close! c)
+ c))
+
+ (deftest async-test
+ (testing "values are returned correctly"
+ (is (= 10
+ (! c (! c :foo) 42)]
+ [(!! c :foo)
+ (! c :foo)
+ (>! c :bar)
+ (>! c :baz)
+
+ (>! c :boz)
+ (!! odd-chan odd)))
+ (.start))
+ even-pusher (doto (Thread. #(doseq [even evens]
+ (async/>!! even-chan even)))
+ (.start))
+ expected (set (range 10))
+ observed (set (for [_ (range 10)] (async/!! long-chan i))
+ (async/close! short-chan)))
+ (.start))
+ short-pusher (doto (Thread. #(do (dotimes [i 10]
+ (async/>!! short-chan i))
+ (async/close! short-chan)))
+ (.start))
+ observed (for [_ (range 10010)] (async/!! broadcaster :foo)
+ expected (repeat 5 :foo)
+ observed (doall (map async/!! broadcaster :foo)
+ (async/>!! broadcaster :bar))
+ first-reads (doall (map async/!! broadcaster i)))
+ observed (for [i (range 100)]
+ (async/!! c 42)
+ (is (= @f 42))))
+
+(def DEREF_WAIT 20)
+
+(deftest writes-block-on-full-buffer
+ (let [c (default-chan)
+ _ (>!! c 42)
+ blocking (deref (future (>!! c 43)) DEREF_WAIT :blocked)]
+ (is (= blocking :blocked))))
+
+(deftest unfulfilled-readers-block
+ (let [c (default-chan)
+ r1 (future (!! c 42)
+ r1v (deref r1 DEREF_WAIT :blocked)
+ r2v (deref r2 DEREF_WAIT :blocked)]
+ (is (and (or (= r1v :blocked) (= r2v :blocked))
+ (or (= 42 r1v) (= 42 r2v))))))
+
+(deftest test-!!-and-take!
+ (is (= :test-val (let [read-promise (promise)
+ test-channel (chan nil)]
+ (take! test-channel #(deliver read-promise %))
+ (is (not (realized? read-promise))
+ "The read waits until a writer provides a value.")
+ (>!! test-channel :test-val)
+ (deref read-promise 1000 false)))
+ "The written value is the value provided to the read callback."))
+
+(deftest take!-on-caller?
+ (is (apply not= (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ read-promise (promise)]
+ (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true)
+ (>!! test-channel :foo)
+ [starting-thread @read-promise]))
+ "When on-caller? requested, but no value is immediately
+ available, take!'s callback executes on another thread.")
+ (is (apply = (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ read-promise (promise)]
+ (put! test-channel :foo (constantly nil))
+ (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true)
+ [starting-thread @read-promise]))
+ "When on-caller? requested, and a value is ready to read,
+ take!'s callback executes on the same thread.")
+ (is (apply not= (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ read-promise (promise)]
+ (put! test-channel :foo (constantly nil))
+ (take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) false)
+ [starting-thread @read-promise]))
+ "When on-caller? is false, and a value is ready to read,
+ take!'s callback executes on a different thread."))
+
+(deftest put!-on-caller?
+ (is (apply = (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ write-promise (promise)]
+ (take! test-channel (fn [_] nil))
+ (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true)
+ [starting-thread @write-promise]))
+ "When on-caller? requested, and a reader can consume the value,
+ put!'s callback executes on the same thread.")
+ (is (apply not= (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ write-promise (promise)]
+ (take! test-channel (fn [_] nil))
+ (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) false)
+ [starting-thread @write-promise]))
+ "When on-caller? is false, but a reader can consume the value,
+ put!'s callback executes on a different thread.")
+ (is (apply not= (let [starting-thread (Thread/currentThread)
+ test-channel (chan nil)
+ write-promise (promise)]
+ (put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true)
+ (take! test-channel (fn [_] nil))
+ [starting-thread @write-promise]))
+ "When on-caller? requested, but no reader can consume the value,
+ put!'s callback executes on a different thread."))
+
+
+(deftest limit-async-take!-put!
+ (testing "async put! limit"
+ (let [c (chan)]
+ (dotimes [x 1024]
+ (put! c x))
+ (is (thrown? AssertionError
+ (put! c 42)))
+ (is (= (!! c 42)))))) ;; make sure the channel unlocks
+
+(deftest puts-fulfill-when-buffer-available
+ (is (= :proceeded
+ (let [c (chan 1)
+ p (promise)]
+ (>!! c :full) ;; fill up the channel
+ (put! c :enqueues (fn [_] (deliver p :proceeded))) ;; enqueue a put
+ (!! c :val)
+ (is (= :val (!! c :LOST)
+ (is (= :val (!! c :val) ;; deliver
+ (is (= :val ("
+ (is (= [2 3 4 5]
+ (let [out (chan)
+ in (a/map> inc out)]
+ (a/onto-chan in [1 2 3 4])
+ ("
+ (is (= [2 4 6]
+ (let [out (chan)
+ in (filter> even? out)]
+ (a/onto-chan in [1 2 3 4 5 6])
+ ("
+ (is (= [1 3 5]
+ (let [out (chan)
+ in (remove> even? out)]
+ (a/onto-chan in [1 2 3 4 5 6])
+ ("
+ (is (= [0 0 1 0 1 2]
+ (let [out (chan)
+ in (mapcat> range out)]
+ (a/onto-chan in [1 2 3])
+ ( [1 1 2 2 3 3]
+(defn xerox [n]
+ (fn [f1]
+ (fn
+ ([] (f1))
+ ([result] (f1 result))
+ ([result input]
+ (loop [res result
+ i n]
+ (if (pos? i)
+ (let [a (f1 result input)]
+ (if (reduced? a)
+ a
+ (recur a (dec i))))
+ res))))))
+
+(defn check-expanding-transducer [buffer-size in multiplier takers]
+ (let [input (range in)
+ xf (xerox multiplier)
+ expected (apply interleave (repeat multiplier input))
+ counter (atom 0)
+ res (atom [])
+ c (chan buffer-size xf)]
+ (dotimes [x takers]
+ (take! c #(do
+ (when (some? %) (swap! res conj %))
+ (swap! counter inc))))
+ (onto-chan c input)
+
+ ;; wait for all takers to report
+ (while (< @counter takers)
+ (Thread/sleep 50))
+
+ ;; check expected results
+ (is (= (sort (clojure.core/take takers expected))
+ (sort @res)))))
+
+(deftest expanding-transducer-delivers-to-multiple-pending
+ (doseq [b (range 1 10)
+ t (range 1 10)]
+ (check-expanding-transducer b 3 3 t)))
+
+;; in 1.7+, use (map f)
+(defn mapping [f]
+ (fn [f1]
+ (fn
+ ([] (f1))
+ ([result] (f1 result))
+ ([result input]
+ (f1 result (f input)))
+ ([result input & inputs]
+ (f1 result (apply f input inputs))))))
+
+(deftest test-transduce
+ (is (= [1 2 3 4 5]
+ (! !! go go-loop thread chan close! to-chan
+ pipeline pipeline-blocking pipeline-async]]))
+
+;; in Clojure 1.7, use (map f) instead of this
+(defn mapping [f]
+ (fn [f1]
+ (fn
+ ([] (f1))
+ ([result] (f1 result))
+ ([result input]
+ (f1 result (f input)))
+ ([result input & inputs]
+ (f1 result (apply f input inputs))))))
+
+(defn pipeline-tester [pipeline-fn n inputs xf]
+ (let [cin (to-chan inputs)
+ cout (chan 1)]
+ (pipeline-fn n cout xf cin)
+ (!! ch v) (close! ch)))
+
+(deftest test-sizes
+ (are [n size]
+ (let [r (range size)]
+ (and
+ (= r (pipeline-tester pipeline n r identity-mapping))
+ (= r (pipeline-tester pipeline-blocking n r identity-mapping))
+ (= r (pipeline-tester pipeline-async n r identity-async))))
+ 1 0
+ 1 10
+ 10 10
+ 20 10
+ 5 1000))
+
+(deftest test-close?
+ (doseq [pf [pipeline pipeline-blocking]]
+ (let [cout (chan 1)]
+ (pf 5 cout identity-mapping (to-chan [1]) true)
+ (is (= 1 (!! cout :more)
+ (is (= :more (!! cout :more)
+ (is (= :more (!! chex e) :err))]
+ (pf 5 cout ex-mapping (to-chan [1 2 3 4]) true ex-handler)
+ (is (= 1 (!! ch i))
+ (close! ch)))
+
+(deftest test-af-multiplier
+ (is (= [0 0 1 0 1 2 0 1 2 3]
+ (pipeline-tester pipeline-async 2 (range 1 5) multiplier-async))))
+
+(def sleep-mapping (mapping #(do (Thread/sleep %) %)))
+
+(deftest test-blocking
+ (let [times [2000 50 1000 100]]
+ (is (= times (pipeline-tester pipeline-blocking 2 times sleep-mapping)))))
+
+(defn slow-fib [n]
+ (if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2)))))
+
+(deftest test-compute
+ (let [input (take 50 (cycle (range 15 38)))]
+ (is (= (slow-fib (last input))
+ (last (pipeline-tester pipeline 8 input (mapping slow-fib)))))))
+
+(deftest test-async
+ (is (= (range 1 101)
+ (pipeline-tester pipeline-async 1 (range 100)
+ (fn [v ch] (future (>!! ch (inc v)) (close! ch)))))))