diff options
Diffstat (limited to '')
-rw-r--r-- | src/lux.clj | 12 | ||||
-rw-r--r-- | src/lux/analyser.clj | 169 | ||||
-rw-r--r-- | src/lux/analyser/host.clj | 222 | ||||
-rw-r--r-- | src/lux/analyser/lux.clj | 4 | ||||
-rw-r--r-- | src/lux/base.clj | 5 | ||||
-rw-r--r-- | src/lux/compiler.clj | 27 | ||||
-rw-r--r-- | src/lux/compiler/base.clj | 32 | ||||
-rw-r--r-- | src/lux/compiler/cache.clj | 7 | ||||
-rw-r--r-- | src/lux/compiler/host.clj | 206 | ||||
-rw-r--r-- | src/lux/compiler/package.clj | 61 | ||||
-rw-r--r-- | src/lux/host.clj | 16 | ||||
-rw-r--r-- | src/lux/type.clj | 150 |
12 files changed, 544 insertions, 367 deletions
diff --git a/src/lux.clj b/src/lux.clj index 9c913c9ac..7e3627cd7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -10,13 +10,15 @@ (:gen-class) (:require [lux.base :as &] [lux.compiler :as &compiler] - [lux.type :as &type] :reload-all)) -(defn -main [& _] - (time (&compiler/compile-all (&/|list "lux" "program"))) - (System/exit 0)) +(defn -main [& [program-module & _]] + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + (System/exit 0) + ) (comment - ;; cd output && jar cvf program.jar * && java -cp "program.jar" program && cd .. + (-main "program") ) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 1606a95c2..de7fc8497 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |list]] + (lux [base :as & :refer [|let |do return fail return* fail*]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,16 +23,16 @@ (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;SymbolS" [_ ?ex-class]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) + (&/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" _]]]]]]]]] - (&/T catch+ ?finally-body))) + (&/T catch+ (&/V "lux;Some" ?finally-body)))) (defn ^:private aba7 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] @@ -62,7 +62,8 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ?methods]]]]]]]]]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] + ["lux;Nil" _]]]]]]]]]]]]]]] (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] @@ -85,74 +86,74 @@ (matchv ::M/objects [token] ;; Primitive conversions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2f analyse ?value) + (&&host/analyse-jvm-d2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2i analyse ?value) + (&&host/analyse-jvm-d2i analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-d2l analyse ?value) + (&&host/analyse-jvm-d2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2d analyse ?value) + (&&host/analyse-jvm-f2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2i analyse ?value) + (&&host/analyse-jvm-f2i analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-f2l analyse ?value) + (&&host/analyse-jvm-f2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2b analyse ?value) + (&&host/analyse-jvm-i2b analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2c analyse ?value) + (&&host/analyse-jvm-i2c analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2d analyse ?value) + (&&host/analyse-jvm-i2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2f analyse ?value) + (&&host/analyse-jvm-i2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2l analyse ?value) + (&&host/analyse-jvm-i2l analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-i2s analyse ?value) + (&&host/analyse-jvm-i2s analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2d analyse ?value) + (&&host/analyse-jvm-l2d analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2f analyse ?value) + (&&host/analyse-jvm-l2f analyse exo-type ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-l2i analyse ?value) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-iand analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ior analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-land analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lor analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lxor analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lshl analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lshr analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lushr analyse ?x ?y) + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) [_] (aba7 analyse eval! compile-module exo-type token))) @@ -163,40 +164,40 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] ["lux;Cons" [?object ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-null? analyse ?object) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-instanceof analyse ?class ?object) + (&&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" _]]]]]]]]]]] - (&&host/analyse-jvm-new analyse ?class ?classes ?args) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-getstatic analyse ?class ?field) + (&&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" _]]]]]]]]]]] - (&&host/analyse-jvm-getfield analyse ?class ?field ?object) + (&&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" _]]]]]]]]]]] - (&&host/analyse-jvm-putstatic analyse ?class ?field ?value) + (&&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]]] @@ -204,7 +205,7 @@ ["lux;Cons" [?object ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-putfield analyse ?class ?field ?object ?value) + (&&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]]] @@ -212,7 +213,7 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]] - (&&host/analyse-jvm-invokestatic analyse ?class ?method ?classes ?args) + (&&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]]] @@ -221,7 +222,7 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args) + (&&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]]] @@ -230,7 +231,7 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokeinterface analyse ?class ?method ?classes ?object ?args) + (&&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]]] @@ -239,29 +240,29 @@ ["lux;Cons" [?object ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-invokespecial analyse ?class ?method ?classes ?object ?args) - + (&&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]]]]]] - (&&host/analyse-jvm-try analyse ?body (&/fold parse-handler [(list) nil] ?handlers)) + (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-throw analyse ?ex) + (&&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" _]]]]]]] - (&&host/analyse-jvm-monitorenter analyse ?monitor) + (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] ["lux;Cons" [?monitor ["lux;Nil" _]]]]]]] - (&&host/analyse-jvm-monitorexit analyse ?monitor) + (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) [_] (aba6 analyse eval! compile-module exo-type token))) @@ -270,53 +271,53 @@ (matchv ::M/objects [token] ;; Float arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-fadd analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-fsub analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-fmul analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-fdiv analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-frem analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-feq analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-flt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-fgt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-dadd analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-dsub analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-dmul analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ddiv analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-drem analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-deq analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-dlt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-dgt analyse ?x ?y) + (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) [_] (aba5 analyse eval! compile-module exo-type token))) @@ -326,63 +327,63 @@ ;; Host special forms ;; Characters [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-ceq analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-clt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-cgt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-iadd analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-isub analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-imul analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-idiv analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-irem analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ieq analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ilt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-igt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ladd analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lsub analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lmul analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-ldiv analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lrem analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-leq analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-llt analyse ?x ?y) + (&&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" _]]]]]]]]] - (&&host/analyse-jvm-lgt analyse ?x ?y) + (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) [_] (aba4 analyse eval! compile-module exo-type token))) @@ -445,7 +446,7 @@ [_] (aba3 analyse eval! compile-module exo-type token))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (|list))))] +(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] (defn ^:private aba1 [analyse eval! compile-module exo-type token] (matchv ::M/objects [token] ;; Standard special forms @@ -479,7 +480,7 @@ (&&lux/analyse-variant analyse exo-type ?ident unit) [["lux;SymbolS" [_ "_jvm_null"]]] - (return (&/|list (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" "null")))) + (&&host/analyse-jvm-null analyse exo-type) [_] (aba2 analyse eval! compile-module exo-type token) @@ -505,7 +506,11 @@ [["lux;Left" msg]] (fail* (add-loc meta msg)) - )))) + )) + + ;; [_] + ;; (assert false (aget token 0)) + )) (defn ^:private just-analyse [analyse-ast eval! compile-module syntax] (&type/with-var diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 11d43ce9e..5033f4f2c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -36,13 +36,32 @@ (return (&/T ?item =type))) ))))) +(defn ^:private ensure-object [token] + "(-> Analysis (Lux (,)))" + (matchv ::M/objects [token] + [[_ ["lux;DataT" _]]] + (return nil) + + [_] + (fail "[Analyser Error] Expecting object"))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (matchv ::M/objects [type] + [["lux;DataT" class]] + (&/V "lux;DataT" (&type/as-obj class)) + + [_] + type)) + ;; [Resources] (do-template [<name> <output-tag> <input-class> <output-class>] (let [input-type (&/V "lux;DataT" <input-class>) output-type (&/V "lux;DataT" <output-class>)] - (defn <name> [analyse ?x ?y] + (defn <name> [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y)] + =y (&&/analyse-1 analyse input-type ?y) + _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V <output-tag> (&/T =x =y)) output-type)))))) analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" @@ -86,94 +105,121 @@ analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse ?class ?field] - (|do [=type (&host/lookup-static-field ?class ?field)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) =type))))) - -(defn analyse-jvm-getfield [analyse ?class ?field ?object] - (|do [=type (&host/lookup-static-field ?class ?field) - =object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) =type))))) - -(defn analyse-jvm-putstatic [analyse ?class ?field ?value] - (|do [=type (&host/lookup-static-field ?class ?field) - =value (&&/analyse-1 analyse =type ?value)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) =type))))) +(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + :let [output-type =type] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type))))) -(defn analyse-jvm-putfield [analyse ?class ?field ?object ?value] - (|do [=type (&host/lookup-static-field ?class ?field) +(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse =type ?value)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) =type))))) - -(defn analyse-jvm-invokestatic [analyse ?class ?method ?classes ?args] - (|do [=classes (&/map% extract-text ?classes) - =return (&host/lookup-static-method ?class ?method =classes) + :let [output-type =type] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) + +(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =value (&&/analyse-1 analyse =type ?value) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type))))) + +(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] + (|do [class-loader &/loader + =type (&host/lookup-static-field class-loader ?class ?field) + =object (&&/analyse-1 analyse ?object) + =value (&&/analyse-1 analyse =type ?value) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type))))) + +(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] ;; [["lux;DataT" _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) =classes - ?args)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) =return))))) + ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) -(defn analyse-jvm-instanceof [analyse ?class ?object] +(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) - :let [[_obj _type] =object]] - (matchv ::M/objects [_type] - [["lux;DataT" _]] - (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class ?object)) (&/V "lux;DataT" "java.lang.Boolean")))) - - [_] - (fail "[Analyser Error] Can only use instanceof with object types.")))) + _ (ensure-object =object) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type))))) (do-template [<name> <tag>] - (defn <name> [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% extract-text ?classes) - =return (&host/lookup-virtual-method ?class ?method =classes) + (defn <name> [analyse exo-type ?class ?method ?classes ?object ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) + =return (&host/lookup-virtual-method class-loader ?class ?method =classes) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args)] - (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) =return))))) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =classes ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual "jvm-invokevirtual" analyse-jvm-invokeinterface "jvm-invokeinterface" ) -(defn analyse-jvm-invokespecial [analyse ?class ?method ?classes ?object ?args] - (|do [=classes (&/map% extract-text ?classes) +(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] + (|do [class-loader &/loader + =classes (&/map% extract-text ?classes) =return (if (= "<init>" ?method) - (return &type/$Void) - (&host/lookup-virtual-method ?class ?method =classes)) + (return &type/Unit) + (&host/lookup-virtual-method class-loader ?class ?method =classes)) =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) - =classes ?args)] - (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) =return))))) + =classes ?args) + :let [output-type =return] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type))))) + +(defn analyse-jvm-null? [analyse exo-type ?object] + (|do [=object (analyse-1+ analyse ?object) + _ (ensure-object =object) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) -(defn analyse-jvm-null? [analyse ?object] - (|do [=object (&&/analyse-1 analyse ?object)] - (return (&/|list (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" "java.lang.Boolean")))))) +(defn analyse-jvm-null [analyse exo-type] + (|do [:let [output-type (&/V "lux;DataT" "null")] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) -(defn analyse-jvm-new [analyse ?class ?classes ?args] +(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) - =args (&/flat-map% analyse ?args)] - (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) (&/V "lux;DataT" ?class)))))) + =args (&/map% (partial analyse-1+ analyse) ?args) + :let [output-type (&/V "lux;DataT" ?class)] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) (&/V "lux;Nil" nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (&&/analyse-1 analyse &type/$Void ?array) - =elem (&&/analyse-1 analyse &type/$Void ?elem) + (|do [=array (analyse-1+ analyse ?array) + =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (&&/analyse-1 analyse ?array) + (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) @@ -259,7 +305,7 @@ (return (&/T (&/ident->text ?input-name) ?input-type)) [_] - (fail "[Analyser Error] Wrong syntax for method."))) + (fail "[Analyser Error] Wrong syntax for method input."))) ?method-inputs) =method-modifiers (analyse-modifiers ?method-modifiers) =method-body (&/with-scope (str ?name "_" ?idx) @@ -302,37 +348,49 @@ :output ?output})) [_] - (fail "[Analyser Error] Invalid method signature!"))) + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods)] (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) -(defn analyse-jvm-try [analyse ?body [?catches ?finally]] - (|do [=body (&&/analyse-1 analyse ?body) +(defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] + (|do [:let [[?catches ?finally] ?catches+?finally] + =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) - (|do [=catch-body (&&/analyse-1 analyse ?catch-body)] - (return [?ex-class ?ex-arg =catch-body])))) + (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (&&/analyse-1 analyse exo-type ?catch-body)) + idx &&env/next-local-idx] + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (&&/analyse-1 analyse ?finally) - =body-type (&&/expr-type =body)] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) =body-type))))) - -(defn analyse-jvm-throw [analyse ?ex] - (|do [=ex (&&/analyse-1 analyse ?ex)] + =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))))] + (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) + +(defn analyse-jvm-throw [analyse exo-type ?ex] + (|do [=ex (analyse-1+ analyse ?ex) + :let [[_obj _type] =ex] + _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) -(defn analyse-jvm-monitorenter [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) - -(defn analyse-jvm-monitorexit [analyse ?monitor] - (|do [=monitor (&&/analyse-1 analyse ?monitor)] - (return (&/|list (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))) +(do-template [<name> <tag>] + (defn <name> [analyse exo-type ?monitor] + (|do [=monitor (analyse-1+ analyse ?monitor) + _ (ensure-object =monitor) + :let [output-type &type/Unit] + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =monitor) output-type))))) + + analyse-jvm-monitorenter "jvm-monitorenter" + analyse-jvm-monitorexit "jvm-monitorexit" + ) (do-template [<name> <tag> <from-class> <to-class>] - (defn <name> [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)] - (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>)))))) + (let [output-type (&/V "lux;DataT" <to-class>)] + (defn <name> [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer" @@ -355,9 +413,11 @@ ) (do-template [<name> <tag> <from-class> <to-class>] - (defn <name> [analyse ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value)] - (return (&/|list (&/T (&/V <tag> =value) (&/V "lux;DataT" <to-class>)))))) + (let [output-type (&/V "lux;DataT" <to-class>)] + (defn <name> [analyse exo-type ?value] + (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" <from-class>) ?value) + _ (&type/check exo-type output-type)] + (return (&/|list (&/T (&/V <tag> =value) output-type)))))) analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4a912f1c1..065e150d9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -261,11 +261,11 @@ (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "open" ?name)) + ;; (= "case" ?name)) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "open")))] + ;; (prn ?module "case")))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) diff --git a/src/lux/base.clj b/src/lux/base.clj index 9f0a78fa7..eb94c2c90 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -466,7 +466,10 @@ (findClass [^String class-name] ;; (prn 'findClass class-name) (if-let [^bytes bytecode (get @store class-name)] - (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (catch java.lang.reflect.InvocationTargetException e + (prn 'InvocationTargetException (.getCause e)) + (throw e))) (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index bb1c72f66..3449900e0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -28,7 +28,8 @@ [lux :as &&lux] [host :as &&host] [case :as &&case] - [lambda :as &&lambda])) + [lambda :as &&lambda] + [package :as &&package])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -383,17 +384,18 @@ (fail "[Compiler Error] Can't redefine a module!") (|do [_ (&a-module/enter-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd))]] + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] (fn [state] - (matchv ::M/objects [((&/exhaust% compiler-step) - (->> state - (&/set$ &/$SOURCE (&reader/from file-name file-content)) - (&/update$ &/$HOST #(&/set$ &/$WRITER (&/V "lux;Some" =class) %))))] + (matchv ::M/objects [((&/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 @@ -409,7 +411,9 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil (->> imports (&/|interpose "\t") (&/fold str ""))) .visitEnd) - (.visitEnd))]] + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] (&&/save-class! "_" (.toByteArray =class))) ?state) @@ -421,12 +425,13 @@ (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] -(defn compile-all [modules] +(defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module modules) (&/init-state nil))] + (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] [["lux;Right" [?state _]]] (do (println "Compilation complete!") - (&&cache/clean ?state)) + (&&cache/clean ?state) + (&&package/package program-module)) [["lux;Left" ?message]] (assert false ?message))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 0631f51e8..28339c162 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -7,7 +7,8 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.compiler.base - (:require [clojure.string :as string] + (:require (clojure [template :refer [do-template]] + [string :as string]) [clojure.java.io :as io] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array @@ -29,6 +30,7 @@ (def ^String version "0.2") (def ^String input-dir "source") (def ^String output-dir "target/jvm") +(def ^String output-package (str output-dir "/program.jar")) (def ^String function-class "lux/Function") (def ^String local-prefix "l") @@ -59,7 +61,31 @@ !classes &/classes :let [real-name (str (&host/->module-class module) "." name) _ (swap! !classes assoc real-name bytecode) - _ (load-class! loader real-name) _ (when (not eval?) - (write-output module name bytecode))]] + (write-output module name bytecode)) + _ (load-class! loader real-name)]] (return nil))) + +(do-template [<name> <class> <sig> <dup>] + (defn <name> [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC <class> "valueOf" (str <sig> (&host/->type-signature <class>)))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW <class>) ;; XW + ;; (.visitInsn <dup>) ;; WXW + ;; (.visitInsn <dup>) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>) ;; W + ;; ) + ) + + wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 + wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 + wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 + wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 + wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 + wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 + wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 + wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 57e81a2b0..c0d978146 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -55,8 +55,11 @@ (defn clean [state] "(-> Compiler (,))" (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) - outdated? #(-> ^File % .getName (string/replace " " "/") (->> (contains? needed-modules)) not) - outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?))] + outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) + outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) + program-file (new File &&/output-package)] + (when (.exists program-file) + (.delete program-file)) (doseq [f outdate-files] (clean-file f)) nil)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 3df09b29e..346b66fd2 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (matchv ::M/objects [*type*] - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] (.visitInsn *writer* Opcodes/ACONST_NULL) [["lux;DataT" "boolean"]] @@ -84,7 +84,7 @@ *writer*)) ;; [Resources] -(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>] +(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrap>] (defn <name> [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer @@ -98,32 +98,32 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>)) _ (doto *writer* (.visitInsn <opcode>) - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (&host/->type-signature <wrapper-class>))))]] + (<wrap>))]] (return nil))) - compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" - compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)" + compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" &&/wrap-int + compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" &&/wrap-int - compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)" - - compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" - compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)" + compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" &&/wrap-long + compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" &&/wrap-long + + compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" &&/wrap-float + compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" &&/wrap-float - compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" - compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)" + compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" &&/wrap-double + compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" &&/wrap-double ) (do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig>] @@ -205,31 +205,50 @@ (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class ?class) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) (prepare-return! *type*))]] (return nil))) (do-template [<name> <op>] (defn <name> [compile *type* ?class ?method ?classes ?object ?args] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn <op> (&host/->class ?class) ?method method-sig) + (.visitMethodInsn <op> ?class* ?method method-sig) (prepare-return! *type*))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) +(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] + (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + _ (compile ?object) + ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "<init>" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) + (prepare-return! *type*))]] + (return nil))) + (defn compile-jvm-null [compile *type*] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] @@ -293,31 +312,33 @@ (defn compile-jvm-getstatic [compile *type* ?class ?field] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*)) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) (prepare-return! *type*))]] (return nil))) (defn compile-jvm-getfield [compile *type* ?class ?field ?object] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST (&host/->class ?class)) - (.visitFieldInsn Opcodes/GETFIELD (&host/->class ?class) ?field (&host/->java-sig *type*)) + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) (prepare-return! *type*))]] (return nil))) (defn compile-jvm-putstatic [compile *type* ?class ?field ?value] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] (return nil))) (defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class (&type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer _ (compile ?object) _ (compile ?value) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host/->class ?class))] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD (&host/->class ?class) ?field (&host/->java-sig *type*))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] (return nil))) (defn ^:private modifiers->int [mods] @@ -336,11 +357,12 @@ 0))) (defn compile-jvm-instanceof [compile *type* class object] - (|do [^MethodVisitor *writer* &/get-writer + (|do [:let [class* (&host/->class class)] + ^MethodVisitor *writer* &/get-writer _ (compile object) :let [_ (doto *writer* - (.visitLdcInsn class) - (.visitTypeInsn Opcodes/INSTANCEOF class))]] + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] (return nil))) (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] @@ -391,46 +413,50 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (if ?finally - (|do [_ (return nil) - _ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) - _ (.visitLabel *writer* $from)] + 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))) + 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) + ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] + ] + (doto *writer* + (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) + (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) + _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)] + :let [_ (.visitLabel *writer* $from)] _ (compile ?body) :let [_ (.visitLabel *writer* $to)] _ compile-finally - handlers (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [:let [$handler-start (new Label) - $handler-end (new Label)] - _ (compile ?catch-body) - :let [_ (.visitLabel *writer* $handler-end)] - _ compile-finally] - (return [?ex-class $handler-start $handler-end]))) - ?catches) + handlers (&/map2% (fn [[?ex-class ?ex-idx ?catch-body] [_ $handler-start $handler-end]] + (|do [:let [_ (doto *writer* + (.visitLabel $handler-start) + (.visitVarInsn Opcodes/ASTORE ?ex-idx))] + _ (compile ?catch-body) + :let [_ (.visitLabel *writer* $handler-end)]] + compile-finally)) + ?catches + catch-boundaries) + ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (if ?finally - (|do [_ (compile ?finally) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/ATHROW))]] - (return nil)) - (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (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))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $end)] - :let [_ (doseq [[?ex-class $handler-start $handler-end] handlers] - (doto *writer* - (.visitTryCatchBlock $from $to $handler-start ?ex-class) - (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil)) - ) - _ (.visitTryCatchBlock *writer* $from $to $catch-finally nil)]] + :let [_ (.visitLabel *writer* $end)]] (return nil))) (defn compile-jvm-throw [compile *type* ?ex] @@ -518,12 +544,17 @@ ) (defn compile-jvm-program [compile ?body] - (|do [^ClassWriter *writer* &/get-writer] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'compile-jvm-program module-name)] + ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) (|do [^MethodVisitor main-writer &/get-writer - :let [$loop (new Label) + :let [;; _ (prn "#1" module-name *writer*) + $loop (new Label) + ;; _ (prn "#2") $end (new Label) + ;; _ (prn "#3") _ (doto main-writer ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S @@ -589,14 +620,21 @@ (.visitLabel $end) ;; VI (.visitInsn Opcodes/POP) ;; V (.visitVarInsn Opcodes/ASTORE (int 0)) ;; - )] + ) + ;; _ (prn "#4") + ] _ (compile ?body) - :let [_ (doto main-writer + :let [;; _ (prn "#5") + _ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) + ;; _ (prn "#6") + ] :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; _ (prn "#7") + ]] (return nil))))) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj new file mode 100644 index 000000000..40639e85a --- /dev/null +++ b/src/lux/compiler/package.clj @@ -0,0 +1,61 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.package + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io File + FileInputStream + FileOutputStream + BufferedInputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.getName file)] + (doseq [$class (.listFiles file)] + (write-class! module-name $class out)))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + ;; (prn 'package module) + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + )) diff --git a/src/lux/host.clj b/src/lux/host.clj index cf9830169..906e3c714 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -18,6 +18,7 @@ ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) +(def module-separator "_") ;; [Utils] (defn ^:private class->type [^Class class] @@ -27,7 +28,7 @@ "") (.getSimpleName class)))] (if (.equals "void" base) - (return &type/$Void) + (return &type/Unit) (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) @@ -40,7 +41,7 @@ (string/replace class #"\." "/")) (defn ^String ->module-class [module-name] - (string/replace module-name #"/" " ")) + (string/replace module-name #"/" module-separator)) (def ->package ->module-class) @@ -71,13 +72,13 @@ [["lux;LambdaT" [_ _]]] (->type-signature function-class) - [["lux;VariantT" ["lux;Nil" _]]] + [["lux;TupleT" ["lux;Nil" _]]] "V" )) (do-template [<name> <static?>] - (defn <name> [target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName target)) + (defn <name> [class-loader target field] + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object field (.getName =field)) (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] @@ -90,8 +91,9 @@ ) (do-template [<name> <static?>] - (defn <name> [target method-name args] - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName target)) + (defn <name> [class-loader target method-name args] + ;; (prn '<name> target method-name) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object <static?> (Modifier/isStatic (.getModifiers =method))) (&/fold2 #(and %1 (.equals ^Object %2 %3)) diff --git a/src/lux/type.clj b/src/lux/type.clj index af2bbf30f..f5b8d3f25 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -587,12 +587,24 @@ [_] (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) -(def init-fixpoints (&/|list)) - -(def counter (atom {})) -(defn ^:private check* [fixpoints expected actual] - ;; (swap! counter update-in [[(aget expected 0) (aget actual 0)]] - ;; #(inc (or % 0))) +(defn as-obj [class] + (case class + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + class)) + +(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) + +(def ^:private init-fixpoints (&/|list)) + +(defn ^:private check* [class-loader fixpoints expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (matchv ::M/objects [expected actual] @@ -619,13 +631,13 @@ (return (&/T fixpoints nil))) [["lux;Some" etype] ["lux;None" _]] - (check* fixpoints etype actual) + (check* class-loader fixpoints etype actual) [["lux;None" _] ["lux;Some" atype]] - (check* fixpoints expected atype) + (check* class-loader fixpoints expected atype) [["lux;Some" etype] ["lux;Some" atype]] - (check* fixpoints etype atype)))) + (check* class-loader fixpoints etype atype)))) [["lux;VarT" ?id] _] (fn [state] @@ -635,7 +647,7 @@ [["lux;Left" _]] ((|do [bound (deref ?id)] - (check* fixpoints bound actual)) + (check* class-loader fixpoints bound actual)) state))) [_ ["lux;VarT" ?id]] @@ -646,7 +658,7 @@ [["lux;Left" _]] ((|do [bound (deref ?id)] - (check* fixpoints expected bound)) + (check* class-loader fixpoints expected bound)) state))) [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] @@ -654,13 +666,13 @@ (matchv ::M/objects [((|do [F1 (deref ?eid)] (fn [state] (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (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* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) state)))) state)] [["lux;Right" [state* output]]] @@ -668,62 +680,62 @@ [["lux;Left" _]] (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - [fixpoints** _] (check* fixpoints* A1 A2)] + ((|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))) state)))) - ;; (|do [_ (check* fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) - ;; _ (check* fixpoints A1 A2)] + ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] (fn [state] (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) - [fixpoints** _] (check* fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints (&/V "lux;VarT" ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] (fn [state] (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state)] [["lux;Right" [state* output]]] (return* state* output) [["lux;Left" _]] - ((|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) - [fixpoints** _] (check* fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* fixpoints F1 (&/V "lux;VarT" ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) [["lux;AppT" [F A]] _] @@ -745,85 +757,44 @@ [["lux;None" _]] (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) expected* actual)))) + (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) [_ ["lux;AppT" [F A]]] (|do [actual* (apply-type F A)] - (check* fixpoints expected actual*)) + (check* class-loader fixpoints expected actual*)) [["lux;AllT" _] _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] - (check* fixpoints expected* actual)))) + (check* class-loader fixpoints expected* actual)))) [_ ["lux;AllT" _]] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] - (check* fixpoints expected actual*)))) - - [["lux;DataT" "boolean"] ["lux;DataT" "java.lang.Boolean"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "byte"] ["lux;DataT" "java.lang.Byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "short"] ["lux;DataT" "java.lang.Short"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "int"] ["lux;DataT" "java.lang.Integer"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "long"] ["lux;DataT" "java.lang.Long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "float"] ["lux;DataT" "java.lang.Float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "double"] ["lux;DataT" "java.lang.Double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "char"] ["lux;DataT" "java.lang.Character"]] - (return (&/T fixpoints nil)) + (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" "java.lang.Boolean"] ["lux;DataT" "boolean"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Byte"] ["lux;DataT" "byte"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Short"] ["lux;DataT" "short"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Integer"] ["lux;DataT" "int"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Long"] ["lux;DataT" "long"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Float"] ["lux;DataT" "float"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Double"] ["lux;DataT" "double"]] - (return (&/T fixpoints nil)) - - [["lux;DataT" "java.lang.Character"] ["lux;DataT" "char"]] - (return (&/T fixpoints nil)) + [["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))) [["lux;DataT" e!name] ["lux;DataT" a!name]] - (if (or (.equals ^Object e!name a!name) - (.isAssignableFrom (Class/forName e!name) (Class/forName a!name))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))) + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (if (or (.equals ^Object e!name a!name) + (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (return (&/T fixpoints nil)) + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] - (|do [[fixpoints* _] (check* fixpoints aI eI)] - (check* fixpoints* eO aO)) + (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] + (check* class-loader fixpoints* eO aO)) [["lux;TupleT" e!members] ["lux;TupleT" a!members]] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* fp e a)] + (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) fixpoints e!members a!members)] @@ -834,7 +805,7 @@ (|let [[e!name e!type] e!case [a!name a!type] a!case] (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] + (|do [[fp* _] (check* class-loader fp e!type a!type)] (return fp*)) (fail (check-error expected actual))))) fixpoints @@ -846,7 +817,7 @@ (|let [[e!name e!type] e!slot [a!name a!type] a!slot] (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* fp e!type a!type)] + (|do [[fp* _] (check* class-loader fp e!type a!type)] (return fp*)) (fail (check-error expected actual))))) fixpoints @@ -863,7 +834,8 @@ ))) (defn check [expected actual] - (|do [_ (check* init-fixpoints expected actual)] + (|do [class-loader &/loader + _ (check* class-loader init-fixpoints expected actual)] (return nil))) (defn apply-lambda [func param] |