aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lux/analyser.clj18
-rw-r--r--src/lux/analyser/host.clj17
-rw-r--r--src/lux/compiler.clj4
-rw-r--r--src/lux/compiler/host.clj81
-rw-r--r--src/lux/host.clj51
-rw-r--r--src/lux/packager/program.clj9
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))
#{}))
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 15:50:00 +0000