aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser.clj5
-rw-r--r--src/lux/analyser/host.clj62
-rw-r--r--src/lux/base.clj28
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/host.clj12
-rw-r--r--src/lux/host/generics.clj19
-rw-r--r--src/lux/type/host.clj36
7 files changed, 117 insertions, 49 deletions
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index ff8863003..5a0aa0b3c 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -133,8 +133,9 @@
(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token]
(|case token
;; Arrays
- (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil)))))
- (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length)
+ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons gtype (&/$Cons ?length (&/$Nil)))))
+ (|do [=gtype (&&a-parser/parse-gclass gtype)]
+ (&&host/analyse-jvm-anewarray analyse exo-type =gtype ?length))
(&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))
(&&host/analyse-jvm-aastore analyse exo-type ?array ?idx ?elem)
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 0ccfc9a5c..b729ffd33 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -7,7 +7,7 @@
(:require (clojure [template :refer [do-template]])
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [|let |do return fail |case assert!]]
+ (lux [base :as & :refer [|let |do return* return fail |case assert!]]
[type :as &type]
[host :as &host])
[lux.type.host :as &host-type]
@@ -411,14 +411,15 @@
(let [length-type &type/Int
idx-type &type/Int]
- (defn analyse-jvm-anewarray [analyse exo-type class length]
- (|do [elem-type (&host-type/dummy-gtype class)
- :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))]
+ (defn analyse-jvm-anewarray [analyse exo-type gclass length]
+ (|do [gtype-env &/get-type-env
+ =gclass (&host-type/instance-gtype &type/existential gtype-env gclass)
+ :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list =gclass))]
=length (&&/analyse-1 analyse length-type length)
_ (&type/check exo-type array-type)
_cursor &/cursor]
(return (&/|list (&&/|meta exo-type _cursor
- (&/V &&/$jvm-anewarray (&/T class =length)))))))
+ (&/V &&/$jvm-anewarray (&/T gclass =length gtype-env)))))))
(defn analyse-jvm-aaload [analyse exo-type array idx]
(|do [=array (&&/analyse-1+ analyse array)
@@ -574,14 +575,15 @@
=ca-term (&&/analyse-1 analyse =ca-type ca-term)]
(return (&/T ca-type =ca-term))))
?ctor-args)
- =body (&&env/with-local &&/jvm-this class-type
- (&/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 ?inputs)))]
+ =body (&/with-type-env full-env
+ (&&env/with-local &&/jvm-this class-type
+ (&/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 ?inputs))))]
(return (&/V &/$ConstructorMethodAnalysis (&/T ?anns ?gvars ?exceptions ?inputs =ctor-args =body))))
(&/$VirtualMethodSyntax ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
@@ -591,14 +593,15 @@
?gvars)
:let [full-env (&/|++ class-env method-env)]
output-type (generic-class->type full-env ?output)
- =body (&&env/with-local &&/jvm-this class-type
- (&/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 ?inputs)))]
+ =body (&/with-type-env full-env
+ (&&env/with-local &&/jvm-this class-type
+ (&/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 ?inputs))))]
(return (&/V &/$VirtualMethodAnalysis (&/T ?name ?anns ?gvars ?exceptions ?inputs ?output =body))))
(&/$OverridenMethodSyntax ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
@@ -609,14 +612,15 @@
?gvars)
:let [full-env (&/|++ super-env method-env)]
output-type (generic-class->type full-env ?output)
- =body (&&env/with-local &&/jvm-this class-type
- (&/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 ?inputs)))]
+ =body (&/with-type-env full-env
+ (&&env/with-local &&/jvm-this class-type
+ (&/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 ?inputs))))]
(return (&/V &/$OverridenMethodAnalysis (&/T ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output =body))))
)))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 78625f39c..c0c72c084 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -92,7 +92,8 @@
"loader"
"classes"
"catching"
- "module-states"])
+ "module-states"
+ "type-env"])
;; Compiler
(deftags
@@ -640,7 +641,8 @@
Nil$
;; "lux;module-states"
(|table)
- )))
+ ;; lux;type-env
+ (|table))))
(defn init-state [_]
(T ;; "lux;source"
@@ -1049,3 +1051,25 @@
($None) (|some f xs*)
output output)
))
+
+(def get-type-env
+ "(Lux TypeEnv)"
+ (fn [state]
+ (return* state (->> state (get$ $host) (get$ $type-env)))))
+
+(defn with-type-env [type-env body]
+ "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
+ (fn [state]
+ (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %)
+ state)]
+ (|case (body state*)
+ ($Right [state** output])
+ (V $Right (T (update$ $host
+ #(set$ $type-env
+ (->> state (get$ $host) (get$ $type-env))
+ %)
+ state**)
+ output))
+
+ ($Left msg)
+ (V $Left msg)))))
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 73b5a4206..9b16a2001 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -309,8 +309,8 @@
(&o/$jvm-caload ?array ?idx)
(&&host/compile-jvm-caload compile-expression ?array ?idx)
- (&o/$jvm-anewarray ?class ?length)
- (&&host/compile-jvm-anewarray compile-expression ?class ?length)
+ (&o/$jvm-anewarray ?class ?length gtype-env)
+ (&&host/compile-jvm-anewarray compile-expression ?class ?length gtype-env)
(&o/$jvm-aastore ?array ?idx ?elem)
(&&host/compile-jvm-aastore compile-expression ?array ?idx ?elem)
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index 009c9a9e4..19af75dce 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -283,7 +283,9 @@
(do (defn <new-name> [compile ?length]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?length)
- :let [_ (.visitInsn *writer* Opcodes/L2I)]
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
:let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
(return nil)))
@@ -326,11 +328,13 @@
Opcodes/T_CHAR "[C" compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
)
-(defn compile-jvm-anewarray [compile ?class ?length]
+(defn compile-jvm-anewarray [compile ?gclass ?length type-env]
(|do [^MethodVisitor *writer* &/get-writer
_ (compile ?length)
- :let [_ (.visitInsn *writer* Opcodes/L2I)]
- :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/->bytecode-class-name ?class))]]
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
(return nil)))
(defn compile-jvm-aaload [compile ?array ?idx]
diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj
index 169827789..5709fb615 100644
--- a/src/lux/host/generics.clj
+++ b/src/lux/host/generics.clj
@@ -131,6 +131,25 @@
_
(assert false (str 'gclass->class-name " " (&/adt->text gclass)))))
+;; TODO: CLEAN THIS UP, IT'S DOING A HACK BY TREATING GCLASSES AS GVARS
+(let [object-bc-name (->bytecode-class-name "java.lang.Object")]
+ (defn gclass->bytecode-class-name* [gclass type-env]
+ "(-> GenericClass Text)"
+ (|case gclass
+ (&/$GenericTypeVar name)
+ object-bc-name
+
+ (&/$GenericWildcard)
+ object-bc-name
+
+ (&/$GenericClass name params)
+ (if (&/|get name type-env)
+ object-bc-name
+ (->bytecode-class-name name))
+
+ (&/$GenericArray param)
+ (assert false "gclass->bytecode-class-name doesn't work on arrays."))))
+
(let [object-bc-name (->bytecode-class-name "java.lang.Object")]
(defn gclass->bytecode-class-name [gclass]
"(-> GenericClass Text)"
diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj
index 6e783821c..b03fd9828 100644
--- a/src/lux/type/host.clj
+++ b/src/lux/type/host.clj
@@ -117,6 +117,32 @@
(instance-param existential matchings bound)
existential)))
+;; 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))"
+ (|case gtype
+ (&/$GenericArray component-type)
+ (|do [inner-type (instance-gtype existential matchings component-type)]
+ (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type)))))
+
+ (&/$GenericClass type-name type-params)
+ (if-let [m-type (&/|get type-name matchings)]
+ (return m-type)
+ (|do [params* (&/map% (partial instance-gtype existential matchings)
+ type-params)]
+ (return (&/V &/$DataT (&/T type-name
+ params*)))))
+
+ (&/$GenericTypeVar var-name)
+ (if-let [m-type (&/|get var-name matchings)]
+ (return m-type)
+ (fail (str "[Type Error] Unknown generic type variable: " var-name " -- " (->> matchings
+ (&/|map &/|first)
+ &/->seq))))
+
+ (&/$GenericWildcard)
+ existential))
+
;; [Utils]
(defn ^:private translate-params [existential super-type-params sub-type-params params]
"(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))"
@@ -224,16 +250,6 @@
(prn 'check-host-types e [e!name a!name])
(throw e)))))
-(let [Void$ (&/V &/$VariantT (&/|list))
- gen-type (constantly Void$)]
- (defn dummy-gtype [class]
- (|do [class-loader &/loader]
- (try (|let [=class (Class/forName class true class-loader)
- params (->> =class .getTypeParameters seq &/->list (&/|map gen-type))]
- (return (&/V &/$DataT (&/T class params))))
- (catch Exception e
- (fail (str "[Type Error] Unknown type: " class)))))))
-
(defn gtype->gclass [gtype]
"(-> GenericType GenericClass)"
(cond (instance? Class gtype)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 02:24:48 +0000