From b541374a65ae70d070291e6a16ea266087601362 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 1 Jan 2016 11:35:15 -0400 Subject: - Modified _jvm_anewarray so it now works with generic classes. --- src/lux/analyser.clj | 5 ++-- src/lux/analyser/host.clj | 62 +++++++++++++++++++++++++---------------------- src/lux/base.clj | 28 +++++++++++++++++++-- src/lux/compiler.clj | 4 +-- src/lux/compiler/host.clj | 12 ++++++--- src/lux/host/generics.clj | 19 +++++++++++++++ src/lux/type/host.clj | 36 +++++++++++++++++++-------- 7 files changed, 117 insertions(+), 49 deletions(-) (limited to 'src') 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 [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 )]] (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) -- cgit v1.2.3