From 25b0b39472028260ead6e4863b8a67bc2fa029ec Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 30 Dec 2015 21:46:47 -0400 Subject: - Fixed some bugs in the way _jvm_putfield & _jvm_putstatic special forms were being compiled. - Fixed a bug in the way constructor arguments in constructor methods were being compiled. - Fixed small bugs in the lux.type.host/instance-param and lux.host.generics/gclass->class-name functions. --- src/lux/analyser/host.clj | 8 +++++--- src/lux/compiler.clj | 8 ++++---- src/lux/compiler/host.clj | 23 +++++++++++++++-------- src/lux/host/generics.clj | 2 +- src/lux/type/host.clj | 26 +++++++++++++++++++++++++- 5 files changed, 50 insertions(+), 17 deletions(-) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index bec12c4de..fb4c3e55d 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -231,13 +231,14 @@ (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader [gvars gtype] (&host/lookup-static-field class-loader class field) + :let [gclass (&host-type/gtype->gclass gtype)] =type (&host-type/instance-param &type/existential (&/|list) gtype) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-putstatic (&/T class field =value =type))))))) + (&/V &&/$jvm-putstatic (&/T class field =value gclass =type))))))) (defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader @@ -245,13 +246,14 @@ :let [obj-type (&&/expr-type* =object)] _ (ensure-object obj-type) [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) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-putfield (&/T class field =value =object =type))))))) + (&/V &&/$jvm-putfield (&/T class field =value gclass =object =type))))))) (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) @@ -561,7 +563,7 @@ (|do [:let [[ca-type ca-term] ctor-arg] =ca-type (generic-class->type full-env ca-type) =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T =ca-type =ca-term)))) + (return (&/T ca-type =ca-term)))) ?ctor-args) =body (&&env/with-local &&/jvm-this class-type (&/fold (fn [body* input*] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7fe6871b0..73b5a4206 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -219,11 +219,11 @@ (&o/$jvm-getfield ?class ?field ?object ?output-type) (&&host/compile-jvm-getfield compile-expression ?class ?field ?object ?output-type) - (&o/$jvm-putstatic ?class ?field ?value ?input-type) - (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value ?input-type) + (&o/$jvm-putstatic ?class ?field ?value input-gclass ?input-type) + (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value input-gclass ?input-type) - (&o/$jvm-putfield ?class ?field ?value ?object ?input-type) - (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value ?input-type) + (&o/$jvm-putfield ?class ?field ?value input-gclass ?object ?input-type) + (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value input-gclass ?input-type) (&o/$jvm-invokestatic ?class ?method ?classes ?args ?output-type) (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0401593f7..009c9a9e4 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -389,23 +389,27 @@ (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-putstatic [compile ?class ?field ?value ?input-type] +(defn compile-jvm-putstatic [compile ?class ?field ?value input-gclass ?input-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) =input-sig (&host/->java-sig ?input-type) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig)] - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] (return nil))) -(defn compile-jvm-putfield [compile ?class ?field ?object ?value ?input-type] +(defn compile-jvm-putfield [compile ?class ?field ?object ?value input-gclass ?input-type] (|do [:let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?value) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) =input-sig (&host/->java-sig ?input-type) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field =input-sig)]] + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] (return nil))) (defn compile-jvm-instanceof [compile class object] @@ -496,11 +500,14 @@ (->> ?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-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) init-sig (str "(" init-types ")" "V") _ (&/|map (partial compile-annotation =method) ?anns) _ (doto =method (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) + :let [_ (doto =method (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig))] _ (compile ?body) :let [_ (doto =method diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj index 30d7629c1..1050da53a 100644 --- a/src/lux/host/generics.clj +++ b/src/lux/host/generics.clj @@ -111,7 +111,7 @@ "(-> GenericClass Text)" (|case gclass (&/$GenericTypeVar name) - (gclass->class-name "java.lang.Object") + (->bytecode-class-name "java.lang.Object") (&/$GenericClass name params) (->bytecode-class-name name) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index ff5759923..3c76b431e 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -92,7 +92,7 @@ (return (class->type refl-type)) (instance? GenericArrayType refl-type) - (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type))))) (instance? ParameterizedType refl-type) @@ -254,3 +254,27 @@ "[C" (&/V &/$DataT (&/T array-data-tag (&/|list (&/V &/$DataT (&/T "char" (&/|list)))))) ;; else (&/V &/$DataT (&/T class-name (&/|list))))) + +(defn gtype->gclass [gtype] + "(-> GenericType GenericClass)" + (cond (instance? Class gtype) + (&/V &/$GenericClass (&/T (.getName gtype) &/Nil$)) + + (instance? GenericArrayType gtype) + (&/V &/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) + + (instance? ParameterizedType gtype) + (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) + type-params (->> ^ParameterizedType gtype + .getActualTypeArguments + seq &/->list + (&/|map gtype->gclass))] + (&/V &/$GenericClass (&/T type-name type-params))) + + (instance? TypeVariable gtype) + (&/V &/$GenericTypeVar (.getName ^TypeVariable gtype)) + + (instance? WildcardType gtype) + (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] + (gtype->gclass bound) + (&/V &/$GenericClass (&/T "java.lang.Object" &/Nil$))))) -- cgit v1.2.3