aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/case.clj7
-rw-r--r--src/lux/analyser/host.clj71
-rw-r--r--src/lux/analyser/lux.clj13
-rw-r--r--src/lux/base.clj49
-rw-r--r--src/lux/compiler/host.clj10
-rw-r--r--src/lux/host.clj53
-rw-r--r--src/lux/type/host.clj33
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 [<name> <tag> <only-interface?>]
(defn <name> [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)]
(= <only-interface?> (.isInterface =class)))
(if <only-interface?>
(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 (= "<init>" 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" <tag>]) (&/$Cons =object =args) (&/|list class method classes output-type)))))))
+ (&&/$proc (&/T ["jvm" <tag>]) (&/$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 [<name> <op>]
(defn <name> [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= "<init>" ?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 [<name> <static?> <method-type>]
(defn <name> [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 <static?> (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 "<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 ""))]
+(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))"
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 10:34:55 +0000