diff options
| -rw-r--r-- | src/lux/analyser/host.clj | 157 | ||||
| -rw-r--r-- | src/lux/analyser/lux.clj | 64 | ||||
| -rw-r--r-- | src/lux/analyser/parser.clj | 88 | ||||
| -rw-r--r-- | src/lux/base.clj | 28 | ||||
| -rw-r--r-- | src/lux/compiler/host.clj | 167 | ||||
| -rw-r--r-- | src/lux/host.clj | 114 | ||||
| -rw-r--r-- | src/lux/host/generics.clj | 23 |
7 files changed, 451 insertions, 190 deletions
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 44ebc8d1d..482e6c723 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -524,26 +524,89 @@ (return (&type/Data$ &host-type/array-data-tag (&/|list =param)))) )) -(defn ^:private analyse-method [analyse class-decl method] - (|do [:let [[?cname ?cparams] class-decl - class-type (&/V &/$GenericClass (&/T ?cname &/Nil$)) - [?decl ?body] method - [_ _ ?gvars ?exs ?inputs ?output] ?decl - all-gvars (&/|++ ?cparams ?gvars)] - gvar-env (&/map% (fn [gvar] - (|do [ex &type/existential] - (return (&/T gvar ex)))) - all-gvars) - output-type (generic-class->type gvar-env ?output) - =body (&/fold (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type gvar-env itype*)] - (&&env/with-local iname itype - body*))) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type) - ?inputs)))] - (return (&/T ?decl =body)))) +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/Some$ (&/zip2 class-vars super-params)) + &/None$))) + supers) + (&/$None) + (fail (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T var =gtype)))) + vars+gtypes) + ))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/V &/$GenericClass (&/T ?cname &/Nil$))] + (|case method + (&/$ConstructorMethodSyntax ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [:let [all-gvars (&/|++ ?cparams ?gvars)] + gvar-env (&/map% (fn [gvar] + (|do [ex &type/existential] + (return (&/T gvar ex)))) + all-gvars) + :let [output-type &type/Unit] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type gvar-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T =ca-type =ca-term)))) + ?ctor-args) + =body (&/fold (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type gvar-env itype*)] + (&&env/with-local iname itype + body*))) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type) + ?inputs)))] + (return (&/V &/$ConstructorMethodAnalysis (&/T ?anns ?gvars ?exceptions ?inputs =ctor-args =body)))) + + (&/$VirtualMethodSyntax ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [:let [all-gvars (&/|++ ?cparams ?gvars)] + all-env (&/map% (fn [gvar] + (|do [ex &type/existential] + (return (&/T gvar ex)))) + all-gvars) + output-type (generic-class->type all-env ?output) + =body (&/fold (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type all-env itype*)] + (&&env/with-local iname itype + body*))) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type) + ?inputs)))] + (return (&/V &/$VirtualMethodAnalysis (&/T ?name ?anns ?gvars ?exceptions ?inputs ?output =body)))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + gvar-env (&/map% (fn [gvar] + (|do [ex &type/existential] + (return (&/T gvar ex)))) + ?gvars) + :let [full-env (&/|++ super-env gvar-env)] + output-type (generic-class->type full-env ?output) + =body (&/fold (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (&&env/with-local iname itype + body*))) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type) + ?inputs)))] + (return (&/V &/$OverridenMethodAnalysis (&/T ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output =body)))) + ))) (defn ^:private mandatory-methods [supers] (|do [class-loader &/loader] @@ -554,19 +617,28 @@ (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] (prn 'methods-map (count mentry) mentry) - (|let [[[=name =anns =gvars =exceptions =inputs =output] _] mentry] - (assoc mmap =name mentry))) + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name =anns =gvars =exceptions =inputs =output body) + (assoc mmap =name =inputs) + )) {} methods) missing-method (&/fold (fn [missing abs-meth] - (|let [[am-name am-inputs] abs-meth] - (or missing + (or missing + (|let [[am-name am-inputs] abs-meth] (if-let [meth-struct (get methods-map am-name)] - (|let [[[=name =anns =gvars =exceptions =inputs =output] _] meth-struct] + (|let [=inputs meth-struct] (if (and (= (&/|length =inputs) (&/|length am-inputs)) (&/fold2 (fn [prev mi ai] (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) + (do (prn '[iname itype] [iname itype]) + (and prev (= (generic-class->simple-class itype) ai))))) true =inputs am-inputs)) nil @@ -583,11 +655,16 @@ (&/with-closure (|do [module &/get-module-name :let [[?name ?params] class-decl - full-name (str module "." ?name)] + full-name (str module "." ?name) + all-supers (&/Cons$ super-class interfaces)] + class-env (&/map% (fn [gvar] + (|do [ex &type/existential] + (return (&/T gvar ex)))) + ?params) _ (&host/use-dummy-class class-decl super-class interfaces &/None$ =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl) methods) + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) ;; :let [_ (prn 'analyse-jvm-class/_2)] - _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + _ (check-method-completion all-supers =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] _ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces =anns =fields =methods nil))) :let [_ (println 'DEF full-name)]] @@ -604,12 +681,12 @@ [name [_ (&&/$captured _ _ source)]] source)) -(let [default-<init> (&/T "<init>" - (&/|list) - (&/|list) - (&/|list) - (&/|list) - (&/V &/$GenericClass (&/T "void" (&/|list)))) +(let [default-<init> (&/V &/$ConstructorMethodSyntax (&/T (&/|list) + (&/|list) + (&/|list) + (&/|list) + (&/|list) + (&/V &/$TupleS (&/|list)))) captured-slot-type "java.lang.Object"] (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces ctor-args methods] (&/with-closure @@ -627,11 +704,12 @@ (return (&/T arg-type =arg-term))))) ctor-args) _ (->> methods - (&/|map &/|first) (&/Cons$ default-<init>) (&host/use-dummy-class class-decl super-class interfaces (&/Some$ =ctor-args) (&/|list))) - =methods (&/map% (partial analyse-method analyse class-decl) methods) - _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + :let [all-supers (&/Cons$ super-class interfaces) + class-env (&/|list)] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] (&/T (str &c!base/closure-prefix (aget idx+capt 0)) @@ -667,7 +745,8 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex) - _cursor &/cursor] + _cursor &/cursor + _ (&type/check exo-type &type/$Void)] (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex)))))) (do-template [<name> <tag>] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 846b7192b..c52cd5937 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -351,38 +351,40 @@ )) (defn analyse-apply [analyse exo-type form-cursor =fn ?args] - (|do [loader &/loader] - (|let [[[=fn-type =fn-cursor] =fn-form] =fn] - (|case =fn-form - (&&/$var (&/$Global ?module ?name)) - (|do [[real-name $def] (&&module/find-def ?module ?name)] - (|case $def - (&/$MacroD macro) - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (when (or (= "invoke-static$" (aget real-name 1)) - ;; (= "invoke-virtual$" (aget real-name 1)) - ;; (= "new$" (aget real-name 1)) - ;; (= "let%" (aget real-name 1)) - ;; (= "jvm-import" (aget real-name 1))) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name))))] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (|do [loader &/loader + :let [[[=fn-type =fn-cursor] =fn-form] =fn]] + (|case =fn-form + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name $def] (&&module/find-def ?module ?name)] + (|case $def + (&/$MacroD macro) + (|do [macro-expansion (fn [state] (-> macro (.apply ?args) (.apply state))) + ;; :let [_ (when (or (= "case" (aget real-name 1)) + ;; ;; (= "invoke-static$" (aget real-name 1)) + ;; ;; (= "invoke-virtual$" (aget real-name 1)) + ;; ;; (= "new$" (aget real-name 1)) + ;; ;; (= "let%" (aget real-name 1)) + ;; ;; (= "jvm-import" (aget real-name 1)) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name))))] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) - _ - (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-cursor - (&/V &&/$apply (&/T =fn =args)) - )))))) - - _ - (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-cursor - (&/V &&/$apply (&/T =fn =args)) - ))))) - ))) + _ + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + )))))) + + _ + (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + ))))) + )) (defn analyse-case [analyse exo-type ?value ?branches] (|do [:let [num-branches (&/|length ?branches)] diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj index 074b032ee..a0b83a9e9 100644 --- a/src/lux/analyser/parser.clj +++ b/src/lux/analyser/parser.clj @@ -26,14 +26,6 @@ _ (fail (str "[Analyser Error] Not text: " (&/show-ast ast))))) -(defn parse-ctor-arg [ast] - (|case ast - [_ (&/$TupleS (&/$Cons ?class (&/$Cons [_ (&/$TextS ?term)] (&/$Nil))))] - (return (&/T ?class ?term)) - - _ - (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast))))) - (defn parse-gclass-decl [ast] (|case ast [_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS args)] (&/$Nil))))] @@ -68,6 +60,15 @@ _ (fail (str "[Analyser Error] Not generic super-class: " (&/show-ast ast))))) +(defn parse-ctor-arg [ast] + (|case ast + [_ (&/$TupleS (&/$Cons ?class (&/$Cons ?term (&/$Nil))))] + (|do [=class (parse-gclass ?class)] + (return (&/T =class ?term))) + + _ + (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast))))) + (defn parse-handler [[catch+ finally+] token] (|case token [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] @@ -123,7 +124,7 @@ _ (fail (str "[Analyser Error] Invalid argument declaration: " (&/show-ast ast))))) -(defn ^:private parse-method-decl* [asts] +(defn parse-method-decl [asts] (|case asts (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS anns)] @@ -135,7 +136,7 @@ (|do [=anns (&/map% parse-ann anns) =gvars (&/map% parse-text gvars) =exceptions (&/map% parse-gclass exceptions) - =inputs (&/map% parse-arg-decl inputs) + =inputs (&/map% parse-gclass inputs) =output (parse-gclass output)] (return (&/T (&/T method-name =anns =gvars =exceptions =inputs =output) *tail*))) @@ -143,30 +144,53 @@ _ (fail (str "[Analyser Error] Invalid method declaration: " (->> asts (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))) -(defn parse-method-decl [ast] - (|case ast - [_ (&/$FormS tokens)] - (|do [[decl *tail*] (parse-method-decl* tokens)] - (|case *tail* - (&/$Nil) - (return decl) - - _ - (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) - - _ - (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast))))) - (defn parse-method-def [ast] (|case ast - [_ (&/$FormS tokens)] - (|do [[decl *tail*] (parse-method-decl* tokens)] - (|case *tail* - (&/$Cons body (&/$Nil)) - (return (&/T decl body)) - - _ - (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS "init")] + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons ?ctor-args + (&/$Cons body (&/$Nil)))))))))] + (|do [=anns (&/map% parse-ann anns) + =gvars (&/map% parse-text gvars) + =exceptions (&/map% parse-gclass exceptions) + =inputs (&/map% parse-arg-decl inputs) + =ctor-args (&/map% parse-ctor-arg ?ctor-args)] + (return (&/V &/$ConstructorMethodSyntax (&/T =anns =gvars =exceptions =inputs =ctor-args body)))) + + [_ (&/$FormS (&/$Cons [_ (&/$TextS "virtual")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons output + (&/$Cons body (&/$Nil))))))))))] + (|do [=anns (&/map% parse-ann anns) + =gvars (&/map% parse-text gvars) + =exceptions (&/map% parse-gclass exceptions) + =inputs (&/map% parse-arg-decl inputs) + =output (parse-gclass output)] + (return (&/V &/$VirtualMethodSyntax (&/T ?name =anns =gvars =exceptions =inputs =output body)))) + + [_ (&/$FormS (&/$Cons [_ (&/$TextS "override")] + (&/$Cons ?class-decl + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS anns)] + (&/$Cons [_ (&/$TupleS gvars)] + (&/$Cons [_ (&/$TupleS exceptions)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons output + (&/$Cons body (&/$Nil)))))))))))] + (|do [=class-decl (parse-gclass-decl ?class-decl) + =anns (&/map% parse-ann anns) + =gvars (&/map% parse-text gvars) + =exceptions (&/map% parse-gclass exceptions) + =inputs (&/map% parse-arg-decl inputs) + =output (parse-gclass output)] + (return (&/V &/$OverridenMethodSyntax (&/T =class-decl ?name =anns =gvars =exceptions =inputs =output body)))) _ (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index e570a1399..4f34f8c24 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -112,6 +112,17 @@ "GenericClass" "GenericArray"]) +;; Methods +(deftags + ["ConstructorMethodSyntax" + "VirtualMethodSyntax" + "OverridenMethodSyntax"]) + +(deftags + ["ConstructorMethodAnalysis" + "VirtualMethodAnalysis" + "OverridenMethodAnalysis"]) + ;; [Exports] (def datum-field "_datum") (def meta-field "_meta") @@ -323,6 +334,7 @@ )) (defn |empty? [xs] + "(All [a] (-> (List a) Bool))" (|case xs ($Nil) true @@ -331,6 +343,7 @@ false)) (defn |filter [p xs] + "(All [a] (-> (-> a Bool) (List a) (List a)))" (|case xs ($Nil) xs @@ -341,6 +354,7 @@ (|filter p xs*)))) (defn flat-map [f xs] + "(All [a b] (-> (-> a (List b)) (List a) (List b)))" (|case xs ($Nil) xs @@ -996,6 +1010,7 @@ (do-template [<name> <default> <op>] (defn <name> [p xs] + "(All [a] (-> (-> a Bool) (List a) Bool))" (|case xs ($Nil) <default> @@ -1013,6 +1028,7 @@ (f y)))) (defn with-attempt [m-value on-error] + "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))" (fn [state] (|case (m-value state) ($Left msg) @@ -1020,3 +1036,15 @@ output output))) + +(defn |some [f xs] + "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" + (|case xs + ($Nil) + None$ + + ($Cons x xs*) + (|case (f x) + ($None) (|some f xs*) + output output) + )) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bcbed07c9..ffee3b095 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -26,6 +26,8 @@ AnnotationVisitor))) ;; [Utils] +(def init-method "<init>") + (let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"] "byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"] "short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"] @@ -432,54 +434,118 @@ nil))) (defn ^:private compile-method-return [^MethodVisitor writer output] - (case output - "void" (.visitInsn writer Opcodes/RETURN) - "boolean" (doto writer - &&/unwrap-boolean - (.visitInsn Opcodes/IRETURN)) - "byte" (doto writer - &&/unwrap-byte - (.visitInsn Opcodes/IRETURN)) - "short" (doto writer - &&/unwrap-short - (.visitInsn Opcodes/IRETURN)) - "int" (doto writer - &&/unwrap-int - (.visitInsn Opcodes/IRETURN)) - "long" (doto writer - &&/unwrap-long - (.visitInsn Opcodes/LRETURN)) - "float" (doto writer - &&/unwrap-float - (.visitInsn Opcodes/FRETURN)) - "double" (doto writer - &&/unwrap-double - (.visitInsn Opcodes/DRETURN)) - "char" (doto writer - &&/unwrap-char - (.visitInsn Opcodes/IRETURN)) - ;; else + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + _ (.visitInsn writer Opcodes/ARETURN))) -(defn ^:private compile-method-def [compile ^ClassWriter class-writer method-def] - (|let [[=method-decl =body] method-def - [=name =anns =gvars =exceptions =inputs =output] =method-decl - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - Opcodes/ACC_PUBLIC - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) =anns) - _ (.visitCode =method)] - _ (compile =body) - :let [_ (doto =method - (compile-method-return =output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) +(defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/V &/$GenericClass (&/T "void" (&/|list))) + =method-decl (&/T init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + Opcodes/ACC_PUBLIC + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (doto =method + (.visitCode) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig))] + _ (compile ?body) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T ?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + Opcodes/ACC_PUBLIC + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + _ (compile ?body) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T ?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + Opcodes/ACC_PUBLIC + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + _ (compile ?body) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + )) (defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl @@ -525,7 +591,6 @@ (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) (let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") - init-method "<init>" <init>-return "V"] (defn ^:private anon-class-<init>-signature [env] (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" @@ -574,7 +639,7 @@ _ (&/|map (partial compile-annotation =class) ?anns) _ (&/|map (partial compile-field =class) ?fields)] - _ (&/map% (partial compile-method-def compile =class) ?methods) + _ (&/map% (partial compile-method-def compile =class ?super-class) ?methods) _ (|case ??ctor-args (&/$Some ctor-args) (add-anon-class-<init> =class compile full-name ?super-class env ctor-args) @@ -612,7 +677,7 @@ (&/|list) (&/|list) (&/|list) - (&/|list (&/T "arg" object-class)) + (&/|list object-class) object-class))] (compile-jvm-interface nil interface-decl ?supers ?anns ?methods)))))) @@ -695,7 +760,7 @@ (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from-class>)) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from-class>) <from-method> <from-sig>) (.visitInsn <op>) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]] + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]] (return nil))) compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V" @@ -734,7 +799,7 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from2-class>) <from2-method> <from2-sig>))] :let [_ (doto *writer* (.visitInsn <op>) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]] + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]] (return nil))) compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" diff --git a/src/lux/host.clj b/src/lux/host.clj index 2f0a1829c..c196496ab 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -185,22 +185,9 @@ (doto writer (.visitInsn Opcodes/ACONST_NULL)))) -(defn ^:private dummy-return [^MethodVisitor writer super-class ??ctor-args name output] +(defn ^:private dummy-return [^MethodVisitor writer output] (case output - "void" (if (= "<init>" name) - (|let [(&/$Some ctor-args) ??ctor-args - ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (-> (doto (dummy-value arg-type) - (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) - (->> (when (not (primitive-jvm-type? arg-type)))))) - (->> (doseq [ctor-arg (&/->seq ctor-args) - :let [;; arg-term (&/|first ctor-arg) - arg-type (&/|first ctor-arg)]]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class) "<init>" (str "(" ctor-arg-types ")V")) - (.visitInsn Opcodes/RETURN))) - (.visitInsn writer Opcodes/RETURN)) + "void" (.visitInsn writer Opcodes/RETURN) "boolean" (doto writer (.visitLdcInsn false) (.visitInsn Opcodes/IRETURN)) @@ -230,10 +217,83 @@ (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN)))) +(def init-method-name "<init>") + +(defn ^:private dummy-ctor [^MethodVisitor writer super-class ctor-args] + (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (dummy-value arg-type) + (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) + (->> (when (not (primitive-jvm-type? arg-type)))))) + (->> (doseq [ctor-arg (&/->seq ctor-args) + :let [;; arg-term (&/|first ctor-arg) + arg-type (&/|first ctor-arg)]]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) + (.visitInsn Opcodes/RETURN)))) + +(defn ^:private compile-dummy-method [^ClassWriter =class super-class method-def] + (|case method-def + (&/$ConstructorMethodSyntax =anns =gvars =exceptions =inputs =ctor-args body) + (|let [=output (&/V &/$GenericClass (&/T "void" (&/|list))) + method-decl [init-method-name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (do (println 'compile-dummy-method + (&/adt->text =exceptions) + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq) + simple-signature + generic-signature) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + init-method-name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-ctor super-class =ctor-args) + (.visitMaxs 0 0) + (.visitEnd)))) + + (&/$VirtualMethodSyntax =name =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + (&/$OverridenMethodSyntax =class-decl =name =anns =gvars =exceptions =inputs =output body) + (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + [simple-signature generic-signature] (&host-generics/method-signatures method-decl) + _ (prn 'OverridenMethodSyntax =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq))] + (doto (.visitMethod =class Opcodes/ACC_PUBLIC + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return =output) + (.visitMaxs 0 0) + (.visitEnd))) + + _ + (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) + )) + (defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] (|do [module &/get-module-name :let [[?name ?params] class-decl full-name (str module "/" ?name) + _ (println 'use-dummy-class full-name ;; (&/adt->text methods) + (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) + (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq)) class-signature (&host-generics/gclass-decl->signature class-decl interfaces) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) @@ -243,29 +303,19 @@ (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) _ (&/|map (fn [field] (|let [[=name =anns =type] field] - (doto (.visitField =class Opcodes/ACC_PUBLIC =name - (&host-generics/->type-signature =type) nil nil) - (.visitEnd)))) + (do (prn 'use-dummy-class/=name =name (&host-generics/->type-signature =type) (&/adt->text =type)) + (doto (.visitField =class Opcodes/ACC_PUBLIC =name + (&host-generics/->type-signature =type) nil nil) + (.visitEnd))))) fields) - _ (&/|map (fn [method-decl] - (prn 'use-dummy-class (count method-decl) method-decl) - (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return super-class ctor-args =name =output) - (.visitMaxs 0 0) - (.visitEnd)))) - methods) + _ (&/|map (partial compile-dummy-method =class super-class) methods) bytecode (.toByteArray (doto =class .visitEnd))] ^ClassLoader loader &/loader !classes &/classes :let [real-name (str (&host-generics/->class-name module) "." ?name) _ (prn 'use-dummy-class/_0 ?name real-name) _ (swap! !classes assoc real-name bytecode) + ;; _ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str "target/jvm/" full-name ".class")))] + ;; (.write stream bytecode)) _ (.loadClass loader real-name)]] (return nil))) diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj index 79b28b2ef..ccedf70ae 100644 --- a/src/lux/host/generics.clj +++ b/src/lux/host/generics.clj @@ -56,8 +56,18 @@ (str "T" name ";") (&/$GenericClass name params) - (let [params* (str "<" (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")] - (str "L" (->bytecode-class-name name) params* ";")) + (case name + "void" "V" + "boolean" "Z" + "byte" "B" + "short" "S" + "int" "I" + "long" "L" + "float" "F" + "double" "D" + "char" "C" + (let [params* (str "<" (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")] + (str "L" (->bytecode-class-name name) params* ";"))) (&/$GenericArray param) (str "[" (gclass->signature param)))) @@ -86,7 +96,10 @@ (->type-signature name) (&/$GenericArray param) - (str "[" (gclass->simple-signature param))))) + (str "[" (gclass->simple-signature param)) + + _ + (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) (let [object-bc-name (->bytecode-class-name "java.lang.Object")] (defn gclass->bytecode-class-name [gclass] @@ -103,9 +116,9 @@ (defn method-signatures [method-decl] (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl - simple-signature (str "(" (&/fold str "" (&/|map (comp gclass->simple-signature &/|second) =inputs)) ")" (gclass->simple-signature =output)) + simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) generic-signature (str "<" (->> =gvars (&/|interpose " ") (&/fold str "")) ">" - "(" (&/fold str "" (&/|map (comp gclass->signature &/|second) =inputs)) ")" + "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" (gclass->signature =output) (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] (&/T simple-signature generic-signature))) |