pax_global_header00006660000000000000000000000064131120373450014511gustar00rootroot0000000000000052 comment=33bfa63f037d174d9d5ddd9578b82fa56cab45ee core.async-core.async-0.3.443/000077500000000000000000000000001311203734500157725ustar00rootroot00000000000000core.async-core.async-0.3.443/.gitignore000066400000000000000000000003351311203734500177630ustar00rootroot00000000000000*.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 core.async-core.async-0.3.443/CONTRIBUTING.md000066400000000000000000000001571311203734500202260ustar00rootroot00000000000000If you'd like to submit a patch, please follow the [contributing guidelines](http://clojure.org/contributing). core.async-core.async-0.3.443/README.md000066400000000000000000000143741311203734500172620ustar00rootroot00000000000000# 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 core.async-core.async-0.3.443/VERSION_TEMPLATE000077500000000000000000000000261311203734500203360ustar00rootroot000000000000000.3.GENERATED_VERSION core.async-core.async-0.3.443/doc/000077500000000000000000000000001311203734500165375ustar00rootroot00000000000000core.async-core.async-0.3.443/doc/intro.md000066400000000000000000000000361311203734500202130ustar00rootroot00000000000000# Introduction to core.async core.async-core.async-0.3.443/epl.html000066400000000000000000000305361311203734500174470ustar00rootroot00000000000000 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.

