diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/lux/analyser.clj | 62 | ||||
| -rw-r--r-- | src/lux/analyser/host.clj | 307 | ||||
| -rw-r--r-- | src/lux/base.clj | 5 | ||||
| -rw-r--r-- | src/lux/compiler.clj | 24 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 166 | ||||
| -rw-r--r-- | src/lux/host.clj | 69 | ||||
| -rw-r--r-- | src/lux/type.clj | 6 |
7 files changed, 390 insertions, 249 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 03709b226..a412362d9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -71,85 +71,85 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) (&&host/analyse-jvm-znewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-bnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-baload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-snewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-saload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-inewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-iaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-lnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-faload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-dnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-daload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-cnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) @@ -173,6 +173,14 @@ (|do [=supers (&/map% extract-text ?supers)] (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil)))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) + ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] (&/$Cons [_ (&/$SymbolS "" ?args)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index db04a60c0..f6963d8bf 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -12,7 +12,9 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &&] - [env :as &&env]))) + [lambda :as &&lambda] + [env :as &&env]) + [lux.compiler.base :as &c!base])) ;; [Utils] (defn ^:private extract-text [ast] @@ -65,14 +67,6 @@ output))))) )) -(defn ^:private analyse-1+ [analyse token] - (&type/with-var - (fn [$var] - (|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 (,)))" (|case token @@ -215,7 +209,7 @@ (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type class object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -258,14 +252,14 @@ (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) + (|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 exo-type] - (|do [:let [output-type (&type/Data$ "null" &/Nil$)] + (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) @@ -280,18 +274,23 @@ (do-template [<class> <new-name> <new-tag> <load-name> <load-tag> <store-name> <store-tag>] (let [elem-type (&type/Data$ <class> &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + length-type &type/Int + idx-type &type/Int] (defn <new-name> [analyse length] - (return (&/|list (&/T (&/V <new-tag> length) array-type)))) + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V <new-tag> =length) array-type))))) (defn <load-name> [analyse array idx] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V <load-tag> (&/T =array idx)) elem-type))))) + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V <load-tag> (&/T =array =idx)) elem-type))))) (defn <store-name> [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V <store-tag> (&/T =array idx =elem)) array-type))))) + (return (&/|list (&/T (&/V <store-tag> (&/T =array =idx =elem)) array-type))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -304,30 +303,35 @@ "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore ) -(defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) - -(defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) +(let [length-type &type/Int + idx-type &type/Int] + (defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + + (defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) -(defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + (defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) @@ -367,68 +371,85 @@ :concurrency nil} modifiers)) -(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [class-loader &/loader - abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) - =fields (&/map% (fn [?field] - (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$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] - (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] - (|do [=method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/T ?input-name ?input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - ?method-inputs) - =method-modifiers (analyse-modifiers ?method-modifiers) - =method-body (&/with-scope (str ?name "_" ?idx) - (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) - body*))) - (if (= "void" ?method-output) - (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) - (&/|reverse (if (:static? =method-modifiers) - =method-inputs - (&/Cons$ (&/T "this" ?super-class) - =method-inputs)))))] - (return {:name ?method-name - :modifiers =method-modifiers - :inputs (&/|map &/|second =method-inputs) - :output ?method-output - :body =method-body})) - - _ - (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods)) - ;; Test for method completion +(defn ^:private analyse-field [field] + (|case field + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$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."))) + +(defn ^:private analyse-method [analyse name owner-class method] + (|case method + [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons method-body + (&/$Nil)))))))]] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs) + =method-body (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) + body*))) + (if (= "void" method-output) + (&&/analyse-1+ analyse method-body) + (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) + (&/|reverse (&/Cons$ (&/T "this" owner-class) + =method-inputs)))] + (return {:name method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output method-output + :body =method-body})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + +(defn ^:private analyse-method-decl [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Nil))))))] + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name + :modifiers =modifiers + :inputs =inputs + :output output})) + + _ + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] (assoc mmap (:name mentry) mentry)) {} - =methods) + methods) missing-method (&/fold (fn [missing abs-meth] (|let [[am-name am-inputs] abs-meth] (or missing @@ -442,36 +463,74 @@ am-name)) am-name)))) nil - abstract-methods)] - _ (if (nil? missing-method) - (return nil) - (fail (str "[Analyser Error] Missing method: " missing-method))) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] - ] - (return &/Nil$))) + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))))) + +(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] + (&/with-closure + (|do [module &/get-module-name + ;; :let [_ (prn 'analyse-jvm-class/_0)] + =fields (&/map% analyse-field fields) + ;; :let [_ (prn 'analyse-jvm-class/_1)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-class/_2)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-class/_3)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] - (|do [=methods (&/map% (fn [method] - (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] - (return {:name method-name - :modifiers =modifiers - :inputs =inputs - :output output})) - - _ - (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] + (|do [module &/get-module-name + =methods (&/map% analyse-method-decl methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [(&&/$captured _ _ source) _]] + source)) + +(let [captured-slot-modifier {:visibility "private" + :static? false + :final? false + :abstract? false + :concurrency nil} + captured-slot-type "java.lang.Object"] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (&/with-closure + (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] + module &/get-module-name + scope &/get-scope-name + ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] + :let [name (&host/location (&/|tail scope)) + anon-class (str module "." name)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] + =captured &&env/captured-vars + :let [=fields (&/|map (fn [idx+capt] + {:name (str &c!base/closure-prefix (aget idx+capt 0)) + :modifiers captured-slot-modifier + :type captured-slot-type}) + (&/enumerate =captured)) + ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) + ;; =methods* (rename-captured-vars) + ] + :let [sources (&/|map captured-source =captured)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] + ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + :let [_ (println 'DEF anon-class)]] + (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) + )))) + (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] @@ -485,19 +544,17 @@ (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally (&/$None) (return &/None$) - (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] (return (&/V &/$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 (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) (do-template [<name> <tag>] (defn <name> [analyse exo-type ?monitor] - (|do [=monitor (analyse-1+ analyse ?monitor) + (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 4c5d8ae44..0e164f5d2 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -749,10 +749,11 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* (update$ $host #(set$ $writer old-writer %) ?state) ?value) _ diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d6bbb17ae..048b9ee1d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -405,23 +405,6 @@ ) )) -(defn ^:private compile-statement [syntax] - (|case syntax - (&a/$def ?name ?body) - (&&lux/compile-def compile-expression ?name ?body) - - (&a/$declare-macro ?module ?name) - (&&lux/compile-declare-macro compile-expression ?module ?name) - - (&a/$jvm-program ?body) - (&&host/compile-jvm-program compile-expression ?body) - - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - - (&a/$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] (|case syntax (&a/$def ?name ?body) @@ -436,8 +419,8 @@ (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) _ (compile-expression syntax))) @@ -483,7 +466,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 83c769b4b..2ca613633 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -76,7 +76,7 @@ (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _ (&/$Nil)) + (&/$DataT _ _) nil (&/$NamedT ?name ?type) @@ -290,16 +290,18 @@ (do-template [<prim-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>] (do (defn <new-name> [compile *type* ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitIntInsn Opcodes/NEWARRAY <prim-type>))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]] (return nil))) (defn <load-name> [compile *type* ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) (.visitInsn <load-op>) <wrapper>)]] (return nil))) @@ -307,9 +309,10 @@ (defn <store-name> [compile *type* ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (doto *writer* <unwrapper> @@ -329,25 +332,27 @@ (defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) (defn compile-jvm-aaload [compile *type* ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) (defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) @@ -355,6 +360,7 @@ (defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (doto *writer* (.visitInsn Opcodes/ARRAYLENGTH) (.visitInsn Opcodes/I2L) @@ -417,33 +423,75 @@ (&&/wrap-boolean))]] (return nil))) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (|do [module &/get-module-name] - (let [super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) +(defn ^:private compile-method [compile class-writer method] + ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) + ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) + ;; (prn 'compile-method/_2 (&/adt->text (:output method))) + ;; (prn 'compile-method/_3 (&/adt->text (:body method))) + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + +(defn ^:private compile-method-decl [class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + +(let [clo-field-sig (&host/->type-signature "java.lang.Object") + <init>-return "V"] + (defn ^:private anon-class-<init>-signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + <init>-return)) + + (defn ^:private add-anon-class-<init> [class-writer class-name env] + (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "<init>" (anon-class-<init>-signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] + (|do [;; :let [_ (prn 'compile-jvm-class/_0)] + module &/get-module-name + ;; :let [_ (prn 'compile-jvm-class/_1)] + :let [full-name (str module "/" ?name) + super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + ;; :let [_ (prn 'compile-jvm-class/_2)] + _ (&/map% (partial compile-method compile =class) ?methods) + ;; :let [_ (prn 'compile-jvm-class/_3)] + :let [_ (when env + (add-anon-class-<init> =class full-name env))] + ;; :let [_ (prn 'compile-jvm-class/_4)] + ] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) @@ -451,11 +499,7 @@ (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) @@ -467,14 +511,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (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) @@ -501,12 +545,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 9137f3874..eafd6a1ac 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -19,21 +19,45 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") +(def array-data-tag "#Array") +(def null-data-tag "#Null") ;; [Utils] +(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") + +(comment + (let [class (class (to-array []))] + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class))) + + (.getName String) "java.lang.String" + + (.getName (class (to-array []))) "[Ljava.lang.Object;" + + (re-find class-name-re "java.lang.String") + ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] + + (re-find class-name-re "[Ljava.lang.Object;") + ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] + ) + (defn ^:private class->type [^Class class] "(-> Class Type)" - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (.equals "void" base) - &type/Unit - (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - &/Nil$) - ))) + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -70,11 +94,31 @@ (str "L" class* ";"))) )) +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$DataT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T (inc count) inner)) + + _ + (&/T 0 type))) + (defn ->java-sig [^objects type] "(-> Type Text)" (|case type (&/$DataT ?name params) - (->type-signature ?name) + (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= null-data-tag ?name) (->type-signature "java.lang.Object") + :else (->type-signature ?name)) (&/$LambdaT _ _) (->type-signature function-class) @@ -123,6 +167,7 @@ ) (defn lookup-constructor [class-loader target args] + ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] (and (= (&/|length args) (&/|length param-types)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 8a1e11bed..baf834ee6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -862,7 +862,7 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] + [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -880,7 +880,9 @@ ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) ;; true) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) (return (&/T fixpoints nil)) :else |