├── .gitignore ├── LICENSE ├── README.md ├── doc └── intro.md ├── project.clj ├── src └── eclj │ ├── common.clj │ ├── core.clj │ ├── core │ ├── base.eclj │ ├── bools.eclj │ ├── case.eclj │ ├── colls.eclj │ ├── defprotocol.eclj │ ├── deftype.eclj │ ├── delays.eclj │ ├── equiv.eclj │ ├── ext.eclj │ ├── flow.eclj │ ├── fns.eclj │ ├── hash.eclj │ ├── jvm.eclj │ ├── locks.eclj │ ├── maps.eclj │ ├── metadata.eclj │ ├── names.eclj │ ├── order.eclj │ ├── protocols.eclj │ ├── refs.eclj │ ├── seqs.eclj │ ├── sets.eclj │ ├── strs.eclj │ └── vecs.eclj │ ├── env.clj │ ├── fn.clj │ ├── interpret │ ├── cps.clj │ └── meta.eclj │ ├── method_cache.clj │ ├── multi_fn.eclj │ ├── ns.clj │ ├── parse.clj │ └── reader.clj └── test └── eclj ├── eval_test.clj ├── ext_test.clj └── parse_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /classes 3 | /checkouts 4 | pom.xml 5 | pom.xml.asc 6 | *.jar 7 | *.class 8 | /.lein-* 9 | /.nrepl-port 10 | /*.iml 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC 2 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM 3 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 4 | 5 | 1. DEFINITIONS 6 | 7 | "Contribution" means: 8 | 9 | a) in the case of the initial Contributor, the initial code and 10 | documentation distributed under this Agreement, and 11 | 12 | b) in the case of each subsequent Contributor: 13 | 14 | i) changes to the Program, and 15 | 16 | ii) additions to the Program; 17 | 18 | where such changes and/or additions to the Program originate from and are 19 | distributed by that particular Contributor. A Contribution 'originates' from 20 | a Contributor if it was added to the Program by such Contributor itself or 21 | anyone acting on such Contributor's behalf. Contributions do not include 22 | additions to the Program which: (i) are separate modules of software 23 | distributed in conjunction with the Program under their own license 24 | agreement, and (ii) are not derivative works of the Program. 25 | 26 | "Contributor" means any person or entity that distributes the Program. 27 | 28 | "Licensed Patents" mean patent claims licensable by a Contributor which are 29 | necessarily infringed by the use or sale of its Contribution alone or when 30 | combined with the Program. 31 | 32 | "Program" means the Contributions distributed in accordance with this 33 | Agreement. 34 | 35 | "Recipient" means anyone who receives the Program under this Agreement, 36 | including all Contributors. 37 | 38 | 2. GRANT OF RIGHTS 39 | 40 | a) Subject to the terms of this Agreement, each Contributor hereby grants 41 | Recipient a non-exclusive, worldwide, royalty-free copyright license to 42 | reproduce, prepare derivative works of, publicly display, publicly perform, 43 | distribute and sublicense the Contribution of such Contributor, if any, and 44 | such derivative works, in source code and object code form. 45 | 46 | b) Subject to the terms of this Agreement, each Contributor hereby grants 47 | Recipient a non-exclusive, worldwide, royalty-free patent license under 48 | Licensed Patents to make, use, sell, offer to sell, import and otherwise 49 | transfer the Contribution of such Contributor, if any, in source code and 50 | object code form. This patent license shall apply to the combination of the 51 | Contribution and the Program if, at the time the Contribution is added by the 52 | Contributor, such addition of the Contribution causes such combination to be 53 | covered by the Licensed Patents. The patent license shall not apply to any 54 | other combinations which include the Contribution. No hardware per se is 55 | licensed hereunder. 56 | 57 | c) Recipient understands that although each Contributor grants the licenses 58 | to its Contributions set forth herein, no assurances are provided by any 59 | Contributor that the Program does not infringe the patent or other 60 | intellectual property rights of any other entity. Each Contributor disclaims 61 | any liability to Recipient for claims brought by any other entity based on 62 | infringement of intellectual property rights or otherwise. As a condition to 63 | exercising the rights and licenses granted hereunder, each Recipient hereby 64 | assumes sole responsibility to secure any other intellectual property rights 65 | needed, if any. For example, if a third party patent license is required to 66 | allow Recipient to distribute the Program, it is Recipient's responsibility 67 | to acquire that license before distributing the Program. 68 | 69 | d) Each Contributor represents that to its knowledge it has sufficient 70 | copyright rights in its Contribution, if any, to grant the copyright license 71 | set forth in this Agreement. 72 | 73 | 3. REQUIREMENTS 74 | 75 | A Contributor may choose to distribute the Program in object code form under 76 | its own license agreement, provided that: 77 | 78 | a) it complies with the terms and conditions of this Agreement; and 79 | 80 | b) its license agreement: 81 | 82 | i) effectively disclaims on behalf of all Contributors all warranties and 83 | conditions, express and implied, including warranties or conditions of title 84 | and non-infringement, and implied warranties or conditions of merchantability 85 | and fitness for a particular purpose; 86 | 87 | ii) effectively excludes on behalf of all Contributors all liability for 88 | damages, including direct, indirect, special, incidental and consequential 89 | damages, such as lost profits; 90 | 91 | iii) states that any provisions which differ from this Agreement are offered 92 | by that Contributor alone and not by any other party; and 93 | 94 | iv) states that source code for the Program is available from such 95 | Contributor, and informs licensees how to obtain it in a reasonable manner on 96 | or through a medium customarily used for software exchange. 97 | 98 | When the Program is made available in source code form: 99 | 100 | a) it must be made available under this Agreement; and 101 | 102 | b) a copy of this Agreement must be included with each copy of the Program. 103 | 104 | Contributors may not remove or alter any copyright notices contained within 105 | the Program. 106 | 107 | Each Contributor must identify itself as the originator of its Contribution, 108 | if any, in a manner that reasonably allows subsequent Recipients to identify 109 | the originator of the Contribution. 110 | 111 | 4. COMMERCIAL DISTRIBUTION 112 | 113 | Commercial distributors of software may accept certain responsibilities with 114 | respect to end users, business partners and the like. While this license is 115 | intended to facilitate the commercial use of the Program, the Contributor who 116 | includes the Program in a commercial product offering should do so in a 117 | manner which does not create potential liability for other Contributors. 118 | Therefore, if a Contributor includes the Program in a commercial product 119 | offering, such Contributor ("Commercial Contributor") hereby agrees to defend 120 | and indemnify every other Contributor ("Indemnified Contributor") against any 121 | losses, damages and costs (collectively "Losses") arising from claims, 122 | lawsuits and other legal actions brought by a third party against the 123 | Indemnified Contributor to the extent caused by the acts or omissions of such 124 | Commercial Contributor in connection with its distribution of the Program in 125 | a commercial product offering. The obligations in this section do not apply 126 | to any claims or Losses relating to any actual or alleged intellectual 127 | property infringement. In order to qualify, an Indemnified Contributor must: 128 | a) promptly notify the Commercial Contributor in writing of such claim, and 129 | b) allow the Commercial Contributor tocontrol, and cooperate with the 130 | Commercial Contributor in, the defense and any related settlement 131 | negotiations. The Indemnified Contributor may participate in any such claim 132 | at its own expense. 133 | 134 | For example, a Contributor might include the Program in a commercial product 135 | offering, Product X. That Contributor is then a Commercial Contributor. If 136 | that Commercial Contributor then makes performance claims, or offers 137 | warranties related to Product X, those performance claims and warranties are 138 | such Commercial Contributor's responsibility alone. Under this section, the 139 | Commercial Contributor would have to defend claims against the other 140 | Contributors related to those performance claims and warranties, and if a 141 | court requires any other Contributor to pay any damages as a result, the 142 | Commercial Contributor must pay those damages. 143 | 144 | 5. NO WARRANTY 145 | 146 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON 147 | AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER 148 | EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR 149 | CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A 150 | PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the 151 | appropriateness of using and distributing the Program and assumes all risks 152 | associated with its exercise of rights under this Agreement , including but 153 | not limited to the risks and costs of program errors, compliance with 154 | applicable laws, damage to or loss of data, programs or equipment, and 155 | unavailability or interruption of operations. 156 | 157 | 6. DISCLAIMER OF LIABILITY 158 | 159 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY 160 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, 161 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION 162 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 163 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 164 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE 165 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY 166 | OF SUCH DAMAGES. 167 | 168 | 7. GENERAL 169 | 170 | If any provision of this Agreement is invalid or unenforceable under 171 | applicable law, it shall not affect the validity or enforceability of the 172 | remainder of the terms of this Agreement, and without further action by the 173 | parties hereto, such provision shall be reformed to the minimum extent 174 | necessary to make such provision valid and enforceable. 175 | 176 | If Recipient institutes patent litigation against any entity (including a 177 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself 178 | (excluding combinations of the Program with other software or hardware) 179 | infringes such Recipient's patent(s), then such Recipient's rights granted 180 | under Section 2(b) shall terminate as of the date such litigation is filed. 181 | 182 | All Recipient's rights under this Agreement shall terminate if it fails to 183 | comply with any of the material terms or conditions of this Agreement and 184 | does not cure such failure in a reasonable period of time after becoming 185 | aware of such noncompliance. If all Recipient's rights under this Agreement 186 | terminate, Recipient agrees to cease use and distribution of the Program as 187 | soon as reasonably practicable. However, Recipient's obligations under this 188 | Agreement and any licenses granted by Recipient relating to the Program shall 189 | continue and survive. 190 | 191 | Everyone is permitted to copy and distribute copies of this Agreement, but in 192 | order to avoid inconsistency the Agreement is copyrighted and may only be 193 | modified in the following manner. The Agreement Steward reserves the right to 194 | publish new versions (including revisions) of this Agreement from time to 195 | time. No one other than the Agreement Steward has the right to modify this 196 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The 197 | Eclipse Foundation may assign the responsibility to serve as the Agreement 198 | Steward to a suitable separate entity. Each new version of the Agreement will 199 | be given a distinguishing version number. The Program (including 200 | Contributions) may always be distributed subject to the version of the 201 | Agreement under which it was received. In addition, after a new version of 202 | the Agreement is published, Contributor may elect to distribute the Program 203 | (including its Contributions) under the new version. Except as expressly 204 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or 205 | licenses to the intellectual property of any Contributor under this 206 | Agreement, whether expressly, by implication, estoppel or otherwise. All 207 | rights in the Program not expressly granted under this Agreement are 208 | reserved. 209 | 210 | This Agreement is governed by the laws of the State of Washington and the 211 | intellectual property laws of the United States of America. No party to this 212 | Agreement will bring a legal action under this Agreement more than one year 213 | after the cause of action arose. Each party waives its rights to a jury trial 214 | in any resulting litigation. 215 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Extensible Clojure 2 | 3 | An extensible, symbolic, functionally-pure Clojure interpreter. 4 | 5 | Extensible Clojure aims to completely virtualize the Clojure language, such 6 | that portable Clojure code can be run within a precisely controlled 7 | environment. Proper tail calls are supported via delimited continuations, 8 | which enables all effects to be modeled as pure data. Effects, including 9 | bidirectional interop, are processed at the top-level of the interpreter loop, 10 | so they too are fully programmable. 11 | 12 | This project's ambitious goals are based on a vast academic foundation. Oleg 13 | Kiselyov's [Extensible Effects & Interpreters][1] page provides an excellent 14 | entry point. I'm also interested in building an evaluator that includes an 15 | extensible abstract interpreter and extensible JIT compiler. See [Lancet][2]. 16 | 17 | 18 | ## Status 19 | 20 | Experimental and unstable! 21 | 22 | Development temporarily halted because I couldn't wrap my head around how to 23 | write a compiler for this thing. In the interim, I've developed 24 | [Meta-Clojure][3], which may get me over the hump. 25 | 26 | ### Platform 27 | 28 | Runs on the JVM with Clojure 1.6.0. 29 | 30 | Standalone deployment and cross-compilation to alternative platforms are goals. 31 | 32 | ### Evaluator 33 | 34 | The base interpreter is written in a trampolined continuation-passing style. It 35 | is complete enough to be self-applicable. There is also a meta-circular 36 | interpreter written in a direct style, utilizing constant space tail calls and 37 | the effect system. This meta-interpreter is *highly* experimental and will form 38 | the foundation of the forthcoming JIT compiler. 39 | 40 | ### Libraries 41 | 42 | The core libraries are currently a hybrid of compiled functions borrowed from 43 | `clojure.core` and symbolic EClj ports. Borrowed functions are actively being 44 | ported and abstracted to facilitate partial evaluation, utilize the effect 45 | system, and ease future targeting of non-JVM platforms. 46 | 47 | ### Types 48 | 49 | Clojure's primary data structures (those defined in Java) are the primary data 50 | structures used throughout EClj as well. Ultimately, EClj will provide 51 | additional implementations of these data structures wherever possible, but 52 | will maintain interop via the existing Java interfaces. The goal is for EClj 53 | to use the most appropriate data structures for the host. 54 | 55 | Type defining forms (`reify`, `deftype`, and `defrecord`) delegate to the 56 | Clojure compiler to create the JVM type, but methods are interpreted by EClj. 57 | Effects cannot (yet) propagate across JVM method call boundaries. 58 | 59 | ### Not In Scope 60 | 61 | * monitor-enter 62 | * monitor-exit 63 | 64 | 65 | ## Usage 66 | 67 | Only `eclj.core` provides a stable(-ish) public API at this time. It exports 68 | the same functionality as `clojure.core` with some to-be-documented extensions. 69 | 70 | You can evaluate individual forms with `eclj.core/eval` and load `.eclj` files 71 | with `eclj.core/require` or related namespace & code loading functions. EClj 72 | can interop with normal Clojure code seamlessly, but `clojure.core/ns` can't 73 | load EClj. Of course, `eclj.core/ns` can require either file type. 74 | 75 | Various caveats apply, but the list is too volatile to justify enumerating now. 76 | 77 | 78 | ## License 79 | 80 | Portions of this project derived from Clojure: 81 | Copyright © 2006-2014 Rich Hickey 82 | 83 | Original code and Clojure modifications: 84 | Copyright © 2014 Brandon Bloom 85 | 86 | Both are distributed under the Eclipse Public License either version 1.0 or 87 | (at your option) any later version. 88 | 89 | 90 | [1]: http://okmij.org/ftp/Haskell/extensible/ 91 | [2]: https://github.com/TiarkRompf/lancet 92 | [3]: https://github.com/brandonbloom/metaclj 93 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to eclj 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject eclj "0.1.0-SNAPSHOT" 2 | :description "Extensible Clojure" 3 | :url "https://github.com/brandonbloom/eclj" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.6.0"] 7 | [org.clojure/tools.reader "0.8.4"]] 8 | :jvm-opts ^:replace ["-Xmx1g" "-server"]) 9 | -------------------------------------------------------------------------------- /src/eclj/common.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.common) 2 | 3 | ;;TODO: Install handler that converts all effects in to errors. 4 | (defmacro pure [x] x) 5 | 6 | (defrecord Syntax [head form env]) 7 | 8 | ;; For symbol macros. 9 | (defrecord Expansion [expr]) 10 | 11 | (defn expansion? [expr] 12 | (instance? Expansion expr)) 13 | -------------------------------------------------------------------------------- /src/eclj/core.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.core 2 | (:refer-clojure :only []) 3 | (:require [eclj.interpret.cps :as cps] 4 | [eclj.env :as env] 5 | [eclj.common :refer (map->Syntax)] 6 | [eclj.method-cache])) 7 | 8 | (clojure.core/defn eval 9 | ([form] 10 | (eval form (env/ns-env))) 11 | ([form env] 12 | (cps/interpret-result form env))) 13 | 14 | (clojure.core/intern 'eclj.core 'eval eval) 15 | (clojure.core/require '[eclj.ns :as ns]) 16 | 17 | (ns/publish-vars 'clojure.core :exclude '#{ 18 | eval case ns deftype defrecord defprotocol refer-clojure apply 19 | }) 20 | 21 | (defn load 22 | "Loads Clojure code from resources in classpath. A path is interpreted as 23 | classpath-relative if it begins with a slash or relative to the root 24 | directory for the current namespace otherwise." 25 | [& paths] 26 | (doseq [path paths] 27 | (ns/load path))) 28 | 29 | (defn require 30 | "Loads libs, skipping any that are already loaded. Each argument is 31 | either a libspec that identifies a lib, a prefix list that identifies 32 | multiple libs whose names share a common prefix, or a flag that modifies 33 | how all the identified libs are loaded. Use :require in the ns macro 34 | in preference to calling this directly. 35 | 36 | Libs 37 | 38 | A 'lib' is a named set of resources in classpath whose contents define a 39 | library of Clojure code. Lib names are symbols and each lib is associated 40 | with a Clojure namespace and a Java package that share its name. A lib's 41 | name also locates its root directory within classpath using Java's 42 | package name to classpath-relative path mapping. All resources in a lib 43 | should be contained in the directory structure under its root directory. 44 | All definitions a lib makes should be in its associated namespace. 45 | 46 | 'require loads a lib by loading its root resource. The root resource path 47 | is derived from the lib name in the following manner: 48 | Consider a lib named by the symbol 'x.y.z; it has the root directory 49 | /x/y/, and its root resource is /x/y/z.clj. The root 50 | resource should contain code to create the lib's namespace (usually by using 51 | the ns macro) and load any additional lib resources. 52 | 53 | Libspecs 54 | 55 | A libspec is a lib name or a vector containing a lib name followed by 56 | options expressed as sequential keywords and arguments. 57 | 58 | Recognized options: 59 | :as takes a symbol as its argument and makes that symbol an alias to the 60 | lib's namespace in the current namespace. 61 | :refer takes a list of symbols to refer from the namespace or the :all 62 | keyword to bring in all public vars. 63 | 64 | Prefix Lists 65 | 66 | It's common for Clojure code to depend on several libs whose names have 67 | the same prefix. When specifying libs, prefix lists can be used to reduce 68 | repetition. A prefix list contains the shared prefix followed by libspecs 69 | with the shared prefix removed from the lib names. After removing the 70 | prefix, the names that remain must not contain any periods. 71 | 72 | Flags 73 | 74 | A flag is a keyword. 75 | Recognized flags: :reload, :reload-all, :verbose 76 | :reload forces loading of all the identified libs even if they are 77 | already loaded 78 | :reload-all implies :reload and also forces loading of all libs that the 79 | identified libs directly or indirectly load via require or use 80 | :verbose triggers printing information about each load, alias, and refer 81 | 82 | Example: 83 | 84 | The following would load the libraries clojure.zip and clojure.set 85 | abbreviated as 's'. 86 | 87 | (require '(clojure zip [set :as s]))" 88 | [& args] 89 | (clojure.core/apply ns/load-libs :require args)) 90 | 91 | (defn use 92 | "Like 'require, but also refers to each lib's namespace using 93 | eclj.core/refer. Use :use in the ns macro in preference to calling 94 | this directly. 95 | 96 | 'use accepts additional options in libspecs: :exclude, :only, :rename. 97 | The arguments and semantics for :exclude, :only, and :rename are the same 98 | as those documented for eclj.core/refer." 99 | [& args] 100 | (clojure.core/apply ns/load-libs :require :use args)) 101 | 102 | (eclj.ns/load-eclj "eclj/core/base.eclj") 103 | (eclj.ns/load-eclj "eclj/core/ext.eclj") 104 | (eclj.ns/load-eclj "eclj/core/case.eclj") 105 | (eclj.ns/load-eclj "eclj/core/deftype.eclj") 106 | (eclj.ns/load-eclj "eclj/core/defprotocol.eclj") 107 | (eclj.ns/load-eclj "eclj/core/protocols.eclj") 108 | (eclj.ns/load-eclj "eclj/core/jvm.eclj") 109 | (eclj.ns/load-eclj "eclj/core/bools.eclj") 110 | (eclj.ns/load-eclj "eclj/core/equiv.eclj") 111 | (eclj.ns/load-eclj "eclj/core/metadata.eclj") 112 | (eclj.ns/load-eclj "eclj/core/refs.eclj") 113 | (eclj.ns/load-eclj "eclj/core/locks.eclj") 114 | (eclj.ns/load-eclj "eclj/core/delays.eclj") 115 | (eclj.ns/load-eclj "eclj/core/hash.eclj") 116 | (eclj.ns/load-eclj "eclj/core/seqs.eclj") 117 | (eclj.ns/load-eclj "eclj/core/colls.eclj") 118 | (eclj.ns/load-eclj "eclj/core/maps.eclj") 119 | (eclj.ns/load-eclj "eclj/core/sets.eclj") 120 | (eclj.ns/load-eclj "eclj/core/vecs.eclj") 121 | (eclj.ns/load-eclj "eclj/core/fns.eclj") 122 | (eclj.ns/load-eclj "eclj/core/strs.eclj") 123 | (eclj.ns/load-eclj "eclj/core/names.eclj") 124 | (eclj.ns/load-eclj "eclj/core/flow.eclj") 125 | (eclj.ns/load-eclj "eclj/core/order.eclj") 126 | -------------------------------------------------------------------------------- /src/eclj/core/base.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | ;;TODO: Implement restarts, etc. 4 | (defn signal [condition] 5 | (raise (merge {:op :condition} condition))) 6 | 7 | (defn- recur-handler [f env] 8 | (fn [effect] 9 | (when (= (:op effect) :recur) 10 | (if (tail-effect? effect) 11 | (answer (eval-syntax {:head :apply :f f :arg (:args effect) :env env})) 12 | (signal {:error :non-tail-position}))))) 13 | 14 | (defn apply* [f args] ;TODO: Open dispatch 15 | (cond 16 | 17 | (instance? eclj.fn.Fn f) 18 | (let [{:keys [name arities max-fixed-arity env]} f 19 | argcount (count (if (counted? args) 20 | args 21 | (take (inc max-fixed-arity) args))) 22 | {:keys [params expr]} (or (arities argcount) 23 | (and (>= argcount max-fixed-arity) 24 | (arities :more))) 25 | ;;TODO: port arity checking code from cps interpreter. 26 | env* (if name (assoc-in env [:locals name] f) env) 27 | ;;TODO: Don't generate form, destructure to env & use AST directly. 28 | form `(let [~params '~args] ~expr)] 29 | (handle-with (recur-handler f env) 30 | (eval form env*))) 31 | 32 | (instance? clojure.lang.Var f) 33 | (apply* (raise {:op :deref :ref f}) args) 34 | 35 | (instance? clojure.lang.IFn f) 36 | (raise {:op :invoke :f f :args args}) 37 | 38 | :else (signal {:error :not-callable :f f :args args}) 39 | 40 | )) 41 | 42 | (defn- spread [arglist] 43 | (cond 44 | (nil? arglist) nil 45 | (nil? (next arglist)) (seq (first arglist)) 46 | :else (cons (first arglist) (spread (next arglist))))) 47 | 48 | (defn apply 49 | "Applies fn f to the argument list formed by prepending intervening 50 | arguments to args." 51 | [f & args] 52 | (apply* f (spread args))) 53 | 54 | 55 | 56 | (defmacro refer-clojure 57 | "Same as (refer 'eclj.core )" 58 | [& filters] 59 | `(eclj.core/refer '~'eclj.core ~@filters)) 60 | 61 | (defmacro ns 62 | "Sets *ns* to the namespace named by name (unevaluated), creating it 63 | if needed. references can be zero or more of: (:refer-clojure ...) 64 | (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class) 65 | with the syntax of refer-clojure/require/use/import/load/gen-class 66 | respectively, except the arguments are unevaluated and need not be 67 | quoted. (:gen-class ...), when supplied, defaults to :name 68 | corresponding to the ns name, :main true, :impl-ns same as ns, and 69 | :init-impl-ns true. All options of gen-class are 70 | supported. The :gen-class directive is ignored when not 71 | compiling. If :gen-class is not supplied, when compiled only an 72 | nsname__init.class will be generated. If :refer-clojure is not used, a 73 | default (refer-clojure) is used. Use of ns is preferred to 74 | individual calls to in-ns/require/use/import: 75 | 76 | (ns foo.bar 77 | (:refer-clojure :exclude [ancestors printf]) 78 | (:require (clojure.contrib sql combinatorics)) 79 | (:use (my.lib this that)) 80 | (:import (java.util Date Timer Random) 81 | (java.sql Connection Statement)))" 82 | {:arglists '([name docstring? attr-map? references*])} 83 | [name & references] 84 | ;;TODO: gen-class 85 | (let [{:keys [name statements]} (ns/parse &form)] 86 | `(do 87 | (clojure.core/in-ns '~name) 88 | ~@statements 89 | nil))) 90 | 91 | ;;XXX Why do I need this? Seems like the clojure.core/ns var is special cased. 92 | (.setMacro #'eclj.core/ns) 93 | 94 | 95 | (defn ^:private 96 | maybe-destructured 97 | [params body] 98 | (if (every? symbol? params) 99 | (cons params body) 100 | (loop [params params 101 | new-params [] 102 | lets []] 103 | (if params 104 | (if (symbol? (first params)) 105 | (recur (next params) (conj new-params (first params)) lets) 106 | (let [gparam (gensym "p__")] 107 | (recur (next params) (conj new-params gparam) 108 | (-> lets (conj (first params)) (conj gparam))))) 109 | `(~new-params 110 | (let ~lets 111 | ~@body)))))) 112 | 113 | 114 | (defmacro ^:private assert-args 115 | [& pairs] 116 | `(do (when-not ~(first pairs) 117 | (throw (IllegalArgumentException. 118 | (str (first ~'&form) " requires " ~(second pairs) 119 | " in " ~'*ns* ":" (:line (meta ~'&form)))))) 120 | ~(let [more (nnext pairs)] 121 | (when more 122 | (list* `assert-args more))))) 123 | 124 | 125 | (comment ;XXX 126 | 127 | (require 'eclj.interpret.meta :reload) 128 | 129 | (defn eval 130 | "Evaluates the form data structure (not text!) and returns the result. 131 | Unlike clojure.core/eval, optionally accepts an environment instead of the 132 | current namespace's environment. May raise effects when called from EClj." 133 | ([form] 134 | (eval form (env/ns-env))) 135 | ([form env] 136 | (eclj.interpret.meta/eval-result form env))) 137 | 138 | ) 139 | -------------------------------------------------------------------------------- /src/eclj/core/bools.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn nil? 4 | "Returns true if x is nil, false otherwise." 5 | [x] 6 | (identical? x nil)) 7 | 8 | (defn false? 9 | "Returns true if x is the value false, false otherwise." 10 | [x] 11 | (identical? x false)) 12 | 13 | (defn true? 14 | "Returns true if x is the value true, false otherwise." 15 | [x] 16 | (identical? x true)) 17 | 18 | (defn not 19 | "Returns true if x is logical false, false otherwise." 20 | [x] 21 | (if x false true)) 22 | 23 | (defn some? 24 | "Returns true if x is not nil, false otherwise." 25 | [x] 26 | (not (nil? x))) 27 | -------------------------------------------------------------------------------- /src/eclj/core/case.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | ;;TODO: Implement efficent case compilation. 4 | (defmacro case 5 | "Takes an expression, and a set of clauses. 6 | 7 | Each clause can take the form of either: 8 | 9 | test-constant result-expr 10 | 11 | (test-constant1 ... test-constantN) result-expr 12 | 13 | The test-constants are not evaluated. They must be compile-time 14 | literals, and need not be quoted. If the expression is equal to a 15 | test-constant, the corresponding result-expr is returned. A single 16 | default expression can follow the clauses, and its value will be 17 | returned if no clause matches. If no default expression is provided 18 | and no clause matches, an IllegalArgumentException is thrown. 19 | 20 | Unlike cond and condp, case does a constant-time dispatch, the 21 | clauses are not considered sequentially. All manner of constant 22 | expressions are acceptable in case, including numbers, strings, 23 | symbols, keywords, and (Clojure) composites thereof. Note that since 24 | lists are used to group multiple constants that map to the same 25 | expression, a vector can be used to match a list if needed. The 26 | test-constants need not be all of the same type." 27 | [e & clauses] 28 | (let [default? (odd? (count clauses))] 29 | ;;TODO: Handle documented list behavior. 30 | `(eclj.core/case* ~e 31 | ~(->> (if default? (butlast clauses) clauses) 32 | (partition 2) (map vec) (into {})) 33 | ~(if default? 34 | (last clauses) 35 | `(throw (ex-info (str "No clause matching") 36 | {:error :no-matching-clause})))))) 37 | -------------------------------------------------------------------------------- /src/eclj/core/colls.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn coll? 4 | "Returns true if x is not nil and satisfies ICollection" 5 | [x] 6 | (and (some? x) (satisfies? ICollection x))) 7 | 8 | (defn list? 9 | "Returns true if x is not nil and satisfies IList" 10 | [x] 11 | (and (some? x) (satisfies? IList x))) 12 | 13 | (defn associative? 14 | "Returns true if x is not nil and satisfies IAssociative" 15 | [x] 16 | (and (some? x) (satisfies? IAssociative x))) 17 | 18 | (defn sequential? 19 | "Returns true if x is not nil and satisfies ISequential" 20 | [x] 21 | (and (some? x) (satisfies? ISequential x))) 22 | 23 | (defn sorted? 24 | "Returns true if x is not nil and satisfies ISorted" 25 | [x] 26 | (and (some? x) (satisfies? ISorted x))) 27 | 28 | (defn counted? 29 | "Returns true if x is not nil and implements count in constant time" 30 | [x] 31 | (and (some? x) (satisfies? ICounted x))) 32 | 33 | (defn reversible? 34 | "Returns true if x is not nil and satisfies IReversible" 35 | [x] 36 | (and (some? x) (satisfies? IReversible x))) 37 | 38 | (defn conj 39 | "conj[oin]. Returns a new collection with the xs 'added'. (conj nil item) 40 | returns (item). The 'addition' may happen at different 'places' depending 41 | on the concrete type." 42 | [coll & xs] 43 | (reduce -conj coll xs)) 44 | 45 | (defn empty 46 | "Returns an empty collection of the same category as coll, or nil" 47 | [coll] 48 | (-empty coll)) 49 | 50 | (defn empty? 51 | "Returns true if coll has no items - same as (not (seq coll)). 52 | Please use the idiom (seq x) rather than (not (empty? x))" 53 | [coll] 54 | (not (seq coll))) 55 | 56 | (defn not-empty 57 | "If coll is empty, returns nil, else coll" 58 | [coll] 59 | (when (seq coll) coll)) 60 | -------------------------------------------------------------------------------- /src/eclj/core/defprotocol.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn- protocol? 4 | [maybe-p] 5 | (boolean (:on-interface maybe-p))) 6 | 7 | (defn- implements? [protocol atype] 8 | (and atype (.isAssignableFrom ^Class (:on-interface protocol) atype))) 9 | 10 | (defn extends? 11 | "Returns true if atype extends protocol" 12 | [protocol atype] 13 | (boolean (or (implements? protocol atype) 14 | (get (:impls protocol) atype)))) 15 | 16 | (defn extenders 17 | "Returns a collection of the types explicitly extending protocol" 18 | [protocol] 19 | (keys (:impls protocol))) 20 | 21 | (defn find-protocol-impl [protocol x] 22 | (eclj.method-cache/find-impl protocol x)) 23 | 24 | (defn find-protocol-method [protocol methodk x] 25 | (eclj.method-cache/find-method protocol methodk x)) 26 | 27 | (defn satisfies? 28 | "Returns true if x satisfies the protocol" 29 | [protocol x] 30 | (boolean (find-protocol-impl protocol x))) 31 | 32 | (defn- emit-method-builder [on-interface method on-method arglists] 33 | (let [methodk (keyword method) 34 | gthis (gensym) 35 | ginterf (gensym) 36 | gcache (gensym)] 37 | `(fn [cache#] 38 | (let [~gcache (atom cache#) 39 | ~ginterf 40 | (fn 41 | ~@(map 42 | (fn [args] 43 | (let [gargs (map #(gensym (str "gf__" % "__")) args) 44 | target (first gargs)] 45 | `([~@gargs] 46 | (. ~(with-meta target {:tag on-interface}) (~(or on-method method) ~@(rest gargs)))))) 47 | arglists)) 48 | f# 49 | (fn ~gthis 50 | ~@(map 51 | (fn [args] 52 | (let [gargs (map #(gensym (str "gf__" % "__")) args) 53 | target (first gargs)] 54 | `([~@gargs] 55 | (let [f# (.fnFor @~gcache (clojure.lang.Util/classOf ~target))] 56 | (if f# 57 | (f# ~@gargs) 58 | ((eclj.method-cache/cache-method ~gcache ~target ~on-interface ~ginterf) ~@gargs)))))) 59 | arglists))] 60 | f#)))) 61 | 62 | (defn -reset-methods [protocol] 63 | (doseq [[^clojure.lang.Var v build] (:method-builders protocol)] 64 | (let [cache (clojure.lang.MethodImplCache. protocol (keyword (.sym v)))] 65 | (.bindRoot v (build cache))))) 66 | 67 | (defn- assert-same-protocol [protocol-var method-syms] 68 | (doseq [m method-syms] 69 | (let [v (resolve m) 70 | p (:protocol (meta v))] 71 | (when (and v (bound? v) (not= protocol-var p)) 72 | (binding [*out* *err*] 73 | (println "Warning: protocol" protocol-var "is overwriting" 74 | (if p 75 | (str "method " (.sym v) " of protocol " (.sym p)) 76 | (str "function " (.sym v))))))))) 77 | 78 | (defn- emit-protocol [name opts+sigs] 79 | (let [iname (symbol (str (munge (namespace-munge *ns*)) "." (munge name))) 80 | [opts sigs] 81 | (loop [opts {:on-interface iname} sigs opts+sigs] 82 | (condp #(%1 %2) (first sigs) 83 | string? (recur (assoc opts :doc (first sigs)) (next sigs)) 84 | keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs)) 85 | [opts sigs])) 86 | opts (assoc opts :on (list 'quote (:on-interface opts))) 87 | sigs (when sigs 88 | (reduce (fn [m s] 89 | (let [name-meta (meta (first s)) 90 | mname (with-meta (first s) nil) 91 | [arglists doc] 92 | (loop [as [] rs (rest s)] 93 | (if (vector? (first rs)) 94 | (recur (conj as (first rs)) (next rs)) 95 | [(seq as) (first rs)]))] 96 | (when (some #{0} (map count arglists)) 97 | (throw (IllegalArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) 98 | (when (m (keyword mname)) 99 | (throw (IllegalArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) 100 | (assoc m (keyword mname) 101 | (merge name-meta 102 | {:name (vary-meta mname assoc :doc doc :arglists arglists) 103 | :arglists arglists 104 | :doc doc})))) 105 | {} sigs)) 106 | meths (mapcat (fn [sig] 107 | (let [m (munge (:name sig))] 108 | (map #(vector m (vec (repeat (dec (count %))'Object)) 'Object) 109 | (:arglists sig)))) 110 | (vals sigs))] 111 | `(do 112 | (defonce ~name {}) 113 | ~(when (= iname (:on-interface opts)) 114 | `(gen-interface :name ~iname :methods ~meths)) 115 | (alter-meta! (var ~name) assoc :doc ~(:doc opts)) 116 | ~(when sigs 117 | `(#'assert-same-protocol (var ~name) '~(map :name (vals sigs)))) 118 | (alter-var-root (var ~name) merge 119 | (assoc ~opts 120 | :sigs '~sigs 121 | :var (var ~name) 122 | :method-map 123 | ~(and (:on opts) 124 | (apply hash-map 125 | (mapcat 126 | (fn [s] 127 | [(keyword (:name s)) (keyword (or (:on s) (:name s)))]) 128 | (vals sigs)))) 129 | :method-builders 130 | ~(apply hash-map 131 | (mapcat 132 | (fn [s] 133 | [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)}))) 134 | (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) 135 | (vals sigs))))) 136 | (-reset-methods ~name) 137 | '~name))) 138 | 139 | (defmacro defprotocol 140 | "A protocol is a named set of named methods and their signatures: 141 | (defprotocol AProtocolName 142 | 143 | ;optional doc string 144 | \"A doc string for AProtocol abstraction\" 145 | 146 | ;method signatures 147 | (bar [this a b] \"bar docs\") 148 | (baz [this a] [this a b] [this a b c] \"baz docs\")) 149 | 150 | No implementations are provided. Docs can be specified for the 151 | protocol overall and for each method. The above yields a set of 152 | polymorphic functions and a protocol object. All are 153 | namespace-qualified by the ns enclosing the definition The resulting 154 | functions dispatch on the type of their first argument, which is 155 | required and corresponds to the implicit target object ('this' in 156 | Java parlance). defprotocol is dynamic, has no special compile-time 157 | effect, and defines no new types or classes. Implementations of 158 | the protocol methods can be provided using extend. 159 | 160 | defprotocol will automatically generate a corresponding interface, 161 | with the same name as the protocol, i.e. given a protocol: 162 | my.ns/Protocol, an interface: my.ns.Protocol. The interface will 163 | have methods corresponding to the protocol functions, and the 164 | protocol will automatically work with instances of the interface. 165 | 166 | Note that you should not use this interface with deftype or 167 | reify, as they support the protocol directly: 168 | 169 | (defprotocol P 170 | (foo [this]) 171 | (bar-me [this] [this y])) 172 | 173 | (deftype Foo [a b c] 174 | P 175 | (foo [this] a) 176 | (bar-me [this] b) 177 | (bar-me [this y] (+ c y))) 178 | 179 | (bar-me (Foo. 1 2 3) 42) 180 | => 45 181 | 182 | (foo 183 | (let [x 42] 184 | (reify P 185 | (foo [this] 17) 186 | (bar-me [this] x) 187 | (bar-me [this y] x)))) 188 | => 17" 189 | [name & opts+sigs] 190 | (emit-protocol name opts+sigs)) 191 | 192 | (defn extend 193 | "Implementations of protocol methods can be provided using the extend construct: 194 | 195 | (extend AType 196 | AProtocol 197 | {:foo an-existing-fn 198 | :bar (fn [a b] ...) 199 | :baz (fn ([a]...) ([a b] ...)...)} 200 | BProtocol 201 | {...} 202 | ...) 203 | 204 | extend takes a type/class (or interface, see below), and one or more 205 | protocol + method map pairs. It will extend the polymorphism of the 206 | protocol's methods to call the supplied methods when an AType is 207 | provided as the first argument. 208 | 209 | Method maps are maps of the keyword-ized method names to ordinary 210 | fns. This facilitates easy reuse of existing fns and fn maps, for 211 | code reuse/mixins without derivation or composition. You can extend 212 | an interface to a protocol. This is primarily to facilitate interop 213 | with the host (e.g. Java) but opens the door to incidental multiple 214 | inheritance of implementation since a class can inherit from more 215 | than one interface, both of which extend the protocol. It is TBD how 216 | to specify which impl to use. You can extend a protocol on nil. 217 | 218 | If you are supplying the definitions explicitly (i.e. not reusing 219 | exsting functions or mixin maps), you may find it more convenient to 220 | use the extend-type or extend-protocol macros. 221 | 222 | Note that multiple independent extend clauses can exist for the same 223 | type, not all protocols need be defined in a single extend call. 224 | 225 | See also: 226 | extends?, satisfies?, extenders" 227 | [atype & proto+mmaps] 228 | (doseq [[proto mmap] (partition 2 proto+mmaps)] 229 | (when-not (protocol? proto) 230 | (throw (IllegalArgumentException. 231 | (str proto " is not a protocol")))) 232 | (when (implements? proto atype) 233 | (throw (IllegalArgumentException. 234 | (str atype " already directly implements " (:on-interface proto) " for protocol:" 235 | (:var proto))))) 236 | (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap)))) 237 | 238 | (defn- emit-impl [[p fs]] 239 | [p (zipmap (map #(-> % first keyword) fs) 240 | (map #(cons 'fn (drop 1 %)) fs))]) 241 | 242 | (defn- emit-hinted-impl [c [p fs]] 243 | (let [hint (fn [specs] 244 | (let [specs (if (vector? (first specs)) 245 | (list specs) 246 | specs)] 247 | (map (fn [[[target & args] & body]] 248 | (cons (apply vector (vary-meta target assoc :tag c) args) 249 | body)) 250 | specs)))] 251 | [p (zipmap (map #(-> % first name keyword) fs) 252 | (map #(cons 'fn (hint (drop 1 %))) fs))])) 253 | 254 | (defn- emit-extend-type [c specs] 255 | (let [impls (parse-impls specs)] 256 | `(extend ~c 257 | ~@(mapcat (partial emit-hinted-impl c) impls)))) 258 | 259 | (defmacro extend-type 260 | "A macro that expands into an extend call. Useful when you are 261 | supplying the definitions explicitly inline, extend-type 262 | automatically creates the maps required by extend. Propagates the 263 | class as a type hint on the first argument of all fns. 264 | 265 | (extend-type MyType 266 | Countable 267 | (cnt [c] ...) 268 | Foo 269 | (bar [x y] ...) 270 | (baz ([x] ...) ([x y & zs] ...))) 271 | 272 | expands into: 273 | 274 | (extend MyType 275 | Countable 276 | {:cnt (fn [c] ...)} 277 | Foo 278 | {:baz (fn ([x] ...) ([x y & zs] ...)) 279 | :bar (fn [x y] ...)})" 280 | [t & specs] 281 | (emit-extend-type t specs)) 282 | 283 | (defn- emit-extend-protocol [p specs] 284 | (let [impls (parse-impls specs)] 285 | `(do 286 | ~@(map (fn [[t fs]] 287 | `(extend-type ~t ~p ~@fs)) 288 | impls)))) 289 | 290 | (defmacro extend-protocol 291 | "Useful when you want to provide several implementations of the same 292 | protocol all at once. Takes a single protocol and the implementation 293 | of that protocol for one or more types. Expands into calls to 294 | extend-type: 295 | 296 | (extend-protocol Protocol 297 | AType 298 | (foo [x] ...) 299 | (bar [x y] ...) 300 | BType 301 | (foo [x] ...) 302 | (bar [x y] ...) 303 | AClass 304 | (foo [x] ...) 305 | (bar [x y] ...) 306 | nil 307 | (foo [x] ...) 308 | (bar [x y] ...)) 309 | 310 | expands into: 311 | 312 | (do 313 | (eclj.core/extend-type AType Protocol 314 | (foo [x] ...) 315 | (bar [x y] ...)) 316 | (eclj.core/extend-type BType Protocol 317 | (foo [x] ...) 318 | (bar [x y] ...)) 319 | (eclj.core/extend-type AClass Protocol 320 | (foo [x] ...) 321 | (bar [x y] ...)) 322 | (eclj.core/extend-type nil Protocol 323 | (foo [x] ...) 324 | (bar [x y] ...)))" 325 | [p & specs] 326 | (emit-extend-protocol p specs)) 327 | -------------------------------------------------------------------------------- /src/eclj/core/deftype.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn namespace-munge 4 | "Convert a Clojure namespace name to a legal Java package name." 5 | [ns] 6 | (.replace (str ns) \- \_)) 7 | 8 | (defn- parse-opts [s] 9 | (loop [opts {} [k v & rs :as s] s] 10 | (if (keyword? k) 11 | (recur (assoc opts k v) rs) 12 | [opts s]))) 13 | 14 | (defn- parse-impls [specs] 15 | (loop [ret {} s specs] 16 | (if (seq s) 17 | (recur (assoc ret (first s) (take-while seq? (next s))) 18 | (drop-while seq? (next s))) 19 | ret))) 20 | 21 | (defn- parse-opts+specs [opts+specs] 22 | (let [[opts specs] (parse-opts opts+specs) 23 | impls (parse-impls specs) 24 | resolve-proto #(if (var? (resolve %)) 25 | (deref (resolve %)) 26 | %) 27 | interfaces (-> (map #(:on (resolve-proto %) %) (keys impls)) 28 | set 29 | (disj 'Object 'java.lang.Object) 30 | vec) 31 | methods (for [[proto meths] impls 32 | :let [proto (resolve-proto proto) 33 | method-map (:method-map proto identity)] 34 | [meth params & body] meths 35 | :let [meth (symbol (name (method-map (keyword meth))))]] 36 | (cons meth (maybe-destructured params body)))] 37 | (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))] 38 | (throw (IllegalArgumentException. 39 | (apply print-str "Unsupported option(s) -" bad-opts)))) 40 | [interfaces methods opts])) 41 | 42 | (defmacro reify 43 | "reify is a macro with the following structure: 44 | 45 | (reify options* specs*) 46 | 47 | Currently there are no options. 48 | 49 | Each spec consists of the protocol or interface name followed by zero 50 | or more method bodies: 51 | 52 | protocol-or-interface-or-Object 53 | (methodName [args+] body)* 54 | 55 | Methods should be supplied for all methods of the desired 56 | protocol(s) and interface(s). You can also define overrides for 57 | methods of Object. Note that the first parameter must be supplied to 58 | correspond to the target object ('this' in Java parlance). Thus 59 | methods for interfaces will take one more argument than do the 60 | interface declarations. Note also that recur calls to the method 61 | head should *not* pass the target object, it will be supplied 62 | automatically and can not be substituted. 63 | 64 | The return type can be indicated by a type hint on the method name, 65 | and arg types can be indicated by a type hint on arg names. If you 66 | leave out all hints, reify will try to match on same name/arity 67 | method in the protocol(s)/interface(s) - this is preferred. If you 68 | supply any hints at all, no inference is done, so all hints (or 69 | default of Object) must be correct, for both arguments and return 70 | type. If a method is overloaded in a protocol/interface, multiple 71 | independent method definitions must be supplied. If overloaded with 72 | same arity in an interface you must specify complete hints to 73 | disambiguate - a missing hint implies Object. 74 | 75 | recur works to method heads The method bodies of reify are lexical 76 | closures, and can refer to the surrounding local scope: 77 | 78 | (str (let [f \"foo\"] 79 | (reify Object 80 | (toString [this] f)))) 81 | == \"foo\" 82 | 83 | (seq (let [f \"foo\"] 84 | (reify clojure.lang.Seqable 85 | (seq [this] (seq f))))) 86 | == (\\f \\o \\o)) 87 | 88 | reify always implements clojure.lang.IObj and transfers meta 89 | data of the form to the created object. 90 | 91 | (meta ^{:k :v} (reify Object (toString [this] \"foo\"))) 92 | == {:k :v}" 93 | [& opts+specs] 94 | (let [[interfaces methods] (parse-opts+specs opts+specs)] 95 | (with-meta `(reify* ~interfaces ~@methods) (meta &form)))) 96 | 97 | (defn hash-combine [x y] 98 | (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y))) 99 | 100 | (defn munge [s] 101 | ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s)))) 102 | 103 | (defn- imap-cons 104 | [^IPersistentMap this o] 105 | (cond 106 | (instance? java.util.Map$Entry o) 107 | (let [^java.util.Map$Entry pair o] 108 | (.assoc this (.getKey pair) (.getValue pair))) 109 | (instance? clojure.lang.IPersistentVector o) 110 | (let [^clojure.lang.IPersistentVector vec o] 111 | (.assoc this (.nth vec 0) (.nth vec 1))) 112 | :else (loop [this this 113 | o o] 114 | (if (seq o) 115 | (let [^java.util.Map$Entry pair (first o)] 116 | (recur (.assoc this (.getKey pair) (.getValue pair)) (rest o))) 117 | this)))) 118 | 119 | (defn- emit-defrecord 120 | "Do not use this directly - use defrecord" 121 | [tagname name fields interfaces methods] 122 | (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) 123 | interfaces (vec interfaces) 124 | interface-set (set (map resolve interfaces)) 125 | methodname-set (set (map first methods)) 126 | hinted-fields fields 127 | fields (vec (map #(with-meta % nil) fields)) 128 | base-fields fields 129 | fields (conj fields '__meta '__extmap) 130 | type-hash (hash classname)] 131 | (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields)) 132 | (throw (IllegalArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields"))) 133 | (let [gs (gensym)] 134 | (letfn 135 | [(irecord [[i m]] 136 | [(conj i 'clojure.lang.IRecord) 137 | m]) 138 | (eqhash [[i m]] 139 | [(conj i 'clojure.lang.IHashEq) 140 | (conj m 141 | `(hasheq [this#] (bit-xor ~type-hash (clojure.lang.APersistentMap/mapHasheq this#))) 142 | `(hashCode [this#] (clojure.lang.APersistentMap/mapHash this#)) 143 | `(equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))]) 144 | (iobj [[i m]] 145 | [(conj i 'clojure.lang.IObj) 146 | (conj m `(meta [this#] ~'__meta) 147 | `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))))]) 148 | (ilookup [[i m]] 149 | [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup) 150 | (conj m `(valAt [this# k#] (.valAt this# k# nil)) 151 | `(valAt [this# k# else#] 152 | (case k# ~@(mapcat (fn [fld] [(keyword fld) fld]) 153 | base-fields) 154 | (get ~'__extmap k# else#))) 155 | `(getLookupThunk [this# k#] 156 | (let [~'gclass (class this#)] 157 | (case k# 158 | ~@(let [hinted-target (with-meta 'gtarget {:tag tagname})] 159 | (mapcat 160 | (fn [fld] 161 | [(keyword fld) 162 | `(reify clojure.lang.ILookupThunk 163 | (get [~'thunk ~'gtarget] 164 | (if (identical? (class ~'gtarget) ~'gclass) 165 | (. ~hinted-target ~(symbol (str "-" fld))) 166 | ~'thunk)))]) 167 | base-fields)) 168 | nil))))]) 169 | (imap [[i m]] 170 | [(conj i 'clojure.lang.IPersistentMap) 171 | (conj m 172 | `(count [this#] (+ ~(count base-fields) (count ~'__extmap))) 173 | `(empty [this#] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname))))) 174 | `(cons [this# e#] ((var imap-cons) this# e#)) 175 | `(equiv [this# ~gs] 176 | (boolean 177 | (or (identical? this# ~gs) 178 | (when (identical? (class this#) (class ~gs)) 179 | (let [~gs ~(with-meta gs {:tag tagname})] 180 | (and ~@(map (fn [fld] `(= ~fld (. ~gs ~(symbol (str "-" fld))))) base-fields) 181 | (= ~'__extmap (. ~gs ~'__extmap)))))))) 182 | `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#)))) 183 | `(entryAt [this# k#] (let [v# (.valAt this# k# this#)] 184 | (when-not (identical? this# v#) 185 | (clojure.lang.MapEntry. k# v#)))) 186 | `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)] 187 | ~'__extmap))) 188 | `(iterator [this#] (clojure.lang.SeqIterator. (.seq this#))) 189 | `(assoc [this# k# ~gs] 190 | (condp identical? k# 191 | ~@(mapcat (fn [fld] 192 | [(keyword fld) (list* `new tagname (replace {fld gs} fields))]) 193 | base-fields) 194 | (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs)))) 195 | `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#) 196 | (dissoc (with-meta (into {} this#) ~'__meta) k#) 197 | (new ~tagname ~@(remove #{'__extmap} fields) 198 | (not-empty (dissoc ~'__extmap k#))))))]) 199 | (ijavamap [[i m]] 200 | [(conj i 'java.util.Map 'java.io.Serializable) 201 | (conj m 202 | `(size [this#] (.count this#)) 203 | `(isEmpty [this#] (= 0 (.count this#))) 204 | `(containsValue [this# v#] (boolean (some #{v#} (vals this#)))) 205 | `(get [this# k#] (.valAt this# k#)) 206 | `(put [this# k# v#] (throw (UnsupportedOperationException.))) 207 | `(remove [this# k#] (throw (UnsupportedOperationException.))) 208 | `(putAll [this# m#] (throw (UnsupportedOperationException.))) 209 | `(clear [this#] (throw (UnsupportedOperationException.))) 210 | `(keySet [this#] (set (keys this#))) 211 | `(values [this#] (vals this#)) 212 | `(entrySet [this#] (set this#)))]) 213 | ] 214 | (let [[i m] (-> [interfaces methods] irecord eqhash iobj ilookup imap ijavamap)] 215 | `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap) 216 | :implements ~(vec i) 217 | ~@m)))))) 218 | 219 | (defn- build-positional-factory 220 | "Used to build a positional factory for a given type/record. Because of the 221 | limitation of 20 arguments to Clojure functions, this factory needs to be 222 | constructed to deal with more arguments. It does this by building a straight 223 | forward type/record ctor call in the <=20 case, and a call to the same 224 | ctor pulling the extra args out of the & overage parameter. Finally, the 225 | arity is constrained to the number of expected fields and an ArityException 226 | will be thrown at runtime if the actual arg count does not match." 227 | [nom classname fields] 228 | (let [fn-name (symbol (str '-> nom)) 229 | [field-args over] (split-at 20 fields) 230 | field-count (count fields) 231 | arg-count (count field-args) 232 | over-count (count over) 233 | docstring (str "Positional factory function for class " classname ".")] 234 | `(defn ~fn-name 235 | ~docstring 236 | [~@field-args ~@(if (seq over) '[& overage] [])] 237 | ~(if (seq over) 238 | `(if (= (count ~'overage) ~over-count) 239 | (new ~classname 240 | ~@field-args 241 | ~@(for [i (range 0 (count over))] 242 | (list `nth 'overage i))) 243 | (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name)))) 244 | `(new ~classname ~@field-args))))) 245 | 246 | (defn- validate-fields 247 | "" 248 | [fields] 249 | (when-not (vector? fields) 250 | (throw (AssertionError. "No fields vector given."))) 251 | (let [specials #{'__meta '__extmap}] 252 | (when (some specials fields) 253 | (throw (AssertionError. (str "The names in " specials " cannot be used as field names for types or records.")))))) 254 | 255 | (defmacro defrecord 256 | "(defrecord name [fields*] options* specs*) 257 | 258 | Currently there are no options. 259 | 260 | Each spec consists of a protocol or interface name followed by zero 261 | or more method bodies: 262 | 263 | protocol-or-interface-or-Object 264 | (methodName [args*] body)* 265 | 266 | Dynamically generates compiled bytecode for class with the given 267 | name, in a package with the same name as the current namespace, the 268 | given fields, and, optionally, methods for protocols and/or 269 | interfaces. 270 | 271 | The class will have the (immutable) fields named by 272 | fields, which can have type hints. Protocols/interfaces and methods 273 | are optional. The only methods that can be supplied are those 274 | declared in the protocols/interfaces. Note that method bodies are 275 | not closures, the local environment includes only the named fields, 276 | and those fields can be accessed directly. 277 | 278 | Method definitions take the form: 279 | 280 | (methodname [args*] body) 281 | 282 | The argument and return types can be hinted on the arg and 283 | methodname symbols. If not supplied, they will be inferred, so type 284 | hints should be reserved for disambiguation. 285 | 286 | Methods should be supplied for all methods of the desired 287 | protocol(s) and interface(s). You can also define overrides for 288 | methods of Object. Note that a parameter must be supplied to 289 | correspond to the target object ('this' in Java parlance). Thus 290 | methods for interfaces will take one more argument than do the 291 | interface declarations. Note also that recur calls to the method 292 | head should *not* pass the target object, it will be supplied 293 | automatically and can not be substituted. 294 | 295 | In the method bodies, the (unqualified) name can be used to name the 296 | class (for calls to new, instance? etc). 297 | 298 | The class will have implementations of several (clojure.lang) 299 | interfaces generated automatically: IObj (metadata support) and 300 | IPersistentMap, and all of their superinterfaces. 301 | 302 | In addition, defrecord will define type-and-value-based =, 303 | and will defined Java .hashCode and .equals consistent with the 304 | contract for java.util.Map. 305 | 306 | When AOT compiling, generates compiled bytecode for a class with the 307 | given name (a symbol), prepends the current ns as the package, and 308 | writes the .class file to the *compile-path* directory. 309 | 310 | Two constructors will be defined, one taking the designated fields 311 | followed by a metadata map (nil for none) and an extension field 312 | map (nil for none), and one taking only the fields (using nil for 313 | meta and extension fields). Note that the field names __meta 314 | and __extmap are currently reserved and should not be used when 315 | defining your own records. 316 | 317 | Given (defrecord TypeName ...), two factory functions will be 318 | defined: ->TypeName, taking positional parameters for the fields, 319 | and map->TypeName, taking a map of keywords to field values." 320 | [name fields & opts+specs] 321 | (validate-fields fields) 322 | (let [gname name 323 | [interfaces methods opts] (parse-opts+specs opts+specs) 324 | ns-part (namespace-munge *ns*) 325 | classname (symbol (str ns-part "." gname)) 326 | hinted-fields fields 327 | fields (vec (map #(with-meta % nil) fields))] 328 | `(let [] 329 | (declare ~(symbol (str '-> gname))) 330 | (declare ~(symbol (str 'map-> gname))) 331 | ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods) 332 | (import ~classname) 333 | ~(build-positional-factory gname classname fields) 334 | (defn ~(symbol (str 'map-> gname)) 335 | ~(str "Factory function for class " classname ", taking a map of keywords to field values.") 336 | ([m#] (~(symbol (str classname "/create")) m#))) 337 | ~classname))) 338 | 339 | (defn record? 340 | "Returns true if x is a record" 341 | [x] 342 | (instance? clojure.lang.IRecord x)) 343 | 344 | (defn- emit-deftype* 345 | "Do not use this directly - use deftype" 346 | [tagname name fields interfaces methods] 347 | (let [classname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name)) 348 | interfaces (conj interfaces 'clojure.lang.IType)] 349 | `(deftype* ~tagname ~classname ~fields 350 | :implements ~interfaces 351 | ~@methods))) 352 | 353 | (defmacro deftype 354 | "(deftype name [fields*] options* specs*) 355 | 356 | Currently there are no options. 357 | 358 | Each spec consists of a protocol or interface name followed by zero 359 | or more method bodies: 360 | 361 | protocol-or-interface-or-Object 362 | (methodName [args*] body)* 363 | 364 | Dynamically generates compiled bytecode for class with the given 365 | name, in a package with the same name as the current namespace, the 366 | given fields, and, optionally, methods for protocols and/or 367 | interfaces. 368 | 369 | The class will have the (by default, immutable) fields named by 370 | fields, which can have type hints. Protocols/interfaces and methods 371 | are optional. The only methods that can be supplied are those 372 | declared in the protocols/interfaces. Note that method bodies are 373 | not closures, the local environment includes only the named fields, 374 | and those fields can be accessed directy. Fields can be qualified 375 | with the metadata :volatile-mutable true or :unsynchronized-mutable 376 | true, at which point (set! afield aval) will be supported in method 377 | bodies. Note well that mutable fields are extremely difficult to use 378 | correctly, and are present only to facilitate the building of higher 379 | level constructs, such as Clojure's reference types, in Clojure 380 | itself. They are for experts only - if the semantics and 381 | implications of :volatile-mutable or :unsynchronized-mutable are not 382 | immediately apparent to you, you should not be using them. 383 | 384 | Method definitions take the form: 385 | 386 | (methodname [args*] body) 387 | 388 | The argument and return types can be hinted on the arg and 389 | methodname symbols. If not supplied, they will be inferred, so type 390 | hints should be reserved for disambiguation. 391 | 392 | Methods should be supplied for all methods of the desired 393 | protocol(s) and interface(s). You can also define overrides for 394 | methods of Object. Note that a parameter must be supplied to 395 | correspond to the target object ('this' in Java parlance). Thus 396 | methods for interfaces will take one more argument than do the 397 | interface declarations. Note also that recur calls to the method 398 | head should *not* pass the target object, it will be supplied 399 | automatically and can not be substituted. 400 | 401 | In the method bodies, the (unqualified) name can be used to name the 402 | class (for calls to new, instance? etc). 403 | 404 | When AOT compiling, generates compiled bytecode for a class with the 405 | given name (a symbol), prepends the current ns as the package, and 406 | writes the .class file to the *compile-path* directory. 407 | 408 | One constructor will be defined, taking the designated fields. Note 409 | that the field names __meta and __extmap are currently reserved and 410 | should not be used when defining your own types. 411 | 412 | Given (deftype TypeName ...), a factory function called ->TypeName 413 | will be defined, taking positional parameters for the fields" 414 | [name fields & opts+specs] 415 | (validate-fields fields) 416 | (let [gname name 417 | [interfaces methods opts] (parse-opts+specs opts+specs) 418 | ns-part (namespace-munge *ns*) 419 | classname (symbol (str ns-part "." gname)) 420 | hinted-fields fields 421 | fields (vec (map #(with-meta % nil) fields)) 422 | [field-args over] (split-at 20 fields)] 423 | `(let [] 424 | ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods) 425 | (import ~classname) 426 | ~(build-positional-factory gname classname fields) 427 | ~classname))) 428 | -------------------------------------------------------------------------------- /src/eclj/core/delays.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (deftype Delay [lock state] 4 | 5 | IDelay 6 | 7 | IDeref 8 | (-deref [_] 9 | (locking lock 10 | (let [[done? f-or-v] @state] 11 | (if done? 12 | f-or-v 13 | (let [v (f-or-v)] 14 | (reset! state [true v]) 15 | v))))) 16 | 17 | IPending 18 | (-realized? [_] 19 | (first @state)) 20 | 21 | ) 22 | 23 | (defmacro delay [& body] 24 | "Takes a body of expressions and yields a Delay object that will invoke the 25 | body only the first time it is forced (with force or deref/@), and will 26 | cache the result and return it on all subsequent force calls." 27 | `(Delay. (reentrant-lock) (atom [false (fn [] ~@body)]))) 28 | 29 | (defn delay? 30 | "returns true if x is a Delay created with delay" 31 | [x] 32 | (satisfies? IDelay x)) 33 | 34 | (defn force 35 | "If x is a Delay, returns the (possibly cached) value of its expression, 36 | else returns x" 37 | [x] 38 | (if (delay? x) 39 | (deref x) 40 | x)) 41 | 42 | (defn ^boolean realized? 43 | "Returns true if a value has been produced for a promise, delay, future or 44 | lazy sequence." 45 | [d] 46 | (-realized? d)) 47 | -------------------------------------------------------------------------------- /src/eclj/core/equiv.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn identical? 4 | "Tests if 2 arguments are the same object" 5 | [x y] 6 | (clojure.lang.Util/identical x y)) 7 | 8 | (defn = 9 | "Equality. Returns true if x equals y, false if not. Same as Java 10 | x.equals(y) except it also works for nil, and compares numbers and 11 | collections in a type-independent manner. Clojure's immutable data 12 | structures define equals() (and thus =) as a value, not an identity, 13 | comparison." 14 | [x & xs] 15 | (if (seq xs) 16 | (and (-equiv x (first xs)) 17 | (apply = x (next xs))) 18 | true)) 19 | 20 | (defn not= 21 | "Same as (not (= obj1 obj2))" 22 | [x & xs] 23 | (not (apply = x xs))) 24 | 25 | (defn- equiv-sequential 26 | "Assumes x is sequential. Returns true if x equals y, otherwise 27 | returns false." 28 | [x y] 29 | (boolean 30 | (when (sequential? y) 31 | (loop [xs (seq x) ys (seq y)] 32 | (cond 33 | (nil? xs) (nil? ys) 34 | (nil? ys) false 35 | (= (first xs) (first ys)) (recur (next xs) (next ys)) 36 | :else false))))) 37 | -------------------------------------------------------------------------------- /src/eclj/core/ext.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn ^:eclj ns-env [] 4 | (eclj.env/ns-env)) 5 | 6 | ;;XXX quasi-primitive 7 | (defmacro ^:eclj raise [effect] 8 | `(eclj.core/raise ~effect)) 9 | 10 | (defn ^:eclj handle-with* [handler thunk] 11 | (let [eff (eclj.core/eval-effect (list thunk) (assoc (ns-env) :kernel nil))] 12 | (raise (or (handler eff) eff)))) 13 | 14 | (defmacro ^:eclj handle-with [handler & body] 15 | `(handle-with* ~handler (fn [] ~@body))) 16 | 17 | (defn ^:eclj continue [k x] 18 | (raise (trampoline k x))) 19 | 20 | (defmacro symbol-macrolet [bindings & body] 21 | (let [symbols (take-nth 2 bindings) 22 | expansions (map eclj.common/->Expansion (take-nth 2 (next bindings)))] 23 | `(let [~@(interleave symbols expansions)] 24 | ~@body))) 25 | -------------------------------------------------------------------------------- /src/eclj/core/flow.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | ;;; Macros for flow of control and data. 4 | 5 | (defmacro when 6 | "Evaluates test. If logical true, evaluates body in an implicit do." 7 | [test & body] 8 | `(if ~test (do ~@body))) 9 | 10 | (defmacro when-not 11 | "Evaluates test. If logical false, evaluates body in an implicit do." 12 | [test & body] 13 | `(if ~test nil (do ~@body))) 14 | 15 | (defmacro cond 16 | "Takes a set of test/expr pairs. It evaluates each test one at a 17 | time. If a test returns logical true, cond evaluates and returns 18 | the value of the corresponding expr and doesn't evaluate any of the 19 | other tests or exprs. (cond) returns nil." 20 | [& clauses] 21 | (when clauses 22 | `(if ~(first clauses) 23 | ~(if (next clauses) 24 | (second clauses) 25 | (throw (IllegalArgumentException. 26 | "cond requires an even number of forms"))) 27 | (cond ~@(nnext clauses))))) 28 | 29 | (defmacro if-not 30 | "Evaluates test. If logical false, evaluates and returns then expr, 31 | otherwise else expr, if supplied, else nil." 32 | ([test then] 33 | `(if-not ~test ~then nil)) 34 | ([test then else] 35 | `(if (not ~test) ~then ~else))) 36 | 37 | (defmacro and 38 | "Evaluates exprs one at a time, from left to right. If a form 39 | returns logical false (nil or false), and returns that value and 40 | doesn't evaluate any of the other expressions, otherwise it returns 41 | the value of the last expr. (and) returns true." 42 | ([] true) 43 | ([x] x) 44 | ([x & next] 45 | `(let [and# ~x] 46 | (if and# (and ~@next) and#)))) 47 | 48 | (defmacro or 49 | "Evaluates exprs one at a time, from left to right. If a form 50 | returns a logical true value, or returns that value and doesn't 51 | evaluate any of the other expressions, otherwise it returns the 52 | value of the last expression. (or) returns nil." 53 | ([] nil) 54 | ([x] x) 55 | ([x & next] 56 | `(let [or# ~x] 57 | (if or# or# (or ~@next))))) 58 | 59 | (defmacro .. 60 | "form => fieldName-symbol or (instanceMethodName-symbol args*) 61 | 62 | Expands into a member access (.) of the first member on the first 63 | argument, followed by the next member on the result, etc. For 64 | instance: 65 | 66 | (.. System (getProperties) (get \"os.name\")) 67 | 68 | expands to: 69 | 70 | (. (. System (getProperties)) (get \"os.name\")) 71 | 72 | but is easier to write, read, and understand." 73 | ([x form] `(. ~x ~form)) 74 | ([x form & more] `(.. (. ~x ~form) ~@more))) 75 | 76 | (defmacro -> 77 | "Threads the expr through the forms. Inserts x as the 78 | second item in the first form, making a list of it if it is not a 79 | list already. If there are more forms, inserts the first form as the 80 | second item in second form, etc." 81 | [x & forms] 82 | (loop [x x, forms forms] 83 | (if forms 84 | (let [form (first forms) 85 | threaded (if (seq? form) 86 | (with-meta `(~(first form) ~x ~@(next form)) 87 | (meta form)) 88 | (list form x))] 89 | (recur threaded (next forms))) 90 | x))) 91 | 92 | (defmacro ->> 93 | "Threads the expr through the forms. Inserts x as the 94 | last item in the first form, making a list of it if it is not a 95 | list already. If there are more forms, inserts the first form as the 96 | last item in second form, etc." 97 | [x & forms] 98 | (loop [x x, forms forms] 99 | (if forms 100 | (let [form (first forms) 101 | threaded (if (seq? form) 102 | (with-meta `(~(first form) ~@(next form) ~x) 103 | (meta form)) 104 | (list form x))] 105 | (recur threaded (next forms))) 106 | x))) 107 | 108 | (defmacro if-let 109 | "bindings => binding-form test 110 | 111 | If test is true, evaluates then with binding-form bound to the value of 112 | test, if not, yields else" 113 | ([bindings then] 114 | `(if-let ~bindings ~then nil)) 115 | ([bindings then else & oldform] 116 | (assert-args 117 | (vector? bindings) "a vector for its binding" 118 | (nil? oldform) "1 or 2 forms after binding vector" 119 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 120 | (let [form (bindings 0) tst (bindings 1)] 121 | `(let [temp# ~tst] 122 | (if temp# 123 | (let [~form temp#] 124 | ~then) 125 | ~else))))) 126 | 127 | (defmacro when-let 128 | "bindings => binding-form test 129 | 130 | When test is true, evaluates body with binding-form bound 131 | to the value of test" 132 | [bindings & body] 133 | (assert-args 134 | (vector? bindings) "a vector for its binding" 135 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 136 | (let [form (bindings 0) tst (bindings 1)] 137 | `(let [temp# ~tst] 138 | (when temp# 139 | (let [~form temp#] 140 | ~@body))))) 141 | 142 | (defmacro if-some 143 | "bindings => binding-form test 144 | 145 | If test is not nil, evaluates then with binding-form bound to the 146 | value of test, if not, yields else" 147 | ([bindings then] 148 | `(if-some ~bindings ~then nil)) 149 | ([bindings then else & oldform] 150 | (assert-args 151 | (vector? bindings) "a vector for its binding" 152 | (nil? oldform) "1 or 2 forms after binding vector" 153 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 154 | (let [form (bindings 0) tst (bindings 1)] 155 | `(let [temp# ~tst] 156 | (if (nil? temp#) 157 | ~else 158 | (let [~form temp#] 159 | ~then)))))) 160 | 161 | (defmacro when-some 162 | "bindings => binding-form test 163 | 164 | When test is not nil, evaluates body with binding-form bound to the 165 | value of test" 166 | [bindings & body] 167 | (assert-args 168 | (vector? bindings) "a vector for its binding" 169 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 170 | (let [form (bindings 0) tst (bindings 1)] 171 | `(let [temp# ~tst] 172 | (if (nil? temp#) 173 | nil 174 | (let [~form temp#] 175 | ~@body))))) 176 | 177 | ;TODO doseq ? Put this with for comprehensions? 178 | 179 | (defmacro dotimes 180 | "bindings => name n 181 | 182 | Repeatedly executes body (presumably for side-effects) with name 183 | bound to integers from 0 through n-1." 184 | [bindings & body] 185 | (assert-args 186 | (vector? bindings) "a vector for its binding" 187 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 188 | (let [i (first bindings) 189 | n (second bindings)] 190 | `(let [n# (long ~n)] 191 | (loop [~i 0] 192 | (when (< ~i n#) 193 | ~@body 194 | (recur (unchecked-inc ~i))))))) 195 | 196 | (defmacro doto 197 | "Evaluates x then calls all of the methods and functions with the 198 | value of x supplied at the front of the given arguments. The forms 199 | are evaluated in order. Returns x. 200 | 201 | (doto (new java.util.HashMap) (.put \"a\" 1) (.put \"b\" 2))" 202 | [x & forms] 203 | (let [gx (gensym)] 204 | `(let [~gx ~x] 205 | ~@(map (fn [f] 206 | (if (seq? f) 207 | `(~(first f) ~gx ~@(next f)) 208 | `(~f ~gx))) 209 | forms) 210 | ~gx))) 211 | 212 | (defmacro when-first 213 | "bindings => x xs 214 | 215 | Roughly the same as (when (seq xs) (let [x (first xs)] body)) but xs is 216 | evaluated only once" 217 | [bindings & body] 218 | (assert-args 219 | (vector? bindings) "a vector for its binding" 220 | (= 2 (count bindings)) "exactly 2 forms in binding vector") 221 | (let [[x xs] bindings] 222 | `(when-let [xs# (seq ~xs)] 223 | (let [~x (first xs#)] 224 | ~@body)))) 225 | 226 | (defmacro while 227 | "Repeatedly executes body while test expression is true. Presumes 228 | some side-effect will cause test to become false/nil. Returns nil" 229 | [test & body] 230 | `(loop [] 231 | (when ~test 232 | ~@body 233 | (recur)))) 234 | 235 | (defmacro condp 236 | "Takes a binary predicate, an expression, and a set of clauses. 237 | Each clause can take the form of either: 238 | 239 | test-expr result-expr 240 | 241 | test-expr :>> result-fn 242 | 243 | Note :>> is an ordinary keyword. 244 | 245 | For each clause, (pred test-expr expr) is evaluated. If it returns 246 | logical true, the clause is a match. If a binary clause matches, the 247 | result-expr is returned, if a ternary clause matches, its result-fn, 248 | which must be a unary function, is called with the result of the 249 | predicate as its argument, the result of that call being the return 250 | value of condp. A single default expression can follow the clauses, 251 | and its value will be returned if no clause matches. If no default 252 | expression is provided and no clause matches, an 253 | IllegalArgumentException is thrown." 254 | [pred expr & clauses] 255 | (let [gpred (gensym "pred__") 256 | gexpr (gensym "expr__") 257 | emit (fn emit [pred expr args] 258 | (let [[[a b c :as clause] more] 259 | (split-at (if (= :>> (second args)) 3 2) args) 260 | n (count clause)] 261 | (cond 262 | (= 0 n) `(throw (IllegalArgumentException. 263 | (str "No matching clause: " ~expr))) 264 | (= 1 n) a 265 | (= 2 n) `(if (~pred ~a ~expr) 266 | ~b 267 | ~(emit pred expr more)) 268 | :else `(if-let [p# (~pred ~a ~expr)] 269 | (~c p#) 270 | ~(emit pred expr more))))) 271 | gres (gensym "res__")] 272 | `(let [~gpred ~pred 273 | ~gexpr ~expr] 274 | ~(emit gpred gexpr clauses)))) 275 | 276 | (defmacro cond-> 277 | "Takes an expression and a set of test/form pairs. Threads expr (via ->) 278 | through each form for which the corresponding test 279 | expression is true. Note that, unlike cond branching, cond-> threading does 280 | not short circuit after the first true test expression." 281 | [expr & clauses] 282 | (assert (even? (count clauses))) 283 | (let [g (gensym) 284 | pstep (fn [[test step]] `(if ~test (-> ~g ~step) ~g))] 285 | `(let [~g ~expr 286 | ~@(interleave (repeat g) (map pstep (partition 2 clauses)))] 287 | ~g))) 288 | 289 | (defmacro cond->> 290 | "Takes an expression and a set of test/form pairs. Threads expr (via ->>) 291 | through each form for which the corresponding test expression is true. Note 292 | that, unlike cond branching, cond->> threading does not short circuit after 293 | the first true test expression." 294 | [expr & clauses] 295 | (assert (even? (count clauses))) 296 | (let [g (gensym) 297 | pstep (fn [[test step]] `(if ~test (->> ~g ~step) ~g))] 298 | `(let [~g ~expr 299 | ~@(interleave (repeat g) (map pstep (partition 2 clauses)))] 300 | ~g))) 301 | 302 | (defmacro as-> 303 | "Binds name to expr, evaluates the first form in the lexical context 304 | of that binding, then binds name to that result, repeating for each 305 | successive form, returning the result of the last form." 306 | [expr name & forms] 307 | `(let [~name ~expr 308 | ~@(interleave (repeat name) forms)] 309 | ~name)) 310 | 311 | (defmacro some-> 312 | "When expr is not nil, threads it into the first form (via ->), 313 | and when that result is not nil, through the next etc" 314 | [expr & forms] 315 | (let [g (gensym) 316 | pstep (fn [step] `(if (nil? ~g) nil (-> ~g ~step)))] 317 | `(let [~g ~expr 318 | ~@(interleave (repeat g) (map pstep forms))] 319 | ~g))) 320 | 321 | (defmacro some->> 322 | "When expr is not nil, threads it into the first form (via ->>), 323 | and when that result is not nil, through the next etc" 324 | [expr & forms] 325 | (let [g (gensym) 326 | pstep (fn [step] `(if (nil? ~g) nil (->> ~g ~step)))] 327 | `(let [~g ~expr 328 | ~@(interleave (repeat g) (map pstep forms))] 329 | ~g))) 330 | -------------------------------------------------------------------------------- /src/eclj/core/fns.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn ifn? 4 | "Returns true if x satisfies IFn. Note that many data structures 5 | (e.g. sets and maps) satify IFn" 6 | [x] 7 | (satisfies? IFn x)) 8 | 9 | (defn fn? 10 | "Returns true if x is marked with IFn, i.e. is an object created via fn." 11 | [x] 12 | (satisfies? Fn x)) 13 | 14 | (defn identity 15 | "Returns its argument." 16 | [x] 17 | x) 18 | 19 | (defn constantly 20 | "Returns a function that takes any number of arguments and returns x." 21 | [x] 22 | (fn [& args] x)) 23 | 24 | (defn comp 25 | "Takes a set of functions and returns a fn that is the composition of those 26 | fns. The returned fn takes a variable number of args, applies the rightmost 27 | of fns to the args, the next fn (right-to-left) to the result, etc." 28 | ([] identity) 29 | ([& fs] 30 | (let [[f & fs] (reverse fs)] 31 | (fn [& args] 32 | (reduce (fn [x g] (g x)) 33 | (apply f args) 34 | fs))))) 35 | 36 | (defn juxt 37 | "Takes a set of functions and returns a fn that is the juxtaposition 38 | of those fns. The returned fn takes a variable number of args, and 39 | returns a vector containing the result of applying each fn to the 40 | args (left-to-right). 41 | ((juxt a b c) x) => [(a x) (b x) (c x)]" 42 | [& fns] 43 | (fn [& args] 44 | (mapv #(apply % args) fns))) 45 | 46 | (defn partial 47 | "Takes a function f and fewer than the normal arguments to f, and 48 | returns a fn that takes a variable number of additional args. When 49 | called, the returned function calls f with args + additional args." 50 | [f & args] 51 | (fn [& xs] 52 | (apply f (concat args xs)))) 53 | 54 | (defn complement 55 | "Takes a fn f and returns a fn that takes the same arguments as f, 56 | has the same effects, if any, and returns the opposite truth value." 57 | [f] 58 | (fn [& args] 59 | (not (apply f args)))) 60 | -------------------------------------------------------------------------------- /src/eclj/core/hash.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn hash 4 | "Returns the hash code of its argument. Note this is the hash code 5 | consistent with =, and thus is different than .hashCode for Integer, 6 | Short, Byte and Clojure collections." 7 | [x] 8 | (-hash x)) 9 | 10 | ;TODO port Murmur3 to eclj 11 | 12 | (defn mix-collection-hash 13 | "Mix final collection hash for ordered or unordered collections. 14 | hash-basis is the combined collection hash, count is the number 15 | of elements included in the basis. Note this is the hash code 16 | consistent with =, different from .hashCode. 17 | See http://clojure.org/data_structures#hash for full algorithms." 18 | ^long 19 | [^long hash-basis ^long count] 20 | (clojure.lang.Murmur3/mixCollHash hash-basis count)) 21 | 22 | (defn hash-ordered-coll 23 | "Returns the hash code, consistent with =, for an external ordered 24 | collection implementing Iterable. 25 | See http://clojure.org/data_structures#hash for full algorithms." 26 | ^long 27 | [coll] 28 | (clojure.lang.Murmur3/hashOrdered coll)) 29 | 30 | (defn hash-unordered-coll 31 | "Returns the hash code, consistent with =, for an external unordered 32 | collection implementing Iterable. For maps, the iterator should return map 33 | entries whose hash is computed as 34 | (hash-ordered-coll [k v]). 35 | See http://clojure.org/data_structures#hash for full algorithms." 36 | ^long 37 | [coll] 38 | (clojure.lang.Murmur3/hashUnordered coll)) 39 | -------------------------------------------------------------------------------- /src/eclj/core/jvm.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn instance? 4 | "Evaluates x and tests if it is an instance of the class c. Returns 5 | true or false" 6 | [^java.lang.Class c x] 7 | (.isInstance c x)) 8 | 9 | (defn class? 10 | "Returns true if x is an instance of Class" 11 | [x] 12 | (instance? java.lang.Class x)) 13 | 14 | (defn cast 15 | "Throws a ClassCastException if x is not a c, else returns x." 16 | [^java.lang.Class c x] 17 | (.cast c x)) 18 | 19 | (extend-type nil 20 | 21 | ISeqable 22 | (-seq [o] nil) 23 | 24 | ISeq 25 | (-first [o] nil) 26 | (-rest [o] ()) 27 | 28 | ISeqable 29 | (-seq [o] nil) 30 | 31 | INext 32 | (-next [o] nil) 33 | 34 | IAssociative 35 | (-entry-at [coll k] nil) 36 | (-contains-key? [coll k] false) 37 | (-assoc [coll k v] {k v}) 38 | 39 | IStack 40 | (-peek [coll] nil) 41 | (-pop [coll] nil) 42 | 43 | ICollection 44 | (-conj [coll x] (list x)) 45 | 46 | IEmptyableCollection 47 | (-empty [coll] nil) 48 | 49 | ILookup 50 | (-lookup 51 | ([o k] nil) 52 | ([o k not-found] not-found)) 53 | 54 | IMap 55 | (-dissoc [coll x] nil) 56 | 57 | ISet 58 | (-disjoin [coll x] nil) 59 | 60 | ) 61 | 62 | (extend-protocol ISeqable 63 | 64 | java.lang.Iterable 65 | (-seq [o] 66 | (clojure.lang.IteratorSeq/create (.iterator o))) 67 | 68 | java.lang.CharSequence 69 | (-seq [o] 70 | (clojure.lang.StringSeq/create o)) 71 | 72 | java.util.Map 73 | (-seq [o] 74 | (seq (.entrySet o))) 75 | 76 | ) 77 | 78 | (doseq [arr '["[Ljava.lang.Object;" "[I" "[F" "[D" "[J" "[B" "[C" "[S" "[Z"]] 79 | (extend (java.lang.Class/forName arr) 80 | 81 | ;; ArraySeq and its primitive specializations have private constructors. 82 | ISeqable 83 | {:-seq clojure.core/seq} 84 | 85 | ILookup 86 | {:-lookup (fn 87 | ([o k] (-lookup o k nil)) 88 | ([o k not-found] 89 | (if (and (number? k) (< -1 k (count o))) 90 | (nth o k) 91 | not-found)))} 92 | 93 | )) 94 | 95 | (extend-protocol ILookup 96 | 97 | java.util.Map 98 | (-lookup 99 | ([o k] nil) 100 | ([o k not-found] 101 | not-found)) 102 | 103 | java.lang.String 104 | (-lookup 105 | ([o k] (-lookup o k nil)) 106 | ([o k not-found] 107 | (if (and (number? k) (< -1 k (count o))) 108 | (nth o k) 109 | not-found))) 110 | 111 | clojure.lang.IPersistentSet 112 | (-lookup 113 | ([o k] (.get o k)) 114 | ([o k not-found] 115 | (if (contains? o k) 116 | (.get o k) 117 | not-found))) 118 | 119 | ) 120 | 121 | (extend-protocol IMapEntry 122 | 123 | clojure.lang.IPersistentVector 124 | (-key [coll] 125 | (nth coll 0)) 126 | (-val [coll] 127 | (nth coll 1)) 128 | 129 | ) 130 | 131 | (def lookup-sentinel (java.lang.Object.)) 132 | 133 | (extend-protocol INamed 134 | 135 | java.lang.String 136 | (-name [x] x) 137 | (-namespace [x] nil) 138 | 139 | ) 140 | 141 | (extend-protocol IDelay clojure.lang.Delay) 142 | 143 | (extend-type java.util.concurrent.Future 144 | 145 | IDeref 146 | (-deref [o] (.get o)) 147 | 148 | IDerefWithTimeout 149 | (-deref-with-timeout [o msec timeout-val] 150 | (try 151 | (.get o msec java.util.concurrent.TimeUnit/MILLISECONDS) 152 | (catch java.util.concurrent.TimeoutException e 153 | timeout-val))) 154 | 155 | ) 156 | 157 | (extend-protocol IEquiv 158 | 159 | java.lang.Object 160 | (-equiv [x y] 161 | (.equals x y)) 162 | 163 | java.lang.Number 164 | (-equiv [x y] 165 | (clojure.lang.Numbers/equal x y)) 166 | 167 | clojure.lang.IPersistentCollection 168 | (-equiv [coll o] 169 | (clojure.lang.Util/pcequiv coll o)) 170 | 171 | ) 172 | 173 | (extend-protocol IHash 174 | 175 | java.lang.Object 176 | (-hash [o] 177 | (.hashCode o)) 178 | 179 | java.lang.Number 180 | (-hash [o] 181 | (clojure.lang.Numbers/hasheq o)) 182 | 183 | java.lang.String 184 | (-hash [o] 185 | (clojure.lang.Murmur3/hashInt (.hashCode o))) 186 | 187 | ) 188 | -------------------------------------------------------------------------------- /src/eclj/core/locks.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defmacro locking [x & body] 4 | `(let [lockee# ~x] 5 | (-lock lockee#) 6 | (try 7 | ~@body 8 | (finally 9 | (-unlock lockee#))))) 10 | 11 | (defn- reentrant-lock [] 12 | (java.util.concurrent.locks.ReentrantLock.)) 13 | -------------------------------------------------------------------------------- /src/eclj/core/maps.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn map? 4 | "Return true if x is not nil and satisfies IMap" 5 | [x] 6 | (and (some? x) (satisfies? IMap x))) 7 | 8 | (defn hash-map 9 | "keyval => key val 10 | Returns a new hash map with supplied mappings. If any keys are 11 | equal, they are handled as if by repeated uses of assoc." 12 | [& keyvals] 13 | (clojure.lang.PersistentHashMap/create keyvals)) 14 | 15 | (defn sorted-map 16 | "keyval => key val 17 | Returns a new sorted map with supplied mappings. If any keys are 18 | equal, they are handled as if by repeated uses of assoc." 19 | [& keyvals] 20 | (clojure.lang.PersistentTreeMap/create keyvals)) 21 | 22 | (defn sorted-map-by 23 | "keyval => key val 24 | Returns a new sorted map with supplied mappings, using the supplied 25 | comparator. If any keys are equal, they are handled as if by 26 | repeated uses of assoc." 27 | [comparator & keyvals] 28 | (clojure.lang.PersistentTreeMap/create comparator keyvals)) 29 | 30 | (defn assoc 31 | "assoc[iate]. When applied to a map, returns a new map of the 32 | same (hashed/sorted) type, that contains the mapping of key(s) to 33 | val(s). When applied to a vector, returns a new vector that 34 | contains val at index. Note - index must be <= (count vector)." 35 | [map & kvs] 36 | (loop [ret map 37 | kvs kvs] 38 | (if kvs 39 | (if (next kvs) 40 | (recur (-assoc ret (first kvs) (second kvs)) (nnext kvs)) 41 | (throw (IllegalArgumentException. 42 | "assoc expects even number of arguments after map/vector, found odd number"))) 43 | ret))) 44 | 45 | (defn get 46 | "Returns the value mapped to key, not-found or nil if key not present." 47 | ([map key] 48 | (-lookup map key)) 49 | ([map key not-found] 50 | (-lookup map key not-found))) 51 | 52 | (defn contains? 53 | "Returns true if key is present in the given collection, otherwise 54 | returns false. Note that for numerically indexed collections like 55 | vectors and Java arrays, this tests if the numeric key is within the 56 | range of indexes. 'contains?' operates constant or logarithmic time; 57 | it will not perform a linear search for a value. See also 'some'." 58 | [coll key] 59 | ;XXX Consider IAssociative's -contains-key? and ISet's -contains. 60 | (not (identical? (get coll key lookup-sentinel) lookup-sentinel))) 61 | 62 | (defn dissoc 63 | "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, 64 | that does not contain a mapping for key(s)." 65 | [map & ks] 66 | (reduce -dissoc map ks)) 67 | 68 | (defn find 69 | "Returns the map entry for key, or nil if key not present." 70 | [coll k] 71 | ;XXX Consider IAssociative's -entry-at. 72 | (let [v (get coll k lookup-sentinel)] 73 | (when (not (identical? v lookup-sentinel)) 74 | [k v]))) 75 | 76 | (defn select-keys 77 | "Returns a map containing only those entries in m whose key is in keys" 78 | [m keyseq] 79 | (->> keyseq 80 | (map #(find m %)) 81 | (remove nil?) 82 | (into (empty m)))) 83 | 84 | (defn keys 85 | "Returns a sequence of the map's keys, in the same order as (seq m)." 86 | [m] 87 | (map -key m)) 88 | 89 | (defn vals 90 | "Returns a sequence of the map's values, in the same order as (seq m)." 91 | [m] 92 | (map -val m)) 93 | 94 | (defn key 95 | "Returns the key of the map entry." 96 | [e] 97 | (-key e)) 98 | 99 | (defn val 100 | "Returns the value in the map entry." 101 | [e] 102 | (-val e)) 103 | 104 | (defn get-in 105 | "Returns the value in a nested associative structure, 106 | where ks is a sequence of keys. Returns nil if the key 107 | is not present, or the not-found value if supplied." 108 | ([m ks] 109 | (get-in m ks nil)) 110 | ([m ks not-found] 111 | (reduce (fn [m k] 112 | (let [v (get m k lookup-sentinel)] 113 | (if (identical? v lookup-sentinel) 114 | (reduced not-found) 115 | v))) 116 | m, ks))) 117 | 118 | (defn assoc-in 119 | "Associates a value in a nested associative structure, where ks is a 120 | sequence of keys and v is the new value and returns a new nested structure. 121 | If any levels do not exist, hash-maps will be created." 122 | [m [k & ks] v] 123 | (if ks 124 | (assoc m k (assoc-in (get m k) ks v)) 125 | (assoc m k v))) 126 | 127 | (defn update-in 128 | "'Updates' a value in a nested associative structure, where ks is a 129 | sequence of keys and f is a function that will take the old value 130 | and any supplied args and return the new value, and returns a new 131 | nested structure. If any levels do not exist, hash-maps will be 132 | created." 133 | [m [k & ks] f & args] 134 | (if ks 135 | (assoc m k (apply update-in (get m k) ks f args)) 136 | (assoc m k (apply f (get m k) args)))) 137 | -------------------------------------------------------------------------------- /src/eclj/core/metadata.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn meta 4 | "Returns the metadata of obj, returns nil if there is no metadata." 5 | [x] 6 | (when (satisfies? IMeta x) 7 | (-meta x))) 8 | 9 | (defn with-meta 10 | "Returns an object of the same type and value as obj, 11 | with map m as its metadata." 12 | [x m] 13 | (-with-meta x m)) 14 | 15 | (defn vary-meta 16 | "Returns an object of the same type and value as obj, with 17 | (apply f (meta obj) args) as its metadata." 18 | [obj f & args] 19 | (with-meta obj (apply f (meta obj) args))) 20 | -------------------------------------------------------------------------------- /src/eclj/core/names.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn symbol? 4 | "Return true if x is a Symbol" 5 | [x] 6 | (instance? clojure.lang.Symbol x)) 7 | 8 | (defn keyword? 9 | "Return true if x is a Keyword" 10 | [x] 11 | (instance? clojure.lang.Keyword x)) 12 | 13 | (defn name 14 | "Returns the name String of a string, symbol or keyword." 15 | [x] 16 | (-name x)) 17 | 18 | (defn namespace 19 | "Returns the namespace String of a symbol or keyword, or nil if not present." 20 | [x] 21 | (-namespace x)) 22 | -------------------------------------------------------------------------------- /src/eclj/core/order.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn comparator 4 | "Returns an implementation of java.util.Comparator based upon pred." 5 | [pred] 6 | (fn [x y] 7 | (cond 8 | (pred x y) -1 9 | (pred y x) 1 10 | :else 0))) 11 | 12 | (defn max-key 13 | "Returns the x for which (k x), a number, is greatest." 14 | [k x & xs] 15 | (reduce (fn [a b] 16 | (if (> (k a) (k b)) a b)) 17 | x, xs)) 18 | 19 | (defn min-key 20 | "Returns the x for which (k x), a number, is least." 21 | [k x & xs] 22 | (reduce (fn [a b] 23 | (if (< (k a) (k b)) a b)) 24 | x, xs)) 25 | -------------------------------------------------------------------------------- /src/eclj/core/protocols.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defprotocol Fn 4 | :on-interface clojure.lang.Fn 5 | "Marker interface indicating invokeables that are explictly functions") 6 | 7 | (defprotocol IFn 8 | :on-interface clojure.lang.IFn 9 | (^{:on :invoke} -invoke 10 | [this] 11 | [this a] 12 | [this a b] 13 | [this a b c] 14 | [this a b c d] 15 | [this a b c d e] 16 | [this a b c d e f] 17 | [this a b c d e f g] 18 | [this a b c d e f g h] 19 | [this a b c d e f g h i] 20 | [this a b c d e f g h i j] 21 | [this a b c d e f g h i j k] 22 | [this a b c d e f g h i j k l] 23 | [this a b c d e f g h i j k l m] 24 | [this a b c d e f g h i j k l m n] 25 | [this a b c d e f g h i j k l m n o] 26 | [this a b c d e f g h i j k l m n o p] 27 | [this a b c d e f g h i j k l m n o p q] 28 | [this a b c d e f g h i j k l m n o p q s] 29 | [this a b c d e f g h i j k l m n o p q s t] 30 | [this a b c d e f g h i j k l m n o p q s t u] 31 | [this a b c d e f g h i j k l m n o p q s t u rest])) 32 | 33 | (defprotocol ICounted 34 | :on-interface clojure.lang.Counted 35 | (^{:on :count} -count [coll])) 36 | 37 | (defprotocol IEmptyableCollection 38 | :on-interface clojure.lang.IPersistentCollection 39 | (^{:on :empty} -empty [coll])) 40 | 41 | (defprotocol ICollection 42 | :on-interface clojure.lang.IPersistentCollection 43 | (^{:on :cons} -conj [coll o]) 44 | ;XXX clojure.lang.IPersistentCollection#equiv 45 | ) 46 | 47 | ;XXX clojure.lang.ASeq 48 | 49 | (defprotocol ISeq 50 | :on-interface clojure.lang.ISeq 51 | (^{:on :first} -first [coll]) 52 | (^{:on :more} -rest [coll])) 53 | 54 | (defprotocol INext 55 | :on-interface clojure.lang.ISeq 56 | (^{:on :next} -next [coll])) 57 | 58 | (defprotocol ILookup 59 | :on-interface clojure.lang.ILookup 60 | (^{:on :valAt} -lookup [o k] [o k not-found])) 61 | 62 | (defprotocol IAssociative 63 | :on-interface clojure.lang.Associative 64 | (^{:on :containsKey} -contains-key? [coll k]) 65 | (^{:on :entryAt} -entry-at [coll k]) 66 | (^{:on :assoc} -assoc [coll k v])) 67 | 68 | (defprotocol IMap 69 | :on-interface clojure.lang.IPersistentMap 70 | ;XXX (^{:on :assocEx} ...) unused variant that throws for duplicate keys 71 | (^{:on :without} -dissoc [coll k])) 72 | 73 | (defprotocol IMapEntry 74 | :on-interface clojure.lang.IMapEntry 75 | (^{:on :key} -key [coll]) 76 | (^{:on :val} -val [coll])) 77 | 78 | (defprotocol ISet 79 | :on-interface clojure.lang.IPersistentSet 80 | (^{:on :disjoin} -disjoin [coll v]) 81 | ;XXX (^{:on :contains} -contains [coll k]) 82 | ;XXX (^{:on :get} [coll k]) 83 | ) 84 | 85 | (defprotocol IStack 86 | :on-interface clojure.lang.IPersistentStack 87 | (^{:on :peek} -peek [coll]) 88 | (^{:on :pop} -pop [coll])) 89 | 90 | (defprotocol IVector 91 | :on-interface clojure.lang.IPersistentVector 92 | (^{:on :assocN} -assoc-n [coll n val]) 93 | ;XXX (^{:on :length} ...) unused count alias 94 | ) 95 | 96 | (defprotocol IDeref 97 | :on-interface clojure.lang.IDeref 98 | (^{:on :deref} -deref [o])) 99 | 100 | (defprotocol IDerefWithTimeout 101 | :on-interface clojure.lang.IBlockingDeref 102 | (^{:on :deref} -deref-with-timeout [o msec timeout-val])) 103 | 104 | (defprotocol IMeta 105 | :on-interface clojure.lang.IMeta 106 | (^{:on :meta} -meta [o])) 107 | 108 | (defprotocol IWithMeta 109 | :on-interface clojure.lang.IObj 110 | (^{:on :withMeta} -with-meta [o meta])) 111 | 112 | ;XXX clojure.lang.IReduce is unused 113 | ;XXX clojure.lang.protocols.InternalReduce is legacy 114 | 115 | (defprotocol IReduce 116 | :on-interface clojure.core.protocols.CollReduce 117 | (^{:on :reduce} -reduce [coll f] [coll f start])) 118 | 119 | (defprotocol IKVReduce 120 | :on-interface clojure.core.protocols.IKVReduce 121 | (^{:on :kv-reduce} -kv-reduce [coll f init])) 122 | 123 | ;XXX java.lang.Object#equals 124 | ;XXX clojure.lang.IPersistentCollection#equiv 125 | ;XXX clojure.lang.MapEquivalence marker 126 | 127 | (defprotocol IEquiv 128 | (-equiv [o other])) 129 | 130 | (defprotocol IHash 131 | ;XXX java.lang.Object#hashCode 132 | :on-interface clojure.lang.IHashEq 133 | (^{:on :hasheq} -hash [o])) 134 | 135 | (defprotocol ISeqable 136 | :on-interface clojure.lang.Seqable 137 | (^{:on :seq} -seq [o])) 138 | 139 | (defprotocol ISequential 140 | :on-interface clojure.lang.Sequential 141 | "Marker interface indicating a persistent collection of sequential items") 142 | 143 | (defprotocol IList 144 | :on-interface clojure.lang.IPersistentList 145 | "Marker interface indicating a persistent list") 146 | 147 | (defprotocol IRecord 148 | :on-interface clojure.lang.IRecord 149 | "Marker interface indicating a record object") 150 | 151 | (defprotocol IReversible 152 | :on-interface clojure.lang.Reversible 153 | (^{:on :rseq} -rseq [coll])) 154 | 155 | (defprotocol ISorted 156 | :on-interface clojure.lang.Sorted 157 | (^{:on :seq} -sorted-seq [coll ascending?]) 158 | (^{:on :seqFrom} -sorted-seq-from [coll k ascending?]) 159 | (^{:on :entryKey} -entry-key [coll entry]) 160 | (^{:on :comparator} -comparator [coll])) 161 | 162 | ;TODO: Integration with print-method and/or java.io.Writer? 163 | ;(defprotocol IWriter 164 | ; (-write [writer s]) 165 | ; (-flush [writer])) 166 | ; 167 | ;(defprotocol IPrintWithWriter 168 | ; (-pr-writer [o writer opts])) 169 | 170 | (defprotocol IPending 171 | :on-interface clojure.lang.IPending 172 | (^{:on :isRealized} -realized? [d])) 173 | 174 | (defprotocol IWatchable 175 | :on-interface clojure.lang.IRef 176 | (-notify-watches [this oldval newval]) ;XXX getWatches 177 | (^{:on :addWatch} -add-watch [this key f]) 178 | (^{:on :removeWatch} -remove-watch [this key])) 179 | 180 | (defprotocol IEditableCollection 181 | :on-interface clojure.lang.IEditableCollection 182 | (^{:on :asTransient} -as-transient [coll])) 183 | 184 | (defprotocol ITransientCollection 185 | :on-interface clojure.lang.ITransientCollection 186 | (^{:on :conj} -conj! [tcoll val]) 187 | (^{:on :persistent} -persistent! [tcoll])) 188 | 189 | (defprotocol ITransientAssociative 190 | :on-interface clojure.lang.ITransientAssociative 191 | (^{:on :assoc} -assoc! [tcoll key val])) 192 | 193 | (defprotocol ITransientMap 194 | :on-interface clojure.lang.ITransientMap 195 | (^{:on :without} -dissoc! [tcoll key])) 196 | 197 | (defprotocol ITransientVector 198 | :on-interface clojure.lang.ITransientVector 199 | (^{:on :assocN} -assoc-n! [tcoll n val]) 200 | (^{:on :pop} -pop! [tcoll])) 201 | 202 | (defprotocol ITransientSet 203 | :on-interface clojure.lang.ITransientSet 204 | (^{:on :disjoin} -disjoin! [tcoll v]) 205 | ;XXX clojure.lang.ITransientSet#contains 206 | ;XXX clojure.lang.ITransientSet#get 207 | ) 208 | 209 | (defprotocol IComparable 210 | :on-interface java.lang.Comparable 211 | (^{:on :compareTo} -compare [x y])) 212 | 213 | (defprotocol IChunk 214 | :on-interface clojure.lang.IChunk 215 | (^{:on :dropFirst} -drop-first [coll])) 216 | 217 | (defprotocol IChunkedSeq 218 | :on-interface clojure.lang.IChunkedSeq 219 | (^{:on :chunkedFirst} -chunked-first [coll]) 220 | (^{:on :chunkedMore} -chunked-rest [coll])) 221 | 222 | (defprotocol IChunkedNext 223 | :on-interface clojure.lang.IChunkedSeq 224 | (^{:on :chunkedNext} -chunked-next [coll])) 225 | 226 | (defprotocol INamed 227 | :on-interface clojure.lang.Named 228 | (^{:on :getName} -name [x]) 229 | (^{:on :getNamespace} -namespace [x])) 230 | 231 | ;XXX ISymbol 232 | ;XXX IKeyword 233 | 234 | (defprotocol IAtom) ;XXX on-interface 235 | 236 | (defprotocol IReset ;XXX on-interface 237 | (-reset! [o new-value])) 238 | 239 | (defprotocol ISwap ;XXX on-interface 240 | (-swap! [o f] [o f a] [o f a b] [o f a b xs])) ;XXX which arglists? 241 | 242 | ;XXX IRef 243 | ;XXX IAgent 244 | 245 | (defprotocol IMultiFn ;XXX on-interface 246 | (-reset [mf]) 247 | (-add-method [mf dispatch-val method]) 248 | (-remove-method [mf dispatch-val]) 249 | (-prefer-method [mf dispatch-val dispatch-val-y]) 250 | (-get-method [mf dispatch-val]) 251 | (-methods [mf]) 252 | (-prefers [mf])) 253 | 254 | ;XXX hierarchy 255 | 256 | (defprotocol IDelay) 257 | 258 | (defprotocol ILock 259 | :on-interface java.util.concurrent.locks.Lock 260 | (^{:on :lock} -lock [this]) 261 | (^{:on :unlock} -unlock [this])) 262 | -------------------------------------------------------------------------------- /src/eclj/core/refs.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn deref 4 | "Also reader macro: @ref/@agent/@var/@atom/@delay/@future/@promise. Within a 5 | transaction, returns the in-transaction-value of ref, else returns the 6 | most-recently-committed value of ref. When applied to a var, agent or atom, 7 | returns its current state. When applied to a delay, forces it if not already 8 | forced. When applied to a future, will block if computation not complete. 9 | When applied to a promise, will block until a value is delivered. The 10 | variant taking a timeout can be used for blocking references (futures and 11 | promises), and will return timeout-val if the timeout (in milliseconds) is 12 | reached before a value is available. See also - realized?." 13 | ([ref] (-deref ref)) 14 | ([ref timeout-ms timeout-val] 15 | (-deref-with-timeout ref timeout-ms timeout-val))) 16 | -------------------------------------------------------------------------------- /src/eclj/core/seqs.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn seq? 4 | "Return true if x not nil and satisfies ISeq" 5 | [x] 6 | (and (some? x) (satisfies? ISeq x))) 7 | 8 | (defn chunked-seq? 9 | "Return true if x satisfies IChunkedSeq" 10 | [x] 11 | (satisfies? IChunkedSeq x)) 12 | 13 | (defn seq [coll] 14 | "Returns a seq on the collection. If the collection is 15 | empty, returns nil. (seq nil) returns nil. seq also works on 16 | Strings, native Java arrays (of reference types) and any objects 17 | that implement Iterable." 18 | (-seq coll)) 19 | 20 | (defn first 21 | "Returns the first item in the collection. Calls seq on its 22 | argument. If coll is nil, returns nil." 23 | [coll] 24 | (-first (seq coll))) 25 | 26 | (defn next 27 | "Returns a seq of the items after the first. Calls seq on its 28 | argument. If there are no more items, returns nil." 29 | [coll] 30 | (-next (seq coll))) 31 | 32 | (defn rest 33 | "Returns a possibly empty seq of the items after the first. Calls seq on its 34 | argument." 35 | [coll] 36 | (-rest (seq coll))) 37 | 38 | (defn second 39 | "Same as (first (next x))" 40 | [x] 41 | (first (next x))) 42 | 43 | (defn ffirst 44 | "Same as (first (first x))" 45 | [x] 46 | (first (first x))) 47 | 48 | (defn nfirst 49 | "Same as (next (first x))" 50 | [x] 51 | (next (first x))) 52 | 53 | (defn fnext 54 | "Same as (first (next x))" 55 | [x] 56 | (first (next x))) 57 | 58 | (defn nnext 59 | "Same as (next (next x))" 60 | [x] 61 | (next (next x))) 62 | 63 | (defn nthnext 64 | "Returns the nth next of coll, (seq coll) when n is 0." 65 | [coll n] 66 | (loop [n n xs (seq coll)] 67 | (if (and xs (pos? n)) 68 | (recur (dec n) (next xs)) 69 | xs))) 70 | 71 | (defn nthrest 72 | "Returns the nth rest of coll, coll when n is 0." 73 | [coll n] 74 | (loop [n n xs coll] 75 | (if (and (pos? n) (seq xs)) 76 | (recur (dec n) (rest xs)) 77 | xs))) 78 | 79 | (defn last 80 | "Return the last item in coll, in linear time" 81 | [s] 82 | (if (next s) 83 | (recur (next s)) 84 | (first s))) 85 | 86 | (defn butlast 87 | "Return a seq of all but the last item in coll, in linear time" 88 | [s] 89 | (loop [ret [] s s] 90 | (if (next s) 91 | (recur (conj ret (first s)) (next s)) 92 | (seq ret)))) 93 | 94 | (defn peek 95 | "For a list or queue, same as first, for a vector, same as, but much 96 | more efficient than, last. If the collection is empty, returns nil." 97 | [coll] 98 | (-peek coll)) 99 | 100 | (defn pop 101 | "For a list or queue, returns a new list/queue without the first 102 | item, for a vector, returns a new vector without the last item. If 103 | the collection is empty, throws an exception. Note - not the same 104 | as next/butlast." 105 | [coll] 106 | (-pop coll)) 107 | 108 | (defn cons 109 | "Returns a new seq where x is the first element and coll is the rest." 110 | [x coll] 111 | (if coll 112 | (clojure.lang.Cons. x (seq coll)) 113 | (list x))) 114 | 115 | (defn rseq 116 | "Returns, in constant time, a seq of the items in rev (which can be a vector 117 | or sorted-map), in reverse order. If rev is empty returns nil" 118 | [rev] 119 | (-rseq rev)) 120 | 121 | ;XXX figure out what to do about chunking 122 | ;(defn map 123 | ; "Returns a lazy sequence consisting of the result of applying f to the 124 | ; set of first items of each coll, followed by applying f to the set 125 | ; of second items in each coll, until any one of the colls is 126 | ; exhausted. Any remaining items in other colls are ignored. Function 127 | ; f should accept number-of-colls arguments." 128 | ; [f & colls] 129 | ; ) 130 | 131 | (defn mapcat 132 | "Returns the result of applying concat to the result of applying map 133 | to f and colls. Thus function f should return a collection." 134 | [f & colls] 135 | (apply concat (apply map f colls))) 136 | 137 | ;XXX figure out what to do about chunking 138 | ;(defn filter 139 | ; "Returns a lazy sequence of the items in coll for which 140 | ; (pred item) returns true. pred must be free of side-effects." 141 | ; ([pred coll] 142 | ; (lazy-seq 143 | ; (when-let [s (seq coll)] 144 | ; (if (chunked-seq? s) 145 | ; (let [c (chunk-first s) 146 | ; size (count c) 147 | ; b (chunk-buffer size)] 148 | ; (dotimes [i size] 149 | ; (when (pred (.nth c i)) 150 | ; (chunk-append b (.nth c i)))) 151 | ; (chunk-cons (chunk b) (filter pred (chunk-rest s)))) 152 | ; (let [f (first s) r (rest s)] 153 | ; (if (pred f) 154 | ; (cons f (filter pred r)) 155 | ; (filter pred r)))))))) 156 | 157 | 158 | (defn remove 159 | "Returns a lazy sequence of the items in coll for which 160 | (pred item) returns false. pred must be free of side-effects." 161 | [pred coll] 162 | (filter (complement pred) coll)) 163 | 164 | (defn take 165 | "Returns a lazy sequence of the first n items in coll, or all items if 166 | there are fewer than n." 167 | [n coll] 168 | (lazy-seq 169 | (when (pos? n) 170 | (when-let [s (seq coll)] 171 | (cons (first s) (take (dec n) (rest s))))))) 172 | 173 | (defn take-while 174 | "Returns a lazy sequence of successive items from coll while 175 | (pred item) returns true. pred must be free of side-effects." 176 | [pred coll] 177 | (lazy-seq 178 | (when-let [s (seq coll)] 179 | (when (pred (first s)) 180 | (cons (first s) (take-while pred (rest s))))))) 181 | 182 | (defn drop 183 | "Returns a lazy sequence of all but the first n items in coll." 184 | [n coll] 185 | (lazy-seq 186 | (loop [n n, coll coll] 187 | (let [s (seq coll)] 188 | (if (and (pos? n) s) 189 | (recur (dec n) (rest s)) 190 | s))))) 191 | 192 | (defn drop-last 193 | "Return a lazy sequence of all but the last n (default 1) items in coll" 194 | ([s] (drop-last 1 s)) 195 | ([n s] (map (fn [x _] x) s (drop n s)))) 196 | 197 | (defn take-last 198 | "Returns a seq of the last n items in coll. Depending on the type 199 | of coll may be no better than linear time. For vectors, see also subvec." 200 | [n coll] 201 | (loop [s (seq coll), lead (seq (drop n coll))] 202 | (if lead 203 | (recur (next s) (next lead)) 204 | s))) 205 | 206 | (defn drop-while 207 | "Returns a lazy sequence of the items in coll starting from the first 208 | item for which (pred item) returns logical false." 209 | [pred coll] 210 | (lazy-seq 211 | (loop [pred pred, coll coll] 212 | (let [s (seq coll)] 213 | (if (and s (pred (first s))) 214 | (recur pred (rest s)) 215 | s))))) 216 | 217 | (defn cycle 218 | "Returns a lazy (infinite!) sequence of repetitions of the items in coll." 219 | [coll] 220 | (lazy-seq 221 | (when-let [s (seq coll)] 222 | (concat s (cycle s))))) 223 | 224 | (defn split-at 225 | "Returns a vector of [(take n coll) (drop n coll)]" 226 | [n coll] 227 | [(take n coll) (drop n coll)]) 228 | 229 | (defn split-with 230 | "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" 231 | [pred coll] 232 | [(take-while pred coll) (drop-while pred coll)]) 233 | 234 | (defn repeat 235 | "Returns a lazy (infinite!, or length n if supplied) sequence of xs." 236 | ([x] (lazy-seq (cons x (repeat x)))) 237 | ([n x] (take n (repeat x)))) 238 | 239 | (defn replicate 240 | "DEPRECATED: Use 'repeat' instead. 241 | Returns a lazy seq of n xs." 242 | [n x] 243 | (take n (repeat x))) 244 | 245 | (defn iterate 246 | "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must 247 | be free of side-effects" 248 | [f x] 249 | (cons x (lazy-seq (iterate f (f x))))) 250 | 251 | ;XXX figure out what to do about chunking 252 | ;(defn range 253 | ; "Returns a lazy seq of nums from start (inclusive) to end 254 | ; (exclusive), by step, where start defaults to 0, step to 1, and end to 255 | ; infinity. When step is equal to 0, returns an infinite sequence of 256 | ; start. When start is equal to end, returns empty list." 257 | ; ([] (range 0 Double/POSITIVE_INFINITY 1)) 258 | ; ([end] (range 0 end 1)) 259 | ; ([start end] (range start end 1)) 260 | ; ([start end step] 261 | ; (lazy-seq 262 | ; (let [b (chunk-buffer 32) 263 | ; comp (cond (or (zero? step) (= start end)) not= 264 | ; (pos? step) < 265 | ; (neg? step) >)] 266 | ; (loop [i start] 267 | ; (if (and (< (count b) 32) 268 | ; (comp i end)) 269 | ; (do 270 | ; (chunk-append b i) 271 | ; (recur (+ i step))) 272 | ; (chunk-cons (chunk b) 273 | ; (when (comp i end) 274 | ; (range i end step))))))))) 275 | 276 | (defn take-nth 277 | "Returns a lazy seq of every nth item in coll." 278 | [n coll] 279 | (lazy-seq 280 | (when-let [s (seq coll)] 281 | (cons (first s) (take-nth n (drop n s)))))) 282 | 283 | (defn interleave 284 | "Returns a lazy seq of the first item in each coll, then the second etc." 285 | ([] ()) 286 | ([& colls] 287 | (lazy-seq 288 | (let [ss (map seq colls)] 289 | (when (every? identity ss) 290 | (concat (map first ss) (apply interleave (map rest ss)))))))) 291 | 292 | 293 | (defn interpose 294 | "Returns a lazy seq of the elements of coll separated by sep" 295 | [sep coll] 296 | (drop 1 (interleave (repeat sep) coll))) 297 | 298 | (defn partition 299 | "Returns a lazy sequence of lists of n items each, at offsets step 300 | apart. If step is not supplied, defaults to n, i.e. the partitions 301 | do not overlap. If a pad collection is supplied, use its elements as 302 | necessary to complete last partition upto n items. In case there are 303 | not enough padding elements, return a partition with less than n items." 304 | ([n coll] 305 | (partition n n coll)) 306 | ([n step coll] 307 | (partition n step nil coll)) 308 | ([n step pad coll] 309 | (lazy-seq 310 | (when-let [s (seq coll)] 311 | (let [p (doall (take n s))] 312 | (if (= n (count p)) 313 | (cons p (partition n step pad (nthrest s step))) 314 | (list (take n (concat p pad))))))))) 315 | -------------------------------------------------------------------------------- /src/eclj/core/sets.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn set? 4 | "Returns true if x is not nil and satisfies ISet" 5 | [x] 6 | (and (some? x) (satisfies? ISet x))) 7 | 8 | (defn hash-set 9 | "Returns a new hash set with supplied keys. Any equal keys are 10 | handled as if by repeated uses of conj." 11 | [& keys] 12 | (clojure.lang.PersistentHashSet/create keys)) 13 | 14 | (defn sorted-set 15 | "Returns a new sorted set with supplied keys. Any equal keys are 16 | handled as if by repeated uses of conj." 17 | [& keys] 18 | (clojure.lang.PersistentTreeSet/create keys)) 19 | 20 | (defn sorted-set-by 21 | "Returns a new sorted set with supplied keys, using the supplied 22 | comparator. Any equal keys are handled as if by repeated uses of 23 | conj." 24 | [comparator & keys] 25 | (clojure.lang.PersistentTreeSet/create comparator keys)) 26 | 27 | (defn disj 28 | "disj[oin]. Returns a new set of the same (hashed/sorted) type, that 29 | does not contain key(s)." 30 | [set & ks] 31 | (reduce -disjoin set ks)) 32 | -------------------------------------------------------------------------------- /src/eclj/core/strs.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn char? 4 | "Return true if x is a Character" 5 | [x] 6 | (instance? java.lang.Character x)) 7 | 8 | (defn string? 9 | "Return true if x is a String" 10 | [x] 11 | (instance? java.lang.String x)) 12 | -------------------------------------------------------------------------------- /src/eclj/core/vecs.eclj: -------------------------------------------------------------------------------- 1 | (in-ns 'eclj.core) 2 | 3 | (defn vector? 4 | "Return true if x is not nil and satisfies IVector" 5 | [x] 6 | (and (some? x) (satisfies? IVector x))) 7 | 8 | (defn vector 9 | "Creates a new vector containing the args." 10 | [& args] 11 | (clojure.lang.PersistentVector/create (sequence args))) 12 | 13 | (defn vec 14 | "Creates a new vector containing the contents of coll." 15 | [coll] 16 | (clojure.lang.PersistentVector/create (sequence coll))) 17 | 18 | (defn subvec 19 | "Returns a persistent vector of the items in vector from 20 | start (inclusive) to end (exclusive). If end is not supplied, 21 | defaults to (count vector). This operation is O(1) and very fast, as 22 | the resulting vector shares structure with the original and no 23 | trimming is done." 24 | ([v start] 25 | (subvec v start (count v))) 26 | ([v start end] 27 | (when-not (<= 0 start end (count v)) 28 | (throw (java.lang.IndexOutOfBoundsException.))) 29 | (if (= start end) 30 | [] 31 | (clojure.lang.APersistentVector$SubVector. nil v start end)))) 32 | 33 | (defn mapv 34 | "Returns a vector consisting of the result of applying f to the 35 | set of first items of each coll, followed by applying f to the set 36 | of second items in each coll, until any one of the colls is 37 | exhausted. Any remaining items in other colls are ignored. Function 38 | f should accept number-of-colls arguments." 39 | [f & colls] 40 | (into [] (apply map f colls))) 41 | 42 | (defn filterv 43 | "Returns a vector of the items in coll for which 44 | (pred item) returns true. pred must be free of side-effects." 45 | [pred coll] 46 | (->> coll 47 | (reduce (fn [v x] 48 | (if (pred x) (conj! v x) v)) 49 | (transient [])) 50 | persistent!)) 51 | -------------------------------------------------------------------------------- /src/eclj/env.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.env 2 | (:import [clojure.lang Reflector])) 3 | 4 | (defrecord Env [namespace locals kernel]) 5 | ;TODO: Should only the top env have kernel? 6 | 7 | (defn static-invoke [class member & args] 8 | (if (zero? (count args)) 9 | (try 10 | (Reflector/getStaticField class member) 11 | (catch Exception e 12 | (Reflector/invokeStaticMethod 13 | class member clojure.lang.RT/EMPTY_ARRAY))) 14 | (Reflector/invokeStaticMethod class member (object-array args)))) 15 | 16 | (defn staticfn [class member] 17 | (fn [& args] 18 | (apply static-invoke class member args))) 19 | 20 | (def patches {#'clojure.core/case 'eclj.core/case 21 | #'clojure.core/ns 'eclj.core/ns 22 | #'clojure.core/deftype 'eclj.core/deftype 23 | #'clojure.core/defrecord 'eclj.core/defrecord 24 | #'clojure.core/defprotocol 'eclj.core/defprotocol}) 25 | 26 | (defn try-lookup [ns sym] 27 | (try 28 | (if-let [x (ns-resolve ns sym)] 29 | (if (var? x) 30 | (if-let [patch (patches x)] 31 | (try-lookup ns patch) 32 | {:origin :namespace :value (or (-> x meta :eclj/alias) x)}) 33 | {:origin :host :value x}) 34 | {:origin :host :value (clojure.lang.RT/classForName (name sym))}) 35 | (catch ClassNotFoundException e 36 | nil))) 37 | 38 | ;;TODO: Namespaced keys? 39 | (def kernel { 40 | 41 | :deref 42 | (fn [{:keys [ref]}] 43 | (deref ref)) 44 | 45 | :invoke 46 | (fn [{:keys [f args]}] 47 | (apply f args)) 48 | 49 | :resolve 50 | (fn [{:keys [env sym]}] 51 | (or (try-lookup (:namespace env) sym) 52 | (when-let [ns (namespace sym)] 53 | (let [{:keys [value]} (try-lookup (:namespace env) (symbol ns)) 54 | n (name sym)] 55 | (when (instance? Class value) 56 | {:origin :host 57 | :value (try 58 | (.get (.getField value n) value) 59 | (catch NoSuchFieldException _ 60 | (staticfn value n)))}))))) 61 | 62 | :declare 63 | (fn [{:keys [sym]}] 64 | (intern *ns* sym)) 65 | 66 | :define 67 | (fn [{:keys [sym value]}] 68 | (let [var (intern *ns* sym value)] 69 | (when (-> sym meta :dynamic) 70 | (.setDynamic var)) 71 | var)) 72 | 73 | :new 74 | (fn [{:keys [class args]}] 75 | (Reflector/invokeConstructor class (object-array args))) 76 | 77 | :interop 78 | (fn [{:keys [static? object member args]}] 79 | (let [s (str member) 80 | s (if (.startsWith s "-") 81 | (apply str (next s)) 82 | s)] 83 | (if static? 84 | (apply static-invoke object s args) 85 | (if (zero? (count args)) 86 | (Reflector/invokeNoArgInstanceMember object s) 87 | (Reflector/invokeInstanceMember s object (object-array args)))))) 88 | 89 | :assign-var 90 | (fn [{:keys [var value]}] 91 | (var-set var value)) 92 | 93 | :assign-field ;TODO: Test this. 94 | (fn [{:keys [object field value]}] 95 | (let [field (name field)] 96 | (if (instance? Class object) 97 | (Reflector/setStaticField object field value) 98 | (Reflector/setInstanceField object field value)))) 99 | 100 | :import 101 | (fn [{:keys [sym]}] 102 | (.importClass *ns* (clojure.lang.RT/classForName (name sym)))) 103 | 104 | :reify 105 | (fn [{:keys [env interfaces methods]}] 106 | (clojure.core/eval 107 | `(reify* ~interfaces 108 | ~@((for [[name args & body] methods 109 | :let [expr `'(do ~@body) 110 | denv `(-> ~env ~@(for [arg args] 111 | `(assoc-in [:locals '~arg] ~arg)))]] 112 | (list name args `(eclj.core/eval ~expr ~denv))))))) 113 | 114 | :deftype 115 | (fn [{:keys [env tagname classname fields implements methods] :as op}] 116 | (clojure.core/eval 117 | `(deftype* ~tagname ~classname ~fields :implements ~implements 118 | ~@(for [[name args & body] methods 119 | :let [params (repeatedly (count args) gensym) 120 | this (first params) 121 | getters (map #(list (symbol (str ".-" %)) this) fields) 122 | expr `'(eclj.core/symbol-macrolet 123 | [~@(interleave fields getters)] 124 | (let [~@(interleave args params)] 125 | ~@body)) 126 | denv `(-> ~env 127 | ~@(for [param params] 128 | `(assoc-in [:locals '~param] ~param)))]] 129 | (list name (vec params) `(eclj.core/eval ~expr ~denv)))))) 130 | 131 | }) 132 | 133 | (defn ns-env 134 | ([] (ns-env *ns*)) 135 | ([ns] 136 | (Env. (the-ns ns) {} kernel))) 137 | -------------------------------------------------------------------------------- /src/eclj/fn.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.fn 2 | (:refer-clojure :exclude [eval]) 3 | (:require [eclj.common :refer (map->Syntax)])) 4 | 5 | (defn fn-apply [{:keys [env] :as f} arg] 6 | (let [eval (resolve 'eclj.core/eval) 7 | syntax (map->Syntax {:head :apply :f f :arg arg :env env}) 8 | form (list 'eclj.core/eval (list 'quote syntax) env)] 9 | (eval form))) 10 | 11 | (defrecord Fn [name arities max-fixed-arity env] 12 | clojure.lang.Fn 13 | clojure.lang.IFn 14 | (applyTo [this args] 15 | (fn-apply this args)) 16 | ;; *cringe* 17 | (invoke [this] 18 | (fn-apply this [])) 19 | (invoke [this a] 20 | (fn-apply this [a])) 21 | (invoke [this a b] 22 | (fn-apply this [a b])) 23 | (invoke [this a b c] 24 | (fn-apply this [a b c])) 25 | (invoke [this a b c d] 26 | (fn-apply this [a b c d])) 27 | (invoke [this a b c d e] 28 | (fn-apply this [a b c d e])) 29 | (invoke [this a b c d e f] 30 | (fn-apply this [a b c d e f])) 31 | (invoke [this a b c d e f g] 32 | (fn-apply this [a b c d e f g])) 33 | (invoke [this a b c d e f g h] 34 | (fn-apply this [a b c d e f g h])) 35 | (invoke [this a b c d e f g h i] 36 | (fn-apply this [a b c d e f g h i])) 37 | (invoke [this a b c d e f g h i j] 38 | (fn-apply this [a b c d e f g h i j])) 39 | (invoke [this a b c d e f g h i j k] 40 | (fn-apply this [a b c d e f g h i j k])) 41 | (invoke [this a b c d e f g h i j k l] 42 | (fn-apply this [a b c d e f g h i j k l])) 43 | (invoke [this a b c d e f g h i j k l m] 44 | (fn-apply this [a b c d e f g h i j k l m])) 45 | (invoke [this a b c d e f g h i j k l m n] 46 | (fn-apply this [a b c d e f g h i j k l m n])) 47 | (invoke [this a b c d e f g h i j k l m n o] 48 | (fn-apply this [a b c d e f g h i j k l m n o])) 49 | (invoke [this a b c d e f g h i j k l m n o p] 50 | (fn-apply this [a b c d e f g h i j k l m n o p])) 51 | (invoke [this a b c d e f g h i j k l m n o p q] 52 | (fn-apply this [a b c d e f g h i j k l m n o p q])) 53 | (invoke [this a b c d e f g h i j k l m n o p q r] 54 | (fn-apply this [a b c d e f g h i j k l m n o p q r])) 55 | (invoke [this a b c d e f g h i j k l m n o p q r s] 56 | (fn-apply this [a b c d e f g h i j k l m n o p q r s])) 57 | (invoke [this a b c d e f g h i j k l m n o p q r s t] 58 | (fn-apply this [a b c d e f g h i j k l m n o p q r s t])) 59 | (invoke [this a b c d e f g h i j k l m n o p q r s t rest] 60 | (fn-apply this (concat [a b c d e f g h i j k l m n o p q r s t] rest))) 61 | 62 | ) 63 | -------------------------------------------------------------------------------- /src/eclj/interpret/cps.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.interpret.cps 2 | (:refer-clojure :exclude [eval]) 3 | (:require [eclj.common :refer (map->Syntax expansion?)] 4 | [eclj.parse :refer (parse)] 5 | [eclj.fn])) 6 | 7 | (def answer ^:eclj/answer 8 | (fn [x] {:op :answer :value x})) 9 | 10 | ;; Necessary because eclj.interpret.meta redefines answer symbolically. 11 | (defn tail-effect? [effect] 12 | (-> effect :k meta :eclj/answer)) 13 | 14 | (defmulti interpret-syntax :head) 15 | 16 | (defn interpret [x env] 17 | (interpret-syntax (parse x env))) 18 | 19 | (defn thunk [expr env] 20 | #(interpret expr env)) 21 | 22 | (defn thunk-syntax [syntax] 23 | (thunk (map->Syntax syntax) (:env syntax))) 24 | 25 | (defmulti -apply (fn [f arg] (class f))) 26 | 27 | (defmacro call [f & args] 28 | `(let [f# ~f] 29 | (if (instance? eclj.fn.Fn f#) 30 | (-apply f# [~@args]) 31 | (f# ~@args)))) 32 | 33 | (defn interpret-effect [x env] 34 | (loop [f (thunk x env)] 35 | (let [x (call f)] 36 | (if (fn? x) 37 | (recur x) 38 | (let [{:keys [op k]} x] 39 | (if-let [handler (get-in env [:kernel op])] 40 | (recur #(call k (call handler x))) 41 | x)))))) 42 | 43 | (defn result [effect] 44 | (case (:op effect) 45 | :answer (:value effect) 46 | :throw (throw (:error effect)) 47 | (throw (ex-info "Unhandled Effect" {:eclj/effect effect})))) 48 | 49 | (defn interpret-result [x env] 50 | (result (interpret-effect x env))) 51 | 52 | (defn raise [action] 53 | (merge {:k answer} action)) 54 | 55 | ;;TODO: Implement restarts, etc. 56 | (defn signal [condition] 57 | (raise (merge {:op :condition} condition))) 58 | 59 | (defn handle-with [handler effect k] 60 | (let [rec #(handle-with handler % k)] 61 | (if (fn? effect) 62 | #(rec (effect)) 63 | (or (handler effect k) 64 | (assoc effect :k #(rec (fn [] ((:k effect) %)))))))) 65 | 66 | (defn default-handler [effect k] 67 | (when (= (:op effect) :answer) 68 | #(k (:value effect)))) 69 | 70 | (defn handle [effect k] 71 | (handle-with default-handler effect k)) 72 | 73 | (defn lookup [{:keys [locals] :as env} sym] 74 | (if-let [[_ value] (find locals sym)] 75 | (answer {:origin :locals :value value}) 76 | (raise {:op :resolve 77 | :env env 78 | :sym sym 79 | :k #(if % 80 | (answer %) 81 | (signal {:error :undefined :sym sym}))}))) 82 | 83 | (defmethod interpret-syntax :constant 84 | [{:keys [value]}] 85 | (answer value)) 86 | 87 | (defn interpret-items [coll env] 88 | ((fn rec [dest src] 89 | (if (empty? src) 90 | (answer dest) 91 | (handle (thunk (first src) env) 92 | #(rec (conj dest %) (next src))))) 93 | (empty coll) coll)) 94 | 95 | (defmethod interpret-syntax :collection 96 | [{:keys [coll env]}] 97 | (interpret-items coll env)) 98 | 99 | (defn macro? [{:keys [origin value]}] 100 | (and (= origin :namespace) (-> value meta :macro))) 101 | 102 | (defmethod interpret-syntax :name 103 | [{:keys [sym env]}] 104 | (handle (lookup env sym) 105 | (fn [{:keys [origin value] :as resolved}] 106 | (cond 107 | (macro? resolved) (signal {:error :value-of-macro :name sym}) 108 | (expansion? value) (thunk (:expr value) env) 109 | :else (case origin 110 | :locals (answer value) 111 | :host (answer value) 112 | :namespace (raise {:op :deref :ref value})))))) 113 | 114 | (defmethod interpret-syntax :if 115 | [{:keys [test then else env]}] 116 | (handle (thunk test env) 117 | #(thunk (if % then else) env))) 118 | 119 | (defmethod interpret-syntax :var 120 | [{:keys [sym env]}] 121 | (handle (raise {:op :resolve :env env :sym sym}) 122 | (fn [{:keys [origin value]}] 123 | (assert (= origin :namespace)) 124 | (answer value)))) 125 | 126 | (defmethod interpret-syntax :do 127 | [{:keys [statements ret env]}] 128 | (if (seq statements) 129 | (handle (thunk-syntax {:head :do :env env 130 | :statements (pop statements) 131 | :ret (peek statements)}) 132 | (fn [_] (thunk ret env))) 133 | (thunk ret env))) 134 | 135 | (defmethod interpret-syntax :bind 136 | [{:keys [name value expr env]}] 137 | (thunk expr (assoc-in env [:locals name] value))) 138 | 139 | (defmethod interpret-syntax :let 140 | [{:keys [bindings expr env]}] 141 | (if-let [[{:keys [name init]} & bindings*] (seq bindings)] 142 | (handle (thunk init env) 143 | #(thunk-syntax {:head :let :env (assoc-in env [:locals name] %) 144 | :bindings (vec bindings*) :expr expr})) 145 | (thunk expr env))) 146 | 147 | (defmethod -apply Object 148 | [f arg] 149 | (signal {:error :not-callable :f f :args arg})) 150 | 151 | (defmethod -apply clojure.lang.IFn 152 | [f arg] 153 | (raise {:op :invoke :f f :args arg})) 154 | 155 | (defmethod -apply clojure.lang.Var 156 | [f arg] 157 | (handle (raise {:op :deref :ref f}) 158 | #(-apply % arg))) 159 | 160 | (defn recur-handler [f env] 161 | (fn [effect k] 162 | (case (:op effect) 163 | :answer #(k (:value effect)) 164 | :recur (if (tail-effect? effect) 165 | (thunk-syntax {:head :apply :f f :arg (:args effect) :env env}) 166 | (signal {:error :non-tail-position})) 167 | nil))) 168 | 169 | (defmethod -apply eclj.fn.Fn 170 | [{:keys [name arities max-fixed-arity env] :as f} args] 171 | (let [argcount (count (if (counted? args) 172 | args 173 | (take (inc max-fixed-arity) args))) 174 | {:keys [params expr] :as method} (or (arities argcount) 175 | (and (>= argcount max-fixed-arity) 176 | (arities :more)))] 177 | (if method 178 | (let [env* (if name (assoc-in env [:locals name] f) env) 179 | ;;TODO: Don't generate form, destructure to env & use AST directly. 180 | form `(let [~params '~args] ~expr)] 181 | (handle-with (recur-handler f env) 182 | (thunk form env*) answer)) 183 | (signal {:error :arity, :f f :given argcount})))) 184 | 185 | ;TODO: defmethod -apply for symbols & keywords ? 186 | 187 | (defmethod interpret-syntax :letfn 188 | [{:keys [bindings expr env]}] 189 | (thunk expr (update-in env [:locals] merge bindings))) 190 | 191 | (defn exception-handler [catches default finally env] 192 | (fn handler [{:keys [op] :as effect} k] 193 | (case op 194 | :answer #(handle (thunk finally env) 195 | (fn [_] (fn [] (k (:value effect))))) 196 | :throw (let [error (:error effect) 197 | catch (some (fn [{:keys [class sym expr] :as catch}] 198 | (when (instance? class error) catch)) 199 | catches)] 200 | (when-let [{:keys [name expr]} (or catch default)] 201 | #(handle (thunk-syntax {:head :bind :env env 202 | :name name :value error :expr expr}) 203 | (fn [y] 204 | (handle (thunk finally env) 205 | (fn [_] (k y))))))) 206 | nil))) 207 | 208 | (defmethod interpret-syntax :try 209 | [{:keys [try catches default finally env]}] 210 | (handle (interpret-items (mapv :type catches) env) 211 | (fn [classes] ;TODO: Ensure items are exception classes. 212 | (let [catches* (map #(assoc %1 :class %2) catches classes)] 213 | (handle-with (exception-handler catches* default finally env) 214 | (thunk try env) answer))))) 215 | 216 | (defmethod interpret-syntax :raise 217 | [{:keys [expr env]}] 218 | (handle (thunk expr env) raise)) 219 | 220 | (defn apply-args [f args env] 221 | (handle (interpret-items (reverse args) env) 222 | #(thunk-syntax {:head :apply :f f :arg % :env env}))) 223 | 224 | (defmethod interpret-syntax :apply 225 | [{:keys [f arg]}] 226 | (-apply f arg)) 227 | 228 | (defmethod interpret-syntax :invoke 229 | [{:keys [f args env form] :as ast}] 230 | (if (symbol? f) 231 | (handle (lookup env f) 232 | #(let [{:keys [value] :as resolved} %] 233 | (cond 234 | (macro? resolved) (thunk-syntax {:head :expand :macro value 235 | :form form :env env}) 236 | (expansion? value) (thunk-syntax (assoc ast :f (:expr value))) 237 | :else (apply-args value args env)))) 238 | (handle (thunk f env) 239 | #(apply-args % args env)))) 240 | 241 | ;;TODO: Replace expand special with -apply on a macro type. 242 | (defmethod interpret-syntax :expand 243 | [{:keys [macro form env]}] 244 | (handle (thunk-syntax {:head :apply :env env :f macro 245 | :arg (list* form env (next form))}) 246 | #(thunk % env))) 247 | 248 | (defmethod interpret-syntax :new 249 | [{:keys [class args env]}] 250 | (handle (thunk class env) 251 | (fn [class*] ;TODO: Validate 252 | (fn [] 253 | (handle (interpret-items args env) 254 | #(raise {:op :new :class class* :args %})))))) 255 | 256 | (defmethod interpret-syntax :interop 257 | [{:keys [target member args env]}] 258 | (let [interop (fn [static? object] 259 | (handle (interpret-items (vec args) env) 260 | #(raise {:op :interop :static? static? 261 | :object object :member member :args %}))) 262 | instance-invoke (fn [] 263 | (handle (thunk target env) 264 | #(interop false %)))] 265 | (if (symbol? target) 266 | (handle (lookup env target) 267 | (fn [{:keys [origin value] :as resolved}] 268 | (if (= origin :host) 269 | (interop true value) 270 | (instance-invoke)))) 271 | (instance-invoke)))) 272 | 273 | (defn interpret-meta [x env] 274 | (handle (thunk (meta x) env) 275 | #(answer (with-meta x %)))) 276 | 277 | (defmethod interpret-syntax :declare 278 | [{:keys [sym env]}] 279 | (handle (interpret-meta sym env) 280 | #(raise {:op :declare :sym %}))) 281 | 282 | (defmethod interpret-syntax :define 283 | [{:keys [sym expr env]}] 284 | (handle (thunk expr env) 285 | (fn [value] 286 | (handle (interpret-meta sym env) 287 | #(raise {:op :define :sym % :value value}))))) 288 | 289 | ;;TODO just :assign, expand symbol macros for place 290 | (defmethod interpret-syntax :assign-var 291 | [{:keys [name expr env]}] 292 | (handle (lookup env name) 293 | (fn [{:keys [origin value]}] 294 | (if (= origin :namespace) 295 | (handle (thunk expr env) 296 | #(raise {:op :assign-var :var value :value %})) 297 | (signal {:error :not-assignable :location value}))))) 298 | 299 | (defmethod interpret-syntax :assign-field 300 | [{:keys [object field expr env]}] 301 | (handle (thunk object env) 302 | (fn [instance] 303 | (handle (thunk expr env) 304 | #(raise {:op :assign-field :object instance 305 | :field field :value %}))))) 306 | 307 | (defmethod interpret-syntax :loop 308 | [{:keys [bindings expr env]}] 309 | (let [syms (vec (take-nth 2 bindings)) 310 | inits (vec (take-nth 2 (next bindings)))] 311 | ;;TODO: Generate AST directly instead of syntax forms. 312 | (handle (interpret-items inits env) 313 | (fn [values] 314 | (thunk `((fn ~syms ~expr) 315 | ~@(map #(list 'quote %) values)) 316 | env))))) 317 | 318 | (defmethod interpret-syntax :recur 319 | [{:keys [args env]}] 320 | (handle (interpret-items args env) 321 | #(raise {:op :recur :args %}))) 322 | 323 | (defmethod interpret-syntax :import 324 | [{:keys [sym]}] 325 | (raise {:op :import :sym sym})) 326 | 327 | (defmethod interpret-syntax :case 328 | [{:keys [expr cases default env]}] 329 | (handle (thunk expr env) 330 | (fn [value] 331 | (if-let [[_ match] (find cases value)] 332 | (thunk match env) 333 | (thunk default env))))) 334 | 335 | (defmethod interpret-syntax :meta 336 | [{:keys [expr meta env]}] 337 | (handle (thunk expr env) 338 | (fn [object] 339 | (handle (thunk meta env) 340 | #(answer (with-meta object %)))))) 341 | 342 | (defmethod interpret-syntax :eval-effect 343 | [{:keys [expr env-expr env]}] 344 | (handle (thunk expr env) 345 | (fn [form] 346 | (handle (thunk env-expr env) 347 | (fn [env*] 348 | (handle-with (fn [effect k] (k (answer effect))) 349 | (thunk form env*) 350 | identity)))))) 351 | 352 | (defmethod interpret-syntax :reify 353 | [{:keys [env interfaces methods]}] 354 | (raise {:op :reify :env env :interfaces interfaces :methods methods})) 355 | 356 | (defmethod interpret-syntax :deftype 357 | [{:keys [env tagname classname fields implements methods]}] 358 | (raise {:op :deftype :env env :tagname tagname :classname classname 359 | :fields fields :implements implements :methods methods})) 360 | -------------------------------------------------------------------------------- /src/eclj/interpret/meta.eclj: -------------------------------------------------------------------------------- 1 | (ns eclj.interpret.meta 2 | (:refer-clojure :exclude [eval defmulti defmethod]) 3 | (:require [eclj.common :refer (map->Syntax expansion?)] 4 | [eclj.parse :refer (parse)] 5 | [eclj.fn] 6 | [eclj.multi-fn :refer (defmulti defmethod)])) 7 | 8 | (def answer ^:eclj/answer 9 | (fn [x] {:op :answer :value x})) 10 | 11 | ;; Necessary because eclj.interpret.meta redefines answer symbolically. 12 | (defn tail-effect? [effect] 13 | (-> effect :k meta :eclj/answer)) 14 | 15 | ;;TODO: Need a symbolic multimethod! 16 | (defmulti eval-head :head) 17 | 18 | (defn eval [x env] 19 | ;(println "eval") 20 | ;(fipp.edn/pprint x) 21 | (eval-head (parse x env))) 22 | 23 | (defn eval-syntax [syntax] 24 | (eval (map->Syntax syntax) (:env syntax))) 25 | 26 | (defn kernel-handler [kernel] 27 | (fn [{:keys [op k] :as effect}] 28 | (println "kernel effect!" op (:sym effect)) 29 | ;(fipp.edn/pprint (dissoc effect :k)) 30 | ;(println "--") 31 | (if-let [f (get kernel op)] 32 | (do 33 | ;(fipp.edn/pprint effect) 34 | ;(when (#{:invoke} op) 35 | ; (println "meta kernel call") 36 | ; (fipp.edn/pprint (:f effect))) 37 | (continue k (f effect))) 38 | effect))) 39 | 40 | (defn eval-result [x env] 41 | (handle-with (kernel-handler (:kernel env)) 42 | (eval x env))) 43 | 44 | (defn lookup [{:keys [locals] :as env} sym] 45 | (if-let [[_ value] (find locals sym)] 46 | {:origin :locals :value value} 47 | (or (raise {:op :resolve :env env :sym sym}) 48 | (signal {:error :undefined :sym sym})))) 49 | 50 | (defmethod eval-head :constant 51 | [{:keys [value]}] 52 | value) 53 | 54 | (defn eval-items [coll env] 55 | (into (empty coll) (map #(eval % env) coll))) 56 | 57 | (defmethod eval-head :collection 58 | [{:keys [coll env]}] 59 | (eval-items coll env)) 60 | 61 | (defn macro? [{:keys [origin value]}] 62 | (and (= origin :namespace) (-> value meta :macro))) 63 | 64 | (defmethod eval-head :name 65 | [{:keys [sym env]}] 66 | (let [{:keys [origin value] :as resolved} (lookup env sym)] 67 | (cond 68 | (macro? resolved) (signal {:error :value-of-macro :name sym}) 69 | (expansion? value) (eval (:expr value) env) 70 | :else (case origin 71 | :locals value 72 | :host value 73 | :namespace (raise {:op :deref :ref value}))))) 74 | 75 | (defmethod eval-head :if 76 | [{:keys [test then else env]}] 77 | (eval (if (eval test env) then else) env)) 78 | 79 | (defmethod eval-head :var 80 | [{:keys [sym env]}] 81 | (let [{:keys [origin value]} (raise {:op :resolve :env env :sym sym})] 82 | (assert (= origin :namespace)) 83 | value)) 84 | 85 | (defmethod eval-head :do 86 | [{:keys [statements ret env]}] 87 | (doseq [statement statements] 88 | (eval statement env)) 89 | (eval ret env)) 90 | 91 | (defmethod eval-head :bind 92 | [{:keys [name value expr env]}] 93 | (eval expr (assoc-in env [:locals name] value))) 94 | 95 | (defmethod eval-head :let 96 | [{:keys [bindings expr env]}] 97 | (if-let [[{:keys [name init]} & bindings*] (seq bindings)] 98 | (let [value (eval init env)] 99 | (eval-syntax {:head :let :env (assoc-in env [:locals name] value) 100 | :bindings (vec bindings*) :expr expr})) 101 | (eval expr env))) 102 | 103 | (defmethod eval-head :letfn 104 | [{:keys [bindings expr env]}] 105 | (eval expr (update-in env [:locals] merge bindings))) 106 | 107 | (defn exception-handler [catches default finally env] 108 | (fn handler [{:keys [op] :as effect}] 109 | (case op 110 | :answer (do (eval finally env) nil) 111 | :throw (let [error (:error effect) 112 | catch (some (fn [{:keys [class sym expr] :as catch}] 113 | (when (instance? class error) catch)) 114 | catches)] 115 | (when-let [{:keys [name expr]} (or catch default)] 116 | (let [ret (eval-syntax {:head :bind :env env 117 | :name name :value error :expr expr})] 118 | (eval finally env) 119 | (answer ret)))) 120 | nil))) 121 | 122 | (defmethod eval-head :try 123 | [{:keys [try catches default finally env]}] 124 | ;;TODO: Ensure items are exception classes. 125 | (let [classes (eval-items (mapv :type catches) env) 126 | catches* (map #(assoc %1 :class %2) catches classes) 127 | handler (exception-handler catches* default finally env)] 128 | (handle-with handler (eval try env)))) 129 | 130 | (defmethod eval-head :handle-with 131 | [{:keys [handler expr env]}] 132 | (handle-with (eval handler env) (eval expr env))) 133 | 134 | (defmethod eval-head :raise 135 | [{:keys [expr env]}] 136 | (raise (eval expr env))) 137 | 138 | (defn apply-args [f args env] 139 | (let [values (eval-items (reverse args) env)] 140 | (apply f values))) 141 | 142 | (defmethod eval-head :invoke 143 | [{:keys [f args env form] :as ast}] 144 | (if (symbol? f) 145 | (let [{:keys [value] :as resolved} (lookup env f)] 146 | (cond 147 | (macro? resolved) (eval-syntax {:head :expand :macro value 148 | :form form :env env}) 149 | (expansion? value) (eval-syntax (assoc ast :f (:expr value))) 150 | :else (apply-args value args env))) 151 | (apply-args (eval f env) args env))) 152 | 153 | ;;TODO: Replace expand special with -apply on a macro type. 154 | (defmethod eval-head :expand 155 | [{:keys [macro form env]}] 156 | (let [expanded (apply macro (list* form env (next form)))] 157 | (eval expanded env))) 158 | 159 | (defmethod eval-head :new 160 | [{:keys [class args env]}] 161 | (let [class* (eval class env) 162 | args* (eval-items args env)] 163 | (raise {:op :new :class class* :args args*}))) 164 | 165 | (defmethod eval-head :interop 166 | [{:keys [target member args env]}] 167 | (let [resolved (when (symbol? target) (lookup env target)) 168 | [static? object] (if (and resolved (= (:origin resolved) :host)) 169 | [true (:value resolved)] 170 | [false (eval target env)]) 171 | args* (eval-items (vec args) env)] 172 | (raise {:op :interop :static? static? 173 | :object object :member member :args args*}))) 174 | 175 | (defn eval-meta [x env] 176 | (with-meta x (eval (meta x) env))) 177 | 178 | (defmethod eval-head :declare 179 | [{:keys [sym env]}] 180 | (let [sym* (eval-meta sym env)] 181 | (raise {:op :declare :sym sym*}))) 182 | 183 | (defmethod eval-head :define 184 | [{:keys [sym expr env]}] 185 | (let [value (eval expr env) 186 | sym* (eval-meta sym env)] 187 | (raise {:op :define :sym sym* :value value}))) 188 | 189 | (defmethod eval-head :assign-var 190 | [{:keys [name expr env]}] 191 | (let [{:keys [origin] loc :value} (lookup env name)] 192 | (if (= origin :namespace) 193 | (let [value (eval expr env)] 194 | (raise {:op :assign-var :var loc :value value})) 195 | (signal {:error :not-assignable :location loc})))) 196 | 197 | (defmethod eval-head :assign-field 198 | [{:keys [object field expr env]}] 199 | (let [instance (eval object env) 200 | value (eval expr env)] 201 | (raise {:op :assign-field :object instance :field field :value value}))) 202 | 203 | (defmethod eval-head :loop 204 | [{:keys [bindings expr env]}] 205 | (let [syms (vec (take-nth 2 bindings)) 206 | inits (vec (take-nth 2 (next bindings))) 207 | values (eval-items inits env)] 208 | ;;TODO: Generate AST directly instead of syntax forms. 209 | (eval `((fn ~syms ~expr) ~@(map #(list 'quote %) values)) env))) 210 | 211 | (defmethod eval-head :recur 212 | [{:keys [args env]}] 213 | (let [args (eval-items args env)] 214 | (raise {:op :recur :args args}))) 215 | 216 | (defmethod eval-head :import 217 | [{:keys [sym]}] 218 | (raise {:op :import :sym sym})) 219 | 220 | (defmethod eval-head :case 221 | [{:keys [expr cases default env]}] 222 | (let [value (eval expr env) 223 | body (if-let [[_ match] (find cases value)] match default)] 224 | (eval body env))) 225 | 226 | (defmethod eval-head :meta 227 | [{:keys [expr meta env]}] 228 | (with-meta (eval expr env) (eval meta env))) 229 | -------------------------------------------------------------------------------- /src/eclj/method_cache.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.method-cache) 2 | 3 | (defn super-chain [^Class c] 4 | (if (.isArray c) ;XXX EClj extension 5 | (let [^Class ctype (.getComponentType c)] 6 | (if (identical? ctype java.lang.Object) ;TODO consider (.isPrimitive ctype) 7 | [c java.lang.Object] 8 | [c #=(java.lang.Class/forName "[Ljava.lang.Object;") java.lang.Object])) 9 | ((fn rec [^Class c] 10 | (when c 11 | (cons c (rec (.getSuperclass c))))) 12 | c))) 13 | 14 | (defn pref 15 | ([] nil) 16 | ([a] a) 17 | ([^Class a ^Class b] 18 | (if (.isAssignableFrom a b) b a))) 19 | 20 | (defn find-impl [protocol x] 21 | (if (instance? (:on-interface protocol) x) 22 | x 23 | (let [c (class x) 24 | impl #(get (:impls protocol) %)] 25 | (or (impl c) 26 | (and c (or (first (remove nil? (map impl (butlast (super-chain c))))) 27 | (when-let [t (reduce pref (filter impl (disj (supers c) Object)))] 28 | (impl t)) 29 | (impl Object))))))) 30 | 31 | (defn find-method [protocol methodk x] 32 | (get (find-impl protocol x) methodk)) 33 | 34 | (defn cache-method [cache x ^Class cls ^clojure.lang.IFn interf] 35 | (let [che @cache 36 | f (if (.isInstance cls x) 37 | interf 38 | (find-method (.protocol che) (.methodk che) x))] 39 | (when-not f 40 | (throw (IllegalArgumentException. (str "No implementation of method: " (.methodk che) 41 | " of protocol: " (:var (.protocol che)) 42 | " found for class: " (if (nil? x) "nil" (.getName (class x))))))) 43 | (swap! cache #'clojure.core/expand-method-impl-cache (class x) f) 44 | f)) 45 | -------------------------------------------------------------------------------- /src/eclj/multi_fn.eclj: -------------------------------------------------------------------------------- 1 | (ns eclj.multi-fn 2 | (:refer-clojure :exclude [defmulti defmethod])) 3 | 4 | ;;;XXX This is a placeholder implementation. 5 | 6 | (defmacro defmulti [name dispatch-fn] 7 | (let [table (atom {})] 8 | `(def ~name (with-meta 9 | (let [f# ~dispatch-fn] 10 | (fn [& args#] 11 | (apply (@~table (apply f# args#)) args#))) 12 | {::table ~table})))) 13 | 14 | (defmacro defmethod [name dispatch-val & fn-tail] 15 | `(swap! (-> ~name meta ::table) assoc ~dispatch-val (fn ~@fn-tail))) 16 | -------------------------------------------------------------------------------- /src/eclj/ns.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.ns 2 | (:refer-clojure :exclude [load]) 3 | (:require #_[eclj.core] ; eclj.core/eval provided during boot 4 | [eclj.env :as env] 5 | [eclj.reader :as reader]) 6 | (:import [clojure.lang Compiler RT])) 7 | 8 | ;;XXX This function (especially :eclj/alias) is a dirty hack. 9 | (defn publish-vars [ns & {:keys [exclude]}] 10 | (doseq [[sym var] (ns-publics ns) 11 | :when (not (exclude sym))] 12 | (let [metadata (assoc (meta var) :eclj/alias var)] 13 | (intern *ns* (with-meta sym metadata) @var)))) 14 | 15 | (defn parse [[_ sym & body :as form]] 16 | (let [doc (when (string? (first body)) (first body)) 17 | refs (if doc (next body) body) 18 | sym (if doc (vary-meta sym assoc :doc doc) sym) 19 | metadata (when (map? (first refs)) (first refs)) 20 | refs (if metadata (next refs) refs) 21 | gencls (first (filter #(= :gen-class (first %)) refs)) 22 | refclj (first (filter #(= :refer-clojure (first %)) refs)) 23 | stmts (if refclj [] ['(eclj.core/refer-clojure)]) 24 | stmts (into stmts 25 | (for [[f & args] refs 26 | :when (not (= :gen-class f))] 27 | `(~(symbol "eclj.core" (name f)) 28 | ~@(map #(list 'quote %) args)))) 29 | sym (if metadata (vary-meta sym merge metadata) sym)] 30 | {:name sym 31 | :meta (meta sym) 32 | :statements stmts 33 | :gen-class gencls})) 34 | 35 | 36 | ;;;; Adapted from clojure.core below here. 37 | 38 | (defn throw-if 39 | "Throws a CompilerException with a message if pred is true" 40 | [pred fmt & args] 41 | (when pred 42 | (let [^String message (apply format fmt args) 43 | exception (Exception. message) 44 | raw-trace (.getStackTrace exception) 45 | boring? #(not= (.getMethodName ^StackTraceElement %) "doInvoke") 46 | trace (into-array (drop 2 (drop-while boring? raw-trace)))] 47 | (.setStackTrace exception trace) 48 | (throw (clojure.lang.Compiler$CompilerException. 49 | *file* 50 | (.deref clojure.lang.Compiler/LINE) 51 | (.deref clojure.lang.Compiler/COLUMN) 52 | exception))))) 53 | 54 | (defn libspec? 55 | "Returns true if x is a libspec" 56 | [x] 57 | (or (symbol? x) 58 | (and (vector? x) 59 | (or 60 | (nil? (second x)) 61 | (keyword? (second x)))))) 62 | 63 | (defn prependss 64 | "Prepends a symbol or a seq to coll" 65 | [x coll] 66 | (if (symbol? x) 67 | (cons x coll) 68 | (concat x coll))) 69 | 70 | (defn root-resource 71 | "Returns the root directory path for a lib" 72 | {:tag String} 73 | [lib] 74 | (str \/ 75 | (.. (name lib) 76 | (replace \- \_) 77 | (replace \. \/)))) 78 | 79 | (defn root-directory 80 | "Returns the root resource path for a lib" 81 | [lib] 82 | (let [d (root-resource lib)] 83 | (subs d 0 (.lastIndexOf d "/")))) 84 | 85 | (defn ensure-core [] 86 | (when-not (find-ns 'eclj.core) 87 | (clojure.core/require 'eclj.core))) 88 | 89 | (defn load-eclj-stream [stream path] 90 | (ensure-core) 91 | (with-bindings {Compiler/LOADER (RT/makeClassLoader)} 92 | (with-open [stream stream] 93 | (last (map eclj.core/eval (reader/form-seq stream path)))))) 94 | 95 | (defn load-eclj [name] 96 | (if-let [stream (RT/resourceAsStream (RT/baseLoader) name)] 97 | (let [path (.getPath (RT/getResource (RT/baseLoader) name))] 98 | (load-eclj-stream stream path)) 99 | (throw (Exception. 100 | (str "Could not locate EClj resource on classpath: " name))))) 101 | 102 | (defn load* [scriptbase] 103 | (let [classfile (str scriptbase RT/LOADER_SUFFIX ".class") 104 | srcs (map #(str scriptbase "." %) ["clj" "eclj"]) 105 | class-url (RT/getResource (RT/baseLoader) classfile) 106 | src-urls (remove nil? (map #(RT/getResource (RT/baseLoader) %) srcs))] 107 | (when (> (count src-urls) 1) 108 | (throw (Exception. (str scriptbase " is ambiguous: " 109 | (mapv #(.getPath %) src-urls))))) 110 | (let [url (first src-urls)] 111 | (cond 112 | (and class-url (or (not url) 113 | (> (RT/lastModified class-url classfile) 114 | (RT/lastModified url (.getPath url))))) 115 | (RT/load scriptbase) 116 | (not url) 117 | (throw (ex-info "Could not locate class or source file on classpath." 118 | {:files (into [classfile] srcs)})) 119 | (.endsWith (.getPath url) ".eclj") 120 | (load-eclj (str scriptbase ".eclj")) 121 | :else (RT/load scriptbase))))) 122 | 123 | (defn check-cyclic-dependency 124 | "Detects and rejects non-trivial cyclic load dependencies. The 125 | exception message shows the dependency chain with the cycle 126 | highlighted. Ignores the trivial case of a file attempting to load 127 | itself because that can occur when a gen-class'd class loads its 128 | implementation." 129 | [path] 130 | (when (some #{path} (rest @#'clojure.core/*pending-paths*)) 131 | (let [pending (map #(if (= % path) (str "[ " % " ]") %) 132 | (cons path @#'clojure.core/*pending-paths*)) 133 | chain (apply str (interpose "->" pending))] 134 | (throw-if true "Cyclic load dependency: %s" chain)))) 135 | 136 | (defn load [path] 137 | (let [^String path (if (.startsWith path "/") 138 | path 139 | (str (root-directory (ns-name *ns*)) \/ path))] 140 | (when @#'clojure.core/*loading-verbosely* 141 | (printf "(eclj.core/load \"%s\")\n" path) 142 | (flush)) 143 | (check-cyclic-dependency path) 144 | (when-not (= path (first @#'clojure.core/*pending-paths*)) 145 | (binding [*ns* *ns* ; Because in-ns will set! this. 146 | clojure.core/*pending-paths* 147 | (conj @#'clojure.core/*pending-paths* path)] 148 | (load* (.substring path 1)))))) 149 | 150 | (defn load-one 151 | "Loads a lib given its name. If need-ns, ensures that the associated 152 | namespace exists after loading. If require, records the load so any 153 | duplicate loads can be skipped." 154 | [lib need-ns require] 155 | (load (root-resource lib)) 156 | (throw-if (and need-ns (not (find-ns lib))) 157 | "namespace '%s' not found after loading '%s'" 158 | lib (root-resource lib)) 159 | (when require 160 | (dosync 161 | (commute @#'clojure.core/*loaded-libs* conj lib)))) 162 | 163 | (defn load-all 164 | "Loads a lib given its name and forces a load of any libs it directly or 165 | indirectly loads. If need-ns, ensures that the associated namespace 166 | exists after loading. If require, records the load so any duplicate loads 167 | can be skipped." 168 | [lib need-ns require] 169 | (dosync 170 | (commute @#'clojure.core/*loaded-libs* #(reduce conj %1 %2) 171 | (binding [clojure.core/*loaded-libs* (ref (sorted-set))] 172 | (load-one lib need-ns require) 173 | @#'clojure.core/*loaded-libs*)))) 174 | 175 | (defn load-lib 176 | "Loads a lib with options" 177 | [prefix lib & options] 178 | (throw-if (and prefix (pos? (.indexOf (name lib) (int \.)))) 179 | "Found lib name '%s' containing period with prefix '%s'. lib names inside prefix lists must not contain periods" 180 | (name lib) prefix) 181 | (let [lib (if prefix (symbol (str prefix \. lib)) lib) 182 | opts (apply hash-map options) 183 | {:keys [as reload reload-all require use verbose]} opts 184 | loaded (contains? @@#'clojure.core/*loaded-libs* lib) 185 | load (cond reload-all 186 | load-all 187 | (or reload (not require) (not loaded)) 188 | load-one) 189 | need-ns (or as use) 190 | filter-opts (select-keys opts '(:exclude :only :rename :refer)) 191 | undefined-on-entry (not (find-ns lib))] 192 | (binding [clojure.core/*loading-verbosely* (or @#'clojure.core/*loading-verbosely* verbose)] 193 | (if load 194 | (try 195 | (load lib need-ns require) 196 | (catch Exception e 197 | (when undefined-on-entry 198 | (remove-ns lib)) 199 | (throw e))) 200 | (throw-if (and need-ns (not (find-ns lib))) 201 | "namespace '%s' not found" lib)) 202 | (when (and need-ns @#'clojure.core/*loading-verbosely*) 203 | (printf "(eclj.core/in-ns '%s)\n" (ns-name *ns*))) 204 | (when as 205 | (when @#'clojure.core/*loading-verbosely* 206 | (printf "(eclj.core/alias '%s '%s)\n" as lib)) 207 | (alias as lib)) 208 | (when (or use (:refer filter-opts)) 209 | (when @#'clojure.core/*loading-verbosely* 210 | (printf "(eclj.core/refer '%s" lib) 211 | (doseq [opt filter-opts] 212 | (printf " %s '%s" (key opt) (print-str (val opt)))) 213 | (printf ")\n")) 214 | (apply refer lib (mapcat seq filter-opts)))))) 215 | 216 | (defn load-libs 217 | "Loads libs, interpreting libspecs, prefix lists, and flags for 218 | forwarding to load-lib" 219 | [& args] 220 | (let [flags (filter keyword? args) 221 | opts (interleave flags (repeat true)) 222 | args (filter (complement keyword?) args)] 223 | ; check for unsupported options 224 | (let [supported #{:as :reload :reload-all :require :use :verbose :refer} 225 | unsupported (seq (remove supported flags))] 226 | (throw-if unsupported 227 | (apply str "Unsupported option(s) supplied: " 228 | (interpose \, unsupported)))) 229 | ; check a load target was specified 230 | (throw-if (not (seq args)) "Nothing specified to load") 231 | (doseq [arg args] 232 | (if (libspec? arg) 233 | (apply load-lib nil (prependss arg opts)) 234 | (let [[prefix & args] arg] 235 | (throw-if (nil? prefix) "prefix cannot be nil") 236 | (doseq [arg args] 237 | (apply load-lib prefix (prependss arg opts)))))))) 238 | -------------------------------------------------------------------------------- /src/eclj/parse.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.parse 2 | (:require [eclj.common :refer (pure map->Syntax)] 3 | [eclj.fn :refer (map->Fn)])) 4 | 5 | ;TODO: namespaced symbols can't be shadowed; hence eclj.env/patches 6 | ;TODO: validation conditions. 7 | ; ie raise error for (var inc inc), (quote x x), odd number bindings, etc 8 | 9 | (defprotocol Expression 10 | (-parse [expr env])) 11 | 12 | (defn parse [form env] 13 | (pure (map->Syntax (-parse form env)))) 14 | 15 | (defn parse-meta [{:keys [form env] :as syntax}] 16 | (if-let [metadata (meta form)] 17 | {:head :meta :expr (map->Syntax syntax) :meta metadata :env env} 18 | syntax)) 19 | 20 | (defn parse-constant [x env] 21 | {:head :constant :form x :env env :value x}) 22 | 23 | (defn parse-collection [coll env] 24 | (parse-meta {:head :collection :form coll :env env :coll coll})) 25 | 26 | (doseq [t [nil java.lang.Object]] 27 | (extend t Expression {:-parse parse-constant})) 28 | 29 | (defmulti parse-seq (fn [xs env] (first xs))) 30 | 31 | (defn parse-invoke [[f & args :as form] env] 32 | {:head :invoke :form form :env env :f f :args args}) 33 | 34 | (extend-protocol Expression 35 | 36 | eclj.common.Syntax 37 | (-parse [this env] this) 38 | 39 | clojure.lang.Symbol 40 | (-parse [sym env] 41 | {:head :name :form sym :env env :sym sym}) 42 | 43 | clojure.lang.ISeq 44 | (-parse [xs env] 45 | (cond 46 | (empty? xs) (parse-meta (parse-constant xs env)) 47 | (symbol? (first xs)) (parse-seq xs env) 48 | :else (parse-invoke xs env))) 49 | 50 | clojure.lang.AMapEntry 51 | (-parse [kvp env] 52 | (parse-collection (vec kvp) env)) 53 | 54 | ) 55 | 56 | (doseq [t [clojure.lang.PersistentArrayMap 57 | clojure.lang.PersistentHashMap 58 | clojure.lang.PersistentHashSet 59 | clojure.lang.PersistentQueue 60 | clojure.lang.PersistentTreeMap 61 | clojure.lang.PersistentTreeSet 62 | clojure.lang.PersistentVector]] 63 | (extend t Expression {:-parse parse-collection})) 64 | 65 | (defn expand-dot [[head & tail :as form] env] 66 | (let [s (str head)] 67 | (cond 68 | (= s "..") nil ;XXX Special cases the `..` macro, but could be others. 69 | (.endsWith s ".") (let [class (symbol (apply str (butlast s)))] 70 | {:head :new :form form :env env 71 | :class class :args (vec tail)}) 72 | (.startsWith s ".") (let [member (symbol (apply str (next s))) 73 | [obj & args] tail] 74 | {:head :interop :form form :env env 75 | :target obj :member member :args (vec args)})))) 76 | 77 | (defmethod parse-seq :default 78 | [form env] 79 | (or (and (symbol? (first form)) (expand-dot form env)) 80 | {:head :invoke :form form :env env 81 | :f (first form) :args (vec (rest form))})) 82 | 83 | (defmethod parse-seq 'if 84 | [[_ test then else :as form] env] 85 | {:head :if :form form :env env 86 | :test test :then then :else else}) 87 | 88 | (defmethod parse-seq 'var 89 | [[_ sym :as form] env] 90 | {:head :var :form form :env env :sym sym}) 91 | 92 | (defmethod parse-seq 'do 93 | [[_ & body :as form] env] 94 | (if (seq body) 95 | (let [v (vec body)] 96 | {:head :do :form form :env env 97 | :statements (pop v) :ret (peek v)}) 98 | {:head :constant :form form :env env :value nil})) 99 | 100 | (defmethod parse-seq 'quote 101 | [[_ value :as form] env] 102 | {:head :constant :form form :env env :value value}) 103 | 104 | (defn implicit-do [body] 105 | (case (count (take 2 body)) 106 | 0 nil 107 | 1 (first body) 108 | (list* 'do body))) 109 | 110 | (defmethod parse-seq 'let* 111 | [[_ bindings & body :as form] env] 112 | {:head :let :form form :env env 113 | :bindings (mapv (fn [[name init]] 114 | (when (namespace name) 115 | (throw (Exception. (str "Can't let qualified name: " name)))) 116 | {:name name :init init}) 117 | (partition 2 bindings)) 118 | :expr (implicit-do body)}) 119 | 120 | (defn parse-method [params body] 121 | ;;TODO: validate signature. 122 | (let [[fixed [_ varargs]] (split-with (complement '#{&}) params)] 123 | [(if varargs :more (count fixed)) 124 | {:fixed-arity (count fixed) 125 | :variadic? (boolean varargs) 126 | :params params 127 | :expr (implicit-do body)}])) 128 | 129 | (defn parse-fn [[_ & fn-tail] env] 130 | ;;TODO: validate methods. 131 | (let [[name impl] (if (symbol? (first fn-tail)) 132 | [(first fn-tail) (next fn-tail)] 133 | [nil fn-tail]) 134 | methods (for [[sig & body] (if (vector? (first impl)) 135 | (list impl) 136 | impl)] 137 | (parse-method sig body)) 138 | arities (into {} methods)] 139 | (map->Fn {:name name :env env 140 | :arities arities 141 | :max-fixed-arity (apply max (for [[_ m] arities] 142 | (:fixed-arity m)))}))) 143 | 144 | (defmethod parse-seq 'fn* 145 | [form env] 146 | (parse-meta {:head :constant :form form :env env 147 | :value (parse-fn form env)})) 148 | 149 | (defmethod parse-seq 'letfn* 150 | [[_ bindings & body :as form] env] 151 | {:head :letfn :form form :env env 152 | :bindings (->> (next bindings) 153 | (take-nth 2) 154 | (map (comp (juxt :name identity) #(parse-fn % env))) 155 | vec) 156 | :expr (implicit-do body)}) 157 | 158 | (defmethod parse-seq 'try 159 | [[_ & body :as form] env] 160 | (let [catch? (every-pred seq? #(= (first %) 'catch)) 161 | default? (every-pred catch? #(= (second %) :default)) 162 | finally? (every-pred seq? #(= (first %) 'finally))] 163 | (loop [{:keys [state forms body] :as parser} 164 | {:state :start :forms body :body [] 165 | :catches [] :default nil :finally nil}] 166 | (if-let [[form & forms*] forms] 167 | (let [parser* (assoc parser :forms forms*)] 168 | (case state 169 | :start 170 | (cond 171 | (catch? form) (recur (assoc parser :state :catches)) 172 | (finally? form) (recur (assoc parser :state :finally)) 173 | :else (recur (update-in parser* [:body] conj form))) 174 | :catches 175 | (cond 176 | (default? form) 177 | (let [[_ _ name & dbody] form 178 | default {:name name :expr (implicit-do dbody)}] 179 | (recur (assoc parser* :default default :state :finally))) 180 | (catch? form) 181 | (let [[_ type name & cbody] form 182 | catch {:type type :name name 183 | :expr (implicit-do cbody)}] 184 | (recur (update-in parser* [:catches] conj catch))) 185 | (finally? form) 186 | (recur (assoc parser :state :finally)) 187 | :else 188 | (throw (Exception. "Invalid try form"))) 189 | :finally 190 | (let [[_ & fbody] form 191 | finally (implicit-do fbody)] 192 | (recur (assoc parser* :finally finally :state :done))) 193 | :done 194 | (throw (Exception. "Unexpected form after finally")))) 195 | (-> parser 196 | (select-keys [:catches :default :finally]) 197 | (assoc :head :try :form form :env env 198 | :try (-> parser :body implicit-do))))))) 199 | 200 | (defmethod parse-seq 'throw 201 | [[_ expr :as form] env] 202 | {:head :raise :form form :env env 203 | :expr {:op :throw :error expr}}) 204 | 205 | (defmethod parse-seq 'def 206 | [[_ & body :as form] env] 207 | (let [[sym doc expr] (case (count body) 208 | 1 [(first body)] 209 | 2 [(first body) nil (second body)] 210 | 3 body) 211 | doc (or doc (-> sym meta :doc)) 212 | sym (vary-meta sym assoc :doc doc)] 213 | (merge 214 | {:sym sym :form form :env env} 215 | (if (> (count body) 1) 216 | {:head :define :expr expr} 217 | {:head :declare})))) 218 | 219 | (defmethod parse-seq 'new 220 | [[_ class & args :as form] env] 221 | {:head :new :form form :env env :class class :args (vec args)}) 222 | 223 | (defmethod parse-seq '. 224 | [[_ target & body :as form] env] 225 | (let [[member args] (if (and (= (count body) 1) (seq? (first body))) 226 | [(ffirst body) (nfirst body)] 227 | [(first body) (next body)]) 228 | ;; syntax-quote may non-sensically qualify member symbols. 229 | member (symbol (name member))] 230 | {:head :interop :form form :env env 231 | :target target :member member :args (vec args)})) 232 | 233 | (defmethod parse-seq 'set! 234 | [[_ location expr :as form] env] 235 | ;;TODO just :head :assign 236 | (if (symbol? location) 237 | {:head :assign-var :form form :env env 238 | :name location :expr expr} 239 | (let [[field object] location] 240 | ;;TODO: Validate location. 241 | {:head :assign-field :form form :env env 242 | :object object 243 | :field (symbol (apply str (next (str field)))) 244 | :expr expr}))) 245 | 246 | (defmethod parse-seq 'loop* 247 | [[_ bindings & body :as form] env] 248 | {:head :loop :form form :env env 249 | :bindings bindings :expr (implicit-do body)}) 250 | 251 | (defmethod parse-seq 'recur 252 | [[_ & args :as form] env] 253 | {:head :recur :form form :env env :args (vec args)}) 254 | 255 | (defmethod parse-seq 'clojure.core/import* 256 | [[_ sym :as form] env] 257 | {:head :import :form form :env env :sym sym}) 258 | 259 | (defmethod parse-seq 'eclj.core/case* 260 | [[_ expr cases default :as form] env] 261 | {:head :case :form form :env env 262 | :expr expr :cases cases :default default}) 263 | 264 | ;;TODO: Provide a single vau-like primitive for eclj extensions. 265 | 266 | (defmethod parse-seq 'eclj.core/raise 267 | [[_ expr :as form] env] 268 | {:head :raise :form form :env env :expr expr}) 269 | 270 | (defmethod parse-seq 'eclj.core/eval-effect 271 | [[_ expr env-expr :as form] env] 272 | {:head :eval-effect :expr expr :env-expr env-expr :fom form :env env}) 273 | 274 | (defmethod parse-seq 'reify* 275 | [[_ interfaces & methods :as form] env] 276 | {:head :reify :form form :env env 277 | :interfaces interfaces :methods methods}) 278 | 279 | ;;XXX This naive parsing assumes no deftype options & only internal usage. 280 | (defmethod parse-seq 'deftype* 281 | [[_ tagname classname fields _ implements & methods :as form] env] 282 | {:head :deftype :form form :env env :tagname tagname :classname classname 283 | :fields fields :implements implements :methods methods}) 284 | -------------------------------------------------------------------------------- /src/eclj/reader.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.reader 2 | (:require [clojure.tools.reader :as reader] 3 | [clojure.tools.reader.reader-types :refer 4 | (input-stream-push-back-reader indexing-push-back-reader)])) 5 | 6 | ;;;TODO: Override evaulator for *read-eval*, etc. 7 | 8 | (defn form-seq [stream path] 9 | (let [eof (Object.) 10 | rdr (-> (input-stream-push-back-reader stream) 11 | (indexing-push-back-reader 1 path))] 12 | ((fn rec [] 13 | (lazy-seq 14 | (let [form (reader/read rdr false eof)] 15 | (when-not (identical? eof form) 16 | (cons form (rec))))))))) 17 | -------------------------------------------------------------------------------- /test/eclj/eval_test.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.eval-test 2 | (:refer-clojure :exclude [eval]) 3 | (:use [clojure.test]) 4 | (:require [eclj.core])) 5 | 6 | (defmethod assert-expr `=clj [msg [_ form]] 7 | `(let [expected# (clojure.core/eval ~form) 8 | actual# (eclj.core/eval ~form)] 9 | (do-report {:type (if (= expected# actual#) :pass :fail) 10 | :message ~msg :expected expected# :actual actual#}) 11 | actual#)) 12 | 13 | (defmacro =clj [expr] 14 | `(is (=clj ~expr))) 15 | 16 | (defmethod assert-expr `throws [msg [_ pred expr]] 17 | (let [check `(~pred (ex-data ~'e))] 18 | `(try 19 | (eclj.core/eval ~expr) 20 | (do-report {:type :fail :message ~msg :expected '~check :actual nil}) 21 | (catch Throwable ~'e 22 | (do-report {:type (if ~check :pass :fail) 23 | :message ~msg :expected '~check :actual ~'e}) 24 | ~'e)))) 25 | 26 | (defmacro throws [pred expr] 27 | `(is (throws ~pred ~expr))) 28 | 29 | (defmacro expect [pred expr] 30 | `(is (~pred (eclj.core/eval ~expr)))) 31 | 32 | (deftest eval-test 33 | 34 | (=clj 5) 35 | (=clj true) 36 | (=clj "str") 37 | 38 | (=clj 'inc) 39 | (=clj #'inc) 40 | (=clj '#'inc) 41 | (=clj '(identity inc)) 42 | (=clj '(#'identity #'inc)) 43 | (=clj 'Boolean) 44 | (throws #(= (-> % :eclj/effect :error) :undefined) 'something-undefined) 45 | 46 | (=clj ()) 47 | 48 | (=clj '(if true 5 10)) 49 | (=clj '(if false 5 10)) 50 | (=clj '(if true 5)) 51 | (=clj '(if false 5)) 52 | (throws #(= (-> % :eclj/effect :error) :undefined) '(if xx 5)) 53 | 54 | (=clj '(- 10 3)) 55 | (=clj '((identity -) 10 3)) 56 | (=clj '(+ (inc 5) (inc 10))) 57 | (=clj '(#'* (inc 4) 2)) 58 | (=clj '(#'identity "hello")) 59 | 60 | (=clj '[1 "two" inc (+ 5 10)]) 61 | (=clj '{1 "two" inc (+ 5 10)}) 62 | (=clj '#{1"two" inc (+ 5 10)}) 63 | 64 | (=clj '(do)) 65 | (=clj '(do :x)) 66 | (=clj '(do :x :y)) 67 | (=clj ''(with-out-str (do (prn :x) (prn :y)))) 68 | (=clj '(with-out-str (do (prn :x) (prn :y) (prn :z)))) 69 | 70 | (=clj '(-> 8 inc (- 3))) 71 | 72 | (=clj '(let [] 1)) 73 | (=clj '(let [x 2] x)) 74 | (=clj '(let [x 2 y 4] (+ x y))) 75 | (=clj '(let [x 2 y 4 z 6] (+ x y z))) 76 | 77 | (=clj ''x) 78 | 79 | (=clj '((fn [] 1))) 80 | (=clj '((fn [x] x) 5)) 81 | ;XXX (=clj '(eclj.core/apply (fn [& args] (eclj.core/apply + args)) (range 1000))) 82 | (=clj '(clojure.core/apply (fn [x] x) 'a [])) 83 | (=clj '(eclj.core/apply (fn [x] x) 'a [])) 84 | 85 | (expect fn? '(fn [])) 86 | (expect fn? '(fn [x] x)) 87 | (expect fn? '(fn ([x] x))) 88 | (expect fn? '(fn f [x] x)) 89 | (expect fn? '(fn f ([x] x))) 90 | (expect fn? '(fn ([] 0) ([x] 1) ([x y] 2))) 91 | (expect fn? '(fn ([] 0) ([x] 1) ([x y] 2) ([x y & zs] :n))) 92 | 93 | (is (= 5 ((eclj.core/eval '(fn [x] x)) 5))) 94 | 95 | (expect (complement bound?) '(def declared)) 96 | (expect bound? '(def defined 1)) 97 | (expect #(= @% 3) '(do (def redefined 2) (def redefined 3))) 98 | (expect #(= @% 4) '(def foo "bar" 4)) 99 | (expect #(= (-> % meta :doc) "bar") '(def foo "bar" 4)) 100 | (=clj '(-> (defn asdf [a b c]) meta :arglists)) 101 | 102 | (=clj '(try 1)) 103 | (=clj '(try 1 (catch Throwable e 2))) 104 | (=clj '(with-out-str (try 1 (finally (prn 2))))) 105 | (throws (constantly true) '(throw (ex-info "err" {}))) 106 | (throws (constantly true) '(try (throw (ex-info "err" {})))) 107 | (throws (constantly true) 108 | '(try 1 (throw (ex-info "err" {})) 2 109 | (catch IllegalArgumentException e 2))) 110 | (is (= 3 (eclj.core/eval '(try (throw (ex-info "err" {})) 111 | (catch Exception e 3))))) 112 | (is (= 3 (eclj.core/eval '(try (throw (ex-info "err" {})) 113 | (catch :default e 3))))) 114 | (expect #(instance? Exception %) 115 | '(try (throw (ex-info "err" {})) 116 | (catch :default e e))) 117 | (expect #(= % "2") 118 | (with-out-str 119 | (eclj.core/eval '(try (throw (ex-info "err" {})) 120 | (catch :default e e) 121 | (finally (print 2)))))) 122 | (throws #(= (-> % :eclj/effect :error) :non-tail-position) 123 | '(loop [] (inc (recur)))) 124 | 125 | ;;TODO: FIXME 126 | #_(=clj '(try 127 | ;; The symbolic fn will be excuted by fnil's compiled fn. 128 | ((clojure.core/fnil #(throw %) (Exception. "!")) nil) 129 | (catch Exception e 130 | 123))) 131 | 132 | (=clj '(import [java.util Date Currency])) 133 | (throws (constantly true) '(var Class)) 134 | 135 | (=clj '(new String "abc")) 136 | (=clj '(String. "xyz")) 137 | 138 | (=clj '(. "abc" toUpperCase)) 139 | (=clj '(. "abc" (toUpperCase))) 140 | (=clj '(.toUpperCase "abc")) 141 | (=clj '(. "abc" startsWith "x")) 142 | (=clj '(. "abc" (startsWith "x"))) 143 | (=clj '(.startsWith "abc" "x")) 144 | 145 | (=clj 'Byte) 146 | (=clj '(. Byte TYPE)) 147 | (=clj '(. String valueOf true)) 148 | (=clj '(. String (valueOf true))) 149 | 150 | (=clj 'Byte/TYPE) 151 | (=clj '(identity Byte/TYPE)) 152 | (=clj '(String/valueOf true)) 153 | 154 | (=clj '(do (def ^:dynamic *foo* 1) 155 | (binding [*foo* 2] 156 | (set! *foo* 3) 157 | *foo*))) 158 | 159 | (=clj '((fn factorial [x] 160 | (if (<= x 1) 161 | 1 162 | (* x (factorial (- x 1))))) 163 | 5)) 164 | 165 | (=clj '(letfn [(even? [x] (or (zero? x) (odd? (dec x)))) 166 | (odd? [x] (and (not (zero? x)) (even? (dec x))))] 167 | ((juxt even? odd?) 11))) 168 | 169 | (=clj '((fn [acc n] 170 | (if (zero? n) 171 | acc 172 | (recur (+ acc n) (dec n)))) 173 | 0 10)) 174 | 175 | (=clj '(loop [acc 0, n 10] 176 | (if (zero? n) 177 | acc 178 | (recur (+ acc n) (dec n))))) 179 | 180 | (=clj '(with-out-str (doseq [a [:x :y :z]] (prn a)))) 181 | 182 | (=clj '(import 'java.util.Date)) 183 | 184 | (=clj '(case 5 185 | 5 :number)) 186 | 187 | (=clj '(case 5 188 | 5 :number 189 | :default)) 190 | 191 | (=clj '(case "str" 192 | 5 :number 193 | :default)) 194 | 195 | (=clj '(case [1 2 3] 196 | 5 :number 197 | [1 2 3] :vector)) 198 | 199 | (throws #(= (:error %) :no-matching-clause) 200 | '(case "str" 5 :number)) 201 | 202 | (comment 203 | 204 | (def eval eclj.core/eval) 205 | 206 | (eval '(.valueOf String true)) ;XXX Not expected to work 207 | 208 | (time 209 | (dotimes [i 200] 210 | (eval '((fn factorial [x] 211 | (if (<= x 1) 212 | 1 213 | (* x (factorial (- x 1))))) 214 | 20)))) 215 | 216 | (eval '(deftype Foo [bar])) 217 | (eval '(Foo. 1)) 218 | (eval '(defrecord Point [x y])) 219 | (eval '(Point. 5 10)) 220 | 221 | (eval (list 'set! (list '.__methodImplCache (fn [])) ; explicitly a host fn. 222 | (list 'clojure.lang.MethodImplCache. nil nil))) 223 | 224 | (eval '(defprotocol P)) 225 | (eval '(defprotocol P (f [this]))) 226 | (eval '(extend-protocol P Foo (f [this] :foo))) 227 | (eval '(f (Foo. 2))) 228 | (eval '(f (reify P (f [this] :reified)))) 229 | 230 | (eval 'foo.Bar) 231 | (eval '(import 'foo.Bar)) 232 | 233 | ) 234 | 235 | ) 236 | -------------------------------------------------------------------------------- /test/eclj/ext_test.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.ext-test 2 | (:refer-clojure :exclude [eval]) 3 | (:require [eclj.core])) 4 | 5 | ;;TODO: Assertions 6 | 7 | (comment 8 | 9 | (eclj.core/require 'eclj.ext :reload) 10 | 11 | (eclj.ext/eval 1) 12 | (eclj.ext/eval '(+ 2 4)) 13 | 14 | (eclj.ext/eval '(eclj.ext/handle-with 15 | (fn [effect] 16 | (when (= (:op effect) :answer) 17 | {:op :answer :value (inc (:value effect))})) 18 | 5)) 19 | 20 | (eclj.ext/eval '(eclj.ext/handle-with 21 | (fn [effect] 22 | (when (= (:op effect) :foo) 23 | {:op :answer :value :bar})) 24 | (eclj.ext/raise {:op :foo}))) 25 | 26 | (eclj.ext/eval 27 | '(eclj.ext/handle-with 28 | (fn [{:keys [op k] :as effect}] 29 | (println "outer") 30 | (fipp.edn/pprint effect) 31 | (println) 32 | nil) 33 | (eclj.ext/handle-with 34 | (fn [{:keys [op k] :as effect}] 35 | (println "inner") 36 | (fipp.edn/pprint effect) 37 | (println) 38 | (when (= op :foo) 39 | {:op :answer :value (eclj.ext/continue k 123)})) 40 | (println "innermost") 41 | (eclj.ext/raise {:op :foo})))) 42 | 43 | (eclj.ext/eval 44 | '(eclj.ext/handle-with 45 | (fn [{:keys [op k] :as effect}] 46 | (println "outer") 47 | (fipp.edn/pprint effect) 48 | (println) 49 | (when (= op :foo) 50 | {:op :answer :value (eclj.ext/continue k 123)})) 51 | (eclj.ext/handle-with 52 | (fn [{:keys [op k] :as effect}] 53 | (println "inner") 54 | (fipp.edn/pprint effect) 55 | (println) 56 | nil) 57 | (println "innermost") 58 | (eclj.ext/raise {:op :foo})))) 59 | 60 | ) 61 | -------------------------------------------------------------------------------- /test/eclj/parse_test.clj: -------------------------------------------------------------------------------- 1 | (ns eclj.parse-test 2 | (:require [eclj.env :refer (ns-env)] 3 | [eclj.parse :refer (parse)])) 4 | 5 | (defn ! [x] 6 | (-> (parse x (ns-env)) 7 | #_fipp.edn/pprint)) 8 | 9 | ;;TODO: assertions 10 | 11 | (! nil) 12 | (! 5) 13 | (! ()) 14 | (! '()) 15 | (! '(f x)) 16 | (! '(quote (f x))) 17 | (! '(let* [])) 18 | (! '(let* [x 1] x)) 19 | (! '(let* [x 1 y 2] (+ x y))) 20 | (! '(let* [x 1 y 2] (println "!") (+ x y))) 21 | (! '(do)) 22 | (! '(try)) 23 | (! '(try 1)) 24 | (! '(try 1 2)) 25 | (! '(try 1 (catch Exception e 2))) 26 | (! '(try 1 (catch Exception e 2 3))) 27 | (! '(try 1 (catch RuntimeException e 2) (catch Exception e 3))) 28 | (! '(try 1 (catch :default e 2))) 29 | (! '(try 1 (catch :default e 2 3))) 30 | (! '(try 1 (finally 2 3))) 31 | (! '(throw x)) 32 | (! '(def x)) 33 | (! '(def ^{:doc "foo"} x)) 34 | (! '(def x 1)) 35 | (! '(def x "foo" 1)) 36 | (! '(. x y z)) 37 | (! '(.x y z)) 38 | (! '(fn* [])) 39 | (! '(fn* [] 1)) 40 | (! '(fn* foo [] 1)) 41 | (! '(fn* foo [] (+ 2 4))) 42 | (! '(fn* foo [x] x)) 43 | (! '(fn* foo [x y & z] z)) 44 | (! '(fn* foo [x y & z] x y z)) 45 | (! '(fn* ([x] x) ([x y] y))) 46 | (! '(fn* foo ([x] x) ([x y] y))) 47 | (! '(fn* foo ([x] x) ([x y] y) ([x y & z] z))) 48 | (! '(set! x 1)) 49 | (! '(set! (.x y) 1)) 50 | (! '(letfn* [even? (clojure.core/fn even? [x] 51 | (or (zero? x) (odd? (dec x)))) 52 | odd? (clojure.core/fn odd? [x] 53 | (and (not (zero? x)) (even? (dec x))))] 54 | ((juxt even? odd?) 11))) 55 | (! '(eclj.core/case* :x {:x 1} 2)) 56 | --------------------------------------------------------------------------------