From 218af254c30f35d290ab944aef1cf2b33e179224 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 18:33:25 -0400 Subject: - Refacted the compiler by shifting to a pattern-matching syntax more akin to Lux's, while also allowing non-literal tags that can be defined as constants elsewhere. - Added some extra JVM ops for bit-fiddling that were missing. --- src/lux/analyser.clj | 499 ++++++++++++++++++++++---------------------- src/lux/analyser/base.clj | 13 +- src/lux/analyser/case.clj | 157 +++++++------- src/lux/analyser/env.clj | 10 +- src/lux/analyser/host.clj | 117 ++++++----- src/lux/analyser/lambda.clj | 23 +- src/lux/analyser/lux.clj | 169 ++++++++------- src/lux/analyser/module.clj | 85 ++++---- src/lux/base.clj | 297 ++++++++++++++------------ src/lux/compiler.clj | 247 +++++++++++----------- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 24 +-- src/lux/compiler/host.clj | 67 +++--- src/lux/compiler/lambda.clj | 16 +- src/lux/compiler/lux.clj | 16 +- src/lux/compiler/type.clj | 28 +-- src/lux/host.clj | 12 +- src/lux/parser.clj | 87 ++++---- src/lux/reader.clj | 34 +-- src/lux/type.clj | 343 +++++++++++++++--------------- 20 files changed, 1141 insertions(+), 1111 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7dc4c7607..e49797fa5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -8,9 +8,9 @@ (ns lux.analyser (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail*]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -21,471 +21,483 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_catch")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?ex-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ex-arg)) + ("lux;Cons" ?catch-body + ("lux;Nil"))))))) (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_finally")) + ("lux;Cons" ?finally-body + ("lux;Nil"))))) (return (&/T catch+ (&/V "lux;Some" ?finally-body))) - [_] + _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new-array")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?length)) + ("lux;Nil"))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aastore")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Cons" ?elem + ("lux;Nil")))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aaload")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Nil"))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_class")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?super-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?interfaces)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?fields)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?methods)) + ("lux;Nil")))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_interface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?supers)) + ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_program")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?args)) + ("lux;Cons" ?body + ("lux;Nil"))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) - [_] + _ (fail ""))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2b")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2c")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2s")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iand")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ior")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ixor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_land")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lxor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - [_] + _ (aba7 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Objects - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_null?")) + ("lux;Cons" ?object + ("lux;Nil")))) (&&host/analyse-jvm-null? analyse exo-type ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_instanceof")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ?object + ("lux;Nil"))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Nil"))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Nil")))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?value + ("lux;Nil")))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Cons" ?value + ("lux;Nil"))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokestatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil"))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokevirtual")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokeinterface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokespecial")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_try")) + ("lux;Cons" ?body + ?handlers))) (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_throw")) + ("lux;Cons" ?ex + ("lux;Nil")))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorenter")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorexit")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) - [_] + _ (aba6 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) - - [_] + + _ (aba5 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Host special forms ;; Characters - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) - [_] + _ (aba4 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] + (|case token + ("lux;SymbolS" ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_case")) + ("lux;Cons" ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_lambda")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?self)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?arg)) + ("lux;Cons" ?body + ("lux;Nil")))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_def")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-def analyse compile-token ?name ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_declare-macro")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Nil")))) (&&lux/analyse-declare-macro analyse compile-token ?name) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_import")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?path)) + ("lux;Nil")))) (&&lux/analyse-import analyse compile-module compile-token ?path) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:!")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_export")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ident)) + ("lux;Nil")))) (&&lux/analyse-export analyse compile-token ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_alias")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?alias)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?module)) + ("lux;Nil"))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) - [_] + _ (aba3 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Standard special forms - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;TupleS" ?elems]] + ("lux;TupleS" ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;RecordS" ?elems]] + ("lux;RecordS" ?elems) (&&lux/analyse-record analyse exo-type ?elems) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) - [["lux;SymbolS" [_ "_jvm_null"]]] + ("lux;SymbolS" _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) - [_] + _ (aba2 analyse eval! compile-module compile-token exo-type token) )) @@ -497,30 +509,27 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) - (matchv ::M/objects [token] - [["lux;Meta" [meta ?token]]] + (|case token + ("lux;Meta" meta ?token) (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module compile-token exo-type ?token) state)] - [["lux;Right" [state* output]]] + (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" ""]] + ("lux;Left" "") (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* (add-loc (&/get$ &/$cursor state) msg)) )) - - ;; [_] - ;; (assert false (aget token 0)) )) (defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] - (matchv ::M/objects [?var ?output-type] - [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (|case [?var ?output-type] + [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) @@ -533,23 +542,21 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) ?values))) (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ?fn ?args))) (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + ("lux;Right" state* =fn) (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - [_] + _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - [_] + _ (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9fc3f1030..beeb57b08 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -7,24 +7,23 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.base - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [type :as &type]))) ;; [Exports] (defn expr-type [syntax+] - (matchv ::M/objects [syntax+] - [[_ type]] + (|let [[_ type] syntax+] (return type))) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn resolved-ident [ident] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7f2c34924..2cdf233cc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.case - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let]] + (lux [base :as & :refer [|do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -20,13 +20,13 @@ (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) (defn ^:private resolve-type [type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" [_aenv _aname _aarg _abody]]] + ("lux;AllT" _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -36,20 +36,20 @@ ;; (|do [=type (&type/apply-type type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type type))) (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - (matchv ::M/objects [type] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case type + ("lux;AllT" _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - [["lux;TupleT" ?members]] - (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] + ("lux;TupleT" ?members) + (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -63,8 +63,8 @@ up)) ?members*)))) - [["lux;RecordT" ?fields]] - (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] + ("lux;RecordT" ?fields) + (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -79,8 +79,8 @@ up)))) ?fields*)))) - [["lux;VariantT" ?cases]] - (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] + ("lux;VariantT" ?cases) + (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -95,11 +95,11 @@ up)))) ?cases*)))) - [["lux;AppT" [?tfun ?targ]]] + ("lux;AppT" ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -113,48 +113,47 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (matchv ::M/objects [pattern] - [["lux;Meta" [_ pattern*]]] - (matchv ::M/objects [pattern*] - [["lux;SymbolS" ["" name]]] + (|let [("lux;Meta" _ pattern*) pattern] + (|case pattern* + ("lux;SymbolS" "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - [["lux;SymbolS" ident]] + ("lux;SymbolS" ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - [["lux;TupleS" ?members]] + ("lux;TupleS" ?members) (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?member-types]] + (|case value-type* + ("lux;TupleT" ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -167,48 +166,48 @@ (&/|reverse (&/zip2 ?member-types ?members)))] (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - [_] + _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - [["lux;RecordS" ?slots]] + + ("lux;RecordS" ?slots) (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] + (|case value-type* + ("lux;RecordT" ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;TagS" ?ident]]]] + (|case sn + ("lux;Meta" _ ("lux;TagS" ?ident)) (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - [_] + _ (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - [_] + _ (fail "[Pattern-matching Error] Record requires record-type."))) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ?values]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -228,50 +227,50 @@ (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] - (matchv ::M/objects [struct test] - [["DefaultTotal" total?] ["StoreTestAC" ?idx]] + (|case [struct test] + [("DefaultTotal" total?) ("StoreTestAC" ?idx)] (return (&/V "DefaultTotal" true)) - [[?tag [total? ?values]] ["StoreTestAC" ?idx]] + [[?tag [total? ?values]] ("StoreTestAC" ?idx)] (return (&/V ?tag (&/T true ?values))) - [["DefaultTotal" total?] ["BoolTestAC" ?value]] + [("DefaultTotal" total?) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) - [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]] + [("BoolTotal" total? ?values) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["IntTestAC" ?value]] + [("DefaultTotal" total?) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) - [["IntTotal" [total? ?values]] ["IntTestAC" ?value]] + [("IntTotal" total? ?values) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["RealTestAC" ?value]] + [("DefaultTotal" total?) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) - [["RealTotal" [total? ?values]] ["RealTestAC" ?value]] + [("RealTotal" total? ?values) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["CharTestAC" ?value]] + [("DefaultTotal" total?) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) - [["CharTotal" [total? ?values]] ["CharTestAC" ?value]] + [("CharTotal" total? ?values) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TextTestAC" ?value]] + [("DefaultTotal" total?) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) - [["TextTotal" [total? ?values]] ["TextTestAC" ?value]] + [("TextTotal" total? ?values) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TupleTestAC" ?tests]] + [("DefaultTotal" total?) ("TupleTestAC" ?tests)] (|do [structs (&/map% (fn [t] (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] + [("TupleTotal" total? ?values) ("TupleTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) @@ -279,7 +278,7 @@ (return (&/V "TupleTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [["DefaultTotal" total?] ["RecordTestAC" ?tests]] + [("DefaultTotal" total?) ("RecordTestAC" ?tests)] (|do [structs (&/map% (fn [t] (|let [[slot value] t] (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] @@ -290,7 +289,7 @@ &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] + [("RecordTotal" total? ?values) ("RecordTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left @@ -307,12 +306,12 @@ (return (&/V "RecordTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent record-size.")) - [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] + [("DefaultTotal" total?) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) (&/T ?test ?body))] (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] + [("VariantTotal" total? ?branches) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) (&/V "DefaultTotal" total?)) (&/T ?test ?body))] @@ -320,43 +319,43 @@ )))) (defn ^:private check-totality [value-type struct] - (matchv ::M/objects [struct] - [["BoolTotal" [?total ?values]]] + (|case struct + ("BoolTotal" ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) - [["IntTotal" [?total _]]] + ("IntTotal" ?total _) (return ?total) - [["RealTotal" [?total _]]] + ("RealTotal" ?total _) (return ?total) - [["CharTotal" [?total _]]] + ("CharTotal" ?total _) (return ?total) - [["TextTotal" [?total _]]] + ("TextTotal" ?total _) (return ?total) - [["TupleTotal" [?total ?structs]]] + ("TupleTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?members]] + (|case value-type* + ("lux;TupleT" ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Tuple is not total.")))) - [["RecordTotal" [?total ?structs]]] + ("RecordTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?fields]] + (|case value-type* + ("lux;RecordT" ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -365,15 +364,15 @@ ?fields)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Record is not total.")))) - [["VariantTotal" [?total ?structs]]] + ("VariantTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;VariantT" ?cases]] + (|case value-type* + ("lux;VariantT" ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -382,10 +381,10 @@ ?cases)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Variant is not total.")))) - [["DefaultTotal" ?total]] + ("DefaultTotal" ?total) (return ?total) )) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 391d78411..a39ec490a 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.env - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail]]) + (lux [base :as & :refer [|do return return* fail |case]]) [lux.analyser.base :as &&])) ;; [Exports] @@ -31,8 +31,8 @@ (&/|head stack)) (&/|tail stack)))) state))] - (matchv ::M/objects [=return] - [["lux;Right" [?state ?value]]] + (|case =return + ("lux;Right" ?state ?value) (return* (&/update$ &/$ENVS (fn [stack*] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER dec) @@ -42,7 +42,7 @@ ?state) ?value) - [_] + _ =return)))) (def captured-vars diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index d03d0e65c..707060323 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -8,9 +8,9 @@ (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -19,39 +19,37 @@ ;; [Utils] (defn ^:private extract-text [text] - (matchv ::M/objects [text] - [["lux;Meta" [_ ["lux;TextS" ?text]]]] + (|case text + ("lux;Meta" _ ("lux;TextS" ?text)) (return ?text) - [_] + _ (fail "[Analyser Error] Can't extract Text."))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" - (matchv ::M/objects [token] - [[_ ["lux;DataT" _]]] + (|case token + [_ ("lux;DataT" _)] (return nil) - [_] + _ (fail "[Analyser Error] Expecting object"))) (defn ^:private as-object [type] "(-> Type Type)" - (matchv ::M/objects [type] - [["lux;DataT" class]] + (|case type + ("lux;DataT" class) (&/V "lux;DataT" (&type/as-obj class)) - [_] + _ type)) ;; [Resources] @@ -225,32 +223,32 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] - (matchv ::M/objects [modif] - [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (|case modif + ("lux;Meta" _ ("lux;TextS" "public")) (return (assoc so-far :visibility "public")) - [["lux;Meta" [_ ["lux;TextS" "private"]]]] + ("lux;Meta" _ ("lux;TextS" "private")) (return (assoc so-far :visibility "private")) - [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + ("lux;Meta" _ ("lux;TextS" "protected")) (return (assoc so-far :visibility "protected")) - [["lux;Meta" [_ ["lux;TextS" "static"]]]] + ("lux;Meta" _ ("lux;TextS" "static")) (return (assoc so-far :static? true)) - [["lux;Meta" [_ ["lux;TextS" "final"]]]] + ("lux;Meta" _ ("lux;TextS" "final")) (return (assoc so-far :final? true)) - [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + ("lux;Meta" _ ("lux;TextS" "abstract")) (return (assoc so-far :abstract? true)) - [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + ("lux;Meta" _ ("lux;TextS" "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + ("lux;Meta" _ ("lux;TextS" "volatile")) (return (assoc so-far :concurrency "volatile")) - [_] + _ (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) {:visibility "default" :static? false @@ -276,35 +274,35 @@ (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] - (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] - ["lux;Nil" _]]]]]]]]]]] + (|case ?field + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-type)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?field-modifiers)) + ("lux;Nil")))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers :type ?field-type})) - [_] + _ (fail "[Analyser Error] Wrong syntax for field."))) ?fields) =methods (&/map% (fn [?method] - (matchv ::M/objects [?method] - [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] - ["lux;Cons" [?method-body - ["lux;Nil" _]]]]]]]]]]]]]]]] + (|case ?method + [?idx ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-modifiers)) + ("lux;Cons" ?method-body + ("lux;Nil"))))))))] (|do [=method-inputs (&/map% (fn [minput] - (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] - ["lux;Nil" _]]]]]]]]] + (|case minput + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?input-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?input-type)) + ("lux;Nil"))))) (return (&/T ?input-name ?input-type)) - [_] + _ (fail "[Analyser Error] Wrong syntax for method input."))) ?method-inputs) =method-modifiers (analyse-modifiers ?method-modifiers) @@ -326,7 +324,7 @@ :output ?method-output :body =method-body})) - [_] + _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] @@ -335,12 +333,12 @@ (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] - (matchv ::M/objects [method] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] - ["lux;Nil" _]]]]]]]]]]]]] + (|case method + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?modifiers)) + ("lux;Nil"))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -348,7 +346,7 @@ :inputs =inputs :output ?output})) - [_] + _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] @@ -363,10 +361,10 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (matchv ::M/objects [?finally] - [["lux;None" _]] (return (&/V "lux;None" nil)) - [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] + =finally (|case [?finally] + ("lux;None") (return (&/V "lux;None" nil)) + ("lux;Some" ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V "lux;Some" =finally))))] (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] @@ -423,11 +421,14 @@ analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor "jvm-ixor" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl "jvm-ishl" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr "jvm-ishr" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr "jvm-iushr" "java.lang.Integer" "java.lang.Integer" analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 7c7b80577..a230c8642 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.lambda - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -25,13 +25,12 @@ (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] - (matchv ::M/objects [register] - [[_ register-type]] - (|let [register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) - register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) - frame))))) + (|let [[_ register-type] register + register* (&/T (&/V "captured" (&/T scope + (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + register)) + register-type)] + (&/T register* (&/update$ &/$CLOSURE #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 7aba5dd39..cd89764c3 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -8,9 +8,9 @@ (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -23,68 +23,66 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] - (matchv ::M/objects [form] - [["lux;Meta" [_ syntax]]] + (|case form + ("lux;Meta" _ syntax) (&/V "lux;Meta" (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type*] - [["lux;TupleT" ?members]] + (|case exo-type* + ("lux;TupleT" ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-tuple analyse exo-type** ?elems)))) - [_] + _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (matchv ::M/objects [?values] - [["lux;Nil" _]] + (|do [output (|case ?values + ("lux;Nil") (analyse-tuple analyse exo-type (&/|list)) - [["lux;Cons" [?value ["lux;Nil" _]]]] + ("lux;Cons" ?value ("lux;Nil")) (analyse exo-type ?value) - [_] + _ (analyse-tuple analyse exo-type ?values) )] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type ident ?values] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] (&type/actual-type &type/Type)))) - [_] + _ (&type/actual-type exo-type))] - (matchv ::M/objects [exo-type*] - [["lux;VariantT" ?cases]] + (|case exo-type* + ("lux;VariantT" ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -92,22 +90,22 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** ident ?values)))) - [_] + _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - [["lux;AllT" _]] + ("lux;AllT" _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -116,21 +114,21 @@ ;; (|do [=type (&type/apply-type exo-type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type exo-type)) - types (matchv ::M/objects [exo-type*] - [["lux;RecordT" ?table]] + types (|case exo-type* + ("lux;RecordT" ?table) (return ?table) - [_] + _ (fail (str "[Analyser Error] The type of a record must be a record type:\n" (&type/show-type exo-type*) "\n"))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] + (|case kv + [("lux;Meta" _ ["lux;TagS" ?ident]) ?value] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) @@ -138,7 +136,7 @@ =value (&&/analyse-1 analyse slot-type ?value)] (return (&/T ?tag =value))) - [_] + _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) @@ -146,14 +144,14 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -168,28 +166,28 @@ no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] + (|case outer + ("lux;Nil") (&/run-state (|do [module-name &/get-module-name] (analyse-global analyse exo-type module-name name)) state) - [["lux;Cons" [?genv ["lux;Nil" _]]]] + ("lux;Cons" ?genv ("lux;Nil")) (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* name*]] _]] + (|case global + [("lux;Global" ?module* name*) _] ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -204,7 +202,7 @@ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) - [["lux;Cons" [top-outer _]]] + ("lux;Cons" top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) @@ -232,15 +230,15 @@ (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] ;; (prn 'analyse-apply* (aget fun-type 0)) - (matchv ::M/objects [?args] - [["lux;Nil" _]] + (|case ?args + ("lux;Nil") (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type (&/|list)))) - [["lux;Cons" [?arg ?args*]]] + ("lux;Cons" ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case ?fun-type* + ("lux;AllT" _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -248,8 +246,8 @@ (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) @@ -258,7 +256,7 @@ (return (&/T type** =args))) )))) - [["lux;LambdaT" [?input-t ?output-t]]] + ("lux;LambdaT" ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) @@ -266,19 +264,18 @@ ;; [["lux;VarT" ?id-t]] ;; (|do [ (&type/deref ?id-t)]) - [_] + _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (matchv ::M/objects [=fn] - [[=fn-form =fn-type]] - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] + (|let [[=fn-form =fn-type] =fn] + (|case =fn-form + ("lux;Global" ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] + (|case $def + ("lux;MacroD" macro) (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] @@ -293,12 +290,12 @@ ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t)))))) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t))))) @@ -316,8 +313,8 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type] - [["lux;AllT" _]] + (|case exo-type + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -326,38 +323,38 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - [["lux;LambdaT" [?arg-t ?return-t]]] + ("lux;LambdaT" ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) - [_] + _ (fail (str "[Analyser Error] Functions require function types: " (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;AllT" [_env _self _arg _body]]] + (|case exo-type + ("lux;AllT" _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] - (matchv ::M/objects [dtype] - [["lux;BoundT" ?vname]] + (|case dtype + ("lux;BoundT" ?vname) (return (&/T _expr exo-type)) - [["lux;ExT" _]] + ("lux;ExT" _) (return (&/T _expr exo-type)) - [["lux;VarT" ?_id]] + ("lux;VarT" ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? @@ -365,11 +362,11 @@ (return (&/T _expr exo-type))) ) - [_] + _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) - [_] + _ (|do [exo-type* (&type/actual-type exo-type)] (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) @@ -389,15 +386,15 @@ (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] - (matchv ::M/objects [=value] - [[["lux;Global" [?r-module ?r-name]] _]] + (|case =value + [("lux;Global" ?r-module ?r-name) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] (return (&/|list))) - [_] + _ (do (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] (return (&/|list))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 327dad27f..c92b7b976 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -9,9 +9,9 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail*]] + (lux [base :as & :refer [|let |do return return* fail fail* |case]] [type :as &type] [host :as &host]) [lux.analyser.base :as &&])) @@ -44,8 +44,8 @@ (defn define [module name def-data type] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -57,7 +57,7 @@ ms)))) nil) - [_] + _ (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) (defn def-type [module name] @@ -65,17 +65,17 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[_ ["lux;TypeD" _]]] + (|case $def + [_ ("lux;TypeD" _)] (return* state &type/Type) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (return* state &type/Macro) - [[_ ["lux;ValueD" [_type _]]]] + [_ ("lux;ValueD" _type _)] (return* state _type) - [[_ ["lux;AliasD" [?r-module ?r-name]]]] + [_ ("lux;AliasD" ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) @@ -84,8 +84,8 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -97,7 +97,7 @@ ms)))) nil) - [_] + _ (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] @@ -133,17 +133,16 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[exported? $$def]] + (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] + (|case $$def + ("lux;AliasD" ?r-module ?r-name) (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) ((find-def ?r-module ?r-name) state)) - [_] + _ (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) @@ -158,8 +157,8 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" [?type _]]]] + (|case $def + [exported? ("lux;ValueD" ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -178,24 +177,24 @@ nil))) state) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ _]] + [_ _] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[true _]] + (|case $def + [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) - [[false ?data]] + [false ?data] (return* (->> state (&/update$ &/$MODULES (fn [ms] (&/|update module (fn [m] @@ -206,7 +205,7 @@ nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) - [_] + _ (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) (def defs @@ -214,22 +213,20 @@ (fn [state] (return* state (&/|map (fn [kv] - (|let [[k v] kv] - (matchv ::M/objects [v] - [[?exported? ?def]] - (do ;; (prn 'defs k ?exported?) - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") - - [["lux;TypeD" _]] - (&/T ?exported? k "T") - - [_] - (&/T ?exported? k "V")))))) + (|let [[k [?exported? ?def]] kv] + (do ;; (prn 'defs k ?exported?) + (|case ?def + ("lux;AliasD" ?r-module ?r-name) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + ("lux;MacroD" _) + (&/T ?exported? k "M") + + ("lux;TypeD" _) + (&/T ?exported? k "T") + + _ + (&/T ?exported? k "V"))))) (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) (def imports diff --git a/src/lux/base.clj b/src/lux/base.clj index 85e8df4d1..bcd113daa 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,6 +12,7 @@ clojure.core.match.array)) ;; [Tags] +(def $Nil "lux;Nil") (def $Cons "lux;Cons") ;; [Fields] @@ -73,10 +74,33 @@ (defn return* [state value] (V "lux;Right" (T state value))) +(defn transform-pattern [pattern] + (cond (vector? pattern) (mapv transform-pattern pattern) + (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] + (vec (cons (eval (first pattern)) + (list (case (count parts) + 0 '_ + 1 (first parts) + ;; else + `[~@parts]))))) + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T ~@value)] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + (defmacro |let [bindings body] (reduce (fn [inner [left right]] - `(matchv ::M/objects [~right] - [~left] + `(|case ~right + ~left ~inner)) body (reverse (partition 2 bindings)))) @@ -94,59 +118,62 @@ (reverse (partition 2 elems)))) (defn |get [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) nil - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) v (|get slot table*)))) (defn |put [slot value table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))))) + (V "lux;Cons" (T (T k v) (|put slot value table*)))) + + _ + (assert false (prn-str '|put (aget table 0))))) (defn |remove [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) (defn |update [k f table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k* v] table*]]] + ($Cons [k* v] table*) (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) (defn |head [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [x _]]] + ($Cons x _) x)) (defn |tail [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [_ xs*]]] + ($Cons _ xs*) xs*)) ;; [Resources/Monads] @@ -161,11 +188,11 @@ (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] - (matchv ::M/objects [inputs] - [["lux;Right" [?state ?datum]]] + (|case inputs + ("lux;Right" ?state ?datum) ((step ?datum) ?state) - [["lux;Left" _]] + ("lux;Left" _) inputs )))) @@ -177,8 +204,8 @@ ;; else `(bind ~computation (fn [val#] - (matchv ::M/objects [val#] - [~label] + (|case val# + ~label ~inner))))) return (reverse (partition 2 steps)))) @@ -188,90 +215,90 @@ (V "lux;Cons" (T head tail))) (defn |++ [xs ys] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) ys - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (|++ xs* ys))))) (defn |map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T (f x) (|map f xs*))))) (defn |empty? [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) true - [["lux;Cons" [_ _]]] + ($Cons _ _) false)) (defn |filter [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (V "lux;Cons" (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|++ (f x) (flat-map f xs*)))) (defn |split-with [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (T xs xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] (T (|cons x pre) post)) (T (V "lux;Nil" nil) xs)))) (defn |contains? [k table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) false - [["lux;Cons" [[k* _] table*]]] + ($Cons [k* _] table*) (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) init - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (fold f (f init x) xs*))) (defn fold% [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [init* (f init x)] (fold% f init* xs*)))) (defn folds [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (|list init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|cons init (folds f (f init x) xs*)))) (defn |length [xs] @@ -293,47 +320,47 @@ _2)) (defn zip2 [xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) [_ _] (V "lux;Nil" nil))) (defn |keys [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons k (|keys plist*)))) (defn |vals [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons v (|vals plist*)))) (defn |interpose [sep xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [_ ["lux;Nil" _]]]] + ($Cons _ ($Nil)) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [y (f x) ys ( f xs*)] (return ( y ys))))) @@ -345,11 +372,11 @@ (fold |++ (V "lux;Nil" nil) xss)) (defn |as-pairs [xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] + (|case xs + ($Cons x ($Cons y xs*)) (V "lux;Cons" (T (T x y) (|as-pairs xs*))) - [_] + _ (V "lux;Nil" nil))) (defn |reverse [xs] @@ -368,18 +395,18 @@ (return* state state))) (defn try-all% [monads] - (matchv ::M/objects [monads] - [["lux;Nil" _]] + (|case monads + ($Nil) (fail "There are no alternatives to try!") - [["lux;Cons" [m monads*]]] + ($Cons m monads*) (fn [state] (let [output (m state)] - (matchv ::M/objects [output monads*] - [["lux;Right" _] _] + (|case [output monads*] + [("lux;Right" _) _] output - [_ ["lux;Nil" _]] + [_ ($Nil)] output [_ _] @@ -395,11 +422,11 @@ (defn exhaust% [step] (fn [state] - (matchv ::M/objects [(step state)] - [["lux;Right" [state* _]]] + (|case (step state) + ("lux;Right" state* _) ((exhaust% step) state*) - [["lux;Left" msg]] + ("lux;Left" msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -510,23 +537,23 @@ (defn save-module [body] (fn [state] - (matchv ::M/objects [(body state)] - [["lux;Right" [state* output]]] + (|case (body state) + ("lux;Right" state* output) (return* (->> state* (set$ $ENVS (get$ $ENVS state)) (set$ $SOURCE (get$ $SOURCE state))) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (defn with-eval [body] (fn [state] - (matchv ::M/objects [(body (set$ $EVAL? true state))] - [["lux;Right" [state* output]]] + (|case (body (set$ $EVAL? true state)) + ("lux;Right" state* output) (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (def get-eval @@ -536,11 +563,11 @@ (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - (matchv ::M/objects [writer*] - [["lux;Some" datum]] + (|case writer* + ("lux;Some" datum) (return* state datum) - [_] + _ (fail* "Writer hasn't been set."))))) (def get-top-local-env @@ -556,11 +583,11 @@ (return* (set$ $SEED (inc seed) state) seed)))) (defn ->seq [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (list) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (cons x (->seq xs*)))) (defn ->list [seq] @@ -575,21 +602,21 @@ (def get-module-name (fn [state] - (matchv ::M/objects [(|reverse (get$ $ENVS state))] - [["lux;Nil"]] + (|case (|reverse (get$ $ENVS state)) + ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") - [["lux;Cons" [?global _]]] + ($Cons ?global _) (return* state (get$ $NAME ?global))))) (defn with-scope [name body] (fn [state] (let [output (body (update$ $ENVS #(|cons (env name) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [state* datum]]] + (|case output + ("lux;Right" state* datum) (return* (update$ $ENVS |tail state*) datum) - [_] + _ output)))) (defn run-state [monad state] @@ -611,24 +638,24 @@ (defn with-writer [writer body] (fn [state] (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) ?value) - [_] + _ output)))) (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] (let [output (body (set$ $EXPECTED type state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) ?value) - [_] + _ output)))) (defn with-cursor [cursor body] @@ -637,50 +664,50 @@ body (fn [state] (let [output (body (set$ $cursor cursor state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $cursor (get$ $cursor state) ?state) ?value) - [_] + _ output))))) (defn show-ast [ast] - (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;BoolS" ?value]]]] + (|case ast + ("lux;Meta" _ ["lux;BoolS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;IntS" ?value]]]] + ("lux;Meta" _ ["lux;IntS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;RealS" ?value]]]] + ("lux;Meta" _ ["lux;RealS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;CharS" ?value]]]] + ("lux;Meta" _ ["lux;CharS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;TextS" ?value]]]] + ("lux;Meta" _ ["lux;TextS" ?value]) (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] + ("lux;Meta" _ ["lux;TagS" ?module ?tag]) (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] + ("lux;Meta" _ ["lux;SymbolS" ?module ?ident]) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] + ("lux;Meta" _ ["lux;TupleS" ?elems]) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] + ("lux;Meta" _ ["lux;RecordS" ?elems]) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;FormS" ?elems]]]] + ("lux;Meta" _ ["lux;FormS" ?elems]) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) @@ -689,57 +716,57 @@ (str ?module ";" ?name))) (defn fold2% [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [init* (f init x y)] (fold2% f init* xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return init) [_ _] (fail "Lists don't match in size."))) (defn map2% [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] (return (|cons z zs))) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return (V "lux;Nil" nil)) [_ _] (fail "Lists don't match in size."))) (defn map2 [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|cons (f x y) (map2 f xs* ys*)) [_ _] (V "lux;Nil" nil))) (defn fold2 [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (and init (fold2 f (f init x y) xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] init [_ _] false)) (defn ^:private enumerate* [idx xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x xs*]]] + (|case xs + ($Cons x xs*) (V "lux;Cons" (T (T idx x) (enumerate* (inc idx) xs*))) - [["lux;Nil" _]] + ($Nil) xs )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4c12f9519..7463bdce7 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -11,9 +11,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail* |case]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -38,327 +38,338 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - (matchv ::M/objects [syntax] - [[?form ?type]] - (matchv ::M/objects [?form] - [["bool" ?value]] + (|let [[?form ?type] syntax] + (|case ?form + ("bool" ?value) (&&lux/compile-bool compile-expression ?type ?value) - [["int" ?value]] + ("int" ?value) (&&lux/compile-int compile-expression ?type ?value) - [["real" ?value]] + ("real" ?value) (&&lux/compile-real compile-expression ?type ?value) - [["char" ?value]] + ("char" ?value) (&&lux/compile-char compile-expression ?type ?value) - [["text" ?value]] + ("text" ?value) (&&lux/compile-text compile-expression ?type ?value) - [["tuple" ?elems]] + ("tuple" ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - [["record" ?elems]] + ("record" ?elems) (&&lux/compile-record compile-expression ?type ?elems) - [["lux;Local" ?idx]] + ("lux;Local" ?idx) (&&lux/compile-local compile-expression ?type ?idx) - [["captured" [?scope ?captured-id ?source]]] + ("captured" ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - [["lux;Global" [?owner-class ?name]]] + ("lux;Global" ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?args]]] + ("apply" ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - [["variant" [?tag ?members]]] + ("variant" ?tag ?members) (&&lux/compile-variant compile-expression ?type ?tag ?members) - [["case" [?value ?match]]] + ("case" ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) - [["lambda" [?scope ?env ?body]]] + ("lambda" ?scope ?env ?body) (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - [["ann" [?value-ex ?type-ex]]] + ("ann" ?value-ex ?type-ex) (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) ;; Characters - [["jvm-ceq" [?x ?y]]] + ("jvm-ceq" ?x ?y) (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - [["jvm-clt" [?x ?y]]] + ("jvm-clt" ?x ?y) (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - [["jvm-cgt" [?x ?y]]] + ("jvm-cgt" ?x ?y) (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] + ("jvm-iadd" ?x ?y) (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - [["jvm-isub" [?x ?y]]] + ("jvm-isub" ?x ?y) (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - [["jvm-imul" [?x ?y]]] + ("jvm-imul" ?x ?y) (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - [["jvm-idiv" [?x ?y]]] + ("jvm-idiv" ?x ?y) (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - [["jvm-irem" [?x ?y]]] + ("jvm-irem" ?x ?y) (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - [["jvm-ieq" [?x ?y]]] + ("jvm-ieq" ?x ?y) (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - [["jvm-ilt" [?x ?y]]] + ("jvm-ilt" ?x ?y) (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - [["jvm-igt" [?x ?y]]] + ("jvm-igt" ?x ?y) (&&host/compile-jvm-igt compile-expression ?type ?x ?y) ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] + ("jvm-ladd" ?x ?y) (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - [["jvm-lsub" [?x ?y]]] + ("jvm-lsub" ?x ?y) (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - [["jvm-lmul" [?x ?y]]] + ("jvm-lmul" ?x ?y) (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - [["jvm-ldiv" [?x ?y]]] + ("jvm-ldiv" ?x ?y) (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - [["jvm-lrem" [?x ?y]]] + ("jvm-lrem" ?x ?y) (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - [["jvm-leq" [?x ?y]]] + ("jvm-leq" ?x ?y) (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - [["jvm-llt" [?x ?y]]] + ("jvm-llt" ?x ?y) (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - [["jvm-lgt" [?x ?y]]] + ("jvm-lgt" ?x ?y) (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] + ("jvm-fadd" ?x ?y) (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - [["jvm-fsub" [?x ?y]]] + ("jvm-fsub" ?x ?y) (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - [["jvm-fmul" [?x ?y]]] + ("jvm-fmul" ?x ?y) (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - [["jvm-fdiv" [?x ?y]]] + ("jvm-fdiv" ?x ?y) (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - [["jvm-frem" [?x ?y]]] + ("jvm-frem" ?x ?y) (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - [["jvm-feq" [?x ?y]]] + ("jvm-feq" ?x ?y) (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - [["jvm-flt" [?x ?y]]] + ("jvm-flt" ?x ?y) (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - [["jvm-fgt" [?x ?y]]] + ("jvm-fgt" ?x ?y) (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] + ("jvm-dadd" ?x ?y) (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - [["jvm-dsub" [?x ?y]]] + ("jvm-dsub" ?x ?y) (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - [["jvm-dmul" [?x ?y]]] + ("jvm-dmul" ?x ?y) (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - [["jvm-ddiv" [?x ?y]]] + ("jvm-ddiv" ?x ?y) (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - [["jvm-drem" [?x ?y]]] + ("jvm-drem" ?x ?y) (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - [["jvm-deq" [?x ?y]]] + ("jvm-deq" ?x ?y) (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - [["jvm-dlt" [?x ?y]]] + ("jvm-dlt" ?x ?y) (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - [["jvm-dgt" [?x ?y]]] + ("jvm-dgt" ?x ?y) (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - [["jvm-null" _]] + ("jvm-null" _) (&&host/compile-jvm-null compile-expression ?type) - [["jvm-null?" ?object]] + ("jvm-null?" ?object) (&&host/compile-jvm-null? compile-expression ?type ?object) - [["jvm-new" [?class ?classes ?args]]] + ("jvm-new" ?class ?classes ?args) (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - [["jvm-getstatic" [?class ?field]]] + ("jvm-getstatic" ?class ?field) (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - [["jvm-getfield" [?class ?field ?object]]] + ("jvm-getfield" ?class ?field ?object) (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - [["jvm-putstatic" [?class ?field ?value]]] + ("jvm-putstatic" ?class ?field ?value) (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - [["jvm-putfield" [?class ?field ?object ?value]]] + ("jvm-putfield" ?class ?field ?object ?value) (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] + ("jvm-invokestatic" ?class ?method ?classes ?args) (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + ("jvm-invokevirtual" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + ("jvm-invokeinterface" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + ("jvm-invokespecial" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-new-array" [?class ?length]]] + ("jvm-new-array" ?class ?length) (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] + ("jvm-aastore" ?array ?idx ?elem) (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] + ("jvm-aaload" ?array ?idx) (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] + ("jvm-try" ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] + ("jvm-throw" ?ex) (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] + ("jvm-monitorenter" ?monitor) (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] + ("jvm-monitorexit" ?monitor) (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] + ("jvm-d2f" ?value) (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] + ("jvm-d2i" ?value) (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] + ("jvm-d2l" ?value) (&&host/compile-jvm-d2l compile-expression ?type ?value) - [["jvm-f2d" ?value]] + ("jvm-f2d" ?value) (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] + ("jvm-f2i" ?value) (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] + ("jvm-f2l" ?value) (&&host/compile-jvm-f2l compile-expression ?type ?value) - [["jvm-i2b" ?value]] + ("jvm-i2b" ?value) (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] + ("jvm-i2c" ?value) (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] + ("jvm-i2d" ?value) (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] + ("jvm-i2f" ?value) (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] + ("jvm-i2l" ?value) (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] + ("jvm-i2s" ?value) (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] + ("jvm-l2d" ?value) (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] + ("jvm-l2f" ?value) (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] + ("jvm-l2i" ?value) (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] + ("jvm-iand" ?x ?y) (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] + ("jvm-ior" ?x ?y) (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] + ("jvm-ixor" ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) + + ("jvm-ishl" ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) + + ("jvm-ishr" ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) + + ("jvm-iushr" ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) + + ("jvm-land" ?x ?y) (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] + ("jvm-lor" ?x ?y) (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] + ("jvm-lxor" ?x ?y) (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] + ("jvm-lshl" ?x ?y) (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] + ("jvm-lshr" ?x ?y) (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] + ("jvm-lushr" ?x ?y) (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - [["jvm-instanceof" [?class ?object]]] + ("jvm-instanceof" ?class ?object) (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) (defn ^:private compile-statement [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private compile-token [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) - [_] + _ (compile-expression syntax))) (defn ^:private eval! [expr] @@ -413,10 +424,10 @@ ;; _ (prn 'compile-module name =class) ]] (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + ("lux;Right" ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports :let [_ (doto =class @@ -437,7 +448,7 @@ (&&/save-class! "_" (.toByteArray =class))) ?state) - [["lux;Left" ?message]] + ("lux;Left" ?message) (fail* ?message))))))) )) )) @@ -448,11 +459,11 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] - [["lux;Right" [?state _]]] + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + ("lux;Right" ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) (&&package/package program-module)) - [["lux;Left" ?message]] + ("lux;Left" ?message) (assert false ?message))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 565eae898..2b6f2e919 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -10,9 +10,9 @@ (:refer-clojure :exclude [load]) (:require [clojure.string :as string] [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -126,8 +126,8 @@ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-meta (get-field "_meta" def-class)] - (matchv ::M/objects [def-meta] - [["lux;ValueD" [def-type _]]] + (|case def-meta + ("lux;ValueD" def-type _) (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 906cc1ca8..d27577be1 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -9,9 +9,9 @@ (ns lux.compiler.case (:require (clojure [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -26,13 +26,13 @@ ;; [Utils] (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - (matchv ::M/objects [?match] - [["StoreTestAC" ?idx]] + (|case ?match + ("StoreTestAC" ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - [["BoolTestAC" ?value]] + ("BoolTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,7 +42,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["IntTestAC" ?value]] + ("IntTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) @@ -53,7 +53,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RealTestAC" ?value]] + ("RealTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) @@ -64,7 +64,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["CharTestAC" ?value]] + ("CharTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +74,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TextTestAC" ?value]] + ("TextTestAC" ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +83,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TupleTestAC" ?members]] + ("TupleTestAC" ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,7 +101,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RecordTestAC" ?slots]] + ("RecordTestAC" ?slots) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -124,7 +124,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["VariantTestAC" [?tag ?test]]] + ("VariantTestAC" ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 542bd9a40..bde19d8fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -51,35 +51,35 @@ double-class "java.lang.Double" char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] - (matchv ::M/objects [*type*] - [["lux;TupleT" ["lux;Nil" _]]] + (|case *type* + ("lux;TupleT" ("lux;Nil")) (.visitInsn *writer* Opcodes/ACONST_NULL) - [["lux;DataT" "boolean"]] + ("lux;DataT" "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - [["lux;DataT" "byte"]] + ("lux;DataT" "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - [["lux;DataT" "short"]] + ("lux;DataT" "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - [["lux;DataT" "int"]] + ("lux;DataT" "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - [["lux;DataT" "long"]] + ("lux;DataT" "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - [["lux;DataT" "float"]] + ("lux;DataT" "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - [["lux;DataT" "double"]] + ("lux;DataT" "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - [["lux;DataT" "char"]] + ("lux;DataT" "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - [["lux;DataT" _]] + ("lux;DataT" _) nil) *writer*)) @@ -413,16 +413,16 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + compile-finally (|case ?finally + ("lux;Some" ?finally*) (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -447,14 +447,14 @@ catch-boundaries) ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (|case ?finally + ("lux;Some" ?finally*) (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) @@ -533,11 +533,14 @@ compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index ccd12e68a..0d1ea4844 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -46,8 +46,8 @@ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -83,8 +83,8 @@ (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] + (|case ?name+?captured + [?name [("captured" _ _ ?source) _]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -101,8 +101,8 @@ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index def5220f7..9a3a7a6f2 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -138,8 +138,8 @@ (defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [def-type] - ["type"] + (|case def-type + "type" (|do [:let [;; ?type* (&&type/->analysis ?type) _ (doto **writer** ;; Tail: Begin @@ -160,13 +160,13 @@ ] (return nil)) - ["value"] + "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - ?def-type (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] + ?def-type (|case ?body + [("ann" ?def-value ?type-expr) ?def-type] ?type-expr - [[?def-value ?def-type]] + [?def-value ?def-type] (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 01141f8e4..bfa322206 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.compiler.type - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]))) ;; [Utils] @@ -39,18 +39,18 @@ ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" - (matchv ::M/objects [type] - [["lux;DataT" ?class]] + (|case type + ("lux;DataT" ?class) (variant$ "lux;DataT" (text$ ?class)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (variant$ "lux;TupleT" (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - [["lux;VariantT" ?cases]] + ("lux;VariantT" ?cases) (variant$ "lux;VariantT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -59,7 +59,7 @@ $Nil (&/|reverse ?cases))) - [["lux;RecordT" ?slots]] + ("lux;RecordT" ?slots) (variant$ "lux;RecordT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -68,16 +68,16 @@ $Nil (&/|reverse ?slots))) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (variant$ "lux;AllT" - (tuple$ (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] + (tuple$ (&/|list (|case ?env + ("lux;None") (variant$ "lux;None" (tuple$ (&/|list))) - [["lux;Some" ??env]] + ("lux;Some" ??env) (variant$ "lux;Some" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (variant$ "lux;BoundT" (text$ ?name)) - [["lux;AppT" [?fun ?arg]]] + ("lux;AppT" ?fun ?arg) (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 91582c526..2414d97b6 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,9 +9,9 @@ (ns lux.host (:require (clojure [string :as string] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) (:import (java.lang.reflect Field Method Modifier))) @@ -68,14 +68,14 @@ )) (defn ->java-sig [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" ?name]] + (|case type + ("lux;DataT" ?name) (->type-signature ?name) - [["lux;LambdaT" [_ _]]] + ("lux;LambdaT" _ _) (->type-signature function-class) - [["lux;TupleT" ["lux;Nil" _]]] + ("lux;TupleT" ("lux;Nil")) "V" )) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 966c322bf..aa05b48af 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -8,9 +8,9 @@ (ns lux.parser (:require [clojure.template :refer [do-template]] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail]] + (lux [base :as & :refer [|do return fail |case]] [lexer :as &lexer]))) ;; [Utils] @@ -18,11 +18,11 @@ (defn [parse] (|do [elems (&/repeat% parse) token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta [ _]]]] + (|case token + ("lux;Meta" meta [ _]) (return (&/V (&/fold &/|++ (&/|list) elems))) - [_] + _ (fail (str "[Parser Error] Unbalanced " "."))))) ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" @@ -33,60 +33,59 @@ (|do [elems* (&/repeat% parse) token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["Close_Brace" _]]]] + (|case token + ("lux;Meta" meta ("Close_Brace" _)) (if (even? (&/|length elems)) (return (&/V "lux;RecordS" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) - [_] + _ (fail (str "[Parser Error] Unbalanced braces."))))) ;; [Interface] (def parse - (|do [token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta token*]]] - (matchv ::M/objects [token*] - [["White_Space" _]] - (return (&/|list)) + (|do [token &lexer/lex + :let [("lux;Meta" meta token*) token]] + (|case token* + ("White_Space" _) + (return (&/|list)) - [["Comment" _]] - (return (&/|list)) - - [["Bool" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + ("Comment" _) + (return (&/|list)) + + ("Bool" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) - [["Int" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + ("Int" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) - [["Real" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + ("Real" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) - [["Char" ^String ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + ("Char" ^String ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) - [["Text" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + ("Text" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) - [["Symbol" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + ("Symbol" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) - [["Tag" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + ("Tag" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) - [["Open_Paren" _]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["Open_Bracket" _]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Paren" _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + + ("Open_Bracket" _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [["Open_Brace" _]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Brace" _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [_] - (fail "[Parser Error] Unknown lexer token.") - )))) + _ + (fail "[Parser Error] Unknown lexer token.") + ))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 9fd9b14ea..6bda8f166 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -8,40 +8,40 @@ (ns lux.reader (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let]])) + [lux.base :as & :refer [|do return* return fail fail* |let |case]])) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;Nil" _]] + (|case (&/get$ &/$SOURCE state) + ("lux;Nil") (fail* "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] line] - more]]] - (matchv ::M/objects [(body file-name line-num column-num line)] - [["No" msg]] + ("lux;Cons" [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ("No" msg) (fail* msg) - [["Done" output]] + ("Done" output) (return* (&/set$ &/$SOURCE more state) output) - [["Yes" [output line*]]] + ("Yes" output line*) (return* (&/set$ &/$SOURCE (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] - [["lux;Right" [reader* match]]] + (|case (body (&/get$ &/$SOURCE state)) + ("lux;Right" reader* match) (return* (&/set$ &/$SOURCE reader* state) match) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg) ))) @@ -102,12 +102,12 @@ (fn [reader] (loop [prefix "" reader* reader] - (matchv ::M/objects [reader*] - [["lux;Nil" _]] + (|case reader* + ("lux;Nil") (&/V "lux;Left" "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] ^String line] - reader**]]] + ("lux;Cons" [[file-name line-num column-num] ^String line] + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) diff --git a/src/lux/type.clj b/src/lux/type.clj index e4117492c..ab8ea4e61 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -8,9 +8,9 @@ (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -191,33 +191,33 @@ (defn bound? [id] (fn [state] (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type] - [["lux;Some" type*]] + (|case type + ("lux;Some" type*) (return* state true) - [["lux;None" _]] + ("lux;None") (return* state false)) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn deref [id] (fn [state] (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] + (|case type* + ("lux;Some" type) (return* state type) - [["lux;None" _]] + ("lux;None") (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [tvar] - [["lux;Some" bound]] + (|case tvar + ("lux;Some" bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - [["lux;None" _]] + ("lux;None") (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) ts)) state) @@ -251,18 +251,18 @@ (|let [[?id ?type] binding] (if (.equals ^Object id ?id) (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] + (|case ?type + ("lux;None") (return binding) - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] + ("lux;Some" ?type*) + (|case ?type* + ("lux;VarT" ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V "lux;None" nil))) (return binding)) - [_] + _ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V "lux;Some" ?type**))))) )))) @@ -288,46 +288,46 @@ (return output))) (defn clean* [?tid type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - [["lux;LambdaT" [?arg ?return]]] + ("lux;LambdaT" ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] (return (&/V "lux;LambdaT" (&/T =arg =return)))) - [["lux;AppT" [?lambda ?param]]] + ("lux;AppT" ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] (return (&/V "lux;AppT" (&/T =lambda =param)))) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (&/V "lux;TupleT" =members))) - [["lux;VariantT" ?members]] + ("lux;VariantT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;VariantT" =members))) - [["lux;RecordT" ?members]] + ("lux;RecordT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;RecordT" =members))) - [["lux;AllT" [?env ?name ?arg ?body]]] - (|do [=env (matchv ::M/objects [?env] - [["lux;None" _]] + ("lux;AllT" ?env ?name ?arg ?body) + (|do [=env (|case ?env + ("lux;None") (return ?env) - [["lux;Some" ?env*]] + ("lux;Some" ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) @@ -336,96 +336,96 @@ body* (clean* ?tid ?body)] (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) - [_] + _ (return type) )) (defn clean [tvar type] - (matchv ::M/objects [tvar] - [["lux;VarT" ?id]] + (|case tvar + ("lux;VarT" ?id) (clean* ?id type) - [_] + _ (fail (str "[Type Error] Not type-var: " (show-type tvar))))) (defn ^:private unravel-fun [type] - (matchv ::M/objects [type] - [["lux;LambdaT" [?in ?out]]] + (|case type + ("lux;LambdaT" ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) - [_] + _ (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] - (matchv ::M/objects [fun-type] - [["lux;AppT" [?left ?right]]] + (|case fun-type + ("lux;AppT" ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) - [_] + _ (&/T fun-type (&/|list)))) (defn show-type [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" name]] + (|case type + ("lux;DataT" name) (str "(^ " name ")") - [["lux;TupleT" elems]] + ("lux;TupleT" elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;VariantT" cases]] + ("lux;VariantT" cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["lux;TupleT" ["lux;Nil" _]]]] + (|case kv + [k ("lux;TupleT" ("lux;Nil"))] (str "#" k) - [[k v]] + [k v] (str "(#" k " " (show-type v) ")")))) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;RecordT" fields]] + ("lux;RecordT" fields) (str "(& " (->> fields (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k v]] + (|case kv + [k v] (str "#" k " " (show-type v))))) (&/|interpose " ") (&/fold str "")) ")") - [["lux;LambdaT" [input output]]] + ("lux;LambdaT" input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - [["lux;VarT" id]] + ("lux;VarT" id) (str "⌈" id "⌋") - [["lux;ExT" ?id]] + ("lux;ExT" ?id) (str "⟨" ?id "⟩") - [["lux;BoundT" name]] + ("lux;BoundT" name) name - [["lux;AppT" [_ _]]] + ("lux;AppT" _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] + (|case body* + ("lux;AllT" ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) - [_] + _ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) @@ -433,17 +433,17 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] + (let [output (|case [x y] + [("lux;DataT" xname) ("lux;DataT" yname)] (.equals ^Object xname yname) - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + [("lux;TupleT" xelems) ("lux;TupleT" yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + [("lux;VariantT" xcases) ("lux;VariantT" ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + [("lux;RecordT" xslots) ("lux;RecordT" yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [["lux;VarT" xid] ["lux;VarT" yid]] + [("lux;VarT" xid) ("lux;VarT" yid)] (.equals ^Object xid yid) - [["lux;BoundT" xname] ["lux;BoundT" yname]] + [("lux;BoundT" xname) ("lux;BoundT" yname)] (.equals ^Object xname yname) - [["lux;ExT" xid] ["lux;ExT" yid]] + [("lux;ExT" xid) ("lux;ExT" yid)] (.equals ^Object xid yid) - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -501,11 +501,11 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] - (matchv ::M/objects [fixpoints] - [["lux;Nil" _]] + (|case fixpoints + ("lux;Nil") (&/V "lux;None" nil) - [["lux;Cons" [[[e* a*] v*] fixpoints*]]] + ("lux;Cons" [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) (&/V "lux;Some" v*) @@ -521,73 +521,64 @@ "\n")) (defn beta-reduce [env type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (&/V "lux;VariantT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - [["lux;RecordT" ?fields]] + ("lux;RecordT" ?fields) (&/V "lux;RecordT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) - [["lux;AppT" [?type-fn ?type-arg]]] + ("lux;AppT" ?type-fn ?type-arg) (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]] - (matchv ::M/objects [?local-env] - [["lux;None" _]] + ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (|case ?local-env + ("lux;None") (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) - [["lux;Some" _]] + ("lux;Some" _) type) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) - [_] + _ type )) -(defn slot-type [record slot] - (fn [state] - (matchv ::M/objects [(&/|get slot record)] - [["lux;Left" msg]] - (fail* msg) - - [["lux;Right" type]] - (return* state type)))) - (defn apply-type [type-fn param] - (matchv ::M/objects [type-fn] - [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [local-env* (matchv ::M/objects [local-env] - [["lux;None" _]] + (|case type-fn + ("lux;AllT" local-env local-name local-arg local-def) + (let [local-env* (|case local-env + ("lux;None") (&/|table) - [["lux;Some" local-env*]] + ("lux;Some" local-env*) local-env*)] (return (beta-reduce (->> local-env* (&/|put local-name type-fn) (&/|put local-arg param)) local-def))) - [["lux;AppT" [F A]]] + ("lux;AppT" F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) - [_] + _ (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] @@ -610,85 +601,85 @@ (defn ^:private check* [class-loader fixpoints expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (|case [expected actual] + [("lux;VarT" ?eid) ("lux;VarT" ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] + (|case ((deref ?eid) state) + ("lux;Right" state* ebound) (return* state* (&/V "lux;Some" ebound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil)))) abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] + (|case ((deref ?aid) state) + ("lux;Right" state* abound) (return* state* (&/V "lux;Some" abound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] + (|case [ebound abound] + [("lux;None" _) ("lux;None" _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [["lux;Some" etype] ["lux;None" _]] + [("lux;Some" etype) ("lux;None" _)] (check* class-loader fixpoints etype actual) - [["lux;None" _] ["lux;Some" atype]] + [("lux;None" _) ("lux;Some" atype)] (check* class-loader fixpoints expected atype) - [["lux;Some" etype] ["lux;Some" atype]] + [("lux;Some" etype) ("lux;Some" atype)] (check* class-loader fixpoints etype atype)))) - [["lux;VarT" ?id] _] + [("lux;VarT" ?id) _] (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id actual) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints bound actual)) state))) - [_ ["lux;VarT" ?id]] + [_ ("lux;VarT" ?id)] (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id expected) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints expected bound)) state))) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?eid)] + (fn [state] + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + ("lux;Right" state* output) + (return* state* output) + + ("lux;Left" _) + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + ("lux;Left" _) + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) @@ -697,15 +688,15 @@ ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) @@ -719,15 +710,15 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) @@ -741,7 +732,7 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F A]] _] + [("lux;AppT" F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -752,33 +743,33 @@ (&/|interpose "\n\n") (&/fold str ""))) (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] + (|case (fp-get fp-pair fixpoints) + ("lux;Some" ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - [["lux;None" _]] + ("lux;None") (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ["lux;AppT" [F A]]] + [_ ("lux;AppT" F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [["lux;AllT" _] _] + [("lux;AllT" _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ["lux;AllT" _]] + [_ ("lux;AllT" _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" e!name] ["lux;DataT" "null"]] + [("lux;DataT" e!name) ("lux;DataT" "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -791,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + [("lux;TupleT" e!members) ("lux;TupleT" a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -803,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] + [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -815,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -827,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [["lux;ExT" e!id] ["lux;ExT" a!id]] + [("lux;ExT" e!id) ("lux;ExT" a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -842,41 +833,41 @@ (return nil))) (defn apply-lambda [func param] - (matchv ::M/objects [func] - [["lux;LambdaT" [input output]]] + (|case func + ("lux;LambdaT" input output) (|do [_ (check* init-fixpoints input param)] (return output)) - [["lux;AllT" _]] + ("lux;AllT" _) (with-var (fn [$var] (|do [func* (apply-type func $var) =return (apply-lambda func* param)] (clean $var =return)))) - [_] + _ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] - (matchv ::M/objects [type] - [["lux;AppT" [?all ?param]]] + (|case type + ("lux;AppT" ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (deref ?id) - [_] + _ (return type) )) (defn variant-case [case type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) - [_] + _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) -- cgit v1.2.3