- _jvm_anon-class now requires that constructor arguments (with proper type-tags) are given in order to construct the instances.

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
@@ -49,6 +49,14 @@
     (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)))))
 
 (defn analyse-variant+ [analyser exo-type ident values]
@@ -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-<init>)
-                   (&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 "<init>"
       <init>-return "V"]
   (defn ^:private anon-class-<init>-signature [env]
     (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
          <init>-return))
 
-  (defn ^:private add-anon-class-<init> [^ClassWriter class-writer class-name super-class env]
-    (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "<init>" (anon-class-<init>-signature env) nil nil)
-      (.visitCode)
-      (.visitVarInsn Opcodes/ALOAD 0)
-      (.visitMethodInsn Opcodes/INVOKESPECIAL (&host/->class super-class) "<init>" "()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-<init> [^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-<init>-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 ")" <init>-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-<init> =class full-name ?super-class env))]]
+        _ (|case ??ctor-args
+            (&/$Some ctor-args)
+            (add-anon-class-<init> =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 (= "<init>" name)
-             (doto writer
-               (.visitVarInsn Opcodes/ALOAD 0)
-               (.visitMethodInsn Opcodes/INVOKESPECIAL (->class super-class) "<init>" "()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) "<init>" (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))
                  #{}))
     ))