├── .gitignore ├── LICENSE ├── README.md ├── core.toc ├── core ├── analyzer.toc ├── ast-rewrite.toc ├── ast.toc ├── error.toc ├── file-io.toc ├── free ├── free.toc ├── grammar.toc ├── id.toc ├── logic-programming.toc ├── parser.toc ├── reader.toc ├── state-maybe.toc ├── state.toc └── stream.toc ├── counts ├── doc └── toccata-ebnf.txt ├── examples ├── diamond.toc ├── ebnf.toc ├── error.toc ├── fizzbuzz.toc ├── fn-comp.toc ├── free-tree.toc ├── full-ebnf.toc ├── hello.toc ├── list-comp.toc ├── listzipper.toc ├── mapping.toc ├── maybe.toc └── thunk.toc ├── scripts ├── build ├── build-ex ├── full-test ├── profile ├── re-build └── run ├── toccata.c └── toccata.toc /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | core.a 3 | 4 | *.c 5 | 6 | diamond 7 | 8 | *.plist 9 | 10 | hello 11 | 12 | core.c 13 | 14 | toccata 15 | 16 | fizzbuzz 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Eclipse Public License - v 1.0 2 | 3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 4 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF 5 | THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. 6 | 7 | 1. DEFINITIONS 8 | 9 | "Contribution" means: 10 | 11 | a) in the case of the initial Contributor, the initial code and 12 | documentation distributed under this Agreement, and 13 | 14 | b) in the case of each subsequent Contributor: 15 | 16 | i) changes to the Program, and 17 | 18 | ii) additions to the Program; 19 | 20 | where such changes and/or additions to the Program originate from and 21 | are distributed by that particular Contributor. A Contribution 22 | 'originates' from a Contributor if it was added to the Program by such 23 | Contributor itself or anyone acting on such Contributor's 24 | behalf. Contributions do not include additions to the Program which: 25 | (i) are separate modules of software distributed in conjunction with 26 | the Program under their own license agreement, and (ii) are not 27 | derivative works of the Program. 28 | 29 | "Contributor" means any person or entity that distributes the Program. 30 | 31 | "Licensed Patents" mean patent claims licensable by a Contributor 32 | which are necessarily infringed by the use or sale of its Contribution 33 | alone or when combined with the Program. 34 | 35 | "Program" means the Contributions distributed in accordance with this 36 | Agreement. 37 | 38 | "Recipient" means anyone who receives the Program under this 39 | Agreement, including all Contributors. 40 | 41 | 2. GRANT OF RIGHTS 42 | 43 | a) Subject to the terms of this Agreement, each Contributor hereby 44 | grants Recipient a non-exclusive, worldwide, royalty-free copyright 45 | license to reproduce, prepare derivative works of, publicly display, 46 | publicly perform, distribute and sublicense the Contribution of such 47 | Contributor, if any, and such derivative works, in source code and 48 | object code form. 49 | 50 | b) Subject to the terms of this Agreement, each Contributor hereby 51 | grants Recipient a non-exclusive, worldwide, royalty-free patent 52 | license under Licensed Patents to make, use, sell, offer to sell, 53 | import and otherwise transfer the Contribution of such Contributor, if 54 | any, in source code and object code form. This patent license shall 55 | apply to the combination of the Contribution and the Program if, at 56 | the time the Contribution is added by the Contributor, such addition 57 | of the Contribution causes such combination to be covered by the 58 | Licensed Patents. The patent license shall not apply to any other 59 | combinations which include the Contribution. No hardware per se is 60 | licensed hereunder. 61 | 62 | c) Recipient understands that although each Contributor grants the 63 | licenses to its Contributions set forth herein, no assurances are 64 | provided by any Contributor that the Program does not infringe the 65 | patent or other intellectual property rights of any other entity. Each 66 | Contributor disclaims any liability to Recipient for claims brought by 67 | any other entity based on infringement of intellectual property rights 68 | or otherwise. As a condition to exercising the rights and licenses 69 | granted hereunder, each Recipient hereby assumes sole responsibility 70 | to secure any other intellectual property rights needed, if any. For 71 | example, if a third party patent license is required to allow 72 | Recipient to distribute the Program, it is Recipient's responsibility 73 | to acquire that license before distributing the Program. 74 | 75 | d) Each Contributor represents that to its knowledge it has sufficient 76 | copyright rights in its Contribution, if any, to grant the copyright 77 | license set forth in this Agreement. 78 | 79 | 3. REQUIREMENTS 80 | 81 | A Contributor may choose to distribute the Program in object code form 82 | under its own license agreement, provided that: 83 | 84 | a) it complies with the terms and conditions of this Agreement; and 85 | 86 | b) its license agreement: 87 | 88 | i) effectively disclaims on behalf of all Contributors all warranties 89 | and conditions, express and implied, including warranties or 90 | conditions of title and non-infringement, and implied warranties or 91 | conditions of merchantability and fitness for a particular purpose; 92 | 93 | ii) effectively excludes on behalf of all Contributors all liability 94 | for damages, including direct, indirect, special, incidental and 95 | consequential damages, such as lost profits; 96 | 97 | iii) states that any provisions which differ from this Agreement are 98 | offered by that Contributor alone and not by any other party; and 99 | 100 | iv) states that source code for the Program is available from such 101 | Contributor, and informs licensees how to obtain it in a reasonable 102 | manner on or through a medium customarily used for software exchange. 103 | 104 | When the Program is made available in source code form: 105 | 106 | a) it must be made available under this Agreement; and 107 | 108 | b) a copy of this Agreement must be included with each copy of the Program. 109 | 110 | Contributors may not remove or alter any copyright notices contained 111 | within the Program. 112 | 113 | Each Contributor must identify itself as the originator of its 114 | Contribution, if any, in a manner that reasonably allows subsequent 115 | Recipients to identify the originator of the Contribution. 116 | 117 | 4. COMMERCIAL DISTRIBUTION 118 | 119 | Commercial distributors of software may accept certain 120 | responsibilities with respect to end users, business partners and the 121 | like. While this license is intended to facilitate the commercial use 122 | of the Program, the Contributor who includes the Program in a 123 | commercial product offering should do so in a manner which does not 124 | create potential liability for other Contributors. Therefore, if a 125 | Contributor includes the Program in a commercial product offering, 126 | such Contributor ("Commercial Contributor") hereby agrees to defend 127 | and indemnify every other Contributor ("Indemnified Contributor") 128 | against any losses, damages and costs (collectively "Losses") arising 129 | from claims, lawsuits and other legal actions brought by a third party 130 | against the Indemnified Contributor to the extent caused by the acts 131 | or omissions of such Commercial Contributor in connection with its 132 | distribution of the Program in a commercial product offering. The 133 | obligations in this section do not apply to any claims or Losses 134 | relating to any actual or alleged intellectual property 135 | infringement. In order to qualify, an Indemnified Contributor must: a) 136 | promptly notify the Commercial Contributor in writing of such claim, 137 | and b) allow the Commercial Contributor tocontrol, and cooperate with 138 | the Commercial Contributor in, the defense and any related settlement 139 | negotiations. The Indemnified Contributor may participate in any such 140 | claim at its own expense. 141 | 142 | For example, a Contributor might include the Program in a commercial 143 | product offering, Product X. That Contributor is then a Commercial 144 | Contributor. If that Commercial Contributor then makes performance 145 | claims, or offers warranties related to Product X, those performance 146 | claims and warranties are such Commercial Contributor's responsibility 147 | alone. Under this section, the Commercial Contributor would have to 148 | defend claims against the other Contributors related to those 149 | performance claims and warranties, and if a court requires any other 150 | Contributor to pay any damages as a result, the Commercial Contributor 151 | must pay those damages. 152 | 153 | 5. NO WARRANTY 154 | 155 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 156 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 157 | KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY 158 | WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 159 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 160 | responsible for determining the appropriateness of using and 161 | distributing the Program and assumes all risks associated with its 162 | exercise of rights under this Agreement , including but not limited to 163 | the risks and costs of program errors, compliance with applicable 164 | laws, damage to or loss of data, programs or equipment, and 165 | unavailability or interruption of operations. 166 | 167 | 6. DISCLAIMER OF LIABILITY 168 | 169 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR 170 | ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 171 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 172 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 173 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 174 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 175 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 176 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 177 | 178 | 7. GENERAL 179 | 180 | If any provision of this Agreement is invalid or unenforceable under 181 | applicable law, it shall not affect the validity or enforceability of 182 | the remainder of the terms of this Agreement, and without further 183 | action by the parties hereto, such provision shall be reformed to the 184 | minimum extent necessary to make such provision valid and enforceable. 185 | 186 | If Recipient institutes patent litigation against any entity 187 | (including a cross-claim or counterclaim in a lawsuit) alleging that 188 | the Program itself (excluding combinations of the Program with other 189 | software or hardware) infringes such Recipient's patent(s), then such 190 | Recipient's rights granted under Section 2(b) shall terminate as of 191 | the date such litigation is filed. 192 | 193 | All Recipient's rights under this Agreement shall terminate if it 194 | fails to comply with any of the material terms or conditions of this 195 | Agreement and does not cure such failure in a reasonable period of 196 | time after becoming aware of such noncompliance. If all Recipient's 197 | rights under this Agreement terminate, Recipient agrees to cease use 198 | and distribution of the Program as soon as reasonably 199 | practicable. However, Recipient's obligations under this Agreement and 200 | any licenses granted by Recipient relating to the Program shall 201 | continue and survive. 202 | 203 | Everyone is permitted to copy and distribute copies of this Agreement, 204 | but in order to avoid inconsistency the Agreement is copyrighted and 205 | may only be modified in the following manner. The Agreement Steward 206 | reserves the right to publish new versions (including revisions) of 207 | this Agreement from time to time. No one other than the Agreement 208 | Steward has the right to modify this Agreement. The Eclipse Foundation 209 | is the initial Agreement Steward. The Eclipse Foundation may assign 210 | the responsibility to serve as the Agreement Steward to a suitable 211 | separate entity. Each new version of the Agreement will be given a 212 | distinguishing version number. The Program (including Contributions) 213 | may always be distributed subject to the version of the Agreement 214 | under which it was received. In addition, after a new version of the 215 | Agreement is published, Contributor may elect to distribute the 216 | Program (including its Contributions) under the new version. Except as 217 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives 218 | no rights or licenses to the intellectual property of any Contributor 219 | under this Agreement, whether expressly, by implication, estoppel or 220 | otherwise. All rights in the Program not expressly granted under this 221 | Agreement are reserved. 222 | 223 | This Agreement is governed by the laws of the State of Washington and 224 | the intellectual property laws of the United States of America. No 225 | party to this Agreement will bring a legal action under this Agreement 226 | more than one year after the cause of action arose. Each party waives 227 | its rights to a jury trial in any resulting litigation. 228 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Toccata 2 | ======= 3 | 4 | *This project is no longer active. It has moved to https://github.com/Toccata-Lang/toccata* 5 | =========================================================================================== 6 | 7 | A Clojure-inspired Lisp dialect that compiles to native executable using the Clang compiler 8 | 9 | This is very much WFM code. Not suitable for any useful purpose. 10 | 11 | You can learn more about Toccata by following the [blog here](http://toccata.io) 12 | 13 | Quick Start 14 | =========== 15 | 16 | Make sure the Clang compiler is installed and runnable 17 | On OSX, it's part of the Xcode package. You can run 'clang -v' to check. 18 | 19 | Clone this repo 20 | 21 | cd to the repo directory 22 | 23 | run the 'scripts/build' script. 24 | This will compile the 'toccata' executable and then use that to compile 'examples/hello.toc' and execute it. You should see 'Howdy, Universe!!!' as the final output. 25 | 26 | Rebuilding Toccata 27 | ========= 28 | 29 | Run './toccata toccata.toc > toccata.c' 30 | 31 | Then you can re-run the 'build' script. 32 | 33 | Good luck!!! 34 | -------------------------------------------------------------------------------- /core/analyzer.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns ast (module "core/ast.toc")) 3 | (add-ns sm (module "core/state-maybe.toc")) 4 | ;; (add-ns fio (module "core/file-io.toc")) 5 | 6 | (defn set-expr [expr] 7 | (sm/set-val :expr expr)) 8 | 9 | (defn is-expr [pred] 10 | (for [expr (sm/get-val :expr) 11 | :when (pred expr)] 12 | expr)) 13 | 14 | (def analyze-expr) 15 | 16 | (defn analyze-inline-text [] 17 | (flat-map (sm/get-val :expr) 18 | (fn [expr] 19 | (sm/when (match expr 20 | |List 'inline-text type text| 21 | (maybe (ast/inline-text text type)) 22 | 23 | |List 'inline-text text| 24 | (maybe (ast/inline-text text :no-type))))))) 25 | 26 | (defn analyze-symbol [] 27 | (for [sym (is-expr (partial instance? Symbol))] 28 | (ast/sym sym))) 29 | 30 | (defn analyze-keyword [] 31 | (for [kw (is-expr (partial instance? Keyword))] 32 | (ast/kw kw))) 33 | 34 | (defn make-static-number [num] 35 | (for [num-idx (sm/get-val :num-count) 36 | _ (sm/set-val :num-count (inc num-idx)) 37 | _ (sm/assoc-in-val (list :new-numbers num) 38 | (str "_num_" num-idx))] 39 | "")) 40 | 41 | (defn analyze-number [] 42 | (for [num (is-expr (partial instance? Number))] 43 | (ast/number num))) 44 | 45 | (defn analyze-string [] 46 | (for [str-val (is-expr string?)] 47 | (ast/strng str-val))) 48 | 49 | (defn analyze-call [] 50 | (for [expr (sm/get-val :expr) 51 | [target & args] (sm/traverse expr analyze-expr)] 52 | (ast/call-expr target args))) 53 | 54 | (defn analyze-let-binding [binding-pair] 55 | (for [_ (sm/when (= 2 (count binding-pair))) 56 | :let [[binding expr] binding-pair] 57 | curr-expr (sm/get-val :expr) 58 | ast (analyze-expr expr) 59 | _ (sm/set-val :expr curr-expr)] 60 | (ast/binding binding ast))) 61 | 62 | (defn analyze-let [] 63 | (for [expr (sm/get-val :expr) 64 | [bindings exprs] (sm/when (match expr 65 | |List 'let bindings & exprs| 66 | (maybe (list bindings exprs)))) 67 | bindings (sm/traverse bindings analyze-let-binding) 68 | body (sm/traverse exprs analyze-expr)] 69 | (ast/let-expr bindings body))) 70 | 71 | (defn analyze-fn-arity [] 72 | (for [expr (sm/get-val :expr) 73 | [args exprs] (sm/when (match expr 74 | |List 'fn-arity args exprs| 75 | (maybe (list args exprs)))) 76 | body (sm/traverse exprs analyze-expr)] 77 | (match (some args (partial = "&")) 78 | nothing (ast/fixed-arity args body) 79 | (ast/variadic-arity (remove args (partial = "&")) body)))) 80 | 81 | ;; TODO: let anonymous function closures reference themselves by name 82 | (defn analyze-fn [] 83 | (for [expr (sm/get-val :expr) 84 | [_ name arities] (sm/when (match expr 85 | |List 'fn _ _| 86 | (maybe expr))) 87 | arities (sm/traverse arities analyze-expr)] 88 | (ast/fn-expr (ast/sym name) arities))) 89 | 90 | (defn analyze-proto-arity [[fn-name params & default-body]] 91 | (flat-map (sm/when-not (some params (partial = "&"))) 92 | (fn [_] 93 | (comp (for [_ (sm/when (list-empty? default-body))] 94 | {fn-name {(dec (count params)) {}}}) 95 | (for [ast (analyze-expr (list 'fn-arity (rest params) default-body))] 96 | {fn-name {(dec (count params)) {:default ast}}}))))) 97 | 98 | (defn analyze-protocol [] 99 | (for [expr (sm/get-val :expr) 100 | [name defs] (sm/when (match expr 101 | |List 'defprotocol name & defs| 102 | (maybe (list name defs)))) 103 | proto-fns (sm/traverse defs analyze-proto-arity)] 104 | (ast/proto name (apply merge-with comp proto-fns)))) 105 | 106 | (defn make-quoted [quoted-form] 107 | (match quoted-form 108 | |Symbol| 109 | (sm/state-maybe (ast/quoted quoted-form)) 110 | 111 | |String| 112 | (analyze-expr quoted-form) 113 | 114 | |Keyword| 115 | (analyze-expr quoted-form) 116 | 117 | |Number| 118 | (analyze-expr quoted-form) 119 | 120 | |List 'quote| 121 | (make-quoted (car (cdr quoted-form))) 122 | 123 | |List 'hash-map| 124 | (for [contents (sm/traverse (cdr quoted-form) make-quoted)] 125 | (ast/call-expr (ast/sym 'hash-map) contents)) 126 | 127 | |List 'vector| 128 | (for [contents (sm/traverse (cdr quoted-form) make-quoted)] 129 | (ast/call-expr (ast/sym 'vector) contents)) 130 | 131 | |List| 132 | (for [qs (sm/traverse quoted-form make-quoted)] 133 | (ast/call-expr (ast/sym 'list) qs)) 134 | 135 | (sm/state-maybe ""))) 136 | 137 | (defn analyze-quoted [] 138 | (for [expr (sm/get-val :expr) 139 | to-be-quoted (sm/when (match expr 140 | |List 'quote quoted| 141 | (maybe quoted))) 142 | quoted (make-quoted to-be-quoted)] 143 | quoted)) 144 | 145 | (defn analyze-def [] 146 | (flat-map (sm/get-val :expr) 147 | (fn [expr] 148 | (match expr 149 | |List 'def name value| 150 | (for [val-ast (analyze-expr value)] 151 | (ast/def-expr name val-ast)) 152 | 153 | |List 'def name| 154 | (sm/state-maybe (ast/declare name)) 155 | 156 | (zero sm/state-maybe))))) 157 | 158 | (defn analyze-cond [] 159 | (for [expr (sm/get-val :expr) 160 | clause-pairs (sm/when (match expr 161 | |List 'cond & clause-pairs| 162 | (maybe clause-pairs))) 163 | clause-pairs (sm/traverse clause-pairs analyze-expr)] 164 | (let [clauses (partition-all clause-pairs 2)] 165 | (match (last clauses empty-list) 166 | |List default| (ast/cond-expr (butlast clauses) default) 167 | (let [_ (print-err "'cond' must have a default clause")] 168 | (abort)))))) 169 | 170 | (defn analyze-match [] 171 | (for [expr (sm/get-val :expr) 172 | [value clauses default] (sm/when (match expr 173 | |List 'match value clauses default| 174 | (maybe (list value clauses default)))) 175 | value (analyze-expr value) 176 | clauses (sm/traverse clauses 177 | (fn [[pattern result]] 178 | (for [_ (analyze-expr pattern) 179 | result (analyze-expr result)] 180 | (list pattern result)))) 181 | default (analyze-expr default)] 182 | (ast/match-expr value clauses default))) 183 | 184 | (defn analyze-proto-fn [] 185 | (for [expr (sm/get-val :expr) 186 | [name args exprs frms] (sm/when (match expr 187 | |List frm & frms| 188 | (match frm 189 | |List name args & exprs| 190 | (maybe (list name args exprs frms))))) 191 | body (sm/traverse exprs analyze-expr) 192 | _ (sm/set-val :expr frms)] 193 | {name (list (ast/fixed-arity (rest args) body))})) 194 | 195 | (defn analyze-proto-impl [] 196 | (for [expr (sm/get-val :expr) 197 | [name frms] (sm/when (match expr 198 | |List name & frms| 199 | (maybe (list name frms)))) 200 | :when (instance? Symbol name) 201 | _ (sm/set-val :expr frms) 202 | fn-impls (sm/recur (analyze-proto-fn))] 203 | {name (apply merge-with comp fn-impls)})) 204 | 205 | (defn analyze-extensions [exts] 206 | (for [curr-expr (sm/get-val :expr) 207 | _ (sm/set-val :expr exts) 208 | proto-impls (sm/recur (analyze-proto-impl)) 209 | _ (sm/set-val :expr curr-expr)] 210 | (apply merge-with comp proto-impls))) 211 | 212 | (defn analyze-extend-type [] 213 | (for [expr (sm/get-val :expr) 214 | [name defs] (sm/when (match expr 215 | |List 'extend-type name & defs| 216 | (maybe (list name defs)))) 217 | proto-specs (analyze-extensions defs)] 218 | (ast/type-extension name proto-specs))) 219 | 220 | (defn analyze-reify [] 221 | (for [expr (sm/get-val :expr) 222 | defs (sm/when (match expr 223 | |List 'reify & defs| 224 | (maybe defs))) 225 | proto-specs (analyze-extensions defs)] 226 | (ast/reified proto-specs))) 227 | 228 | (defn analyze-deftype [] 229 | (flat-map (sm/get-val :expr) 230 | (fn [expr] 231 | (sm/when (match expr 232 | |List 'deftype name fields & defs| 233 | (maybe (ast/type-expr name fields defs))))))) 234 | 235 | (defn analyze-add-ns [] 236 | (for [expr (sm/get-val :expr) 237 | [ns-name defs] (sm/when (match expr 238 | |List 'add-ns ns-name defs| 239 | (maybe (list ns-name defs)))) 240 | asts (analyze-expr defs)] 241 | (ast/ns-add ns-name asts))) 242 | 243 | (defn analyze-module [] 244 | (for [expr (sm/get-val :expr) 245 | module-name (sm/when (match expr 246 | |List 'module module-name| 247 | (maybe module-name))) 248 | module-ast (comp 249 | (for [_ (sm/get-in-val (list :modules module-name))] 250 | (list (ast/strng module-name))) 251 | (for [text (sm/get-val :text) 252 | _ (sm/set-val :text (slurp module-name)) 253 | file-name (sm/get-val :file-name) 254 | _ (sm/set-val :file-name module-name) 255 | parser (sm/get-val :parser) 256 | asts (sm/recur (for [expr parser 257 | ast (analyze-expr expr)] 258 | ast)) 259 | ;; :let [_ (fio/close-stream module-stream)] 260 | _ (sm/set-val :file-name file-name) 261 | _ (sm/set-val :text text)] 262 | (cons (ast/strng module-name) 263 | asts)))] 264 | module-ast)) 265 | 266 | (defn analyze-main [] 267 | (for [expr (sm/get-val :expr) 268 | [args exprs] (sm/when (match expr 269 | |List 'main args & exprs| 270 | (maybe (list args exprs)))) 271 | body (sm/traverse exprs analyze-expr)] 272 | (ast/main-fn args body))) 273 | 274 | (defn expr-to-ast [] 275 | (comp (analyze-symbol) 276 | (analyze-keyword) 277 | (analyze-number) 278 | (analyze-string) 279 | (analyze-fn) 280 | (analyze-deftype) 281 | (analyze-protocol) 282 | (analyze-main) 283 | (analyze-def) 284 | (analyze-cond) 285 | (analyze-match) 286 | (analyze-extend-type) 287 | (analyze-reify) 288 | (analyze-module) 289 | (analyze-add-ns) 290 | (analyze-inline-text) 291 | (analyze-fn-arity) 292 | (analyze-let) 293 | (analyze-quoted) 294 | (analyze-call) 295 | (flat-map (sm/get-val :expr) 296 | (fn [e] 297 | (print-err "could not analyze" e) 298 | empty-list)))) 299 | 300 | (defn analyze-expr [expr] 301 | (for [curr-expr (sm/get-val :expr) 302 | _ (set-expr expr) 303 | ast (expr-to-ast) 304 | _ (set-expr curr-expr)] 305 | ast)) 306 | 307 | -------------------------------------------------------------------------------- /core/ast-rewrite.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns sm (module "core/state-maybe.toc")) 3 | (add-ns fr (module "core/free.toc")) 4 | (add-ns parser (module "core/parser.toc")) 5 | (add-ns grmr (module "core/grammar.toc")) 6 | (add-ns ast (module "core/ast.toc")) 7 | (add-ns an (module "core/analyzer.toc")) 8 | (add-ns id (module "core/id.toc")) 9 | 10 | (defprotocol ASTRewrite 11 | (apply-rewrite [ast rule])) 12 | 13 | (defn rewrite [free-ast rule] 14 | (fr/evaluate free-ast rule)) 15 | 16 | (defprotocol PrettyPrinter 17 | (pprint [ast] 18 | ast)) 19 | 20 | (extend-type ast/quoted-ast 21 | ASTRewrite 22 | (apply-rewrite [ast rule] 23 | (sm/state-maybe (fr/free ast))) 24 | 25 | PrettyPrinter 26 | (pprint [q] 27 | (str "'" (.sym q))) 28 | 29 | Stringable 30 | (string-list [q] (list ""))) 31 | 32 | (extend-type ast/const-string-ast 33 | ASTRewrite 34 | (apply-rewrite [ast rule] 35 | (sm/state-maybe (fr/free ast))) 36 | 37 | PrettyPrinter 38 | (pprint [s] 39 | (cond 40 | (empty? (.const-str s)) "\"\"" 41 | (str "\"" (escape-chars (.const-str s)) "\"")))) 42 | 43 | (extend-type ast/const-number-ast 44 | ASTRewrite 45 | (apply-rewrite [ast rule] 46 | (sm/state-maybe (fr/free ast))) 47 | 48 | PrettyPrinter 49 | (pprint [k] 50 | (str (.num k))) 51 | 52 | Stringable 53 | (string-list [k] (list ""))) 54 | 55 | (extend-type ast/keyword-ast 56 | ASTRewrite 57 | (apply-rewrite [ast rule] 58 | (sm/state-maybe (fr/free ast))) 59 | 60 | PrettyPrinter 61 | (pprint [k] 62 | (str (.kw k))) 63 | 64 | Stringable 65 | (string-list [k] (list ""))) 66 | 67 | (extend-type ast/symbol-ast 68 | ASTRewrite 69 | (apply-rewrite [ast rule] 70 | (sm/state-maybe (fr/free ast))) 71 | 72 | PrettyPrinter 73 | (pprint [s] 74 | (str (.sym s))) 75 | 76 | Stringable 77 | (string-list [k] (list ""))) 78 | 79 | (extend-type ast/call-ast 80 | ASTRewrite 81 | (apply-rewrite [c rule] 82 | (apply-to (fn [callee params] 83 | (fr/free (ast/call-ast callee (apply* (fr/free list) params)))) 84 | (rewrite (.callee c) rule) 85 | (rewrite (.params c) rule))) 86 | 87 | PrettyPrinter 88 | (pprint [c] 89 | (str "(" 90 | (fr/evaluate (.callee c) pprint) 91 | " " 92 | (fr/evaluate (.params c) pprint) 93 | ")")) 94 | 95 | Stringable 96 | (string-list [c] 97 | (comp (list "")))) 102 | 103 | (extend-type ast/reify-ast 104 | Stringable 105 | (string-list [r] 106 | (list "")) 107 | 108 | ASTRewrite 109 | (apply-rewrite [c rule] 110 | (apply-to (fn [impls] 111 | (fr/free (ast/reify-ast (reduce impls 112 | {} 113 | (fn [acc k-v] 114 | (assoc acc (first k-v) (second k-v))))))) 115 | (traverse (seq (.impls c)) 116 | (fn [impl] 117 | (apply-to (fn [impl-fns] 118 | (list (first impl) impl-fns)) 119 | (traverse (second impl) 120 | (fn [impl-fn] 121 | (apply-to (fn [impl-arity] 122 | (list (first impl-fn) 123 | impl-arity)) 124 | (rewrite (second impl-fn) rule))))))))) 125 | 126 | PrettyPrinter 127 | (pprint [c] 128 | (str "(reify\n" 129 | (.impls c) 130 | ")")) 131 | 132 | ;; Stringable 133 | ;; (string-list [c] 134 | ;; (comp (list ""))) 137 | ) 138 | 139 | (extend-type ast/cond-ast 140 | PrettyPrinter 141 | (pprint [c] 142 | (apply str (comp (list "(cond\n") 143 | (interpose (map (.clauses c) 144 | (fn [clause] 145 | (str (fr/evaluate (first clause) pprint) 146 | " " 147 | (fr/evaluate (second clause) pprint)))) 148 | "\n") 149 | (list "\n") 150 | (list (fr/evaluate (.default c) pprint)) 151 | (list ")")))) 152 | 153 | ASTRewrite 154 | (apply-rewrite [c rule] 155 | (apply-to (fn [clauses default] 156 | (fr/free (ast/cond-ast clauses default))) 157 | (traverse (.clauses c) 158 | (fn [clause] 159 | (traverse clause (fn [part] 160 | (rewrite part rule))))) 161 | (rewrite (.default c) rule))) 162 | 163 | Stringable 164 | (string-list [c] 165 | (comp (list "")))) 170 | 171 | (extend-type ast/let-ast 172 | ASTRewrite 173 | (apply-rewrite [lt rule] 174 | (apply-to (fn [bindings body] 175 | (fr/free (ast/let-ast 176 | (apply* (fr/free list) bindings) 177 | (apply* (fr/free list) body)))) 178 | (rewrite (.bindings lt) rule) 179 | (rewrite (.body lt) rule))) 180 | 181 | PrettyPrinter 182 | (pprint [l] 183 | (str "(let [" 184 | (apply str (interpose (map (.args (.bindings l)) (fn [binding] (fr/evaluate binding pprint))) "\n")) 185 | "]\n" 186 | (fr/evaluate (.body l) pprint) 187 | ")")) 188 | 189 | Stringable 190 | (string-list [l] 191 | (comp (list "")))) 195 | 196 | (extend-type ast/binding-ast 197 | ASTRewrite 198 | (apply-rewrite [lt rule] 199 | (apply-to (fn [binding val] 200 | (fr/free (ast/binding-ast binding val))) 201 | (rewrite (.binding lt) rule) 202 | (rewrite (.val lt) rule))) 203 | 204 | PrettyPrinter 205 | (pprint [b] 206 | (str (fr/evaluate (.binding b) pprint) 207 | " " 208 | (fr/evaluate (.val b) pprint))) 209 | 210 | Stringable 211 | (string-list [l] 212 | (comp (list "")))) 216 | 217 | (extend-type ast/fn-ast 218 | ASTRewrite 219 | (apply-rewrite [lt rule] 220 | (apply-to (fn [fn-name arities] 221 | (fr/free (ast/fn-ast fn-name (apply* (fr/free list) arities)))) 222 | (rewrite (.fn-name lt) rule) 223 | (rewrite (.arities lt) rule))) 224 | 225 | PrettyPrinter 226 | (pprint [f] 227 | (let [arities (.args (.arities f))] 228 | (cond 229 | (= 1 (count arities)) 230 | (str "(fn " (fr/evaluate (.fn-name f) pprint) " " 231 | (subs (fr/evaluate (.arities f) pprint) 1)) 232 | (str "(fn " 233 | (fr/evaluate (.fn-name f) pprint) "\n" 234 | (fr/evaluate (.arities f) pprint) ")")))) 235 | 236 | Stringable 237 | (string-list [f] 238 | (comp (list "")))) 243 | 244 | (extend-type ast/fn-arity-ast 245 | ASTRewrite 246 | (apply-rewrite [fn-arity rule] 247 | (apply-to (fn [args body] 248 | (fr/free (ast/fn-arity-ast (apply* (fr/free list) args) 249 | (apply* (fr/free list) body)))) 250 | (rewrite (.args fn-arity) rule) 251 | (rewrite (.body fn-arity) rule))) 252 | 253 | PrettyPrinter 254 | (pprint [a] 255 | (str "([" (fr/evaluate (.args a) pprint) 256 | "]\n" 257 | (fr/evaluate (.body a) pprint) 258 | ")")) 259 | 260 | Stringable 261 | (string-list [a] 262 | (comp (list "")))) 266 | 267 | (extend-type ast/variadic-arity-ast 268 | ASTRewrite 269 | (apply-rewrite [fn-arity rule] 270 | (apply-to (fn [args body] 271 | (fr/free (ast/variadic-arity-ast (apply* (fr/free list) args) 272 | (apply* (fr/free list) body)))) 273 | (rewrite (.args fn-arity) rule) 274 | (rewrite (.body fn-arity) rule))) 275 | 276 | PrettyPrinter 277 | (pprint [a] 278 | (str "([" (fr/evaluate (.args a) pprint) 279 | "]\n" 280 | (fr/evaluate (.body a) pprint) 281 | ")")) 282 | 283 | Stringable 284 | (string-list [a] 285 | (comp (list "")))) 289 | 290 | (defn compile-source [parser] 291 | (for [expr parser 292 | ast (an/analyze-expr (first expr))] 293 | ast)) 294 | 295 | (defprotocol ReplaceCallee 296 | (replace-callee [ast old-callee new-callee] 297 | (apply-rewrite ast (fn [ast] 298 | (replace-callee ast old-callee new-callee))))) 299 | 300 | (defprotocol InlineFM 301 | (inline-flat-map [ast] 302 | (apply-rewrite ast inline-flat-map))) 303 | 304 | (defprotocol FnToLet 305 | (convert-fn-to-let [ast] 306 | (apply-rewrite ast convert-fn-to-let))) 307 | 308 | (extend-type ast/call-ast 309 | ReplaceCallee 310 | (replace-callee [ast old-callee new-callee] 311 | (for [new-ast (cond 312 | (not (instance? fr/free (.callee ast))) 313 | (apply-rewrite ast (fn [ast] 314 | (replace-callee ast old-callee new-callee))) 315 | 316 | (not (instance? ast/symbol-ast (.v (.callee ast)))) 317 | (apply-rewrite ast (fn [ast] 318 | (replace-callee ast old-callee new-callee))) 319 | 320 | (not (= old-callee (.sym (.v (.callee ast))))) 321 | (apply-rewrite ast (fn [ast] 322 | (replace-callee ast old-callee new-callee))) 323 | 324 | (for [params (fr/evaluate (.params ast) inline-flat-map) 325 | ;; ast (fr/evaluate ast convert-fn-to-let) 326 | ] 327 | (fr/free 328 | (ast/call-ast new-callee 329 | (apply* (fr/free list) params)))))] 330 | new-ast))) 331 | 332 | (extend-type ast/call-ast 333 | FnToLet 334 | (convert-fn-to-let [ast] 335 | (cond 336 | (not (instance? fr/free (.callee ast))) (apply-rewrite ast inline-flat-map) 337 | (not (instance? ast/fn-ast (.v (.callee ast)))) (apply-rewrite ast inline-flat-map) 338 | (for [ast (apply-rewrite ast inline-flat-map) 339 | :let [ast (.v ast) 340 | params (.x (fr/evaluate (.params ast) id/id-m)) 341 | args (.x (fr/evaluate (.args (.v (first (.args (.arities (.v (.callee ast))))))) 342 | id/id-m)) 343 | body (.body (.v (first (.args (.arities (.v (.callee ast))))))) 344 | bindings (apply-to list (fr/free (ast/binding-ast (fr/free (first args)) 345 | (fr/free (first params)))))] 346 | body-ast (cond 347 | (= (count args) 2) (fr/evaluate body (fn [ast] 348 | (replace-callee ast 349 | (.sym (second args)) 350 | (fr/free (second params))))) 351 | (sm/state-maybe (fr/free (.x (fr/evaluate body id/id-m))))) 352 | body-ast (fr/evaluate (apply* (fr/free list) body-ast) convert-fn-to-let) 353 | ] 354 | (fr/free (ast/let-ast bindings (apply* (fr/free list) body-ast))))) 355 | )) 356 | 357 | (extend-type ast/call-ast 358 | InlineFM 359 | (inline-flat-map [ast] 360 | (cond 361 | (not (instance? ast/symbol-ast (.v (.callee ast)))) (apply-rewrite ast inline-flat-map) 362 | (not (= 'flat-map (.sym (.v (.callee ast))))) (apply-rewrite ast inline-flat-map) 363 | (for [flat-map-ast (sm/get-val :flat-map-ast (fr/free (ast/symbol-ast 'mapcat))) 364 | ast (map (fr/evaluate (.params ast) inline-flat-map) 365 | (fn [params] 366 | (fr/free (ast/call-ast flat-map-ast 367 | (apply* (fr/free list) params))))) 368 | :when false 369 | ;; ast (fr/evaluate ast convert-fn-to-let) 370 | ] 371 | ast)) 372 | ;; (for [flat-map-ast (sm/get-val :flat-map-ast (fr/free (ast/symbol-ast 'mapcat))) 373 | ;; new-ast (cond 374 | ;; (not (instance? ast/symbol-ast (.v (.callee ast)))) (apply-rewrite ast inline-flat-map) 375 | ;; (not (= 'flat-map (.sym (.v (.callee ast))))) (apply-rewrite ast inline-flat-map) 376 | ;; (for [ast (map (fr/evaluate (.params ast) inline-flat-map) 377 | ;; (fn [params] 378 | ;; (fr/free (ast/call-ast flat-map-ast 379 | ;; (apply* (fr/free list) params))))) 380 | ;; :when false 381 | ;; ;; ast (fr/evaluate ast convert-fn-to-let) 382 | ;; ] 383 | ;; ast))] 384 | ;; new-ast) 385 | )) 386 | 387 | (defprotocol InlineWrap 388 | (inline-wrap [ast] 389 | (apply-rewrite ast inline-wrap))) 390 | 391 | (extend-type ast/call-ast 392 | InlineWrap 393 | (inline-wrap [ast] 394 | (for [wrap-ast (sm/get-val :wrap-ast) 395 | new-ast (cond 396 | (not (instance? fr/free (.callee ast))) (apply-rewrite ast inline-wrap) 397 | (not (instance? ast/symbol-ast (.v (.callee ast)))) (apply-rewrite ast inline-wrap) 398 | (not (= 'wrap (.sym (.v (.callee ast))))) (apply-rewrite ast inline-wrap) 399 | (for [ast (map (fr/evaluate (.params ast) inline-wrap) 400 | (fn [params] 401 | (fr/free (ast/call-ast wrap-ast 402 | (apply* (fr/free list) params))))) 403 | ast (rewrite ast convert-fn-to-let) 404 | ] 405 | ast))] 406 | new-ast))) 407 | 408 | (extend-type Function 409 | PrettyPrinter 410 | (pprint [f] 411 | (reify 412 | Applicative 413 | (apply* [_ args] 414 | (apply str (interpose args " "))))) 415 | 416 | ASTRewrite 417 | (apply-rewrite [f rule] 418 | (sm/state-maybe f))) 419 | 420 | (extend-type sm/new-sm 421 | Stringable 422 | (string-list [_] (list ""))) 423 | 424 | ;; (main [_] 425 | ;; (let [p (fr/evaluate (grmr/read-form) parser/recursive-descent) 426 | ;; flat-map-ast (first ((compile-source p) {:text "(fn [ev f] 427 | ;; (fn [s] 428 | ;; (let [v-ss (ev s) 429 | ;; v (nth v-ss 0) 430 | ;; ss (nth v-ss 1)] 431 | ;; ((f v) ss))))"})) 432 | ;; wrap-ast (first ((compile-source p) {:text "(fn [_ v] 433 | ;; (fn [s] 434 | ;; (list v s)))"})) 435 | ;; cond-ast (first ((compile-source p) {:text "(cond 436 | ;; true (inc x) 437 | ;; :bogus (dec x) 438 | ;; 0)"})) 439 | ;; ast (first ((compile-source p) {:text "(for [x (get-val :x) 440 | ;; y (set-val :x x)] 441 | ;; y)"})) 442 | ;; ;; new-ast (first ((rewrite ast inline-wrap) {:flat-map-ast flat-map-ast 443 | ;; ;; :wrap-ast wrap-ast})) 444 | ;; ;; new-ast (first ((rewrite new-ast inline-flat-map) {:flat-map-ast flat-map-ast 445 | ;; ;; :wrap-ast wrap-ast})) 446 | ;; ;; new-ast (first ((rewrite new-ast convert-fn-to-let) {})) 447 | 448 | ;; ;; new-ast (first ((for [ast (rewrite ast inline-wrap) 449 | ;; ;; ast (comp (rewrite ast inline-flat-map) 450 | ;; ;; (sm/state-maybe ast))] 451 | ;; ;; ast) {:flat-map-ast flat-map-ast 452 | ;; ;; :wrap-ast wrap-ast})) 453 | ;; ] 454 | ;; ;; (println :ast ast) 455 | ;; ;; (println :concrete (first new-ast)) 456 | ;; ;; (println) 457 | ;; ;; (println :result1 (fr/evaluate ast pprint)) 458 | ;; ;; (println cond-ast) 459 | ;; (println (fr/evaluate cond-ast pprint)) 460 | ;; )) 461 | 462 | ;; (defn emit-callsite [ast] 463 | ;; (for [target (fr/evaluate (.callee ast) emit-c) 464 | ;; args (eval-args (.args (.params ast))) 465 | ;; result (comp (call-proto-impl (.callee ast) args) 466 | ;; (call-invoke target args) 467 | ;; (call-static-fixed target args) 468 | ;; (call-static-variadic target args) 469 | ;; (call-recursive target args) 470 | ;; (call-dyn-fn-value target args) 471 | ;; (call-dyn-unknown-type target args) 472 | ;; (call-dyn-known-type target args) 473 | ;; (sm/new-sm (fn [s] 474 | ;; (print-err (str "could not emit callsite for '" 475 | ;; (first (fr/evaluate (.callee ast) string-list)) 476 | ;; "'")) 477 | ;; (print-err :target (.c-val target)) 478 | ;; (abort))))] 479 | ;; result)) 480 | 481 | ;; (defprotocol Rename-new-sm 482 | ;; (rename-new-sm [ast] 483 | ;; (rwr/apply-rewrite ast rename-new-sm))) 484 | 485 | ;; (defprotocol InlineFunction 486 | ;; (inline-fn [ast] 487 | ;; (rwr/apply-rewrite ast inline-fn))) 488 | 489 | ;; (defprotocol MergeLets 490 | ;; (merge-lets [ast] 491 | ;; (rwr/apply-rewrite ast merge-lets))) 492 | 493 | ;; (defprotocol CallingLet 494 | ;; (calling-let [ast] 495 | ;; (rwr/apply-rewrite ast calling-let))) 496 | 497 | ;; (extend-type ast/let-ast 498 | ;; MergeLets 499 | ;; (merge-lets [ast] 500 | ;; ;; TODO: currently assumes .body has one element 501 | ;; (cond 502 | ;; (not (instance? ast/let-ast (.v (first (.args (.body ast)))))) 503 | ;; (sm/state-maybe (fr/free ast)) 504 | 505 | ;; (let [outer-bindings (.args (.bindings ast)) 506 | ;; inner-bindings (.args (.bindings (.v (first (.args (.body ast)))))) 507 | ;; inner-body (.body (.v (first (.args (.body ast)))))] 508 | ;; (sm/state-maybe (fr/free (ast/let-ast (apply* (fr/free list) 509 | ;; (comp outer-bindings inner-bindings)) 510 | ;; inner-body))))))) 511 | 512 | ;; (extend-type ast/symbol-ast 513 | ;; Rename-new-sm 514 | ;; (rename-new-sm [ast] 515 | ;; (cond 516 | ;; (= 'new-sm (.sym ast)) (comp 517 | ;; (for [_ (sm/get-in-val (list :defined-syms 'new-sm))] 518 | ;; (sm/state-maybe (fr/free ast))) 519 | ;; (sm/state-maybe (fr/free (ast/symbol-ast 'sm/new-sm)))) 520 | ;; (sm/state-maybe (fr/free ast))))) 521 | 522 | ;; (defn lookup-proto-fn-ast [fn-sym type-num num-args] 523 | ;; (for [qualified-name (sm/get-in-val (list :defined-protos fn-sym)) 524 | ;; proto-fn (sm/get-in-val (list :protocols qualified-name :impls 525 | ;; type-num :fn-sym)) 526 | ;; invoke-fn-sym (lookup-static-fn proto-fn num-args) 527 | ;; ast (comp (sm/get-in-val (list :static-fns proto-fn num-args :ast)) 528 | ;; (sm/get-in-val (list :core-static-fns proto-fn num-args :ast)))] 529 | ;; ast)) 530 | 531 | ;; (deftype ast-rewriter [data rewrite-fn] 532 | ;; Function 533 | ;; (invoke [ar ast] 534 | ;; (rewrite-fn ast ar))) 535 | 536 | 537 | ;; ;; inline-fn 538 | ;; ;; fn-to-let 539 | ;; ;; call-let all the way down 540 | ;; ;; call-new-sm 541 | ;; ;; fn-to-let 542 | ;; ;; merge-lets 543 | 544 | ;; (defn fn-to-let [fn-ast args] 545 | ;; (cond 546 | ;; (not (instance? ast/fn-ast (.v fn-ast))) 547 | ;; (sm/state-maybe fn-ast) 548 | 549 | ;; (let [arg-count (count args) 550 | ;; arity (filter (.args (.arities (.v fn-ast))) 551 | ;; (fn [arity] 552 | ;; (= arg-count (count (.args (.args (.v arity)))))))] 553 | ;; (cond 554 | ;; (empty? arity) 555 | ;; (sm/state-maybe fn-ast) 556 | 557 | ;; (let [arity (.v (first arity)) 558 | ;; params (.args (.args arity)) 559 | ;; body (.body arity) 560 | ;; zipped (zip-lists params args) 561 | ;; binding-pairs (remove zipped (fn [pair] 562 | ;; (instance? ast/fn-ast (.v (second pair))))) 563 | ;; sym-ast-map (reduce zipped 564 | ;; {} 565 | ;; (fn [m pair] 566 | ;; (cond 567 | ;; (instance? ast/fn-ast (.v (second pair))) 568 | ;; (assoc m 569 | ;; (.sym (.v (first pair))) (second pair)) 570 | 571 | ;; m))) 572 | ;; bindings (apply* (fr/free list) 573 | ;; (map binding-pairs 574 | ;; (fn [pair] 575 | ;; (ast/binding (first pair) (second pair)))))] 576 | ;; (cond 577 | ;; (empty? sym-ast-map) 578 | ;; (sm/state-maybe (fr/free (ast/let-ast bindings (.body arity)))) 579 | 580 | ;; (for [inlined-asts (sm/get-val :inlined-asts {}) 581 | ;; _ (sm/update-in-val (list :inlined-asts) (fn [m] (comp m sym-ast-map))) 582 | ;; body-asts (fr/evaluate body inline-fn) 583 | ;; body-asts (traverse body-asts (fn [ast] 584 | ;; (for [new-ast (fr/evaluate ast calling-let) 585 | ;; new-ast (fr/evaluate new-ast merge-lets)] 586 | ;; new-ast))) 587 | ;; _ (sm/set-val :inlined-asts inlined-asts)] 588 | ;; (fr/free (ast/let-ast bindings (apply* (fr/free list) body-asts)))))))))) 589 | 590 | ;; (extend-type ast/call-ast 591 | ;; Emitter 592 | ;; (emit-c [ast] 593 | ;; (cond 594 | ;; (not (instance? ast/symbol-ast (.v (.callee ast)))) 595 | ;; (emit-callsite ast) 596 | 597 | ;; (= 'flat-map (.sym (.v (.callee ast)))) 598 | ;; (for [target (fr/evaluate (.callee ast) emit-c) 599 | ;; arg1 (fr/evaluate (first (.args (.params ast))) emit-c) 600 | ;; :let [type-num (.type-num arg1)] 601 | ;; inline-map (comp (sm/get-in-val (list :inliners type-num)) 602 | ;; (for [wrap-ast (lookup-proto-fn-ast 'wrap type-num 2) 603 | ;; ;; TODO: Total hack 604 | ;; wrap-ast (fr/evaluate wrap-ast rename-new-sm) 605 | ;; _ (sm/assoc-in-val (list :inlined-asts 'wrap) wrap-ast) 606 | ;; flat-map-ast (lookup-proto-fn-ast 'flat-map type-num 2) 607 | ;; ;; TODO: Total hack 608 | ;; flat-map-ast (fr/evaluate flat-map-ast rename-new-sm) 609 | ;; _ (sm/assoc-in-val (list :inlined-asts 'flat-map) flat-map-ast) 610 | ;; :let [inline-map {'wrap wrap-ast 611 | ;; 'flat-map flat-map-ast}] 612 | ;; _ (sm/assoc-in-val (list :inliners type-num) inline-map)] 613 | ;; inline-map) 614 | ;; (sm/state-maybe :no-inliner)) 615 | ;; result (cond 616 | ;; (= :no-inliner inline-map) 617 | ;; (for [;; _ (debug :ast (fr/evaluate (.params ast) rwr/pprint)) 618 | ;; arg2 (fr/evaluate (second (.args (.params ast))) emit-c) 619 | ;; :let [args (list (list arg1 arg2) 620 | ;; (comp (.init arg1) (.init arg2)))] 621 | ;; result (call-static-fixed target args)] 622 | ;; (c-code (.c-val result) 623 | ;; (.init result) 624 | ;; (.decl result) 625 | ;; type-num)) 626 | 627 | ;; (for [;; _ (debug :old (fr/evaluate (second (.args (.params ast))) rwr/pprint)) 628 | ;; new-ast (fr/evaluate (second (.args (.params ast))) inline-fn) 629 | ;; ;; _ (debug :type-num type-num :new (fr/evaluate new-ast rwr/pprint)) 630 | 631 | ;; arg2 (fr/evaluate new-ast emit-c) 632 | ;; :let [args (list (list arg1 arg2) 633 | ;; (comp (.init arg1) (.init arg2)))] 634 | ;; result (call-static-fixed target args)] 635 | ;; (c-code (.c-val result) 636 | ;; (.init result) 637 | ;; (.decl result) 638 | ;; type-num)))] 639 | ;; result) 640 | 641 | ;; (emit-callsite ast))) 642 | 643 | ;; CallingLet 644 | ;; (calling-let [ast] 645 | ;; (cond 646 | ;; (instance? ast/let-ast (.v (.callee ast))) 647 | ;; (let [bindings (.bindings (.v (.callee ast))) 648 | ;; ;; TODO: currently assumes .body has one element 649 | ;; body-expr (first (.args (.body (.v (.callee ast)))))] 650 | ;; ;; (print-err :calling-let (fr/evaluate (fr/free ast) rwr/pprint)) 651 | ;; (for [call-ast (cond 652 | ;; (instance? ast/cond-ast (.v body-expr)) 653 | ;; (let [cond-ast (.v body-expr)] 654 | ;; (for [default (fr/evaluate (fr/free (ast/call-ast (.default cond-ast) 655 | ;; (.params ast))) 656 | ;; calling-let) 657 | ;; default (fr/evaluate default merge-lets) 658 | ;; clauses (traverse (.clauses cond-ast) 659 | ;; (fn [clause] 660 | ;; (let [test (car clause) 661 | ;; action (car (cdr clause))] 662 | ;; (for [new-action (fr/evaluate (fr/free 663 | ;; (ast/call-ast action 664 | ;; (.params ast))) 665 | ;; calling-let) 666 | ;; new-action (fr/evaluate new-action merge-lets)] 667 | ;; (list test new-action)))))] 668 | ;; (fr/free (ast/cond-ast clauses default)))) 669 | 670 | ;; (not (instance? ast/call-ast (.v body-expr))) 671 | ;; (fr/evaluate (fr/free (ast/call-ast body-expr (.params ast))) 672 | ;; calling-let) 673 | 674 | ;; (not (instance? ast/symbol-ast (.v (.callee (.v body-expr))))) 675 | ;; (sm/state-maybe (fr/free ast)) 676 | 677 | ;; (not (= 'sm/new-sm (.sym (.v (.callee (.v body-expr)))))) 678 | ;; (sm/state-maybe (fr/free ast)) 679 | 680 | ;; (fn-to-let (first (.args (.params (.v body-expr)))) 681 | ;; (.args (.params ast))))] 682 | ;; (cond 683 | ;; (not (instance? fr/free call-ast)) 684 | ;; (fr/free (ast/let-ast bindings (apply-to list call-ast))) 685 | 686 | ;; (not (instance? ast/let-ast (.v call-ast))) 687 | ;; (fr/free (ast/let-ast bindings (apply-to list call-ast))) 688 | 689 | ;; (fr/free (ast/let-ast (apply* (fr/free list) 690 | ;; (comp (.args bindings) 691 | ;; (.args (.bindings (.v call-ast))))) 692 | ;; (.body (.v call-ast))))))) 693 | 694 | ;; (rwr/apply-rewrite ast calling-let))) 695 | 696 | ;; InlineFunction 697 | ;; (inline-fn [ast] 698 | ;; (cond 699 | ;; (not (instance? ast/symbol-ast (.v (.callee ast)))) 700 | ;; (rwr/apply-rewrite ast inline-fn) 701 | 702 | ;; (for [inlined-ast (sm/get-in-val (list :inlined-asts (.sym (.v (.callee ast)))) :not-found) 703 | ;; new-ast (cond 704 | ;; (= :not-found inlined-ast) 705 | ;; (rwr/apply-rewrite ast inline-fn) 706 | 707 | ;; (= 'flat-map (.sym (.v (.callee ast)))) 708 | ;; (for [new-ast (fr/evaluate (second (.args (.params ast))) inline-fn) 709 | ;; new-ast (fn-to-let inlined-ast (list (first (.args (.params ast))) new-ast))] 710 | ;; new-ast) 711 | 712 | ;; (for [args (fr/evaluate (.params ast) inline-fn) 713 | ;; new-ast (fn-to-let inlined-ast args)] 714 | ;; new-ast))] 715 | ;; new-ast))) 716 | 717 | ;; ) 718 | -------------------------------------------------------------------------------- /core/ast.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns fr (module "core/free.toc")) 3 | 4 | (deftype inline-ast [txt result-type]) 5 | 6 | (defn inline-text [text return-type] 7 | (fr/free (inline-ast text return-type))) 8 | 9 | (deftype symbol-ast [sym] 10 | Stringable 11 | (string-list [f] (list ""))) 12 | 13 | (defn sym [s] 14 | (fr/free (symbol-ast s))) 15 | 16 | (deftype keyword-ast [kw] 17 | Stringable 18 | (string-list [_] 19 | (list ""))) 20 | 21 | (defn kw [k] 22 | (fr/free (keyword-ast k))) 23 | 24 | (deftype const-number-ast [num] 25 | Stringable 26 | (string-list [_] (list (str num)))) 27 | 28 | (defn number [n] 29 | (fr/free (const-number-ast n))) 30 | 31 | (deftype const-string-ast [const-str] 32 | Stringable 33 | (string-list [_] (list ""))) 61 | 62 | (defn match-expr [value clauses default] 63 | (fr/free (match-ast value clauses default))) 64 | 65 | (deftype reify-ast [impls]) 66 | 67 | (defn reified [impls] 68 | (fr/free (reify-ast impls))) 69 | 70 | (deftype protocol-ast [protocol-name prototypes]) 71 | 72 | (defn proto [name proto-fns] 73 | (fr/free (protocol-ast name proto-fns))) 74 | 75 | (deftype call-ast [callee params] 76 | Stringable 77 | (string-list [_] 78 | (list ""))) 79 | 80 | (defn call-expr [target params] 81 | (fr/free (call-ast target 82 | (apply* (fr/free list) params)))) 83 | 84 | (deftype binding-ast [binding val] 85 | Stringable 86 | (string-list [_] 87 | (list ""))) 88 | 89 | (defn binding [binding val] 90 | (fr/free (binding-ast binding val))) 91 | 92 | (deftype let-ast [bindings body] 93 | Stringable 94 | (string-list [_] 95 | (list ""))) 96 | 97 | (defn let-expr [bindings body] 98 | (fr/free (let-ast (apply* (fr/free list) bindings) 99 | (apply* (fr/free list) body)))) 100 | 101 | (deftype quoted-ast [q-val] 102 | Stringable 103 | (string-list [_] 104 | (list ""))) 105 | 106 | (defn quoted [q-val] 107 | (fr/free (quoted-ast q-val))) 108 | 109 | (deftype main-ast [args body]) 110 | 111 | (defn main-fn [args body] 112 | (fr/free (main-ast args (apply* (fr/free list) body)))) 113 | 114 | (deftype variadic-arity-ast [args body] 115 | Stringable 116 | (string-list [_] (list ""))) 117 | 118 | (defn variadic-arity [args body] 119 | (fr/free (variadic-arity-ast args (apply* (fr/free list) body)))) 120 | 121 | (deftype fn-arity-ast [args body] 122 | Stringable 123 | (string-list [_] (list ""))) 124 | 125 | (defn fixed-arity [args body] 126 | (fr/free (fn-arity-ast args (apply* (fr/free list) body)))) 127 | 128 | (deftype fn-ast [fn-name arities] 129 | Stringable 130 | (string-list [_] (list ""))) 131 | 132 | (defn fn-expr [name arities] 133 | (fr/free (fn-ast name (apply* (fr/free list) arities)))) 134 | 135 | (deftype declaration-ast [name]) 136 | 137 | (defn declare [name] 138 | (fr/free (declaration-ast name))) 139 | 140 | (deftype definition-ast [name value]) 141 | 142 | (defn def-expr [name value] 143 | (fr/free (definition-ast name value))) 144 | 145 | (deftype type-ast [name fields impls]) 146 | 147 | (defn type-expr [name fields impls] 148 | (fr/free (type-ast name (rest fields) impls))) 149 | -------------------------------------------------------------------------------- /core/error.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype error-value [v] 3 | Stringable 4 | (string-list [mv] 5 | (comp (list ""))) 8 | 9 | Functor 10 | (map [mv _] mv) 11 | 12 | Applicative 13 | (wrap [_ x] (error-value x)) 14 | (apply* [fv args] 15 | (match (filter args (fn [arg] (instance? error-value arg))) 16 | |List error| error 17 | fv)) 18 | 19 | Monad 20 | (flat-map [ev _] 21 | ev)) 22 | 23 | (def error 24 | (reify 25 | Type 26 | (instance? [_ mv] 27 | (instance? error-value mv)) 28 | 29 | Fn 30 | (invoke [_ v] 31 | (error-value v)))) 32 | 33 | (deftype valid-value [v] 34 | Stringable 35 | (string-list [mv] 36 | (comp (list ""))) 39 | 40 | Functor 41 | (map [mv f] 42 | (valid-value (f v))) 43 | 44 | Applicative 45 | (wrap [_ x] (valid-value x)) 46 | (apply* [fv args] 47 | (match (filter args (fn [arg] (instance? error-value arg))) 48 | |List error| error 49 | (valid-value (apply v (map args .v))))) 50 | 51 | Monad 52 | (flat-map [_ f] 53 | (f v))) 54 | 55 | (def valid 56 | (reify 57 | Type 58 | (instance? [_ mv] 59 | (instance? valid-value mv)) 60 | 61 | Fn 62 | (invoke [_ v] 63 | (valid-value v)))) 64 | 65 | (defn double [x] 66 | (* 2 x)) 67 | 68 | (defn check-int [x] 69 | (match (rem x 2) 70 | 0 (valid x) 71 | (error (str "Found odd int: " x)))) 72 | 73 | (main [_] 74 | ;; check the functor and applicative laws for valid-value 75 | (println :valid) 76 | (println :functor-1 (= (map (valid 5) identity) (valid 5))) 77 | (println :functor-2 (= (map (map (valid 2) inc) double) 78 | (map (valid 2) (comp inc double)))) 79 | (println :apply-1 (= (map (valid 5) inc) 80 | (apply-to inc (valid 5)))) 81 | (println :apply-2 (= (valid 5) (apply-to identity (valid 5)))) 82 | (let [v1 (valid "first ") 83 | v2 (valid "second ") 84 | v3 (valid "third")] 85 | (println :apply-3 (= (apply-to comp (apply-to comp v1 v2) v3) 86 | (apply-to comp v1 (apply-to comp v2 v3)) 87 | (apply-to comp v1 v2 v3)))) 88 | 89 | ;; check the functor and applicative laws for error-value 90 | (println) 91 | (println :error) 92 | (println :functor-1 (= (map (error 5) identity) (error 5))) 93 | (println :functor-2 (= (map (map (error 2) inc) double) 94 | (map (error 2) (comp inc double)))) 95 | (println :apply-1 (= (map (error 5) inc) 96 | (apply-to inc (error 5)))) 97 | (println :apply-2 (= (error 5) (apply-to identity (error 5)))) 98 | (let [v1 (error "first ") 99 | v2 (error "second ") 100 | v3 (error "third")] 101 | (println :apply-3 (= (apply-to comp (apply-to comp v1 v2) v3) 102 | (apply-to comp v1 (apply-to comp v2 v3)) 103 | (apply-to comp v1 v2 v3)))) 104 | 105 | ;; make sure an error-value will short circuit apply-to 106 | (println) 107 | (println :valid-error (= (error :some-error) 108 | (apply-to + (valid 8) (error :some-error) (valid 13)))) 109 | 110 | ;; error-value in action 111 | (let [good-ints (map (list 8 10 2 4 14) check-int) 112 | error-ints (map (list 8 3 2 5 14) check-int)] 113 | (println :sum-good-ints (apply* (valid +) good-ints)) 114 | (println :sum-error-ints (apply* (valid +) error-ints)))) 115 | -------------------------------------------------------------------------------- /core/file-io.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns st (module "core/stream.toc")) 3 | 4 | ;; This malloc's an Opaque pointer type that leaks 5 | (defn fopen-read [file-path] 6 | (inline-text 7 | "String *arg0Str = (String *)my_malloc(sizeof(String) + ((String *)arg0)->len + 5); 8 | arg0Str->type = StringType; 9 | if (arg0->type == StringType) 10 | snprintf(arg0Str->buffer, ((String *)arg0)->len + 1, \"%s\", ((String *)arg0)->buffer); 11 | else if (arg0->type == SubStringType) 12 | snprintf(arg0Str->buffer, ((String *)arg0)->len + 1, \"%s\", ((SubString *)arg0)->buffer); 13 | else { 14 | fprintf(stderr, \"\\ninvalid type for 'fopen'\\n\"); 15 | abort(); 16 | } 17 | 18 | Opaque *ptrVal = (Opaque *)my_malloc(sizeof(Opaque)); 19 | malloc_count--; 20 | ptrVal->type = OpaqueType; 21 | ptrVal->ptr = (void *)fopen(arg0Str->buffer, \"r\"); 22 | dec_and_free((Value *)arg0Str); 23 | return((Value *)ptrVal);\n")) 24 | 25 | (defn fclose [fptr] 26 | (inline-text 27 | "fseek((FILE *)((Opaque *)arg0)->ptr, ((Number *)arg0)->numVal, 0); 28 | incRef(arg0); 29 | return(arg0);\n")) 30 | 31 | (defn read-byte 32 | ([fptr offset] 33 | (inline-text 34 | "String *strVal = (String *)my_malloc(sizeof(String) + 2); 35 | fseek((FILE *)((Opaque *)arg0)->ptr, ((Number *)arg1)->numVal, 0); 36 | size_t bytesRead = fread(strVal->buffer, 1, 1, (FILE *)((Opaque *)arg0)->ptr); 37 | strVal->type = StringType; 38 | strVal->buffer[bytesRead] = 0;\n 39 | strVal->len = bytesRead; 40 | return((Value *)strVal);\n")) 41 | ([fptr] 42 | (inline-text 43 | "String *strVal = (String *)my_malloc(sizeof(String) + 2); 44 | size_t bytesRead = fread(strVal->buffer, 1, 1, (FILE *)((Opaque *)arg0)->ptr); 45 | strVal->type = StringType; 46 | strVal->buffer[bytesRead] = 0;\n 47 | strVal->len = bytesRead; 48 | return((Value *)strVal);\n"))) 49 | 50 | (defn file-stream [frdr] 51 | (st/stream (list frdr 0) 52 | (fn [strm-info] 53 | (m-first (read-byte frdr (second strm-info)))) 54 | (fn [strm-info] 55 | (list frdr (inc (second strm-info)))))) 56 | 57 | (defn close-stream [s] 58 | (fclose (first (.carrier s)))) 59 | -------------------------------------------------------------------------------- /core/free: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jduey/toccata/4917656927c7e164d5ed11db8198ae6a76cf40b1/core/free -------------------------------------------------------------------------------- /core/free.toc: -------------------------------------------------------------------------------- 1 | 2 | (defprotocol FreeEval 3 | (evaluate [free-val eval-free])) 4 | 5 | (def free) 6 | (def free-app) 7 | (def free-monad) 8 | 9 | (def free-zero 10 | (reify 11 | Stringable 12 | (string-list [_] (list "")) 13 | 14 | Eq 15 | (=* [x y] 16 | (type= x y)) 17 | 18 | Applicative 19 | (wrap [_ v] (free v)) 20 | (apply* [fv args] 21 | (free-app fv args)) 22 | 23 | Monad 24 | (flat-map [fv ff] 25 | (free-monad fv ff)) 26 | 27 | Monoid 28 | (zero [ev] ev) 29 | (comp* [_ mvs] mvs))) 30 | 31 | (deftype free-comp [alts] 32 | Stringable 33 | (string-list [_] 34 | (comp (list ""))) 37 | 38 | FreeEval 39 | (evaluate [free-val eval-free] 40 | (let [[alt & alts] alts] 41 | (comp* (evaluate alt eval-free) 42 | (map alts (fn [alt] 43 | (evaluate alt eval-free)))))) 44 | 45 | Applicative 46 | (wrap [_ v] (free v)) 47 | (apply* [fv args] 48 | (free-app fv args)) 49 | 50 | Monad 51 | (flat-map [fv ff] 52 | (free-monad fv ff)) 53 | 54 | Comonad 55 | (extract [_] alts) 56 | 57 | Monoid 58 | (zero [ev] free-zero) 59 | (comp* [mv mvs] 60 | (free-comp (cons mv mvs)))) 61 | 62 | (deftype free-app [fv args] 63 | Stringable 64 | (string-list [_] 65 | (comp (list ""))) 70 | 71 | FreeEval 72 | (evaluate [free-val eval-free] 73 | (let [args (map args (fn [arg] 74 | (evaluate arg eval-free))) 75 | f (evaluate fv eval-free)] 76 | (apply* f args))) 77 | 78 | Applicative 79 | (wrap [_ v] (free v)) 80 | (apply* [fv args] 81 | (free-app fv args)) 82 | 83 | Monad 84 | (flat-map [fv ff] 85 | (free-monad fv ff)) 86 | 87 | Comonad 88 | (extract [_] 89 | (list fv args)) 90 | 91 | Monoid 92 | (zero [ev] 93 | free-zero) 94 | (comp* [mv mvs] 95 | (free-comp (cons mv mvs)))) 96 | 97 | (deftype free-monad [fv ff] 98 | Stringable 99 | (string-list [_] 100 | (comp (list ""))) 105 | 106 | FreeEval 107 | (evaluate [free-val eval-free] 108 | (flat-map (evaluate fv eval-free) 109 | (fn [v] 110 | (evaluate (ff v) eval-free)))) 111 | 112 | Applicative 113 | (wrap [_ v] (free v)) 114 | (apply* [fv args] 115 | (free-app fv args)) 116 | 117 | Monad 118 | (flat-map [fv ff] 119 | (free-monad fv ff)) 120 | 121 | Monoid 122 | (zero [ev] 123 | free-zero) 124 | (comp* [mv mvs] 125 | (free-comp (cons mv mvs)))) 126 | 127 | (deftype free [v] 128 | Stringable 129 | (string-list [_] 130 | (comp (list ""))) 133 | 134 | FreeEval 135 | (evaluate [free-val eval-free] 136 | (eval-free v)) 137 | 138 | Functor 139 | (map [_ f] 140 | (free (f v))) 141 | 142 | Applicative 143 | (wrap [_ v] 144 | (free v)) 145 | (apply* [fv args] 146 | (free-app fv args)) 147 | 148 | Monad 149 | (flat-map [fv ff] 150 | (free-monad fv ff)) 151 | 152 | Comonad 153 | (extract [_] v) 154 | 155 | Monoid 156 | (zero [_] 157 | free-zero) 158 | (comp* [mv mvs] 159 | (free-comp (cons mv mvs)))) 160 | 161 | ;; (add-ns id (module "core/id.toc")) 162 | ;; (main [_] 163 | ;; (let [double (fn [x] 164 | ;; (* 2 x))] 165 | ;; ;; check the functor and applicative laws for free 166 | ;; (println :free) 167 | ;; (println :functor-1 (= (map (free 5) identity) (free 5))) 168 | ;; (println :functor-2 (= (map (map (free 2) inc) double) 169 | ;; (map (free 2) (comp inc double)))) 170 | ;; (println :apply-1 (= (evaluate (map (free 5) inc) id/id-m) 171 | ;; (evaluate (apply-to inc (free 5)) id/id-m))) 172 | ;; (println :apply-2 (= (evaluate (free 5) id/id-m) 173 | ;; (evaluate (apply-to identity (free 5)) id/id-m))) 174 | ;; (let [v1 (free "first ") 175 | ;; v2 (free "second ") 176 | ;; v3 (free "third")] 177 | ;; (println :apply-3 (= (evaluate (apply-to comp (apply-to comp v1 v2) v3) id/id-m) 178 | ;; (evaluate (apply-to comp v1 (apply-to comp v2 v3)) id/id-m) 179 | ;; (evaluate (apply-to comp v1 v2 v3) id/id-m)))) 180 | 181 | ;; (let [f-inc (fn [x] (free (inc x))) 182 | ;; f-dbl (fn [x] (free (double x)))] 183 | ;; (println :flat-map-1 (= (evaluate (flat-map (free 4) f-inc) id/id-m) 184 | ;; (evaluate (f-inc 4) id/id-m))) 185 | ;; (println :flat-map-2 (= (evaluate (flat-map (free 4) free) id/id-m) 186 | ;; (evaluate (free 4) id/id-m))) 187 | ;; (println :flat-map-3 (= (evaluate (flat-map (flat-map (free 4) f-inc) f-dbl) id/id-m) 188 | ;; (evaluate (flat-map (free 4) (fn [x] (flat-map (f-inc x) f-dbl))) id/id-m)))))) 189 | -------------------------------------------------------------------------------- /core/grammar.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns sm (module "core/state-maybe.toc")) 3 | (add-ns fr (module "core/free.toc")) 4 | (add-ns parser (module "core/parser.toc")) 5 | 6 | (deftype do-debug [tag] 7 | Parser 8 | (parser/recursive-descent [_] 9 | (for [text (parser/read-text)] 10 | (print-err tag (subs text 0 10))))) 11 | 12 | (defn debug [tag] 13 | (parser/ignore 14 | (parser/rule "debug" 15 | (fr/free (do-debug tag))))) 16 | 17 | (defn to-string [rule] 18 | (apply-to (fn [chars] 19 | (apply str chars)) 20 | rule)) 21 | 22 | (defn symbol-start [] 23 | (parser/rule "symbol-start" 24 | (comp (parser/alpha) (parser/one-of "._<>=+-*/")))) 25 | 26 | (defn symbol-punct [] 27 | (parser/rule "symbol-punct" 28 | (parser/one-of "._<>=*/+!-?"))) 29 | 30 | (defn symbol-char [] 31 | (parser/rule "symbol-char" 32 | (comp (parser/alpha) (parser/digit) (symbol-punct)))) 33 | 34 | (defn rest-of-symbol [] 35 | (parser/rule "rest-of-symbol" 36 | (parser/none-or-more (symbol-char)))) 37 | 38 | (defn read-symbol [] 39 | (parser/rule "symbol" 40 | (apply-to (fn [start the-rest] 41 | (symbol (apply str (cons start the-rest)))) 42 | (symbol-start) 43 | (rest-of-symbol)))) 44 | 45 | (defn read-keyword [] 46 | (parser/rule "keyword" 47 | (apply-to (fn [start the-rest] 48 | (keyword (apply str (cons start the-rest)))) 49 | (parser/ignore (parser/term ":")) 50 | (symbol-start) 51 | (rest-of-symbol)))) 52 | 53 | (defn backslash [] 54 | (parser/term (char 92))) 55 | 56 | (defn read-string-newline [] 57 | (parser/rule "newline" 58 | (parser/all (parser/ignore (backslash)) 59 | (parser/ignore (parser/term "n")) 60 | (parser/always (char 10))))) 61 | 62 | (defn read-string-tab [] 63 | (parser/rule "tab" 64 | (parser/all (parser/ignore (backslash)) 65 | (parser/ignore (parser/term "t")) 66 | (parser/always (char 9))))) 67 | 68 | (defn read-string-backspace [] 69 | (parser/rule "backspace" 70 | (parser/all (parser/ignore (backslash)) 71 | (parser/ignore (parser/term "b")) 72 | (parser/always (char 8))))) 73 | 74 | (defn read-string-return [] 75 | (parser/rule "return" 76 | (parser/all (parser/ignore (backslash)) 77 | (parser/ignore (parser/term "r")) 78 | (parser/always (char 13))))) 79 | 80 | (defn read-string-formfeed [] 81 | (parser/rule "formfeed" 82 | (parser/all (parser/ignore (backslash)) 83 | (parser/ignore (parser/term "f")) 84 | (parser/always (char 12))))) 85 | 86 | (defn read-string-doublequote [] 87 | (parser/rule "doublequote" 88 | (parser/all (parser/ignore (backslash)) 89 | (parser/ignore (parser/term (char 34))) 90 | (parser/always (char 34))))) 91 | 92 | (defn read-string-backslash [] 93 | (parser/rule "backslash" 94 | (parser/all (parser/ignore (backslash)) 95 | (parser/ignore (backslash)) 96 | (parser/always (char 92))))) 97 | 98 | (deftype parse-not-backslash [] 99 | Parser 100 | (parser/recursive-descent [_] 101 | (parser/char-test (fn [c] 102 | (match (or (=* (char 92) c) 103 | (=* (char 34) c)) 104 | nothing maybe1 105 | nothing))))) 106 | 107 | (defn not-backslash [] 108 | (parser/rule "not-backslash" 109 | (fr/free (parse-not-backslash)))) 110 | 111 | (defn read-const-string [] 112 | (parser/rule "string" 113 | (parser/all (parser/ignore (parser/term (char 34))) 114 | (to-string 115 | (parser/none-or-more 116 | (comp (not-backslash) 117 | (read-string-backslash) 118 | (read-string-doublequote) 119 | (read-string-tab) 120 | (read-string-backspace) 121 | (read-string-return) 122 | (read-string-formfeed) 123 | (read-string-newline)))) 124 | (parser/ignore (parser/term (char 34)))))) 125 | 126 | (defn str-to-int [int-str] 127 | (let [code-0 (char-code "0")] 128 | (reduce int-str 0 129 | (fn [n c] 130 | (+ (* n 10) (- (char-code c) code-0)))))) 131 | 132 | ;; only reads integers 133 | (defn read-number [] 134 | (parser/rule "number" 135 | (comp 136 | (apply-to str-to-int 137 | (parser/one-or-more (parser/digit))) 138 | (apply-to (fn [digits] 139 | (* -1 (str-to-int digits))) 140 | (parser/ignore (parser/term "-")) 141 | (parser/one-or-more (parser/digit)))))) 142 | 143 | (deftype parse-sub-form [] 144 | Parser 145 | (parser/recursive-descent [_] 146 | (for [parser-fn (sm/get-in-val (list :parser-fns "form")) 147 | result (sm/new-sm parser-fn)] 148 | result))) 149 | 150 | (defn read-sub-form [] 151 | (parser/rule "form" 152 | (fr/free (parse-sub-form)))) 153 | 154 | (defn read-quoted [] 155 | (parser/rule "quoted" 156 | (apply-to (fn [arg] 157 | (list 'quote arg)) 158 | (parser/ignore (parser/term "'")) 159 | (read-sub-form)))) 160 | 161 | (defn read-list [] 162 | (parser/rule "list" 163 | (parser/all (parser/ignore (parser/term "(")) 164 | (parser/none-or-more (read-sub-form)) 165 | (parser/ignore (parser/term ")"))))) 166 | 167 | (defn read-hash-map [] 168 | (parser/rule "hash-map" 169 | (apply-to (partial cons 'hash-map) 170 | (parser/ignore (parser/term "{")) 171 | (parser/none-or-more (read-sub-form)) 172 | (parser/ignore (parser/term "}"))))) 173 | 174 | (defn read-vector [] 175 | (parser/rule "vector" 176 | (apply-to (partial cons 'vector) 177 | (parser/ignore (parser/term "[")) 178 | (parser/none-or-more (read-sub-form)) 179 | (parser/ignore (parser/term "]"))))) 180 | 181 | (deftype parse-not-eol [] 182 | Parser 183 | (parser/recursive-descent [_] 184 | (parser/char-test (fn [c] 185 | (match (=* (char 10) c) 186 | nothing maybe1 187 | nothing))))) 188 | 189 | (defn not-eol [] 190 | (parser/rule "not-eol" 191 | (fr/free (parse-not-eol)))) 192 | 193 | (defn read-comment [] 194 | (parser/rule "comment" 195 | (parser/all (parser/term ";") 196 | (parser/ignore (parser/none-or-more (not-eol))) 197 | (parser/term (char 10))))) 198 | 199 | (defn whitespace [] 200 | (parser/rule "whitespace" 201 | (comp (parser/one-of " ,") 202 | (parser/term (char 9)) 203 | (parser/term (char 13)) 204 | (parser/term (char 10)) 205 | (read-comment)))) 206 | 207 | (deftype parse-destructure [] 208 | Parser 209 | (parser/recursive-descent [_] 210 | (for [parser-fn (sm/get-in-val (list :parser-fns "destructure")) 211 | result (sm/new-sm parser-fn)] 212 | result))) 213 | 214 | (defn read-sub-dest [] 215 | (parser/rule "destructure" 216 | (fr/free (parse-destructure)))) 217 | 218 | (defn read-arg [] 219 | (parser/rule "arg" 220 | (parser/all (parser/ignore (parser/none-or-more (whitespace))) 221 | (read-symbol) 222 | (parser/ignore (parser/none-or-more (whitespace)))))) 223 | 224 | (defn read-var-arg [] 225 | (parser/rule "var-arg" 226 | (apply-to list 227 | (parser/ignore (parser/none-or-more (whitespace))) 228 | (parser/term "&") 229 | (read-arg)))) 230 | 231 | (defn read-list-destructure [] 232 | (parser/rule "list-destructure" 233 | (apply-to (fn [args tail] 234 | (comp args (remove tail (partial = "&")))) 235 | (parser/ignore (parser/none-or-more (whitespace))) 236 | (parser/ignore (parser/term "[")) 237 | (parser/none-or-more (read-sub-dest)) 238 | (comp (read-var-arg) 239 | (parser/always (list :no-tail))) 240 | (parser/ignore (parser/term "]"))))) 241 | 242 | (defn read-destructure [] 243 | (parser/recursive-rule "destructure" 244 | (comp 245 | (read-list-destructure) 246 | (read-arg)))) 247 | 248 | (defn read-args [] 249 | (parser/rule "args" 250 | (apply-to comp 251 | (parser/ignore (parser/none-or-more (whitespace))) 252 | (parser/ignore (parser/term "[")) 253 | (parser/none-or-more (read-destructure)) 254 | (comp (read-var-arg) 255 | (parser/always empty-list)) 256 | (parser/ignore (parser/term "]"))))) 257 | 258 | (defn read-main [] 259 | (parser/rule "main" 260 | (apply-to (partial list* 'main) 261 | (parser/ignore (parser/term "(")) 262 | (parser/ignore (parser/none-or-more (whitespace))) 263 | (parser/ignore (parser/term "main")) 264 | (parser/ignore (parser/one-or-more (whitespace))) 265 | (read-args) 266 | (parser/one-or-more (read-sub-form)) 267 | (parser/ignore (parser/none-or-more (whitespace))) 268 | (parser/ignore (parser/term ")"))))) 269 | 270 | (defn read-single-arity [] 271 | (parser/rule "single-arity" 272 | (apply-to (fn [& vs] 273 | (list (cons 'fn-arity vs))) 274 | (read-args) 275 | (parser/none-or-more (read-sub-form))))) 276 | 277 | (defn read-multi-arity [] 278 | (parser/rule "multi-arity" 279 | (apply-to (partial list 'fn-arity) 280 | (parser/ignore (parser/none-or-more (whitespace))) 281 | (parser/ignore (parser/term "(")) 282 | (parser/ignore (parser/none-or-more (whitespace))) 283 | (read-args) 284 | (parser/none-or-more (read-sub-form)) 285 | (parser/ignore (parser/none-or-more (whitespace))) 286 | (parser/ignore (parser/term ")"))))) 287 | 288 | (defn read-arities [] 289 | (parser/rule "arities" 290 | (comp (read-single-arity) 291 | (parser/one-or-more (read-multi-arity))))) 292 | 293 | (defn read-defn [] 294 | (parser/rule "defn" 295 | (apply-to (fn [name arities] 296 | (list 'def name (list 'fn name arities))) 297 | (parser/ignore (parser/term "(")) 298 | (parser/ignore (parser/none-or-more (whitespace))) 299 | (parser/ignore (parser/term "defn")) 300 | (parser/ignore (parser/one-or-more (whitespace))) 301 | (read-symbol) 302 | (parser/ignore (parser/one-or-more (whitespace))) 303 | (read-arities) 304 | (parser/ignore (parser/none-or-more (whitespace))) 305 | (parser/ignore (parser/term ")"))))) 306 | 307 | (defn read-fn [] 308 | (parser/rule "fn" 309 | (apply-to (partial list 'fn) 310 | (parser/ignore (parser/term "(")) 311 | (parser/ignore (parser/none-or-more (whitespace))) 312 | (parser/ignore (parser/term "fn")) 313 | (parser/ignore (parser/one-or-more (whitespace))) 314 | (comp (read-symbol) 315 | (parser/always 'anon)) 316 | (parser/ignore (parser/none-or-more (whitespace))) 317 | (read-arities) 318 | (parser/ignore (parser/none-or-more (whitespace))) 319 | (parser/ignore (parser/term ")"))))) 320 | 321 | (defn read-fields [] 322 | (parser/rule "type-fields" 323 | (apply-to (partial list* 'vector) 324 | (parser/ignore (parser/term "[")) 325 | (parser/none-or-more (read-symbol)) 326 | (parser/ignore (parser/term "]"))))) 327 | 328 | ;; (defn read-restricted-symbol [] 329 | ;; (parser/rule "type-name" 330 | ;; (apply-to (fn [chars] 331 | ;; (symbol (apply str chars))) 332 | ;; (parser/one-or-more (parser/alpha))))) 333 | 334 | ;; (defn read-deftype [] 335 | ;; (parser/rule "deftype" 336 | ;; (apply-to (partial list* 'deftype) 337 | ;; (parser/ignore (parser/term "(")) 338 | ;; (parser/ignore (parser/none-or-more (whitespace))) 339 | ;; (parser/ignore (parser/term "deftype")) 340 | ;; (parser/ignore (parser/one-or-more (whitespace))) 341 | ;; (read-restricted-symbol) 342 | ;; (parser/ignore (parser/one-or-more (whitespace))) 343 | ;; (read-fields) 344 | ;; (parser/none-or-more (read-sub-form)) 345 | ;; (parser/ignore (parser/term ")"))))) 346 | 347 | (defn read-let-binding [] 348 | (parser/rule "let-binding" 349 | (apply-to list 350 | (parser/ignore (parser/none-or-more (whitespace))) 351 | (read-destructure) 352 | (parser/ignore (parser/none-or-more (whitespace))) 353 | (read-sub-form)))) 354 | 355 | (defn read-let [] 356 | (parser/rule "let" 357 | (apply-to (partial list* 'let) 358 | (parser/ignore (parser/term "(")) 359 | (parser/ignore (parser/none-or-more (whitespace))) 360 | (parser/ignore (parser/term "let")) 361 | (parser/ignore (parser/one-or-more (whitespace))) 362 | (parser/ignore (parser/term "[")) 363 | (parser/none-or-more (read-let-binding)) 364 | (parser/ignore (parser/term "]")) 365 | (parser/one-or-more (read-sub-form)) 366 | (parser/ignore (parser/none-or-more (whitespace))) 367 | (parser/ignore (parser/term ")"))))) 368 | 369 | (defn read-for-let [] 370 | (parser/rule "for-let" 371 | (apply-to (partial list :let) 372 | (parser/ignore (parser/none-or-more (whitespace))) 373 | (parser/ignore (parser/term ":let")) 374 | (parser/ignore (parser/one-or-more (whitespace))) 375 | (parser/ignore (parser/term "[")) 376 | (parser/none-or-more (read-let-binding)) 377 | (parser/ignore (parser/term "]"))))) 378 | 379 | (defn read-for-when [] 380 | (parser/rule "for-when" 381 | (apply-to (partial list :when) 382 | (parser/ignore (parser/none-or-more (whitespace))) 383 | (parser/ignore (parser/term ":when")) 384 | (parser/ignore (parser/one-or-more (whitespace))) 385 | (read-sub-form)))) 386 | 387 | (defn read-for-when-not [] 388 | (parser/rule "for-when-not" 389 | (apply-to (partial list :when-not) 390 | (parser/ignore (parser/none-or-more (whitespace))) 391 | (parser/ignore (parser/term ":when-not")) 392 | (parser/ignore (parser/one-or-more (whitespace))) 393 | (read-sub-form)))) 394 | 395 | (defn read-for-binding [] 396 | (parser/rule "for-binding" 397 | (comp (read-for-let) 398 | (read-for-when) 399 | (read-for-when-not) 400 | (read-let-binding)))) 401 | 402 | (defn read-for [] 403 | (parser/rule "for" 404 | (apply-to (fn [bound val bindings body] 405 | (let [wrap-sym (gensym "wrapper_") 406 | bindings (cons (list bound wrap-sym) bindings)] 407 | (list 'let (list (list wrap-sym val)) 408 | (reduce (reverse bindings) (list 'wrap wrap-sym body) 409 | (fn [expr for-clause] 410 | (match for-clause 411 | |List :let val| (list 'let val expr) 412 | |List :when val| (list 'cond val expr 413 | (list 'zero wrap-sym)) 414 | |List :when-not val| (list 'cond (list '=* 'nothing val) 415 | expr (list 'zero wrap-sym)) 416 | (list 'flat-map (second for-clause) 417 | (list 'fn 'anon 418 | (list (list 'fn-arity 419 | (list (first for-clause)) 420 | (list expr))))))))))) 421 | (parser/ignore (parser/term "(")) 422 | (parser/ignore (parser/none-or-more (whitespace))) 423 | (parser/ignore (parser/term "for")) 424 | (parser/ignore (parser/one-or-more (whitespace))) 425 | (parser/ignore (parser/term "[")) 426 | (read-destructure) 427 | (read-sub-form) 428 | (parser/none-or-more (read-for-binding)) 429 | (parser/ignore (parser/term "]")) 430 | (read-sub-form) 431 | (parser/ignore (parser/none-or-more (whitespace))) 432 | (parser/ignore (parser/term ")"))))) 433 | 434 | (defn read-and [] 435 | (parser/rule "and" 436 | (apply-to (fn [exprs] 437 | (let [exprs (reverse exprs)] 438 | (reduce (rest exprs) 439 | (first exprs) 440 | (fn [final-expr and-clause] 441 | (list 'cond and-clause final-expr 442 | 'nothing))))) 443 | (parser/ignore (parser/term "(")) 444 | (parser/ignore (parser/none-or-more (whitespace))) 445 | (parser/ignore (parser/term "and")) 446 | (parser/ignore (parser/one-or-more (whitespace))) 447 | (parser/one-or-more (read-sub-form)) 448 | (parser/ignore (parser/term ")"))))) 449 | 450 | (defn read-or [] 451 | (parser/rule "or" 452 | (apply-to (fn [exprs] 453 | (let [exprs (reverse exprs)] 454 | (reduce (rest exprs) 455 | (first exprs) 456 | (fn [final-expr or-clause] 457 | (let [or-sym (gensym "or-")] 458 | (list 'let (list (list or-sym or-clause)) 459 | (list 'cond or-sym or-sym final-expr))))))) 460 | (parser/ignore (parser/term "(")) 461 | (parser/ignore (parser/none-or-more (whitespace))) 462 | (parser/ignore (parser/term "or")) 463 | (parser/ignore (parser/one-or-more (whitespace))) 464 | (parser/one-or-more (read-sub-form)) 465 | (parser/ignore (parser/term ")"))))) 466 | 467 | (defn read-apply [] 468 | (parser/rule "apply" 469 | (apply-to (fn [f args] 470 | (list 'apply* f (cons 'list args))) 471 | (parser/ignore (parser/term "(")) 472 | (parser/ignore (parser/none-or-more (whitespace))) 473 | (parser/ignore (parser/term "apply")) 474 | (parser/ignore (parser/one-or-more (whitespace))) 475 | (read-sub-form) 476 | (parser/one-or-more (read-sub-form)) 477 | (parser/ignore (parser/none-or-more (whitespace))) 478 | (parser/ignore (parser/term ")"))))) 479 | 480 | (defn read-apply-to [] 481 | (parser/rule "apply-to" 482 | (apply-to (fn [f arg args] 483 | (let [wrap-sym (gensym "wrapper_") 484 | msg (str (list 'apply-to f arg args)) 485 | r (list 'let (list (list wrap-sym arg)) 486 | (list 'print-err msg) 487 | (list 488 | (list 'apply* (list 'wrap wrap-sym f) 489 | (cons 'list (cons wrap-sym args)))))] 490 | (list 'let (list (list wrap-sym arg)) 491 | (list 'apply* (list 'wrap wrap-sym f) 492 | (cons 'list (cons wrap-sym args)))))) 493 | (parser/ignore (parser/term "(")) 494 | (parser/ignore (parser/none-or-more (whitespace))) 495 | (parser/ignore (parser/term "apply-to")) 496 | (parser/ignore (parser/one-or-more (whitespace))) 497 | (read-sub-form) 498 | (read-sub-form) 499 | (parser/none-or-more (read-sub-form)) 500 | (parser/ignore (parser/none-or-more (whitespace))) 501 | (parser/ignore (parser/term ")"))))) 502 | 503 | (defn read-comp [] 504 | (parser/rule "comp" 505 | (apply-to (fn [arg args] 506 | (list 'comp* arg (cons 'list args))) 507 | (parser/ignore (parser/term "(")) 508 | (parser/ignore (parser/none-or-more (whitespace))) 509 | (parser/ignore (parser/term "comp")) 510 | (parser/ignore (parser/one-or-more (whitespace))) 511 | (read-sub-form) 512 | (parser/none-or-more (read-sub-form)) 513 | (parser/ignore (parser/none-or-more (whitespace))) 514 | (parser/ignore (parser/term ")"))))) 515 | 516 | (defn read-pattern [] 517 | (parser/rule "match-pattern" 518 | (apply-to (fn [pattern-type args-head args-tail] 519 | (comp (cons pattern-type args-head) 520 | args-tail)) 521 | (parser/ignore (parser/term "|")) 522 | (parser/ignore (parser/none-or-more (whitespace))) 523 | (read-symbol) 524 | (parser/ignore (parser/none-or-more (whitespace))) 525 | (parser/none-or-more (parser/all 526 | (comp (read-symbol) 527 | (read-keyword) 528 | (read-const-string) 529 | (read-number) 530 | (read-quoted)) 531 | (parser/ignore (parser/none-or-more (whitespace))))) 532 | (comp (read-var-arg) 533 | (parser/always empty-list)) 534 | (parser/ignore (parser/term "|"))))) 535 | 536 | (defn read-match [] 537 | (parser/rule "match" 538 | (apply-to (partial list 'match) 539 | (parser/ignore (parser/term "(")) 540 | (parser/ignore (parser/none-or-more (whitespace))) 541 | (parser/ignore (parser/term "match")) 542 | (parser/ignore (parser/one-or-more (whitespace))) 543 | (read-sub-form) 544 | (parser/one-or-more (apply-to list 545 | (comp 546 | (read-pattern) 547 | (read-const-string) 548 | (read-symbol) 549 | (read-keyword) 550 | (read-quoted) 551 | (read-number)) 552 | (read-sub-form))) 553 | (comp (read-sub-form) 554 | (parser/always 'nothing)) 555 | (parser/ignore (parser/term ")"))))) 556 | 557 | (defn read-form [] 558 | (parser/recursive-rule "form" 559 | (parser/all (parser/ignore (parser/none-or-more (whitespace))) 560 | (comp (read-number) 561 | (read-match) 562 | (read-keyword) 563 | (read-symbol) 564 | (read-quoted) 565 | (read-const-string) 566 | (read-let) 567 | (read-main) 568 | (read-defn) 569 | (read-fn) 570 | (read-for) 571 | (read-comp) 572 | (read-apply) 573 | (read-apply-to) 574 | (read-hash-map) 575 | (read-vector) 576 | (read-or) 577 | (read-and) 578 | (read-list)) 579 | (parser/ignore (parser/none-or-more (whitespace)))))) 580 | 581 | -------------------------------------------------------------------------------- /core/id.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype id-m [x] 3 | Stringable 4 | (string-list [_] 5 | (list "")) 8 | 9 | Functor 10 | (map [_ f] 11 | (id-m (f x))) 12 | 13 | Applicative 14 | (wrap [_ v] (id-m v)) 15 | (apply* [_ args] 16 | (id-m (apply x (map args .x)))) 17 | 18 | Monad 19 | (flat-map [_ f] 20 | (f x))) 21 | -------------------------------------------------------------------------------- /core/logic-programming.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns f (module "core/free.toc")) 3 | (add-ns s (module "core/state.toc")) 4 | 5 | (deftype Unify [x y]) 6 | 7 | (defn == [x y] 8 | (f/free (Unify x y))) 9 | 10 | 11 | (deftype Fail []) 12 | 13 | (defn fail [] 14 | (f/free (Fail))) 15 | 16 | 17 | (defn all [& clauses] 18 | (apply* (f/free list) clauses)) 19 | 20 | (defn conde [clause & clauses] 21 | (comp* clause clauses)) 22 | 23 | 24 | (deftype LVar [sym] 25 | Eq 26 | (=* [x y] 27 | (number= x y)) 28 | 29 | Stringable 30 | (string-list [v] (list (str sym))) 31 | 32 | Hash 33 | (sha1 [_] 34 | (sha1 sym))) 35 | 36 | (defn lvar [] 37 | (LVar (gensym "lvar_"))) 38 | 39 | 40 | (deftype EagerGoal [prog-fn] 41 | Function 42 | (invoke [_ s] 43 | (prog-fn s)) 44 | 45 | Monoid 46 | (comp* [p ps] 47 | (let [ps (cons p ps)] 48 | (EagerGoal (fn [s] 49 | (apply comp (map ps (fn [p] 50 | (p s)))))))) 51 | 52 | Applicative 53 | (apply* [_ ps] 54 | (EagerGoal (fn [s] 55 | (reduce ps (list s) 56 | (fn [ss p] 57 | (apply comp (map ss p)))))))) 58 | 59 | (deftype LazyGoal [prog-fn] 60 | Function 61 | (invoke [_ s] 62 | (prog-fn s)) 63 | 64 | Monoid 65 | (comp* [p ps] 66 | (LazyGoal (fn [s] 67 | :bogus))) 68 | 69 | Applicative 70 | (apply* [_ ps] 71 | (LazyGoal (fn [s] 72 | :bogus)))) 73 | 74 | (deftype CPSGoal [f] 75 | Stringable 76 | (string-list [_] 77 | (list "")) 78 | 79 | Function 80 | (invoke [_ s] 81 | (f s)) 82 | 83 | Monoid 84 | (comp* [p ps] 85 | (let [ps (cons p ps)] 86 | (CPSGoal (fn comp*-s [s] 87 | (fn comp*-c [c] 88 | (fn comp*-l 89 | ([l] 90 | (cond 91 | (= :fail s) ((c s) l) 92 | (let [mapped (map ps (fn [p] 93 | ((p s) c)))] 94 | (reduce mapped l 95 | (fn [l m] 96 | (m l)))))) 97 | ([n l] 98 | (cond 99 | (= :fail s) ((c s) l) 100 | (let [mapped (map ps (fn [p] 101 | ((p s) c)))] 102 | (reduce mapped l 103 | (fn [l m] 104 | (cond 105 | (< (count l) n) (m n l) 106 | l)))))))))))) 107 | 108 | Applicative 109 | (apply* [_ ps] 110 | (CPSGoal (fn apply*-s [s] 111 | (fn apply*-c [c] 112 | (cond 113 | (= :fail s) (c s) 114 | ((reduce (reverse ps) c 115 | (fn [c p] 116 | (fn [s] 117 | ((p s) c)))) 118 | s))))))) 119 | 120 | (defprotocol LogicProgram 121 | (eager-goal [_]) 122 | (lazy-goal [_]) 123 | (cps-goal [_]) 124 | (parallel-goal [_])) 125 | 126 | (extend-type Function 127 | LogicProgram 128 | (eager-goal [f] 129 | (EagerGoal f)) 130 | 131 | (cps-goal [f] 132 | (CPSGoal f))) 133 | 134 | (extend-type Unify 135 | Stringable 136 | (string-list [u] 137 | (list "(== " (str (.x u)) 138 | " " (str (.y u)) ")")) 139 | 140 | LogicProgram 141 | (eager-goal [u] 142 | (EagerGoal (fn [s] 143 | (cond 144 | (instance? LVar (.x u)) (list (assoc s (.x u) (.y u))) 145 | (instance? LVar (.y u)) (list (assoc s (.y u) (.x u))) 146 | (= (.x u) (.y u)) (list s) 147 | empty-list)))) 148 | (cps-goal [u] 149 | (CPSGoal (fn unify-s [s] 150 | (let [new-s (cond 151 | (= :fail s) s 152 | (instance? LVar (.x u)) (assoc s (.x u) (.y u)) 153 | (instance? LVar (.y u)) (assoc s (.y u) (.x u)) 154 | (= (.x u) (.y u)) s 155 | :fail)] 156 | (fn unify-c [c] 157 | (c new-s))))))) 158 | 159 | 160 | (extend-type Fail 161 | LogicProgram 162 | (eager-goal [_] 163 | (EagerGoal (fn [s] empty-list))) 164 | (cps-goal [_] 165 | (CPSGoal (fn fail-s [s] 166 | (fn fail-c [c] 167 | (c :fail)))))) 168 | 169 | 170 | (defn walk [s lv] 171 | (cond 172 | (seq? lv) (map lv (partial walk s)) 173 | (instance? LVar lv) (let [v (get s lv '_)] 174 | (cond 175 | (instance? LVar v) (walk s v) 176 | (seq? v) (map v (partial walk s)) 177 | v)) 178 | lv)) 179 | 180 | (defn run 181 | ([q p] 182 | (let [goal (apply* (CPSGoal :ignore) 183 | (list (f/evaluate p cps-goal) 184 | (CPSGoal (fn tail-s [s] 185 | (fn tail-c [c] 186 | (fn tail-l [l] 187 | (cond 188 | (= :fail s) l 189 | (cons (walk s q) l))))))))] 190 | (((goal {}) identity) empty-list))) 191 | ([n q p] 192 | (let [goal (apply* (CPSGoal :ignore) 193 | (list (f/evaluate p cps-goal) 194 | (CPSGoal (fn tail-s [s] 195 | (fn tail-c [c] 196 | (fn tail-l [n l] 197 | (cond 198 | (= :fail s) l 199 | (< (count l) n) (cons (walk s q) l) 200 | l)))))))] 201 | (((goal {}) identity) n empty-list)))) 202 | -------------------------------------------------------------------------------- /core/parser.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns sm (module "core/state-maybe.toc")) 3 | (add-ns fr (module "core/free.toc")) 4 | (add-ns st (module "core/state.toc")) 5 | 6 | ;; this function gets caled A LOT so needs to be super fast 7 | (defn read-text [] 8 | (sm/new-sm (fn [s] 9 | (list (get* s :text "" (sha1 :text) 0) s)))) 10 | 11 | (defprotocol Parser 12 | (recursive-descent [f] 13 | (sm/state-maybe (fn [& args] 14 | (list (apply f (map (remove args list-empty?) 15 | first))))))) 16 | 17 | (deftype parser-terminal [term-str] 18 | Parser 19 | (recursive-descent [_] 20 | (let [term-count (count term-str)] 21 | (for [text (read-text) 22 | :when-not (< (count text) term-count) 23 | :when (= (subs text 0 term-count) term-str) 24 | _ (sm/set-val :text (subs text term-count))] 25 | (list term-str))))) 26 | 27 | (defn term [term-str] 28 | (fr/free (parser-terminal term-str))) 29 | 30 | (deftype repeat-rule [rule] 31 | Parser 32 | (recursive-descent [_] 33 | (let [rule (fr/evaluate rule recursive-descent)] 34 | (flat-map (sm/recur rule) 35 | (fn [[head & tail]] 36 | (sm/state-maybe (list (comp* head tail)))))))) 37 | 38 | (defn one-or-more [rule] 39 | (fr/free (repeat-rule rule))) 40 | 41 | (deftype ignore-rule [rule] 42 | Parser 43 | (recursive-descent [_] 44 | (flat-map (fr/evaluate rule recursive-descent) 45 | (fn [_] 46 | (sm/state-maybe empty-list))))) 47 | 48 | (defn ignore [rule] 49 | (fr/free (ignore-rule rule))) 50 | 51 | (deftype parser-always [v] 52 | Parser 53 | (recursive-descent [_] 54 | (sm/state-maybe (list v)))) 55 | 56 | (defn always [v] 57 | (fr/free (parser-always v))) 58 | 59 | (defn all [& rules] 60 | (apply* (fr/free comp) rules)) 61 | 62 | (deftype optional-rule [rule] 63 | Parser 64 | (recursive-descent [_] 65 | (comp (fr/evaluate rule recursive-descent) 66 | (recursive-descent (parser-always ""))))) 67 | 68 | (defn optional [rule] 69 | (fr/free (optional-rule rule))) 70 | 71 | (deftype none-or-more-rule [rule] 72 | Parser 73 | (recursive-descent [_] 74 | (comp (recursive-descent (repeat-rule rule)) 75 | (recursive-descent (parser-always empty-list))))) 76 | 77 | (defn none-or-more [rule] 78 | (fr/free (none-or-more-rule rule))) 79 | 80 | (deftype parser-rule [name grammar] 81 | Parser 82 | (recursive-descent [_] 83 | (fr/evaluate grammar recursive-descent))) 84 | 85 | (defn rule [name grammar] 86 | (fr/free (parser-rule name grammar))) 87 | 88 | (deftype recursive-parser-rule [name grammar] 89 | Parser 90 | (recursive-descent [_] 91 | (let [parser (fr/evaluate grammar recursive-descent) 92 | parser-fn (fn [s] (parser s))] 93 | (for [_ (sm/assoc-in-val (list :parser-fns name) parser-fn) 94 | result (sm/new-sm parser-fn)] 95 | result)))) 96 | 97 | (defn recursive-rule [name grammar] 98 | (fr/free (recursive-parser-rule name grammar))) 99 | 100 | (defn char-test [pred] 101 | (for [text (read-text) 102 | :when-not (=* "" text) 103 | :when (pred (subs text 0 1)) 104 | _ (sm/set-val :text (rest text))] 105 | (list (subs text 0 1)))) 106 | 107 | (deftype parse-lower-alphas [] 108 | Parser 109 | (recursive-descent [_] 110 | (char-test (fn [c] 111 | (< (dec (char-code "a")) (char-code c) (inc (char-code "z"))))))) 112 | 113 | (defn lower-alpha [] 114 | (fr/free (parse-lower-alphas))) 115 | 116 | (deftype parse-upper-alphas [] 117 | Parser 118 | (recursive-descent [_] 119 | (char-test (fn [c] 120 | (< (dec (char-code "A")) (char-code c) (inc (char-code "Z"))))))) 121 | 122 | (defn upper-alpha [] 123 | (fr/free (parse-upper-alphas))) 124 | 125 | (defn alpha [] 126 | (comp (lower-alpha) 127 | (upper-alpha))) 128 | 129 | (deftype parse-digit [] 130 | Parser 131 | (recursive-descent [_] 132 | (char-test (fn [c] 133 | (< (dec (char-code "0")) (char-code c) (inc (char-code "9"))))))) 134 | 135 | (defn digit [] 136 | (fr/free (parse-digit))) 137 | 138 | (defn one-of [coll] 139 | (let [coll (seq coll)] 140 | (comp* (term (first coll)) 141 | (map (rest coll) term)))) 142 | -------------------------------------------------------------------------------- /core/reader.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype reader-value [invoke-fn] 3 | Stringable 4 | (string-list [_] 5 | (list "")) 6 | 7 | Fn 8 | (invoke [_ env] 9 | (invoke-fn env)) 10 | 11 | Functor 12 | (map [_ f] 13 | (reader-value (fn [env] 14 | (f (invoke-fn env))))) 15 | 16 | Applicative 17 | (wrap [_ v] 18 | (reader-value (fn [_] v))) 19 | (apply* [fv args] 20 | (reader-value (fn [env] 21 | (apply (invoke-fn env) (map args (fn [rv] (rv env)))))))) 22 | 23 | (def reader 24 | (reify 25 | Fn 26 | (invoke [_ v] 27 | (reader-value (fn [_] v))) 28 | 29 | Type 30 | (instance? [_ mv] 31 | (instance? reader-value mv)))) 32 | 33 | (defn double [x] 34 | (* 2 x)) 35 | 36 | (main [_] 37 | ;; check the functor and applicative laws for reader 38 | (println :reader) 39 | (let [env :environment] 40 | (println :functor-1 (= ((map (reader 5) identity) env) 41 | ((reader 5) env))) 42 | (println :functor-2 (= ((map (map (reader 2) inc) double) env) 43 | ((map (reader 2) (comp inc double)) env))) 44 | (println :apply-1 (= ((map (reader 5) inc) env) 45 | ((apply-to inc (reader 5)) env))) 46 | (println :apply-2 (= ((reader 5) env) 47 | ((apply-to identity (reader 5)) env))) 48 | (let [v1 (reader "first ") 49 | v2 (reader "second ") 50 | v3 (reader "third")] 51 | (println :apply-3 (= ((apply-to comp (apply-to comp v1 v2) v3) env) 52 | ((apply-to comp v1 (apply-to comp v2 v3)) env) 53 | ((apply-to comp v1 v2 v3) env))))) 54 | (println) 55 | 56 | (let [rv1 (reader 1) 57 | rv5 (reader 5) 58 | env {:x 5 :y 1 :z 9}] 59 | (println :rv1-invoked (rv1 env)) 60 | (println) 61 | (println :map (map rv1 (fn [x] 62 | (println :incrementing x) 63 | (inc x)))) 64 | (println) 65 | (println :mapped ((map rv1 (fn [x] 66 | (println :incrementing x) 67 | (inc x))) 68 | env)) 69 | (println) 70 | (println :apply (apply-to + rv1 rv5)) 71 | (println) 72 | (println :applied ((apply-to + rv1 rv5) env)) 73 | 74 | ;; using other functions as readers 75 | (println :apply-reader ((apply (reader +) :x :y :z) env)) 76 | 77 | ;; nesting calls to apply 78 | (println :nested ((apply-to comp 79 | (reader "<") 80 | (apply (reader str) :x 81 | (reader ", ") :y 82 | (reader ", ") :z) 83 | (reader ">")) 84 | env)) 85 | )) 86 | -------------------------------------------------------------------------------- /core/state-maybe.toc: -------------------------------------------------------------------------------- 1 | 2 | ;; state-maybe monad with lazy comp* 3 | 4 | (defn reduce-args [[arg & args] s] 5 | (let [result-s (arg s)] 6 | (match result-s 7 | |List result new-s| 8 | (match args 9 | empty-list (list (list result) new-s) 10 | (match (reduce-args args new-s) 11 | |List results final-s| 12 | (list (cons result results) final-s)))))) 13 | 14 | (defn -comp* [mv mvs s] 15 | (let [x (mv s)] 16 | (cond 17 | (list-empty? mvs) x 18 | (= nothing x) (let [[mv & mvs] mvs] 19 | (-comp* mv mvs s)) 20 | x)) 21 | ;; slow 22 | ;; (let [x (mv s)] 23 | ;; (match mvs 24 | ;; empty-list x 25 | ;; (match x 26 | ;; nothing (-comp* (first mvs) (rest mvs) s) 27 | ;; x))) 28 | ) 29 | 30 | (deftype new-sm [invoke-fn] 31 | Stringable 32 | (string-list [_] (list "")) 33 | 34 | Function 35 | (invoke [ev s] 36 | (invoke-fn s)) 37 | 38 | Applicative 39 | (wrap [_ v] 40 | (new-sm (fn [s] 41 | (list v s)))) 42 | (apply* [fv args] 43 | (match args 44 | empty-list (new-sm (fn [s] 45 | (let [[f new-s] (fv s)] 46 | (list (f) new-s)))) 47 | (new-sm (fn [s] 48 | (let [reduce-state (reduce-args args s)] 49 | (cond 50 | (= nothing reduce-state) nothing 51 | (let [[results s] reduce-state 52 | [f s] (fv s)] 53 | (list (apply f results) s)))))) 54 | ;; slow but not by much 55 | ;; (new-sm (fn [s] 56 | ;; (match (reduce-args args s) 57 | ;; |List results s| (let [[f s] (fv s)] 58 | ;; (list (apply f results) s)) 59 | ;; ))) 60 | )) 61 | 62 | Monad 63 | (flat-map [ev f] 64 | (new-sm (fn [s] 65 | (let [v-ss (invoke-fn s)] 66 | (cond 67 | (= nothing v-ss) v-ss 68 | (let [[v ss] v-ss] 69 | ((f v) ss)))) 70 | ;; slow 71 | ;; (match (invoke-fn s) 72 | ;; |List v ss| ((f v) ss) 73 | ;; ) 74 | ))) 75 | 76 | Monoid 77 | (zero [_] (new-sm (fn [_] nothing))) 78 | (comp* [mv mvs] 79 | (new-sm (partial -comp* mv mvs)))) 80 | 81 | (def state-maybe 82 | (reify 83 | Function 84 | (invoke [_ v] 85 | (new-sm (fn [s] 86 | (list v s)))) 87 | 88 | Monoid 89 | (zero [_] (new-sm (fn [_] nothing))))) 90 | 91 | (defn traverse [coll f] 92 | ;; (cond 93 | ;; (empty? coll) (state-maybe empty-list) 94 | ;; (apply* (state-maybe list) (map coll f))) 95 | ;; slow 96 | (apply* (state-maybe list) (map coll f)) 97 | ) 98 | 99 | (defn update-state [f] 100 | (new-sm (fn [s] 101 | (list s (f s))))) 102 | 103 | (defn get-val 104 | ([k] 105 | (new-sm (fn [s] 106 | (let [v (m-get s k)] 107 | (cond 108 | (= nothing v) nothing 109 | (list (.v v) s))) 110 | ;; slow 111 | ;; (match (m-get s k) 112 | ;; |maybe v| (list v s) 113 | ;; ) 114 | ))) 115 | ([k nf] 116 | (new-sm (fn [s] 117 | (list (get s k nf) s))))) 118 | 119 | (defn set-val [k v] 120 | (new-sm (fn [s] 121 | (list (get s k nothing) (assoc s k v))))) 122 | 123 | (defn get-in-val 124 | ([path] 125 | (new-sm (fn [s] 126 | (let [v (get-in s path)] 127 | (cond 128 | (= nothing v) nothing 129 | (list (.v v) s))) 130 | ;; slow 131 | ;; (match (get-in s path) 132 | ;; |maybe v| (list v s) 133 | ;; ) 134 | ))) 135 | ([path nf] 136 | (new-sm (fn [s] 137 | (let [v (get-in s path)] 138 | (cond 139 | (= nothing v) (list nf s) 140 | (list (.v v) s))) 141 | ;; slow 142 | ;; (match (get-in s path) 143 | ;; nothing (list nf s) 144 | ;; |maybe v| (list v s) 145 | ;; ) 146 | )))) 147 | 148 | (defn assoc-in-val [path v] 149 | (new-sm (fn [s] 150 | (list v (assoc-in s path v))))) 151 | 152 | (defn update-in-val [path f] 153 | (new-sm (fn [s] 154 | (list (get-in s path) (update-in s path f))))) 155 | 156 | (defn recur-fn [f as s] 157 | (let [v-ss (f s)] 158 | (cond 159 | (= nothing v-ss) (list as s) 160 | (let [[v ss] v-ss] 161 | (recur-fn f (cons v as) ss)))) 162 | ;; slow 163 | ;; (match (f s) 164 | ;; nothing (list as s) 165 | ;; |List v ss| (recur-fn f (cons v as) ss) 166 | ;; ) 167 | ) 168 | 169 | (defn recur [mv] 170 | (new-sm (fn [s] 171 | (let [v-ss (mv s)] 172 | (cond 173 | (= nothing v-ss) nothing 174 | (let [[v ss] v-ss 175 | x (recur-fn (.invoke-fn mv) (list v) ss)] 176 | (cond 177 | (= nothing x) x 178 | (cons (reverse (car x)) (cdr x)))))))) 179 | ;; (new-sm (fn [s] 180 | ;; (match (mv s) 181 | ;; |List v ss| 182 | ;; (match (recur-fn (.invoke-fn mv) (list v) ss) 183 | ;; |List x & xs| (cons (reverse x) xs) 184 | ;; ) 185 | ;; ))) 186 | ) 187 | 188 | (defn when [val] 189 | (match val 190 | |maybe v| (state-maybe v) 191 | (zero state-maybe))) 192 | 193 | (defn when-not [val] 194 | (match val 195 | nothing (state-maybe 1) 196 | (zero state-maybe))) 197 | -------------------------------------------------------------------------------- /core/state.toc: -------------------------------------------------------------------------------- 1 | 2 | (defn reduce-args [args s] 3 | (cond 4 | (empty? args) (list empty-list s) 5 | (let [result-s ((first args) s) 6 | results-s (reduce-args (rest args) (second result-s))] 7 | (list (cons (first result-s) (first results-s)) 8 | (second results-s))))) 9 | 10 | (deftype state-val [invoke-fn] 11 | Stringable 12 | (string-list [mv] 13 | (list "")) 14 | 15 | Fn 16 | (invoke [ev s] 17 | (invoke-fn s)) 18 | 19 | Functor 20 | (map [_ f] 21 | (state-val (fn [s] 22 | (let [v-ss (invoke-fn s)] 23 | (list (f (first v-ss)) (second v-ss)))))) 24 | 25 | Applicative 26 | (wrap [_ v] 27 | (state-val (fn [s] 28 | (list v s)))) 29 | (apply* [fv args] 30 | (state-val (fn [s] 31 | (let [reduce-state (reduce-args args s) 32 | results (first reduce-state) 33 | s (second reduce-state) 34 | f-s (fv s)] 35 | (list (apply (first f-s) results) (second f-s)))))) 36 | 37 | Monad 38 | (flat-map [ev f] 39 | (state-val (fn [s] 40 | (let [v-ss (invoke-fn s) 41 | v (nth v-ss 0) 42 | ss (nth v-ss 1)] 43 | ((f v) ss)))))) 44 | 45 | (def state 46 | (reify 47 | Function 48 | (invoke [_ v] 49 | (state-val (fn [s] 50 | (list v s)))) 51 | 52 | Type 53 | (instance? [_ sv] (instance? state-val sv)) 54 | 55 | Monoid 56 | (comp* [_ _] :nothing-yet))) 57 | 58 | (defn get-state [] 59 | (state-val (fn [s] 60 | (list s s)))) 61 | 62 | (defn update-state [f] 63 | (state-val (fn [s] 64 | (list s (f s))))) 65 | 66 | (defn double [x] 67 | (* 2 x)) 68 | 69 | ;; (main [_] 70 | ;; ;; check the functor and applicative laws for state 71 | ;; (println :state) 72 | ;; (let [env :environment] 73 | ;; (println :functor-1 (= ((map (state 5) identity) env) 74 | ;; ((state 5) env))) 75 | ;; (println :functor-2 (= ((map (map (state 2) inc) double) env) 76 | ;; ((map (state 2) (comp inc double)) env))) 77 | ;; (println :apply-1 (= ((map (state 5) inc) env) 78 | ;; ((apply-to inc (state 5)) env))) 79 | ;; (println :apply-2 (= ((state 5) env) 80 | ;; ((apply-to identity (state 5)) env))) 81 | ;; (let [v1 (state "first ") 82 | ;; v2 (state "second ") 83 | ;; v3 (state "third")] 84 | ;; (println :apply-3 (= ((apply-to comp (apply-to comp v1 v2) v3) env) 85 | ;; ((apply-to comp v1 (apply-to comp v2 v3)) env) 86 | ;; ((apply-to comp v1 v2 v3) env))))) 87 | ;; (println) 88 | 89 | ;; (let [rv1 (state 1) 90 | ;; rv5 (state 5) 91 | ;; env {:x 5 :y 1 :z 9}] 92 | ;; (println :rv1-invoked (rv1 env)) 93 | ;; (println) 94 | ;; (println :map (map rv1 (fn [x] 95 | ;; (println :incrementing x) 96 | ;; (inc x)))) 97 | ;; (println) 98 | ;; (println :mapped ((map rv1 (fn [x] 99 | ;; (println :incrementing x) 100 | ;; (inc x))) 101 | ;; env)) 102 | ;; (println) 103 | ;; (println :apply (apply-to + rv1 rv5)) 104 | ;; (println) 105 | ;; (println :applied ((apply-to + rv1 rv5) env)))) 106 | -------------------------------------------------------------------------------- /core/stream.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype stream [carrier hd-fn tl-fn] 3 | Seqable 4 | (first [s] 5 | (hd-fn carrier)) 6 | (rest [s] 7 | (stream (tl-fn carrier) hd-fn tl-fn)) 8 | 9 | Comonad 10 | (extract [s] 11 | (first s)) 12 | (extend [s f] 13 | (stream s f rest))) 14 | -------------------------------------------------------------------------------- /counts: -------------------------------------------------------------------------------- 1 | protoFnImpl_262: Function count: 562606 2 | arityImpl_110: Function count: 588616 3 | protoFnImpl_313: Function count: 633806 4 | protoFnImpl_250: Function count: 653242 5 | arityImpl_518: Function count: 734205 6 | arityImpl_531: Function count: 796760 7 | arityImpl_475: Function count: 860456 8 | assoc: Function count: 885564 9 | protoFnImpl_382: Function count: 885564 10 | arityImpl_564: Function count: 1184013 11 | arityImpl_113: Function count: 1184014 12 | arityImpl_525: Function count: 1193481 13 | arityImpl_489: Function count: 1194911 14 | protoFnImpl_358: Function count: 1202518 15 | arityImpl_1449: Function count: 1220641 16 | arityImpl_968: Function count: 1222757 17 | protoImpl_971: Function count: 1222757 18 | protoFnImpl_239: Function count: 1258114 19 | arityImpl_163: Function count: 1272205 20 | arityImpl_453: Function count: 1272205 21 | arityImpl_430: Function count: 1301955 22 | arityImpl_340: Function count: 1368880 23 | my_malloc: Function count: 1377718 24 | arityImpl_517: Function count: 1405765 25 | protoFnImpl_305: Function count: 1407095 26 | arityImpl_619: Function count: 1466803 27 | arityImpl_679: Function count: 1466803 28 | protoFnImpl_614: Function count: 1466803 29 | protoImpl_680: Function count: 1466803 30 | arityImpl_739: Function count: 1467109 31 | arityImpl_600: Function count: 1467154 32 | arityImpl_94: Function count: 1467154 33 | protoImpl_601: Function count: 1467154 34 | arityImpl_880: Function count: 1468012 35 | arityImpl_98: Function count: 1469096 36 | arityImpl_127: Function count: 1482708 37 | arityImpl_978: Function count: 1602415 38 | arityImpl_868: Function count: 1693656 39 | protoImpl_869: Function count: 1693656 40 | malloc_substring: Function count: 1800803 41 | arityImpl_662: Function count: 1841483 42 | protoImpl_663: Function count: 1841483 43 | protoFnImpl_611: Function count: 1855911 44 | arityImpl_933: Function count: 2089744 45 | arityImpl_936: Function count: 2163137 46 | arityImpl_834: Function count: 2278336 47 | arityImpl_844: Function count: 2283166 48 | arityImpl_124: Function count: 2322421 49 | protoFnImpl_403: Function count: 2367829 50 | arityImpl_812: Function count: 2377570 51 | arityImpl_970: Function count: 2389168 52 | arityImpl_771: Function count: 2692365 53 | equal: Function count: 2761976 54 | valsEqual: Function count: 2761976 55 | arityImpl_949: Function count: 2827292 56 | protoFnImpl_944: Function count: 2827292 57 | arityImpl_528: Function count: 2834742 58 | bitpos: Function count: 2839599 59 | arityImpl_736: Function count: 2842361 60 | protoFnImpl_332: Function count: 2857471 61 | arityImpl_145: Function count: 2903091 62 | protoFnImpl_311: Function count: 3015291 63 | arityImpl_514: Function count: 3015585 64 | arityImpl_877: Function count: 3099496 65 | arityImpl_878: Function count: 3169933 66 | protoFnImpl_410: Function count: 3253805 67 | sha1: Function count: 3253805 68 | arityImpl_148: Function count: 3293960 69 | arityImpl_91: Function count: 3472062 70 | arityImpl_530: Function count: 4360661 71 | malloc_reified: Function count: 4394951 72 | get: Function count: 4660736 73 | protoFnImpl_380: Function count: 4660736 74 | protoFnImpl_330: Function count: 4662733 75 | Sha1Update: Function count: 4727505 76 | protoFnImpl_10: Function count: 5303360 77 | arityImpl_992: Function count: 5303361 78 | protoImpl_993: Function count: 5303361 79 | mask: Function count: 5550672 80 | arityImpl_467: Function count: 5943562 81 | arityImpl_104: Function count: 6020505 82 | arityImpl_242: Function count: 6602857 83 | arityImpl_133: Function count: 7109364 84 | arityImpl_529: Function count: 8427871 85 | protoFnImpl_334: Function count: 9893800 86 | arityImpl_130: Function count: 11626801 87 | arityImpl_422: Function count: 12539831 88 | malloc_number: Function count: 13296561 89 | numberValue: Function count: 13296561 90 | protoFnImpl_277: Function count: 15301807 91 | malloc_fnArity: Function count: 20494829 92 | malloc_function: Function count: 20494829 93 | arityImpl_271: Function count: 20724181 94 | isTrue: Function count: 35511552 95 | listCons: Function count: 37412335 96 | malloc_list: Function count: 42796584 97 | findProtoImpl: Function count: 61771341 98 | findFnArity: Function count: 74973273 99 | incRef: Function count: 188624774 100 | dec_and_free: Function count: 355848281 101 | done 102 | -------------------------------------------------------------------------------- /doc/toccata-ebnf.txt: -------------------------------------------------------------------------------- 1 | not-eol = (* anything but \n *) 2 | comment = ';', { not-eol }, '\n' 3 | whitespace = ' ' | ',' | '\t' | '\r' | '\n' | comment 4 | digit = '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' 5 | number = [ '-' ], digit, { digit } 6 | lower-alpha = 'a' | 'b' | 'c' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 7 | 'j' | 'k' | 'l' | 'm' | 'n' | 'o' | 'p' | 'q' | 'r' | 8 | 's' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' 9 | upper-alpha = 'A' | 'B' | 'C' | 'D' | 'E' | 'F' | 'G' | 'H' | 'I' | 10 | 'J' | 'K' | 'L' | 'M' | 'N' | 'O' | 'P' | 'Q' | 'R' | 11 | 'S' | 'T' | 'U' | 'V' | 'W' | 'X' | 'Y' | 'Z' 12 | symbol-start = lower-alpha | upper-alpha | '.' | '_' | '<' | '>' | '=' | '+' | '-' | '*' | '/' 13 | symbol-punct = '.' | '_' | '<' | '>' | '=' | '*' | '/' | '+' | '!' | '-' | '?' 14 | symbol-char = lower-alpha | upper-alpha | digit | symbol-punct 15 | rest-of-symbol = { symbol-char } 16 | keyword = ':', symbol-start, rest-of-symbol 17 | symbol = symbol-start, rest-of-symbol 18 | form = { whitespace }, number | keyword | symbol | quoted | string | let | main | defn | fn | 19 | for | hash-map | vector | list, { whitespace } 20 | quoted = ''', form 21 | not-backslash = (* anything but \ *) 22 | backslash = '\\', '\\' 23 | doublequote = '\\', '\"' 24 | tab = '\\', 't' 25 | backspace = '\\', 'b' 26 | return = '\\', 'r' 27 | formfeed = '\\', 'f' 28 | newline = '\\', 'n' 29 | string = '\"', { not-backslash | backslash | doublequote | tab | backspace | return | 30 | formfeed | newline }, '\"' 31 | let-binding = { whitespace }, symbol, { whitespace }, form 32 | let = '(', { whitespace }, 'let', whitespace, { whitespace }, '[', { let-binding }, ']', 33 | form, { form }, { whitespace }, ')' 34 | arg = { whitespace }, symbol, { whitespace } 35 | var-arg = { whitespace }, '&', whitespace, { whitespace }, symbol 36 | args = { whitespace }, '[', { arg }, var-arg, ']' 37 | main = '(', { whitespace }, 'main', whitespace, { whitespace }, args, form, { form }, { whitespace }, ')' 38 | single-arity = args, { form } 39 | multi-arity = { whitespace }, '(', { whitespace }, args, { form }, { whitespace }, ')' 40 | arities = single-arity | multi-arity, { multi-arity } 41 | defn = '(', { whitespace }, 'defn', whitespace, { whitespace }, symbol, whitespace, { whitespace }, 42 | arities, { whitespace }, ')' 43 | fn = '(', { whitespace }, 'fn', whitespace, { whitespace }, symbol, { whitespace }, arities, { whitespace }, ')' 44 | for-let = { whitespace }, ':let', whitespace, { whitespace }, '[', { let-binding }, ']' 45 | for-when = { whitespace }, ':when', whitespace, { whitespace }, form 46 | for-binding = for-let | for-when | let-binding 47 | for = '(', { whitespace }, 'for', whitespace, { whitespace }, '[', { whitespace }, symbol, whitespace, 48 | { whitespace }, form, { for-binding }, ']', form, { whitespace }, ')' 49 | hash-map = '{', { form }, '}' 50 | vector = '[', { form }, ']' 51 | list = '(', { form }, ')' 52 | -------------------------------------------------------------------------------- /examples/diamond.toc: -------------------------------------------------------------------------------- 1 | ;; 2 | 3 | ;; The Diamond Kata 4 | ;; ---------------- 5 | ;; 6 | ;; This problem came up on the Google Clojure Group, and I was curious to give it a go. The problem is desribed at: 7 | ;; [Thinking before programming](http://alistair.cockburn.us/Thinking+before+programming) 8 | ;; but essentially you call a function with a character from "A" to "Z" and it prints out a diamond with the letters. 9 | ;; (diamond "A") prints 10 | ;; 11 | ;; 
A
12 | ;; 13 | ;; (diamond "C") prints 14 | ;; 15 | ;; 
16 | ;;   A
17 | ;;  B B
18 | ;; C   C
19 | ;;  B B
20 | ;;   A
21 | ;;
22 | ;; 23 | ;; The key observation is that its doesn't matter how many letters you are doing, a given letter is 24 | ;; always followed by a fixed number of spaces. So A has no spaces, but C has three spaces. This is 25 | ;; independant of the size of the diamond. I was particularly taken with the size and simplicity of this 26 | ;; solution compared with other languages. 27 | ;; 28 | ;; The code itself is a set of four trivial helper functions followed by the diamond function that does 29 | ;; most of the work. and a print function that dumps the final solution. Unlike the original clojure version 30 | ;; this one does not yet guard against bad inputs so if you try (diamond "a") you are on your own. 31 | 32 | ;; Create a string with a given number of spaces. 33 | 34 | (defn spaces [n] (apply str (repeat n " "))) 35 | 36 | ;; Given a number between 0 and 25 return a character, "A" is 0, "Z" is 25 37 | 38 | (defn n->a [n] (nth "ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)) 39 | 40 | ;; Given a character between "A" and "Z", return its numeric index where "A" is 0 and "Z" is 25 41 | 42 | (defn a->n [a] (- (char-code a) (char-code "A"))) 43 | 44 | ;; Return a string of 2n-1 spaces for a given n 45 | 46 | (defn gap [n] (spaces (dec (* 2 n)))) 47 | 48 | ;; The diamond function works by calculating the index of the selected character 49 | ;; and then creating the upper half, then the lower half of the diamond. 50 | 51 | (defn diamond [c] 52 | (let [l (a->n c)] 53 | (comp 54 | (for [i (range (inc l))] (str (spaces (- l i)) (n->a i) (gap i) (cond (< i 1) "" (n->a i)))) 55 | (for [i (reverse (range l))] (str (spaces (- l i)) (n->a i) (gap i) (cond (< i 1) "" (n->a i))))))) 56 | 57 | ;; Main. Try it with "A"->"Z" 58 | 59 | (main [arg-list] 60 | (map (diamond "Z") println)) 61 | 62 | -------------------------------------------------------------------------------- /examples/ebnf.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns p (module "core/parser.toc")) 3 | (add-ns fr (module "core/free.toc")) 4 | 5 | ;; Sample Grammar 6 | ;; ------------------ 7 | ;; digit := “0” | “1” ... | “9”; 8 | ;; letter := “a” | “b” ... | “z”; 9 | ;; number := [“-”], digit, {digit}; 10 | ;; symbol := letter, {digit | letter}; 11 | ;; expression := “(“, {symbol | number | expression}, “)”; 12 | 13 | (defn letter [] 14 | (p/rule "letter" 15 | (p/one-of "abcdefghijklmnopqrstuvwxyz"))) 16 | 17 | (defn digit [] 18 | (p/rule "digit" 19 | (p/one-of "0123456789"))) 20 | 21 | (defn number [] 22 | (p/rule "number" 23 | (apply-to str 24 | (p/optional (p/term "-")) 25 | (p/one-or-more (digit))))) 26 | 27 | (defn symbol [] 28 | (p/rule "symbol" 29 | (apply-to str 30 | (letter) 31 | (p/none-or-more (comp (digit) (letter)))))) 32 | 33 | (defn sub-expression [] 34 | (p/rule "expression" 35 | (p/term ""))) 36 | 37 | (defn expression [] 38 | (p/rule "expression" 39 | (apply-to str 40 | (p/term "( ") 41 | (p/none-or-more (comp (symbol) (number) 42 | (sub-expression))) 43 | (p/term " )")))) 44 | 45 | (deftype EBNF [ebnf-str rules] 46 | Applicative 47 | (apply* [_ vs] 48 | (EBNF (apply str (interpose (map vs .ebnf-str) ", ")) 49 | (apply comp (map vs .rules)))) 50 | 51 | Monoid 52 | (comp* [v vs] 53 | (let [vs (cons v vs)] 54 | (EBNF (apply str (interpose (map vs .ebnf-str) " | ")) 55 | (apply comp (map vs .rules)))))) 56 | 57 | (defprotocol Make-EBNF 58 | (ebnf [grammar])) 59 | 60 | (extend-type Function 61 | Make-EBNF 62 | (ebnf [_] 63 | (EBNF "" {}))) 64 | 65 | (extend-type parser-terminal 66 | Make-EBNF 67 | (ebnf [terminal] 68 | (EBNF (str "'" (.term-str terminal) "'") {}))) 69 | 70 | (extend-type p/repeat-rule 71 | Make-EBNF 72 | (ebnf [r] 73 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 74 | (EBNF (str (.ebnf-str rule-body) ", { " (.ebnf-str rule-body) " }") 75 | (.rules rule-body))))) 76 | 77 | (extend-type p/optional-rule 78 | Make-EBNF 79 | (ebnf [r] 80 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 81 | (EBNF (str "[ " (.ebnf-str rule-body) " ]") 82 | (.rules rule-body))))) 83 | 84 | (extend-type p/none-or-more-rule 85 | Make-EBNF 86 | (ebnf [r] 87 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 88 | (EBNF (str "{ " (.ebnf-str rule-body) " }") 89 | (.rules rule-body))))) 90 | 91 | (extend-type p/parser-rule 92 | Make-EBNF 93 | (ebnf [r] 94 | (let [rule-body (fr/evaluate (.grammar r) ebnf)] 95 | (EBNF (.name r) 96 | (assoc (.rules rule-body) 97 | (.name r) (.ebnf-str rule-body)))))) 98 | 99 | (main [_] 100 | (let [rules (seq (.rules (fr/evaluate (expression) ebnf)))] 101 | (map rules (fn [rule] 102 | (println (first rule) "=" (second rule) ";"))))) 103 | -------------------------------------------------------------------------------- /examples/error.toc: -------------------------------------------------------------------------------- 1 | 2 | (defn double [x] 3 | (* 2 x)) 4 | 5 | (defn check-int [x] 6 | (cond 7 | (= 0 (rem x 2)) (valid x) 8 | (error (str "Found odd int: " x)))) 9 | 10 | (main [_] 11 | ;; check the functor and applicative laws for valid-value 12 | (println :valid) 13 | (println :functor-1 (= (map (valid 5) identity) (valid 5))) 14 | (println :functor-2 (= (map (map (valid 2) inc) double) 15 | (map (valid 2) (comp inc double)))) 16 | (println :apply-1 (= (map (valid 5) inc) 17 | (apply-to inc (valid 5)))) 18 | (println :apply-2 (= (valid 5) (apply-to identity (valid 5)))) 19 | (let [v1 (valid "first ") 20 | v2 (valid "second ") 21 | v3 (valid "third")] 22 | (println :apply-3 (= (apply-to comp (apply-to comp v1 v2) v3) 23 | (apply-to comp v1 (apply-to comp v2 v3)) 24 | (apply-to comp v1 v2 v3)))) 25 | 26 | ;; check the functor and applicative laws for error-value 27 | (println) 28 | (println :error) 29 | (println :functor-1 (= (map (error 5) identity) (error 5))) 30 | (println :functor-2 (= (map (map (error 2) inc) double) 31 | (map (error 2) (comp inc double)))) 32 | (println :apply-1 (= (map (error 5) inc) 33 | (apply-to inc (error 5)))) 34 | (println :apply-2 (= (error 5) (apply-to identity (error 5)))) 35 | (let [v1 (error "first ") 36 | v2 (error "second ") 37 | v3 (error "third")] 38 | (println :apply-3 (= (apply-to comp (apply-to comp v1 v2) v3) 39 | (apply-to comp v1 (apply-to comp v2 v3)) 40 | (apply-to comp v1 v2 v3)))) 41 | 42 | ;; make sure an error-value will short circuit apply-to 43 | (println) 44 | (println :valid-error (= (error :some-error) 45 | (apply-to + (valid 8) (error :some-error) (valid 13)))) 46 | 47 | ;; error-value in action 48 | (let [good-ints (map (list 8 10 2 4 14) check-int) 49 | error-ints (map (list 8 3 2 5 14) check-int)] 50 | (println :sum-good-ints (apply* (valid +) good-ints)) 51 | (println :sum-error-ints (apply* (valid +) error-ints)))) 52 | -------------------------------------------------------------------------------- /examples/fizzbuzz.toc: -------------------------------------------------------------------------------- 1 | ;; Fizzbuzz 2 | ;; -------- 3 | ;; 4 | ;; Fizzbuzz is a word game sometimes used by teachers trying to teach 5 | ;; division. The basic idea is that everyone sits in a circle and the 6 | ;; first player says 'one', the next 'two' and so on. As the count passes 7 | ;; round the circle each player has to say the next number unless the 8 | ;; number is divisible by three in which case the player has to say 'fizz' 9 | ;; instead. If the number is divisble by five the player has to say 'buzz'. 10 | ;; If the number is divisible by three and five, the player has to say 11 | ;; 'fizzbuzz'. 12 | ;; 13 | ;; Programmers tend to use this exercise as a basic test of being able 14 | ;; to put together a simple program. A surprising number of people can get 15 | ;; get through a course on programming and yet be unable to produce 16 | ;; a fizzbuzz example on request. See [Using FizzBuzz to Find Developers 17 | ;; who Grok Coding] (http://imranontech.com/2007/01/24/using-fizzbuzz-to-find-developers-who-grok-coding/) 18 | ;; for a discussion on this subject. 19 | ;; 20 | ;; This particular version produces both the number and its fizzbuzz 21 | ;; substitution for the numbers 1-100. 22 | 23 | (defn zero? [x] 24 | (= x 0)) 25 | 26 | (defn divisible-by-three? [x] 27 | (zero? (rem x 3))) 28 | 29 | (defn divisible-by-five? [x] 30 | (zero? (rem x 5))) 31 | 32 | (defn fizzbuzz [x] 33 | (let [d3? (divisible-by-three? x) 34 | d5? (divisible-by-five? x)] 35 | (cond (and d3? d5?) (str x " - fizzbuzz") 36 | d3? (str x " - fizz") 37 | d5? (str x " - buzz") 38 | (str x)))) 39 | 40 | ;; Tests 41 | ;; ----- 42 | ;; (println "(zero? -10)" (zero? -10)) 43 | ;; (println "(zero? 1)" (zero? 1)) 44 | ;; (println "(zero? 0)" (zero? 0)) 45 | ;; (println "(rem -3 3)" (rem -3 3)) 46 | ;; (println "(rem 0 3)" (rem 0 3)) 47 | ;; (println "(rem 1 3)" (rem 1 3)) 48 | ;; (println "(rem 3 3)" (rem 3 3)) 49 | ;; (println "(rem 4 3)" (rem 4 3)) 50 | ;; (println "(rem 6 3)" (rem 6 3)) 51 | ;; (println "(divisible-by-three? -1)" (divisible-by-three? -1)) 52 | ;; (println "(divisible-by-three? 0)" (divisible-by-three? 0)) 53 | ;; (println "(divisible-by-three? 12)" (divisible-by-three? 12)) 54 | ;; (println "(divisible-by-three? 11)" (divisible-by-three? 11)) 55 | ;; (println "(divisible-by-five? 5)" (divisible-by-five? 5)) 56 | ;; (println "(divisible-by-five? 6)" (divisible-by-five? 6)) 57 | ;; (println "(fizzbuzz 0)" (fizzbuzz 0)) 58 | ;; (println "(fizzbuzz 1)" (fizzbuzz 1)) 59 | ;; (println "(fizzbuzz 3)" (fizzbuzz 3)) 60 | ;; (println "(fizzbuzz 5)" (fizzbuzz 5)) 61 | ;; (println "(fizzbuzz 11)" (fizzbuzz 11)) 62 | ;; (println "(fizzbuzz 15)" (fizzbuzz 15)) 63 | 64 | (main [arglist] 65 | (map (range 100) (fn [n] (println (fizzbuzz (inc n)))))) 66 | -------------------------------------------------------------------------------- /examples/fn-comp.toc: -------------------------------------------------------------------------------- 1 | 2 | (main [argslist] 3 | (println 9 ((comp inc (partial + 2)) 6)) 4 | (println 7 ((comp inc (zero inc)) 6)) 5 | (println 7 ((comp (zero inc) inc) 6)) 6 | (println ((comp inc (partial + 2) str) 6) 7 | ((comp inc (comp (partial + 2) str)) 6) 8 | ((comp (comp inc (partial + 2)) str) 6))) 9 | -------------------------------------------------------------------------------- /examples/free-tree.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns st (module "core/state.toc")) 3 | 4 | (defn tree-node [v] 5 | (cond 6 | (= v :list) (apply-to (fn [node-count] 7 | (fn [& sub-nodes] 8 | (let [node-name (str "node_" node-count)] 9 | (println node-name "[label=\"\"];") 10 | (map sub-nodes 11 | (fn [sub-node] 12 | (println (str node-name " -- " sub-node ";")))) 13 | node-name))) 14 | (st/update-state inc)) 15 | (apply-to (fn [node-count] 16 | (let [node-name (str "node_" node-count)] 17 | (println (str node-name " [label=\"" v "\"];")) 18 | node-name)) 19 | (st/update-state inc)))) 20 | 21 | (main [_] 22 | (let [tree (apply-to :list 23 | (free 9) 24 | (free 3) 25 | (apply-to :list 26 | (free 5) 27 | (free 1) 28 | (apply-to :list 29 | (free 7) 30 | (free 6) 31 | (free 4))) 32 | (free 2) 33 | (free 0))] 34 | (println "graph graphname {") 35 | ((evaluate tree tree-node) 0) 36 | (println "}"))) 37 | -------------------------------------------------------------------------------- /examples/full-ebnf.toc: -------------------------------------------------------------------------------- 1 | 2 | (add-ns p (module "core/parser.toc")) 3 | (add-ns fr (module "core/free.toc")) 4 | (add-ns st (module "core/state.toc")) 5 | (add-ns gr (module "core/grammar.toc")) 6 | 7 | (defn letter [] 8 | (p/rule "letter" 9 | (p/one-of "abcdefghijklmnopqrstuvwxyz"))) 10 | 11 | (defn digit [] 12 | (p/rule "digit" 13 | (p/one-of "0123456789"))) 14 | 15 | (defn number [] 16 | (p/rule "number" 17 | (apply-to str 18 | (p/optional (p/term "-")) 19 | (p/one-or-more (digit))))) 20 | 21 | (defn symbol [] 22 | (p/rule "symbol" 23 | (apply-to str 24 | (letter) 25 | (p/none-or-more (comp (digit) (letter)))))) 26 | 27 | (defn sub-expression [] 28 | (p/rule "expression" 29 | (p/term ""))) 30 | 31 | (defn expression [] 32 | (p/rule "expression" 33 | (apply-to str 34 | (p/term "( ") 35 | (p/none-or-more (comp (symbol) (number) 36 | (sub-expression))) 37 | (p/term " )")))) 38 | 39 | (deftype EBNF [s rules] 40 | Stringable 41 | (string-list [_] 42 | (list "")) 43 | 44 | Applicative 45 | (apply* [_ vs] 46 | (EBNF (apply str (interpose 47 | (remove (map vs .s) 48 | (fn [s] (= "" s))) 49 | ", ")) 50 | (apply comp (map vs .rules)))) 51 | 52 | Monoid 53 | (comp* [v vs] 54 | (let [vs (cons v vs)] 55 | (EBNF (apply str (interpose 56 | (remove (map vs .s) 57 | (fn [s] (= "" s))) 58 | " | ")) 59 | (apply comp (map vs .rules)))))) 60 | 61 | (defprotocol Make-EBNF 62 | (ebnf [grammar])) 63 | 64 | (extend-type Function 65 | Make-EBNF 66 | (ebnf [_] 67 | (EBNF "" {}))) 68 | 69 | (extend-type parser-terminal 70 | Make-EBNF 71 | (ebnf [t] 72 | (EBNF (str "'" (escape-chars (.term-str t)) "'") 73 | {}))) 74 | 75 | (extend-type p/repeat-rule 76 | Make-EBNF 77 | (ebnf [r] 78 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 79 | (EBNF (str (.s rule-body) ", { " (.s rule-body) " }") 80 | (.rules rule-body))))) 81 | 82 | (extend-type p/optional-rule 83 | Make-EBNF 84 | (ebnf [r] 85 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 86 | (EBNF (str "[ " (.s rule-body) " ]") 87 | (.rules rule-body))))) 88 | 89 | (extend-type p/none-or-more-rule 90 | Make-EBNF 91 | (ebnf [r] 92 | (let [rule-body (fr/evaluate (.rule r) ebnf)] 93 | (EBNF (str "{ " (.s rule-body) " }") 94 | (.rules rule-body))))) 95 | 96 | (extend-type p/parser-rule 97 | Make-EBNF 98 | (ebnf [r] 99 | (let [rule-body (fr/evaluate (.grammar r) ebnf)] 100 | (EBNF (.name r) 101 | (assoc (.rules rule-body) 102 | (.name r) (.s rule-body)))))) 103 | 104 | (extend-type p/recursive-parser-rule 105 | Make-EBNF 106 | (ebnf [r] 107 | (let [rule-body (fr/evaluate (.grammar r) ebnf)] 108 | (EBNF (.name r) 109 | (assoc (.rules rule-body) 110 | (.name r) (.s rule-body)))))) 111 | 112 | (extend-type p/ignore-rule 113 | Make-EBNF 114 | (ebnf [rule] 115 | (fr/evaluate (.rule rule) ebnf))) 116 | 117 | (extend-type p/parse-digit 118 | Make-EBNF 119 | (ebnf [_] 120 | (EBNF "digit" 121 | {"digit" (.s (fr/evaluate (p/one-of "0123456789") ebnf))}))) 122 | 123 | (extend-type p/parse-lower-alphas 124 | Make-EBNF 125 | (ebnf [_] 126 | (EBNF "lower-alpha" 127 | {"lower-alpha" (.s (fr/evaluate (p/one-of "abcdefghijklmnopqrstuvwxyz") ebnf))}))) 128 | 129 | (extend-type p/parse-upper-alphas 130 | Make-EBNF 131 | (ebnf [_] 132 | (EBNF "upper-alpha" 133 | {"upper-alpha" (.s (fr/evaluate (p/one-of "ABCDEFGHIJKLMNOPQRSTUVWXYZ") ebnf))}))) 134 | 135 | (extend-type p/parser-always 136 | Make-EBNF 137 | (ebnf [_] 138 | (EBNF "" {}))) 139 | 140 | (extend-type gr/parse-sub-form 141 | Make-EBNF 142 | (ebnf [_] 143 | (EBNF "form" {}))) 144 | 145 | (extend-type gr/parse-not-backslash 146 | Make-EBNF 147 | (ebnf [_] 148 | (EBNF "(* anything but \\ *)" {}))) 149 | 150 | (extend-type gr/parse-not-eol 151 | Make-EBNF 152 | (ebnf [_] 153 | (EBNF "(* anything but \\n *)" {}))) 154 | 155 | (main [_] 156 | (let [final-ebnf (fr/evaluate (gr/read-form) ebnf)] 157 | (map (seq (.rules final-ebnf)) 158 | (fn [rule] 159 | (println (first rule) "=" (second rule)))) 160 | (println (.s final-ebnf)))) 161 | -------------------------------------------------------------------------------- /examples/hello.toc: -------------------------------------------------------------------------------- 1 | 2 | (main [arg-list] 3 | (println "Howdy," (str (second arg-list) "!!!"))) 4 | -------------------------------------------------------------------------------- /examples/list-comp.toc: -------------------------------------------------------------------------------- 1 | 2 | (main [arglist] 3 | (let [a (list 1 3 4) 4 | b (list :a :x)] 5 | (println :list-a a) 6 | (println :list-b b) 7 | (println :comp (comp a b)))) 8 | -------------------------------------------------------------------------------- /examples/listzipper.toc: -------------------------------------------------------------------------------- 1 | 2 | (def move-left) 3 | (def move-right) 4 | 5 | (defn extend-side 6 | ([f context move side] 7 | (let [new-side (new-list)] 8 | (extend-side f new-side move (move context) new-side side))) 9 | ([f new-side move context new-tail side] 10 | (cond 11 | (empty? side) new-side 12 | (extend-side f 13 | new-side 14 | move 15 | (move context) 16 | (snoc new-side new-tail (f context)) 17 | (rest side))))) 18 | 19 | (deftype list-zipper-val [left focus right] 20 | Stringable 21 | (string-list [_] 22 | (comp (list ""))) 29 | 30 | Eq 31 | (=* [x y] 32 | (cond 33 | (not (instance? list-zipper-val y)) false 34 | (and (= left (.left y)) 35 | (= focus (.focus y)) 36 | (= right (.right y))))) 37 | 38 | Seqable 39 | (seq? [_] true) 40 | (seq [_] (comp (reverse left) (cons focus right))) 41 | (first [_] (first (reverse left))) 42 | (rest [lz] (rest (seq lz))) 43 | 44 | Functor 45 | (map [_ f] (list-zipper-val (map left f) 46 | (f focus) 47 | (map right f))) 48 | 49 | Comonad 50 | (extract [_] 51 | focus) 52 | (extend [lz f] 53 | (list-zipper-val (extend-side f lz move-left left) 54 | (f lz) 55 | (extend-side f lz move-right right)))) 56 | 57 | (defn move-left [lz] 58 | (cond 59 | (empty? (.left lz)) lz 60 | (list-zipper-val (rest (.left lz)) 61 | (first (.left lz)) 62 | (cons (.focus lz) (.right lz))))) 63 | 64 | (defn move-right [lz] 65 | (cond 66 | (empty? (.right lz)) lz 67 | (list-zipper-val (cons (.focus lz) (.left lz)) 68 | (first (.right lz)) 69 | (rest (.right lz))))) 70 | 71 | (defn f [lz] 72 | (inc (extract lz))) 73 | 74 | (defn g [lz] 75 | (* 2 (extract lz))) 76 | 77 | (main [_] 78 | (let [lz (list-zipper-val (list 5 4 3) 8 (list 1 2 9))] 79 | (println :lz lz) 80 | (println :focus (extract lz)) 81 | (println :map (map lz inc)) 82 | (println :extend (extend lz (comp extract inc))) 83 | (println :first-law (= (extend lz extract) lz)) 84 | (println :second-law (= (extract (extend lz f)) 85 | (f lz))) 86 | (println :third-law (= (extend (extend lz g) f) 87 | (extend lz (fn [x] 88 | (f (extend x g)))))))) 89 | -------------------------------------------------------------------------------- /examples/mapping.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype maybe-value [v]) 3 | 4 | (extend-type maybe-value 5 | Stringable 6 | (string-list [mv] 7 | (comp (list "")))) 10 | 11 | (extend-type maybe-value 12 | Functor 13 | (map [mv f] 14 | (maybe-value (f (.v mv))))) 15 | 16 | (deftype TreeVal [children] 17 | Stringable 18 | (string-list [_] (string-list children)) 19 | 20 | Functor 21 | (map [_ f] 22 | (TreeVal (map children (fn [child] 23 | (map child f)))))) 24 | 25 | (defn tree [& children] 26 | (TreeVal children)) 27 | 28 | (main [_] 29 | (println :char-code-A (char-code "A")) 30 | (println (maybe-value 10) (instance? maybe-value (maybe-value 8))) 31 | (let [mv (maybe-value 8)] 32 | (println (maybe-value (inc (.v mv))))) 33 | (println (map (maybe-value 3) inc)) 34 | (let [int-list (list 9 8 3 7 5)] 35 | (println :map-list (map int-list inc)) 36 | (println :nested-map (map (map int-list inc) str)) 37 | (println :comped-map (map int-list (comp inc str)))) 38 | 39 | (println) 40 | (let [t1 (tree 5 1 (tree -4 2 9) 8 (tree (tree (maybe-value 0) 3) -8))] 41 | (println (map t1 inc)))) 42 | -------------------------------------------------------------------------------- /examples/maybe.toc: -------------------------------------------------------------------------------- 1 | 2 | (main [_] 3 | (let [double (fn [x] 4 | (* 2 x)) 5 | check-int (fn [x] 6 | (match (rem x 2) 7 | 0 (maybe x)))] 8 | ;; check the functor and applicative laws for maybe 9 | (println :maybe) 10 | (println :functor-1 (= (map (maybe 5) identity) (maybe 5))) 11 | (println :functor-2 (= (map (map (maybe 2) inc) double) 12 | (map (maybe 2) (comp inc double)))) 13 | (println :apply-1 (= (map (maybe 5) inc) 14 | (apply-to inc (maybe 5)))) 15 | (println :apply-2 (= (maybe 5) (apply-to identity (maybe 5)))) 16 | (let [v1 (maybe "first ") 17 | v2 (maybe "second ") 18 | v3 (maybe "third")] 19 | (println :apply-3 (= (apply-to comp (apply-to comp v1 v2) v3) 20 | (apply-to comp v1 (apply-to comp v2 v3)) 21 | (apply-to comp v1 v2 v3)))) 22 | 23 | ;; check the functor and applicative laws for nothing 24 | (println) 25 | (println :nothing) 26 | (println :functor-1 (= (map nothing identity) nothing)) 27 | (println :functor-2 (= (map (map nothing inc) double) 28 | (map nothing (comp inc double)))) 29 | (println :apply-1 (= (map nothing inc) 30 | (apply-to inc nothing))) 31 | (println :apply-2 (= nothing (apply-to identity nothing))) 32 | (println :apply-3 (= (apply-to comp (apply-to comp nothing nothing) nothing) 33 | (apply-to comp nothing (apply-to comp nothing nothing)) 34 | (apply-to comp nothing nothing nothing))) 35 | 36 | ;; make sure an nothing will short circuit apply-to 37 | (println) 38 | (println :short-circuit (= nothing 39 | (apply-to + (maybe 8) nothing (maybe 13)))) 40 | 41 | ;; nothing in action 42 | (let [good-ints (map (list 8 10 2 4 14) check-int) 43 | nothing-ints (map (list 8 3 2 5 14) check-int)] 44 | (println :sum-good-ints (apply* (maybe +) good-ints)) 45 | (println :sum-nothing-ints (apply* (maybe +) nothing-ints))))) 46 | -------------------------------------------------------------------------------- /examples/thunk.toc: -------------------------------------------------------------------------------- 1 | 2 | (deftype thunk-value [invoke-fn] 3 | Stringable 4 | (string-list [_] 5 | (list "")) 6 | 7 | Fn 8 | (invoke [_] 9 | (invoke-fn)) 10 | 11 | Functor 12 | (map [_ f] 13 | (thunk-value (fn [] 14 | (f (invoke-fn))))) 15 | 16 | Applicative 17 | (wrap [_ v] 18 | (thunk-value (fn [] 19 | (println "un-thunking" v) 20 | v))) 21 | (apply* [fv args] 22 | (thunk-value (fn [] 23 | (apply (invoke-fn) (map args invoke)))))) 24 | 25 | (def thunk 26 | (reify 27 | Fn 28 | (invoke [_ v] 29 | (thunk-value (fn [] 30 | (println "un-thunking" v) 31 | v))) 32 | 33 | Type 34 | (instance? [_ mv] 35 | (instance? thunk-value mv)))) 36 | 37 | (defn double [x] 38 | (* 2 x)) 39 | 40 | (main [_] 41 | ;; check the functor and applicative laws for thunk 42 | (println :thunk) 43 | (println :functor-1 (= (invoke (map (thunk 5) identity)) 44 | (invoke (thunk 5)))) 45 | (println :functor-2 (= (invoke (map (map (thunk 2) inc) double)) 46 | (invoke (map (thunk 2) (comp inc double))))) 47 | (println :apply-1 (= (invoke (map (thunk 5) inc)) 48 | (invoke (apply-to inc (thunk 5))))) 49 | (println :apply-2 (= (invoke (thunk 5)) 50 | (invoke (apply-to identity (thunk 5))))) 51 | (let [v1 (thunk "first ") 52 | v2 (thunk "second ") 53 | v3 (thunk "third")] 54 | (println :apply-3 (= (invoke (apply-to comp (apply-to comp v1 v2) v3)) 55 | (invoke (apply-to comp v1 (apply-to comp v2 v3))) 56 | (invoke (apply-to comp v1 v2 v3))))) 57 | (println) 58 | 59 | (let [tv1 (thunk 1) 60 | tv5 (thunk 5)] 61 | (println :tv1 tv1) 62 | (println) 63 | (println :tv5 tv5) 64 | (println) 65 | (println :tv1-invoked (invoke tv1)) 66 | (println) 67 | (println :tv1-invoked (tv1)) 68 | (println) 69 | (println :map (map tv1 (fn [x] 70 | (println :incrementing x) 71 | (inc x)))) 72 | (println) 73 | (println :mapped (invoke (map tv1 (fn [x] 74 | (println :incrementing x) 75 | (inc x))))) 76 | (println) 77 | (println :apply (apply-to + tv1 tv5)) 78 | (println) 79 | (println :applied (invoke (apply-to + tv1 tv5))))) 80 | -------------------------------------------------------------------------------- /scripts/build: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | clang -fno-objc-arc -lpthread -g -o toccata toccata.c && 4 | ./toccata examples/hello.toc > hello.c && 5 | clang -fno-objc-arc -g -o hello hello.c && 6 | ./hello Universe 7 | -------------------------------------------------------------------------------- /scripts/build-ex: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # build-ex build examples the examples directory 3 | 4 | if [ $# -eq 0 ] 5 | then 6 | echo "Usage: 'build-ex hello' or 'build-ex hello diamond' please supply an arguments without a trailing suffixes." 7 | echo "build-ex -R ex1 ex2... forces the core to recompile first." 8 | echo "This relies on the initial toccata command being available." 9 | exit 10 | fi 11 | 12 | if [ $1 == "-R" ] 13 | then 14 | ./toccata core.toc > core.c 15 | clang -g -c -o core.a core.c 16 | clang ~/boehm/lib/libgc.a core.c -g -o toccata toccata.c 17 | shift 1 18 | fi 19 | 20 | for var in "$@" 21 | do 22 | ./toccata examples/"$var".toc > "$var".c 23 | clang ~/boehm/lib/libgc.a core.a -g -o "$var" "$var.c" 24 | done 25 | -------------------------------------------------------------------------------- /scripts/full-test: -------------------------------------------------------------------------------- 1 | 2 | scripts/build && 3 | time ./toccata toccata.toc > toccata.c && 4 | scripts/build && 5 | time ./toccata toccata.toc > toccata.c && 6 | scripts/build && 7 | time ./toccata toccata.toc > toccata.c && 8 | scripts/build -------------------------------------------------------------------------------- /scripts/profile: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | clang -fprofile-instr-generate -c -o core.a core.c && 4 | clang core.a -fprofile-instr-generate -fno-objc-arc -g -o toccata toccata.c && 5 | ./toccata toccata.toc > /dev/null 6 | llvm-profdata merge -output=toccata.profdata default.profraw && 7 | llvm-profdata show -all-functions default.profraw | grep -v Hash | grep -v Counters | sed 'N;s/:\n/:/' \ 8 | | grep -v "count: 0" | grep "Function count:" | sort --key=4 -n | tail -n 100 9 | # clang -fprofile-instr-use -g -o toccata toccata.c && 10 | echo "done" 11 | -------------------------------------------------------------------------------- /scripts/re-build: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | clang -g -o toccata toccata.c && 4 | scripts/build && 5 | time ./toccata toccata.toc > toccata.c && 6 | scripts/build 7 | -------------------------------------------------------------------------------- /scripts/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ./toccata $1.toc > $1.c && 4 | clang -fno-objc-arc -lpthread -g -o $1 $1.c && 5 | ./$1 6 | --------------------------------------------------------------------------------