From 0f110f4b904f64a1c79928be2f62dbffcf699ff5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 21 May 2016 13:55:14 -0400 Subject: - Fixed a bug in which it was impossible to pattern-match against existentially-qualified types. - Improved error-reporting. - When loading a class post-compilation, the ClassLoader kept referring to the previous dummy version used during analysis, which meant the real class, with it's code, couldn't be used at compile time. Fixed this (with a hack, sadly...). - Fixed a bug in which using JVM type-vars with top-bounds different from java.lang.Object was not getting acknowledged by the compiler, and resulted in incorrect signatures for methods. --- src/lux/analyser/case.clj | 7 ++++- src/lux/analyser/host.clj | 71 ++++++++++++++++++++++++++++------------------- src/lux/analyser/lux.clj | 13 +++++++-- src/lux/base.clj | 49 ++++++++++++++++++++++++++++---- src/lux/compiler/host.clj | 10 +++---- src/lux/host.clj | 53 ++++++++++++++++++++++------------- src/lux/type/host.clj | 33 ++++++++++++++++++++-- 7 files changed, 169 insertions(+), 67 deletions(-) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0aefca025..5d6bc9965 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -52,6 +52,11 @@ =type (&type/apply-type type $var)] (&type/actual-type =type)) + (&/$ExQ _ _) + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + _ (&type/actual-type type))) @@ -460,7 +465,7 @@ (return (&/fold #(and %1 %2) true totals)))) _ - (fail "[Pattern-maching Error] Tuple is not total."))))))) + (fail (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) ($VariantTotal ?total ?structs) (if ?total diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index eea8297c4..c8fa72b5f 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -8,7 +8,7 @@ [string :as string]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail |case assert!]] + (lux [base :as & :refer [|let |do return* return |case assert!]] [type :as &type] [host :as &host] [lexer :as &lexer] @@ -42,7 +42,8 @@ now))) nil exceptions)] - (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) (&/return* state nil))) ))) @@ -86,7 +87,7 @@ (ensure-object type*)) _ - (fail (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) (defn ^:private as-object [type] "(-> Type Type)" @@ -160,10 +161,10 @@ gvars targs)] (&host-type/instance-param &type/existential gtype-env gtype)) - (fail (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) _ - (fail (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) (defn generic-class->simple-class [gclass] "(-> GenericClass Text)" @@ -222,7 +223,7 @@ (&/$GenericTypeVar var-name) (if-let [ex (&/|get var-name env)] (return ex) - (fail (str "[Analysis Error] Unknown type var: " var-name))) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) (&/$GenericClass name params) (case name @@ -257,7 +258,7 @@ &/$None))) supers) (&/$None) - (fail (str "[Analyser Error] Unrecognized super-class: " class-name)) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) (&/$Some vars+gtypes) (&/map% (fn [var+gtype] @@ -412,7 +413,7 @@ (if (nil? missing-method) (return nil) (|let [[am-name am-inputs] missing-method] - (fail (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) (defn ^:private analyse-field [analyse gtype-env field] "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" @@ -682,9 +683,10 @@ (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) (defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [:let [(&/$Nil) ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader !class! field) =type (&host-type/instance-param &type/existential &/$Nil gtype) :let [output-type =type] _ (&type/check exo-type output-type) @@ -693,11 +695,12 @@ (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) (defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] class-loader &/loader =object (&&/analyse-1+ analyse object) _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader class field) + [gvars gtype] (&host/lookup-field class-loader !class! field) =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) :let [output-type =type] _ (&type/check exo-type output-type) @@ -706,9 +709,10 @@ (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) (defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [:let [(&/$Cons value (&/$Nil)) ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader !class! field) :let [gclass (&host-type/gtype->gclass gtype)] =type (&host-type/instance-param &type/existential &/$Nil gtype) =value (&&/analyse-1 analyse =type value) @@ -719,12 +723,13 @@ (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) (defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [:let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] class-loader &/loader =object (&&/analyse-1+ analyse object) :let [obj-type (&&/expr-type* =object)] _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader class field) + [gvars gtype] (&host/lookup-field class-loader !class! field) :let [gclass (&host-type/gtype->gclass gtype)] =type (analyse-field-access-helper obj-type gvars gtype) =value (&&/analyse-1 analyse =type value) @@ -756,22 +761,26 @@ (let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] (do-template [ ] (defn [analyse exo-type class method classes ?values] - (|do [:let [(&/$Cons object args) ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] class-loader &/loader - _ (try (assert! (let [=class (Class/forName class true class-loader)] + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] (= (.isInterface =class))) (if (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) (catch Exception e - (fail (str "[Analyser Error] Unknown class: " class)))) + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) [gret exceptions parent-gvars gvars gargs] (if (= "" method) (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader class method classes)) + (&host/lookup-virtual-method class-loader !class! method classes)) _ (ensure-catching exceptions) =object (&&/analyse-1+ analyse object) [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) (&/|table) parent-gvars @@ -780,7 +789,7 @@ _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type))))))) + (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) ^:private analyse-jvm-invokevirtual "invokevirtual" false ^:private analyse-jvm-invokespecial "invokespecial" false @@ -788,16 +797,17 @@ )) (defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [:let [args ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) _ (ensure-catching exceptions) :let [gtype-env (&/|table)] [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type))))))) + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) (defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] (|case gtype-vars @@ -819,9 +829,10 @@ )) (defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] - (|do [:let [args ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) _ (ensure-catching exceptions) [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) _ (&type/check exo-type output-type) @@ -909,6 +920,7 @@ =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) _ (check-method-completion all-supers =methods) _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name :let [_ (println 'DEF full-name)] _cursor &/cursor] (return (&/|list (&&/|meta &/$UnitT _cursor @@ -960,6 +972,7 @@ (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name _cursor &/cursor] (return (&/|list (&&/|meta anon-class-type _cursor (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) @@ -1064,7 +1077,7 @@ "c2i" (analyse-jvm-c2i analyse exo-type ?values) "c2l" (analyse-jvm-c2l analyse exo-type ?values) ;; else - (->> (fail (str "[Analyser Error] Unknown host procedure: " [category proc])) + (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] (&reader/with-source "interface" _def-code (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] @@ -1111,4 +1124,4 @@ (analyse-jvm-putfield analyse exo-type _class _field ?values)))) ;; else - (fail (str "[Analyser Error] Unknown host procedure: " [category proc]))))) + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 1844aab3d..8492d5766 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -120,6 +120,15 @@ (&&/$tuple =elems) ))))) + (&/$ExQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) + =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-cursor + tuple-analysis))] + (return (&/|list =tuple-analysis))))) + (&/$UnivQ _) (|do [$var &type/existential :let [(&/$ExT $var-id) $var] @@ -224,10 +233,8 @@ (&/$UnivQ _) (|do [$var &type/existential - :let [(&/$ExT $var-id) $var] exo-type** (&type/apply-type exo-type* $var)] - (&/with-scope-type-var $var-id - (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values))) + (analyse-variant analyse (&/$Right exo-type**) idx is-last? ?values)) (&/$ExQ _) (&type/with-var diff --git a/src/lux/base.clj b/src/lux/base.clj index d9198885e..73f032a9d 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -126,7 +126,9 @@ "classes" "catching" "module-states" - "type-env"]) + "type-env" + "dummy-mappings" + ]) ;; Compiler (defvariant @@ -695,10 +697,6 @@ (defn normalize-name [ident] (reduce str "" (map normalize-char ident))) -(def loader - (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) - (def classes (fn [state] (return* state (->> state (get$ $host) (get$ $classes))))) @@ -733,6 +731,10 @@ (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) +(def loader + (fn [state] + (return* state (->> state (get$ $host) (get$ $loader))))) + (defn host [_] (let [store (atom {})] (T [;; "lux;writer" @@ -746,7 +748,10 @@ ;; "lux;module-states" (|table) ;; lux;type-env - (|table)]))) + (|table) + ;; lux;dummy-mappings + (|table) + ]))) (defn default-compiler-info [mode] (T [;; compiler-name @@ -1281,3 +1286,35 @@ ($Left msg) ($Left msg)))) + +(defn push-dummy-name [real-name store-name] + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + (partial $Cons (T [real-name store-name])) + %) + state) + nil])))) + +(def pop-dummy-name + (fn [state] + ($Right (T [(update$ $host + #(update$ $dummy-mappings + |tail + %) + state) + nil])))) + +(defn de-alias-class [class-name] + (fn [state] + ($Right (T [state + (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (->> state (get$ $host) (get$ $dummy-mappings))) + ($Some store-name) + store-name + + _ + class-name)])))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index da0d6f788..121374b37 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1156,10 +1156,9 @@ (defn ^:private compile-jvm-invokestatic [compile ?values special-args] (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Nil))))) special-args] + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -1173,11 +1172,10 @@ (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?object ?args) ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Nil))))) special-args] + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" =output-type)] + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] _ (compile ?object) :let [_ (when (not= "" ?method) (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] diff --git a/src/lux/host.clj b/src/lux/host.clj index 9dade6731..213a68cea 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -104,7 +104,7 @@ (do-template [ ] (defn [class-loader target method-name args] (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] - (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) + (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods target-class) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) (let [param-types (&/->list (seq (.getParameterTypes =method)))] @@ -142,7 +142,7 @@ gargs (->> ctor .getGenericParameterTypes seq &/->list) exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))] (return (&/T [exs gvars gargs]))) - (fail (str "[Host Error] Constructor does not exist: " target))))) + (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader super-class] "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" @@ -256,10 +256,20 @@ (dummy-value output) (.visitInsn Opcodes/ARETURN)))) +(defn ^:private ->dummy-type [real-name store-name gclass] + (|case gclass + (&/$GenericClass _name _params) + (if (= real-name _name) + (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) + gclass) + + _ + gclass)) + (def init-method-name "") -(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 ""))] +(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] + (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] (doto writer (.visitVarInsn Opcodes/ALOAD 0) (-> (doto (dummy-value arg-type) @@ -267,15 +277,15 @@ (->> (when (not (primitive-jvm-type? arg-type)))))) (->> (doseq [ctor-arg (&/->seq ctor-args) :let [;; arg-term (&/|first ctor-arg) - arg-type (&/|first ctor-arg)]]))) + arg-type (->dummy-type real-name store-name (&/|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] +(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] (|case method-def (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) (|let [=output (&/$GenericClass "void" (&/|list)) - method-decl [init-method-name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method-name @@ -283,12 +293,12 @@ generic-signature (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) .visitCode - (dummy-ctor super-class =ctor-args) + (dummy-ctor real-name store-name super-class =ctor-args) (.visitMaxs 0 0) (.visitEnd))) (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC (if =final? Opcodes/ACC_FINAL 0)) @@ -302,7 +312,7 @@ (.visitEnd))) (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC =name @@ -315,7 +325,7 @@ (.visitEnd))) (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) =name @@ -328,7 +338,7 @@ (.visitEnd))) (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) =name @@ -338,7 +348,7 @@ (.visitEnd))) (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output] + (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) =name @@ -377,11 +387,14 @@ (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) + dummy-name (str ?name "__DUMMY__") + dummy-full-name (str module "/" dummy-name) + real-name (str (&host-generics/->class-name module) "." ?name) + store-name (str (&host-generics/->class-name module) "." dummy-name) class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons super-class interfaces)) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name + dummy-full-name (if (= "" class-signature) nil class-signature) (&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 (into-array String)))) @@ -402,13 +415,13 @@ (.visitEnd)) )) fields) - _ (&/|map (partial compile-dummy-method =class super-class) methods) + _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) bytecode (.toByteArray (doto =class .visitEnd))] ^ClassLoader loader &/loader !classes &/classes - :let [real-name (str (&host-generics/->class-name module) "." ?name) - _ (swap! !classes assoc real-name bytecode) - ;; _ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str "target/jvm/" full-name ".class")))] + :let [_ (swap! !classes assoc store-name bytecode) + ;; _ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str "target/jvm/" dummy-full-name ".class")))] ;; (.write stream bytecode)) - _ (.loadClass loader real-name)]] + _ (.loadClass loader store-name)] + _ (&/push-dummy-name real-name store-name)] (return nil))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index de5b3df84..340d805a2 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -6,7 +6,8 @@ (ns lux.type.host (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.host.generics :as &host-generics]) (:import (java.lang.reflect GenericArrayType ParameterizedType TypeVariable @@ -63,7 +64,7 @@ (&/fold2 matcher (&/|table) sub-type-params params))) ;; [Exports] -(let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+)|(\[+)([ZBSIJFDC]))" +(let [class-name-re #"((\[+)L([\.a-zA-Z0-9\$]+);|([\.a-zA-Z0-9\$]+)|(\[+)([ZBSIJFDC]))" jprim->lprim (fn [prim] (case prim "Z" "boolean" @@ -125,6 +126,34 @@ (instance-param existential matchings bound) existential))) +(defn principal-class [refl-type] + (cond (instance? Class refl-type) + (|case (class->type refl-type) + (&/$HostT "#Array" (&/$Cons (&/$HostT class-name _) (&/$Nil))) + (str "[" (&host-generics/->type-signature class-name)) + + (&/$HostT class-name _) + (&host-generics/->type-signature class-name) + + (&/$UnitT) + "V") + + (instance? GenericArrayType refl-type) + (&host-generics/->type-signature (str refl-type)) + + (instance? ParameterizedType refl-type) + (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) + + (instance? TypeVariable refl-type) + (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (principal-class bound) + (&host-generics/->type-signature "java.lang.Object")))) + ;; TODO: CLEAN THIS UP, IT'S DOING A HACK BY TREATING GCLASSES AS GVARS (defn instance-gtype [existential matchings gtype] "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" -- cgit v1.2.3