Commit 7fdd091b7ab2aaba7e687116b181996cfe21afb7 - core-async-clojure

New upstream version 0.3.443 Apollon Oikonomopoulos 6 years ago

58 changed file(s) with 8954 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+20

-0

.gitignore less more

	0	*.iml
	1	*init.clj
	2	.idea
	3	out-simp
	4	out-simp-node
	5	out-adv
	6	out-adv-node
	7	/target
	8	/lib
	9	/classes
	10	/checkouts
	11	*.jar
	12	*.class
	13	.lein-deps-sum
	14	.lein-failures
	15	.lein-plugins
	16	.lein-repl-history
	17	tests.js
	18	tests.js.map
	19	pom.xml.versionsBackup

-0

CONTRIBUTING.md less more

If you'd like to submit a patch, please follow the [contributing guidelines](http://clojure.org/contributing).

+119

-0

README.md less more

	0	# core.async
	1
	2	A Clojure library providing facilities for async programming and communication.
	3
	4
	5	## Releases and Dependency Information
	6
	7	Latest release: 0.3.442
	8
	9	* [All Released Versions](http://search.maven.org/#search%7Cgav%7C1%7Cg%3A%22org.clojure%22%20AND%20a%3A%22core.async%22)
	10
	11	[Leiningen](https://github.com/technomancy/leiningen) dependency information:
	12
	13	```clj
	14	[org.clojure/clojure "1.6.0"]
	15	[org.clojure/core.async "0.3.442"]
	16	```
	17
	18	[Maven](http://maven.apache.org/) dependency information:
	19
	20	```xml
	21	<dependency>
	22	<groupId>org.clojure</groupId>
	23	<artifactId>core.async</artifactId>
	24	<version>0.3.442</version>
	25	</dependency>
	26	```
	27
	28	## Documentation
	29
	30	* [Rationale](http://clojure.com/blog/2013/06/28/clojure-core-async-channels.html)
	31	* [API docs](http://clojure.github.io/core.async/)
	32	* [Code walkthrough](https://github.com/clojure/core.async/blob/master/examples/walkthrough.clj)
	33
	34	## Presentations
	35
	36	* [Rich Hickey on core.async](http://www.infoq.com/presentations/clojure-core-async)
	37	* [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)).
	38	* 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)
	39	* David Nolen [core.async webinar](http://go.cognitect.com/core_async_webinar_recording)
	40
	41	## Contributing
	42
	43	[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.
	44
	45	To run the ClojureScript tests:
	46
	47	* lein cljsbuild once
	48	* open script/runtests.html
	49	* View JavaScript console for test results
	50
	51	## License
	52
	53	Copyright © 2017 Rich Hickey and contributors
	54
	55	Distributed under the Eclipse Public License, the same as Clojure.
	56
	57	## Changelog
	58
	59	* Release 0.3.xxx on 2017.05.26
	60	*
	61	* Release 0.3.442 on 2017.03.14
	62	* Fix bad `:refer-clojure` clause that violates new spec in Clojure 1.9.0-alpha15
	63	* Release 0.3.441 on 2017.02.23
	64	* [ASYNC-187](http://dev.clojure.org/jira/browse/ASYNC-187) - Tag metadata is lost in local closed over by a loop
	65	* Related: [ASYNC-188](http://dev.clojure.org/jira/browse/ASYNC-188)
	66	* [ASYNC-185](http://dev.clojure.org/jira/browse/ASYNC-185) - `thread` prevents clearing of body locals
	67	* [ASYNC-186](http://dev.clojure.org/jira/browse/ASYNC-186) - NPE when `go` closes over a local variable bound to nil
	68	* Release 0.3.426 on 2017.02.22
	69	* [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)
	70	* [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)
	71	* [ASYNC-155](http://dev.clojure.org/jira/browse/ASYNC-155) - preserve loop binding metadata when inside a go block
	72	* [ASYNC-54](http://dev.clojure.org/jira/browse/ASYNC-54) - fix bad type hint on MAX-QUEUE-SIZE
	73	* [ASYNC-177](http://dev.clojure.org/jira/browse/ASYNC-177) - fix typo in Buffer protocol full? method
	74	* [ASYNC-70](http://dev.clojure.org/jira/browse/ASYNC-70) - docstring change in thread, thread-call
	75	* [ASYNC-143](http://dev.clojure.org/jira/browse/ASYNC-143) - assert that fixed buffers must have size > 0
	76	* Update tools.analyzer.jvm dependency
	77	* Release 0.2.395 on 2016.10.12
	78	* Add async version of transduce
	79	* Release 0.2.391 on 2016.09.09
	80	* Fix redefinition warning for bounded-count (added in Clojure 1.9)
	81	* Add :deprecated meta to the deprecated functions
	82	* Release 0.2.385 on 2016.06.17
	83	* Updated tools.analyzer.jvm version
	84	* Release 0.2.382 on 2016.06.13
	85	* Important: Change default dispatch thread pool size to 8.
	86	* Add Java system property `clojure.core.async.pool-size` to set the dispatch thread pool size
	87	* [ASYNC-152](http://dev.clojure.org/jira/browse/ASYNC-152) - disable t.a.jvm's warn-on-reflection pass
	88	* Release 0.2.374 on 2015.11.11
	89	* [ASYNC-149](http://dev.clojure.org/jira/browse/ASYNC-149) - fix error compiling recur inside case in a go block
	90	* Updated tools.analyzer.jvm version (and other upstream deps)
	91	* Updated to latest clojurescript and cljsbuild versions
	92	* Release 0.2.371 on 2015.10.28
	93	* [ASYNC-124](http://dev.clojure.org/jira/browse/ASYNC-124) - dispatch multiple pending takers from expanding transducer
	94	* [ASYNC-103](http://dev.clojure.org/jira/browse/ASYNC-103) - NEW promise-chan
	95	* [ASYNC-104](http://dev.clojure.org/jira/browse/ASYNC-104) - NEW non-blocking offer!, poll!
	96	* [ASYNC-101](http://dev.clojure.org/jira/browse/ASYNC-101) - async/reduce now respects reduced
	97	* [ASYNC-112](http://dev.clojure.org/jira/browse/ASYNC-112) - replace "transformer" with "transducer" in deprecation messages
	98	* [ASYNC-6](http://dev.clojure.org/jira/browse/ASYNC-6) - alts! docs updated to explicitly state ports is a vector
	99	* Support (try (catch :default)) in CLJS exception handling
	100	* Use cljs.test
	101	* Updated tools.analyzer.jvm version (and other upstream deps)
	102	* Release 0.1.346.0-17112a-alpha on 2014.09.22
	103	* cljs nextTick relies on goog.async.nextTick
	104	* Updated docstring for put! re result on closed channel
	105	* Release 0.1.338.0-5c5012-alpha on 2014.08.19
	106	* Add cljs transducers support
	107	* Release 0.1.319.0-6b1aca-alpha on 2014.08.06
	108	* Add transducers support
	109	* NEW pipeline
	110	* Release 0.1.303.0-886421-alpha on 2014.05.08
	111	* Release 0.1.301.0-deb34a-alpha on 2014.04.29
	112	* Release 0.1.298.0-2a82a1-alpha on 2014.04.25
	113	* Release 0.1.278.0-76b25b-alpha on 2014.02.07
	114	* Release 0.1.267.0-0d7780-alpha on 2013.12.11
	115	* Release 0.1.262.0-151b23-alpha on 2013.12.10
	116	* Release 0.1.256.0-1bf8cf-alpha on 2013.11.07
	117	* Release 0.1.242.0-44b1e3-alpha on 2013.09.27
	118	* Release 0.1.222.0-83d0c2-alpha on 2013.09.12

-0

VERSION_TEMPLATE less more

0.3.GENERATED_VERSION

-0

doc/intro.md less more

	0	# Introduction to core.async
	1

+261

-0

epl.html less more

	0	<?xml version="1.0" encoding="ISO-8859-1" ?>
	1	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	2	<html xmlns="http://www.w3.org/1999/xhtml">
	3
	4	<head>
	5	<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
	6	<title>Eclipse Public License - Version 1.0</title>
	7	<style type="text/css">
	8	body {
	9	size: 8.5in 11.0in;
	10	margin: 0.25in 0.5in 0.25in 0.5in;
	11	tab-interval: 0.5in;
	12	}
	13	p {
	14	margin-left: auto;
	15	margin-top: 0.5em;
	16	margin-bottom: 0.5em;
	17	}
	18	p.list {
	19	margin-left: 0.5in;
	20	margin-top: 0.05em;
	21	margin-bottom: 0.05em;
	22	}
	23	</style>
	24
	25	</head>
	26
	27	<body lang="EN-US">
	28
	29	<h2>Eclipse Public License - v 1.0</h2>
	30
	31	<p>THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
	32	PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR
	33	DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS
	34	AGREEMENT.</p>
	35
	36	<p><b>1. DEFINITIONS</b></p>
	37
	38	<p>"Contribution" means:</p>
	39
	40	<p class="list">a) in the case of the initial Contributor, the initial
	41	code and documentation distributed under this Agreement, and</p>
	42	<p class="list">b) in the case of each subsequent Contributor:</p>
	43	<p class="list">i) changes to the Program, and</p>
	44	<p class="list">ii) additions to the Program;</p>
	45	<p class="list">where such changes and/or additions to the Program
	46	originate from and are distributed by that particular Contributor. A
	47	Contribution 'originates' from a Contributor if it was added to the
	48	Program by such Contributor itself or anyone acting on such
	49	Contributor's behalf. Contributions do not include additions to the
	50	Program which: (i) are separate modules of software distributed in
	51	conjunction with the Program under their own license agreement, and (ii)
	52	are not derivative works of the Program.</p>
	53
	54	<p>"Contributor" means any person or entity that distributes
	55	the Program.</p>
	56
	57	<p>"Licensed Patents" mean patent claims licensable by a
	58	Contributor which are necessarily infringed by the use or sale of its
	59	Contribution alone or when combined with the Program.</p>
	60
	61	<p>"Program" means the Contributions distributed in accordance
	62	with this Agreement.</p>
	63
	64	<p>"Recipient" means anyone who receives the Program under
	65	this Agreement, including all Contributors.</p>
	66
	67	<p><b>2. GRANT OF RIGHTS</b></p>
	68
	69	<p class="list">a) Subject to the terms of this Agreement, each
	70	Contributor hereby grants Recipient a non-exclusive, worldwide,
	71	royalty-free copyright license to reproduce, prepare derivative works
	72	of, publicly display, publicly perform, distribute and sublicense the
	73	Contribution of such Contributor, if any, and such derivative works, in
	74	source code and object code form.</p>
	75
	76	<p class="list">b) Subject to the terms of this Agreement, each
	77	Contributor hereby grants Recipient a non-exclusive, worldwide,
	78	royalty-free patent license under Licensed Patents to make, use, sell,
	79	offer to sell, import and otherwise transfer the Contribution of such
	80	Contributor, if any, in source code and object code form. This patent
	81	license shall apply to the combination of the Contribution and the
	82	Program if, at the time the Contribution is added by the Contributor,
	83	such addition of the Contribution causes such combination to be covered
	84	by the Licensed Patents. The patent license shall not apply to any other
	85	combinations which include the Contribution. No hardware per se is
	86	licensed hereunder.</p>
	87
	88	<p class="list">c) Recipient understands that although each Contributor
	89	grants the licenses to its Contributions set forth herein, no assurances
	90	are provided by any Contributor that the Program does not infringe the
	91	patent or other intellectual property rights of any other entity. Each
	92	Contributor disclaims any liability to Recipient for claims brought by
	93	any other entity based on infringement of intellectual property rights
	94	or otherwise. As a condition to exercising the rights and licenses
	95	granted hereunder, each Recipient hereby assumes sole responsibility to
	96	secure any other intellectual property rights needed, if any. For
	97	example, if a third party patent license is required to allow Recipient
	98	to distribute the Program, it is Recipient's responsibility to acquire
	99	that license before distributing the Program.</p>
	100
	101	<p class="list">d) Each Contributor represents that to its knowledge it
	102	has sufficient copyright rights in its Contribution, if any, to grant
	103	the copyright license set forth in this Agreement.</p>
	104
	105	<p><b>3. REQUIREMENTS</b></p>
	106
	107	<p>A Contributor may choose to distribute the Program in object code
	108	form under its own license agreement, provided that:</p>
	109
	110	<p class="list">a) it complies with the terms and conditions of this
	111	Agreement; and</p>
	112
	113	<p class="list">b) its license agreement:</p>
	114
	115	<p class="list">i) effectively disclaims on behalf of all Contributors
	116	all warranties and conditions, express and implied, including warranties
	117	or conditions of title and non-infringement, and implied warranties or
	118	conditions of merchantability and fitness for a particular purpose;</p>
	119
	120	<p class="list">ii) effectively excludes on behalf of all Contributors
	121	all liability for damages, including direct, indirect, special,
	122	incidental and consequential damages, such as lost profits;</p>
	123
	124	<p class="list">iii) states that any provisions which differ from this
	125	Agreement are offered by that Contributor alone and not by any other
	126	party; and</p>
	127
	128	<p class="list">iv) states that source code for the Program is available
	129	from such Contributor, and informs licensees how to obtain it in a
	130	reasonable manner on or through a medium customarily used for software
	131	exchange.</p>
	132
	133	<p>When the Program is made available in source code form:</p>
	134
	135	<p class="list">a) it must be made available under this Agreement; and</p>
	136
	137	<p class="list">b) a copy of this Agreement must be included with each
	138	copy of the Program.</p>
	139
	140	<p>Contributors may not remove or alter any copyright notices contained
	141	within the Program.</p>
	142
	143	<p>Each Contributor must identify itself as the originator of its
	144	Contribution, if any, in a manner that reasonably allows subsequent
	145	Recipients to identify the originator of the Contribution.</p>
	146
	147	<p><b>4. COMMERCIAL DISTRIBUTION</b></p>
	148
	149	<p>Commercial distributors of software may accept certain
	150	responsibilities with respect to end users, business partners and the
	151	like. While this license is intended to facilitate the commercial use of
	152	the Program, the Contributor who includes the Program in a commercial
	153	product offering should do so in a manner which does not create
	154	potential liability for other Contributors. Therefore, if a Contributor
	155	includes the Program in a commercial product offering, such Contributor
	156	("Commercial Contributor") hereby agrees to defend and
	157	indemnify every other Contributor ("Indemnified Contributor")
	158	against any losses, damages and costs (collectively "Losses")
	159	arising from claims, lawsuits and other legal actions brought by a third
	160	party against the Indemnified Contributor to the extent caused by the
	161	acts or omissions of such Commercial Contributor in connection with its
	162	distribution of the Program in a commercial product offering. The
	163	obligations in this section do not apply to any claims or Losses
	164	relating to any actual or alleged intellectual property infringement. In
	165	order to qualify, an Indemnified Contributor must: a) promptly notify
	166	the Commercial Contributor in writing of such claim, and b) allow the
	167	Commercial Contributor to control, and cooperate with the Commercial
	168	Contributor in, the defense and any related settlement negotiations. The
	169	Indemnified Contributor may participate in any such claim at its own
	170	expense.</p>
	171
	172	<p>For example, a Contributor might include the Program in a commercial
	173	product offering, Product X. That Contributor is then a Commercial
	174	Contributor. If that Commercial Contributor then makes performance
	175	claims, or offers warranties related to Product X, those performance
	176	claims and warranties are such Commercial Contributor's responsibility
	177	alone. Under this section, the Commercial Contributor would have to
	178	defend claims against the other Contributors related to those
	179	performance claims and warranties, and if a court requires any other
	180	Contributor to pay any damages as a result, the Commercial Contributor
	181	must pay those damages.</p>
	182
	183	<p><b>5. NO WARRANTY</b></p>
	184
	185	<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
	186	PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS
	187	OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION,
	188	ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY
	189	OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely
	190	responsible for determining the appropriateness of using and
	191	distributing the Program and assumes all risks associated with its
	192	exercise of rights under this Agreement , including but not limited to
	193	the risks and costs of program errors, compliance with applicable laws,
	194	damage to or loss of data, programs or equipment, and unavailability or
	195	interruption of operations.</p>
	196
	197	<p><b>6. DISCLAIMER OF LIABILITY</b></p>
	198
	199	<p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT
	200	NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT,
	201	INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING
	202	WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF
	203	LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
	204	NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR
	205	DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED
	206	HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.</p>
	207
	208	<p><b>7. GENERAL</b></p>
	209
	210	<p>If any provision of this Agreement is invalid or unenforceable under
	211	applicable law, it shall not affect the validity or enforceability of
	212	the remainder of the terms of this Agreement, and without further action
	213	by the parties hereto, such provision shall be reformed to the minimum
	214	extent necessary to make such provision valid and enforceable.</p>
	215
	216	<p>If Recipient institutes patent litigation against any entity
	217	(including a cross-claim or counterclaim in a lawsuit) alleging that the
	218	Program itself (excluding combinations of the Program with other
	219	software or hardware) infringes such Recipient's patent(s), then such
	220	Recipient's rights granted under Section 2(b) shall terminate as of the
	221	date such litigation is filed.</p>
	222
	223	<p>All Recipient's rights under this Agreement shall terminate if it
	224	fails to comply with any of the material terms or conditions of this
	225	Agreement and does not cure such failure in a reasonable period of time
	226	after becoming aware of such noncompliance. If all Recipient's rights
	227	under this Agreement terminate, Recipient agrees to cease use and
	228	distribution of the Program as soon as reasonably practicable. However,
	229	Recipient's obligations under this Agreement and any licenses granted by
	230	Recipient relating to the Program shall continue and survive.</p>
	231
	232	<p>Everyone is permitted to copy and distribute copies of this
	233	Agreement, but in order to avoid inconsistency the Agreement is
	234	copyrighted and may only be modified in the following manner. The
	235	Agreement Steward reserves the right to publish new versions (including
	236	revisions) of this Agreement from time to time. No one other than the
	237	Agreement Steward has the right to modify this Agreement. The Eclipse
	238	Foundation is the initial Agreement Steward. The Eclipse Foundation may
	239	assign the responsibility to serve as the Agreement Steward to a
	240	suitable separate entity. Each new version of the Agreement will be
	241	given a distinguishing version number. The Program (including
	242	Contributions) may always be distributed subject to the version of the
	243	Agreement under which it was received. In addition, after a new version
	244	of the Agreement is published, Contributor may elect to distribute the
	245	Program (including its Contributions) under the new version. Except as
	246	expressly stated in Sections 2(a) and 2(b) above, Recipient receives no
	247	rights or licenses to the intellectual property of any Contributor under
	248	this Agreement, whether expressly, by implication, estoppel or
	249	otherwise. All rights in the Program not expressly granted under this
	250	Agreement are reserved.</p>
	251
	252	<p>This Agreement is governed by the laws of the State of New York and
	253	the intellectual property laws of the United States of America. No party
	254	to this Agreement will bring a legal action under this Agreement more
	255	than one year after the cause of action arose. Each party waives its
	256	rights to a jury trial in any resulting litigation.</p>
	257
	258	</body>
	259
	260	</html>

+24

-0

examples/ex-alts.clj less more

	0	(require '[clojure.core.async :as async :refer [<! >! <!! >!! timeout chan alt! alts!! go]])
	1
	2	(defn fan-in [ins]
	3	(let [c (chan)]
	4	(future (while true
	5	(let [[x] (alts!! ins)]
	6	(>!! c x))))
	7	c))
	8
	9	(defn fan-out [in cs-or-n]
	10	(let [cs (if (number? cs-or-n)
	11	(repeatedly cs-or-n chan)
	12	cs-or-n)]
	13	(future (while true
	14	(let [x (<!! in)
	15	outs (map #(vector % x) cs)]
	16	(alts!! outs))))
	17	cs))
	18
	19	(let [cout (chan)
	20	cin (fan-in (fan-out cout (repeatedly 3 chan)))]
	21	(dotimes [n 10]
	22	(>!! cout n)
	23	(prn (<!! cin))))

+25

-0

examples/ex-altsgo.clj less more

	0	(require '[clojure.core.async :as async :refer [<! >! timeout chan alt! alts! go]])
	1
	2	(defn fan-in [ins]
	3	(let [c (chan)]
	4	(go (while true
	5	(let [[x] (alts! ins)]
	6	(>! c x))))
	7	c))
	8
	9	(defn fan-out [in cs-or-n]
	10	(let [cs (if (number? cs-or-n)
	11	(repeatedly cs-or-n chan)
	12	cs-or-n)]
	13	(go (while true
	14	(let [x (<! in)
	15	outs (map #(vector % x) cs)]
	16	(alts! outs))))
	17	cs))
	18
	19	(let [cout (chan)
	20	cin (fan-in (fan-out cout (repeatedly 3 chan)))]
	21	(go (dotimes [n 10]
	22	(>! cout n)
	23	(prn (<! cin))))
	24	nil)

+33

-0

examples/ex-async.clj less more

	0	(require '[clojure.core.async :as async :refer [<!! >!! timeout chan alt!!]])
	1
	2	(defn fake-search [kind]
	3	(fn [c query]
	4	(future
	5	(<!! (timeout (rand-int 100)))
	6	(>!! c [kind query]))))
	7
	8	(def web1 (fake-search :web1))
	9	(def web2 (fake-search :web2))
	10	(def image1 (fake-search :image1))
	11	(def image2 (fake-search :image2))
	12	(def video1 (fake-search :video1))
	13	(def video2 (fake-search :video2))
	14
	15	(defn fastest [query & replicas]
	16	(let [c (chan)]
	17	(doseq [replica replicas]
	18	(replica c query))
	19	c))
	20
	21	(defn google [query]
	22	(let [c (chan)
	23	t (timeout 80)]
	24	(future (>!! c (<!! (fastest query web1 web2))))
	25	(future (>!! c (<!! (fastest query image1 image2))))
	26	(future (>!! c (<!! (fastest query video1 video2))))
	27	(loop [i 0 ret []]
	28	(if (= i 3)
	29	ret
	30	(recur (inc i) (conj ret (alt!! [c t] ([v] v))))))))
	31
	32	(google "clojure")

+34

-0

examples/ex-go.clj less more

	0	(require '[clojure.core.async :as async :refer [<! >! <!! timeout chan alt! go]])
	1
	2	(defn fake-search [kind]
	3	(fn [c query]
	4	(go
	5	(<! (timeout (rand-int 100)))
	6	(>! c [kind query]))))
	7
	8	(def web1 (fake-search :web1))
	9	(def web2 (fake-search :web2))
	10	(def image1 (fake-search :image1))
	11	(def image2 (fake-search :image2))
	12	(def video1 (fake-search :video1))
	13	(def video2 (fake-search :video2))
	14
	15	(defn fastest [query & replicas]
	16	(let [c (chan)]
	17	(doseq [replica replicas]
	18	(replica c query))
	19	c))
	20
	21	(defn google [query]
	22	(let [c (chan)
	23	t (timeout 80)]
	24	(go (>! c (<! (fastest query web1 web2))))
	25	(go (>! c (<! (fastest query image1 image2))))
	26	(go (>! c (<! (fastest query video1 video2))))
	27	(go (loop [i 0 ret []]
	28	(if (= i 3)
	29	ret
	30	(recur (inc i) (conj ret (alt! [c t] ([v] v)))))))))
	31
	32	(<!! (google "clojure"))
	33

+139

-0

examples/walkthrough.clj less more

	0	;; This walkthrough introduces the core concepts of core.async.
	1
	2	;; The clojure.core.async namespace contains the public API.
	3	(require '[clojure.core.async :as async :refer :all])
	4
	5	;;;; CHANNELS
	6
	7	;; Data is transmitted on queue-like channels. By default channels
	8	;; are unbuffered (0-length) - they require producer and consumer to
	9	;; rendezvous for the transfer of a value through the channel.
	10
	11	;; Use `chan` to make an unbuffered channel:
	12	(chan)
	13
	14	;; Pass a number to create a channel with a fixed buffer:
	15	(chan 10)
	16
	17	;; `close!` a channel to stop accepting puts. Remaining values are still
	18	;; available to take. Drained channels return nil on take. Nils may
	19	;; not be sent over a channel explicitly!
	20
	21	(let [c (chan)]
	22	(close! c))
	23
	24	;;;; ORDINARY THREADS
	25
	26	;; In ordinary threads, we use `>!!` (blocking put) and `<!!`
	27	;; (blocking take) to communicate via channels.
	28
	29	(let [c (chan 10)]
	30	(>!! c "hello")
	31	(assert (= "hello" (<!! c)))
	32	(close! c))
	33
	34	;; Because these are blocking calls, if we try to put on an
	35	;; unbuffered channel, we will block the main thread. We can use
	36	;; `thread` (like `future`) to execute a body in a pool thread and
	37	;; return a channel with the result. Here we launch a background task
	38	;; to put "hello" on a channel, then read that value in the current thread.
	39
	40	(let [c (chan)]
	41	(thread (>!! c "hello"))
	42	(assert (= "hello" (<!! c)))
	43	(close! c))
	44
	45	;;;; GO BLOCKS AND IOC THREADS
	46
	47	;; The `go` macro asynchronously executes its body in a special pool
	48	;; of threads. Channel operations that would block will pause
	49	;; execution instead, blocking no threads. This mechanism encapsulates
	50	;; the inversion of control that is external in event/callback
	51	;; systems. Inside `go` blocks, we use `>!` (put) and `<!` (take).
	52
	53	;; Here we convert our prior channel example to use go blocks:
	54	(let [c (chan)]
	55	(go (>! c "hello"))
	56	(assert (= "hello" (<!! (go (<! c)))))
	57	(close! c))
	58
	59	;; Instead of the explicit thread and blocking call, we use a go block
	60	;; for the producer. The consumer uses a go block to take, then
	61	;; returns a result channel, from which we do a blocking take.
	62
	63	;;;; ALTS
	64
	65	;; One killer feature for channels over queues is the ability to wait
	66	;; on many channels at the same time (like a socket select). This is
	67	;; done with `alts!!` (ordinary threads) or `alts!` in go blocks.
	68
	69	;; We can create a background thread with alts that combines inputs on
	70	;; either of two channels. `alts!!` takes a set of operations
	71	;; to perform - either a channel to take from or a [channel value] to put
	72	;; and returns the value (nil for put) and channel that succeeded:
	73
	74	(let [c1 (chan)
	75	c2 (chan)]
	76	(thread (while true
	77	(let [[v ch] (alts!! [c1 c2])]
	78	(println "Read" v "from" ch))))
	79	(>!! c1 "hi")
	80	(>!! c2 "there"))
	81
	82	;; Prints (on stdout, possibly not visible at your repl):
	83	;; Read hi from #<ManyToManyChannel ...>
	84	;; Read there from #<ManyToManyChannel ...>
	85
	86	;; We can use alts! to do the same thing with go blocks:
	87
	88	(let [c1 (chan)
	89	c2 (chan)]
	90	(go (while true
	91	(let [[v ch] (alts! [c1 c2])]
	92	(println "Read" v "from" ch))))
	93	(go (>! c1 "hi"))
	94	(go (>! c2 "there")))
	95
	96	;; Since go blocks are lightweight processes not bound to threads, we
	97	;; can have LOTS of them! Here we create 1000 go blocks that say hi on
	98	;; 1000 channels. We use alts!! to read them as they're ready.
	99
	100	(let [n 1000
	101	cs (repeatedly n chan)
	102	begin (System/currentTimeMillis)]
	103	(doseq [c cs] (go (>! c "hi")))
	104	(dotimes [i n]
	105	(let [[v c] (alts!! cs)]
	106	(assert (= "hi" v))))
	107	(println "Read" n "msgs in" (- (System/currentTimeMillis) begin) "ms"))
	108
	109	;; `timeout` creates a channel that waits for a specified ms, then closes:
	110
	111	(let [t (timeout 100)
	112	begin (System/currentTimeMillis)]
	113	(<!! t)
	114	(println "Waited" (- (System/currentTimeMillis) begin)))
	115
	116	;; We can combine timeout with `alts!` to do timed channel waits.
	117	;; Here we wait for 100 ms for a value to arrive on the channel, then
	118	;; give up:
	119
	120	(let [c (chan)
	121	begin (System/currentTimeMillis)]
	122	(alts!! [c (timeout 100)])
	123	(println "Gave up after" (- (System/currentTimeMillis) begin)))
	124
	125	;; ALT
	126
	127	;; todo
	128
	129	;;;; OTHER BUFFERS
	130
	131	;; Channels can also use custom buffers that have different policies
	132	;; for the "full" case. Two useful examples are provided in the API.
	133
	134	;; Use `dropping-buffer` to drop newest values when the buffer is full:
	135	(chan (dropping-buffer 10))
	136
	137	;; Use `sliding-buffer` to drop oldest values when the buffer is full:
	138	(chan (sliding-buffer 10))

+60

-0

pom.xml less more

	0	<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
	1	<modelVersion>4.0.0</modelVersion>
	2	<groupId>org.clojure</groupId>
	3	<artifactId>core.async</artifactId>
	4	<!-- Don't set this manually! Call script/build/update_version -->
	5	<version>0.3.443</version>
	6	<packaging>jar</packaging>
	7	<name>core.async</name>
	8	<description>Facilities for async programming and communication in Clojure</description>
	9	<url>https://github.com/clojure/core.async</url>
	10
	11	<developers>
	12	<developer>
	13	<id>richhickey</id>
	14	<name>Rich Hickey</name>
	15	<url>http://clojure.org</url>
	16	</developer>
	17	</developers>
	18
	19	<parent>
	20	<groupId>org.clojure</groupId>
	21	<artifactId>pom.contrib</artifactId>
	22	<version>0.2.2</version>
	23	</parent>
	24
	25	<scm>
	26	<connection>scm:git:git://github.com/clojure/core.async.git</connection>
	27	<developerConnection>scm:git:git@github.com:clojure/core.async.git</developerConnection>
	28	<url>https://github.com/clojure/core.async</url>
	29	<tag>core.async-0.3.443</tag>
	30	</scm>
	31
	32	<properties>
	33	<clojure.version>1.7.0</clojure.version>
	34	</properties>
	35
	36	<dependencies>
	37	<dependency>
	38	<groupId>org.clojure</groupId>
	39	<artifactId>clojurescript</artifactId>
	40	<version>0.0-2311</version>
	41	<scope>provided</scope>
	42	</dependency>
	43	<dependency>
	44	<groupId>org.clojure</groupId>
	45	<artifactId>tools.analyzer.jvm</artifactId>
	46	<version>0.7.0</version>
	47	</dependency>
	48	</dependencies>
	49
	50	<build>
	51	<plugins>
	52	<plugin>
	53	<groupId>org.codehaus.mojo</groupId>
	54	<artifactId>versions-maven-plugin</artifactId>
	55	<version>2.3</version>
	56	</plugin>
	57	</plugins>
	58	</build>
	59	</project>

+62

-0

project.clj less more

	0	(defproject org.clojure/core.async "0.1.0-SNAPSHOT"
	1	:description "Facilities for async programming and communication in Clojure"
	2	:url "https://github.com/clojure/core.async"
	3	:license {:name "Eclipse Public License"
	4	:url "http://www.eclipse.org/legal/epl-v10.html"}
	5	:parent [org.clojure/pom.contrib "0.1.2"]
	6	:dependencies [[org.clojure/clojure "1.7.0"]
	7	[org.clojure/tools.analyzer.jvm "0.7.0"]
	8	[org.clojure/clojurescript "1.7.170" :scope "provided"]]
	9	:global-vars {warn-on-reflection true}
	10	:source-paths ["src/main/clojure"]
	11	:test-paths ["src/test/clojure"]
	12	:jvm-opts ^:replace ["-Xmx1g" "-server"]
	13	:java-source-paths ["src/main/java"]
	14	:profiles {:dev {:source-paths ["examples"]}}
	15
	16	:plugins [[lein-cljsbuild "1.1.2"]]
	17
	18	:clean-targets ["tests.js" "tests.js.map"
	19	"out" "out-simp" "out-simp-node"
	20	"out-adv" "out-adv-node"]
	21
	22	:cljsbuild
	23	{:builds
	24	[{:id "dev"
	25	:source-paths ["src/test/cljs" "src/main/clojure/cljs"]
	26	:compiler {:main cljs.core.async.test-runner
	27	:asset-path "../out"
	28	:optimizations :none
	29	:output-to "tests.js"
	30	:output-dir "out"}}
	31	{:id "simple"
	32	:source-paths ["src/test/cljs" "src/main/clojure/cljs"]
	33	:compiler {:optimizations :simple
	34	:pretty-print true
	35	:static-fns true
	36	:output-to "tests.js"
	37	:output-dir "out-simp"}}
	38	{:id "simple-node"
	39	:source-paths ["src/test/cljs" "src/main/clojure/cljs"]
	40	:notify-command ["node" "tests.js"]
	41	:compiler {:optimizations :simple
	42	:target :nodejs
	43	:pretty-print true
	44	:static-fns true
	45	:output-to "tests.js"
	46	:output-dir "out-simp-node"}}
	47	{:id "adv"
	48	:source-paths ["src/test/cljs" "src/main/clojure/cljs"]
	49	:compiler {:optimizations :advanced
	50	:pretty-print false
	51	:output-dir "out-adv"
	52	:output-to "tests.js"
	53	:source-map "tests.js.map"}}
	54	{:id "adv-node"
	55	:source-paths ["src/test/cljs" "src/main/clojure/cljs"]
	56	:compiler {:optimizations :advanced
	57	:target :nodejs
	58	:pretty-print false
	59	:output-dir "out-adv-node"
	60	:output-to "tests.js"
	61	:source-map "tests.js.map"}}]})

+16

-0

script/build/branch_revision less more

	0	#!/usr/bin/env bash
	1
	2	# If on a branch other than master, returns the number of commits made off of master
	3	# If on master, returns 0
	4
	5	set -e
	6
	7	master_tag=`git rev-parse --abbrev-ref HEAD`
	8
	9	if [ "$master_tag" == "master" ]; then
	10	echo "0"
	11	else
	12	last_commit=`git rev-parse HEAD`
	13	revision=`git rev-list master..$last_commit \| wc -l`
	14	echo $revision
	15	fi

+13

-0

script/build/git_revision less more

	0	#!/usr/bin/env bash
	1
	2	# Return the portion of the version number generated from git
	3	# <trunk-basis>
	4
	5	set -e
	6
	7	trunk_basis=`script/build/trunk_revision`
	8	sha=`git rev-parse HEAD`
	9
	10	sha=${sha:0:${#sha}-34} # drop the last 34 characters, keep 6
	11
	12	echo $trunk_basis

+19

-0

script/build/revision less more

	0	#!/usr/bin/env bash
	1
	2	# Return the complete revision number
	3	# <major>.<minor>.<trunk-basis>.<patch-or-0>-<sha>[-qualifier]
	4
	5	set -e
	6
	7	version_template=`cat VERSION_TEMPLATE`
	8
	9	if [[ "$version_template" =~ ^[0-9]+\.[0-9]+\.GENERATED_VERSION(-[a-zA-Z0-9]+)?$ ]]; then
	10
	11	git_revision=`script/build/git_revision`
	12	echo ${version_template/GENERATED_VERSION/$git_revision}
	13
	14	else
	15	echo "Invalid version template string: $version_template" >&2
	16	exit -1
	17	fi
	18

+14

-0

script/build/trunk_revision less more

	0	#!/usr/bin/env bash
	1
	2	# Returns the number of commits made since the v0.0 tag
	3
	4	set -e
	5
	6	REVISION=`git --no-replace-objects describe --match v0.0`
	7
	8	# Extract the version number from the string. Do this in two steps so
	9	# it is a little easier to understand.
	10	REVISION=${REVISION:5} # drop the first 5 characters
	11	REVISION=${REVISION:0:${#REVISION}-9} # drop the last 9 characters
	12
	13	echo $REVISION

-0

script/build/update_version less more

	0	#!/usr/bin/env bash
	1
	2	set -e
	3
	4	mvn versions:set -DnewVersion=`script/build/revision`-SNAPSHOT

-0

script/runtests.html less more

	0	<html>
	1	<head>
	2	</head>
	3	<body>
	4	<script src="../tests.js" language="javascript"></script>
	5
	6	<h2>Open JavaScript Console to see the test results</h2>
	7	</body>
	8	</html>

+159

-0

src/main/clojure/cljs/core/async/impl/buffers.cljs less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns cljs.core.async.impl.buffers
	9	(:require [cljs.core.async.impl.protocols :as impl]))
	10
	11	;; -----------------------------------------------------------------------------
	12	;; DO NOT USE, this is internal buffer representation
	13
	14	(defn acopy [src src-start dest dest-start len]
	15	(loop [cnt 0]
	16	(when (< cnt len)
	17	(aset dest
	18	(+ dest-start cnt)
	19	(aget src (+ src-start cnt)))
	20	(recur (inc cnt)))))
	21
	22	(deftype RingBuffer [^:mutable head ^:mutable tail ^:mutable length ^:mutable arr]
	23	Object
	24	(pop [_]
	25	(when-not (zero? length)
	26	(let [x (aget arr tail)]
	27	(aset arr tail nil)
	28	(set! tail (js-mod (inc tail) (alength arr)))
	29	(set! length (dec length))
	30	x)))
	31
	32	(unshift [_ x]
	33	(aset arr head x)
	34	(set! head (js-mod (inc head) (alength arr)))
	35	(set! length (inc length))
	36	nil)
	37
	38	(unbounded-unshift [this x]
	39	(if (== (inc length) (alength arr))
	40	(.resize this))
	41	(.unshift this x))
	42
	43	;; Doubles the size of the buffer while retaining all the existing values
	44	(resize
	45	[_]
	46	(let [new-arr-size (* (alength arr) 2)
	47	new-arr (make-array new-arr-size)]
	48	(cond
	49	(< tail head)
	50	(do (acopy arr tail new-arr 0 length)
	51	(set! tail 0)
	52	(set! head length)
	53	(set! arr new-arr))
	54
	55	(> tail head)
	56	(do (acopy arr tail new-arr 0 (- (alength arr) tail))
	57	(acopy arr 0 new-arr (- (alength arr) tail) head)
	58	(set! tail 0)
	59	(set! head length)
	60	(set! arr new-arr))
	61
	62	(== tail head)
	63	(do (set! tail 0)
	64	(set! head 0)
	65	(set! arr new-arr)))))
	66
	67	(cleanup [this keep?]
	68	(dotimes [x length]
	69	(let [v (.pop this)]
	70	(when ^boolean (keep? v)
	71	(.unshift this v))))))
	72
	73	(defn ring-buffer [n]
	74	(assert (> n 0) "Can't create a ring buffer of size 0")
	75	(RingBuffer. 0 0 0 (make-array n)))
	76
	77	;; -----------------------------------------------------------------------------
	78
	79	(deftype FixedBuffer [buf n]
	80	impl/Buffer
	81	(full? [this]
	82	(== (.-length buf) n))
	83	(remove! [this]
	84	(.pop buf))
	85	(add!* [this itm]
	86	(.unbounded-unshift buf itm)
	87	this)
	88	(close-buf! [this])
	89	cljs.core/ICounted
	90	(-count [this]
	91	(.-length buf)))
	92
	93	(defn fixed-buffer [n]
	94	(FixedBuffer. (ring-buffer n) n))
	95
	96	(deftype DroppingBuffer [buf n]
	97	impl/UnblockingBuffer
	98	impl/Buffer
	99	(full? [this]
	100	false)
	101	(remove! [this]
	102	(.pop buf))
	103	(add!* [this itm]
	104	(when-not (== (.-length buf) n)
	105	(.unshift buf itm))
	106	this)
	107	(close-buf! [this])
	108	cljs.core/ICounted
	109	(-count [this]
	110	(.-length buf)))
	111
	112	(defn dropping-buffer [n]
	113	(DroppingBuffer. (ring-buffer n) n))
	114
	115	(deftype SlidingBuffer [buf n]
	116	impl/UnblockingBuffer
	117	impl/Buffer
	118	(full? [this]
	119	false)
	120	(remove! [this]
	121	(.pop buf))
	122	(add!* [this itm]
	123	(when (== (.-length buf) n)
	124	(impl/remove! this))
	125	(.unshift buf itm)
	126	this)
	127	(close-buf! [this])
	128	cljs.core/ICounted
	129	(-count [this]
	130	(.-length buf)))
	131
	132	(defn sliding-buffer [n]
	133	(SlidingBuffer. (ring-buffer n) n))
	134
	135	(defonce ^:private NO-VAL (js/Object.))
	136	(defn- undelivered? [val]
	137	(identical? NO-VAL val))
	138
	139	(deftype PromiseBuffer [^:mutable val]
	140	impl/UnblockingBuffer
	141	impl/Buffer
	142	(full? [_]
	143	false)
	144	(remove! [_]
	145	val)
	146	(add!* [this itm]
	147	(when (undelivered? val)
	148	(set! val itm))
	149	this)
	150	(close-buf! [_]
	151	(when (undelivered? val)
	152	(set! val nil)))
	153	cljs.core/ICounted
	154	(-count [_]
	155	(if (undelivered? val) 0 1)))
	156
	157	(defn promise-buffer []
	158	(PromiseBuffer. NO-VAL))

+192

-0

src/main/clojure/cljs/core/async/impl/channels.cljs less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns cljs.core.async.impl.channels
	9	(:require [cljs.core.async.impl.protocols :as impl]
	10	[cljs.core.async.impl.dispatch :as dispatch]
	11	[cljs.core.async.impl.buffers :as buffers]))
	12
	13
	14
	15	(defn box [val]
	16	(reify cljs.core/IDeref
	17	(-deref [_] val)))
	18
	19	(deftype PutBox [handler val])
	20
	21	(defn put-active? [box]
	22	(impl/active? (.-handler box)))
	23
	24	(def ^:const MAX_DIRTY 64)
	25
	26	(defprotocol MMC
	27	(abort [this]))
	28
	29	(deftype ManyToManyChannel [takes ^:mutable dirty-takes puts ^:mutable dirty-puts ^not-native buf ^:mutable closed add!]
	30	MMC
	31	(abort [this]
	32	(loop []
	33	(let [putter (.pop puts)]
	34	(when-not (nil? putter)
	35	(let [^not-native put-handler (.-handler putter)
	36	val (.-val putter)]
	37	(if ^boolean (impl/active? put-handler)
	38	(let [put-cb (impl/commit put-handler)]
	39	(dispatch/run #(put-cb true)))
	40	(recur))))))
	41	(.cleanup puts (constantly false))
	42	(impl/close! this))
	43	impl/WritePort
	44	(put! [this val ^not-native handler]
	45	(assert (not (nil? val)) "Can't put nil in on a channel")
	46	;; bug in CLJS compiler boolean inference - David
	47	(let [^boolean closed closed]
	48	(if (or closed (not ^boolean (impl/active? handler)))
	49	(box (not closed))
	50	(if (and buf (not (impl/full? buf)))
	51	(do
	52	(impl/commit handler)
	53	(let [done? (reduced? (add! buf val))
	54	take-cbs (loop [takers []]
	55	(if (and (pos? (.-length takes)) (pos? (count buf)))
	56	(let [^not-native taker (.pop takes)]
	57	(if ^boolean (impl/active? taker)
	58	(let [ret (impl/commit taker)
	59	val (impl/remove! buf)]
	60	(recur (conj takers (fn [] (ret val)))))
	61	(recur takers)))
	62	takers))]
	63	(when done? (abort this))
	64	(when (seq take-cbs)
	65	(doseq [f take-cbs]
	66	(dispatch/run f)))
	67	(box true)))
	68	(let [taker (loop []
	69	(let [^not-native taker (.pop takes)]
	70	(when taker
	71	(if (impl/active? taker)
	72	taker
	73	(recur)))))]
	74	(if taker
	75	(let [take-cb (impl/commit taker)]
	76	(impl/commit handler)
	77	(dispatch/run (fn [] (take-cb val)))
	78	(box true))
	79	(do
	80	(if (> dirty-puts MAX_DIRTY)
	81	(do (set! dirty-puts 0)
	82	(.cleanup puts put-active?))
	83	(set! dirty-puts (inc dirty-puts)))
	84	(when (impl/blockable? handler)
	85	(assert (< (.-length puts) impl/MAX-QUEUE-SIZE)
	86	(str "No more than " impl/MAX-QUEUE-SIZE
	87	" pending puts are allowed on a single channel."
	88	" Consider using a windowed buffer."))
	89	(.unbounded-unshift puts (PutBox. handler val)))
	90	nil)))))))
	91	impl/ReadPort
	92	(take! [this ^not-native handler]
	93	(if (not ^boolean (impl/active? handler))
	94	nil
	95	(if (and (not (nil? buf)) (pos? (count buf)))
	96	(do
	97	(if-let [take-cb (impl/commit handler)]
	98	(let [val (impl/remove! buf)
	99	[done? cbs] (when (pos? (.-length puts))
	100	(loop [cbs []]
	101	(let [putter (.pop puts)
	102	^not-native put-handler (.-handler putter)
	103	val (.-val putter)
	104	cb (and ^boolean (impl/active? put-handler) (impl/commit put-handler))
	105	cbs (if cb (conj cbs cb) cbs)
	106	done? (when cb (reduced? (add! buf val)))]
	107	(if (and (not done?) (not (impl/full? buf)) (pos? (.-length puts)))
	108	(recur cbs)
	109	[done? cbs]))))]
	110	(when done?
	111	(abort this))
	112	(doseq [cb cbs]
	113	(dispatch/run #(cb true)))
	114	(box val))))
	115	(let [putter (loop []
	116	(let [putter (.pop puts)]
	117	(when putter
	118	(if ^boolean (impl/active? (.-handler putter))
	119	putter
	120	(recur)))))]
	121	(if putter
	122	(let [put-cb (impl/commit (.-handler putter))]
	123	(impl/commit handler)
	124	(dispatch/run #(put-cb true))
	125	(box (.-val putter)))
	126	(if closed
	127	(do
	128	(when buf (add! buf))
	129	(if (and (impl/active? handler) (impl/commit handler))
	130	(let [has-val (and buf (pos? (count buf)))]
	131	(let [val (when has-val (impl/remove! buf))]
	132	(box val)))
	133	nil))
	134	(do
	135	(if (> dirty-takes MAX_DIRTY)
	136	(do (set! dirty-takes 0)
	137	(.cleanup takes impl/active?))
	138	(set! dirty-takes (inc dirty-takes)))
	139	(when (impl/blockable? handler)
	140	(assert (< (.-length takes) impl/MAX-QUEUE-SIZE)
	141	(str "No more than " impl/MAX-QUEUE-SIZE
	142	" pending takes are allowed on a single channel."))
	143	(.unbounded-unshift takes handler))
	144	nil)))))))
	145	impl/Channel
	146	(closed? [_] closed)
	147	(close! [this]
	148	(if ^boolean closed
	149	nil
	150	(do (set! closed true)
	151	(when (and buf (zero? (.-length puts)))
	152	(add! buf))
	153	(loop []
	154	(let [^not-native taker (.pop takes)]
	155	(when-not (nil? taker)
	156	(when ^boolean (impl/active? taker)
	157	(let [take-cb (impl/commit taker)
	158	val (when (and buf (pos? (count buf))) (impl/remove! buf))]
	159	(dispatch/run (fn [] (take-cb val)))))
	160	(recur))))
	161	(when buf (impl/close-buf! buf))
	162	nil))))
	163
	164	(defn- ex-handler [ex]
	165	(.log js/console ex)
	166	nil)
	167
	168	(defn- handle [buf exh t]
	169	(let [else ((or exh ex-handler) t)]
	170	(if (nil? else)
	171	buf
	172	(impl/add! buf else))))
	173
	174	(defn chan
	175	([buf] (chan buf nil))
	176	([buf xform] (chan buf xform nil))
	177	([buf xform exh]
	178	(ManyToManyChannel. (buffers/ring-buffer 32) 0 (buffers/ring-buffer 32)
	179	0 buf false
	180	(let [add! (if xform (xform impl/add!) impl/add!)]
	181	(fn
	182	([buf]
	183	(try
	184	(add! buf)
	185	(catch :default t
	186	(handle buf exh t))))
	187	([buf val]
	188	(try
	189	(add! buf val)
	190	(catch :default t
	191	(handle buf exh t)))))))))

+37

-0

src/main/clojure/cljs/core/async/impl/dispatch.cljs less more

	0	(ns cljs.core.async.impl.dispatch
	1	(:require [cljs.core.async.impl.buffers :as buffers]
	2	[goog.async.nextTick]))
	3
	4	(def tasks (buffers/ring-buffer 32))
	5	(def running? false)
	6	(def queued? false)
	7
	8	(def TASK_BATCH_SIZE 1024)
	9
	10	(declare queue-dispatcher)
	11
	12	(defn process-messages []
	13	(set! running? true)
	14	(set! queued? false)
	15	(loop [count 0]
	16	(let [m (.pop tasks)]
	17	(when-not (nil? m)
	18	(m)
	19	(when (< count TASK_BATCH_SIZE)
	20	(recur (inc count))))))
	21	(set! running? false)
	22	(when (> (.-length tasks) 0)
	23	(queue-dispatcher)))
	24
	25	(defn queue-dispatcher []
	26	(when-not (and queued? running?)
	27	(set! queued? true)
	28	(goog.async.nextTick process-messages)))
	29
	30	(defn run [f]
	31	(.unbounded-unshift tasks f)
	32	(queue-dispatcher))
	33
	34	(defn queue-delay [f delay]
	35	(js/setTimeout f delay))
	36

+146

-0

src/main/clojure/cljs/core/async/impl/ioc_helpers.cljs less more

	0	(ns cljs.core.async.impl.ioc-helpers
	1	(:require [cljs.core.async.impl.protocols :as impl])
	2	(:require-macros [cljs.core.async.impl.ioc-macros :as ioc]))
	3
	4	(def ^:const FN-IDX 0)
	5	(def ^:const STATE-IDX 1)
	6	(def ^:const VALUE-IDX 2)
	7	(def ^:const BINDINGS-IDX 3)
	8	(def ^:const EXCEPTION-FRAMES 4)
	9	(def ^:const CURRENT-EXCEPTION 5)
	10	(def ^:const USER-START-IDX 6)
	11
	12	(defn aset-object [arr idx o]
	13	(aget arr idx o))
	14
	15	(defn aget-object [arr idx]
	16	(aget arr idx))
	17
	18
	19	(defn finished?
	20	"Returns true if the machine is in a finished state"
	21	[state-array]
	22	(keyword-identical? (aget state-array STATE-IDX) :finished))
	23
	24	(defn- fn-handler
	25	[f]
	26	(reify
	27	impl/Handler
	28	(active? [_] true)
	29	(blockable? [_] true)
	30	(commit [_] f)))
	31
	32
	33	(defn run-state-machine [state]
	34	((aget-object state FN-IDX) state))
	35
	36	(defn run-state-machine-wrapped [state]
	37	(try
	38	(run-state-machine state)
	39	(catch js/Object ex
	40	(impl/close! ^not-native (aget-object state USER-START-IDX))
	41	(throw ex))))
	42
	43	(defn take! [state blk ^not-native c]
	44	(if-let [cb (impl/take! c (fn-handler
	45	(fn [x]
	46	(ioc/aset-all! state VALUE-IDX x STATE-IDX blk)
	47	(run-state-machine-wrapped state))))]
	48	(do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk)
	49	:recur)
	50	nil))
	51
	52	(defn put! [state blk ^not-native c val]
	53	(if-let [cb (impl/put! c val (fn-handler (fn [ret-val]
	54	(ioc/aset-all! state VALUE-IDX ret-val STATE-IDX blk)
	55	(run-state-machine-wrapped state))))]
	56	(do (ioc/aset-all! state VALUE-IDX @cb STATE-IDX blk)
	57	:recur)
	58	nil))
	59
	60	(defn return-chan [state value]
	61	(let [^not-native c (aget state USER-START-IDX)]
	62	(when-not (nil? value)
	63	(impl/put! c value (fn-handler (fn [] nil))))
	64	(impl/close! c)
	65	c))
	66
	67	(defrecord ExceptionFrame [catch-block
	68	^Class catch-exception
	69	finally-block
	70	continue-block
	71	prev])
	72
	73	(defn add-exception-frame [state catch-block catch-exception finally-block continue-block]
	74	(ioc/aset-all! state
	75	EXCEPTION-FRAMES
	76	(->ExceptionFrame catch-block
	77	catch-exception
	78	finally-block
	79	continue-block
	80	(aget-object state EXCEPTION-FRAMES))))
	81
	82	(defn process-exception [state]
	83	(let [exception-frame (aget-object state EXCEPTION-FRAMES)
	84	catch-block (:catch-block exception-frame)
	85	catch-exception (:catch-exception exception-frame)
	86	exception (aget-object state CURRENT-EXCEPTION)]
	87	(cond
	88	(and exception
	89	(not exception-frame))
	90	(throw exception)
	91
	92	(and exception
	93	catch-block
	94	(or (= :default catch-exception)
	95	(instance? catch-exception exception)))
	96	(ioc/aset-all! state
	97	STATE-IDX
	98	catch-block
	99	VALUE-IDX
	100	exception
	101	CURRENT-EXCEPTION
	102	nil
	103	EXCEPTION-FRAMES
	104	(assoc exception-frame
	105	:catch-block nil
	106	:catch-exception nil))
	107
	108
	109	(and exception
	110	(not catch-block)
	111	(not (:finally-block exception-frame)))
	112
	113	(do (ioc/aset-all! state
	114	EXCEPTION-FRAMES
	115	(:prev exception-frame))
	116	(recur state))
	117
	118	(and exception
	119	(not catch-block)
	120	(:finally-block exception-frame))
	121	(ioc/aset-all! state
	122	STATE-IDX
	123	(:finally-block exception-frame)
	124	EXCEPTION-FRAMES
	125	(assoc exception-frame
	126	:finally-block nil))
	127
	128	(and (not exception)
	129	(:finally-block exception-frame))
	130	(do (ioc/aset-all! state
	131	STATE-IDX
	132	(:finally-block exception-frame)
	133	EXCEPTION-FRAMES
	134	(assoc exception-frame
	135	:finally-block nil)))
	136
	137	(and (not exception)
	138	(not (:finally-block exception-frame)))
	139	(do (ioc/aset-all! state
	140	STATE-IDX
	141	(:continue-block exception-frame)
	142	EXCEPTION-FRAMES
	143	(:prev exception-frame)))
	144
	145	:else (throw (js/Error. "No matching clause")))))

+883

-0

src/main/clojure/cljs/core/async/impl/ioc_macros.clj less more

	0	; Copyright (c) Rich Hickey. All rights reserved.
	1	; The use and distribution terms for this software are covered by the
	2	; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	; which can be found in the file epl-v10.html at the root of this distribution.
	4	; By using this software in any fashion, you are agreeing to be bound by
	5	; the terms of this license.
	6	; You must not remove this notice, or any other, from this software.
	7
	8	;; by Timothy Baldridge
	9	;; April 13, 2013
	10
	11	(ns cljs.core.async.impl.ioc-macros
	12	(:refer-clojure :exclude [all])
	13	(:require [clojure.pprint :refer [pprint]]
	14	[clojure.set :refer (intersection)]
	15	[clojure.core.async.impl.protocols :as impl]
	16	[clojure.core.async.impl.dispatch :as dispatch]
	17	[cljs.analyzer :as cljs])
	18	(:import [java.util.concurrent.locks Lock]))
	19
	20	(defn debug [x]
	21	(binding [out err]
	22	(pprint x))
	23	x)
	24
	25	(def ^:const FN-IDX 0)
	26	(def ^:const STATE-IDX 1)
	27	(def ^:const VALUE-IDX 2)
	28	(def ^:const BINDINGS-IDX 3)
	29	(def ^:const EXCEPTION-FRAMES 4)
	30	(def ^:const CURRENT-EXCEPTION 5)
	31	(def ^:const USER-START-IDX 6)
	32
	33	(defmacro aset-all!
	34	[arr & more]
	35	(assert (even? (count more)) "Must give an even number of args to aset-all!")
	36	(let [bindings (partition 2 more)
	37	arr-sym (gensym "statearr-")]
	38	`(let [~arr-sym ~arr]
	39	~@(map
	40	(fn [[idx val]]
	41	`(aset ~arr-sym ~idx ~val))
	42	bindings)
	43	~arr-sym)))
	44
	45	;; State monad stuff, used only in SSA construction
	46
	47	(defmacro gen-plan
	48	"Allows a user to define a state monad binding plan.
	49
	50	(gen-plan
	51	[_ (assoc-in-plan [:foo :bar] 42)
	52	val (get-in-plan [:foo :bar])]
	53	val)"
	54	[binds id-expr]
	55	(let [binds (partition 2 binds)
	56	psym (gensym "plan_")
	57	forms (reduce
	58	(fn [acc [id expr]]
	59	(concat acc `[[~id ~psym] (~expr ~psym)]))
	60	[]
	61	binds)]
	62	`(fn [~psym]
	63	(let [~@forms]
	64	[~id-expr ~psym]))))
	65
	66	(defn get-plan
	67	"Returns the final [id state] from a plan. "
	68	[f]
	69	(f {}))
	70
	71	(defn push-binding
	72	"Sets the binding 'key' to value. This operation can be undone via pop-bindings.
	73	Bindings are stored in the state hashmap."
	74	[key value]
	75	(fn [plan]
	76	[nil (update-in plan [:bindings key] conj value)]))
	77
	78	(defn push-alter-binding
	79	"Pushes the result of (apply f old-value args) as current value of binding key"
	80	[key f & args]
	81	(fn [plan]
	82	[nil (update-in plan [:bindings key]
	83	#(conj % (apply f (first %) args)))]))
	84
	85	(defn get-binding
	86	"Gets the value of the current binding for key"
	87	[key]
	88	(fn [plan]
	89	[(first (get-in plan [:bindings key])) plan]))
	90
	91	(defn pop-binding
	92	"Removes the most recent binding for key"
	93	[key]
	94	(fn [plan]
	95	[(first (get-in plan [:bindings key]))
	96	(update-in plan [:bindings key] pop)]))
	97
	98	(defn no-op
	99	"This function can be used inside a gen-plan when no operation is to be performed"
	100	[]
	101	(fn [plan]
	102	[nil plan]))
	103
	104	(defn all
	105	"Assumes that itms is a list of state monad function results, threads the state map
	106	through all of them. Returns a vector of all the results."
	107	[itms]
	108	(fn [plan]
	109	(reduce
	110	(fn [[ids plan] f]
	111	(let [[id plan] (f plan)]
	112	[(conj ids id) plan]))
	113	[[] plan]
	114	itms)))
	115
	116	(defn assoc-in-plan
	117	"Same as assoc-in, but for state hash map"
	118	[path val]
	119	(fn [plan]
	120	[val (assoc-in plan path val)]))
	121
	122	(defn update-in-plan
	123	"Same as update-in, but for a state hash map"
	124	[path f & args]
	125	(fn [plan]
	126	[nil (apply update-in plan path f args)]))
	127
	128	(defn get-in-plan
	129	"Same as get-in, but for a state hash map"
	130	[path]
	131	(fn [plan]
	132	[(get-in plan path) plan]))
	133
	134	(defn print-plan []
	135	(fn [plan]
	136	(pprint plan)
	137	[nil plan]))
	138
	139	(defn set-block
	140	"Sets the current block being written to by the functions. The next add-instruction call will append to this block"
	141	[block-id]
	142	(fn [plan]
	143	[block-id (assoc plan :current-block block-id)]))
	144
	145	(defn get-block
	146	"Gets the current block"
	147	[]
	148	(fn [plan]
	149	[(:current-block plan) plan]))
	150
	151	(defn add-block
	152	"Adds a new block, returns its id, but does not change the current block (does not call set-block)."
	153	[]
	154	(gen-plan
	155	[_ (update-in-plan [:block-id] (fnil inc 0))
	156	blk-id (get-in-plan [:block-id])
	157	cur-blk (get-block)
	158	_ (assoc-in-plan [:blocks blk-id] [])
	159	catches (get-binding :catch)
	160	_ (assoc-in-plan [:block-catches blk-id] catches)
	161	_ (if-not cur-blk
	162	(assoc-in-plan [:start-block] blk-id)
	163	(no-op))]
	164	blk-id))
	165
	166
	167	(defn instruction? [x]
	168	(::instruction (meta x)))
	169
	170	(defn add-instruction
	171	"Appends an instruction to the current block. "
	172	[inst]
	173	(let [inst-id (with-meta (gensym "inst_")
	174	{::instruction true})
	175	inst (assoc inst :id inst-id)]
	176	(gen-plan
	177	[blk-id (get-block)
	178	_ (update-in-plan [:blocks blk-id] (fnil conj []) inst)]
	179	inst-id)))
	180
	181	;;
	182
	183	;; We're going to reduce Clojure expressions to a ssa format,
	184	;; and then translate the instructions for this
	185	;; virtual-virtual-machine back into Clojure data.
	186
	187	;; Here we define the instructions:
	188
	189	(defprotocol IInstruction
	190	(reads-from [this] "Returns a list of instructions this instruction reads from")
	191	(writes-to [this] "Returns a list of instructions this instruction writes to")
	192	(block-references [this] "Returns all the blocks this instruction references"))
	193
	194	(defprotocol IEmittableInstruction
	195	(emit-instruction [this state-sym] "Returns the clojure code that this instruction represents"))
	196
	197	(defprotocol ITerminator
	198	(terminator-code [this] "Returns a unique symbol for this instruction")
	199	(terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block"))
	200
	201	(defrecord Const [value]
	202	IInstruction
	203	(reads-from [this] [value])
	204	(writes-to [this] [(:id this)])
	205	(block-references [this] [])
	206	IEmittableInstruction
	207	(emit-instruction [this state-sym]
	208	(if (= value ::value)
	209	`[~(:id this) (aget ~state-sym ~VALUE-IDX)]
	210	`[~(:id this) ~value])))
	211
	212	(defrecord CustomTerminator [f blk values]
	213	IInstruction
	214	(reads-from [this] values)
	215	(writes-to [this] [])
	216	(block-references [this] [])
	217	ITerminator
	218	(terminate-block [this state-sym _]
	219	`(~f ~state-sym ~blk ~@values)))
	220
	221	(defn- emit-clashing-binds
	222	[recur-nodes ids clashes]
	223	(let [temp-binds (reduce
	224	(fn [acc i]
	225	(assoc acc i (gensym "tmp")))
	226	{} clashes)]
	227	(concat
	228	(mapcat (fn [i]
	229	`[~(temp-binds i) ~i])
	230	clashes)
	231	(mapcat (fn [node id]
	232	`[~node ~(get temp-binds id id)])
	233	recur-nodes
	234	ids))))
	235
	236	(defrecord Recur [recur-nodes ids]
	237	IInstruction
	238	(reads-from [this] ids)
	239	(writes-to [this] recur-nodes)
	240	(block-references [this] [])
	241	IEmittableInstruction
	242	(emit-instruction [this state-sym]
	243	(if-let [overlap (seq (intersection (set recur-nodes) (set ids)))]
	244	(emit-clashing-binds recur-nodes ids overlap)
	245	(mapcat (fn [r i]
	246	`[~r ~i]) recur-nodes ids))))
	247
	248	(defrecord Call [refs]
	249	IInstruction
	250	(reads-from [this] refs)
	251	(writes-to [this] [(:id this)])
	252	(block-references [this] [])
	253	IEmittableInstruction
	254	(emit-instruction [this state-sym]
	255	`[~(:id this) ~(seq refs)]))
	256
	257	(defrecord Case [val-id test-vals jmp-blocks default-block]
	258	IInstruction
	259	(reads-from [this] [val-id])
	260	(writes-to [this] [])
	261	(block-references [this] [])
	262	ITerminator
	263	(terminate-block [this state-sym _]
	264	`(do (case ~val-id
	265	~@(concat (mapcat (fn [test blk]
	266	`[~test (aset-all! ~state-sym
	267	~STATE-IDX ~blk)])
	268	test-vals jmp-blocks)
	269	(when default-block
	270	`[(do (aset-all! ~state-sym ~STATE-IDX ~default-block)
	271	:recur)])))
	272	:recur)))
	273
	274	(defrecord Fn [fn-expr local-names local-refs]
	275	IInstruction
	276	(reads-from [this] local-refs)
	277	(writes-to [this] [(:id this)])
	278	(block-references [this] [])
	279	IEmittableInstruction
	280	(emit-instruction [this state-sym]
	281	`[~(:id this)
	282	(let [~@(interleave local-names local-refs)]
	283	~@fn-expr)]))
	284
	285	(defrecord Dot [target method args]
	286	IInstruction
	287	(reads-from [this] `[~target ~method ~@args])
	288	(writes-to [this] [(:id this)])
	289	(block-references [this] [])
	290	IEmittableInstruction
	291	(emit-instruction [this state-sym]
	292	(if (.startsWith (name method) "-")
	293	`[~(:id this) (. ~target ~method)]
	294	`[~(:id this) (. ~target ~(cons method args))])))
	295
	296	(defrecord Jmp [value block]
	297	IInstruction
	298	(reads-from [this] [value])
	299	(writes-to [this] [])
	300	(block-references [this] [block])
	301	ITerminator
	302	(terminate-block [this state-sym _]
	303	`(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block)
	304	:recur)))
	305
	306	(defrecord Return [value]
	307	IInstruction
	308	(reads-from [this] [value])
	309	(writes-to [this] [])
	310	(block-references [this] [])
	311	ITerminator
	312	(terminator-code [this] :Return)
	313	(terminate-block [this state-sym custom-terminators]
	314	(if-let [f (get custom-terminators (terminator-code this))]
	315	`(~f ~state-sym ~value)
	316	`(do (aset-all! ~state-sym
	317	~VALUE-IDX ~value
	318	~STATE-IDX :finished)
	319	nil))))
	320
	321	(defrecord Set! [field object val]
	322	IInstruction
	323	(reads-from [this] [object val])
	324	(writes-to [this] [(:id this)])
	325	(block-references [this] [])
	326	IEmittableInstruction
	327	(emit-instruction [this state-sym]
	328	(if field
	329	`[~(:id this) (set! (~field ~object) ~val)]
	330	`[~(:id this) (set! ~object ~val)])))
	331
	332	(defrecord CondBr [test then-block else-block]
	333	IInstruction
	334	(reads-from [this] [test])
	335	(writes-to [this] [])
	336	(block-references [this] [then-block else-block])
	337	ITerminator
	338	(terminate-block [this state-sym _]
	339	`(do (if ~test
	340	(aset-all! ~state-sym
	341	~STATE-IDX ~then-block)
	342	(aset-all! ~state-sym
	343	~STATE-IDX ~else-block))
	344	:recur)))
	345
	346
	347	(defrecord Try [catch-block catch-exception finally-block continue-block]
	348	IInstruction
	349	(reads-from [this] [])
	350	(writes-to [this] [])
	351	(block-references [this] [catch-block finally-block continue-block])
	352	IEmittableInstruction
	353	(emit-instruction [this state-sym]
	354	`[~'_ (cljs.core.async.impl.ioc-helpers/add-exception-frame ~state-sym
	355	~catch-block
	356	~catch-exception
	357	~finally-block
	358	~continue-block)]))
	359
	360	(defrecord ProcessExceptionWithValue [value]
	361	IInstruction
	362	(reads-from [this] [value])
	363	(writes-to [this] [])
	364	(block-references [this] [])
	365	ITerminator
	366	(terminate-block [this state-sym _]
	367	`(do (aset-all! ~state-sym
	368	~VALUE-IDX
	369	~value)
	370	(cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
	371	:recur)))
	372
	373	(defrecord EndCatchFinally []
	374	IInstruction
	375	(reads-from [this] [])
	376	(writes-to [this] [])
	377	(block-references [this] [])
	378	ITerminator
	379	(terminate-block [this state-sym _]
	380	`(do (cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
	381	:recur)))
	382
	383
	384
	385	;; Dispatch clojure forms based on data type
	386	(defmulti -item-to-ssa (fn [x]
	387	(cond
	388	(symbol? x) :symbol
	389	(seq? x) :list
	390	(map? x) :map
	391	(set? x) :set
	392	(vector? x) :vector
	393	:else :default)))
	394
	395	(defn item-to-ssa [x]
	396	(-item-to-ssa x))
	397
	398	;; given an sexpr, dispatch on the first item
	399	(defmulti sexpr-to-ssa (fn [[x & _]]
	400	x))
	401
	402	(defn is-special? [x]
	403	(let [^clojure.lang.MultiFn mfn sexpr-to-ssa]
	404	(.getMethod mfn x)))
	405
	406
	407
	408	(defn default-sexpr [args]
	409	(gen-plan
	410	[args-ids (all (map item-to-ssa args))
	411	inst-id (add-instruction (->Call args-ids))]
	412	inst-id))
	413
	414	(defn let-binding-to-ssa
	415	[[sym bind]]
	416	(gen-plan
	417	[bind-id (item-to-ssa bind)
	418	_ (push-alter-binding :locals assoc sym bind-id)]
	419	bind-id))
	420
	421	(defmethod sexpr-to-ssa 'let*
	422	[[_ binds & body]]
	423	(let [parted (partition 2 binds)]
	424	(gen-plan
	425	[let-ids (all (map let-binding-to-ssa parted))
	426	body-ids (all (map item-to-ssa body))
	427	_ (all (map (fn [x]
	428	(pop-binding :locals))
	429	(range (count parted))))]
	430	(last body-ids))))
	431
	432	(defmethod sexpr-to-ssa 'loop*
	433	[[_ locals & body]]
	434	(let [parted (partition 2 locals)
	435	syms (map first parted)
	436	inits (map second parted)]
	437	(gen-plan
	438	[local-val-ids (all (map ; parallel bind
	439	(fn [sym init]
	440	(gen-plan
	441	[itm-id (item-to-ssa init)
	442	_ (push-alter-binding :locals assoc sym itm-id)]
	443	itm-id))
	444	syms
	445	inits))
	446	_ (all (for [x syms]
	447	(pop-binding :locals)))
	448	local-ids (all (map (comp add-instruction ->Const) local-val-ids))
	449	body-blk (add-block)
	450	final-blk (add-block)
	451	_ (add-instruction (->Jmp nil body-blk))
	452
	453	_ (set-block body-blk)
	454	_ (push-alter-binding :locals merge (zipmap syms local-ids))
	455	_ (push-binding :recur-point body-blk)
	456	_ (push-binding :recur-nodes local-ids)
	457
	458	body-ids (all (map item-to-ssa body))
	459
	460	_ (pop-binding :recur-nodes)
	461	_ (pop-binding :recur-point)
	462	_ (pop-binding :locals)
	463	_ (if (not= (last body-ids) ::terminated)
	464	(add-instruction (->Jmp (last body-ids) final-blk))
	465	(no-op))
	466	_ (set-block final-blk)
	467	ret-id (add-instruction (->Const ::value))]
	468	ret-id)))
	469
	470	(defmethod sexpr-to-ssa 'set!
	471	[[_ assignee val]]
	472	(let [target (cond
	473	(symbol? assignee)
	474	assignee
	475	(and (list? assignee)
	476	(= (count assignee) 2))
	477	(second assignee))
	478	field (if (list? assignee)
	479	(first assignee))]
	480	(gen-plan
	481	[locals (get-binding :locals)
	482
	483	target-id (if (contains? locals target)
	484	(fn [p]
	485	[(get locals target) p])
	486	(item-to-ssa target))
	487	val-id (item-to-ssa val)
	488
	489	ret-id (add-instruction (->Set! field target-id val-id))]
	490	ret-id)))
	491
	492	(defmethod sexpr-to-ssa 'do
	493	[[_ & body]]
	494	(gen-plan
	495	[ids (all (map item-to-ssa body))]
	496	(last ids)))
	497
	498	(defmethod sexpr-to-ssa 'case
	499	[[_ val & body]]
	500	(let [clauses (partition 2 body)
	501	default (when (odd? (count body))
	502	(last body))]
	503	(gen-plan
	504	[end-blk (add-block)
	505	start-blk (get-block)
	506	clause-blocks (all (map (fn [expr]
	507	(gen-plan
	508	[blk-id (add-block)
	509	_ (set-block blk-id)
	510	expr-id (item-to-ssa expr)
	511	_ (if (not= expr-id ::terminated)
	512	(add-instruction (->Jmp expr-id end-blk))
	513	(no-op))]
	514	blk-id))
	515	(map second clauses)))
	516	default-block (if (odd? (count body))
	517	(gen-plan
	518	[blk-id (add-block)
	519	_ (set-block blk-id)
	520	expr-id (item-to-ssa default)
	521	_ (if (not= expr-id ::terminated)
	522	(add-instruction (->Jmp expr-id end-blk))
	523	(no-op))]
	524	blk-id)
	525	(no-op))
	526	_ (set-block start-blk)
	527	val-id (item-to-ssa val)
	528	case-id (add-instruction (->Case val-id (map first clauses) clause-blocks default-block))
	529	_ (set-block end-blk)
	530	ret-id (add-instruction (->Const ::value))]
	531	ret-id)))
	532
	533	(defmethod sexpr-to-ssa 'quote
	534	[expr]
	535	(gen-plan
	536	[ret-id (add-instruction (->Const expr))]
	537	ret-id))
	538
	539	(defmethod sexpr-to-ssa '.
	540	[[_ target method & args]]
	541	(let [args (if (seq? method)
	542	(next method)
	543	args)
	544	method (if (seq? method)
	545	(first method)
	546	method)]
	547	(gen-plan
	548	[target-id (item-to-ssa target)
	549	args-ids (all (map item-to-ssa args))
	550	ret-id (add-instruction (->Dot target-id method args-ids))]
	551	ret-id)))
	552
	553	(defmethod sexpr-to-ssa 'try
	554	[[_ & body]]
	555	(let [finally-fn (every-pred seq? (comp (partial = 'finally) first))
	556	catch-fn (every-pred seq? (comp (partial = 'catch) first))
	557	finally (next (first (filter finally-fn body)))
	558	body (remove finally-fn body)
	559	catch (next (first (filter catch-fn body)))
	560	[ex ex-bind & catch-body] catch
	561	body (remove catch-fn body)]
	562	(gen-plan
	563	[end-blk (add-block)
	564	finally-blk (if finally
	565	(gen-plan
	566	[cur-blk (get-block)
	567	blk (add-block)
	568	_ (set-block blk)
	569	value-id (add-instruction (->Const ::value))
	570	_ (all (map item-to-ssa finally))
	571	_ (add-instruction (->EndCatchFinally))
	572	_ (set-block cur-blk)]
	573	blk)
	574	(no-op))
	575	catch-blk (if catch
	576	(gen-plan
	577	[cur-blk (get-block)
	578	blk (add-block)
	579	_ (set-block blk)
	580	ex-id (add-instruction (->Const ::value))
	581	_ (push-alter-binding :locals assoc ex-bind ex-id)
	582	ids (all (map item-to-ssa catch-body))
	583	_ (add-instruction (->ProcessExceptionWithValue (last ids)))
	584	_ (pop-binding :locals)
	585	_ (set-block cur-blk)
	586	_ (push-alter-binding :catch (fnil conj []) [ex blk])]
	587	blk)
	588	(no-op))
	589	body-blk (add-block)
	590	_ (add-instruction (->Jmp nil body-blk))
	591	_ (set-block body-blk)
	592	_ (add-instruction (->Try catch-blk ex finally-blk end-blk))
	593	ids (all (map item-to-ssa body))
	594	_ (if catch
	595	(pop-binding :catch)
	596	(no-op))
	597	_ (add-instruction (->ProcessExceptionWithValue (last ids)))
	598	_ (set-block end-blk)
	599	ret (add-instruction (->Const ::value))]
	600	ret)))
	601
	602	(defmethod sexpr-to-ssa 'recur
	603	[[_ & vals]]
	604	(gen-plan
	605	[val-ids (all (map item-to-ssa vals))
	606	recurs (get-binding :recur-nodes)
	607	_ (do (assert (= (count val-ids)
	608	(count recurs))
	609	"Wrong number of arguments to recur")
	610	(no-op))
	611	_ (add-instruction (->Recur recurs val-ids))
	612
	613	recur-point (get-binding :recur-point)
	614	_ (add-instruction (->Jmp nil recur-point))]
	615	::terminated))
	616
	617	(defmethod sexpr-to-ssa 'if
	618	[[_ test then else]]
	619	(gen-plan
	620	[test-id (item-to-ssa test)
	621	then-blk (add-block)
	622	else-blk (add-block)
	623	final-blk (add-block)
	624	_ (add-instruction (->CondBr test-id then-blk else-blk))
	625
	626	_ (set-block then-blk)
	627	then-id (item-to-ssa then)
	628	_ (if (not= then-id ::terminated)
	629	(gen-plan
	630	[_ (add-instruction (->Jmp then-id final-blk))]
	631	then-id)
	632	(no-op))
	633
	634	_ (set-block else-blk)
	635	else-id (item-to-ssa else)
	636	_ (if (not= else-id ::terminated)
	637	(gen-plan
	638	[_ (add-instruction (->Jmp else-id final-blk))]
	639	then-id)
	640	(no-op))
	641
	642	_ (set-block final-blk)
	643	val-id (add-instruction (->Const ::value))]
	644	val-id))
	645
	646	(defmethod sexpr-to-ssa 'fn*
	647	[& fn-expr]
	648	;; For fn expressions we just want to record the expression as well
	649	;; as a list of all known renamed locals
	650	(gen-plan
	651	[locals (get-binding :locals)
	652	fn-id (add-instruction (->Fn fn-expr (keys locals) (vals locals)))]
	653	fn-id))
	654
	655
	656	(def special-override? '#{case clojure.core/case
	657	try clojure.core/try})
	658
	659	(defn expand [locals env form]
	660	(loop [form form]
	661	(if-not (seq? form)
	662	form
	663	(let [[s & r] form]
	664	(if (symbol? s)
	665	(if (or (get locals s)
	666	(special-override? s))
	667	form
	668	(let [new-env (update-in env [:locals] merge locals)
	669	expanded (cljs/macroexpand-1 new-env form)]
	670	(if (= expanded form)
	671	form
	672	(recur expanded))))
	673	form)))))
	674
	675	(defn terminate-custom [vals term]
	676	(gen-plan
	677	[blk (add-block)
	678	vals (all (map item-to-ssa vals))
	679	val (add-instruction (->CustomTerminator term blk vals))
	680	_ (set-block blk)
	681	res (add-instruction (->Const ::value))]
	682	res))
	683
	684	(defn fixup-aliases [sym env]
	685	(let [aliases (ns-aliases ns)]
	686	(if-not (namespace sym)
	687	sym
	688	(if-let [ns (or (get-in env [:ns :requires-macros (symbol (namespace sym))])
	689	(get-in env [:ns :requires (symbol (namespace sym))]))]
	690	(symbol (name ns) (name sym))
	691	sym))))
	692
	693	(defmethod -item-to-ssa :list
	694	[lst]
	695	(gen-plan
	696	[env (get-binding :env)
	697	locals (get-binding :locals)
	698	terminators (get-binding :terminators)
	699	val (let [exp (expand locals env lst)]
	700	(if (seq? exp)
	701	(if (symbol? (first exp))
	702	(let [f (fixup-aliases (first exp) env)]
	703	(cond
	704	(is-special? f) (sexpr-to-ssa exp)
	705	(get locals f) (default-sexpr exp)
	706	(get terminators f) (terminate-custom (next exp) (get terminators f))
	707	:else (default-sexpr exp)))
	708	(default-sexpr exp))
	709	(item-to-ssa exp)))]
	710	val))
	711
	712	(defmethod -item-to-ssa :default
	713	[x]
	714	(fn [plan]
	715	[x plan]))
	716
	717	(defmethod -item-to-ssa :symbol
	718	[x]
	719	(gen-plan
	720	[locals (get-binding :locals)
	721	inst-id (if (contains? locals x)
	722	(fn [p]
	723	[(locals x) p])
	724	(fn [p]
	725	[x p])
	726	#_(add-instruction (->Const x)))]
	727	inst-id))
	728
	729	(defmethod -item-to-ssa :map
	730	[x]
	731	(-item-to-ssa `(hash-map ~@(mapcat identity x))))
	732
	733	(defmethod -item-to-ssa :vector
	734	[x]
	735	(-item-to-ssa `(vector ~@x)))
	736
	737	(defmethod -item-to-ssa :set
	738	[x]
	739	(-item-to-ssa `(hash-set ~@x)))
	740
	741	(defn parse-to-state-machine
	742	"Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as
	743	a series of SSA style blocks."
	744	[body env terminators]
	745	(-> (gen-plan
	746	[_ (push-binding :env env)
	747	_ (push-binding :locals (zipmap (:locals (keys env)) (:locals (keys env))))
	748	_ (push-binding :terminators terminators)
	749	blk (add-block)
	750	_ (set-block blk)
	751	ids (all (map item-to-ssa body))
	752	term-id (add-instruction (->Return (last ids)))
	753	_ (pop-binding :terminators)
	754	_ (pop-binding :locals)
	755	_ (pop-binding :env)]
	756	term-id)
	757	get-plan))
	758
	759
	760	(defn index-instruction [blk-id idx inst]
	761	(let [idx (reduce
	762	(fn [acc id]
	763	(update-in acc [id :read-in] (fnil conj #{}) blk-id))
	764	idx
	765	(filter instruction? (reads-from inst)))
	766	idx (reduce
	767	(fn [acc id]
	768	(update-in acc [id :written-in] (fnil conj #{}) blk-id))
	769	idx
	770	(filter instruction? (writes-to inst)))]
	771	idx))
	772
	773	(defn index-block [idx [blk-id blk]]
	774	(reduce (partial index-instruction blk-id) idx blk))
	775
	776	(defn index-state-machine [machine]
	777	(reduce index-block {} (:blocks machine)))
	778
	779	(defn id-for-inst [m sym] ;; m :: symbols -> integers
	780	(if-let [i (get @m sym)]
	781	i
	782	(let [next-idx (get @m ::next-idx)]
	783	(swap! m assoc sym next-idx)
	784	(swap! m assoc ::next-idx (inc next-idx))
	785	next-idx)))
	786
	787	(defn persistent-value?
	788	"Returns true if this value should be saved in the state hash map"
	789	[index value]
	790	(or (not= (-> index value :read-in)
	791	(-> index value :written-in))
	792	(-> index value :read-in count (> 1))))
	793
	794	(defn count-persistent-values
	795	[index]
	796	(->> (keys index)
	797	(filter instruction?)
	798	(filter (partial persistent-value? index))
	799	count))
	800
	801	(defn- build-block-preamble [local-map idx state-sym blk]
	802	(let [args (->> (mapcat reads-from blk)
	803	(filter instruction?)
	804	(filter (partial persistent-value? idx))
	805	set
	806	vec)]
	807	(if (empty? args)
	808	[]
	809	(mapcat (fn [sym]
	810	`[~sym (aget ~state-sym ~(id-for-inst local-map sym))])
	811	args))))
	812
	813	(defn- build-block-body [state-sym blk]
	814	(mapcat
	815	#(emit-instruction % state-sym)
	816	(butlast blk)))
	817
	818	(defn- build-new-state [local-map idx state-sym blk]
	819	(let [results (->> blk
	820	(mapcat writes-to)
	821	(filter instruction?)
	822	(filter (partial persistent-value? idx))
	823	set
	824	vec)
	825	results (interleave (map (partial id-for-inst local-map) results) results)]
	826	(if-not (empty? results)
	827	`(aset-all! ~state-sym ~@results)
	828	state-sym)))
	829
	830	(defn- emit-state-machine [machine num-user-params custom-terminators]
	831	(let [index (index-state-machine machine)
	832	state-sym (with-meta (gensym "state_")
	833	{:tag 'objects})
	834	local-start-idx (+ num-user-params USER-START-IDX)
	835	state-arr-size (+ local-start-idx (count-persistent-values index))
	836	local-map (atom {::next-idx local-start-idx})
	837	block-catches (:block-catches machine)
	838	state-val-sym (gensym "state_val_")]
	839	`(let [switch# (fn [~state-sym]
	840	(let [~state-val-sym (aget ~state-sym ~STATE-IDX)]
	841	(cond
	842	~@(mapcat
	843	(fn [[id blk]]
	844	[`(== ~state-val-sym ~id)
	845	`(let [~@(concat (build-block-preamble local-map index state-sym blk)
	846	(build-block-body state-sym blk))
	847	~state-sym ~(build-new-state local-map index state-sym blk)]
	848	~(terminate-block (last blk) state-sym custom-terminators))])
	849	(:blocks machine)))))]
	850	(fn state-machine#
	851	([] (aset-all! (make-array ~state-arr-size)
	852	~FN-IDX state-machine#
	853	~STATE-IDX ~(:start-block machine)))
	854	([~state-sym]
	855	(let [ret-value# (try (loop []
	856	(let [result# (switch# ~state-sym)]
	857	(if (cljs.core/keyword-identical? result# :recur)
	858	(recur)
	859	result#)))
	860	(catch js/Object ex#
	861	(aset-all! ~state-sym ~CURRENT-EXCEPTION ex#)
	862	(cljs.core.async.impl.ioc-helpers/process-exception ~state-sym)
	863	:recur))]
	864	(if (cljs.core/keyword-identical? ret-value# :recur)
	865	(recur ~state-sym)
	866	ret-value#)))))))
	867
	868
	869	(def async-custom-terminators
	870	{'<! 'cljs.core.async.impl.ioc-helpers/take!
	871	'cljs.core.async/<! 'cljs.core.async.impl.ioc-helpers/take!
	872	'>! 'cljs.core.async.impl.ioc-helpers/put!
	873	'cljs.core.async/>! 'cljs.core.async.impl.ioc-helpers/put!
	874	'alts! 'cljs.core.async/ioc-alts!
	875	'cljs.core.async/alts! 'cljs.core.async/ioc-alts!
	876	:Return 'cljs.core.async.impl.ioc-helpers/return-chan})
	877
	878
	879	(defn state-machine [body num-user-params env user-transitions]
	880	(-> (parse-to-state-machine body env user-transitions)
	881	second
	882	(emit-state-machine num-user-params user-transitions)))

+43

-0

src/main/clojure/cljs/core/async/impl/protocols.cljs less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns cljs.core.async.impl.protocols)
	9
	10	(def ^:const MAX-QUEUE-SIZE 1024)
	11
	12	(defprotocol ReadPort
	13	(take! [port fn1-handler] "derefable val if taken, nil if take was enqueued"))
	14
	15	(defprotocol WritePort
	16	(put! [port val fn1-handler] "derefable boolean (false if already closed) if handled, nil if put was enqueued.
	17	Must throw on nil val."))
	18
	19	(defprotocol Channel
	20	(close! [chan])
	21	(closed? [chan]))
	22
	23	(defprotocol Handler
	24	(active? [h] "returns true if has callback. Must work w/o lock")
	25	(blockable? [h] "returns true if this handler may be blocked, otherwise it must not block")
	26	#_(lock-id [h] "a unique id for lock acquisition order, 0 if no lock")
	27	(commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock"))
	28
	29	(defprotocol Buffer
	30	(full? [b] "returns true if buffer cannot accept put")
	31	(remove! [b] "remove and return next item from buffer, called under chan mutex")
	32	(add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex")
	33	(close-buf! [b] "called on chan closed under chan mutex, return ignored"))
	34
	35	(defn add!
	36	([b] b)
	37	([b itm]
	38	(assert (not (nil? itm)))
	39	(add!* b itm)))
	40
	41	;; Defines a buffer that will never block (return true to full?)
	42	(defprotocol UnblockingBuffer)

+167

-0

src/main/clojure/cljs/core/async/impl/timers.cljs less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns cljs.core.async.impl.timers
	9	(:require [cljs.core.async.impl.protocols :as impl]
	10	[cljs.core.async.impl.channels :as channels]
	11	[cljs.core.async.impl.dispatch :as dispatch]))
	12
	13	(def MAX_LEVEL 15) ;; 16 levels
	14	(def P (/ 1 2))
	15
	16	(defn random-level
	17	([] (random-level 0))
	18	([level]
	19	(if (and (< (.random js/Math) P)
	20	(< level MAX_LEVEL))
	21	(recur (inc level))
	22	level)))
	23
	24	(deftype SkipListNode [key ^:mutable val forward]
	25	ISeqable
	26	(-seq [coll]
	27	(list key val))
	28
	29	IPrintWithWriter
	30	(-pr-writer [coll writer opts]
	31	(pr-sequential-writer writer pr-writer "[" " " "]" opts coll)))
	32
	33	(defn skip-list-node
	34	([level] (skip-list-node nil nil level))
	35	([k v level]
	36	(let [arr (make-array (inc level))]
	37	(loop [i 0]
	38	(when (< i (alength arr))
	39	(aset arr i nil)
	40	(recur (inc i))))
	41	(SkipListNode. k v arr))))
	42
	43	(defn least-greater-node
	44	([x k level] (least-greater-node x k level nil))
	45	([x k level update]
	46	(if-not (neg? level)
	47	(let [x (loop [x x]
	48	(if-let [x' (aget (.-forward x) level)]
	49	(if (< (.-key x') k)
	50	(recur x')
	51	x)
	52	x))]
	53	(when-not (nil? update)
	54	(aset update level x))
	55	(recur x k (dec level) update))
	56	x)))
	57
	58	(deftype SkipList [header ^:mutable level]
	59	Object
	60	(put [coll k v]
	61	(let [update (make-array MAX_LEVEL)
	62	x (least-greater-node header k level update)
	63	x (aget (.-forward x) 0)]
	64	(if (and (not (nil? x)) (== (.-key x) k))
	65	(set! (.-val x) v)
	66	(let [new-level (random-level)]
	67	(when (> new-level level)
	68	(loop [i (inc level)]
	69	(when (<= i (inc new-level))
	70	(aset update i header)
	71	(recur (inc i))))
	72	(set! level new-level))
	73	(let [x (skip-list-node k v (make-array new-level))]
	74	(loop [i 0]
	75	(when (<= i level)
	76	(let [links (.-forward (aget update i))]
	77	(aset (.-forward x) i (aget links i))
	78	(aset links i x)))))))))
	79
	80	(remove [coll k]
	81	(let [update (make-array MAX_LEVEL)
	82	x (least-greater-node header k level update)
	83	x (aget (.-forward x) 0)]
	84	(when (and (not (nil? x)) (== (.-key x) k))
	85	(loop [i 0]
	86	(when (<= i level)
	87	(let [links (.-forward (aget update i))]
	88	(if (identical? (aget links i) x)
	89	(do
	90	(aset links i (aget (.-forward x) i))
	91	(recur (inc i)))
	92	(recur (inc i))))))
	93	(while (and (> level 0)
	94	(nil? (aget (.-forward header) level)))
	95	(set! level (dec level))))))
	96
	97	(ceilingEntry [coll k]
	98	(loop [x header level level]
	99	(if-not (neg? level)
	100	(let [nx (loop [x x]
	101	(let [x' (aget (.-forward x) level)]
	102	(when-not (nil? x')
	103	(if (>= (.-key x') k)
	104	x'
	105	(recur x')))))]
	106	(if-not (nil? nx)
	107	(recur nx (dec level))
	108	(recur x (dec level))))
	109	(when-not (identical? x header)
	110	x))))
	111
	112	(floorEntry [coll k]
	113	(loop [x header level level]
	114	(if-not (neg? level)
	115	(let [nx (loop [x x]
	116	(let [x' (aget (.-forward x) level)]
	117	(if-not (nil? x')
	118	(if (> (.-key x') k)
	119	x
	120	(recur x'))
	121	(when (zero? level)
	122	x))))]
	123	(if nx
	124	(recur nx (dec level))
	125	(recur x (dec level))))
	126	(when-not (identical? x header)
	127	x))))
	128
	129	ISeqable
	130	(-seq [coll]
	131	(letfn [(iter [node]
	132	(lazy-seq
	133	(when-not (nil? node)
	134	(cons [(.-key node) (.-val node)]
	135	(iter (aget (.-forward node) 0))))))]
	136	(iter (aget (.-forward header) 0))))
	137
	138	IPrintWithWriter
	139	(-pr-writer [coll writer opts]
	140	(let [pr-pair (fn [keyval]
	141	(pr-sequential-writer writer pr-writer "" " " "" opts keyval))]
	142	(pr-sequential-writer writer pr-pair "{" ", " "}" opts coll))))
	143
	144	(defn skip-list []
	145	(SkipList. (skip-list-node 0) 0))
	146
	147	(def timeouts-map (skip-list))
	148
	149	(def TIMEOUT_RESOLUTION_MS 10)
	150
	151	(defn timeout
	152	"returns a channel that will close after msecs"
	153	[msecs]
	154	(let [timeout (+ (.valueOf (js/Date.)) msecs)
	155	me (.ceilingEntry timeouts-map timeout)]
	156	(or (when (and me (< (.-key me) (+ timeout TIMEOUT_RESOLUTION_MS)))
	157	(.-val me))
	158	(let [timeout-channel (channels/chan nil)]
	159	(.put timeouts-map timeout timeout-channel)
	160	(dispatch/queue-delay
	161	(fn []
	162	(.remove timeouts-map timeout)
	163	(impl/close! timeout-channel))
	164	msecs)
	165	timeout-channel))))
	166

+98

-0

src/main/clojure/cljs/core/async/macros.clj less more

	0	(ns cljs.core.async.macros
	1	(:require [cljs.core.async.impl.ioc-macros :as ioc]))
	2
	3	(defmacro go
	4	"Asynchronously executes the body, returning immediately to the
	5	calling thread. Additionally, any visible calls to <!, >! and alt!/alts!
	6	channel operations within the body will block (if necessary) by
	7	'parking' the calling thread rather than tying up an OS thread (or
	8	the only JS thread when in ClojureScript). Upon completion of the
	9	operation, the body will be resumed.
	10
	11	Returns a channel which will receive the result of the body when
	12	completed"
	13	[& body]
	14	`(let [c# (cljs.core.async/chan 1)]
	15	(cljs.core.async.impl.dispatch/run
	16	(fn []
	17	(let [f# ~(ioc/state-machine body 1 &env ioc/async-custom-terminators)
	18	state# (-> (f#)
	19	(ioc/aset-all! cljs.core.async.impl.ioc-helpers/USER-START-IDX c#))]
	20	(cljs.core.async.impl.ioc-helpers/run-state-machine-wrapped state#))))
	21	c#))
	22
	23
	24	(defn do-alt [alts clauses]
	25	(assert (even? (count clauses)) "unbalanced clauses")
	26	(let [clauses (partition 2 clauses)
	27	opt? #(keyword? (first %))
	28	opts (filter opt? clauses)
	29	clauses (remove opt? clauses)
	30	[clauses bindings]
	31	(reduce
	32	(fn [[clauses bindings] [ports expr]]
	33	(let [ports (if (vector? ports) ports [ports])
	34	[ports bindings]
	35	(reduce
	36	(fn [[ports bindings] port]
	37	(if (vector? port)
	38	(let [[port val] port
	39	gp (gensym)
	40	gv (gensym)]
	41	[(conj ports [gp gv]) (conj bindings [gp port] [gv val])])
	42	(let [gp (gensym)]
	43	[(conj ports gp) (conj bindings [gp port])])))
	44	[[] bindings] ports)]
	45	[(conj clauses [ports expr]) bindings]))
	46	[[] []] clauses)
	47	gch (gensym "ch")
	48	gret (gensym "ret")]
	49	`(let [~@(mapcat identity bindings)
	50	[val# ~gch :as ~gret] (~alts [~@(apply concat (map first clauses))] ~@(apply concat opts))]
	51	(cond
	52	~@(mapcat (fn [[ports expr]]
	53	[`(or ~@(map (fn [port]
	54	`(= ~gch ~(if (vector? port) (first port) port)))
	55	ports))
	56	(if (and (seq? expr) (vector? (first expr)))
	57	`(let [~(first expr) ~gret] ~@(rest expr))
	58	expr)])
	59	clauses)
	60	(= ~gch :default) val#))))
	61
	62	(defmacro alt!
	63	"Makes a single choice between one of several channel operations,
	64	as if by alts!, returning the value of the result expr corresponding
	65	to the operation completed. Must be called inside a (go ...) block.
	66
	67	Each clause takes the form of:
	68
	69	channel-op[s] result-expr
	70
	71	where channel-ops is one of:
	72
	73	take-port - a single port to take
	74	[take-port \| [put-port put-val] ...] - a vector of ports as per alts!
	75	:default \| :priority - an option for alts!
	76
	77	and result-expr is either a list beginning with a vector, whereupon that
	78	vector will be treated as a binding for the [val port] return of the
	79	operation, else any other expression.
	80
	81	(alt!
	82	[c t] ([val ch] (foo ch val))
	83	x ([v] v)
	84	[[out val]] :wrote
	85	:default 42)
	86
	87	Each option may appear at most once. The choice and parking
	88	characteristics are those of alts!."
	89
	90	[& clauses]
	91	(do-alt 'alts! clauses))
	92
	93
	94	(defmacro go-loop
	95	"Like (go (loop ...))"
	96	[bindings & body]
	97	`(go (loop ~bindings ~@body)))

+929

-0

src/main/clojure/cljs/core/async.cljs less more

	0	(ns cljs.core.async
	1	(:refer-clojure :exclude [reduce transduce into merge map take partition partition-by])
	2	(:require [cljs.core.async.impl.protocols :as impl]
	3	[cljs.core.async.impl.channels :as channels]
	4	[cljs.core.async.impl.buffers :as buffers]
	5	[cljs.core.async.impl.timers :as timers]
	6	[cljs.core.async.impl.dispatch :as dispatch]
	7	[cljs.core.async.impl.ioc-helpers :as helpers])
	8	(:require-macros [cljs.core.async.impl.ioc-macros :as ioc]
	9	[cljs.core.async.macros :refer [go go-loop]]))
	10
	11	(defn- fn-handler
	12	([f] (fn-handler f true))
	13	([f blockable]
	14	(reify
	15	impl/Handler
	16	(active? [_] true)
	17	(blockable? [_] blockable)
	18	(commit [_] f))))
	19
	20	(defn buffer
	21	"Returns a fixed buffer of size n. When full, puts will block/park."
	22	[n]
	23	(buffers/fixed-buffer n))
	24
	25	(defn dropping-buffer
	26	"Returns a buffer of size n. When full, puts will complete but
	27	val will be dropped (no transfer)."
	28	[n]
	29	(buffers/dropping-buffer n))
	30
	31	(defn sliding-buffer
	32	"Returns a buffer of size n. When full, puts will complete, and be
	33	buffered, but oldest elements in buffer will be dropped (not
	34	transferred)."
	35	[n]
	36	(buffers/sliding-buffer n))
	37
	38	(defn unblocking-buffer?
	39	"Returns true if a channel created with buff will never block. That is to say,
	40	puts into this buffer will never cause the buffer to be full. "
	41	[buff]
	42	(satisfies? impl/UnblockingBuffer buff))
	43
	44	(defn chan
	45	"Creates a channel with an optional buffer, an optional transducer (like (map f),
	46	(filter p) etc or a composition thereof), and an optional exception handler.
	47	If buf-or-n is a number, will create and use a fixed buffer of that size. If a
	48	transducer is supplied a buffer must be specified. ex-handler must be a
	49	fn of one argument - if an exception occurs during transformation it will be called
	50	with the thrown value as an argument, and any non-nil return value will be placed
	51	in the channel."
	52	([] (chan nil))
	53	([buf-or-n] (chan buf-or-n nil nil))
	54	([buf-or-n xform] (chan buf-or-n xform nil))
	55	([buf-or-n xform ex-handler]
	56	(let [buf-or-n (if (= buf-or-n 0)
	57	nil
	58	buf-or-n)]
	59	(when xform (assert buf-or-n "buffer must be supplied when transducer is"))
	60	(channels/chan (if (number? buf-or-n)
	61	(buffer buf-or-n)
	62	buf-or-n)
	63	xform
	64	ex-handler))))
	65
	66	(defn promise-chan
	67	"Creates a promise channel with an optional transducer, and an optional
	68	exception-handler. A promise channel can take exactly one value that consumers
	69	will receive. Once full, puts complete but val is dropped (no transfer).
	70	Consumers will block until either a value is placed in the channel or the
	71	channel is closed. See chan for the semantics of xform and ex-handler."
	72	([] (promise-chan nil))
	73	([xform] (promise-chan xform nil))
	74	([xform ex-handler]
	75	(chan (buffers/promise-buffer) xform ex-handler)))
	76
	77	(defn timeout
	78	"Returns a channel that will close after msecs"
	79	[msecs]
	80	(timers/timeout msecs))
	81
	82	(defn <!
	83	"takes a val from port. Must be called inside a (go ...) block. Will
	84	return nil if closed. Will park if nothing is available.
	85	Returns true unless port is already closed"
	86	[port]
	87	(throw (js/Error. "<! used not in (go ...) block")))
	88
	89	(defn take!
	90	"Asynchronously takes a val from port, passing to fn1. Will pass nil
	91	if closed. If on-caller? (default true) is true, and value is
	92	immediately available, will call fn1 on calling thread.
	93	Returns nil."
	94	([port fn1] (take! port fn1 true))
	95	([port fn1 on-caller?]
	96	(let [ret (impl/take! port (fn-handler fn1))]
	97	(when ret
	98	(let [val @ret]
	99	(if on-caller?
	100	(fn1 val)
	101	(dispatch/run #(fn1 val)))))
	102	nil)))
	103
	104	(defn- nop [_])
	105	(def ^:private fhnop (fn-handler nop))
	106
	107	(defn >!
	108	"puts a val into port. nil values are not allowed. Must be called
	109	inside a (go ...) block. Will park if no buffer space is available.
	110	Returns true unless port is already closed."
	111	[port val]
	112	(throw (js/Error. ">! used not in (go ...) block")))
	113
	114	(defn put!
	115	"Asynchronously puts a val into port, calling fn0 (if supplied) when
	116	complete. nil values are not allowed. Will throw if closed. If
	117	on-caller? (default true) is true, and the put is immediately
	118	accepted, will call fn0 on calling thread. Returns nil."
	119	([port val]
	120	(if-let [ret (impl/put! port val fhnop)]
	121	@ret
	122	true))
	123	([port val fn1] (put! port val fn1 true))
	124	([port val fn1 on-caller?]
	125	(if-let [retb (impl/put! port val (fn-handler fn1))]
	126	(let [ret @retb]
	127	(if on-caller?
	128	(fn1 ret)
	129	(dispatch/run #(fn1 ret)))
	130	ret)
	131	true)))
	132
	133	(defn close!
	134	([port]
	135	(impl/close! port)))
	136
	137
	138	(defn- random-array
	139	[n]
	140	(let [a (make-array n)]
	141	(dotimes [x n]
	142	(aset a x 0))
	143	(loop [i 1]
	144	(if (= i n)
	145	a
	146	(do
	147	(let [j (rand-int i)]
	148	(aset a i (aget a j))
	149	(aset a j i)
	150	(recur (inc i))))))))
	151
	152	(defn- alt-flag []
	153	(let [flag (atom true)]
	154	(reify
	155	impl/Handler
	156	(active? [_] @flag)
	157	(blockable? [_] true)
	158	(commit [_]
	159	(reset! flag nil)
	160	true))))
	161
	162	(defn- alt-handler [flag cb]
	163	(reify
	164	impl/Handler
	165	(active? [_] (impl/active? flag))
	166	(blockable? [_] true)
	167	(commit [_]
	168	(impl/commit flag)
	169	cb)))
	170
	171	(defn do-alts
	172	"returns derefable [val port] if immediate, nil if enqueued"
	173	[fret ports opts]
	174	(let [flag (alt-flag)
	175	n (count ports)
	176	idxs (random-array n)
	177	priority (:priority opts)
	178	ret
	179	(loop [i 0]
	180	(when (< i n)
	181	(let [idx (if priority i (aget idxs i))
	182	port (nth ports idx)
	183	wport (when (vector? port) (port 0))
	184	vbox (if wport
	185	(let [val (port 1)]
	186	(impl/put! wport val (alt-handler flag #(fret [% wport]))))
	187	(impl/take! port (alt-handler flag #(fret [% port]))))]
	188	(if vbox
	189	(channels/box [@vbox (or wport port)])
	190	(recur (inc i))))))]
	191	(or
	192	ret
	193	(when (contains? opts :default)
	194	(when-let [got (and (impl/active? flag) (impl/commit flag))]
	195	(channels/box [(:default opts) :default]))))))
	196
	197	(defn alts!
	198	"Completes at most one of several channel operations. Must be called
	199	inside a (go ...) block. ports is a vector of channel endpoints,
	200	which can be either a channel to take from or a vector of
	201	[channel-to-put-to val-to-put], in any combination. Takes will be
	202	made as if by <!, and puts will be made as if by >!. Unless
	203	the :priority option is true, if more than one port operation is
	204	ready a non-deterministic choice will be made. If no operation is
	205	ready and a :default value is supplied, [default-val :default] will
	206	be returned, otherwise alts! will park until the first operation to
	207	become ready completes. Returns [val port] of the completed
	208	operation, where val is the value taken for takes, and a
	209	boolean (true unless already closed, as per put!) for puts.
	210
	211	opts are passed as :key val ... Supported options:
	212
	213	:default val - the value to use if none of the operations are immediately ready
	214	:priority true - (default nil) when true, the operations will be tried in order.
	215
	216	Note: there is no guarantee that the port exps or val exprs will be
	217	used, nor in what order should they be, so they should not be
	218	depended upon for side effects."
	219
	220	[ports & {:as opts}]
	221	(throw (js/Error. "alts! used not in (go ...) block")))
	222
	223	(defn offer!
	224	"Puts a val into port if it's possible to do so immediately.
	225	nil values are not allowed. Never blocks. Returns true if offer succeeds."
	226	[port val]
	227	(let [ret (impl/put! port val (fn-handler nop false))]
	228	(when ret @ret)))
	229
	230	(defn poll!
	231	"Takes a val from port if it's possible to do so immediately.
	232	Never blocks. Returns value if successful, nil otherwise."
	233	[port]
	234	(let [ret (impl/take! port (fn-handler nop false))]
	235	(when ret @ret)))
	236
	237	;;;;;;; channel ops
	238
	239	(defn pipe
	240	"Takes elements from the from channel and supplies them to the to
	241	channel. By default, the to channel will be closed when the from
	242	channel closes, but can be determined by the close? parameter. Will
	243	stop consuming the from channel if the to channel closes"
	244
	245	([from to] (pipe from to true))
	246	([from to close?]
	247	(go-loop []
	248	(let [v (<! from)]
	249	(if (nil? v)
	250	(when close? (close! to))
	251	(when (>! to v)
	252	(recur)))))
	253	to))
	254
	255	(defn- pipeline*
	256	([n to xf from close? ex-handler type]
	257	(assert (pos? n))
	258	(let [jobs (chan n)
	259	results (chan n)
	260	process (fn [[v p :as job]]
	261	(if (nil? job)
	262	(do (close! results) nil)
	263	(let [res (chan 1 xf ex-handler)]
	264	(go
	265	(>! res v)
	266	(close! res))
	267	(put! p res)
	268	true)))
	269	async (fn [[v p :as job]]
	270	(if (nil? job)
	271	(do (close! results) nil)
	272	(let [res (chan 1)]
	273	(xf v res)
	274	(put! p res)
	275	true)))]
	276	(dotimes [_ n]
	277	(case type
	278	:compute (go-loop []
	279	(let [job (<! jobs)]
	280	(when (process job)
	281	(recur))))
	282	:async (go-loop []
	283	(let [job (<! jobs)]
	284	(when (async job)
	285	(recur))))))
	286	(go-loop []
	287	(let [v (<! from)]
	288	(if (nil? v)
	289	(close! jobs)
	290	(let [p (chan 1)]
	291	(>! jobs [v p])
	292	(>! results p)
	293	(recur)))))
	294	(go-loop []
	295	(let [p (<! results)]
	296	(if (nil? p)
	297	(when close? (close! to))
	298	(let [res (<! p)]
	299	(loop []
	300	(let [v (<! res)]
	301	(when (and (not (nil? v)) (>! to v))
	302	(recur))))
	303	(recur))))))))
	304
	305	(defn pipeline-async
	306	"Takes elements from the from channel and supplies them to the to
	307	channel, subject to the async function af, with parallelism n. af
	308	must be a function of two arguments, the first an input value and
	309	the second a channel on which to place the result(s). af must close!
	310	the channel before returning. The presumption is that af will
	311	return immediately, having launched some asynchronous operation
	312	whose completion/callback will manipulate the result channel. Outputs
	313	will be returned in order relative to the inputs. By default, the to
	314	channel will be closed when the from channel closes, but can be
	315	determined by the close? parameter. Will stop consuming the from
	316	channel if the to channel closes."
	317	([n to af from] (pipeline-async n to af from true))
	318	([n to af from close?] (pipeline* n to af from close? nil :async)))
	319
	320	(defn pipeline
	321	"Takes elements from the from channel and supplies them to the to
	322	channel, subject to the transducer xf, with parallelism n. Because
	323	it is parallel, the transducer will be applied independently to each
	324	element, not across elements, and may produce zero or more outputs
	325	per input. Outputs will be returned in order relative to the
	326	inputs. By default, the to channel will be closed when the from
	327	channel closes, but can be determined by the close? parameter. Will
	328	stop consuming the from channel if the to channel closes.
	329
	330	Note this is supplied for API compatibility with the Clojure version.
	331	Values of N > 1 will not result in actual concurrency in a
	332	single-threaded runtime."
	333	([n to xf from] (pipeline n to xf from true))
	334	([n to xf from close?] (pipeline n to xf from close? nil))
	335	([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute)))
	336
	337	(defn split
	338	"Takes a predicate and a source channel and returns a vector of two
	339	channels, the first of which will contain the values for which the
	340	predicate returned true, the second those for which it returned
	341	false.
	342
	343	The out channels will be unbuffered by default, or two buf-or-ns can
	344	be supplied. The channels will close after the source channel has
	345	closed."
	346	([p ch] (split p ch nil nil))
	347	([p ch t-buf-or-n f-buf-or-n]
	348	(let [tc (chan t-buf-or-n)
	349	fc (chan f-buf-or-n)]
	350	(go-loop []
	351	(let [v (<! ch)]
	352	(if (nil? v)
	353	(do (close! tc) (close! fc))
	354	(when (>! (if (p v) tc fc) v)
	355	(recur)))))
	356	[tc fc])))
	357
	358	(defn reduce
	359	"f should be a function of 2 arguments. Returns a channel containing
	360	the single result of applying f to init and the first item from the
	361	channel, then applying f to that result and the 2nd item, etc. If
	362	the channel closes without yielding items, returns init and f is not
	363	called. ch must close before reduce produces a result."
	364	[f init ch]
	365	(go-loop [ret init]
	366	(let [v (<! ch)]
	367	(if (nil? v)
	368	ret
	369	(let [ret' (f ret v)]
	370	(if (reduced? ret')
	371	@ret'
	372	(recur ret')))))))
	373
	374	(defn transduce
	375	"async/reduces a channel with a transformation (xform f).
	376	Returns a channel containing the result. ch must close before
	377	transduce produces a result."
	378	[xform f init ch]
	379	(let [f (xform f)]
	380	(go
	381	(let [ret (<! (reduce f init ch))]
	382	(f ret)))))
	383
	384	(defn onto-chan
	385	"Puts the contents of coll into the supplied channel.
	386
	387	By default the channel will be closed after the items are copied,
	388	but can be determined by the close? parameter.
	389
	390	Returns a channel which will close after the items are copied."
	391	([ch coll] (onto-chan ch coll true))
	392	([ch coll close?]
	393	(go-loop [vs (seq coll)]
	394	(if (and vs (>! ch (first vs)))
	395	(recur (next vs))
	396	(when close?
	397	(close! ch))))))
	398
	399
	400	(defn to-chan
	401	"Creates and returns a channel which contains the contents of coll,
	402	closing when exhausted."
	403	[coll]
	404	(let [ch (chan (bounded-count 100 coll))]
	405	(onto-chan ch coll)
	406	ch))
	407
	408
	409	(defprotocol Mux
	410	(muxch* [_]))
	411
	412	(defprotocol Mult
	413	(tap* [m ch close?])
	414	(untap* [m ch])
	415	(untap-all* [m]))
	416
	417	(defn mult
	418	"Creates and returns a mult(iple) of the supplied channel. Channels
	419	containing copies of the channel can be created with 'tap', and
	420	detached with 'untap'.
	421
	422	Each item is distributed to all taps in parallel and synchronously,
	423	i.e. each tap must accept before the next item is distributed. Use
	424	buffering/windowing to prevent slow taps from holding up the mult.
	425
	426	Items received when there are no taps get dropped.
	427
	428	If a tap puts to a closed channel, it will be removed from the mult."
	429	[ch]
	430	(let [cs (atom {}) ;;ch->close?
	431	m (reify
	432	Mux
	433	(muxch* [_] ch)
	434
	435	Mult
	436	(tap* [_ ch close?] (swap! cs assoc ch close?) nil)
	437	(untap* [_ ch] (swap! cs dissoc ch) nil)
	438	(untap-all* [_] (reset! cs {}) nil))
	439	dchan (chan 1)
	440	dctr (atom nil)
	441	done (fn [_] (when (zero? (swap! dctr dec))
	442	(put! dchan true)))]
	443	(go-loop []
	444	(let [val (<! ch)]
	445	(if (nil? val)
	446	(doseq [[c close?] @cs]
	447	(when close? (close! c)))
	448	(let [chs (keys @cs)]
	449	(reset! dctr (count chs))
	450	(doseq [c chs]
	451	(when-not (put! c val done)
	452	(done nil)
	453	(untap* m c)))
	454	;;wait for all
	455	(when (seq chs)
	456	(<! dchan))
	457	(recur)))))
	458	m))
	459
	460	(defn tap
	461	"Copies the mult source onto the supplied channel.
	462
	463	By default the channel will be closed when the source closes,
	464	but can be determined by the close? parameter."
	465	([mult ch] (tap mult ch true))
	466	([mult ch close?] (tap* mult ch close?) ch))
	467
	468	(defn untap
	469	"Disconnects a target channel from a mult"
	470	[mult ch]
	471	(untap* mult ch))
	472
	473	(defn untap-all
	474	"Disconnects all target channels from a mult"
	475	[mult] (untap-all* mult))
	476
	477	(defprotocol Mix
	478	(admix* [m ch])
	479	(unmix* [m ch])
	480	(unmix-all* [m])
	481	(toggle* [m state-map])
	482	(solo-mode* [m mode]))
	483
	484	(defn ioc-alts! [state cont-block ports & {:as opts}]
	485	(ioc/aset-all! state helpers/STATE-IDX cont-block)
	486	(when-let [cb (cljs.core.async/do-alts
	487	(fn [val]
	488	(ioc/aset-all! state helpers/VALUE-IDX val)
	489	(helpers/run-state-machine-wrapped state))
	490	ports
	491	opts)]
	492	(ioc/aset-all! state helpers/VALUE-IDX @cb)
	493	:recur))
	494
	495	(defn mix
	496	"Creates and returns a mix of one or more input channels which will
	497	be put on the supplied out channel. Input sources can be added to
	498	the mix with 'admix', and removed with 'unmix'. A mix supports
	499	soloing, muting and pausing multiple inputs atomically using
	500	'toggle', and can solo using either muting or pausing as determined
	501	by 'solo-mode'.
	502
	503	Each channel can have zero or more boolean modes set via 'toggle':
	504
	505	:solo - when true, only this (ond other soloed) channel(s) will appear
	506	in the mix output channel. :mute and :pause states of soloed
	507	channels are ignored. If solo-mode is :mute, non-soloed
	508	channels are muted, if :pause, non-soloed channels are
	509	paused.
	510
	511	:mute - muted channels will have their contents consumed but not included in the mix
	512	:pause - paused channels will not have their contents consumed (and thus also not included in the mix)
	513	"
	514	[out]
	515	(let [cs (atom {}) ;;ch->attrs-map
	516	solo-modes #{:mute :pause}
	517	attrs (conj solo-modes :solo)
	518	solo-mode (atom :mute)
	519	change (chan)
	520	changed #(put! change true)
	521	pick (fn [attr chs]
	522	(reduce-kv
	523	(fn [ret c v]
	524	(if (attr v)
	525	(conj ret c)
	526	ret))
	527	#{} chs))
	528	calc-state (fn []
	529	(let [chs @cs
	530	mode @solo-mode
	531	solos (pick :solo chs)
	532	pauses (pick :pause chs)]
	533	{:solos solos
	534	:mutes (pick :mute chs)
	535	:reads (conj
	536	(if (and (= mode :pause) (not (empty? solos)))
	537	(vec solos)
	538	(vec (remove pauses (keys chs))))
	539	change)}))
	540	m (reify
	541	Mux
	542	(muxch* [_] out)
	543	Mix
	544	(admix* [_ ch] (swap! cs assoc ch {}) (changed))
	545	(unmix* [_ ch] (swap! cs dissoc ch) (changed))
	546	(unmix-all* [_] (reset! cs {}) (changed))
	547	(toggle* [_ state-map] (swap! cs (partial merge-with cljs.core/merge) state-map) (changed))
	548	(solo-mode* [_ mode]
	549	(assert (solo-modes mode) (str "mode must be one of: " solo-modes))
	550	(reset! solo-mode mode)
	551	(changed)))]
	552	(go-loop [{:keys [solos mutes reads] :as state} (calc-state)]
	553	(let [[v c] (alts! reads)]
	554	(if (or (nil? v) (= c change))
	555	(do (when (nil? v)
	556	(swap! cs dissoc c))
	557	(recur (calc-state)))
	558	(if (or (solos c)
	559	(and (empty? solos) (not (mutes c))))
	560	(when (>! out v)
	561	(recur state))
	562	(recur state)))))
	563	m))
	564
	565	(defn admix
	566	"Adds ch as an input to the mix"
	567	[mix ch]
	568	(admix* mix ch))
	569
	570	(defn unmix
	571	"Removes ch as an input to the mix"
	572	[mix ch]
	573	(unmix* mix ch))
	574
	575	(defn unmix-all
	576	"removes all inputs from the mix"
	577	[mix]
	578	(unmix-all* mix))
	579
	580	(defn toggle
	581	"Atomically sets the state(s) of one or more channels in a mix. The
	582	state map is a map of channels -> channel-state-map. A
	583	channel-state-map is a map of attrs -> boolean, where attr is one or
	584	more of :mute, :pause or :solo. Any states supplied are merged with
	585	the current state.
	586
	587	Note that channels can be added to a mix via toggle, which can be
	588	used to add channels in a particular (e.g. paused) state."
	589	[mix state-map]
	590	(toggle* mix state-map))
	591
	592	(defn solo-mode
	593	"Sets the solo mode of the mix. mode must be one of :mute or :pause"
	594	[mix mode]
	595	(solo-mode* mix mode))
	596
	597
	598	(defprotocol Pub
	599	(sub* [p v ch close?])
	600	(unsub* [p v ch])
	601	(unsub-all* [p] [p v]))
	602
	603	(defn pub
	604	"Creates and returns a pub(lication) of the supplied channel,
	605	partitioned into topics by the topic-fn. topic-fn will be applied to
	606	each value on the channel and the result will determine the 'topic'
	607	on which that value will be put. Channels can be subscribed to
	608	receive copies of topics using 'sub', and unsubscribed using
	609	'unsub'. Each topic will be handled by an internal mult on a
	610	dedicated channel. By default these internal channels are
	611	unbuffered, but a buf-fn can be supplied which, given a topic,
	612	creates a buffer with desired properties.
	613
	614	Each item is distributed to all subs in parallel and synchronously,
	615	i.e. each sub must accept before the next item is distributed. Use
	616	buffering/windowing to prevent slow subs from holding up the pub.
	617
	618	Items received when there are no matching subs get dropped.
	619
	620	Note that if buf-fns are used then each topic is handled
	621	asynchronously, i.e. if a channel is subscribed to more than one
	622	topic it should not expect them to be interleaved identically with
	623	the source."
	624	([ch topic-fn] (pub ch topic-fn (constantly nil)))
	625	([ch topic-fn buf-fn]
	626	(let [mults (atom {}) ;;topic->mult
	627	ensure-mult (fn [topic]
	628	(or (get @mults topic)
	629	(get (swap! mults
	630	#(if (% topic) % (assoc % topic (mult (chan (buf-fn topic))))))
	631	topic)))
	632	p (reify
	633	Mux
	634	(muxch* [_] ch)
	635
	636	Pub
	637	(sub* [p topic ch close?]
	638	(let [m (ensure-mult topic)]
	639	(tap m ch close?)))
	640	(unsub* [p topic ch]
	641	(when-let [m (get @mults topic)]
	642	(untap m ch)))
	643	(unsub-all* [_] (reset! mults {}))
	644	(unsub-all* [_ topic] (swap! mults dissoc topic)))]
	645	(go-loop []
	646	(let [val (<! ch)]
	647	(if (nil? val)
	648	(doseq [m (vals @mults)]
	649	(close! (muxch* m)))
	650	(let [topic (topic-fn val)
	651	m (get @mults topic)]
	652	(when m
	653	(when-not (>! (muxch* m) val)
	654	(swap! mults dissoc topic)))
	655	(recur)))))
	656	p)))
	657
	658	(defn sub
	659	"Subscribes a channel to a topic of a pub.
	660
	661	By default the channel will be closed when the source closes,
	662	but can be determined by the close? parameter."
	663	([p topic ch] (sub p topic ch true))
	664	([p topic ch close?] (sub* p topic ch close?)))
	665
	666	(defn unsub
	667	"Unsubscribes a channel from a topic of a pub"
	668	[p topic ch]
	669	(unsub* p topic ch))
	670
	671	(defn unsub-all
	672	"Unsubscribes all channels from a pub, or a topic of a pub"
	673	([p] (unsub-all* p))
	674	([p topic] (unsub-all* p topic)))
	675
	676
	677	;;;;
	678
	679	(defn map
	680	"Takes a function and a collection of source channels, and returns a
	681	channel which contains the values produced by applying f to the set
	682	of first items taken from each source channel, followed by applying
	683	f to the set of second items from each channel, until any one of the
	684	channels is closed, at which point the output channel will be
	685	closed. The returned channel will be unbuffered by default, or a
	686	buf-or-n can be supplied"
	687	([f chs] (map f chs nil))
	688	([f chs buf-or-n]
	689	(let [chs (vec chs)
	690	out (chan buf-or-n)
	691	cnt (count chs)
	692	rets (object-array cnt)
	693	dchan (chan 1)
	694	dctr (atom nil)
	695	done (mapv (fn [i]
	696	(fn [ret]
	697	(aset rets i ret)
	698	(when (zero? (swap! dctr dec))
	699	(put! dchan (.slice rets 0)))))
	700	(range cnt))]
	701	(go-loop []
	702	(reset! dctr cnt)
	703	(dotimes [i cnt]
	704	(try
	705	(take! (chs i) (done i))
	706	(catch js/Object e
	707	(swap! dctr dec))))
	708	(let [rets (<! dchan)]
	709	(if (some nil? rets)
	710	(close! out)
	711	(do (>! out (apply f rets))
	712	(recur)))))
	713	out)))
	714
	715	(defn merge
	716	"Takes a collection of source channels and returns a channel which
	717	contains all values taken from them. The returned channel will be
	718	unbuffered by default, or a buf-or-n can be supplied. The channel
	719	will close after all the source channels have closed."
	720	([chs] (merge chs nil))
	721	([chs buf-or-n]
	722	(let [out (chan buf-or-n)]
	723	(go-loop [cs (vec chs)]
	724	(if (pos? (count cs))
	725	(let [[v c] (alts! cs)]
	726	(if (nil? v)
	727	(recur (filterv #(not= c %) cs))
	728	(do (>! out v)
	729	(recur cs))))
	730	(close! out)))
	731	out)))
	732
	733	(defn into
	734	"Returns a channel containing the single (collection) result of the
	735	items taken from the channel conjoined to the supplied
	736	collection. ch must close before into produces a result."
	737	[coll ch]
	738	(reduce conj coll ch))
	739
	740	(defn take
	741	"Returns a channel that will return, at most, n items from ch. After n items
	742	have been returned, or ch has been closed, the return chanel will close.
	743
	744	The output channel is unbuffered by default, unless buf-or-n is given."
	745	([n ch]
	746	(take n ch nil))
	747	([n ch buf-or-n]
	748	(let [out (chan buf-or-n)]
	749	(go (loop [x 0]
	750	(when (< x n)
	751	(let [v (<! ch)]
	752	(when (not (nil? v))
	753	(>! out v)
	754	(recur (inc x))))))
	755	(close! out))
	756	out)))
	757
	758	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;;
	759
	760	(defn map<
	761	"Deprecated - this function will be removed. Use transducer instead"
	762	[f ch]
	763	(reify
	764	impl/Channel
	765	(close! [_] (impl/close! ch))
	766	(closed? [_] (impl/closed? ch))
	767
	768	impl/ReadPort
	769	(take! [_ fn1]
	770	(let [ret
	771	(impl/take! ch
	772	(reify
	773	impl/Handler
	774	(active? [_] (impl/active? fn1))
	775	(blockable? [_] true)
	776	#_(lock-id [_] (impl/lock-id fn1))
	777	(commit [_]
	778	(let [f1 (impl/commit fn1)]
	779	#(f1 (if (nil? %) nil (f %)))))))]
	780	(if (and ret (not (nil? @ret)))
	781	(channels/box (f @ret))
	782	ret)))
	783
	784	impl/WritePort
	785	(put! [_ val fn1] (impl/put! ch val fn1))))
	786
	787	(defn map>
	788	"Deprecated - this function will be removed. Use transducer instead"
	789	[f ch]
	790	(reify
	791	impl/Channel
	792	(close! [_] (impl/close! ch))
	793
	794	impl/ReadPort
	795	(take! [_ fn1] (impl/take! ch fn1))
	796
	797	impl/WritePort
	798	(put! [_ val fn1]
	799	(impl/put! ch (f val) fn1))))
	800
	801	(defn filter>
	802	"Deprecated - this function will be removed. Use transducer instead"
	803	[p ch]
	804	(reify
	805	impl/Channel
	806	(close! [_] (impl/close! ch))
	807	(closed? [_] (impl/closed? ch))
	808
	809	impl/ReadPort
	810	(take! [_ fn1] (impl/take! ch fn1))
	811
	812	impl/WritePort
	813	(put! [_ val fn1]
	814	(if (p val)
	815	(impl/put! ch val fn1)
	816	(channels/box (not (impl/closed? ch)))))))
	817
	818	(defn remove>
	819	"Deprecated - this function will be removed. Use transducer instead"
	820	[p ch]
	821	(filter> (complement p) ch))
	822
	823	(defn filter<
	824	"Deprecated - this function will be removed. Use transducer instead"
	825	([p ch] (filter< p ch nil))
	826	([p ch buf-or-n]
	827	(let [out (chan buf-or-n)]
	828	(go-loop []
	829	(let [val (<! ch)]
	830	(if (nil? val)
	831	(close! out)
	832	(do (when (p val)
	833	(>! out val))
	834	(recur)))))
	835	out)))
	836
	837	(defn remove<
	838	"Deprecated - this function will be removed. Use transducer instead"
	839	([p ch] (remove< p ch nil))
	840	([p ch buf-or-n] (filter< (complement p) ch buf-or-n)))
	841
	842	(defn- mapcat* [f in out]
	843	(go-loop []
	844	(let [val (<! in)]
	845	(if (nil? val)
	846	(close! out)
	847	(do (doseq [v (f val)]
	848	(>! out v))
	849	(when-not (impl/closed? out)
	850	(recur)))))))
	851
	852	(defn mapcat<
	853	"Deprecated - this function will be removed. Use transducer instead"
	854	([f in] (mapcat< f in nil))
	855	([f in buf-or-n]
	856	(let [out (chan buf-or-n)]
	857	(mapcat* f in out)
	858	out)))
	859
	860	(defn mapcat>
	861	"Deprecated - this function will be removed. Use transducer instead"
	862	([f out] (mapcat> f out nil))
	863	([f out buf-or-n]
	864	(let [in (chan buf-or-n)]
	865	(mapcat* f in out)
	866	in)))
	867
	868	(defn unique
	869	"Deprecated - this function will be removed. Use transducer instead"
	870	([ch]
	871	(unique ch nil))
	872	([ch buf-or-n]
	873	(let [out (chan buf-or-n)]
	874	(go (loop [last nil]
	875	(let [v (<! ch)]
	876	(when (not (nil? v))
	877	(if (= v last)
	878	(recur last)
	879	(do (>! out v)
	880	(recur v))))))
	881	(close! out))
	882	out)))
	883
	884	(defn partition
	885	"Deprecated - this function will be removed. Use transducer instead"
	886	([n ch]
	887	(partition n ch nil))
	888	([n ch buf-or-n]
	889	(let [out (chan buf-or-n)]
	890	(go (loop [arr (make-array n)
	891	idx 0]
	892	(let [v (<! ch)]
	893	(if (not (nil? v))
	894	(do (aset ^objects arr idx v)
	895	(let [new-idx (inc idx)]
	896	(if (< new-idx n)
	897	(recur arr new-idx)
	898	(do (>! out (vec arr))
	899	(recur (make-array n) 0)))))
	900	(do (when (> idx 0)
	901	(>! out (vec arr)))
	902	(close! out))))))
	903	out)))
	904
	905
	906	(defn partition-by
	907	"Deprecated - this function will be removed. Use transducer instead"
	908	([f ch]
	909	(partition-by f ch nil))
	910	([f ch buf-or-n]
	911	(let [out (chan buf-or-n)]
	912	(go (loop [lst (make-array 0)
	913	last ::nothing]
	914	(let [v (<! ch)]
	915	(if (not (nil? v))
	916	(let [new-itm (f v)]
	917	(if (or (= new-itm last)
	918	(keyword-identical? last ::nothing))
	919	(do (.push lst v)
	920	(recur lst new-itm))
	921	(do (>! out (vec lst))
	922	(let [new-lst (make-array 0)]
	923	(.push new-lst v)
	924	(recur new-lst new-itm)))))
	925	(do (when (> (alength lst) 0)
	926	(>! out (vec lst)))
	927	(close! out))))))
	928	out)))

+96

-0

src/main/clojure/clojure/core/async/impl/buffers.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.buffers
	10	(:require [clojure.core.async.impl.protocols :as impl])
	11	(:import [java.util LinkedList Queue]))
	12
	13	(set! warn-on-reflection true)
	14
	15	(deftype FixedBuffer [^LinkedList buf ^long n]
	16	impl/Buffer
	17	(full? [this]
	18	(>= (.size buf) n))
	19	(remove! [this]
	20	(.removeLast buf))
	21	(add!* [this itm]
	22	(.addFirst buf itm)
	23	this)
	24	(close-buf! [this])
	25	clojure.lang.Counted
	26	(count [this]
	27	(.size buf)))
	28
	29	(defn fixed-buffer [^long n]
	30	(FixedBuffer. (LinkedList.) n))
	31
	32
	33	(deftype DroppingBuffer [^LinkedList buf ^long n]
	34	impl/UnblockingBuffer
	35	impl/Buffer
	36	(full? [this]
	37	false)
	38	(remove! [this]
	39	(.removeLast buf))
	40	(add!* [this itm]
	41	(when-not (>= (.size buf) n)
	42	(.addFirst buf itm))
	43	this)
	44	(close-buf! [this])
	45	clojure.lang.Counted
	46	(count [this]
	47	(.size buf)))
	48
	49	(defn dropping-buffer [n]
	50	(DroppingBuffer. (LinkedList.) n))
	51
	52	(deftype SlidingBuffer [^LinkedList buf ^long n]
	53	impl/UnblockingBuffer
	54	impl/Buffer
	55	(full? [this]
	56	false)
	57	(remove! [this]
	58	(.removeLast buf))
	59	(add!* [this itm]
	60	(when (= (.size buf) n)
	61	(impl/remove! this))
	62	(.addFirst buf itm)
	63	this)
	64	(close-buf! [this])
	65	clojure.lang.Counted
	66	(count [this]
	67	(.size buf)))
	68
	69	(defn sliding-buffer [n]
	70	(SlidingBuffer. (LinkedList.) n))
	71
	72	(defonce ^:private NO-VAL (Object.))
	73	(defn- undelivered? [val]
	74	(identical? NO-VAL val))
	75
	76	(deftype PromiseBuffer [^:unsynchronized-mutable val]
	77	impl/UnblockingBuffer
	78	impl/Buffer
	79	(full? [_]
	80	false)
	81	(remove! [_]
	82	val)
	83	(add!* [this itm]
	84	(when (undelivered? val)
	85	(set! val itm))
	86	this)
	87	(close-buf! [_]
	88	(when (undelivered? val)
	89	(set! val nil)))
	90	clojure.lang.Counted
	91	(count [_]
	92	(if (undelivered? val) 0 1)))
	93
	94	(defn promise-buffer []
	95	(PromiseBuffer. NO-VAL))⏎

+303

-0

src/main/clojure/clojure/core/async/impl/channels.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.channels
	10	(:require [clojure.core.async.impl.protocols :as impl]
	11	[clojure.core.async.impl.dispatch :as dispatch]
	12	[clojure.core.async.impl.mutex :as mutex])
	13	(:import [java.util LinkedList Queue Iterator]
	14	[java.util.concurrent.locks Lock]))
	15
	16	(set! warn-on-reflection true)
	17
	18	(defmacro assert-unlock [lock test msg]
	19	`(when-not ~test
	20	(.unlock ~lock)
	21	(throw (new AssertionError (str "Assert failed: " ~msg "\n" (pr-str '~test))))))
	22
	23	(defn box [val]
	24	(reify clojure.lang.IDeref
	25	(deref [_] val)))
	26
	27	(defprotocol MMC
	28	(cleanup [_])
	29	(abort [_]))
	30
	31	(deftype ManyToManyChannel [^LinkedList takes ^LinkedList puts ^Queue buf closed ^Lock mutex add!]
	32	MMC
	33	(cleanup
	34	[_]
	35	(when-not (.isEmpty takes)
	36	(let [iter (.iterator takes)]
	37	(loop [taker (.next iter)]
	38	(when-not (impl/active? taker)
	39	(.remove iter))
	40	(when (.hasNext iter)
	41	(recur (.next iter))))))
	42	(when-not (.isEmpty puts)
	43	(let [iter (.iterator puts)]
	44	(loop [[putter] (.next iter)]
	45	(when-not (impl/active? putter)
	46	(.remove iter))
	47	(when (.hasNext iter)
	48	(recur (.next iter)))))))
	49
	50	(abort
	51	[this]
	52	(let [iter (.iterator puts)]
	53	(when (.hasNext iter)
	54	(loop [^Lock putter (.next iter)]
	55	(.lock putter)
	56	(let [put-cb (and (impl/active? putter) (impl/commit putter))]
	57	(.unlock putter)
	58	(when put-cb
	59	(dispatch/run (fn [] (put-cb true))))
	60	(when (.hasNext iter)
	61	(recur (.next iter)))))))
	62	(.clear puts)
	63	(impl/close! this))
	64
	65	impl/WritePort
	66	(put!
	67	[this val handler]
	68	(when (nil? val)
	69	(throw (IllegalArgumentException. "Can't put nil on channel")))
	70	(.lock mutex)
	71	(cleanup this)
	72	(if @closed
	73	(do (.unlock mutex)
	74	(box false))
	75	(let [^Lock handler handler]
	76	(if (and buf (not (impl/full? buf)) (not (.isEmpty takes)))
	77	(do
	78	(.lock handler)
	79	(let [put-cb (and (impl/active? handler) (impl/commit handler))]
	80	(.unlock handler)
	81	(if put-cb
	82	(let [done? (reduced? (add! buf val))]
	83	(if (pos? (count buf))
	84	(let [iter (.iterator takes)
	85	take-cbs (loop [takers []]
	86	(if (and (.hasNext iter) (pos? (count buf)))
	87	(let [^Lock taker (.next iter)]
	88	(.lock taker)
	89	(let [ret (and (impl/active? taker) (impl/commit taker))]
	90	(.unlock taker)
	91	(if ret
	92	(let [val (impl/remove! buf)]
	93	(.remove iter)
	94	(recur (conj takers (fn [] (ret val)))))
	95	(recur takers))))
	96	takers))]
	97	(if (seq take-cbs)
	98	(do
	99	(when done?
	100	(abort this))
	101	(.unlock mutex)
	102	(doseq [f take-cbs]
	103	(dispatch/run f)))
	104	(do
	105	(when done?
	106	(abort this))
	107	(.unlock mutex))))
	108	(do
	109	(when done?
	110	(abort this))
	111	(.unlock mutex)))
	112	(box true))
	113	(do (.unlock mutex)
	114	nil))))
	115	(let [iter (.iterator takes)
	116	[put-cb take-cb] (when (.hasNext iter)
	117	(loop [^Lock taker (.next iter)]
	118	(if (< (impl/lock-id handler) (impl/lock-id taker))
	119	(do (.lock handler) (.lock taker))
	120	(do (.lock taker) (.lock handler)))
	121	(let [ret (when (and (impl/active? handler) (impl/active? taker))
	122	[(impl/commit handler) (impl/commit taker)])]
	123	(.unlock handler)
	124	(.unlock taker)
	125	(if ret
	126	(do
	127	(.remove iter)
	128	ret)
	129	(when (.hasNext iter)
	130	(recur (.next iter)))))))]
	131	(if (and put-cb take-cb)
	132	(do
	133	(.unlock mutex)
	134	(dispatch/run (fn [] (take-cb val)))
	135	(box true))
	136	(if (and buf (not (impl/full? buf)))
	137	(do
	138	(.lock handler)
	139	(let [put-cb (and (impl/active? handler) (impl/commit handler))]
	140	(.unlock handler)
	141	(if put-cb
	142	(let [done? (reduced? (add! buf val))]
	143	(when done?
	144	(abort this))
	145	(.unlock mutex)
	146	(box true))
	147	(do (.unlock mutex)
	148	nil))))
	149	(do
	150	(when (and (impl/active? handler) (impl/blockable? handler))
	151	(assert-unlock mutex
	152	(< (.size puts) impl/MAX-QUEUE-SIZE)
	153	(str "No more than " impl/MAX-QUEUE-SIZE
	154	" pending puts are allowed on a single channel."
	155	" Consider using a windowed buffer."))
	156	(.add puts [handler val]))
	157	(.unlock mutex)
	158	nil))))))))
	159
	160	impl/ReadPort
	161	(take!
	162	[this handler]
	163	(.lock mutex)
	164	(cleanup this)
	165	(let [^Lock handler handler
	166	commit-handler (fn []
	167	(.lock handler)
	168	(let [take-cb (and (impl/active? handler) (impl/commit handler))]
	169	(.unlock handler)
	170	take-cb))]
	171	(if (and buf (pos? (count buf)))
	172	(do
	173	(if-let [take-cb (commit-handler)]
	174	(let [val (impl/remove! buf)
	175	iter (.iterator puts)
	176	[done? cbs]
	177	(when (.hasNext iter)
	178	(loop [cbs []
	179	[^Lock putter val] (.next iter)]
	180	(.lock putter)
	181	(let [cb (and (impl/active? putter) (impl/commit putter))]
	182	(.unlock putter)
	183	(.remove iter)
	184	(let [cbs (if cb (conj cbs cb) cbs)
	185	done? (when cb (reduced? (add! buf val)))]
	186	(if (and (not done?) (not (impl/full? buf)) (.hasNext iter))
	187	(recur cbs (.next iter))
	188	[done? cbs])))))]
	189	(when done?
	190	(abort this))
	191	(.unlock mutex)
	192	(doseq [cb cbs]
	193	(dispatch/run #(cb true)))
	194	(box val))
	195	(do (.unlock mutex)
	196	nil)))
	197	(let [iter (.iterator puts)
	198	[take-cb put-cb val]
	199	(when (.hasNext iter)
	200	(loop [[^Lock putter val] (.next iter)]
	201	(if (< (impl/lock-id handler) (impl/lock-id putter))
	202	(do (.lock handler) (.lock putter))
	203	(do (.lock putter) (.lock handler)))
	204	(let [ret (when (and (impl/active? handler) (impl/active? putter))
	205	[(impl/commit handler) (impl/commit putter) val])]
	206	(.unlock handler)
	207	(.unlock putter)
	208	(if ret
	209	(do
	210	(.remove iter)
	211	ret)
	212	(when-not (impl/active? putter)
	213	(.remove iter)
	214	(when (.hasNext iter)
	215	(recur (.next iter))))))))]
	216	(if (and put-cb take-cb)
	217	(do
	218	(.unlock mutex)
	219	(dispatch/run #(put-cb true))
	220	(box val))
	221	(if @closed
	222	(do
	223	(when buf (add! buf))
	224	(let [has-val (and buf (pos? (count buf)))]
	225	(if-let [take-cb (commit-handler)]
	226	(let [val (when has-val (impl/remove! buf))]
	227	(.unlock mutex)
	228	(box val))
	229	(do
	230	(.unlock mutex)
	231	nil))))
	232	(do
	233	(when (impl/blockable? handler)
	234	(assert-unlock mutex
	235	(< (.size takes) impl/MAX-QUEUE-SIZE)
	236	(str "No more than " impl/MAX-QUEUE-SIZE
	237	" pending takes are allowed on a single channel."))
	238	(.add takes handler))
	239	(.unlock mutex)
	240	nil)))))))
	241
	242	impl/Channel
	243	(closed? [_] @closed)
	244	(close!
	245	[this]
	246	(.lock mutex)
	247	(cleanup this)
	248	(if @closed
	249	(do
	250	(.unlock mutex)
	251	nil)
	252	(do
	253	(reset! closed true)
	254	(when (and buf (.isEmpty puts))
	255	(add! buf))
	256	(let [iter (.iterator takes)]
	257	(when (.hasNext iter)
	258	(loop [^Lock taker (.next iter)]
	259	(.lock taker)
	260	(let [take-cb (and (impl/active? taker) (impl/commit taker))]
	261	(.unlock taker)
	262	(when take-cb
	263	(let [val (when (and buf (pos? (count buf))) (impl/remove! buf))]
	264	(dispatch/run (fn [] (take-cb val)))))
	265	(.remove iter)
	266	(when (.hasNext iter)
	267	(recur (.next iter)))))))
	268	(when buf (impl/close-buf! buf))
	269	(.unlock mutex)
	270	nil))))
	271
	272	(defn- ex-handler [ex]
	273	(-> (Thread/currentThread)
	274	.getUncaughtExceptionHandler
	275	(.uncaughtException (Thread/currentThread) ex))
	276	nil)
	277
	278	(defn- handle [buf exh t]
	279	(let [else ((or exh ex-handler) t)]
	280	(if (nil? else)
	281	buf
	282	(impl/add! buf else))))
	283
	284	(defn chan
	285	([buf] (chan buf nil))
	286	([buf xform] (chan buf xform nil))
	287	([buf xform exh]
	288	(ManyToManyChannel.
	289	(LinkedList.) (LinkedList.) buf (atom false) (mutex/mutex)
	290	(let [add! (if xform (xform impl/add!) impl/add!)]
	291	(fn
	292	([buf]
	293	(try
	294	(add! buf)
	295	(catch Throwable t
	296	(handle buf exh t))))
	297	([buf val]
	298	(try
	299	(add! buf val)
	300	(catch Throwable t
	301	(handle buf exh t)))))))))
	302

+30

-0

src/main/clojure/clojure/core/async/impl/concurrent.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.concurrent
	10	(:import [java.util.concurrent ThreadFactory]))
	11
	12	(set! warn-on-reflection true)
	13
	14	(defn counted-thread-factory
	15	"Create a ThreadFactory that maintains a counter for naming Threads.
	16	name-format specifies thread names - use %d to include counter
	17	daemon is a flag for whether threads are daemons or not"
	18	[name-format daemon]
	19	(let [counter (atom 0)]
	20	(reify
	21	ThreadFactory
	22	(newThread [this runnable]
	23	(doto (Thread. runnable)
	24	(.setName (format name-format (swap! counter inc)))
	25	(.setDaemon daemon))))))
	26
	27	(defonce
	28	^{:doc "Number of processors reported by the JVM"}
	29	processors (.availableProcessors (Runtime/getRuntime)))

+21

-0

src/main/clojure/clojure/core/async/impl/dispatch.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.dispatch
	10	(:require [clojure.core.async.impl.protocols :as impl]
	11	[clojure.core.async.impl.exec.threadpool :as tp]))
	12
	13	(set! warn-on-reflection true)
	14
	15	(defonce executor (delay (tp/thread-pool-executor)))
	16
	17	(defn run
	18	"Runs Runnable r in a thread pool thread"
	19	[^Runnable r]
	20	(impl/exec @executor r))

+31

-0

src/main/clojure/clojure/core/async/impl/exec/threadpool.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async.impl.exec.threadpool
	9	(:require [clojure.core.async.impl.protocols :as impl]
	10	[clojure.core.async.impl.concurrent :as conc])
	11	(:import [java.util.concurrent Executors Executor]))
	12
	13	(set! warn-on-reflection true)
	14
	15	(def ^:private pool-size
	16	"Value is set via clojure.core.async.pool-size system property; defaults to 8; uses a
	17	delay so property can be set from code after core.async namespace is loaded but before
	18	any use of the async thread pool."
	19	(delay (or (when-let [prop (System/getProperty "clojure.core.async.pool-size")]
	20	(Long/parseLong prop))
	21	8)))
	22
	23	(defn thread-pool-executor
	24	[]
	25	(let [executor-svc (Executors/newFixedThreadPool
	26	@pool-size
	27	(conc/counted-thread-factory "async-dispatch-%d" true))]
	28	(reify impl/Executor
	29	(impl/exec [this r]
	30	(.execute executor-svc ^Runnable r)))))

-0

src/main/clojure/clojure/core/async/impl/ioc_alt.clj less more

	0	(ns ^{:skip-wiki true}
	1	clojure.core.async.impl.ioc-alt
	2	(:require [clojure.core.async.impl.ioc-macros :refer :all :as m]
	3	[clojure.core.async.impl.dispatch :as dispatch]
	4	[clojure.core.async.impl.protocols :as impl]))
	5
	6

+1114

-0

src/main/clojure/clojure/core/async/impl/ioc_macros.clj less more

	0	; Copyright (c) Rich Hickey. All rights reserved.
	1	; The use and distribution terms for this software are covered by the
	2	; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	; which can be found in the file epl-v10.html at the root of this distribution.
	4	; By using this software in any fashion, you are agreeing to be bound by
	5	; the terms of this license.
	6	; You must not remove this notice, or any other, from this software.
	7
	8	;; by Timothy Baldridge
	9	;; April 13, 2013
	10
	11	(ns ^{:skip-wiki true}
	12	clojure.core.async.impl.ioc-macros
	13	(:refer-clojure :exclude [all])
	14	(:require [clojure.pprint :refer [pprint]]
	15	[clojure.tools.analyzer :as an]
	16	[clojure.tools.analyzer.ast :as ast]
	17	[clojure.tools.analyzer.env :as env]
	18	[clojure.tools.analyzer.passes :refer [schedule]]
	19	[clojure.tools.analyzer.passes.jvm.annotate-loops :refer [annotate-loops]]
	20	[clojure.tools.analyzer.passes.jvm.warn-on-reflection :refer [warn-on-reflection]]
	21	[clojure.tools.analyzer.jvm :as an-jvm]
	22	[clojure.core.async.impl.protocols :as impl]
	23	[clojure.core.async.impl.dispatch :as dispatch]
	24	[clojure.set :refer (intersection union difference)])
	25	(:import [java.util.concurrent.locks Lock]
	26	[java.util.concurrent.atomic AtomicReferenceArray]))
	27
	28	(defn debug [x]
	29	(pprint x)
	30	x)
	31
	32
	33	(def ^:const FN-IDX 0)
	34	(def ^:const STATE-IDX 1)
	35	(def ^:const VALUE-IDX 2)
	36	(def ^:const BINDINGS-IDX 3)
	37	(def ^:const EXCEPTION-FRAMES 4)
	38	(def ^:const CURRENT-EXCEPTION 5)
	39	(def ^:const USER-START-IDX 6)
	40
	41	(defn aset-object [^AtomicReferenceArray arr idx ^Object o]
	42	(.set arr idx o))
	43
	44	(defn aget-object [^AtomicReferenceArray arr idx]
	45	(.get arr idx))
	46
	47	(defmacro aset-all!
	48	[arr & more]
	49	(assert (even? (count more)) "Must give an even number of args to aset-all!")
	50	(let [bindings (partition 2 more)
	51	arr-sym (gensym "statearr-")]
	52	`(let [~arr-sym ~arr]
	53	~@(map
	54	(fn [[idx val]]
	55	`(aset-object ~arr-sym ~idx ~val))
	56	bindings)
	57	~arr-sym)))
	58
	59	;; State monad stuff, used only in SSA construction
	60
	61	(defmacro gen-plan
	62	"Allows a user to define a state monad binding plan.
	63
	64	(gen-plan
	65	[_ (assoc-in-plan [:foo :bar] 42)
	66	val (get-in-plan [:foo :bar])]
	67	val)"
	68	[binds id-expr]
	69	(let [binds (partition 2 binds)
	70	psym (gensym "plan_")
	71	forms (reduce
	72	(fn [acc [id expr]]
	73	(concat acc `[[~id ~psym] (~expr ~psym)]))
	74	[]
	75	binds)]
	76	`(fn [~psym]
	77	(let [~@forms]
	78	[~id-expr ~psym]))))
	79
	80	(defn get-plan
	81	"Returns the final [id state] from a plan. "
	82	[f]
	83	(f {}))
	84
	85	(defn push-binding
	86	"Sets the binding 'key' to value. This operation can be undone via pop-bindings.
	87	Bindings are stored in the state hashmap."
	88	[key value]
	89	(fn [plan]
	90	[nil (update-in plan [:bindings key] conj value)]))
	91
	92	(defn push-alter-binding
	93	"Pushes the result of (apply f old-value args) as current value of binding key"
	94	[key f & args]
	95	(fn [plan]
	96	[nil (update-in plan [:bindings key]
	97	#(conj % (apply f (first %) args)))]))
	98
	99	(defn get-binding
	100	"Gets the value of the current binding for key"
	101	[key]
	102	(fn [plan]
	103	[(first (get-in plan [:bindings key])) plan]))
	104
	105	(defn pop-binding
	106	"Removes the most recent binding for key"
	107	[key]
	108	(fn [plan]
	109	[(first (get-in plan [:bindings key]))
	110	(update-in plan [:bindings key] pop)]))
	111
	112	(defn no-op
	113	"This function can be used inside a gen-plan when no operation is to be performed"
	114	[]
	115	(fn [plan]
	116	[nil plan]))
	117
	118	(defn all
	119	"Assumes that itms is a list of state monad function results, threads the state map
	120	through all of them. Returns a vector of all the results."
	121	[itms]
	122	(fn [plan]
	123	(reduce
	124	(fn [[ids plan] f]
	125	(let [[id plan] (f plan)]
	126	[(conj ids id) plan]))
	127	[[] plan]
	128	itms)))
	129
	130	(defn assoc-in-plan
	131	"Same as assoc-in, but for state hash map"
	132	[path val]
	133	(fn [plan]
	134	[val (assoc-in plan path val)]))
	135
	136	(defn update-in-plan
	137	"Same as update-in, but for a state hash map"
	138	[path f & args]
	139	(fn [plan]
	140	[nil (apply update-in plan path f args)]))
	141
	142	(defn get-in-plan
	143	"Same as get-in, but for a state hash map"
	144	[path]
	145	(fn [plan]
	146	[(get-in plan path) plan]))
	147
	148	(defn print-plan []
	149	(fn [plan]
	150	(pprint plan)
	151	[nil plan]))
	152
	153	(defn set-block
	154	"Sets the current block being written to by the functions. The next add-instruction call will append to this block"
	155	[block-id]
	156	(fn [plan]
	157	[block-id (assoc plan :current-block block-id)]))
	158
	159	(defn get-block
	160	"Gets the current block"
	161	[]
	162	(fn [plan]
	163	[(:current-block plan) plan]))
	164
	165	(defn add-block
	166	"Adds a new block, returns its id, but does not change the current block (does not call set-block)."
	167	[]
	168	(gen-plan
	169	[_ (update-in-plan [:block-id] (fnil inc 0))
	170	blk-id (get-in-plan [:block-id])
	171	cur-blk (get-block)
	172	_ (assoc-in-plan [:blocks blk-id] [])
	173	catches (get-binding :catch)
	174	_ (assoc-in-plan [:block-catches blk-id] catches)
	175	_ (if-not cur-blk
	176	(assoc-in-plan [:start-block] blk-id)
	177	(no-op))]
	178	blk-id))
	179
	180
	181	(defn instruction? [x]
	182	(::instruction (meta x)))
	183
	184	(defn add-instruction
	185	"Appends an instruction to the current block. "
	186	[inst]
	187	(let [inst-id (with-meta (gensym "inst_")
	188	{::instruction true})
	189	inst (assoc inst :id inst-id)]
	190	(gen-plan
	191	[blk-id (get-block)
	192	_ (update-in-plan [:blocks blk-id] (fnil conj []) inst)]
	193	inst-id)))
	194
	195	;;
	196
	197	;; We're going to reduce Clojure expressions to a ssa format,
	198	;; and then translate the instructions for this
	199	;; virtual-virtual-machine back into Clojure data.
	200
	201	;; Here we define the instructions:
	202
	203	(defprotocol IInstruction
	204	(reads-from [this] "Returns a list of instructions this instruction reads from")
	205	(writes-to [this] "Returns a list of instructions this instruction writes to")
	206	(block-references [this] "Returns all the blocks this instruction references"))
	207
	208	(defprotocol IEmittableInstruction
	209	(emit-instruction [this state-sym] "Returns the clojure code that this instruction represents"))
	210
	211	(defprotocol ITerminator
	212	(terminator-code [this] "Returns a unique symbol for this instruction")
	213	(terminate-block [this state-sym custom-terminators] "Emites the code to terminate a given block"))
	214
	215	(defrecord Const [value]
	216	IInstruction
	217	(reads-from [this] [value])
	218	(writes-to [this] [(:id this)])
	219	(block-references [this] [])
	220	IEmittableInstruction
	221	(emit-instruction [this state-sym]
	222	(if (= value ::value)
	223	`[~(:id this) (aget-object ~state-sym ~VALUE-IDX)]
	224	`[~(:id this) ~value])))
	225
	226	(defrecord RawCode [ast locals]
	227	IInstruction
	228	(reads-from [this]
	229	(keep (or locals #{})
	230	(map :name (-> ast :env :locals vals))))
	231	(writes-to [this] [(:id this)])
	232	(block-references [this] [])
	233	IEmittableInstruction
	234	(emit-instruction [this state-sym]
	235	(if (not-empty (reads-from this))
	236	`[~@(->> (-> ast :env :locals vals)
	237	(map #(select-keys % [:op :name :form]))
	238	(filter (fn [local]
	239	(when locals
	240	(get locals (:name local)))))
	241	set
	242	(mapcat
	243	(fn [local]
	244	`[~(:form local) ~(get locals (:name local))])))
	245	~(:id this) ~(:form ast)]
	246	`[~(:id this) ~(:form ast)])))
	247
	248	(defrecord CustomTerminator [f blk values meta]
	249	IInstruction
	250	(reads-from [this] values)
	251	(writes-to [this] [])
	252	(block-references [this] [])
	253	ITerminator
	254	(terminate-block [this state-sym _]
	255	(with-meta `(~f ~state-sym ~blk ~@values)
	256	meta)))
	257
	258	(defn- emit-clashing-binds
	259	[recur-nodes ids clashes]
	260	(let [temp-binds (reduce
	261	(fn [acc i]
	262	(assoc acc i (gensym "tmp")))
	263	{} clashes)]
	264	(concat
	265	(mapcat (fn [i]
	266	`[~(temp-binds i) ~i])
	267	clashes)
	268	(mapcat (fn [node id]
	269	`[~node ~(get temp-binds id id)])
	270	recur-nodes
	271	ids))))
	272
	273	(defrecord Recur [recur-nodes ids]
	274	IInstruction
	275	(reads-from [this] ids)
	276	(writes-to [this] recur-nodes)
	277	(block-references [this] [])
	278	IEmittableInstruction
	279	(emit-instruction [this state-sym]
	280	(if-let [overlap (seq (intersection (set recur-nodes) (set ids)))]
	281	(emit-clashing-binds recur-nodes ids overlap)
	282	(mapcat (fn [r i]
	283	`[~r ~i]) recur-nodes ids))))
	284
	285	(defrecord Call [refs]
	286	IInstruction
	287	(reads-from [this] refs)
	288	(writes-to [this] [(:id this)])
	289	(block-references [this] [])
	290	IEmittableInstruction
	291	(emit-instruction [this state-sym]
	292	`[~(:id this) ~(seq refs)]))
	293
	294	(defrecord StaticCall [class method refs]
	295	IInstruction
	296	(reads-from [this] refs)
	297	(writes-to [this] [(:id this)])
	298	(block-references [this] [])
	299	IEmittableInstruction
	300	(emit-instruction [this state-sym]
	301	`[~(:id this) (. ~class ~method ~@(seq refs))]))
	302
	303	(defrecord InstanceInterop [instance-id op refs]
	304	IInstruction
	305	(reads-from [this] (cons instance-id refs))
	306	(writes-to [this] [(:id this)])
	307	(block-references [this] [])
	308	IEmittableInstruction
	309	(emit-instruction [this state-sym]
	310	`[~(:id this) (. ~instance-id ~op ~@(seq refs))]))
	311
	312	(defrecord Case [val-id test-vals jmp-blocks default-block]
	313	IInstruction
	314	(reads-from [this] [val-id])
	315	(writes-to [this] [])
	316	(block-references [this] [])
	317	ITerminator
	318	(terminate-block [this state-sym _]
	319	`(do (case ~val-id
	320	~@(concat (mapcat (fn [test blk]
	321	`[~test (aset-all! ~state-sym
	322	~STATE-IDX ~blk)])
	323	test-vals jmp-blocks)
	324	(when default-block
	325	`[(do (aset-all! ~state-sym ~STATE-IDX ~default-block)
	326	:recur)])))
	327	:recur)))
	328
	329	(defrecord Fn [fn-expr local-names local-refs]
	330	IInstruction
	331	(reads-from [this] local-refs)
	332	(writes-to [this] [(:id this)])
	333	(block-references [this] [])
	334	IEmittableInstruction
	335	(emit-instruction [this state-sym]
	336	`[~(:id this)
	337	(let [~@(interleave local-names local-refs)]
	338	~@fn-expr)]))
	339
	340	(defrecord Dot [cls-or-instance method args]
	341	IInstruction
	342	(reads-from [this] `[~cls-or-instance ~method ~@args])
	343	(writes-to [this] [(:id this)])
	344	(block-references [this] [])
	345	IEmittableInstruction
	346	(emit-instruction [this state-sym]
	347	`[~(:id this) (. ~cls-or-instance ~method ~@args)]))
	348
	349	(defrecord Jmp [value block]
	350	IInstruction
	351	(reads-from [this] [value])
	352	(writes-to [this] [])
	353	(block-references [this] [block])
	354	ITerminator
	355	(terminate-block [this state-sym _]
	356	`(do (aset-all! ~state-sym ~VALUE-IDX ~value ~STATE-IDX ~block)
	357	:recur)))
	358
	359	(defrecord Return [value]
	360	IInstruction
	361	(reads-from [this] [value])
	362	(writes-to [this] [])
	363	(block-references [this] [])
	364	ITerminator
	365	(terminator-code [this] :Return)
	366	(terminate-block [this state-sym custom-terminators]
	367	(if-let [f (get custom-terminators (terminator-code this))]
	368	`(~f ~state-sym ~value)
	369	`(do (aset-all! ~state-sym
	370	~VALUE-IDX ~value
	371	~STATE-IDX ::finished)
	372	nil))))
	373
	374	(defrecord CondBr [test then-block else-block]
	375	IInstruction
	376	(reads-from [this] [test])
	377	(writes-to [this] [])
	378	(block-references [this] [then-block else-block])
	379	ITerminator
	380	(terminate-block [this state-sym _]
	381	`(do (if ~test
	382	(aset-all! ~state-sym
	383	~STATE-IDX ~then-block)
	384	(aset-all! ~state-sym
	385	~STATE-IDX ~else-block))
	386	:recur)))
	387
	388	(defrecord PushTry [catch-block]
	389	IInstruction
	390	(reads-from [this] [])
	391	(writes-to [this] [])
	392	(block-references [this] [catch-block])
	393	IEmittableInstruction
	394	(emit-instruction [this state-sym]
	395	`[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (cons ~catch-block (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
	396
	397	(defrecord PopTry []
	398	IInstruction
	399	(reads-from [this] [])
	400	(writes-to [this] [])
	401	(block-references [this] [])
	402	IEmittableInstruction
	403	(emit-instruction [this state-sym]
	404	`[~'_ (aset-all! ~state-sym ~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))]))
	405
	406	(defrecord CatchHandler [catches]
	407	IInstruction
	408	(reads-from [this] [])
	409	(writes-to [this] [])
	410	(block-references [this] (map first catches))
	411	ITerminator
	412	(terminate-block [this state-sym _]
	413	(let [ex (gensym 'ex)]
	414	`(let [~ex (aget-object ~state-sym ~VALUE-IDX)]
	415	(aset-all! ~state-sym ~CURRENT-EXCEPTION ~ex)
	416	(cond
	417	~@(for [[handler-idx type] catches
	418	i [`(instance? ~type ~ex) ` (aset-all! ~state-sym
	419	~STATE-IDX ~handler-idx
	420	~CURRENT-EXCEPTION nil)]]
	421	i)
	422	:else (throw ~ex))
	423	:recur))))
	424
	425	(defrecord EndFinally []
	426	IInstruction
	427	(reads-from [this] [])
	428	(writes-to [this] [])
	429	(block-references [this] [])
	430	IEmittableInstruction
	431	(emit-instruction [this state-sym]
	432	`[~'_ (when-let [e# (aget-object ~state-sym ~CURRENT-EXCEPTION)]
	433	(throw e#))]))
	434
	435	;; Dispatch clojure forms based on :op
	436	(def -item-to-ssa nil) ;; for help in the repl
	437	(defmulti -item-to-ssa :op)
	438
	439	(defmethod -item-to-ssa :default
	440	[ast]
	441	(gen-plan
	442	[locals (get-binding :locals)
	443	id (add-instruction (->RawCode ast locals))]
	444	id))
	445
	446	(defn item-to-ssa [ast]
	447	(if (or (::transform? ast)
	448	(contains? #{:local :const :quote} (:op ast)))
	449	(-item-to-ssa ast)
	450	(gen-plan
	451	[locals (get-binding :locals)
	452	id (add-instruction (->RawCode ast locals))]
	453	id)))
	454
	455	(defmethod -item-to-ssa :invoke
	456	[{f :fn args :args}]
	457	(gen-plan
	458	[arg-ids (all (map item-to-ssa (cons f args)))
	459	inst-id (add-instruction (->Call arg-ids))]
	460	inst-id))
	461
	462	(defmethod -item-to-ssa :keyword-invoke
	463	[{f :keyword target :target}]
	464	(gen-plan
	465	[arg-ids (all (map item-to-ssa (list f target)))
	466	inst-id (add-instruction (->Call arg-ids))]
	467	inst-id))
	468
	469	(defmethod -item-to-ssa :protocol-invoke
	470	[{f :protocol-fn target :target args :args}]
	471	(gen-plan
	472	[arg-ids (all (map item-to-ssa (list* f target args)))
	473	inst-id (add-instruction (->Call arg-ids))]
	474	inst-id))
	475
	476	(defmethod -item-to-ssa :instance?
	477	[{:keys [class target]}]
	478	(gen-plan
	479	[arg-id (item-to-ssa target)
	480	inst-id (add-instruction (->Call (list `instance? class arg-id)))]
	481	inst-id))
	482
	483	(defmethod -item-to-ssa :prim-invoke
	484	[{f :fn args :args}]
	485	(gen-plan
	486	[arg-ids (all (map item-to-ssa (cons f args)))
	487	inst-id (add-instruction (->Call arg-ids))]
	488	inst-id))
	489
	490	(defmethod -item-to-ssa :instance-call
	491	[{:keys [instance method args]}]
	492	(gen-plan
	493	[arg-ids (all (map item-to-ssa args))
	494	instance-id (item-to-ssa instance)
	495	inst-id (add-instruction (->InstanceInterop instance-id method arg-ids))]
	496	inst-id))
	497
	498	(defmethod -item-to-ssa :instance-field
	499	[{:keys [instance field]}]
	500	(gen-plan
	501	[instance-id (item-to-ssa instance)
	502	inst-id (add-instruction (->InstanceInterop instance-id (symbol (str "-" field)) ()))]
	503	inst-id))
	504
	505	(defmethod -item-to-ssa :host-interop
	506	[{:keys [target m-or-f]}]
	507	(gen-plan
	508	[instance-id (item-to-ssa target)
	509	inst-id (add-instruction (->InstanceInterop instance-id m-or-f ()))]
	510	inst-id))
	511
	512	(defmethod -item-to-ssa :static-call
	513	[{:keys [class method args]}]
	514	(gen-plan
	515	[arg-ids (all (map item-to-ssa args))
	516	inst-id (add-instruction (->StaticCall class method arg-ids))]
	517	inst-id))
	518
	519	(defmethod -item-to-ssa :set!
	520	[{:keys [val target]}]
	521	(gen-plan
	522	[arg-ids (all (map item-to-ssa (list target val)))
	523	inst-id (add-instruction (->Call (cons 'set! arg-ids)))]
	524	inst-id))
	525
	526	(defn var-name [v]
	527	(let [nm (:name (meta v))
	528	nsp (.getName ^clojure.lang.Namespace (:ns (meta v)))]
	529	(symbol (name nsp) (name nm))))
	530
	531
	532	(defmethod -item-to-ssa :var
	533	[{:keys [var]}]
	534	(gen-plan
	535	[]
	536	(var-name var)))
	537
	538	(defmethod -item-to-ssa :const
	539	[{:keys [form]}]
	540	(gen-plan
	541	[]
	542	form))
	543
	544	(defn let-binding-to-ssa
	545	[{:keys [name init form]}]
	546	(gen-plan
	547	[bind-id (item-to-ssa init)
	548	_ (push-alter-binding :locals assoc (vary-meta name merge (meta form)) bind-id)]
	549	bind-id))
	550
	551	(defmethod -item-to-ssa :let
	552	[{:keys [bindings body]}]
	553	(gen-plan
	554	[let-ids (all (map let-binding-to-ssa bindings))
	555	_ (all (map (fn [_] (pop-binding :locals)) bindings))
	556
	557	local-ids (all (map (comp add-instruction ->Const) let-ids))
	558	_ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}]
	559	[name (vary-meta id merge (meta form))])
	560	local-ids bindings)))
	561
	562	body-id (item-to-ssa body)
	563	_ (pop-binding :locals)]
	564	body-id))
	565
	566	(defmethod -item-to-ssa :loop
	567	[{:keys [body bindings] :as ast}]
	568	(gen-plan
	569	[local-val-ids (all (map let-binding-to-ssa bindings))
	570	_ (all (for [_ bindings]
	571	(pop-binding :locals)))
	572	local-ids (all (map (comp add-instruction ->Const) local-val-ids))
	573	body-blk (add-block)
	574	final-blk (add-block)
	575	_ (add-instruction (->Jmp nil body-blk))
	576
	577	_ (set-block body-blk)
	578	_ (push-alter-binding :locals merge (into {} (map (fn [id {:keys [name form]}]
	579	[name (vary-meta id merge (meta form))])
	580	local-ids bindings)))
	581	_ (push-binding :recur-point body-blk)
	582	_ (push-binding :recur-nodes local-ids)
	583
	584	ret-id (item-to-ssa body)
	585
	586	_ (pop-binding :recur-nodes)
	587	_ (pop-binding :recur-point)
	588	_ (pop-binding :locals)
	589	_ (if (not= ret-id ::terminated)
	590	(add-instruction (->Jmp ret-id final-blk))
	591	(no-op))
	592	_ (set-block final-blk)
	593	ret-id (add-instruction (->Const ::value))]
	594	ret-id))
	595
	596	(defmethod -item-to-ssa :do
	597	[{:keys [statements ret] :as ast}]
	598	(gen-plan
	599	[_ (all (map item-to-ssa statements))
	600	ret-id (item-to-ssa ret)]
	601	ret-id))
	602
	603	(defmethod -item-to-ssa :case
	604	[{:keys [test tests thens default] :as ast}]
	605	(gen-plan
	606	[end-blk (add-block)
	607	start-blk (get-block)
	608	clause-blocks (all (map (fn [expr]
	609	(assert expr)
	610	(gen-plan
	611	[blk-id (add-block)
	612	_ (set-block blk-id)
	613	expr-id (item-to-ssa expr)
	614	_ (if (not= expr-id ::terminated)
	615	(add-instruction (->Jmp expr-id end-blk))
	616	(no-op))]
	617	blk-id))
	618	(map :then thens)))
	619	default-block (if default
	620	(gen-plan
	621	[blk-id (add-block)
	622	_ (set-block blk-id)
	623	expr-id (item-to-ssa default)
	624	_ (if (not= expr-id ::terminated)
	625	(add-instruction (->Jmp expr-id end-blk))
	626	(no-op))]
	627	blk-id)
	628	(no-op))
	629	_ (set-block start-blk)
	630	val-id (item-to-ssa test)
	631	case-id (add-instruction (->Case val-id (map (comp :form :test) tests)
	632	clause-blocks
	633	default-block))
	634	_ (set-block end-blk)
	635	ret-id (add-instruction (->Const ::value))]
	636	ret-id))
	637
	638	(defmethod -item-to-ssa :quote
	639	[{:keys [form]}]
	640	(gen-plan
	641	[ret-id (add-instruction (->Const form))]
	642	ret-id))
	643
	644	(defmethod -item-to-ssa :try
	645	[{:keys [catches body finally] :as ast}]
	646	(gen-plan
	647	[body-block (add-block)
	648	exit-block (add-block)
	649	;; Two routes to the finally block, via normal execution and
	650	;; exception execution
	651	finally-blk (if finally
	652	(gen-plan
	653	[cur-blk (get-block)
	654	finally-blk (add-block)
	655	_ (set-block finally-blk)
	656	result-id (add-instruction (->Const ::value))
	657	_ (item-to-ssa finally)
	658	;; rethrow exception on exception path
	659	_ (add-instruction (->EndFinally))
	660	_ (add-instruction (->Jmp result-id exit-block))
	661	_ (set-block cur-blk)]
	662	finally-blk)
	663	(gen-plan [] exit-block))
	664	catch-blocks (all
	665	(for [{ex-bind :local {ex :val} :class catch-body :body} catches]
	666	(gen-plan
	667	[cur-blk (get-block)
	668	catch-blk (add-block)
	669	_ (set-block catch-blk)
	670	ex-id (add-instruction (->Const ::value))
	671	_ (push-alter-binding :locals assoc (:name ex-bind)
	672	(vary-meta ex-id merge (when (:tag ex-bind)
	673	{:tag (.getName ^Class (:tag ex-bind))})))
	674	result-id (item-to-ssa catch-body)
	675	;; if there is a finally, jump to it after
	676	;; handling the exception, if not jump to exit
	677	_ (add-instruction (->Jmp result-id finally-blk))
	678	_ (pop-binding :locals)
	679	_ (set-block cur-blk)]
	680	[catch-blk ex])))
	681	;; catch block handler routes exceptions to the correct handler,
	682	;; rethrows if there is no match
	683	catch-handler-block (add-block)
	684	cur-blk (get-block)
	685	_ (set-block catch-handler-block)
	686	_ (add-instruction (->CatchHandler catch-blocks))
	687	_ (set-block cur-blk)
	688	_ (add-instruction (->Jmp nil body-block))
	689	_ (set-block body-block)
	690	;; the finally gets pushed on to the exception handler stack, so
	691	;; it will be executed if there is an exception
	692	_ (if finally
	693	(add-instruction (->PushTry finally-blk))
	694	(no-op))
	695	_ (add-instruction (->PushTry catch-handler-block))
	696	body (item-to-ssa body)
	697	_ (add-instruction (->PopTry))
	698	_ (if finally
	699	(add-instruction (->PopTry))
	700	(no-op))
	701	;; if the body finishes executing normally, jump to the finally
	702	;; block, if it exists
	703	_ (add-instruction (->Jmp body finally-blk))
	704	_ (set-block exit-block)
	705	ret (add-instruction (->Const ::value))]
	706	ret))
	707
	708	(defmethod -item-to-ssa :throw
	709	[{:keys [exception] :as ast}]
	710	(gen-plan
	711	[exception-id (item-to-ssa exception)
	712	ret-id (add-instruction (->Call ['throw exception-id]))]
	713	ret-id))
	714
	715	(defmethod -item-to-ssa :new
	716	[{:keys [args class] :as ast}]
	717	(gen-plan
	718	[arg-ids (all (map item-to-ssa args))
	719	ret-id (add-instruction (->Call (list* 'new (:val class) arg-ids)))]
	720	ret-id))
	721
	722	(defmethod -item-to-ssa :recur
	723	[{:keys [exprs] :as ast}]
	724	(gen-plan
	725	[val-ids (all (map item-to-ssa exprs))
	726	recurs (get-binding :recur-nodes)
	727	_ (do (assert (= (count val-ids)
	728	(count recurs))
	729	"Wrong number of arguments to recur")
	730	(no-op))
	731	_ (add-instruction (->Recur recurs val-ids))
	732
	733	recur-point (get-binding :recur-point)
	734
	735	_ (add-instruction (->Jmp nil recur-point))]
	736	::terminated))
	737
	738	(defmethod -item-to-ssa :if
	739	[{:keys [test then else]}]
	740	(gen-plan
	741	[test-id (item-to-ssa test)
	742	then-blk (add-block)
	743	else-blk (add-block)
	744	final-blk (add-block)
	745	_ (add-instruction (->CondBr test-id then-blk else-blk))
	746
	747	_ (set-block then-blk)
	748	then-id (item-to-ssa then)
	749	_ (if (not= then-id ::terminated)
	750	(gen-plan
	751	[_ (add-instruction (->Jmp then-id final-blk))]
	752	then-id)
	753	(no-op))
	754
	755	_ (set-block else-blk)
	756	else-id (item-to-ssa else)
	757	_ (if (not= else-id ::terminated)
	758	(gen-plan
	759	[_ (add-instruction (->Jmp else-id final-blk))]
	760	then-id)
	761	(no-op))
	762
	763	_ (set-block final-blk)
	764	val-id (add-instruction (->Const ::value))]
	765	val-id))
	766
	767	(defmethod -item-to-ssa :transition
	768	[{:keys [name args form]}]
	769	(gen-plan
	770	[blk (add-block)
	771	vals (all (map item-to-ssa args))
	772	val (add-instruction (->CustomTerminator name blk vals (meta form)))
	773	_ (set-block blk)
	774	res (add-instruction (->Const ::value))]
	775	res))
	776
	777	(defmethod -item-to-ssa :local
	778	[{:keys [name form]}]
	779	(gen-plan
	780	[locals (get-binding :locals)
	781	inst-id (if (contains? locals name)
	782	(fn [p]
	783	[(locals name) p])
	784	(fn [p]
	785	[form p]))]
	786	inst-id))
	787
	788	(defmethod -item-to-ssa :map
	789	[{:keys [keys vals]}]
	790	(gen-plan
	791	[keys-ids (all (map item-to-ssa keys))
	792	vals-ids (all (map item-to-ssa vals))
	793	id (add-instruction (->Call (cons 'clojure.core/hash-map
	794	(interleave keys-ids vals-ids))))]
	795	id))
	796
	797	(defmethod -item-to-ssa :with-meta
	798	[{:keys [expr meta]}]
	799	(gen-plan
	800	[meta-id (item-to-ssa meta)
	801	expr-id (item-to-ssa expr)
	802	id (add-instruction (->Call (list 'clojure.core/with-meta expr-id meta-id)))]
	803	id))
	804
	805	(defmethod -item-to-ssa :record
	806	[x]
	807	(-item-to-ssa `(~(symbol (.getName (class x)) "create")
	808	(hash-map ~@(mapcat identity x)))))
	809
	810	(defmethod -item-to-ssa :vector
	811	[{:keys [items]}]
	812	(gen-plan
	813	[item-ids (all (map item-to-ssa items))
	814	id (add-instruction (->Call (cons 'clojure.core/vector
	815	item-ids)))]
	816	id))
	817
	818	(defmethod -item-to-ssa :set
	819	[{:keys [items]}]
	820	(gen-plan
	821	[item-ids (all (map item-to-ssa items))
	822	id (add-instruction (->Call (cons 'clojure.core/hash-set
	823	item-ids)))]
	824	id))
	825
	826	(defn parse-to-state-machine
	827	"Takes an sexpr and returns a hashmap that describes the execution flow of the sexpr as
	828	a series of SSA style blocks."
	829	[body terminators]
	830	(-> (gen-plan
	831	[_ (push-binding :terminators terminators)
	832	blk (add-block)
	833	_ (set-block blk)
	834	id (item-to-ssa body)
	835	term-id (add-instruction (->Return id))
	836	_ (pop-binding :terminators)]
	837	term-id)
	838	get-plan))
	839
	840
	841	(defn index-instruction [blk-id idx inst]
	842	(let [idx (reduce
	843	(fn [acc id]
	844	(update-in acc [id :read-in] (fnil conj #{}) blk-id))
	845	idx
	846	(filter instruction? (reads-from inst)))
	847	idx (reduce
	848	(fn [acc id]
	849	(update-in acc [id :written-in] (fnil conj #{}) blk-id))
	850	idx
	851	(filter instruction? (writes-to inst)))]
	852	idx))
	853
	854	(defn index-block [idx [blk-id blk]]
	855	(reduce (partial index-instruction blk-id) idx blk))
	856
	857	(defn index-state-machine [machine]
	858	(reduce index-block {} (:blocks machine)))
	859
	860	(defn id-for-inst [m sym] ;; m :: symbols -> integers
	861	(if-let [i (get @m sym)]
	862	i
	863	(let [next-idx (get @m ::next-idx)]
	864	(swap! m assoc sym next-idx)
	865	(swap! m assoc ::next-idx (inc next-idx))
	866	next-idx)))
	867
	868	(defn persistent-value?
	869	"Returns true if this value should be saved in the state hash map"
	870	[index value]
	871	(or (not= (-> index value :read-in)
	872	(-> index value :written-in))
	873	(-> index value :read-in count (> 1))))
	874
	875	(defn count-persistent-values
	876	[index]
	877	(->> (keys index)
	878	(filter instruction?)
	879	(filter (partial persistent-value? index))
	880	count))
	881
	882	(defn- build-block-preamble [local-map idx state-sym blk]
	883	(let [args (->> (mapcat reads-from blk)
	884	(filter instruction?)
	885	(filter (partial persistent-value? idx))
	886	set
	887	vec)]
	888	(if (empty? args)
	889	[]
	890	(mapcat (fn [sym]
	891	`[~sym (aget-object ~state-sym ~(id-for-inst local-map sym))])
	892	args))))
	893
	894	(defn- build-block-body [state-sym blk]
	895	(mapcat
	896	#(emit-instruction % state-sym)
	897	(butlast blk)))
	898
	899	(defn- build-new-state [local-map idx state-sym blk]
	900	(let [results (->> blk
	901	(mapcat writes-to)
	902	(filter instruction?)
	903	(filter (partial persistent-value? idx))
	904	set
	905	vec)
	906	results (interleave (map (partial id-for-inst local-map) results) results)]
	907	(if-not (empty? results)
	908	[state-sym `(aset-all! ~state-sym ~@results)]
	909	[])))
	910
	911	(defn- emit-state-machine [machine num-user-params custom-terminators]
	912	(let [index (index-state-machine machine)
	913	state-sym (with-meta (gensym "state_")
	914	{:tag 'objects})
	915	local-start-idx (+ num-user-params USER-START-IDX)
	916	state-arr-size (+ local-start-idx (count-persistent-values index))
	917	local-map (atom {::next-idx local-start-idx})
	918	block-catches (:block-catches machine)]
	919	`(fn state-machine#
	920	([] (aset-all! (AtomicReferenceArray. ~state-arr-size)
	921	~FN-IDX state-machine#
	922	~STATE-IDX ~(:start-block machine)))
	923	([~state-sym]
	924	(let [old-frame# (clojure.lang.Var/getThreadBindingFrame)
	925	ret-value# (try
	926	(clojure.lang.Var/resetThreadBindingFrame (aget-object ~state-sym ~BINDINGS-IDX))
	927	(loop []
	928	(let [result# (case (int (aget-object ~state-sym ~STATE-IDX))
	929	~@(mapcat
	930	(fn [[id blk]]
	931	[id `(let [~@(concat (build-block-preamble local-map index state-sym blk)
	932	(build-block-body state-sym blk))
	933	~@(build-new-state local-map index state-sym blk)]
	934	~(terminate-block (last blk) state-sym custom-terminators))])
	935	(:blocks machine)))]
	936	(if (identical? result# :recur)
	937	(recur)
	938	result#)))
	939	(catch Throwable ex#
	940	(aset-all! ~state-sym ~VALUE-IDX ex#)
	941	(if (seq (aget-object ~state-sym ~EXCEPTION-FRAMES))
	942	(aset-all! ~state-sym ~STATE-IDX (first (aget-object ~state-sym ~EXCEPTION-FRAMES))
	943	~EXCEPTION-FRAMES (rest (aget-object ~state-sym ~EXCEPTION-FRAMES)))
	944	(throw ex#))
	945	:recur)
	946	(finally
	947	(clojure.lang.Var/resetThreadBindingFrame old-frame#)))]
	948	(if (identical? ret-value# :recur)
	949	(recur ~state-sym)
	950	ret-value#))))))
	951
	952	(defn finished?
	953	"Returns true if the machine is in a finished state"
	954	[state-array]
	955	(identical? (aget-object state-array STATE-IDX) ::finished))
	956
	957	(defn- fn-handler
	958	[f]
	959	(reify
	960	Lock
	961	(lock [_])
	962	(unlock [_])
	963
	964	impl/Handler
	965	(active? [_] true)
	966	(blockable? [_] true)
	967	(lock-id [_] 0)
	968	(commit [_] f)))
	969
	970
	971	(defn run-state-machine [state]
	972	((aget-object state FN-IDX) state))
	973
	974	(defn run-state-machine-wrapped [state]
	975	(try
	976	(run-state-machine state)
	977	(catch Throwable ex
	978	(impl/close! (aget-object state USER-START-IDX))
	979	(throw ex))))
	980
	981	(defn take! [state blk c]
	982	(if-let [cb (impl/take! c (fn-handler
	983	(fn [x]
	984	(aset-all! state VALUE-IDX x STATE-IDX blk)
	985	(run-state-machine-wrapped state))))]
	986	(do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
	987	:recur)
	988	nil))
	989
	990	(defn put! [state blk c val]
	991	(if-let [cb (impl/put! c val (fn-handler (fn [ret-val]
	992	(aset-all! state VALUE-IDX ret-val STATE-IDX blk)
	993	(run-state-machine-wrapped state))))]
	994	(do (aset-all! state VALUE-IDX @cb STATE-IDX blk)
	995	:recur)
	996	nil))
	997
	998	(defn return-chan [state value]
	999	(let [c (aget-object state USER-START-IDX)]
	1000	(when-not (nil? value)
	1001	(impl/put! c value (fn-handler (fn [] nil))))
	1002	(impl/close! c)
	1003	c))
	1004
	1005
	1006	(def async-custom-terminators
	1007	{'clojure.core.async/<! `take!
	1008	'clojure.core.async/>! `put!
	1009	'clojure.core.async/alts! 'clojure.core.async/ioc-alts!
	1010	:Return `return-chan})
	1011
	1012	(defn mark-transitions
	1013	{:pass-info {:walk :post :depends #{} :after an-jvm/default-passes}}
	1014	[{:keys [op fn] :as ast}]
	1015	(let [transitions (-> (env/deref-env) :passes-opts :mark-transitions/transitions)]
	1016	(if (and (= op :invoke)
	1017	(= (:op fn) :var)
	1018	(contains? transitions (var-name (:var fn))))
	1019	(merge ast
	1020	{:op :transition
	1021	:name (get transitions (var-name (:var fn)))})
	1022	ast)))
	1023
	1024	(defn propagate-transitions
	1025	{:pass-info {:walk :post :depends #{#'mark-transitions}}}
	1026	[{:keys [op] :as ast}]
	1027	(if (or (= op :transition)
	1028	(some #(or (= (:op %) :transition)
	1029	(::transform? %))
	1030	(ast/children ast)))
	1031	(assoc ast ::transform? true)
	1032	ast))
	1033
	1034	(defn propagate-recur
	1035	{:pass-info {:walk :post :depends #{#'annotate-loops #'propagate-transitions}}}
	1036	[ast]
	1037	(if (and (= (:op ast) :loop)
	1038	(::transform? ast))
	1039	;; If we are a loop and we need to transform, and
	1040	;; one of our children is a recur, then we must transform everything
	1041	;; that has a recur
	1042	(let [loop-id (:loop-id ast)]
	1043	(ast/postwalk ast #(if (contains? (:loops %) loop-id)
	1044	(assoc % ::transform? true)
	1045	%)))
	1046	ast))
	1047
	1048	(defn nested-go? [env]
	1049	(-> env vals first map?))
	1050
	1051	(defn make-env [input-env crossing-env]
	1052	(assoc (an-jvm/empty-env)
	1053	:locals (into {}
	1054	(if (nested-go? input-env)
	1055	(for [[l expr] input-env
	1056	:let [local (get crossing-env l)]]
	1057	[local (-> expr
	1058	(assoc :form local)
	1059	(assoc :name local))])
	1060	(for [l (keys input-env)
	1061	:let [local (get crossing-env l)]]
	1062	[local {:op :local
	1063	:form local
	1064	:name local}])))))
	1065
	1066	(defn pdebug [x]
	1067	(clojure.pprint/pprint x)
	1068	(println "----")
	1069	x)
	1070
	1071	(def passes (into (disj an-jvm/default-passes #'warn-on-reflection)
	1072	#{#'propagate-recur
	1073	#'propagate-transitions
	1074	#'mark-transitions}))
	1075
	1076	(def run-passes
	1077	(schedule passes))
	1078
	1079	(defn emit-hinted [local tag env]
	1080	(let [tag (or tag (-> local meta :tag))
	1081	init (list (get env local))]
	1082	(if-let [prim-fn (case (cond-> tag (string? tag) symbol)
	1083	int `int
	1084	long `long
	1085	char `char
	1086	float `float
	1087	double `double
	1088	byte `byte
	1089	short `short
	1090	boolean `boolean
	1091	nil)]
	1092	[(vary-meta local dissoc :tag) (list prim-fn init)]
	1093	[(vary-meta local merge (when tag {:tag tag})) init])))
	1094
	1095	(defn state-machine [body num-user-params [crossing-env env] user-transitions]
	1096	(binding [an-jvm/run-passes run-passes]
	1097	(-> (an-jvm/analyze `(let [~@(if (nested-go? env)
	1098	(mapcat (fn [[l {:keys [tag]}]]
	1099	(emit-hinted l tag crossing-env))
	1100	env)
	1101	(mapcat (fn [[l ^clojure.lang.Compiler$LocalBinding lb]]
	1102	(emit-hinted l (when (.hasJavaClass lb)
	1103	(some-> lb .getJavaClass .getName))
	1104	crossing-env))
	1105	env))]
	1106	~body)
	1107	(make-env env crossing-env)
	1108	{:passes-opts (merge an-jvm/default-passes-opts
	1109	{:uniquify/uniquify-env true
	1110	:mark-transitions/transitions user-transitions})})
	1111	(parse-to-state-machine user-transitions)
	1112	second
	1113	(emit-state-machine num-user-params user-transitions))))

+30

-0

src/main/clojure/clojure/core/async/impl/mutex.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.mutex
	10	(:require [clojure.core.async.impl.protocols :as impl])
	11	(:import [clojure.core.async Mutex]
	12	[java.util.concurrent.locks Lock ReentrantLock]))
	13
	14	(defn mutex []
	15	(let [m (ReentrantLock.)]
	16	(reify
	17	Lock
	18	(lock [_] (.lock m))
	19	(unlock [_] (.unlock m)))))
	20
	21	#_(defn mutex []
	22	(let [cas (java.util.concurrent.atomic.AtomicInteger.)]
	23	(reify
	24	Lock
	25	(lock [_] (loop [got (.compareAndSet cas 0 1)]
	26	(if got
	27	nil
	28	(recur (.compareAndSet cas 0 1)))))
	29	(unlock [_] (.set cas 0)))))

+47

-0

src/main/clojure/clojure/core/async/impl/protocols.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.protocols)
	10
	11
	12	(def ^:const ^{:tag 'int} MAX-QUEUE-SIZE 1024)
	13
	14	(defprotocol ReadPort
	15	(take! [port fn1-handler] "derefable val if taken, nil if take was enqueued"))
	16
	17	(defprotocol WritePort
	18	(put! [port val fn1-handler] "derefable boolean (false iff already closed) if handled, nil if put was enqueued. Must throw on nil val."))
	19
	20	(defprotocol Channel
	21	(close! [chan])
	22	(closed? [chan]))
	23
	24	(defprotocol Handler
	25	(active? [h] "returns true if has callback. Must work w/o lock")
	26	(blockable? [h] "returns true if this handler may be blocked, otherwise it must not block")
	27	(lock-id [h] "a unique id for lock acquisition order, 0 if no lock")
	28	(commit [h] "commit to fulfilling its end of the transfer, returns cb. Must be called within lock"))
	29
	30	(defprotocol Buffer
	31	(full? [b] "returns true if buffer cannot accept put")
	32	(remove! [b] "remove and return next item from buffer, called under chan mutex")
	33	(add!* [b itm] "if room, add item to the buffer, returns b, called under chan mutex")
	34	(close-buf! [b] "called on chan closed under chan mutex, return ignored"))
	35
	36	(defn add!
	37	([b] b)
	38	([b itm]
	39	(assert (not (nil? itm)))
	40	(add!* b itm)))
	41
	42	(defprotocol Executor
	43	(exec [e runnable] "execute runnable asynchronously"))
	44
	45	;; Defines a buffer that will never block (return true to full?)
	46	(defprotocol UnblockingBuffer)

+68

-0

src/main/clojure/clojure/core/async/impl/timers.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns ^{:skip-wiki true}
	9	clojure.core.async.impl.timers
	10	(:require [clojure.core.async.impl.protocols :as impl]
	11	[clojure.core.async.impl.channels :as channels])
	12	(:import [java.util.concurrent DelayQueue Delayed TimeUnit ConcurrentSkipListMap]))
	13
	14	(set! warn-on-reflection true)
	15
	16	(defonce ^:private ^DelayQueue timeouts-queue
	17	(DelayQueue.))
	18
	19	(defonce ^:private ^ConcurrentSkipListMap timeouts-map
	20	(ConcurrentSkipListMap.))
	21
	22	(def ^:const TIMEOUT_RESOLUTION_MS 10)
	23
	24	(deftype TimeoutQueueEntry [channel ^long timestamp]
	25	Delayed
	26	(getDelay [this time-unit]
	27	(.convert time-unit
	28	(- timestamp (System/currentTimeMillis))
	29	TimeUnit/MILLISECONDS))
	30	(compareTo
	31	[this other]
	32	(let [ostamp (.timestamp ^TimeoutQueueEntry other)]
	33	(if (< timestamp ostamp)
	34	-1
	35	(if (= timestamp ostamp)
	36	0
	37	1))))
	38	impl/Channel
	39	(close! [this]
	40	(impl/close! channel)))
	41
	42	(defn timeout
	43	"returns a channel that will close after msecs"
	44	[^long msecs]
	45	(let [timeout (+ (System/currentTimeMillis) msecs)
	46	me (.ceilingEntry timeouts-map timeout)]
	47	(or (when (and me (< (.getKey me) (+ timeout TIMEOUT_RESOLUTION_MS)))
	48	(.channel ^TimeoutQueueEntry (.getValue me)))
	49	(let [timeout-channel (channels/chan nil)
	50	timeout-entry (TimeoutQueueEntry. timeout-channel timeout)]
	51	(.put timeouts-map timeout timeout-entry)
	52	(.put timeouts-queue timeout-entry)
	53	timeout-channel))))
	54
	55	(defn- timeout-worker
	56	[]
	57	(let [q timeouts-queue]
	58	(loop []
	59	(let [^TimeoutQueueEntry tqe (.take q)]
	60	(.remove timeouts-map (.timestamp tqe) tqe)
	61	(impl/close! tqe))
	62	(recur))))
	63
	64	(defonce timeout-daemon
	65	(doto (Thread. ^Runnable timeout-worker "clojure.core.async.timers/timeout-daemon")
	66	(.setDaemon true)
	67	(.start)))

+108

-0

src/main/clojure/clojure/core/async/lab.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async.lab
	9	"core.async HIGHLY EXPERIMENTAL feature exploration
	10
	11	Caveats:
	12
	13	1. Everything defined in this namespace is experimental, and subject
	14	to change or deletion without warning.
	15
	16	2. Many features provided by this namespace are highly coupled to
	17	implementation details of core.async. Potential features which
	18	operate at higher levels of abstraction are suitable for inclusion
	19	in the examples.
	20
	21	3. Features provided by this namespace MAY be promoted to
	22	clojure.core.async at a later point in time, but there is no
	23	guarantee any of them will."
	24	(:require [clojure.core.async :as async]
	25	[clojure.core.async.impl.protocols :as impl]
	26	[clojure.core.async.impl.mutex :as mutex]
	27	[clojure.core.async.impl.dispatch :as dispatch]
	28	[clojure.core.async.impl.channels :as channels])
	29	(:import [java.util HashSet Set Collection]
	30	[java.util.concurrent.locks Lock]))
	31
	32	(deftype MultiplexingReadPort
	33	[^Lock mutex ^Set read-ports]
	34	impl/ReadPort
	35	(take! [this handler]
	36	(if (empty? read-ports)
	37	(channels/box nil)
	38	(do
	39	(.lock mutex)
	40	(let [^Lock handler handler
	41	commit-handler (fn []
	42	(.lock handler)
	43	(let [take-cb (and (impl/active? handler) (impl/commit handler))]
	44	(.unlock handler)
	45	take-cb))
	46	fret (fn [[val alt-port]]
	47	(if (nil? val)
	48	(do (.lock mutex)
	49	(.remove read-ports alt-port)
	50	(.unlock mutex)
	51	(impl/take! this handler))
	52	(when-let [take-cb (commit-handler)]
	53	(dispatch/run #(take-cb val)))))
	54	current-ports (seq read-ports)]
	55	(if-let [alt-res (async/do-alts fret current-ports {})]
	56	(let [[val alt-port] @alt-res]
	57	(if (nil? val)
	58	(do (.remove read-ports alt-port)
	59	(.unlock mutex)
	60	(recur handler))
	61	(do (.unlock mutex)
	62	(when-let [take-cb (commit-handler)]
	63	(dispatch/run #(take-cb val))))))
	64	(do
	65	(.unlock mutex)
	66	nil)))))))
	67
	68	(defn multiplex
	69	"Returns a multiplexing read port which, when read from, produces a
	70	value from one of ports.
	71
	72	If at read time only one port is available to be read from, the
	73	multiplexing port will return that value. If multiple ports are
	74	available to be read from, the multiplexing port will return one
	75	value from a port chosen non-deterministicly. If no port is
	76	available to be read from, parks execution until a value is
	77	available."
	78	[& ports]
	79	(->MultiplexingReadPort (mutex/mutex) (HashSet. ^Collection ports)))
	80
	81	(defn- broadcast-write
	82	[port-set val handler]
	83	(if (= (count port-set) 1)
	84	(impl/put! (first port-set) val handler)
	85	(let [clauses (map (fn [port] [port val]) port-set)
	86	recur-step (fn [[_ port]] (broadcast-write (disj port-set port) val handler))]
	87	(when-let [alt-res (async/do-alts recur-step clauses {})]
	88	(recur (disj port-set (second @alt-res))
	89	val
	90	handler)))))
	91
	92	(deftype BroadcastingWritePort
	93	[write-ports]
	94	impl/WritePort
	95	(put! [port val handler]
	96	(broadcast-write write-ports val handler)))
	97
	98	(defn broadcast
	99	"Returns a broadcasting write port which, when written to, writes
	100	the value to each of ports.
	101
	102	Writes to the broadcasting port will park until the value is written
	103	to each of the ports used to create it. For this reason, it is
	104	strongly advised that each of the underlying ports support buffered
	105	writes."
	106	[& ports]
	107	(->BroadcastingWritePort (set ports)))⏎

+1187

-0

src/main/clojure/clojure/core/async.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async
	9	"Facilities for async programming and communication.
	10
	11	go blocks are dispatched over an internal thread pool, which
	12	defaults to 8 threads. The size of this pool can be modified using
	13	the Java system property `clojure.core.async.pool-size`."
	14	(:refer-clojure :exclude [reduce transduce into merge map take partition
	15	partition-by bounded-count])
	16	(:require [clojure.core.async.impl.protocols :as impl]
	17	[clojure.core.async.impl.channels :as channels]
	18	[clojure.core.async.impl.buffers :as buffers]
	19	[clojure.core.async.impl.timers :as timers]
	20	[clojure.core.async.impl.dispatch :as dispatch]
	21	[clojure.core.async.impl.ioc-macros :as ioc]
	22	[clojure.core.async.impl.mutex :as mutex]
	23	[clojure.core.async.impl.concurrent :as conc]
	24	)
	25	(:import [clojure.core.async ThreadLocalRandom]
	26	[java.util.concurrent.locks Lock]
	27	[java.util.concurrent Executors Executor]
	28	[java.util ArrayList]))
	29
	30	(alias 'core 'clojure.core)
	31
	32	(set! warn-on-reflection false)
	33
	34	(defn fn-handler
	35	([f]
	36	(fn-handler f true))
	37	([f blockable]
	38	(reify
	39	Lock
	40	(lock [_])
	41	(unlock [_])
	42
	43	impl/Handler
	44	(active? [_] true)
	45	(blockable? [_] blockable)
	46	(lock-id [_] 0)
	47	(commit [_] f))))
	48
	49	(defn buffer
	50	"Returns a fixed buffer of size n. When full, puts will block/park."
	51	[n]
	52	(buffers/fixed-buffer n))
	53
	54	(defn dropping-buffer
	55	"Returns a buffer of size n. When full, puts will complete but
	56	val will be dropped (no transfer)."
	57	[n]
	58	(buffers/dropping-buffer n))
	59
	60	(defn sliding-buffer
	61	"Returns a buffer of size n. When full, puts will complete, and be
	62	buffered, but oldest elements in buffer will be dropped (not
	63	transferred)."
	64	[n]
	65	(buffers/sliding-buffer n))
	66
	67	(defn unblocking-buffer?
	68	"Returns true if a channel created with buff will never block. That is to say,
	69	puts into this buffer will never cause the buffer to be full. "
	70	[buff]
	71	(extends? impl/UnblockingBuffer (class buff)))
	72
	73	(defn chan
	74	"Creates a channel with an optional buffer, an optional transducer
	75	(like (map f), (filter p) etc or a composition thereof), and an
	76	optional exception-handler. If buf-or-n is a number, will create
	77	and use a fixed buffer of that size. If a transducer is supplied a
	78	buffer must be specified. ex-handler must be a fn of one argument -
	79	if an exception occurs during transformation it will be called with
	80	the Throwable as an argument, and any non-nil return value will be
	81	placed in the channel."
	82	([] (chan nil))
	83	([buf-or-n] (chan buf-or-n nil))
	84	([buf-or-n xform] (chan buf-or-n xform nil))
	85	([buf-or-n xform ex-handler]
	86	(when (and buf-or-n (number? buf-or-n)) (assert (pos? buf-or-n) "fixed buffers must have size > 0"))
	87	(when xform (assert buf-or-n "buffer must be supplied when transducer is"))
	88	(channels/chan (if (number? buf-or-n) (buffer buf-or-n) buf-or-n) xform ex-handler)))
	89
	90	(defn promise-chan
	91	"Creates a promise channel with an optional transducer, and an optional
	92	exception-handler. A promise channel can take exactly one value that consumers
	93	will receive. Once full, puts complete but val is dropped (no transfer).
	94	Consumers will block until either a value is placed in the channel or the
	95	channel is closed. See chan for the semantics of xform and ex-handler."
	96	([] (promise-chan nil))
	97	([xform] (promise-chan xform nil))
	98	([xform ex-handler]
	99	(chan (buffers/promise-buffer) xform ex-handler)))
	100
	101	(defn timeout
	102	"Returns a channel that will close after msecs"
	103	[^long msecs]
	104	(timers/timeout msecs))
	105
	106	(defn <!!
	107	"takes a val from port. Will return nil if closed. Will block
	108	if nothing is available."
	109	[port]
	110	(let [p (promise)
	111	ret (impl/take! port (fn-handler (fn [v] (deliver p v))))]
	112	(if ret
	113	@ret
	114	(deref p))))
	115
	116	(defn <!
	117	"takes a val from port. Must be called inside a (go ...) block. Will
	118	return nil if closed. Will park if nothing is available."
	119	[port]
	120	(assert nil "<! used not in (go ...) block"))
	121
	122	(defn take!
	123	"Asynchronously takes a val from port, passing to fn1. Will pass nil
	124	if closed. If on-caller? (default true) is true, and value is
	125	immediately available, will call fn1 on calling thread.
	126	Returns nil."
	127	([port fn1] (take! port fn1 true))
	128	([port fn1 on-caller?]
	129	(let [ret (impl/take! port (fn-handler fn1))]
	130	(when ret
	131	(let [val @ret]
	132	(if on-caller?
	133	(fn1 val)
	134	(dispatch/run #(fn1 val)))))
	135	nil)))
	136
	137	(defn >!!
	138	"puts a val into port. nil values are not allowed. Will block if no
	139	buffer space is available. Returns true unless port is already closed."
	140	[port val]
	141	(let [p (promise)
	142	ret (impl/put! port val (fn-handler (fn [open?] (deliver p open?))))]
	143	(if ret
	144	@ret
	145	(deref p))))
	146
	147	(defn >!
	148	"puts a val into port. nil values are not allowed. Must be called
	149	inside a (go ...) block. Will park if no buffer space is available.
	150	Returns true unless port is already closed."
	151	[port val]
	152	(assert nil ">! used not in (go ...) block"))
	153
	154	(defn- nop [_])
	155	(def ^:private fhnop (fn-handler nop))
	156
	157	(defn put!
	158	"Asynchronously puts a val into port, calling fn1 (if supplied) when
	159	complete, passing false iff port is already closed. nil values are
	160	not allowed. If on-caller? (default true) is true, and the put is
	161	immediately accepted, will call fn1 on calling thread. Returns
	162	true unless port is already closed."
	163	([port val]
	164	(if-let [ret (impl/put! port val fhnop)]
	165	@ret
	166	true))
	167	([port val fn1] (put! port val fn1 true))
	168	([port val fn1 on-caller?]
	169	(if-let [retb (impl/put! port val (fn-handler fn1))]
	170	(let [ret @retb]
	171	(if on-caller?
	172	(fn1 ret)
	173	(dispatch/run #(fn1 ret)))
	174	ret)
	175	true)))
	176
	177	(defn close!
	178	"Closes a channel. The channel will no longer accept any puts (they
	179	will be ignored). Data in the channel remains available for taking, until
	180	exhausted, after which takes will return nil. If there are any
	181	pending takes, they will be dispatched with nil. Closing a closed
	182	channel is a no-op. Returns nil.
	183
	184	Logically closing happens after all puts have been delivered. Therefore, any
	185	blocked or parked puts will remain blocked/parked until a taker releases them."
	186
	187	[chan]
	188	(impl/close! chan))
	189
	190	(defonce ^:private ^java.util.concurrent.atomic.AtomicLong id-gen (java.util.concurrent.atomic.AtomicLong.))
	191
	192	(defn- random-array
	193	[n]
	194	(let [rand (ThreadLocalRandom/current)
	195	a (int-array n)]
	196	(loop [i 1]
	197	(if (= i n)
	198	a
	199	(do
	200	(let [j (.nextInt rand (inc i))]
	201	(aset a i (aget a j))
	202	(aset a j i)
	203	(recur (inc i))))))))
	204
	205	(defn- alt-flag []
	206	(let [^Lock m (mutex/mutex)
	207	flag (atom true)
	208	id (.incrementAndGet id-gen)]
	209	(reify
	210	Lock
	211	(lock [_] (.lock m))
	212	(unlock [_] (.unlock m))
	213
	214	impl/Handler
	215	(active? [_] @flag)
	216	(blockable? [_] true)
	217	(lock-id [_] id)
	218	(commit [_]
	219	(reset! flag nil)
	220	true))))
	221
	222	(defn- alt-handler [^Lock flag cb]
	223	(reify
	224	Lock
	225	(lock [_] (.lock flag))
	226	(unlock [_] (.unlock flag))
	227
	228	impl/Handler
	229	(active? [_] (impl/active? flag))
	230	(blockable? [_] true)
	231	(lock-id [_] (impl/lock-id flag))
	232	(commit [_]
	233	(impl/commit flag)
	234	cb)))
	235
	236	(defn do-alts
	237	"returns derefable [val port] if immediate, nil if enqueued"
	238	[fret ports opts]
	239	(let [flag (alt-flag)
	240	n (count ports)
	241	^ints idxs (random-array n)
	242	priority (:priority opts)
	243	ret
	244	(loop [i 0]
	245	(when (< i n)
	246	(let [idx (if priority i (aget idxs i))
	247	port (nth ports idx)
	248	wport (when (vector? port) (port 0))
	249	vbox (if wport
	250	(let [val (port 1)]
	251	(impl/put! wport val (alt-handler flag #(fret [% wport]))))
	252	(impl/take! port (alt-handler flag #(fret [% port]))))]
	253	(if vbox
	254	(channels/box [@vbox (or wport port)])
	255	(recur (inc i))))))]
	256	(or
	257	ret
	258	(when (contains? opts :default)
	259	(.lock ^Lock flag)
	260	(let [got (and (impl/active? flag) (impl/commit flag))]
	261	(.unlock ^Lock flag)
	262	(when got
	263	(channels/box [(:default opts) :default])))))))
	264
	265	(defn alts!!
	266	"Like alts!, except takes will be made as if by <!!, and puts will
	267	be made as if by >!!, will block until completed, and not intended
	268	for use in (go ...) blocks."
	269	[ports & {:as opts}]
	270	(let [p (promise)
	271	ret (do-alts (partial deliver p) ports opts)]
	272	(if ret
	273	@ret
	274	(deref p))))
	275
	276	(defn alts!
	277	"Completes at most one of several channel operations. Must be called
	278	inside a (go ...) block. ports is a vector of channel endpoints,
	279	which can be either a channel to take from or a vector of
	280	[channel-to-put-to val-to-put], in any combination. Takes will be
	281	made as if by <!, and puts will be made as if by >!. Unless
	282	the :priority option is true, if more than one port operation is
	283	ready a non-deterministic choice will be made. If no operation is
	284	ready and a :default value is supplied, [default-val :default] will
	285	be returned, otherwise alts! will park until the first operation to
	286	become ready completes. Returns [val port] of the completed
	287	operation, where val is the value taken for takes, and a
	288	boolean (true unless already closed, as per put!) for puts.
	289
	290	opts are passed as :key val ... Supported options:
	291
	292	:default val - the value to use if none of the operations are immediately ready
	293	:priority true - (default nil) when true, the operations will be tried in order.
	294
	295	Note: there is no guarantee that the port exps or val exprs will be
	296	used, nor in what order should they be, so they should not be
	297	depended upon for side effects."
	298
	299	[ports & {:as opts}]
	300	(assert nil "alts! used not in (go ...) block"))
	301
	302	(defn do-alt [alts clauses]
	303	(assert (even? (count clauses)) "unbalanced clauses")
	304	(let [clauses (core/partition 2 clauses)
	305	opt? #(keyword? (first %))
	306	opts (filter opt? clauses)
	307	clauses (remove opt? clauses)
	308	[clauses bindings]
	309	(core/reduce
	310	(fn [[clauses bindings] [ports expr]]
	311	(let [ports (if (vector? ports) ports [ports])
	312	[ports bindings]
	313	(core/reduce
	314	(fn [[ports bindings] port]
	315	(if (vector? port)
	316	(let [[port val] port
	317	gp (gensym)
	318	gv (gensym)]
	319	[(conj ports [gp gv]) (conj bindings [gp port] [gv val])])
	320	(let [gp (gensym)]
	321	[(conj ports gp) (conj bindings [gp port])])))
	322	[[] bindings] ports)]
	323	[(conj clauses [ports expr]) bindings]))
	324	[[] []] clauses)
	325	gch (gensym "ch")
	326	gret (gensym "ret")]
	327	`(let [~@(mapcat identity bindings)
	328	[val# ~gch :as ~gret] (~alts [~@(apply concat (core/map first clauses))] ~@(apply concat opts))]
	329	(cond
	330	~@(mapcat (fn [[ports expr]]
	331	[`(or ~@(core/map (fn [port]
	332	`(= ~gch ~(if (vector? port) (first port) port)))
	333	ports))
	334	(if (and (seq? expr) (vector? (first expr)))
	335	`(let [~(first expr) ~gret] ~@(rest expr))
	336	expr)])
	337	clauses)
	338	(= ~gch :default) val#))))
	339
	340	(defmacro alt!!
	341	"Like alt!, except as if by alts!!, will block until completed, and
	342	not intended for use in (go ...) blocks."
	343
	344	[& clauses]
	345	(do-alt `alts!! clauses))
	346
	347	(defmacro alt!
	348	"Makes a single choice between one of several channel operations,
	349	as if by alts!, returning the value of the result expr corresponding
	350	to the operation completed. Must be called inside a (go ...) block.
	351
	352	Each clause takes the form of:
	353
	354	channel-op[s] result-expr
	355
	356	where channel-ops is one of:
	357
	358	take-port - a single port to take
	359	[take-port \| [put-port put-val] ...] - a vector of ports as per alts!
	360	:default \| :priority - an option for alts!
	361
	362	and result-expr is either a list beginning with a vector, whereupon that
	363	vector will be treated as a binding for the [val port] return of the
	364	operation, else any other expression.
	365
	366	(alt!
	367	[c t] ([val ch] (foo ch val))
	368	x ([v] v)
	369	[[out val]] :wrote
	370	:default 42)
	371
	372	Each option may appear at most once. The choice and parking
	373	characteristics are those of alts!."
	374
	375	[& clauses]
	376	(do-alt `alts! clauses))
	377
	378	(defn ioc-alts! [state cont-block ports & {:as opts}]
	379	(ioc/aset-all! state ioc/STATE-IDX cont-block)
	380	(when-let [cb (clojure.core.async/do-alts
	381	(fn [val]
	382	(ioc/aset-all! state ioc/VALUE-IDX val)
	383	(ioc/run-state-machine-wrapped state))
	384	ports
	385	opts)]
	386	(ioc/aset-all! state ioc/VALUE-IDX @cb)
	387	:recur))
	388
	389	(defn offer!
	390	"Puts a val into port if it's possible to do so immediately.
	391	nil values are not allowed. Never blocks. Returns true if offer succeeds."
	392	[port val]
	393	(let [ret (impl/put! port val (fn-handler nop false))]
	394	(when ret @ret)))
	395
	396	(defn poll!
	397	"Takes a val from port if it's possible to do so immediately.
	398	Never blocks. Returns value if successful, nil otherwise."
	399	[port]
	400	(let [ret (impl/take! port (fn-handler nop false))]
	401	(when ret @ret)))
	402
	403	(defmacro go
	404	"Asynchronously executes the body, returning immediately to the
	405	calling thread. Additionally, any visible calls to <!, >! and alt!/alts!
	406	channel operations within the body will block (if necessary) by
	407	'parking' the calling thread rather than tying up an OS thread (or
	408	the only JS thread when in ClojureScript). Upon completion of the
	409	operation, the body will be resumed.
	410
	411	Returns a channel which will receive the result of the body when
	412	completed"
	413	[& body]
	414	(let [crossing-env (zipmap (keys &env) (repeatedly gensym))]
	415	`(let [c# (chan 1)
	416	captured-bindings# (clojure.lang.Var/getThreadBindingFrame)]
	417	(dispatch/run
	418	(^:once fn* []
	419	(let [~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~(vary-meta l dissoc :tag))]) crossing-env)
	420	f# ~(ioc/state-machine `(do ~@body) 1 [crossing-env &env] ioc/async-custom-terminators)
	421	state# (-> (f#)
	422	(ioc/aset-all! ioc/USER-START-IDX c#
	423	ioc/BINDINGS-IDX captured-bindings#))]
	424	(ioc/run-state-machine-wrapped state#))))
	425	c#)))
	426
	427	(defonce ^:private ^Executor thread-macro-executor
	428	(Executors/newCachedThreadPool (conc/counted-thread-factory "async-thread-macro-%d" true)))
	429
	430	(defn thread-call
	431	"Executes f in another thread, returning immediately to the calling
	432	thread. Returns a channel which will receive the result of calling
	433	f when completed, then close."
	434	[f]
	435	(let [c (chan 1)]
	436	(let [binds (clojure.lang.Var/getThreadBindingFrame)]
	437	(.execute thread-macro-executor
	438	(fn []
	439	(clojure.lang.Var/resetThreadBindingFrame binds)
	440	(try
	441	(let [ret (f)]
	442	(when-not (nil? ret)
	443	(>!! c ret)))
	444	(finally
	445	(close! c))))))
	446	c))
	447
	448	(defmacro thread
	449	"Executes the body in another thread, returning immediately to the
	450	calling thread. Returns a channel which will receive the result of
	451	the body when completed, then close."
	452	[& body]
	453	`(thread-call (^:once fn* [] ~@body)))
	454
	455	;;;;;;;;;;;;;;;;;;;; ops ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	456
	457	(defmacro go-loop
	458	"Like (go (loop ...))"
	459	[bindings & body]
	460	`(go (loop ~bindings ~@body)))
	461
	462	(defn pipe
	463	"Takes elements from the from channel and supplies them to the to
	464	channel. By default, the to channel will be closed when the from
	465	channel closes, but can be determined by the close? parameter. Will
	466	stop consuming the from channel if the to channel closes"
	467	([from to] (pipe from to true))
	468	([from to close?]
	469	(go-loop []
	470	(let [v (<! from)]
	471	(if (nil? v)
	472	(when close? (close! to))
	473	(when (>! to v)
	474	(recur)))))
	475	to))
	476
	477	(defn- pipeline*
	478	([n to xf from close? ex-handler type]
	479	(assert (pos? n))
	480	(let [ex-handler (or ex-handler (fn [ex]
	481	(-> (Thread/currentThread)
	482	.getUncaughtExceptionHandler
	483	(.uncaughtException (Thread/currentThread) ex))
	484	nil))
	485	jobs (chan n)
	486	results (chan n)
	487	process (fn [[v p :as job]]
	488	(if (nil? job)
	489	(do (close! results) nil)
	490	(let [res (chan 1 xf ex-handler)]
	491	(>!! res v)
	492	(close! res)
	493	(put! p res)
	494	true)))
	495	async (fn [[v p :as job]]
	496	(if (nil? job)
	497	(do (close! results) nil)
	498	(let [res (chan 1)]
	499	(xf v res)
	500	(put! p res)
	501	true)))]
	502	(dotimes [_ n]
	503	(case type
	504	:blocking (thread
	505	(let [job (<!! jobs)]
	506	(when (process job)
	507	(recur))))
	508	:compute (go-loop []
	509	(let [job (<! jobs)]
	510	(when (process job)
	511	(recur))))
	512	:async (go-loop []
	513	(let [job (<! jobs)]
	514	(when (async job)
	515	(recur))))))
	516	(go-loop []
	517	(let [v (<! from)]
	518	(if (nil? v)
	519	(close! jobs)
	520	(let [p (chan 1)]
	521	(>! jobs [v p])
	522	(>! results p)
	523	(recur)))))
	524	(go-loop []
	525	(let [p (<! results)]
	526	(if (nil? p)
	527	(when close? (close! to))
	528	(let [res (<! p)]
	529	(loop []
	530	(let [v (<! res)]
	531	(when (and (not (nil? v)) (>! to v))
	532	(recur))))
	533	(recur))))))))
	534
	535	;;todo - switch pipe arg order to match these (to/from)
	536	(defn pipeline
	537	"Takes elements from the from channel and supplies them to the to
	538	channel, subject to the transducer xf, with parallelism n. Because
	539	it is parallel, the transducer will be applied independently to each
	540	element, not across elements, and may produce zero or more outputs
	541	per input. Outputs will be returned in order relative to the
	542	inputs. By default, the to channel will be closed when the from
	543	channel closes, but can be determined by the close? parameter. Will
	544	stop consuming the from channel if the to channel closes. Note this
	545	should be used for computational parallelism. If you have multiple
	546	blocking operations to put in flight, use pipeline-blocking instead,
	547	If you have multiple asynchronous operations to put in flight, use
	548	pipeline-async instead."
	549	([n to xf from] (pipeline n to xf from true))
	550	([n to xf from close?] (pipeline n to xf from close? nil))
	551	([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :compute)))
	552
	553	(defn pipeline-blocking
	554	"Like pipeline, for blocking operations."
	555	([n to xf from] (pipeline-blocking n to xf from true))
	556	([n to xf from close?] (pipeline-blocking n to xf from close? nil))
	557	([n to xf from close? ex-handler] (pipeline* n to xf from close? ex-handler :blocking)))
	558
	559	(defn pipeline-async
	560	"Takes elements from the from channel and supplies them to the to
	561	channel, subject to the async function af, with parallelism n. af
	562	must be a function of two arguments, the first an input value and
	563	the second a channel on which to place the result(s). af must close!
	564	the channel before returning. The presumption is that af will
	565	return immediately, having launched some asynchronous operation
	566	(i.e. in another thread) whose completion/callback will manipulate
	567	the result channel. Outputs will be returned in order relative to
	568	the inputs. By default, the to channel will be closed when the from
	569	channel closes, but can be determined by the close? parameter. Will
	570	stop consuming the from channel if the to channel closes. See also
	571	pipeline, pipeline-blocking."
	572	([n to af from] (pipeline-async n to af from true))
	573	([n to af from close?] (pipeline* n to af from close? nil :async)))
	574
	575	(defn split
	576	"Takes a predicate and a source channel and returns a vector of two
	577	channels, the first of which will contain the values for which the
	578	predicate returned true, the second those for which it returned
	579	false.
	580
	581	The out channels will be unbuffered by default, or two buf-or-ns can
	582	be supplied. The channels will close after the source channel has
	583	closed."
	584	([p ch] (split p ch nil nil))
	585	([p ch t-buf-or-n f-buf-or-n]
	586	(let [tc (chan t-buf-or-n)
	587	fc (chan f-buf-or-n)]
	588	(go-loop []
	589	(let [v (<! ch)]
	590	(if (nil? v)
	591	(do (close! tc) (close! fc))
	592	(when (>! (if (p v) tc fc) v)
	593	(recur)))))
	594	[tc fc])))
	595
	596	(defn reduce
	597	"f should be a function of 2 arguments. Returns a channel containing
	598	the single result of applying f to init and the first item from the
	599	channel, then applying f to that result and the 2nd item, etc. If
	600	the channel closes without yielding items, returns init and f is not
	601	called. ch must close before reduce produces a result."
	602	[f init ch]
	603	(go-loop [ret init]
	604	(let [v (<! ch)]
	605	(if (nil? v)
	606	ret
	607	(let [ret' (f ret v)]
	608	(if (reduced? ret')
	609	@ret'
	610	(recur ret')))))))
	611
	612	(defn transduce
	613	"async/reduces a channel with a transformation (xform f).
	614	Returns a channel containing the result. ch must close before
	615	transduce produces a result."
	616	[xform f init ch]
	617	(let [f (xform f)]
	618	(go
	619	(let [ret (<! (reduce f init ch))]
	620	(f ret)))))
	621
	622	(defn- bounded-count
	623	"Returns the smaller of n or the count of coll, without examining
	624	more than n items if coll is not counted"
	625	[n coll]
	626	(if (counted? coll)
	627	(min n (count coll))
	628	(loop [i 0 s (seq coll)]
	629	(if (and s (< i n))
	630	(recur (inc i) (next s))
	631	i))))
	632
	633	(defn onto-chan
	634	"Puts the contents of coll into the supplied channel.
	635
	636	By default the channel will be closed after the items are copied,
	637	but can be determined by the close? parameter.
	638
	639	Returns a channel which will close after the items are copied."
	640	([ch coll] (onto-chan ch coll true))
	641	([ch coll close?]
	642	(go-loop [vs (seq coll)]
	643	(if (and vs (>! ch (first vs)))
	644	(recur (next vs))
	645	(when close?
	646	(close! ch))))))
	647
	648	(defn to-chan
	649	"Creates and returns a channel which contains the contents of coll,
	650	closing when exhausted."
	651	[coll]
	652	(let [c (bounded-count 100 coll)]
	653	(if (pos? c)
	654	(let [ch (chan c)]
	655	(onto-chan ch coll)
	656	ch)
	657	(let [ch (chan)]
	658	(close! ch)
	659	ch))))
	660
	661	(defprotocol Mux
	662	(muxch* [_]))
	663
	664	(defprotocol Mult
	665	(tap* [m ch close?])
	666	(untap* [m ch])
	667	(untap-all* [m]))
	668
	669	(defn mult
	670	"Creates and returns a mult(iple) of the supplied channel. Channels
	671	containing copies of the channel can be created with 'tap', and
	672	detached with 'untap'.
	673
	674	Each item is distributed to all taps in parallel and synchronously,
	675	i.e. each tap must accept before the next item is distributed. Use
	676	buffering/windowing to prevent slow taps from holding up the mult.
	677
	678	Items received when there are no taps get dropped.
	679
	680	If a tap puts to a closed channel, it will be removed from the mult."
	681	[ch]
	682	(let [cs (atom {}) ;;ch->close?
	683	m (reify
	684	Mux
	685	(muxch* [_] ch)
	686
	687	Mult
	688	(tap* [_ ch close?] (swap! cs assoc ch close?) nil)
	689	(untap* [_ ch] (swap! cs dissoc ch) nil)
	690	(untap-all* [_] (reset! cs {}) nil))
	691	dchan (chan 1)
	692	dctr (atom nil)
	693	done (fn [_] (when (zero? (swap! dctr dec))
	694	(put! dchan true)))]
	695	(go-loop []
	696	(let [val (<! ch)]
	697	(if (nil? val)
	698	(doseq [[c close?] @cs]
	699	(when close? (close! c)))
	700	(let [chs (keys @cs)]
	701	(reset! dctr (count chs))
	702	(doseq [c chs]
	703	(when-not (put! c val done)
	704	(done nil)
	705	(untap* m c)))
	706	;;wait for all
	707	(when (seq chs)
	708	(<! dchan))
	709	(recur)))))
	710	m))
	711
	712	(defn tap
	713	"Copies the mult source onto the supplied channel.
	714
	715	By default the channel will be closed when the source closes,
	716	but can be determined by the close? parameter."
	717	([mult ch] (tap mult ch true))
	718	([mult ch close?] (tap* mult ch close?) ch))
	719
	720	(defn untap
	721	"Disconnects a target channel from a mult"
	722	[mult ch]
	723	(untap* mult ch))
	724
	725	(defn untap-all
	726	"Disconnects all target channels from a mult"
	727	[mult] (untap-all* mult))
	728
	729	(defprotocol Mix
	730	(admix* [m ch])
	731	(unmix* [m ch])
	732	(unmix-all* [m])
	733	(toggle* [m state-map])
	734	(solo-mode* [m mode]))
	735
	736	(defn mix
	737	"Creates and returns a mix of one or more input channels which will
	738	be put on the supplied out channel. Input sources can be added to
	739	the mix with 'admix', and removed with 'unmix'. A mix supports
	740	soloing, muting and pausing multiple inputs atomically using
	741	'toggle', and can solo using either muting or pausing as determined
	742	by 'solo-mode'.
	743
	744	Each channel can have zero or more boolean modes set via 'toggle':
	745
	746	:solo - when true, only this (ond other soloed) channel(s) will appear
	747	in the mix output channel. :mute and :pause states of soloed
	748	channels are ignored. If solo-mode is :mute, non-soloed
	749	channels are muted, if :pause, non-soloed channels are
	750	paused.
	751
	752	:mute - muted channels will have their contents consumed but not included in the mix
	753	:pause - paused channels will not have their contents consumed (and thus also not included in the mix)
	754	"
	755	[out]
	756	(let [cs (atom {}) ;;ch->attrs-map
	757	solo-modes #{:mute :pause}
	758	attrs (conj solo-modes :solo)
	759	solo-mode (atom :mute)
	760	change (chan)
	761	changed #(put! change true)
	762	pick (fn [attr chs]
	763	(reduce-kv
	764	(fn [ret c v]
	765	(if (attr v)
	766	(conj ret c)
	767	ret))
	768	#{} chs))
	769	calc-state (fn []
	770	(let [chs @cs
	771	mode @solo-mode
	772	solos (pick :solo chs)
	773	pauses (pick :pause chs)]
	774	{:solos solos
	775	:mutes (pick :mute chs)
	776	:reads (conj
	777	(if (and (= mode :pause) (not (empty? solos)))
	778	(vec solos)
	779	(vec (remove pauses (keys chs))))
	780	change)}))
	781	m (reify
	782	Mux
	783	(muxch* [_] out)
	784	Mix
	785	(admix* [_ ch] (swap! cs assoc ch {}) (changed))
	786	(unmix* [_ ch] (swap! cs dissoc ch) (changed))
	787	(unmix-all* [_] (reset! cs {}) (changed))
	788	(toggle* [_ state-map] (swap! cs (partial merge-with core/merge) state-map) (changed))
	789	(solo-mode* [_ mode]
	790	(assert (solo-modes mode) (str "mode must be one of: " solo-modes))
	791	(reset! solo-mode mode)
	792	(changed)))]
	793	(go-loop [{:keys [solos mutes reads] :as state} (calc-state)]
	794	(let [[v c] (alts! reads)]
	795	(if (or (nil? v) (= c change))
	796	(do (when (nil? v)
	797	(swap! cs dissoc c))
	798	(recur (calc-state)))
	799	(if (or (solos c)
	800	(and (empty? solos) (not (mutes c))))
	801	(when (>! out v)
	802	(recur state))
	803	(recur state)))))
	804	m))
	805
	806	(defn admix
	807	"Adds ch as an input to the mix"
	808	[mix ch]
	809	(admix* mix ch))
	810
	811	(defn unmix
	812	"Removes ch as an input to the mix"
	813	[mix ch]
	814	(unmix* mix ch))
	815
	816	(defn unmix-all
	817	"removes all inputs from the mix"
	818	[mix]
	819	(unmix-all* mix))
	820
	821	(defn toggle
	822	"Atomically sets the state(s) of one or more channels in a mix. The
	823	state map is a map of channels -> channel-state-map. A
	824	channel-state-map is a map of attrs -> boolean, where attr is one or
	825	more of :mute, :pause or :solo. Any states supplied are merged with
	826	the current state.
	827
	828	Note that channels can be added to a mix via toggle, which can be
	829	used to add channels in a particular (e.g. paused) state."
	830	[mix state-map]
	831	(toggle* mix state-map))
	832
	833	(defn solo-mode
	834	"Sets the solo mode of the mix. mode must be one of :mute or :pause"
	835	[mix mode]
	836	(solo-mode* mix mode))
	837
	838	(defprotocol Pub
	839	(sub* [p v ch close?])
	840	(unsub* [p v ch])
	841	(unsub-all* [p] [p v]))
	842
	843	(defn pub
	844	"Creates and returns a pub(lication) of the supplied channel,
	845	partitioned into topics by the topic-fn. topic-fn will be applied to
	846	each value on the channel and the result will determine the 'topic'
	847	on which that value will be put. Channels can be subscribed to
	848	receive copies of topics using 'sub', and unsubscribed using
	849	'unsub'. Each topic will be handled by an internal mult on a
	850	dedicated channel. By default these internal channels are
	851	unbuffered, but a buf-fn can be supplied which, given a topic,
	852	creates a buffer with desired properties.
	853
	854	Each item is distributed to all subs in parallel and synchronously,
	855	i.e. each sub must accept before the next item is distributed. Use
	856	buffering/windowing to prevent slow subs from holding up the pub.
	857
	858	Items received when there are no matching subs get dropped.
	859
	860	Note that if buf-fns are used then each topic is handled
	861	asynchronously, i.e. if a channel is subscribed to more than one
	862	topic it should not expect them to be interleaved identically with
	863	the source."
	864	([ch topic-fn] (pub ch topic-fn (constantly nil)))
	865	([ch topic-fn buf-fn]
	866	(let [mults (atom {}) ;;topic->mult
	867	ensure-mult (fn [topic]
	868	(or (get @mults topic)
	869	(get (swap! mults
	870	#(if (% topic) % (assoc % topic (mult (chan (buf-fn topic))))))
	871	topic)))
	872	p (reify
	873	Mux
	874	(muxch* [_] ch)
	875
	876	Pub
	877	(sub* [p topic ch close?]
	878	(let [m (ensure-mult topic)]
	879	(tap m ch close?)))
	880	(unsub* [p topic ch]
	881	(when-let [m (get @mults topic)]
	882	(untap m ch)))
	883	(unsub-all* [_] (reset! mults {}))
	884	(unsub-all* [_ topic] (swap! mults dissoc topic)))]
	885	(go-loop []
	886	(let [val (<! ch)]
	887	(if (nil? val)
	888	(doseq [m (vals @mults)]
	889	(close! (muxch* m)))
	890	(let [topic (topic-fn val)
	891	m (get @mults topic)]
	892	(when m
	893	(when-not (>! (muxch* m) val)
	894	(swap! mults dissoc topic)))
	895	(recur)))))
	896	p)))
	897
	898	(defn sub
	899	"Subscribes a channel to a topic of a pub.
	900
	901	By default the channel will be closed when the source closes,
	902	but can be determined by the close? parameter."
	903	([p topic ch] (sub p topic ch true))
	904	([p topic ch close?] (sub* p topic ch close?)))
	905
	906	(defn unsub
	907	"Unsubscribes a channel from a topic of a pub"
	908	[p topic ch]
	909	(unsub* p topic ch))
	910
	911	(defn unsub-all
	912	"Unsubscribes all channels from a pub, or a topic of a pub"
	913	([p] (unsub-all* p))
	914	([p topic] (unsub-all* p topic)))
	915
	916	;;; these are down here because they alias core fns, don't want accidents above
	917
	918	(defn map
	919	"Takes a function and a collection of source channels, and returns a
	920	channel which contains the values produced by applying f to the set
	921	of first items taken from each source channel, followed by applying
	922	f to the set of second items from each channel, until any one of the
	923	channels is closed, at which point the output channel will be
	924	closed. The returned channel will be unbuffered by default, or a
	925	buf-or-n can be supplied"
	926	([f chs] (map f chs nil))
	927	([f chs buf-or-n]
	928	(let [chs (vec chs)
	929	out (chan buf-or-n)
	930	cnt (count chs)
	931	rets (object-array cnt)
	932	dchan (chan 1)
	933	dctr (atom nil)
	934	done (mapv (fn [i]
	935	(fn [ret]
	936	(aset rets i ret)
	937	(when (zero? (swap! dctr dec))
	938	(put! dchan (java.util.Arrays/copyOf rets cnt)))))
	939	(range cnt))]
	940	(go-loop []
	941	(reset! dctr cnt)
	942	(dotimes [i cnt]
	943	(try
	944	(take! (chs i) (done i))
	945	(catch Exception e
	946	(swap! dctr dec))))
	947	(let [rets (<! dchan)]
	948	(if (some nil? rets)
	949	(close! out)
	950	(do (>! out (apply f rets))
	951	(recur)))))
	952	out)))
	953
	954	(defn merge
	955	"Takes a collection of source channels and returns a channel which
	956	contains all values taken from them. The returned channel will be
	957	unbuffered by default, or a buf-or-n can be supplied. The channel
	958	will close after all the source channels have closed."
	959	([chs] (merge chs nil))
	960	([chs buf-or-n]
	961	(let [out (chan buf-or-n)]
	962	(go-loop [cs (vec chs)]
	963	(if (pos? (count cs))
	964	(let [[v c] (alts! cs)]
	965	(if (nil? v)
	966	(recur (filterv #(not= c %) cs))
	967	(do (>! out v)
	968	(recur cs))))
	969	(close! out)))
	970	out)))
	971
	972	(defn into
	973	"Returns a channel containing the single (collection) result of the
	974	items taken from the channel conjoined to the supplied
	975	collection. ch must close before into produces a result."
	976	[coll ch]
	977	(reduce conj coll ch))
	978
	979
	980	(defn take
	981	"Returns a channel that will return, at most, n items from ch. After n items
	982	have been returned, or ch has been closed, the return channel will close.
	983
	984	The output channel is unbuffered by default, unless buf-or-n is given."
	985	([n ch]
	986	(take n ch nil))
	987	([n ch buf-or-n]
	988	(let [out (chan buf-or-n)]
	989	(go (loop [x 0]
	990	(when (< x n)
	991	(let [v (<! ch)]
	992	(when (not (nil? v))
	993	(>! out v)
	994	(recur (inc x))))))
	995	(close! out))
	996	out)))
	997
	998	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; deprecated - do not use ;;;;;;;;;;;;;;;;;;;;;;;;;
	999	(defn map<
	1000	"Deprecated - this function will be removed. Use transducer instead"
	1001	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1002	[f ch]
	1003	(reify
	1004	impl/Channel
	1005	(close! [_] (impl/close! ch))
	1006	(closed? [_] (impl/closed? ch))
	1007
	1008	impl/ReadPort
	1009	(take! [_ fn1]
	1010	(let [ret
	1011	(impl/take! ch
	1012	(reify
	1013	Lock
	1014	(lock [_] (.lock ^Lock fn1))
	1015	(unlock [_] (.unlock ^Lock fn1))
	1016
	1017	impl/Handler
	1018	(active? [_] (impl/active? fn1))
	1019	(blockable? [_] true)
	1020	(lock-id [_] (impl/lock-id fn1))
	1021	(commit [_]
	1022	(let [f1 (impl/commit fn1)]
	1023	#(f1 (if (nil? %) nil (f %)))))))]
	1024	(if (and ret (not (nil? @ret)))
	1025	(channels/box (f @ret))
	1026	ret)))
	1027
	1028	impl/WritePort
	1029	(put! [_ val fn1] (impl/put! ch val fn1))))
	1030
	1031	(defn map>
	1032	"Deprecated - this function will be removed. Use transducer instead"
	1033	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1034	[f ch]
	1035	(reify
	1036	impl/Channel
	1037	(close! [_] (impl/close! ch))
	1038	(closed? [_] (impl/closed? ch))
	1039
	1040	impl/ReadPort
	1041	(take! [_ fn1] (impl/take! ch fn1))
	1042
	1043	impl/WritePort
	1044	(put! [_ val fn1]
	1045	(impl/put! ch (f val) fn1))))
	1046
	1047	(defn filter>
	1048	"Deprecated - this function will be removed. Use transducer instead"
	1049	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1050	[p ch]
	1051	(reify
	1052	impl/Channel
	1053	(close! [_] (impl/close! ch))
	1054	(closed? [_] (impl/closed? ch))
	1055
	1056	impl/ReadPort
	1057	(take! [_ fn1] (impl/take! ch fn1))
	1058
	1059	impl/WritePort
	1060	(put! [_ val fn1]
	1061	(if (p val)
	1062	(impl/put! ch val fn1)
	1063	(channels/box (not (impl/closed? ch)))))))
	1064
	1065	(defn remove>
	1066	"Deprecated - this function will be removed. Use transducer instead"
	1067	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1068	[p ch]
	1069	(filter> (complement p) ch))
	1070
	1071	(defn filter<
	1072	"Deprecated - this function will be removed. Use transducer instead"
	1073	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1074	([p ch] (filter< p ch nil))
	1075	([p ch buf-or-n]
	1076	(let [out (chan buf-or-n)]
	1077	(go-loop []
	1078	(let [val (<! ch)]
	1079	(if (nil? val)
	1080	(close! out)
	1081	(do (when (p val)
	1082	(>! out val))
	1083	(recur)))))
	1084	out)))
	1085
	1086	(defn remove<
	1087	"Deprecated - this function will be removed. Use transducer instead"
	1088	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1089	([p ch] (remove< p ch nil))
	1090	([p ch buf-or-n] (filter< (complement p) ch buf-or-n)))
	1091
	1092	(defn- mapcat* [f in out]
	1093	(go-loop []
	1094	(let [val (<! in)]
	1095	(if (nil? val)
	1096	(close! out)
	1097	(do (doseq [v (f val)]
	1098	(>! out v))
	1099	(when-not (impl/closed? out)
	1100	(recur)))))))
	1101
	1102	(defn mapcat<
	1103	"Deprecated - this function will be removed. Use transducer instead"
	1104	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1105	([f in] (mapcat< f in nil))
	1106	([f in buf-or-n]
	1107	(let [out (chan buf-or-n)]
	1108	(mapcat* f in out)
	1109	out)))
	1110
	1111	(defn mapcat>
	1112	"Deprecated - this function will be removed. Use transducer instead"
	1113	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1114	([f out] (mapcat> f out nil))
	1115	([f out buf-or-n]
	1116	(let [in (chan buf-or-n)]
	1117	(mapcat* f in out)
	1118	in)))
	1119
	1120	(defn unique
	1121	"Deprecated - this function will be removed. Use transducer instead"
	1122	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1123	([ch]
	1124	(unique ch nil))
	1125	([ch buf-or-n]
	1126	(let [out (chan buf-or-n)]
	1127	(go (loop [last nil]
	1128	(let [v (<! ch)]
	1129	(when (not (nil? v))
	1130	(if (= v last)
	1131	(recur last)
	1132	(do (>! out v)
	1133	(recur v))))))
	1134	(close! out))
	1135	out)))
	1136
	1137
	1138	(defn partition
	1139	"Deprecated - this function will be removed. Use transducer instead"
	1140	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1141	([n ch]
	1142	(partition n ch nil))
	1143	([n ch buf-or-n]
	1144	(let [out (chan buf-or-n)]
	1145	(go (loop [arr (make-array Object n)
	1146	idx 0]
	1147	(let [v (<! ch)]
	1148	(if (not (nil? v))
	1149	(do (aset ^objects arr idx v)
	1150	(let [new-idx (inc idx)]
	1151	(if (< new-idx n)
	1152	(recur arr new-idx)
	1153	(do (>! out (vec arr))
	1154	(recur (make-array Object n) 0)))))
	1155	(do (when (> idx 0)
	1156	(let [narray (make-array Object idx)]
	1157	(System/arraycopy arr 0 narray 0 idx)
	1158	(>! out (vec narray))))
	1159	(close! out))))))
	1160	out)))
	1161
	1162
	1163	(defn partition-by
	1164	"Deprecated - this function will be removed. Use transducer instead"
	1165	{:deprecated "0.1.319.0-6b1aca-alpha"}
	1166	([f ch]
	1167	(partition-by f ch nil))
	1168	([f ch buf-or-n]
	1169	(let [out (chan buf-or-n)]
	1170	(go (loop [lst (ArrayList.)
	1171	last ::nothing]
	1172	(let [v (<! ch)]
	1173	(if (not (nil? v))
	1174	(let [new-itm (f v)]
	1175	(if (or (= new-itm last)
	1176	(identical? last ::nothing))
	1177	(do (.add ^ArrayList lst v)
	1178	(recur lst new-itm))
	1179	(do (>! out (vec lst))
	1180	(let [new-lst (ArrayList.)]
	1181	(.add ^ArrayList new-lst v)
	1182	(recur new-lst new-itm)))))
	1183	(do (when (> (.size ^ArrayList lst) 0)
	1184	(>! out (vec lst)))
	1185	(close! out))))))
	1186	out)))

+41

-0

src/main/java/clojure/core/async/Mutex.java less more

	0	/*
	1	Copyright (c) Rich Hickey and contributors. All rights reserved.
	2	The use and distribution terms for this software are covered by the
	3	Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	4	which can be found in the file epl-v10.html at the root of this distribution.
	5	By using this software in any fashion, you are agreeing to be bound by
	6	the terms of this license.
	7	You must not remove this notice, or any other, from this software.
	8	*/
	9
	10	package clojure.core.async;
	11
	12	import java.util.concurrent.locks.AbstractQueuedSynchronizer;
	13
	14	// non-recursive, non-reentrant mutex implementation based on example
	15	// from Doug Lea's "The java.util.concurrent Synchronizer Framework"
	16	// http://gee.cs.oswego.edu/dl/papers/aqs.pdf
	17	public class Mutex {
	18	private static class Sync extends AbstractQueuedSynchronizer {
	19	public boolean tryAcquire(int ignored) {
	20	return compareAndSetState(0, 1);
	21	}
	22
	23	public boolean tryRelease(int ignored) {
	24	setState(0);
	25	return true;
	26	}
	27	}
	28
	29	private final Sync sync = new Sync();
	30
	31	public Mutex() {}
	32
	33	public void lock() {
	34	sync.acquire(1);
	35	}
	36
	37	public void unlock() {
	38	sync.release(1);
	39	}
	40	}

+48

-0

src/main/java/clojure/core/async/ThreadLocalRandom.java less more

	0	/*
	1	Copyright (c) Rich Hickey and contributors. All rights reserved.
	2	The use and distribution terms for this software are covered by the
	3	Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	4	which can be found in the file epl-v10.html at the root of this distribution.
	5	By using this software in any fashion, you are agreeing to be bound by
	6	the terms of this license.
	7	You must not remove this notice, or any other, from this software.
	8	*/
	9
	10	package clojure.core.async;
	11
	12	import java.util.Random;
	13
	14	public class ThreadLocalRandom extends Random {
	15
	16	private static final long serialVersionUID = -2599376724352996934L;
	17
	18	private static ThreadLocal<ThreadLocalRandom> currentThreadLocalRandom = new ThreadLocal<ThreadLocalRandom>() {
	19	protected ThreadLocalRandom initialValue() {
	20	return new ThreadLocalRandom();
	21	}
	22	};
	23
	24
	25	/**
	26	* Returns the current ThreadLocalRandom for this thread. Clients must call current,
	27	* rather than constructing instances themselves. The ThreadLocalRandom instance will
	28	* be returned from a ThreadLocal variable.
	29	*
	30	* @return A ThreadLocalRandom for the current thread
	31	*
	32	* @see ThreadLocal
	33	* @see Random
	34	*/
	35	public static ThreadLocalRandom current() {
	36	return currentThreadLocalRandom.get();
	37	}
	38
	39	private ThreadLocalRandom() {
	40	super();
	41	}
	42
	43	private ThreadLocalRandom(long seed) {
	44	super(seed);
	45	}
	46
	47	}

+111

-0

src/test/cljs/cljs/core/async/buffer_tests.cljs less more

	0	(ns cljs.core.async.buffer-tests
	1	(:require-macros [cljs.core.async.macros :as m :refer [go]])
	2	(:require [cljs.core.async
	3	:refer [unblocking-buffer? buffer dropping-buffer sliding-buffer
	4	put! take! chan close!]]
	5	[cljs.core.async.impl.dispatch :as dispatch]
	6	[cljs.core.async.impl.buffers :as buff :refer [promise-buffer]]
	7	[cljs.core.async.impl.protocols
	8	:refer [full? add! remove! close-buf!]]
	9	[cljs.core.async.test-helpers :refer-macros [throws?]]
	10	[cljs.test :refer-macros [deftest testing is]]))
	11
	12	(deftest unblocking-buffer-tests
	13	(testing "buffers"
	14	(is (not (unblocking-buffer? (buffer 1))))
	15	(is (unblocking-buffer? (dropping-buffer 1)))
	16	(is (unblocking-buffer? (sliding-buffer 1)))))
	17
	18	(deftest buffer-tests
	19	(testing "fixed-buffer"
	20	(let [fb (buffer 2)]
	21	(is (= 0 (count fb)))
	22
	23	(add! fb :1)
	24	(is (= 1 (count fb)))
	25
	26	(add! fb :2)
	27	(is (= 2 (count fb)))
	28
	29	(is (full? fb))
	30	#_(assert (throws? (add! fb :3)))
	31
	32	(is (= :1 (remove! fb)))
	33	(is (not (full? fb)))
	34
	35	(is (= 1 (count fb)))
	36	(is (= :2 (remove! fb)))
	37
	38	(is (= 0 (count fb)))
	39	#_(is (helpers/throws? (remove! fb)))))
	40
	41	(testing "dropping-buffer"
	42	(let [fb (dropping-buffer 2)]
	43	(is (= 0 (count fb)))
	44
	45	(add! fb :1)
	46	(is (= 1 (count fb)))
	47
	48	(add! fb :2)
	49	(is (= 2 (count fb)))
	50
	51	(is (not (full? fb)))
	52	(add! fb :3)
	53
	54	(is (= 2 (count fb)))
	55
	56	(is (= :1 (remove! fb)))
	57	(is (not (full? fb)))
	58
	59	(is (= 1 (count fb)))
	60	(is (= :2 (remove! fb)))
	61
	62	(is (= 0 (count fb)))
	63	#_(is (throws? (remove! fb)))))
	64
	65	(testing "sliding-buffer"
	66	(let [fb (sliding-buffer 2)]
	67	(is (= 0 (count fb)))
	68
	69	(add! fb :1)
	70	(is (= 1 (count fb)))
	71
	72	(add! fb :2)
	73	(is (= 2 (count fb)))
	74
	75	(is (not (full? fb)))
	76	(add! fb :3)
	77
	78	(is (= 2 (count fb)))
	79
	80	(is (= :2 (remove! fb)))
	81	(is (not (full? fb)))
	82
	83	(is (= 1 (count fb)))
	84	(is (= :3 (remove! fb)))
	85
	86	(is (= 0 (count fb)))
	87	#_(is (throws? (remove! fb))))))
	88
	89	(deftest promise-buffer-tests
	90	(let [pb (promise-buffer)]
	91	(is (= 0 (count pb)))
	92
	93	(add! pb :1)
	94	(is (= 1 (count pb)))
	95
	96	(add! pb :2)
	97	(is (= 1 (count pb)))
	98
	99	(is (not (full? pb)))
	100	(is (not (throws? (add! pb :3))))
	101	(is (= 1 (count pb)))
	102
	103	(is (= :1 (remove! pb)))
	104	(is (not (full? pb)))
	105
	106	(is (= 1 (count pb)))
	107	(is (= :1 (remove! pb)))
	108
	109	(is (= nil (close-buf! pb)))
	110	(is (= :1 (remove! pb)))))

+117

-0

src/test/cljs/cljs/core/async/pipeline_test.cljs less more

	0	(ns cljs.core.async.pipeline-test
	1	(:require-macros [cljs.core.async.macros :as m :refer [go go-loop]])
	2	(:require [cljs.core.async.test-helpers :refer [latch inc!]]
	3	[cljs.core.async :as a
	4	:refer [<! >! chan close! to-chan pipeline-async pipeline put!]]
	5	[cljs.test :refer-macros [deftest is testing async]]))
	6
	7	(defn pipeline-tester [pipeline-fn n inputs xf]
	8	(let [cin (to-chan inputs)
	9	cout (chan 1)]
	10	(pipeline-fn n cout xf cin)
	11	(go-loop [acc []]
	12	(let [val (<! cout)]
	13	(if (not (nil? val))
	14	(recur (conj acc val))
	15	acc)))))
	16
	17	(defn identity-async [v ch]
	18	(go (>! ch v) (close! ch)))
	19
	20	(defn test-size-async [n size]
	21	(let [r (range size)]
	22	(go (is (= r (<! (pipeline-tester pipeline-async n r identity-async)))))))
	23
	24	(defn test-size-compute [n size]
	25	(let [r (range size)]
	26	(go (is (= r (<! (pipeline-tester pipeline n r (map identity))))))))
	27
	28	(deftest pipeline-test-sizes
	29	(async done
	30	(let [l (latch 2 done)]
	31	(testing "pipeline async test sizes"
	32	(go
	33	(<! (test-size-async 1 0))
	34	(<! (test-size-async 1 10))
	35	(<! (test-size-async 10 10))
	36	(<! (test-size-async 20 10))
	37	(<! (test-size-async 5 1000))
	38	(inc! l)))
	39	(testing "pipeline compute test sizes"
	40	(go
	41	(<! (test-size-compute 1 0))
	42	(<! (test-size-compute 1 10))
	43	(<! (test-size-compute 10 10))
	44	(<! (test-size-compute 20 10))
	45	(<! (test-size-compute 5 1000))
	46	(inc! l))))))
	47
	48	(deftest test-close?
	49	(async done
	50	(go
	51	(let [cout (chan 1)]
	52	(pipeline 5 cout (map identity) (to-chan [1]) true)
	53	(is (= 1 (<! cout)))
	54	(is (= nil (<! cout))))
	55	(let [cout (chan 1)]
	56	(pipeline 5 cout (map identity) (to-chan [1]) false)
	57	(is (= 1 (<! cout)))
	58	(>! cout :more)
	59	(is (= :more (<! cout))))
	60	(let [cout (chan 1)]
	61	(pipeline 5 cout (map identity) (to-chan [1]) nil)
	62	(is (= 1 (<! cout)))
	63	(>! cout :more)
	64	(is (= :more (<! cout))))
	65	(done))))
	66
	67	(deftest test-ex-handler
	68	(async done
	69	(go
	70	(let [cout (chan 1)
	71	chex (chan 1)
	72	ex-mapping (map (fn [x] (if (= x 3) (throw (ex-info "err" {:data x})) x)))
	73	ex-handler (fn [e] (do (put! chex e) :err))]
	74	(pipeline 5 cout ex-mapping (to-chan [1 2 3 4]) true ex-handler)
	75	(is (= 1 (<! cout)))
	76	(is (= 2 (<! cout)))
	77	(is (= :err (<! cout)))
	78	(is (= 4 (<! cout)))
	79	(is (= {:data 3} (ex-data (<! chex)))))
	80	(done))))
	81
	82	(defn multiplier-async [v ch]
	83	(go
	84	(dotimes [i v]
	85	(>! ch i))
	86	(close! ch)))
	87
	88	(deftest async-pipelines-af-multiplier
	89	(async done
	90	(go
	91	(is (= [0 0 1 0 1 2 0 1 2 3]
	92	(<! (pipeline-tester pipeline-async 2 (range 1 5) multiplier-async))))
	93	(done))))
	94
	95	(defn incrementer-async [v ch]
	96	(go
	97	(>! ch (inc v))
	98	(close! ch)))
	99
	100	(deftest pipelines-async
	101	(async done
	102	(go
	103	(is (= (range 1 101)
	104	(<! (pipeline-tester pipeline-async 1 (range 100) incrementer-async))))
	105	(done))))
	106
	107	(defn slow-fib [n]
	108	(if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2)))))
	109
	110	(deftest pipelines-compute
	111	(async done
	112	(let [input (take 50 (cycle (range 15 38)))]
	113	(go
	114	(is (= (slow-fib (last input))
	115	(last (<! (pipeline-tester pipeline 8 input (map slow-fib))))))
	116	(done)))))

+239

-0

src/test/cljs/cljs/core/async/runner_tests.cljs less more

	0	(ns cljs.core.async.runner-tests
	1	(:require [cljs.core.async :refer [buffer dropping-buffer sliding-buffer put! take! chan close!]]
	2	[cljs.core.async.impl.dispatch :as dispatch]
	3	[cljs.core.async.impl.buffers :as buff]
	4	[cljs.core.async.impl.protocols :refer [full? add! remove!]]
	5	[cljs.core.async.impl.ioc-helpers :as ioch])
	6	(:require-macros [cljs.core.async.test-helpers :as h :refer [is= is deftest testing runner locals-test]]
	7	[cljs.core.async.macros :as m :refer [go]]
	8	[cljs.core.async.impl.ioc-macros :as ioc]))
	9
	10	(defn pause [state blk val]
	11	(ioc/aset-all! state ioch/STATE-IDX blk ioch/VALUE-IDX val)
	12	:recur)
	13
	14	(deftest runner-tests
	15	(testing "macros add locals to the env"
	16	(is= :pass
	17	(runner (let [x 42]
	18	(pause (locals-test))))))
	19	(testing "do blocks"
	20	(is= 42
	21	(runner (do (pause 42))))
	22	(is= 42
	23	(runner (do (pause 44)
	24	(pause 42)))))
	25	(testing "if expressions"
	26	(is= true
	27	(runner (if (pause true)
	28	(pause true)
	29	(pause false))))
	30	(is= false
	31	(runner (if (pause false)
	32	(pause true)
	33	(pause false))))
	34	(is= true
	35	(runner (when (pause true)
	36	(pause true))))
	37	(is= nil
	38	(runner (when (pause false)
	39	(pause true)))))
	40
	41	(testing "loop expressions"
	42	(is= 100
	43	(runner (loop [x 0]
	44	(if (< x 100)
	45	(recur (inc (pause x)))
	46	(pause x)))))
	47	(is= [:b :a]
	48	(runner (loop [a :a b :b n 1]
	49	(if (pos? n)
	50	(recur b a (dec n)) ;; swap bindings
	51	[a b]))))
	52	(is= 1
	53	(runner (loop [x 0
	54	y (inc x)]
	55	y))))
	56
	57	(testing "let expressions"
	58	(is= 3
	59	(runner (let [x 1 y 2]
	60	(+ x y)))))
	61
	62	(testing "vector destructuring"
	63	(is= 3
	64	(runner (let [[x y] [1 2]]
	65	(+ x y)))))
	66
	67	(testing "hash-map destructuring"
	68	(is= 3
	69	(runner (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}]
	70	(assert (and foo (pause x) y x2 y2 foo))
	71	(+ x y)))))
	72
	73	(testing "hash-map literals"
	74	(is= {:1 1 :2 2 :3 3}
	75	(runner {:1 (pause 1)
	76	:2 (pause 2)
	77	:3 (pause 3)})))
	78	(testing "hash-set literals"
	79	(is= #{1 2 3}
	80	(runner #{(pause 1)
	81	(pause 2)
	82	(pause 3)})))
	83	(testing "vector literals"
	84	(is= [1 2 3]
	85	(runner [(pause 1)
	86	(pause 2)
	87	(pause 3)])))
	88	(testing "dotimes"
	89	(is= 42 (runner
	90	(dotimes [x 10]
	91	(pause x))
	92	42)))
	93
	94	(testing "set! with field"
	95	(let [x (js-obj)]
	96	(runner (set! (.-foo x) "bar")
	97	(is= (.-foo x) "bar"))
	98	(is= (.-foo x) "bar")))
	99
	100	(testing "set! with var"
	101	(def test-target 0)
	102	(runner (set! test-target 42))
	103	(is= test-target 42))
	104
	105	(testing "keywords as functions"
	106	(is (= :bar
	107	(runner (:foo (pause {:foo :bar}))))))
	108
	109	(testing "vectors as functions"
	110	(is (= 2
	111	(runner ([1 2] 1)))))
	112
	113	(testing "dot forms"
	114	(is (= 8 (runner (. js/Math (pow 2 3)))))
	115	(is (= 8 (runner (. js/Math pow 2 3)))))
	116
	117	(testing "quote"
	118	(is= '(1 2 3)
	119	(runner (pause '(1 2 3)))))
	120
	121	(testing "fn closures"
	122	(is= 42
	123	(runner
	124	(let [x 42
	125	_ (pause x)
	126	f (fn [] x)]
	127	(f)))))
	128
	129	(testing "case"
	130	(is= 43
	131	(runner
	132	(let [value :bar]
	133	(case value
	134	:foo (pause 42)
	135	:bar (pause 43)
	136	:baz (pause 44)))))
	137	(is= :default
	138	(runner
	139	(case :baz
	140	:foo 44
	141	:default)))
	142	(is= nil
	143	(runner
	144	(case true
	145	false false
	146	nil)))
	147	(is= 42
	148	(runner
	149	(loop [x 0]
	150	(case (int x)
	151	0 (recur (inc x))
	152	1 42)))))
	153
	154	(testing "try"
	155	(is= 42
	156	(runner
	157	(try 42
	158	(catch js/Error ex ex))))
	159	(is= 42
	160	(runner
	161	(try
	162	(assert false)
	163	(catch js/Error ex 42))))
	164
	165	(is= 42
	166	(runner
	167	(try
	168	(assert false)
	169	(catch :default ex 42))))
	170
	171	(let [a (atom false)
	172	v (runner
	173	(try
	174	true
	175	(catch js/Error ex false)
	176	(finally (pause (reset! a true)))))]
	177	(is (and @a v)))
	178
	179	(let [a (atom false)
	180	v (runner
	181	(try
	182	(assert false)
	183	(catch js/Error ex true)
	184	(finally (reset! a true))))]
	185	(is (and @a v)))
	186
	187
	188	(let [a (atom false)
	189	v (try (runner
	190	(try
	191	(assert false)
	192	(finally (reset! a true))))
	193	(catch js/Error ex ex))]
	194	(is (and @a v)))
	195
	196
	197	(let [a (atom 0)
	198	v (runner
	199	(try
	200	(try
	201	42
	202	(finally (swap! a inc)))
	203	(finally (swap! a inc))))]
	204	(is (= @a 2)))
	205
	206	(let [a (atom 0)
	207	v (try (runner
	208	(try
	209	(try
	210	(assert false)
	211	(finally (swap! a inc)))
	212	(finally (swap! a inc))))
	213	(catch js/Error ex ex))]
	214	(is (= @a 2)))
	215
	216	(let [a (atom 0)
	217	v (try (runner
	218	(try
	219	(try
	220	(assert false)
	221	(catch js/Error ex (throw ex))
	222	(finally (swap! a inc)))
	223	(catch js/Error ex (throw ex))
	224	(finally (swap! a inc))))
	225	(catch js/Error ex ex))]
	226	(is (= @a 2)))
	227
	228	(let [a (atom 0)
	229	v (try (runner
	230	(try
	231	(try
	232	(assert false)
	233	(catch js/Error ex (pause (throw ex)))
	234	(finally (pause (swap! a inc))))
	235	(catch js/Error ex (pause (throw ex)))
	236	(finally (pause (swap! a inc)))))
	237	(catch js/Error ex ex))]
	238	(is (= @a 2)))))

+59

-0

src/test/cljs/cljs/core/async/test_helpers.clj less more

	0	(ns cljs.core.async.test-helpers
	1	(:require [cljs.core.async.impl.ioc-macros :as ioc]))
	2
	3	(defmacro runner
	4	"Creates a runner block. The code inside the body of this macro will be translated
	5	into a state machine. At run time the body will be run as normal. This transform is
	6	only really useful for testing."
	7	[& body]
	8	(let [terminators {'pause 'cljs.core.async.runner-tests/pause}]
	9	`(let [state# (~(ioc/state-machine body 0 &env terminators))]
	10	(cljs.core.async.impl.ioc-helpers/run-state-machine state#)
	11	(assert (cljs.core.async.impl.ioc-helpers/finished? state#) "state did not return finished")
	12	(aget state# ~ioc/VALUE-IDX))))
	13
	14	(defmacro assert-go-block-completes
	15	[nm & body]
	16	`(let [body-chan# (do ~@body)
	17	timeout# (fn [] (let [c# (cljs.core.async/chan)]
	18	(cljs.core.async.macros/go
	19	(cljs.core.async/<! (cljs.core.async/timeout 10000))
	20	(cljs.core.async/>! c# ::timeout)
	21	(cljs.core.async/close! c#))
	22	c#))]
	23	(when (satisfies? cljs.core.async.impl.protocols.Channel body-chan#)
	24	(cljs.core.async.macros/go
	25	(let [[v# _] (cljs.core.async/alts! [body-chan# (timeout#)] :priority true)]
	26	(assert (not= ::timeout v#)
	27	(str "test timed out: " ~nm ))))
	28	true)))
	29
	30	(defmacro deftest
	31	[nm & body]
	32	`(do (.log js/console (str "Testing: " ~(str nm) "..."))
	33	(assert-go-block-completes ~(str nm) ~@body)))
	34
	35	(defmacro throws?
	36	[& exprs]
	37	`(try ~@exprs false
	38	(catch ~'js/Object e# true)))
	39
	40	(defmacro testing
	41	[nm & body]
	42	`(do (.log js/console (str " " ~nm "..."))
	43	(assert-go-block-completes ~(str nm) ~@body)))
	44
	45	(defmacro is=
	46	[a b]
	47	`(let [a# ~a
	48	b# ~b]
	49	(assert (= a# b#) (str a# " != " b#))))
	50
	51	(defmacro is
	52	[a]
	53	`(assert ~a))
	54
	55	(defmacro locals-test []
	56	(if (get-in &env [:locals] 'x)
	57	:pass
	58	:fail))

+11

-0

src/test/cljs/cljs/core/async/test_helpers.cljs less more

	0	(ns cljs.core.async.test-helpers)
	1
	2	(defn latch [m f]
	3	(let [r (atom 0)]
	4	(add-watch r :latch
	5	(fn [_ _ o n]
	6	(when (== n m) (f))))
	7	r))
	8
	9	(defn inc! [r]
	10	(swap! r inc))

+10

-0

src/test/cljs/cljs/core/async/test_runner.cljs less more

	0	(ns cljs.core.async.test-runner
	1	(:require [cljs.test :refer-macros [run-tests]]
	2	[cljs.core.async.buffer-tests]
	3	[cljs.core.async.pipeline-test]
	4	[cljs.core.async.tests]))
	5
	6	(run-tests
	7	'cljs.core.async.pipeline-test
	8	'cljs.core.async.buffer-tests
	9	'cljs.core.async.tests)

+469

-0

src/test/cljs/cljs/core/async/tests.cljs less more

	0	(ns cljs.core.async.tests
	1	(:require-macros
	2	[cljs.core.async.macros :as m :refer [go alt!]])
	3	(:require
	4	[cljs.core.async :refer
	5	[buffer dropping-buffer sliding-buffer put! take! chan promise-chan
	6	close! take partition-by offer! poll! <! >! alts!] :as async]
	7	[cljs.core.async.impl.dispatch :as dispatch]
	8	[cljs.core.async.impl.buffers :as buff]
	9	[cljs.core.async.impl.timers :as timers :refer [timeout]]
	10	[cljs.core.async.impl.protocols :refer [full? add! remove!]]
	11	[cljs.core.async.test-helpers :refer [latch inc!]]
	12	[cljs.test :as test :refer-macros [deftest is run-tests async testing]]))
	13
	14	(enable-console-print!)
	15
	16	(deftest test-put-take-chan-1
	17	(async done
	18	(let [c (chan 1)
	19	l (latch 2 done)]
	20	(put! c 42 #(do (is true) (inc! l)))
	21	(take! c #(do (is (= 42 %))) (inc! l)))))
	22
	23	(deftest test-put-take-chan
	24	(async done
	25	(let [c (chan)
	26	l (latch 2 done)]
	27	(put! c 42 #(do (is true) (inc! l)))
	28	(take! c #(do (is (= 42 %))) (inc! l)))))
	29
	30	(defn identity-chan
	31	[x]
	32	(let [c (chan 1)]
	33	(go (>! c x)
	34	(close! c))
	35	c))
	36
	37	(defn debug [x]
	38	(.log js/console x)
	39	x)
	40
	41	(deftest test-identity-chan
	42	(async done
	43	(go
	44	(is (= (<! (identity-chan 42)) 42))
	45	(done))))
	46
	47	(deftest test-identity-chan-alts!
	48	(async done
	49	(let [c (identity-chan 42)]
	50	(go
	51	(is (= [42 c] (alts! [c])))
	52	(done)))))
	53
	54	(deftest alt-tests
	55	(async done
	56	(testing "alts! works at all"
	57	(let [c (identity-chan 42)]
	58	(go
	59	(is (= [42 c] (alts! [c])))
	60	(done))))))
	61
	62	(deftest test-alt!-and-alts!
	63	(async done
	64	(let [l (latch 2 done)]
	65	(testing "alt! works"
	66	(go
	67	(is (= [42 :foo] (alt! (identity-chan 42) ([v] [v :foo]))))
	68	(inc! l)))
	69	(testing "alts! can use default"
	70	(go
	71	(is
	72	(= [42 :default]
	73	(alts! [(chan 1)] :default 42)))
	74	(inc! l))))))
	75
	76	#_(deftest timeout-tests
	77	(async done
	78	(let [l (latch 2 done)]
	79	(testing "timeout will return same channel if within delay"
	80	(is (= (timeout 10) (timeout 10)))
	81	(is (= 1 (count (seq timers/timeouts-map)))))
	82	(testing "timeout map is empty after timeout expires"
	83	(go
	84	(<! (timeout 300))
	85	(is (= 0 (count (seq timers/timeouts-map))))
	86	(inc! l)))
	87	(testing "timeout map is empty after timeout expires with namespaced take"
	88	(go
	89	(async/<! (timeout 300))
	90	(is (= 0 (count (seq timers/timeouts-map))))
	91	(inc! l))))))
	92
	93	(deftest queue-limits
	94	(testing "async put!s are limited"
	95	(let [c (chan)]
	96	(dotimes [x 1024]
	97	(put! c x))
	98	(is (thrown? js/Error (put! c 42)))
	99	(take! c (fn [x] (is (= x 0))))))
	100	(testing "async take!s are limited"
	101	(let [c (chan)]
	102	(dotimes [x 1024]
	103	(take! c (fn [x])))
	104	(is (thrown? js/Error (take! c (fn [x]))))
	105	(put! c 42))))
	106
	107	(deftest close-on-exception-tests
	108	(async done
	109	(let [l (latch 2 done)]
	110	(testing "go blocks"
	111	(go
	112	(alt! (go (assert false "This exception is expected"))
	113	([v] (is (nil? v)) (inc! l))
	114	;; if this fails, channel did not close
	115	(timeout 500) ([v] (is false) (inc! l)))
	116	(alt! (go (alts! [(identity-chan 42)])
	117	(assert false "This exception is expected"))
	118	([v] (is (nil? v)) (inc! l))
	119	;; if this fails, channel did not close
	120	(timeout 500) ([v] (is false) (inc! l))))))))
	121
	122	(deftest cleanup
	123	(async done
	124	(let [l (latch 2 done)]
	125	(testing "alt handlers are removed from put!"
	126	(go
	127	(let [c (chan)]
	128	(dotimes [x 1024]
	129	(alts! [[c x]] :default 42))
	130	(put! c 42))
	131	(inc! l)))
	132	(testing "alt handlers are removed from take!"
	133	(go
	134	(let [c (chan)]
	135	(dotimes [x 1024]
	136	(alts! [c] :default 42))
	137	(take! c (fn [x] nil)))
	138	(inc! l))))))
	139
	140	(deftest test-map<
	141	(async done
	142	(go
	143	(is (= [2 3 4 5]
	144	(<! (async/into [] (async/map< inc (async/to-chan [1 2 3 4]))))))
	145	(done))))
	146
	147	(deftest test-map>
	148	(async done
	149	(go
	150	(is (= [2 3 4 5]
	151	(let [out (chan)
	152	in (async/map> inc out)]
	153	(async/onto-chan in [1 2 3 4])
	154	(<! (async/into [] out)))))
	155	(done))))
	156
	157	(deftest test-filter<
	158	(async done
	159	(go
	160	(is (= [2 4 6]
	161	(<! (async/into [] (async/filter< even? (async/to-chan [1 2 3 4 5 6]))))))
	162	(done))))
	163
	164	(deftest test-remoev<
	165	(async done
	166	(go
	167	(is (= [1 3 5]
	168	(<! (async/into [] (async/remove< even? (async/to-chan [1 2 3 4 5 6]))))))
	169	(done))))
	170
	171	(deftest test-filter>
	172	(async done
	173	(go
	174	(is (= [2 4 6]
	175	(let [out (chan)
	176	in (async/filter> even? out)]
	177	(async/onto-chan in [1 2 3 4 5 6])
	178	(<! (async/into [] out)))))
	179	(done))))
	180
	181	(deftest test-remove>
	182	(async done
	183	(go
	184	(is (= [1 3 5]
	185	(let [out (chan)
	186	in (async/remove> even? out)]
	187	(async/onto-chan in [1 2 3 4 5 6])
	188	(<! (async/into [] out)))))
	189	(done))))
	190
	191	(deftest test-mapcat<
	192	(async done
	193	(go
	194	(is (= [0 0 1 0 1 2]
	195	(<! (async/into [] (async/mapcat< range (async/to-chan [1 2 3]))))))
	196	(done))))
	197
	198	(deftest test-mapcat>
	199	(async done
	200	(go
	201	(is (= [0 0 1 0 1 2]
	202	(let [out (chan)
	203	in (async/mapcat> range out)]
	204	(async/onto-chan in [1 2 3])
	205	(<! (async/into [] out)))))
	206	(done))))
	207
	208	(deftest test-pipe
	209	(async done
	210	(go
	211	(is (= [1 2 3 4 5]
	212	(let [out (chan)]
	213	(async/pipe (async/to-chan [1 2 3 4 5])
	214	out)
	215	(<! (async/into [] out)))))
	216	(done))))
	217
	218	(deftest test-split
	219	(async done
	220	;; Must provide buffers for channels else the tests won't complete
	221	(go
	222	(let [[even odd] (async/split even? (async/to-chan [1 2 3 4 5 6]) 5 5)]
	223	(is (= [2 4 6] (<! (async/into [] even))))
	224	(is (= [1 3 5] (<! (async/into [] odd)))))
	225	(done))))
	226
	227	(deftest test-map
	228	(async done
	229	(go
	230	(is (= [0 4 8 12]
	231	(<! (async/into []
	232	(async/map +
	233	[(async/to-chan (range 4))
	234	(async/to-chan (range 4))
	235	(async/to-chan (range 4))
	236	(async/to-chan (range 4))])))))
	237	(done))))
	238
	239	(deftest test-merge
	240	(async done
	241	;; merge uses alt, so results can be in any order, we're using
	242	;; frequencies as a way to make sure we get the right result.
	243	(go
	244	(is (= {0 4, 1 4, 2 4, 3 4}
	245	(frequencies
	246	(<! (async/into []
	247	(async/merge
	248	[(async/to-chan (range 4))
	249	(async/to-chan (range 4))
	250	(async/to-chan (range 4))
	251	(async/to-chan (range 4))]))))))
	252	(done))))
	253
	254	(deftest test-mult
	255	(async done
	256	(go
	257	(let [a (chan 4)
	258	b (chan 4)
	259	src (chan)
	260	m (async/mult src)]
	261	(async/tap m a)
	262	(async/tap m b)
	263	(async/pipe (async/to-chan (range 4)) src)
	264	(is (= [0 1 2 3] (<! (async/into [] a))))
	265	(is (= [0 1 2 3] (<! (async/into [] b))))
	266	(done)))))
	267
	268	(deftest test-mix
	269	(async done
	270	(go
	271	(let [out (chan)
	272	mx (async/mix out)
	273	take-out (chan)
	274	take6 (go (dotimes [x 6]
	275	(>! take-out (<! out)))
	276	(close! take-out))]
	277	(async/admix mx (async/to-chan [1 2 3]))
	278	(async/admix mx (async/to-chan [4 5 6]))
	279	(is (= #{1 2 3 4 5 6} (<! (async/into #{} take-out))))
	280	(done)))))
	281
	282	(deftest test-pub-sub
	283	(async done
	284	(go
	285	(let [a-ints (chan 5)
	286	a-strs (chan 5)
	287	b-ints (chan 5)
	288	b-strs (chan 5)
	289	src (chan)
	290	p (async/pub src (fn [x]
	291	(if (string? x)
	292	:string
	293	:int)))]
	294	(async/sub p :string a-strs)
	295	(async/sub p :string b-strs)
	296	(async/sub p :int a-ints)
	297	(async/sub p :int b-ints)
	298	(async/pipe (async/to-chan [1 "a" 2 "b" 3 "c"]) src)
	299	(is (= [1 2 3]
	300	(<! (async/into [] a-ints))))
	301	(is (= [1 2 3]
	302	(<! (async/into [] b-ints))))
	303	(is (= ["a" "b" "c"]
	304	(<! (async/into [] a-strs))))
	305	(is (= ["a" "b" "c"]
	306	(<! (async/into [] b-strs)))))
	307	(done))))
	308
	309	(deftest test-unique
	310	(async done
	311	(go
	312	(is (= [1 2 3 4]
	313	(<! (async/into [] (async/unique (async/to-chan [1 1 2 2 3 3 3 3 4]))))))
	314	(done))))
	315
	316	(deftest test-partition
	317	(async done
	318	(go
	319	(is (= [[1 2] [2 3]]
	320	(<! (async/into [] (async/partition 2 (async/to-chan [1 2 2 3]))))))
	321	(done))))
	322
	323
	324	(deftest test-partition-by
	325	(async done
	326	(go
	327	(is (= [["a" "b"] [1 :2 3] ["c"]]
	328	(<! (async/into [] (async/partition-by string? (async/to-chan ["a" "b" 1 :2 3 "c"]))))))
	329	(done))))
	330
	331	(deftest test-reduce
	332	(async done
	333	(let [l (latch 3 done)]
	334	(go (is (= 0 (<! (async/reduce + 0 (async/to-chan [])))))
	335	(inc! l))
	336	(go (is (= 45 (<! (async/reduce + 0 (async/to-chan (range 10))))))
	337	(inc! l))
	338	(go (is (= :foo (<! (async/reduce #(if (= %2 2) (reduced :foo) %1) 0
	339	(async/to-chan (range 10))))))
	340	(inc! l)))))
	341
	342	(deftest dispatch-bugs
	343	(async done
	344	(testing "puts are moved to buffers"
	345	(let [c (chan 1)
	346	a (atom 0)]
	347	(put! c 42 (fn [_] (swap! a inc))) ;; Goes into buffer
	348	(put! c 42 (fn [_] (swap! a inc))) ;; Goes into puts
	349	(take! c
	350	(fn [_]
	351	;; Should release the iten in the puts and
	352	;; put its value into the buffer, dispatching the callback
	353	(go
	354	(<! (timeout 500))
	355	;; Thus this should be 2
	356	(is (= @a 2))
	357	(done))))))))
	358
	359	(defn integer-chan
	360	"Returns a channel upon which will be placed integers from 0 to n (exclusive) at 10 ms intervals, using the provided xform"
	361	[n xform]
	362	(let [c (chan 1 xform)]
	363	(go
	364	(loop [i 0]
	365	(if (< i n)
	366	(do
	367	(<! (timeout 10))
	368	(>! c i)
	369	(recur (inc i)))
	370	(close! c))))
	371	c))
	372
	373	(deftest test-transducers
	374	(async done
	375	(let [l (latch 6 done)]
	376	(testing "base case without transducer"
	377	(go (is (= (range 10)
	378	(<! (async/into [] (integer-chan 10 nil)))))
	379	(inc! l)))
	380	(testing "mapping transducer"
	381	(go (is (= (map str (range 10))
	382	(<! (async/into [] (integer-chan 10 (map str))))))
	383	(inc! l)))
	384	(testing "filtering transducer"
	385	(go (is (= (filter even? (range 10))
	386	(<! (async/into [] (integer-chan 10 (filter even?))))))
	387	(inc! l)))
	388	(testing "flatpmapping transducer"
	389	(let [pair-of (fn [x] [x x])]
	390	(go (is (= (mapcat pair-of (range 10))
	391	(<! (async/into [] (integer-chan 10 (mapcat pair-of))))))
	392	(inc! l))))
	393	(testing "partitioning transducer"
	394	(go (is (= [[0 1 2 3 4] [5 6 7]]
	395	(<! (async/into [] (integer-chan 8 (partition-all 5))))))
	396	(inc! l))
	397	(go (is (= [[0 1 2 3 4] [5 6 7 8 9]]
	398	(<! (async/into [] (integer-chan 10 (partition-all 5))))))
	399	(inc! l))))))
	400
	401	(deftest test-bufferless
	402	(async done
	403	(let [c (chan)
	404	l (latch 2 done)]
	405	(go
	406	(is (= [:value c] (async/alts! [c (async/timeout 6000)] :priority true)))
	407	(inc! l))
	408	(go
	409	(is (= [true c] (async/alts! [[c :value] (async/timeout 6000)] :priority true)))
	410	(inc! l)))))
	411
	412	(deftest test-promise-chan
	413	(async done
	414	(let [l (latch 3 done)]
	415	(testing "put on promise-chan fulfills all pending takers"
	416	(let [c (promise-chan)
	417	t1 (go (<! c))
	418	t2 (go (<! c))]
	419	(go
	420	(>! c :val)
	421	(is (= :val (<! t1) (<! t2)))
	422	(testing "then puts succeed but are dropped"
	423	(go (>! c :LOST))
	424	(is (= :val (<! c))))
	425	(testing "then takes succeed with the original value"
	426	(is (= :val (<! c) (<! c) (<! c))))
	427	(testing "then after close takes continue returning val"
	428	(close! c)
	429	(is (= :val (<! c) (<! c))))
	430	(inc! l))))
	431	(testing "close on promise-chan fulfills all pending takers"
	432	(go
	433	(let [c (promise-chan)
	434	t1 (go (<! c))
	435	t2 (go (<! c))]
	436	(close! c)
	437	(is (= nil (<! t1) (<! t2)))
	438	(testing "then takes return nil"
	439	(is (= nil (<! t1) (<! t1) (<! t2) (<! t2)))))
	440	(inc! l)))
	441	(testing "close after put on promise-chan continues delivering promised value"
	442	(go
	443	(let [c (promise-chan)]
	444	(>! c :val) ;; deliver
	445	(is (= :val (<! c) (<! c)))
	446	(close! c)
	447	(is (= :val (<! c) (<! c))))
	448	(inc! l))))))
	449
	450	(deftest test-offer-poll-go
	451	(let [c (chan 2)]
	452	(is (= [true true 5 6 nil]
	453	[(offer! c 5) (offer! c 6) (poll! c) (poll! c) (poll! c)])))
	454	(let [c (chan 2)]
	455	(is (true? (offer! c 1)))
	456	(is (true? (offer! c 2)))
	457	(is (nil? (offer! c 3)))
	458	(is (= 1 (poll! c)))
	459	(is (= 2 (poll! c)))
	460	(is (nil? (poll! c))))
	461	(let [c (chan)]
	462	(is (nil? (offer! c 1)))
	463	(is (nil? (poll! c)))))
	464
	465	(deftest test-transduce
	466	(go
	467	(= [1 2 3 4 5]
	468	(<! (async/transduce (map inc) conj [] (async/to-chan (range 5)))))))

+106

-0

src/test/clojure/clojure/core/async/buffers_test.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async.buffers-test
	9	(:require [clojure.test :refer :all]
	10	[clojure.core.async.impl.buffers :refer :all]
	11	[clojure.core.async.impl.protocols :refer [full? add! remove! close-buf!]]))
	12
	13	(defmacro throws? [expr]
	14	`(try
	15	~expr
	16	false
	17	(catch Throwable _# true)))
	18
	19	(deftest fixed-buffer-tests
	20	(let [fb (fixed-buffer 2)]
	21	(is (= 0 (count fb)))
	22
	23	(add! fb :1)
	24	(is (= 1 (count fb)))
	25
	26	(add! fb :2)
	27	(is (= 2 (count fb)))
	28
	29	(is (= :1 (remove! fb)))
	30	(is (not (full? fb)))
	31
	32	(is (= 1 (count fb)))
	33	(is (= :2 (remove! fb)))
	34
	35	(is (= 0 (count fb)))
	36	(is (throws? (remove! fb)))))
	37
	38	(deftest dropping-buffer-tests
	39	(let [fb (dropping-buffer 2)]
	40	(is (= 0 (count fb)))
	41
	42	(add! fb :1)
	43	(is (= 1 (count fb)))
	44
	45	(add! fb :2)
	46	(is (= 2 (count fb)))
	47
	48	(is (not (full? fb)))
	49	(is (not (throws? (add! fb :3))))
	50	(is (= 2 (count fb)))
	51
	52	(is (= :1 (remove! fb)))
	53	(is (not (full? fb)))
	54
	55	(is (= 1 (count fb)))
	56	(is (= :2 (remove! fb)))
	57
	58	(is (= 0 (count fb)))
	59	(is (throws? (remove! fb)))))
	60
	61	(deftest sliding-buffer-tests
	62	(let [fb (sliding-buffer 2)]
	63	(is (= 0 (count fb)))
	64
	65	(add! fb :1)
	66	(is (= 1 (count fb)))
	67
	68	(add! fb :2)
	69	(is (= 2 (count fb)))
	70
	71	(is (not (full? fb)))
	72	(is (not (throws? (add! fb :3))))
	73	(is (= 2 (count fb)))
	74
	75	(is (= :2 (remove! fb)))
	76	(is (not (full? fb)))
	77
	78	(is (= 1 (count fb)))
	79	(is (= :3 (remove! fb)))
	80
	81	(is (= 0 (count fb)))
	82	(is (throws? (remove! fb)))))
	83
	84	(deftest promise-buffer-tests
	85	(let [pb (promise-buffer)]
	86	(is (= 0 (count pb)))
	87
	88	(add! pb :1)
	89	(is (= 1 (count pb)))
	90
	91	(add! pb :2)
	92	(is (= 1 (count pb)))
	93
	94	(is (not (full? pb)))
	95	(is (not (throws? (add! pb :3))))
	96	(is (= 1 (count pb)))
	97
	98	(is (= :1 (remove! pb)))
	99	(is (not (full? pb)))
	100
	101	(is (= 1 (count pb)))
	102	(is (= :1 (remove! pb)))
	103
	104	(is (= nil (close-buf! pb)))
	105	(is (= :1 (remove! pb)))))

+19

-0

src/test/clojure/clojure/core/async/concurrent_test.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async.concurrent-test
	9	(:require [clojure.test :refer :all]
	10	[clojure.core.async.impl.concurrent :as conc])
	11	(:import [java.util.concurrent ThreadFactory]))
	12
	13	(deftest test-counted-thread-factory
	14	(testing "Creates numbered threads"
	15	(let [^ThreadFactory factory (conc/counted-thread-factory "foo-%d" true)
	16	threads (repeatedly 3 #(.newThread factory (constantly nil)))]
	17	(is (= ["foo-1" "foo-2" "foo-3"] (map #(.getName ^Thread %) threads))))))
	18

+62

-0

src/test/clojure/clojure/core/async/exceptions_test.clj less more

	0	;; Copyright (c) Rich Hickey and contributors. All rights reserved.
	1	;; The use and distribution terms for this software are covered by the
	2	;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
	3	;; which can be found in the file epl-v10.html at the root of this distribution.
	4	;; By using this software in any fashion, you are agreeing to be bound by
	5	;; the terms of this license.
	6	;; You must not remove this notice, or any other, from this software.
	7
	8	(ns clojure.core.async.exceptions-test
	9	"Verify that exceptions thrown on a thread pool managed by
	10	core.async will propagate out to the JVM's default uncaught
	11	exception handler."
	12	(:require [clojure.test :refer [deftest is]]
	13	[clojure.stacktrace :refer [root-cause]]
	14	[clojure.core.async :refer [chan go thread put! take! <!! >!!]]))
	15
	16	(defn with-default-uncaught-exception-handler [handler f]
	17	(let [old-handler (Thread/getDefaultUncaughtExceptionHandler)]
	18	(Thread/setDefaultUncaughtExceptionHandler
	19	(reify Thread$UncaughtExceptionHandler
	20	(uncaughtException [_ thread throwable]
	21	(handler thread throwable))))
	22	(f)
	23	(Thread/setDefaultUncaughtExceptionHandler old-handler)))
	24
	25	(deftest exception-in-go
	26	(let [log (promise)]
	27	(with-default-uncaught-exception-handler
	28	(fn [_ throwable] (deliver log throwable))
	29	#(let [ex (Exception. "This exception is expected")
	30	ret (go (throw ex))]
	31	(<!! ret)
	32	(is (identical? ex (root-cause @log)))))))
	33
	34	(deftest exception-in-thread
	35	(let [log (promise)]
	36	(with-default-uncaught-exception-handler
	37	(fn [_ throwable] (deliver log throwable))
	38	#(let [ex (Exception. "This exception is expected")
	39	ret (thread (throw ex))]
	40	(<!! ret)
	41	(is (identical? ex (root-cause @log)))))))
	42
	43	(deftest exception-in-put-callback
	44	(let [log (promise)]
	45	(with-default-uncaught-exception-handler
	46	(fn [_ throwable] (deliver log throwable))
	47	#(let [ex (Exception. "This exception is expected")
	48	c (chan)]
	49	(put! c :foo (fn [_] (throw ex)))
	50	(<!! c)
	51	(is (identical? ex (root-cause @log)))))))
	52
	53	(deftest exception-in-take-callback
	54	(let [log (promise)]
	55	(with-default-uncaught-exception-handler
	56	(fn [_ throwable] (deliver log throwable))
	57	#(let [ex (Exception. "This exception is expected")
	58	c (chan)]
	59	(take! c (fn [_] (throw ex)))
	60	(>!! c :foo)
	61	(is (identical? ex (root-cause @log)))))))

+507

-0

src/test/clojure/clojure/core/async/ioc_macros_test.clj less more

	0	(ns clojure.core.async.ioc-macros-test
	1	(:refer-clojure :exclude [map into reduce transduce merge take partition
	2	partition-by])
	3	(:require [clojure.core.async.impl.ioc-macros :as ioc]
	4	[clojure.core.async :refer :all :as async]
	5	[clojure.test :refer :all])
	6	(:import [java.io FileInputStream ByteArrayOutputStream File]))
	7
	8	(defn pause [x]
	9	x)
	10
	11	(defn pause-run [state blk val]
	12	(ioc/aset-all! state ioc/STATE-IDX blk ioc/VALUE-IDX val)
	13	:recur)
	14
	15
	16	(defmacro runner
	17	"Creates a runner block. The code inside the body of this macro will be translated
	18	into a state machine. At run time the body will be run as normal. This transform is
	19	only really useful for testing."
	20	[& body]
	21	(let [terminators {`pause `pause-run}
	22	crossing-env (zipmap (keys &env) (repeatedly gensym))]
	23	`(let [captured-bindings# (clojure.lang.Var/getThreadBindingFrame)
	24	~@(mapcat (fn [[l sym]] [sym `(^:once fn* [] ~l)]) crossing-env)
	25	state# (~(ioc/state-machine `(do ~@body) 0 [crossing-env &env] terminators))]
	26	(ioc/aset-all! state#
	27	~ioc/BINDINGS-IDX
	28	captured-bindings#)
	29	(ioc/run-state-machine state#)
	30	(ioc/aget-object state# ioc/VALUE-IDX))))
	31
	32	(deftest test-try-catch-finally
	33	(testing "Don't endlessly loop when exceptions are thrown"
	34	(is (thrown? Exception
	35	(runner
	36	(loop []
	37	(try
	38	(pause (throw (Exception. "Ex")))
	39	(catch clojure.lang.ExceptionInfo ei
	40	:retry))))))
	41	(is (thrown? Throwable
	42	(runner
	43	(loop []
	44	(try
	45	(pause (throw (Throwable. "Ex")))
	46	(catch clojure.lang.ExceptionInfo ei
	47	:retry))))))
	48	;; (is (try ((fn [] (println "Hello") (pause 5))) (catch Exception e)))
	49	(is (= :Throwable
	50	(runner
	51	(try
	52	(pause 5)
	53	(throw (new Throwable))
	54	(catch Exception re
	55	:Exception)
	56	(catch Throwable t
	57	:Throwable))))))
	58	(testing "finally shouldn't change the return value"
	59	(is (= 1 (runner (try 1 (finally (pause 2)))))))
	60	(testing "exception handlers stack"
	61	(is (= "eee"
	62	(runner
	63	(try
	64	(try
	65	(try
	66	(throw (pause (Exception. "e")))
	67	(catch Exception e
	68	(pause (throw (Exception. (str (.getMessage e) "e"))))))
	69	(catch Exception e
	70	(throw (throw (Exception. (str (.getMessage e) "e"))))))
	71	(catch Exception e
	72	(.getMessage e)))))))
	73	(testing "exception handlers and the class hierarchy"
	74	(is
	75	(runner
	76	(try
	77	(pause 10)
	78	(throw (RuntimeException.))
	79	(catch RuntimeException r
	80	(pause true))
	81	(catch Exception e
	82	(pause false)))))
	83	(is
	84	(runner
	85	(try
	86	(pause 10)
	87	(throw (RuntimeException.))
	88	(catch Exception e
	89	(pause true))))))
	90	(testing "don't explode trying to compile this"
	91	(is
	92	(runner
	93	(try
	94	true
	95	(catch Exception e
	96	(pause 1)
	97	e))))))
	98
	99
	100	(defmacro locals-test []
	101	(if (if (contains? &env :locals)
	102	(get (:locals &env) 'x)
	103	(get &env 'x))
	104	:pass
	105	:fail))
	106
	107
	108	(deftest runner-tests
	109	(testing "macros add locals to the env"
	110	(is (= :pass
	111	(runner (let [x 42]
	112	(pause (locals-test)))))))
	113	(testing "fn as first arg in sexpr"
	114	(is (= 42
	115	(runner ((fn [] 42))))))
	116	(testing "do blocks"
	117	(is (= 42
	118	(runner (do (pause 42)))))
	119	(is (= 42
	120	(runner (do (pause 44)
	121	(pause 42))))))
	122	(testing "if expressions"
	123	(is (= true
	124	(runner (if (pause true)
	125	(pause true)
	126	(pause false)))))
	127	(is (= false
	128	(runner (if (pause false)
	129	(pause true)
	130	(pause false)))))
	131	(is (= true
	132	(runner (when (pause true)
	133	(pause true)))))
	134	(is (= nil
	135	(runner (when (pause false)
	136	(pause true))))))
	137
	138	(testing "dot forms"
	139	(is (= 42 (runner (. Long (parseLong "42")))))
	140	(is (= 42 (runner (. Long parseLong "42")))))
	141
	142	(testing "quote"
	143	(is (= '(1 2 3)
	144	(runner (pause '(1 2 3))))))
	145
	146	(testing "loop expressions"
	147	(is (= 100
	148	(runner (loop [x 0]
	149	(if (< x 100)
	150	(recur (inc (pause x)))
	151	(pause x))))))
	152	(is (= 100
	153	(runner (loop [x (pause 0)]
	154	(if (< x 100)
	155	(recur (inc (pause x)))
	156	(pause x))))))
	157	(is (= [:b :a]
	158	(runner (loop [a :a b :b n 1]
	159	(if (pos? n)
	160	(recur b a (dec n)) ;; swap bindings
	161	[a b])))))
	162	(is (= 1
	163	(runner (loop [x 0
	164	y (inc x)]
	165	y)))))
	166
	167	(testing "let expressions"
	168	(is (= 3
	169	(runner (let [x 1 y 2]
	170	(+ x y))))))
	171
	172	(testing "vector destructuring"
	173	(is (= 3
	174	(runner (let [[x y] [1 2]]
	175	(+ x y))))))
	176
	177	(testing "hash-map destructuring"
	178	(is (= 3
	179	(runner (let [{:keys [x y] x2 :x y2 :y :as foo} {:x 1 :y 2}]
	180	(assert (and foo (pause x) y x2 y2 foo))
	181	(+ x y))))))
	182
	183	(testing "hash-map literals"
	184	(is (= {:1 1 :2 2 :3 3}
	185	(runner {:1 (pause 1)
	186	:2 (pause 2)
	187	:3 (pause 3)}))))
	188	(testing "hash-set literals"
	189	(is (= #{1 2 3}
	190	(runner #{(pause 1)
	191	(pause 2)
	192	(pause 3)}))))
	193	(testing "vector literals"
	194	(is (= [1 2 3]
	195	(runner [(pause 1)
	196	(pause 2)
	197	(pause 3)]))))
	198
	199	(testing "keywords as functions"
	200	(is (= :bar
	201	(runner (:foo (pause {:foo :bar}))))))
	202
	203	(testing "vectors as functions"
	204	(is (= 2
	205	(runner ([1 2] 1)))))
	206
	207	(testing "dotimes"
	208	(is (= 42 (runner
	209	(dotimes [x 10]
	210	(pause x))
	211	42))))
	212
	213	(testing "fn closures"
	214	(is (= 42
	215	(runner
	216	(let [x 42
	217	_ (pause x)
	218	f (fn [] x)]
	219	(f))))))
	220
	221	(testing "lazy-seqs in bodies"
	222	(is (= nil
	223	(runner
	224	(loop []
	225	(when-let [x (pause 10)]
	226	(pause (vec (for [i (range x)]
	227	i)))
	228	(if-not x
	229	(recur))))))))
	230
	231	(testing "specials cannot be shadowed"
	232	(is (= 3
	233	(let [let* :foo] (runner (let* [x 3] x))))))
	234
	235	(testing "case"
	236	(is (= 43
	237	(runner
	238	(let [value :bar]
	239	(case value
	240	:foo (pause 42)
	241	:bar (pause 43)
	242	:baz (pause 44))))))
	243	(is (= :default
	244	(runner
	245	(case :baz
	246	:foo 44
	247	:default))))
	248	(is (= nil
	249	(runner
	250	(case true
	251	false false
	252	nil))))
	253	(is (= 42
	254	(runner
	255	(loop [x 0]
	256	(case (int x)
	257	0 (recur (inc x))
	258	1 42))))))
	259
	260	(testing "try"
	261	(is (= 42
	262	(runner
	263	(try 42
	264	(catch Throwable ex ex)))))
	265	(is (= 42
	266	(runner
	267	(try
	268	(assert false)
	269	(catch Throwable ex 42)))))
	270
	271	(let [a (atom false)
	272	v (runner
	273	(try
	274	true
	275	(catch Throwable ex false)
	276	(finally (pause (reset! a true)))))]
	277	(is (and @a v)))
	278
	279	(let [a (atom false)
	280	v (runner
	281	(try
	282	(assert false)
	283	(catch Throwable ex true)
	284	(finally (reset! a true))))]
	285	(is (and @a v)))
	286
	287	(let [a (atom false)
	288	v (try (runner
	289	(try
	290	(assert false)
	291	(finally (reset! a true))))
	292	(catch Throwable ex ex))]
	293	(is (and @a v)))
	294
	295
	296	(let [a (atom 0)
	297	v (runner
	298	(try
	299	(try
	300	42
	301	(finally (swap! a inc)))
	302	(finally (swap! a inc))))]
	303	(is (= @a 2)))
	304
	305	(let [a (atom 0)
	306	v (try (runner
	307	(try
	308	(try
	309	(throw (AssertionError. 42))
	310	(finally (swap! a inc)))
	311	(finally (swap! a inc))))
	312	(catch AssertionError ex ex))]
	313	(is (= @a 2)))
	314
	315	(let [a (atom 0)
	316	v (try (runner
	317	(try
	318	(try
	319	(throw (AssertionError. 42))
	320	(catch Throwable ex (throw ex))
	321	(finally (swap! a inc)))
	322	(catch Throwable ex (throw ex))
	323	(finally (swap! a inc))))
	324	(catch AssertionError ex ex))]
	325	(is (= @a 2)))
	326
	327	(let [a (atom 0)
	328	v (try (runner
	329	(try
	330	(try
	331	(throw (AssertionError. (pause 42)))
	332	(catch Throwable ex (pause (throw ex)))
	333	(finally (pause (swap! a inc))))
	334	(catch Throwable ex (pause (throw ex)))
	335	(finally (pause (swap! a inc)))))
	336	(catch AssertionError ex ex))]
	337	(is (= @a 2)))))
	338
	339
	340	(defn identity-chan
	341	"Defines a channel that instantly writes the given value"
	342	[x]
	343	(let [c (chan 1)]
	344	(>!! c x)
	345	(close! c)
	346	c))
	347
	348	(deftest async-test
	349	(testing "values are returned correctly"
	350	(is (= 10
	351	(<!! (go (<! (identity-chan 10)))))))
	352	(testing "writes work"
	353	(is (= 11
	354	(<!! (go (let [c (chan 1)]
	355	(>! c (<! (identity-chan 11)))
	356	(<! c)))))))
	357
	358	(testing "case with go"
	359	(is (= :1
	360	(<!! (go (case (name :1)
	361	"0" :0
	362	"1" :1
	363	:3))))))
	364
	365	(testing "nil result of go"
	366	(is (= nil
	367	(<!! (go nil)))))
	368
	369	(testing "take inside binding of loop"
	370	(is (= 42
	371	(<!! (go (loop [x (<! (identity-chan 42))]
	372	x))))))
	373
	374	(testing "can get from a catch"
	375	(let [c (identity-chan 42)]
	376	(is (= 42
	377	(<!! (go (try
	378	(assert false)
	379	(catch Throwable ex (<! c))))))))))
	380
	381	(deftest offer-poll
	382	(let [c (chan 2)]
	383	(is (= [true true 5 6 nil]
	384	(<!! (go [(offer! c 5) (offer! c 6) (poll! c) (poll! c) (poll! c)]))))))
	385
	386	(deftest enqueued-chan-ops
	387	(testing "enqueued channel puts re-enter async properly"
	388	(is (= [:foo 42]
	389	(let [c (chan)
	390	result-chan (go (>! c :foo) 42)]
	391	[(<!! c) (<!! result-chan)]))))
	392	(testing "enqueued channel takes re-enter async properly"
	393	(is (= :foo
	394	(let [c (chan)
	395	async-chan (go (<! c))]
	396	(>!! c :foo)
	397	(<!! async-chan)))))
	398	(testing "puts into channels with full buffers re-enter async properly"
	399	(is (= #{:foo :bar :baz :boz}
	400	(let [c (chan 1)
	401	async-chan (go
	402	(>! c :foo)
	403	(>! c :bar)
	404	(>! c :baz)
	405
	406	(>! c :boz)
	407	(<! c))]
	408	(set [(<!! c)
	409	(<!! c)
	410	(<!! c)
	411	(<!! async-chan)]))))))
	412
	413	(defn rand-timeout [x]
	414	(timeout (rand-int x)))
	415
	416	(deftest alt-tests
	417	(testing "alts works at all"
	418	(let [c (identity-chan 42)]
	419	(is (= [42 c]
	420	(<!! (go (alts!
	421	[c])))))))
	422	(testing "alt works"
	423	(is (= [42 :foo]
	424	(<!! (go (alt!
	425	(identity-chan 42) ([v] [v :foo])))))))
	426
	427	(testing "alts can use default"
	428	(is (= [42 :default]
	429	(<!! (go (alts!
	430	[(chan 1)] :default 42))))))
	431
	432	(testing "alt can use default"
	433	(is (= 42
	434	(<!! (go (alt!
	435	(chan) ([v] :failed)
	436	:default 42))))))
	437
	438	(testing "alt obeys its random-array initialization"
	439	(is (= #{:two}
	440	(with-redefs [clojure.core.async/random-array
	441	(constantly (int-array [1 2 0]))]
	442	(<!! (go (loop [acc #{}
	443	cnt 0]
	444	(if (< cnt 10)
	445	(let [label (alt!
	446	(identity-chan :one) ([v] v)
	447	(identity-chan :two) ([v] v)
	448	(identity-chan :three) ([v] v))]
	449	(recur (conj acc label) (inc cnt)))
	450	acc)))))))))
	451
	452	(deftest close-on-exception-tests
	453	(testing "threads"
	454	(is (nil? (<!! (thread (assert false "This exception is expected")))))
	455	(is (nil? (<!! (thread (alts!! [(identity-chan 42)])
	456	(assert false "This exception is expected"))))))
	457	(testing "go blocks"
	458	(is (nil? (<!! (go (assert false "This exception is expected")))))
	459	(is (nil? (<!! (go (alts! [(identity-chan 42)])
	460	(assert false "This exception is expected")))))))
	461
	462	(deftest resolution-tests
	463	(let [<! (constantly 42)]
	464	(is (= 42 (<!! (go (<! (identity-chan 0)))))
	465	"symbol translations do not apply to locals outside go"))
	466
	467	(is (= 42 (<!! (go (let [<! (constantly 42)]
	468	(<! (identity-chan 0))))))
	469	"symbol translations do not apply to locals inside go")
	470
	471	(let [for vector x 3]
	472	(is (= [[3 [0 1]] 3]
	473	(<!! (go (for [x (range 2)] x))))
	474	"locals outside go are protected from macroexpansion"))
	475
	476	(is (= [[3 [0 1]] 3]
	477	(<!! (go (let [for vector x 3]
	478	(for [x (range 2)] x)))))
	479	"locals inside go are protected from macroexpansion")
	480
	481	(let [c (identity-chan 42)]
	482	(is (= [42 c] (<!! (go (async/alts! [c]))))
	483	"symbol translations apply to resolved symbols")))
	484
	485	(deftest go-nests
	486	(is (= [23 42] (<!! (<!! (go (let [let* 1 a 23] (go (let* [b 42] [a b])))))))))
	487
	488	(defprotocol P
	489	(x [p]))
	490
	491	(defrecord R [z]
	492	P
	493	(x [this]
	494	(go
	495	(loop []
	496	(if (zero? (rand-int 3))
	497	[z (.z this)]
	498	(recur))))))
	499
	500	(deftest go-propagates-primitive-hints
	501	(is (= "asd" (<!! (let [a (int 1)] (go (.substring "fasd" a))))))
	502	(is (= 1 (<!! (let [a (int 1)] (go (Integer/valueOf a))))))
	503	(is (= [1 1] (<!! (x (R. 1))))))
	504
	505	(deftest ASYNC-186
	506	(is (let [y nil] (go))))

+79

-0

src/test/clojure/clojure/core/async/lab_test.clj less more

	0	(ns clojure.core.async.lab-test
	1	(:use clojure.test
	2	clojure.core.async.lab)
	3	(:require [clojure.core.async :as async]))
	4
	5	(deftest multiplex-test
	6	(is (apply = (let [even-chan (async/chan)
	7	odd-chan (async/chan)
	8	muxer (multiplex even-chan odd-chan)
	9	odds (filter odd? (range 10))
	10	evens (filter even? (range 10))
	11	odd-pusher (doto (Thread. #(doseq [odd odds]
	12	(async/>!! odd-chan odd)))
	13	(.start))
	14	even-pusher (doto (Thread. #(doseq [even evens]
	15	(async/>!! even-chan even)))
	16	(.start))
	17	expected (set (range 10))
	18	observed (set (for [_ (range 10)] (async/<!! muxer)))]
	19	[expected observed]))
	20	"Multiplexing multiple channels returns a channel which returns
	21	the values written to each.")
	22	(is (let [short-chan (async/chan)
	23	long-chan (async/chan)
	24	muxer (multiplex short-chan long-chan)
	25	semaphore (promise)
	26	long-pusher (doto (Thread. #(do (dotimes [i 10000]
	27	(async/>!! long-chan i))
	28	(async/close! short-chan)))
	29	(.start))
	30	short-pusher (doto (Thread. #(do (dotimes [i 10]
	31	(async/>!! short-chan i))
	32	(async/close! short-chan)))
	33	(.start))
	34	observed (for [_ (range 10010)] (async/<!! muxer))]
	35	(every? identity observed))
	36	"A closed channel will deliver nil, but the multiplexed channel
	37	will never deliver nil until all channels are closed.")
	38	(is (apply = (let [chans (take 5 (repeatedly #(async/chan)))
	39	muxer (apply multiplex chans)]
	40	(doseq [chan chans]
	41	(async/close! chan))
	42	[nil (async/<!! muxer)]))
	43	"When all of a multiplexer's channels are closed, it behaves
	44	like a closed channel on read."))
	45
	46	(deftest broadcast-test
	47	(is (apply = (let [broadcast-receivers (repeatedly 5 #(async/chan 1))
	48	broadcaster (apply broadcast broadcast-receivers)
	49	broadcast-result (async/>!! broadcaster :foo)
	50	expected (repeat 5 :foo)
	51	observed (doall (map async/<!! broadcast-receivers))]
	52	[expected observed]))
	53	"Broadcasting to multiple channels returns a channel which will
	54	write to all the target channels.")
	55	(is (apply = (let [broadcast-receivers (repeatedly 5 async/chan)
	56	broadcaster (apply broadcast broadcast-receivers)
	57	read-channels (take 4 broadcast-receivers)
	58	broadcast-future (future (async/>!! broadcaster :foo)
	59	(async/>!! broadcaster :bar))
	60	first-reads (doall (map async/<!! read-channels))
	61	timeout-channel (async/timeout 500)
	62	alt-read (async/alts!! (conj read-channels timeout-channel))
	63	expected [(repeat 4 :foo) [nil timeout-channel]]
	64	observed [first-reads alt-read]]
	65	(async/<!! (last broadcast-receivers))
	66	(doseq [channel broadcast-receivers]
	67	(async/<!! channel))
	68	[expected observed]))
	69	"Broadcasts block further writes if one of the channels cannot
	70	complete its write.")
	71	(is (apply = (let [broadcast-receivers (repeatedly 5 #(async/chan 100))
	72	broadcaster (apply broadcast broadcast-receivers)
	73	broadcast-future (future (dotimes [i 100]
	74	(async/>!! broadcaster i)))
	75	observed (for [i (range 100)]
	76	(async/<!! (first broadcast-receivers)))
	77	expected (range 100)]
	78	[expected observed])) "When all channels are sufficiently buffered, reads on one channel are not throttled by reads from other channels."))

+11

-0

src/test/clojure/clojure/core/async/mutex_test.clj less more

	0	(ns clojure.core.async.mutex-test
	1	(:use clojure.test)
	2	(:import (clojure.core.async Mutex)))
	3
	4	(deftest mutex-test
	5	(let [lock (Mutex.)]
	6	(.lock lock)
	7	(try
	8	;; do stuff
	9	(finally
	10	(.unlock lock)))))

+27

-0

src/test/clojure/clojure/core/async/timers_test.clj less more

	0	(ns clojure.core.async.timers-test
	1	(:require [clojure.test :refer :all]
	2	[clojure.core.async.impl.timers :refer :all]
	3	[clojure.core.async :as async]))
	4
	5	(deftest timeout-interval-test
	6	(let [start-stamp (System/currentTimeMillis)
	7	test-timeout (timeout 500)]
	8	(is (<= (+ start-stamp 500)
	9	(do (async/<!! test-timeout)
	10	(System/currentTimeMillis)))
	11	"Reading from a timeout channel does not complete until the specified milliseconds have elapsed.")))
	12
	13	(deftest timeout-ordering-test
	14	(let [test-atom (atom [])
	15	timeout-channels [(timeout 800)
	16	(timeout 600)
	17	(timeout 700)
	18	(timeout 500)]
	19	threads (doall (for [i (range 4)]
	20	(doto (Thread. #(do (async/<!! (timeout-channels i))
	21	(swap! test-atom conj i)))
	22	(.start))))]
	23	(doseq [thread threads]
	24	(.join ^Thread thread))
	25	(is (= @test-atom [3 1 2 0])
	26	"Timeouts close in order determined by their delays, not in order determined by their creation.")))

+385

-0

src/test/clojure/clojure/core/async_test.clj less more

	0	(ns clojure.core.async-test
	1	(:refer-clojure :exclude [map into reduce transduce merge take partition partition-by])
	2	(:require [clojure.core.async.impl.buffers :as b]
	3	[clojure.core.async :refer :all :as a]
	4	[clojure.test :refer :all]))
	5
	6
	7	(defn default-chan []
	8	(chan 1))
	9
	10	(deftest buffers-tests
	11	(is (not (unblocking-buffer? (buffer 1))))
	12	(is (unblocking-buffer? (dropping-buffer 1)))
	13	(is (unblocking-buffer? (sliding-buffer 1)))
	14	(is (unblocking-buffer? (b/promise-buffer))))
	15
	16	(deftest basic-channel-test
	17	(let [c (default-chan)
	18	f (future (<!! c))]
	19	(>!! c 42)
	20	(is (= @f 42))))
	21
	22	(def DEREF_WAIT 20)
	23
	24	(deftest writes-block-on-full-buffer
	25	(let [c (default-chan)
	26	_ (>!! c 42)
	27	blocking (deref (future (>!! c 43)) DEREF_WAIT :blocked)]
	28	(is (= blocking :blocked))))
	29
	30	(deftest unfulfilled-readers-block
	31	(let [c (default-chan)
	32	r1 (future (<!! c))
	33	r2 (future (<!! c))
	34	_ (>!! c 42)
	35	r1v (deref r1 DEREF_WAIT :blocked)
	36	r2v (deref r2 DEREF_WAIT :blocked)]
	37	(is (and (or (= r1v :blocked) (= r2v :blocked))
	38	(or (= 42 r1v) (= 42 r2v))))))
	39
	40	(deftest test-<!!-and-put!
	41	(let [executed (promise)
	42	test-channel (chan nil)]
	43	(put! test-channel :test-val (fn [_] (deliver executed true)))
	44	(is (not (realized? executed)) "The provided callback does not execute until
	45	a reader can consume the written value.")
	46	(is (= :test-val (<!! test-channel))
	47	"The written value is provided over the channel when a reader arrives.")
	48	(is @executed "The provided callback executes once the reader has arrived.")))
	49
	50	(deftest test->!!-and-take!
	51	(is (= :test-val (let [read-promise (promise)
	52	test-channel (chan nil)]
	53	(take! test-channel #(deliver read-promise %))
	54	(is (not (realized? read-promise))
	55	"The read waits until a writer provides a value.")
	56	(>!! test-channel :test-val)
	57	(deref read-promise 1000 false)))
	58	"The written value is the value provided to the read callback."))
	59
	60	(deftest take!-on-caller?
	61	(is (apply not= (let [starting-thread (Thread/currentThread)
	62	test-channel (chan nil)
	63	read-promise (promise)]
	64	(take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true)
	65	(>!! test-channel :foo)
	66	[starting-thread @read-promise]))
	67	"When on-caller? requested, but no value is immediately
	68	available, take!'s callback executes on another thread.")
	69	(is (apply = (let [starting-thread (Thread/currentThread)
	70	test-channel (chan nil)
	71	read-promise (promise)]
	72	(put! test-channel :foo (constantly nil))
	73	(take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) true)
	74	[starting-thread @read-promise]))
	75	"When on-caller? requested, and a value is ready to read,
	76	take!'s callback executes on the same thread.")
	77	(is (apply not= (let [starting-thread (Thread/currentThread)
	78	test-channel (chan nil)
	79	read-promise (promise)]
	80	(put! test-channel :foo (constantly nil))
	81	(take! test-channel (fn [_] (deliver read-promise (Thread/currentThread))) false)
	82	[starting-thread @read-promise]))
	83	"When on-caller? is false, and a value is ready to read,
	84	take!'s callback executes on a different thread."))
	85
	86	(deftest put!-on-caller?
	87	(is (apply = (let [starting-thread (Thread/currentThread)
	88	test-channel (chan nil)
	89	write-promise (promise)]
	90	(take! test-channel (fn [_] nil))
	91	(put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true)
	92	[starting-thread @write-promise]))
	93	"When on-caller? requested, and a reader can consume the value,
	94	put!'s callback executes on the same thread.")
	95	(is (apply not= (let [starting-thread (Thread/currentThread)
	96	test-channel (chan nil)
	97	write-promise (promise)]
	98	(take! test-channel (fn [_] nil))
	99	(put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) false)
	100	[starting-thread @write-promise]))
	101	"When on-caller? is false, but a reader can consume the value,
	102	put!'s callback executes on a different thread.")
	103	(is (apply not= (let [starting-thread (Thread/currentThread)
	104	test-channel (chan nil)
	105	write-promise (promise)]
	106	(put! test-channel :foo (fn [_] (deliver write-promise (Thread/currentThread))) true)
	107	(take! test-channel (fn [_] nil))
	108	[starting-thread @write-promise]))
	109	"When on-caller? requested, but no reader can consume the value,
	110	put!'s callback executes on a different thread."))
	111
	112
	113	(deftest limit-async-take!-put!
	114	(testing "async put! limit"
	115	(let [c (chan)]
	116	(dotimes [x 1024]
	117	(put! c x))
	118	(is (thrown? AssertionError
	119	(put! c 42)))
	120	(is (= (<!! c) 0)))) ;; make sure the channel unlocks
	121	(testing "async take! limit"
	122	(let [c (chan)]
	123	(dotimes [x 1024]
	124	(take! c (fn [x])))
	125	(is (thrown? AssertionError
	126	(take! c (fn [x]))))
	127	(is (true? (>!! c 42)))))) ;; make sure the channel unlocks
	128
	129	(deftest puts-fulfill-when-buffer-available
	130	(is (= :proceeded
	131	(let [c (chan 1)
	132	p (promise)]
	133	(>!! c :full) ;; fill up the channel
	134	(put! c :enqueues (fn [_] (deliver p :proceeded))) ;; enqueue a put
	135	(<!! c) ;; make room in the buffer
	136	(deref p 250 :timeout)))))
	137
	138	(deftest offer-poll
	139	(let [c (chan 2)]
	140	(is (true? (offer! c 1)))
	141	(is (true? (offer! c 2)))
	142	(is (nil? (offer! c 3)))
	143	(is (= 1 (<!! c)))
	144	(is (= 2 (poll! c)))
	145	(is (nil? (poll! c))))
	146	(let [c (chan)]
	147	(is (nil? (offer! c 1)))
	148	(is (nil? (poll! c)))))
	149
	150	(deftest test-promise-chan
	151	(testing "put on promise-chan fulfills all pending takers"
	152	(let [c (promise-chan)
	153	t1 (thread (<!! c))
	154	t2 (thread (<!! c))]
	155	(>!! c :val)
	156	(is (= :val (<!! t1) (<!! t2)))
	157	(testing "then puts succeed but are dropped"
	158	(>!! c :LOST)
	159	(is (= :val (<!! c))))
	160	(testing "then takes succeed with the original value"
	161	(is (= :val (<!! c) (<!! c) (<!! c))))
	162	(testing "then after close takes continue returning value"
	163	(close! c)
	164	(is (= :val (<!! c) (<!! c))))))
	165	(testing "close on promise-chan fulfills all pending takers"
	166	(let [c (promise-chan)
	167	t1 (thread (<!! c))
	168	t2 (thread (<!! c))]
	169	(close! c)
	170	(is (= nil (<!! t1) (<!! t2)))
	171	(testing "then takes return nil"
	172	(is (= nil (<!! t1) (<!! t1) (<!! t2) (<!! t2))))))
	173	(testing "close after put on promise-chan continues delivering promised value"
	174	(let [c (promise-chan)]
	175	(>!! c :val) ;; deliver
	176	(is (= :val (<!! c) (<!! c)))
	177	(close! c)
	178	(is (= :val (<!! c) (<!! c))))))
	179
	180	(def ^:dynamic test-dyn false)
	181
	182	(deftest thread-tests
	183	(testing "bindings"
	184	(binding [test-dyn true]
	185	(is (<!! (thread test-dyn))))))
	186
	187
	188	(deftest ops-tests
	189	(testing "map<"
	190	(is (= [2 3 4 5]
	191	(<!! (a/into [] (a/map< inc (a/to-chan [1 2 3 4])))))))
	192	(testing "map>"
	193	(is (= [2 3 4 5]
	194	(let [out (chan)
	195	in (a/map> inc out)]
	196	(a/onto-chan in [1 2 3 4])
	197	(<!! (a/into [] out))))))
	198	(testing "filter<"
	199	(is (= [2 4 6]
	200	(<!! (a/into [] (a/filter< even? (a/to-chan [1 2 3 4 5 6])))))))
	201	(testing "remove<"
	202	(is (= [1 3 5]
	203	(<!! (a/into [] (a/remove< even? (a/to-chan [1 2 3 4 5 6])))))))
	204
	205	(testing "onto-chan"
	206	(is (= (range 10)
	207	(<!! (a/into [] (a/to-chan (range 10)))))))
	208
	209	(testing "filter>"
	210	(is (= [2 4 6]
	211	(let [out (chan)
	212	in (filter> even? out)]
	213	(a/onto-chan in [1 2 3 4 5 6])
	214	(<!! (a/into [] out))))))
	215	(testing "remove>"
	216	(is (= [1 3 5]
	217	(let [out (chan)
	218	in (remove> even? out)]
	219	(a/onto-chan in [1 2 3 4 5 6])
	220	(<!! (a/into [] out))))))
	221	(testing "mapcat<"
	222	(is (= [0 0 1 0 1 2]
	223	(<!! (a/into [] (mapcat< range
	224	(a/to-chan [1 2 3])))))))
	225	(testing "mapcat>"
	226	(is (= [0 0 1 0 1 2]
	227	(let [out (chan)
	228	in (mapcat> range out)]
	229	(a/onto-chan in [1 2 3])
	230	(<!! (a/into [] out))))))
	231
	232
	233	(testing "pipe"
	234	(is (= [1 2 3 4 5]
	235	(let [out (chan)]
	236	(pipe (a/to-chan [1 2 3 4 5])
	237	out)
	238	(<!! (a/into [] out))))))
	239	(testing "split"
	240	;; Must provide buffers for channels else the tests won't complete
	241	(let [[even odd] (a/split even? (a/to-chan [1 2 3 4 5 6]) 5 5)]
	242	(is (= [2 4 6]
	243	(<!! (a/into [] even))))
	244	(is (= [1 3 5]
	245	(<!! (a/into [] odd))))))
	246	(testing "map"
	247	(is (= [0 4 8 12]
	248	(<!! (a/into [] (a/map + [(a/to-chan (range 4))
	249	(a/to-chan (range 4))
	250	(a/to-chan (range 4))
	251	(a/to-chan (range 4))]))))))
	252	(testing "merge"
	253	;; merge uses alt, so results can be in any order, we're using
	254	;; frequencies as a way to make sure we get the right result.
	255	(is (= {0 4
	256	1 4
	257	2 4
	258	3 4}
	259	(frequencies (<!! (a/into [] (a/merge [(a/to-chan (range 4))
	260	(a/to-chan (range 4))
	261	(a/to-chan (range 4))
	262	(a/to-chan (range 4))])))))))
	263
	264	(testing "mult"
	265	(let [a (chan 4)
	266	b (chan 4)
	267	src (chan)
	268	m (mult src)]
	269	(tap m a)
	270	(tap m b)
	271	(pipe (a/to-chan (range 4)) src)
	272	(is (= [0 1 2 3]
	273	(<!! (a/into [] a))))
	274	(is (= [0 1 2 3]
	275	(<!! (a/into [] b))))))
	276
	277
	278	(testing "mix"
	279	(let [out (chan)
	280	mx (mix out)]
	281	(admix mx (a/to-chan [1 2 3]))
	282	(admix mx (a/to-chan [4 5 6]))
	283
	284	(is (= #{1 2 3 4 5 6}
	285	(<!! (a/into #{} (a/take 6 out)))))))
	286
	287	(testing "pub-sub"
	288	(let [a-ints (chan 5)
	289	a-strs (chan 5)
	290	b-ints (chan 5)
	291	b-strs (chan 5)
	292	src (chan)
	293	p (pub src (fn [x]
	294	(if (string? x)
	295	:string
	296	:int)))]
	297	(sub p :string a-strs)
	298	(sub p :string b-strs)
	299	(sub p :int a-ints)
	300	(sub p :int b-ints)
	301	(pipe (a/to-chan [1 "a" 2 "b" 3 "c"]) src)
	302	(is (= [1 2 3]
	303	(<!! (a/into [] a-ints))))
	304	(is (= [1 2 3]
	305	(<!! (a/into [] b-ints))))
	306	(is (= ["a" "b" "c"]
	307	(<!! (a/into [] a-strs))))
	308	(is (= ["a" "b" "c"]
	309	(<!! (a/into [] b-strs))))))
	310
	311	(testing "unique"
	312	(is (= [1 2 3 4]
	313	(<!! (a/into [] (a/unique (a/to-chan [1 1 2 2 3 3 3 3 4])))))))
	314
	315	(testing "partition"
	316	(is (= [[1 2] [2 3]]
	317	(<!! (a/into [] (a/partition 2 (a/to-chan [1 2 2 3])))))))
	318	(testing "partition-by"
	319	(is (= [["a" "b"] [1 :2 3] ["c"]]
	320	(<!! (a/into [] (a/partition-by string? (a/to-chan ["a" "b" 1 :2 3 "c"])))))))
	321
	322	(testing "reduce"
	323	(is (= 0 (<!! (a/reduce + 0 (a/to-chan [])))))
	324	(is (= 45 (<!! (a/reduce + 0 (a/to-chan (range 10))))))
	325	(is (= :foo (<!! (a/reduce #(if (= %2 2) (reduced :foo) %1) 0 (a/to-chan (range 10)))))))
	326	)
	327
	328	;; transducer yielding n copies of each input value
	329	;; (into [] (xerox 2) [1 2 3]) => [1 1 2 2 3 3]
	330	(defn xerox [n]
	331	(fn [f1]
	332	(fn
	333	([] (f1))
	334	([result] (f1 result))
	335	([result input]
	336	(loop [res result
	337	i n]
	338	(if (pos? i)
	339	(let [a (f1 result input)]
	340	(if (reduced? a)
	341	a
	342	(recur a (dec i))))
	343	res))))))
	344
	345	(defn check-expanding-transducer [buffer-size in multiplier takers]
	346	(let [input (range in)
	347	xf (xerox multiplier)
	348	expected (apply interleave (repeat multiplier input))
	349	counter (atom 0)
	350	res (atom [])
	351	c (chan buffer-size xf)]
	352	(dotimes [x takers]
	353	(take! c #(do
	354	(when (some? %) (swap! res conj %))
	355	(swap! counter inc))))
	356	(onto-chan c input)
	357
	358	;; wait for all takers to report
	359	(while (< @counter takers)
	360	(Thread/sleep 50))
	361
	362	;; check expected results
	363	(is (= (sort (clojure.core/take takers expected))
	364	(sort @res)))))
	365
	366	(deftest expanding-transducer-delivers-to-multiple-pending
	367	(doseq [b (range 1 10)
	368	t (range 1 10)]
	369	(check-expanding-transducer b 3 3 t)))
	370
	371	;; in 1.7+, use (map f)
	372	(defn mapping [f]
	373	(fn [f1]
	374	(fn
	375	([] (f1))
	376	([result] (f1 result))
	377	([result input]
	378	(f1 result (f input)))
	379	([result input & inputs]
	380	(f1 result (apply f input inputs))))))
	381
	382	(deftest test-transduce
	383	(is (= [1 2 3 4 5]
	384	(<!! (a/transduce (mapping inc) conj [] (a/to-chan (range 5)))))))⏎

+100

-0

src/test/clojure/clojure/core/pipeline_test.clj less more

	0	(ns clojure.core.pipeline-test
	1	(:require [clojure.test :refer (deftest is are)]
	2	[clojure.core.async :as a :refer [<! >! <!! >!! go go-loop thread chan close! to-chan
	3	pipeline pipeline-blocking pipeline-async]]))
	4
	5	;; in Clojure 1.7, use (map f) instead of this
	6	(defn mapping [f]
	7	(fn [f1]
	8	(fn
	9	([] (f1))
	10	([result] (f1 result))
	11	([result input]
	12	(f1 result (f input)))
	13	([result input & inputs]
	14	(f1 result (apply f input inputs))))))
	15
	16	(defn pipeline-tester [pipeline-fn n inputs xf]
	17	(let [cin (to-chan inputs)
	18	cout (chan 1)]
	19	(pipeline-fn n cout xf cin)
	20	(<!! (go-loop [acc []]
	21	(let [val (<! cout)]
	22	(if (not (nil? val))
	23	(recur (conj acc val))
	24	acc))))))
	25
	26	(def identity-mapping (mapping identity))
	27	(defn identity-async [v ch] (thread (>!! ch v) (close! ch)))
	28
	29	(deftest test-sizes
	30	(are [n size]
	31	(let [r (range size)]
	32	(and
	33	(= r (pipeline-tester pipeline n r identity-mapping))
	34	(= r (pipeline-tester pipeline-blocking n r identity-mapping))
	35	(= r (pipeline-tester pipeline-async n r identity-async))))
	36	1 0
	37	1 10
	38	10 10
	39	20 10
	40	5 1000))
	41
	42	(deftest test-close?
	43	(doseq [pf [pipeline pipeline-blocking]]
	44	(let [cout (chan 1)]
	45	(pf 5 cout identity-mapping (to-chan [1]) true)
	46	(is (= 1 (<!! cout)))
	47	(is (= nil (<!! cout))))
	48	(let [cout (chan 1)]
	49	(pf 5 cout identity-mapping (to-chan [1]) false)
	50	(is (= 1 (<!! cout)))
	51	(>!! cout :more)
	52	(is (= :more (<!! cout))))
	53	(let [cout (chan 1)]
	54	(pf 5 cout identity-mapping (to-chan [1]) nil)
	55	(is (= 1 (<!! cout)))
	56	(>!! cout :more)
	57	(is (= :more (<!! cout))))))
	58
	59	(deftest test-ex-handler
	60	(doseq [pf [pipeline pipeline-blocking]]
	61	(let [cout (chan 1)
	62	chex (chan 1)
	63	ex-mapping (mapping (fn [x] (if (= x 3) (throw (ex-info "err" {:data x})) x)))
	64	ex-handler (fn [e] (do (>!! chex e) :err))]
	65	(pf 5 cout ex-mapping (to-chan [1 2 3 4]) true ex-handler)
	66	(is (= 1 (<!! cout)))
	67	(is (= 2 (<!! cout)))
	68	(is (= :err (<!! cout)))
	69	(is (= 4 (<!! cout)))
	70	(is (= {:data 3} (ex-data (<!! chex)))))))
	71
	72	(defn multiplier-async [v ch]
	73	(thread
	74	(dotimes [i v]
	75	(>!! ch i))
	76	(close! ch)))
	77
	78	(deftest test-af-multiplier
	79	(is (= [0 0 1 0 1 2 0 1 2 3]
	80	(pipeline-tester pipeline-async 2 (range 1 5) multiplier-async))))
	81
	82	(def sleep-mapping (mapping #(do (Thread/sleep %) %)))
	83
	84	(deftest test-blocking
	85	(let [times [2000 50 1000 100]]
	86	(is (= times (pipeline-tester pipeline-blocking 2 times sleep-mapping)))))
	87
	88	(defn slow-fib [n]
	89	(if (< n 2) n (+ (slow-fib (- n 1)) (slow-fib (- n 2)))))
	90
	91	(deftest test-compute
	92	(let [input (take 50 (cycle (range 15 38)))]
	93	(is (= (slow-fib (last input))
	94	(last (pipeline-tester pipeline 8 input (mapping slow-fib)))))))
	95
	96	(deftest test-async
	97	(is (= (range 1 101)
	98	(pipeline-tester pipeline-async 1 (range 100)
	99	(fn [v ch] (future (>!! ch (inc v)) (close! ch)))))))