From 80b50367129f9ac940891cd1ae1dd169216ab237 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 29 Nov 2015 00:32:22 -0400 Subject: - _jvm_anon-class now requires that constructor arguments (with proper type-tags) are given in order to construct the instances. --- src/lux/analyser.clj | 18 +++++++--- src/lux/analyser/host.clj | 17 ++++++---- src/lux/compiler.clj | 4 +-- src/lux/compiler/host.clj | 81 ++++++++++++++++++++++++++++++++++---------- src/lux/host.clj | 51 ++++++++++++++++++++++++---- src/lux/packager/program.clj | 9 ++--- 6 files changed, 139 insertions(+), 41 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8959ac61b..416815dbf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -48,6 +48,14 @@ [_ (&/$TextS text)] (return text) + _ + (fail (str "[Analyser Error] Not text: " (&/show-ast ast))))) + +(defn ^:private parse-ctor-arg [ast] + (|case ast + [_ (&/$TupleT (&/$Cons ?class (&/$Cons (&/$TextS ?term) (&/$Nil))))] + (return (&/T ?class ?term)) + _ (fail (str "[Analyser Error] Can't extract text: " (&/show-ast ast))))) @@ -205,10 +213,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] (&/$Cons [_ (&/$TextS ?super-class)] (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?methods)] - (&/$Nil)))))) - (|do [=interfaces (&/map% parse-text ?interfaces)] - (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) + (&/$Cons [_ (&/$TupleS ?ctor-args)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil))))))) + (|do [=interfaces (&/map% parse-text ?interfaces) + =ctor-args (&/map% parse-ctor-arg ?ctor-args)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces =ctor-args ?methods)) ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 291b7c768..5ddf17a1e 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -226,7 +226,7 @@ (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =object (&&/analyse-1 analyse object) + =object (&&/analyse-1+ analyse object) _ (ensure-object (&&/expr-type* =object)) [gvars gtype] (&host/lookup-field class-loader class field) =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) @@ -249,7 +249,7 @@ (defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader - =object (&&/analyse-1 analyse object) + =object (&&/analyse-1+ analyse object) _ (ensure-object (&&/expr-type* =object)) [gvars gtype] (&host/lookup-field class-loader class field) =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) @@ -675,7 +675,7 @@ =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] =method-descs (&/map% dummy-method-desc methods) - _ (&host/use-dummy-class name super-class interfaces =fields =method-descs) + _ (&host/use-dummy-class name super-class interfaces &/None$ =fields =method-descs) =methods (&/map% (partial analyse-method analyse full-name) methods) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) @@ -713,16 +713,21 @@ :inputs (&/|list) :output "void"} captured-slot-type "java.lang.Object"] - (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces ctor-args methods] (&/with-closure (|do [module &/get-module-name scope &/get-scope-name :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T arg-type =arg-term))))) + ctor-args) =method-descs (&/map% dummy-method-desc methods) _ (->> =method-descs (&/Cons$ default-) - (&host/use-dummy-class name super-class interfaces (&/|list))) + (&host/use-dummy-class name super-class interfaces (&/Some$ =ctor-args) (&/|list))) =methods (&/map% (partial analyse-method analyse anon-class) methods) _ (check-method-completion (&/Cons$ super-class interfaces) =methods) =captured &&env/captured-vars @@ -733,7 +738,7 @@ :type captured-slot-type}) (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured (&/Some$ =ctor-args)))) _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index e951b476d..f35bc47e3 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -435,8 +435,8 @@ (&o/$jvm-interface ?name ?supers ?anns ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods) - (&o/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) + (&o/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env ??ctor-args) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env ??ctor-args) _ (compile-expression syntax))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index dab50107f..2be0b37e9 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -482,30 +482,71 @@ (&/|map (partial compile-annotation =method) (:anns method)) nil))) +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Boolean")) + &&/unwrap-boolean) + "byte" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Byte")) + &&/unwrap-byte) + "short" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Short")) + &&/unwrap-short) + "int" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Integer")) + &&/unwrap-int) + "long" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Long")) + &&/unwrap-long) + "float" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Float")) + &&/unwrap-float) + "double" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Double")) + &&/unwrap-double) + "char" (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class "java.lang.Character")) + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host/->class type))))) + (let [clo-field-sig (&host/->type-signature "java.lang.Object") + init-method "" -return "V"] (defn ^:private anon-class--signature [env] (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" -return)) - (defn ^:private add-anon-class- [^ClassWriter class-writer class-name super-class env] - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class super-class) "" "()V") - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&a/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq env)]))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))) + (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] + (let [init-types (->> ctor-args (&/|map (comp &host/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class super-class) init-method (str "(" init-types ")" -return)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&a/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) ) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env ??ctor-args] (|do [module &/get-module-name [file-name _ _] &/cursor :let [full-name (str module "/" ?name) @@ -518,8 +559,12 @@ _ (&/|map (partial compile-field =class) ?fields)] _ (&/map% (partial compile-method compile =class) ?methods) - :let [_ (when env - (add-anon-class- =class full-name ?super-class env))]] + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class- =class compile full-name ?super-class env ctor-args) + + _ + (return nil))] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] diff --git a/src/lux/host.clj b/src/lux/host.clj index 2e251013a..0ce6d5e6a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -193,13 +193,50 @@ ;; else 0))) -(defn ^:private dummy-return [^MethodVisitor writer super-class name output] +(defn primitive-jvm-type? [type] + (case type + ("boolean" "byte" "short" "int" "long" "float" "double" "char") + true + ;; else + false)) + +(defn dummy-value [^MethodVisitor writer class] + (case class + "boolean" (doto writer + (.visitLdcInsn false)) + "byte" (doto writer + (.visitLdcInsn (byte 0))) + "short" (doto writer + (.visitLdcInsn (short 0))) + "int" (doto writer + (.visitLdcInsn (int 0))) + "long" (doto writer + (.visitLdcInsn (long 0))) + "float" (doto writer + (.visitLdcInsn (float 0.0))) + "double" (doto writer + (.visitLdcInsn (double 0.0))) + "char" (doto writer + (.visitLdcInsn (char 0))) + ;; else + (doto writer + (.visitInsn Opcodes/ACONST_NULL)))) + +(defn ^:private dummy-return [^MethodVisitor writer super-class ??ctor-args name output] (case output "void" (if (= "" name) - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL (->class super-class) "" "()V") - (.visitInsn Opcodes/RETURN)) + (|let [(&/$Some ctor-args) ??ctor-args + ctor-arg-types (->> ctor-args (&/|map (comp ->type-signature &/|first)) (&/fold str ""))] + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (-> (doto (dummy-value arg-type) + (-> (.visitTypeInsn Opcodes/CHECKCAST (->class arg-type)) + (->> (when (not (primitive-jvm-type? arg-type)))))) + (->> (doseq [ctor-arg (&/->seq ctor-args) + :let [;; arg-term (&/|first ctor-arg) + arg-type (&/|first ctor-arg)]]))) + (.visitMethodInsn Opcodes/INVOKESPECIAL (->class super-class) "" (str "(" ctor-arg-types ")V")) + (.visitInsn Opcodes/RETURN))) (.visitInsn writer Opcodes/RETURN)) "boolean" (doto writer (.visitLdcInsn false) @@ -230,7 +267,7 @@ (.visitInsn Opcodes/ACONST_NULL) (.visitInsn Opcodes/ARETURN)))) -(defn use-dummy-class [name super-class interfaces fields methods] +(defn use-dummy-class [name super-class interfaces ctor-args fields methods] (|do [module &/get-module-name :let [full-name (str module "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -250,7 +287,7 @@ nil (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String))) .visitCode - (dummy-return super-class (:name method) (:output method)) + (dummy-return super-class ctor-args (:name method) (:output method)) (.visitMaxs 0 0) (.visitEnd)))) methods) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index e1d9a1d2f..0079f72d3 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -24,6 +24,7 @@ ;; [Utils] (def ^:private kilobyte 1024) +(def ^:private buffer-size (* 10 kilobyte)) (defn ^:private manifest [^String module] "(-> Text Manifest)" @@ -34,7 +35,7 @@ (defn ^:private write-class! [^String path ^File file ^JarOutputStream out] "(-> Text File JarOutputStream Unit)" (with-open [in (new BufferedInputStream (new FileInputStream file))] - (let [buffer (byte-array (* 10 kilobyte))] + (let [buffer (byte-array buffer-size)] (doto out (.putNextEntry (new JarEntry (str path "/" (.getName file)))) (-> (.write buffer 0 bytes-read) @@ -105,9 +106,9 @@ (doseq [$group (.listFiles (new File &&/output-dir))] (write-module! $group out)) (->> (fetch-available-jars) - (filter #(and (not (.endsWith % "luxc.jar")) - (not (.endsWith % "tools.nrepl-0.2.3.jar")) - (not (.endsWith % "clojure-complete-0.2.3.jar")))) + (filter #(and (not (.endsWith ^String % "luxc.jar")) + (not (.endsWith ^String % "tools.nrepl-0.2.3.jar")) + (not (.endsWith ^String % "clojure-complete-0.2.3.jar")))) (reduce (fn [s ^String j] (add-jar! (new File ^String j) s out)) #{})) )) -- cgit v1.2.3