core.async-core.async-0.3.443/examples/000077500000000000000000000000001311203734500176105ustar00rootroot00000000000000core.async-core.async-0.3.443/examples/ex-alts.clj000066400000000000000000000011551311203734500216610ustar00rootroot00000000000000(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 core.async-core.async-0.3.443/project.clj000066400000000000000000000046031311203734500201350ustar00rootroot00000000000000(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"}}]}) core.async-core.async-0.3.443/script/000077500000000000000000000000001311203734500172765ustar00rootroot00000000000000core.async-core.async-0.3.443/script/build/000077500000000000000000000000001311203734500203755ustar00rootroot00000000000000core.async-core.async-0.3.443/script/build/branch_revision000077500000000000000000000005501311203734500234760ustar00rootroot00000000000000#!/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 core.async-core.async-0.3.443/script/build/git_revision000077500000000000000000000004011311203734500230170ustar00rootroot00000000000000#!/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 core.async-core.async-0.3.443/script/build/revision000077500000000000000000000007111311203734500221600ustar00rootroot00000000000000#!/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 core.async-core.async-0.3.443/script/build/trunk_revision000077500000000000000000000006061311203734500234060ustar00rootroot00000000000000#!/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 core.async-core.async-0.3.443/script/build/update_version000077500000000000000000000001341311203734500233500ustar00rootroot00000000000000#!/usr/bin/env bash set -e mvn versions:set -DnewVersion=`script/build/revision`-SNAPSHOT core.async-core.async-0.3.443/script/runtests.html000066400000000000000000000002411311203734500220500ustar00rootroot00000000000000

Open JavaScript Console to see the test results

core.async-core.async-0.3.443/src/000077500000000000000000000000001311203734500165615ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/000077500000000000000000000000001311203734500175055ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/000077500000000000000000000000001311203734500211505ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/cljs/000077500000000000000000000000001311203734500221035ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/cljs/core/000077500000000000000000000000001311203734500230335ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/cljs/core/async.cljs000066400000000000000000000746651311203734500250470ustar00rootroot00000000000000(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))) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/000077500000000000000000000000001311203734500241505ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/000077500000000000000000000000001311203734500251115ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/buffers.cljs000066400000000000000000000077341311203734500274350ustar00rootroot00000000000000;; 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)) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/channels.cljs000066400000000000000000000173071311203734500275710ustar00rootroot00000000000000;; 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))))))))) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/dispatch.cljs000066400000000000000000000014701311203734500275670ustar00rootroot00000000000000(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)) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/ioc_helpers.cljs000066400000000000000000000110511311203734500302600ustar00rootroot00000000000000(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"))))) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/ioc_macros.clj000066400000000000000000000666611311203734500277400ustar00rootroot00000000000000; 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))) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/protocols.cljs000066400000000000000000000033701311203734500300150ustar00rootroot00000000000000;; 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) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/impl/timers.cljs000066400000000000000000000125371311203734500273010ustar00rootroot00000000000000;; 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)))) core.async-core.async-0.3.443/src/main/clojure/cljs/core/async/macros.clj000066400000000000000000000067541311203734500261420ustar00rootroot00000000000000(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))) core.async-core.async-0.3.443/src/main/clojure/clojure/000077500000000000000000000000001311203734500226135ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/clojure/core/000077500000000000000000000000001311203734500235435ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/clojure/core/async.clj000066400000000000000000001203011311203734500253470ustar00rootroot00000000000000;; 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))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/000077500000000000000000000000001311203734500246605ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/000077500000000000000000000000001311203734500256215ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/buffers.clj000066400000000000000000000044201311203734500277470ustar00rootroot00000000000000;; 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))core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/channels.clj000066400000000000000000000263451311203734500301200ustar00rootroot00000000000000;; 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))))))))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/concurrent.clj000066400000000000000000000023131311203734500304740ustar00rootroot00000000000000;; 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))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/dispatch.clj000066400000000000000000000015241311203734500301140ustar00rootroot00000000000000;; 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)) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/exec/000077500000000000000000000000001311203734500265455ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/exec/threadpool.clj000066400000000000000000000026041311203734500314020ustar00rootroot00000000000000;; 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))))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/ioc_alt.clj000066400000000000000000000003671311203734500277330ustar00rootroot00000000000000(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])) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/ioc_macros.clj000066400000000000000000001076351311203734500304450ustar00rootroot00000000000000; 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)))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/mutex.clj000066400000000000000000000021261311203734500274560ustar00rootroot00000000000000;; 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))))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/protocols.clj000066400000000000000000000035161311203734500303440ustar00rootroot00000000000000;; 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) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/impl/timers.clj000066400000000000000000000044501311203734500276210ustar00rootroot00000000000000;; 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))) core.async-core.async-0.3.443/src/main/clojure/clojure/core/async/lab.clj000066400000000000000000000103731311203734500261140ustar00rootroot00000000000000;; 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)))core.async-core.async-0.3.443/src/main/java/000077500000000000000000000000001311203734500204265ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/java/clojure/000077500000000000000000000000001311203734500220715ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/java/clojure/core/000077500000000000000000000000001311203734500230215ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/java/clojure/core/async/000077500000000000000000000000001311203734500241365ustar00rootroot00000000000000core.async-core.async-0.3.443/src/main/java/clojure/core/async/Mutex.java000066400000000000000000000023231311203734500261030ustar00rootroot00000000000000/* 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); } } core.async-core.async-0.3.443/src/main/java/clojure/core/async/ThreadLocalRandom.java000066400000000000000000000025721311203734500303320ustar00rootroot00000000000000/* 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); } } core.async-core.async-0.3.443/src/test/000077500000000000000000000000001311203734500175405ustar00rootroot00000000000000core.async-core.async-0.3.443/src/test/cljs/000077500000000000000000000000001311203734500204735ustar00rootroot00000000000000core.async-core.async-0.3.443/src/test/cljs/cljs/000077500000000000000000000000001311203734500214265ustar00rootroot00000000000000core.async-core.async-0.3.443/src/test/cljs/cljs/core/000077500000000000000000000000001311203734500223565ustar00rootroot00000000000000core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/000077500000000000000000000000001311203734500234735ustar00rootroot00000000000000core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/buffer_tests.cljs000066400000000000000000000050631311203734500270470ustar00rootroot00000000000000(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))))) core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/pipeline_test.cljs000066400000000000000000000066571311203734500272320ustar00rootroot00000000000000(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)) core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/test_helpers.cljs000066400000000000000000000002741311203734500270540ustar00rootroot00000000000000(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)) core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/test_runner.cljs000066400000000000000000000004661311203734500267260ustar00rootroot00000000000000(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) core.async-core.async-0.3.443/src/test/cljs/cljs/core/async/tests.cljs000066400000000000000000000332601311203734500255160ustar00rootroot00000000000000(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))))))) core.async-core.async-0.3.443/src/test/clojure/clojure/core/async/ioc_macros_test.clj000066400000000000000000000356251311203734500305750ustar00rootroot00000000000000(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)))))))