aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--src/lux/analyser/host.clj157
-rw-r--r--src/lux/analyser/lux.clj64
-rw-r--r--src/lux/analyser/parser.clj88
-rw-r--r--src/lux/base.clj28
-rw-r--r--src/lux/compiler/host.clj167
-rw-r--r--src/lux/host.clj114
-rw-r--r--src/lux/host/generics.clj23
7 files changed, 451 insertions, 190 deletions
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 44ebc8d1d..482e6c723 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -524,26 +524,89 @@
(return (&type/Data$ &host-type/array-data-tag (&/|list =param))))
))
-(defn ^:private analyse-method [analyse class-decl method]
- (|do [:let [[?cname ?cparams] class-decl
- class-type (&/V &/$GenericClass (&/T ?cname &/Nil$))
- [?decl ?body] method
- [_ _ ?gvars ?exs ?inputs ?output] ?decl
- all-gvars (&/|++ ?cparams ?gvars)]
- gvar-env (&/map% (fn [gvar]
- (|do [ex &type/existential]
- (return (&/T gvar ex))))
- all-gvars)
- output-type (generic-class->type gvar-env ?output)
- =body (&/fold (fn [body* input*]
- (|do [:let [[iname itype*] input*]
- itype (generic-class->type gvar-env itype*)]
- (&&env/with-local iname itype
- body*)))
- (&&/analyse-1 analyse output-type ?body)
- (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type)
- ?inputs)))]
- (return (&/T ?decl =body))))
+(defn gen-super-env [class-env supers class-decl]
+ "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))"
+ (|let [[class-name class-vars] class-decl]
+ (|case (&/|some (fn [super]
+ (|let [[super-name super-params] super]
+ (if (= class-name super-name)
+ (&/Some$ (&/zip2 class-vars super-params))
+ &/None$)))
+ supers)
+ (&/$None)
+ (fail (str "[Analyser Error] Unrecognized super-class: " class-name))
+
+ (&/$Some vars+gtypes)
+ (&/map% (fn [var+gtype]
+ (|do [:let [[var gtype] var+gtype]
+ =gtype (generic-class->type class-env gtype)]
+ (return (&/T var =gtype))))
+ vars+gtypes)
+ )))
+
+(defn ^:private analyse-method [analyse class-decl class-env all-supers method]
+ "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))"
+ (|let [[?cname ?cparams] class-decl
+ class-type (&/V &/$GenericClass (&/T ?cname &/Nil$))]
+ (|case method
+ (&/$ConstructorMethodSyntax ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
+ (|do [:let [all-gvars (&/|++ ?cparams ?gvars)]
+ gvar-env (&/map% (fn [gvar]
+ (|do [ex &type/existential]
+ (return (&/T gvar ex))))
+ all-gvars)
+ :let [output-type &type/Unit]
+ =ctor-args (&/map% (fn [ctor-arg]
+ (|do [:let [[ca-type ca-term] ctor-arg]
+ =ca-type (generic-class->type gvar-env ca-type)
+ =ca-term (&&/analyse-1 analyse =ca-type ca-term)]
+ (return (&/T =ca-type =ca-term))))
+ ?ctor-args)
+ =body (&/fold (fn [body* input*]
+ (|do [:let [[iname itype*] input*]
+ itype (generic-class->type gvar-env itype*)]
+ (&&env/with-local iname itype
+ body*)))
+ (&&/analyse-1 analyse output-type ?body)
+ (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type)
+ ?inputs)))]
+ (return (&/V &/$ConstructorMethodAnalysis (&/T ?anns ?gvars ?exceptions ?inputs =ctor-args =body))))
+
+ (&/$VirtualMethodSyntax ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|do [:let [all-gvars (&/|++ ?cparams ?gvars)]
+ all-env (&/map% (fn [gvar]
+ (|do [ex &type/existential]
+ (return (&/T gvar ex))))
+ all-gvars)
+ output-type (generic-class->type all-env ?output)
+ =body (&/fold (fn [body* input*]
+ (|do [:let [[iname itype*] input*]
+ itype (generic-class->type all-env itype*)]
+ (&&env/with-local iname itype
+ body*)))
+ (&&/analyse-1 analyse output-type ?body)
+ (&/|reverse (&/Cons$ (&/T &&/jvm-this class-type)
+ ?inputs)))]
+ (return (&/V &/$VirtualMethodAnalysis (&/T ?name ?anns ?gvars ?exceptions ?inputs ?output =body))))
+
+ (&/$OverridenMethodSyntax ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|do [super-env (gen-super-env class-env all-supers ?class-decl)
+ gvar-env (&/map% (fn [gvar]
+ (|do [ex &type/existential]
+ (return (&/T gvar ex))))
+ ?gvars)
+ :let [full-env (&/|++ super-env gvar-env)]
+ output-type (generic-class->type full-env ?output)
+ =body (&/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 (&/Cons$ (&/T &&/jvm-this class-type)
+ ?inputs)))]
+ (return (&/V &/$OverridenMethodAnalysis (&/T ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output =body))))
+ )))
(defn ^:private mandatory-methods [supers]
(|do [class-loader &/loader]
@@ -554,19 +617,28 @@
(|do [abstract-methods (mandatory-methods supers)
:let [methods-map (&/fold (fn [mmap mentry]
(prn 'methods-map (count mentry) mentry)
- (|let [[[=name =anns =gvars =exceptions =inputs =output] _] mentry]
- (assoc mmap =name mentry)))
+ (|case mentry
+ (&/$ConstructorMethodAnalysis _)
+ mmap
+
+ (&/$VirtualMethodAnalysis _)
+ mmap
+
+ (&/$OverridenMethodAnalysis =class-decl =name =anns =gvars =exceptions =inputs =output body)
+ (assoc mmap =name =inputs)
+ ))
{}
methods)
missing-method (&/fold (fn [missing abs-meth]
- (|let [[am-name am-inputs] abs-meth]
- (or missing
+ (or missing
+ (|let [[am-name am-inputs] abs-meth]
(if-let [meth-struct (get methods-map am-name)]
- (|let [[[=name =anns =gvars =exceptions =inputs =output] _] meth-struct]
+ (|let [=inputs meth-struct]
(if (and (= (&/|length =inputs) (&/|length am-inputs))
(&/fold2 (fn [prev mi ai]
(|let [[iname itype] mi]
- (and prev (= (generic-class->simple-class itype) ai))))
+ (do (prn '[iname itype] [iname itype])
+ (and prev (= (generic-class->simple-class itype) ai)))))
true
=inputs am-inputs))
nil
@@ -583,11 +655,16 @@
(&/with-closure
(|do [module &/get-module-name
:let [[?name ?params] class-decl
- full-name (str module "." ?name)]
+ full-name (str module "." ?name)
+ all-supers (&/Cons$ super-class interfaces)]
+ class-env (&/map% (fn [gvar]
+ (|do [ex &type/existential]
+ (return (&/T gvar ex))))
+ ?params)
_ (&host/use-dummy-class class-decl super-class interfaces &/None$ =fields methods)
- =methods (&/map% (partial analyse-method analyse class-decl) methods)
+ =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods)
;; :let [_ (prn 'analyse-jvm-class/_2)]
- _ (check-method-completion (&/Cons$ super-class interfaces) =methods)
+ _ (check-method-completion all-supers =methods)
;; :let [_ (prn 'analyse-jvm-class/_3)]
_ (compile-token (&/V &&/$jvm-class (&/T class-decl super-class interfaces =anns =fields =methods nil)))
:let [_ (println 'DEF full-name)]]
@@ -604,12 +681,12 @@
[name [_ (&&/$captured _ _ source)]]
source))
-(let [default-<init> (&/T "<init>"
- (&/|list)
- (&/|list)
- (&/|list)
- (&/|list)
- (&/V &/$GenericClass (&/T "void" (&/|list))))
+(let [default-<init> (&/V &/$ConstructorMethodSyntax (&/T (&/|list)
+ (&/|list)
+ (&/|list)
+ (&/|list)
+ (&/|list)
+ (&/V &/$TupleS (&/|list))))
captured-slot-type "java.lang.Object"]
(defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces ctor-args methods]
(&/with-closure
@@ -627,11 +704,12 @@
(return (&/T arg-type =arg-term)))))
ctor-args)
_ (->> methods
- (&/|map &/|first)
(&/Cons$ default-<init>)
(&host/use-dummy-class class-decl super-class interfaces (&/Some$ =ctor-args) (&/|list)))
- =methods (&/map% (partial analyse-method analyse class-decl) methods)
- _ (check-method-completion (&/Cons$ super-class interfaces) =methods)
+ :let [all-supers (&/Cons$ super-class interfaces)
+ class-env (&/|list)]
+ =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods)
+ _ (check-method-completion all-supers =methods)
=captured &&env/captured-vars
:let [=fields (&/|map (fn [^objects idx+capt]
(&/T (str &c!base/closure-prefix (aget idx+capt 0))
@@ -667,7 +745,8 @@
(defn analyse-jvm-throw [analyse exo-type ?ex]
(|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)
- _cursor &/cursor]
+ _cursor &/cursor
+ _ (&type/check exo-type &type/$Void)]
(return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex))))))
(do-template [<name> <tag>]
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 846b7192b..c52cd5937 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -351,38 +351,40 @@
))
(defn analyse-apply [analyse exo-type form-cursor =fn ?args]
- (|do [loader &/loader]
- (|let [[[=fn-type =fn-cursor] =fn-form] =fn]
- (|case =fn-form
- (&&/$var (&/$Global ?module ?name))
- (|do [[real-name $def] (&&module/find-def ?module ?name)]
- (|case $def
- (&/$MacroD macro)
- (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
- ;; :let [_ (when (or (= "invoke-static$" (aget real-name 1))
- ;; (= "invoke-virtual$" (aget real-name 1))
- ;; (= "new$" (aget real-name 1))
- ;; (= "let%" (aget real-name 1))
- ;; (= "jvm-import" (aget real-name 1)))
- ;; (->> (&/|map &/show-ast macro-expansion)
- ;; (&/|interpose "\n")
- ;; (&/fold str "")
- ;; (prn (&/ident->text real-name))))]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
+ (|do [loader &/loader
+ :let [[[=fn-type =fn-cursor] =fn-form] =fn]]
+ (|case =fn-form
+ (&&/$var (&/$Global ?module ?name))
+ (|do [[real-name $def] (&&module/find-def ?module ?name)]
+ (|case $def
+ (&/$MacroD macro)
+ (|do [macro-expansion (fn [state] (-> macro (.apply ?args) (.apply state)))
+ ;; :let [_ (when (or (= "case" (aget real-name 1))
+ ;; ;; (= "invoke-static$" (aget real-name 1))
+ ;; ;; (= "invoke-virtual$" (aget real-name 1))
+ ;; ;; (= "new$" (aget real-name 1))
+ ;; ;; (= "let%" (aget real-name 1))
+ ;; ;; (= "jvm-import" (aget real-name 1))
+ ;; )
+ ;; (->> (&/|map &/show-ast macro-expansion)
+ ;; (&/|interpose "\n")
+ ;; (&/fold str "")
+ ;; (prn (&/ident->text real-name))))]
+ ]
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
- _
- (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&&/|meta =output-t =fn-cursor
- (&/V &&/$apply (&/T =fn =args))
- ))))))
-
- _
- (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
- (return (&/|list (&&/|meta =output-t =fn-cursor
- (&/V &&/$apply (&/T =fn =args))
- )))))
- )))
+ _
+ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
+ (return (&/|list (&&/|meta =output-t =fn-cursor
+ (&/V &&/$apply (&/T =fn =args))
+ ))))))
+
+ _
+ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)]
+ (return (&/|list (&&/|meta =output-t =fn-cursor
+ (&/V &&/$apply (&/T =fn =args))
+ )))))
+ ))
(defn analyse-case [analyse exo-type ?value ?branches]
(|do [:let [num-branches (&/|length ?branches)]
diff --git a/src/lux/analyser/parser.clj b/src/lux/analyser/parser.clj
index 074b032ee..a0b83a9e9 100644
--- a/src/lux/analyser/parser.clj
+++ b/src/lux/analyser/parser.clj
@@ -26,14 +26,6 @@
_
(fail (str "[Analyser Error] Not text: " (&/show-ast ast)))))
-(defn parse-ctor-arg [ast]
- (|case ast
- [_ (&/$TupleS (&/$Cons ?class (&/$Cons [_ (&/$TextS ?term)] (&/$Nil))))]
- (return (&/T ?class ?term))
-
- _
- (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast)))))
-
(defn parse-gclass-decl [ast]
(|case ast
[_ (&/$FormS (&/$Cons [_ (&/$TextS class-name)] (&/$Cons [_ (&/$TupleS args)] (&/$Nil))))]
@@ -68,6 +60,15 @@
_
(fail (str "[Analyser Error] Not generic super-class: " (&/show-ast ast)))))
+(defn parse-ctor-arg [ast]
+ (|case ast
+ [_ (&/$TupleS (&/$Cons ?class (&/$Cons ?term (&/$Nil))))]
+ (|do [=class (parse-gclass ?class)]
+ (return (&/T =class ?term)))
+
+ _
+ (fail (str "[Analyser Error] Not constructor argument: " (&/show-ast ast)))))
+
(defn parse-handler [[catch+ finally+] token]
(|case token
[meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")]
@@ -123,7 +124,7 @@
_
(fail (str "[Analyser Error] Invalid argument declaration: " (&/show-ast ast)))))
-(defn ^:private parse-method-decl* [asts]
+(defn parse-method-decl [asts]
(|case asts
(&/$Cons [_ (&/$TextS method-name)]
(&/$Cons [_ (&/$TupleS anns)]
@@ -135,7 +136,7 @@
(|do [=anns (&/map% parse-ann anns)
=gvars (&/map% parse-text gvars)
=exceptions (&/map% parse-gclass exceptions)
- =inputs (&/map% parse-arg-decl inputs)
+ =inputs (&/map% parse-gclass inputs)
=output (parse-gclass output)]
(return (&/T (&/T method-name =anns =gvars =exceptions =inputs =output)
*tail*)))
@@ -143,30 +144,53 @@
_
(fail (str "[Analyser Error] Invalid method declaration: " (->> asts (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))
-(defn parse-method-decl [ast]
- (|case ast
- [_ (&/$FormS tokens)]
- (|do [[decl *tail*] (parse-method-decl* tokens)]
- (|case *tail*
- (&/$Nil)
- (return decl)
-
- _
- (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast)))))
-
- _
- (fail (str "[Analyser Error] Invalid method declaration: " (&/show-ast ast)))))
-
(defn parse-method-def [ast]
(|case ast
- [_ (&/$FormS tokens)]
- (|do [[decl *tail*] (parse-method-decl* tokens)]
- (|case *tail*
- (&/$Cons body (&/$Nil))
- (return (&/T decl body))
-
- _
- (fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast)))))
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS "init")]
+ (&/$Cons [_ (&/$TupleS anns)]
+ (&/$Cons [_ (&/$TupleS gvars)]
+ (&/$Cons [_ (&/$TupleS exceptions)]
+ (&/$Cons [_ (&/$TupleS inputs)]
+ (&/$Cons ?ctor-args
+ (&/$Cons body (&/$Nil)))))))))]
+ (|do [=anns (&/map% parse-ann anns)
+ =gvars (&/map% parse-text gvars)
+ =exceptions (&/map% parse-gclass exceptions)
+ =inputs (&/map% parse-arg-decl inputs)
+ =ctor-args (&/map% parse-ctor-arg ?ctor-args)]
+ (return (&/V &/$ConstructorMethodSyntax (&/T =anns =gvars =exceptions =inputs =ctor-args body))))
+
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS "virtual")]
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TupleS anns)]
+ (&/$Cons [_ (&/$TupleS gvars)]
+ (&/$Cons [_ (&/$TupleS exceptions)]
+ (&/$Cons [_ (&/$TupleS inputs)]
+ (&/$Cons output
+ (&/$Cons body (&/$Nil))))))))))]
+ (|do [=anns (&/map% parse-ann anns)
+ =gvars (&/map% parse-text gvars)
+ =exceptions (&/map% parse-gclass exceptions)
+ =inputs (&/map% parse-arg-decl inputs)
+ =output (parse-gclass output)]
+ (return (&/V &/$VirtualMethodSyntax (&/T ?name =anns =gvars =exceptions =inputs =output body))))
+
+ [_ (&/$FormS (&/$Cons [_ (&/$TextS "override")]
+ (&/$Cons ?class-decl
+ (&/$Cons [_ (&/$TextS ?name)]
+ (&/$Cons [_ (&/$TupleS anns)]
+ (&/$Cons [_ (&/$TupleS gvars)]
+ (&/$Cons [_ (&/$TupleS exceptions)]
+ (&/$Cons [_ (&/$TupleS inputs)]
+ (&/$Cons output
+ (&/$Cons body (&/$Nil)))))))))))]
+ (|do [=class-decl (parse-gclass-decl ?class-decl)
+ =anns (&/map% parse-ann anns)
+ =gvars (&/map% parse-text gvars)
+ =exceptions (&/map% parse-gclass exceptions)
+ =inputs (&/map% parse-arg-decl inputs)
+ =output (parse-gclass output)]
+ (return (&/V &/$OverridenMethodSyntax (&/T =class-decl ?name =anns =gvars =exceptions =inputs =output body))))
_
(fail (str "[Analyser Error] Invalid method definition: " (&/show-ast ast)))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index e570a1399..4f34f8c24 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -112,6 +112,17 @@
"GenericClass"
"GenericArray"])
+;; Methods
+(deftags
+ ["ConstructorMethodSyntax"
+ "VirtualMethodSyntax"
+ "OverridenMethodSyntax"])
+
+(deftags
+ ["ConstructorMethodAnalysis"
+ "VirtualMethodAnalysis"
+ "OverridenMethodAnalysis"])
+
;; [Exports]
(def datum-field "_datum")
(def meta-field "_meta")
@@ -323,6 +334,7 @@
))
(defn |empty? [xs]
+ "(All [a] (-> (List a) Bool))"
(|case xs
($Nil)
true
@@ -331,6 +343,7 @@
false))
(defn |filter [p xs]
+ "(All [a] (-> (-> a Bool) (List a) (List a)))"
(|case xs
($Nil)
xs
@@ -341,6 +354,7 @@
(|filter p xs*))))
(defn flat-map [f xs]
+ "(All [a b] (-> (-> a (List b)) (List a) (List b)))"
(|case xs
($Nil)
xs
@@ -996,6 +1010,7 @@
(do-template [<name> <default> <op>]
(defn <name> [p xs]
+ "(All [a] (-> (-> a Bool) (List a) Bool))"
(|case xs
($Nil)
<default>
@@ -1013,6 +1028,7 @@
(f y))))
(defn with-attempt [m-value on-error]
+ "(All [a] (-> (Lux a) (-> Text (Lux a)) (Lux a)))"
(fn [state]
(|case (m-value state)
($Left msg)
@@ -1020,3 +1036,15 @@
output
output)))
+
+(defn |some [f xs]
+ "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
+ (|case xs
+ ($Nil)
+ None$
+
+ ($Cons x xs*)
+ (|case (f x)
+ ($None) (|some f xs*)
+ output output)
+ ))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index bcbed07c9..ffee3b095 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -26,6 +26,8 @@
AnnotationVisitor)))
;; [Utils]
+(def init-method "<init>")
+
(let [class+method+sig {"boolean" [(&host-generics/->bytecode-class-name "java.lang.Boolean") "booleanValue" "()Z"]
"byte" [(&host-generics/->bytecode-class-name "java.lang.Byte") "byteValue" "()B"]
"short" [(&host-generics/->bytecode-class-name "java.lang.Short") "shortValue" "()S"]
@@ -432,54 +434,118 @@
nil)))
(defn ^:private compile-method-return [^MethodVisitor writer output]
- (case output
- "void" (.visitInsn writer Opcodes/RETURN)
- "boolean" (doto writer
- &&/unwrap-boolean
- (.visitInsn Opcodes/IRETURN))
- "byte" (doto writer
- &&/unwrap-byte
- (.visitInsn Opcodes/IRETURN))
- "short" (doto writer
- &&/unwrap-short
- (.visitInsn Opcodes/IRETURN))
- "int" (doto writer
- &&/unwrap-int
- (.visitInsn Opcodes/IRETURN))
- "long" (doto writer
- &&/unwrap-long
- (.visitInsn Opcodes/LRETURN))
- "float" (doto writer
- &&/unwrap-float
- (.visitInsn Opcodes/FRETURN))
- "double" (doto writer
- &&/unwrap-double
- (.visitInsn Opcodes/DRETURN))
- "char" (doto writer
- &&/unwrap-char
- (.visitInsn Opcodes/IRETURN))
- ;; else
+ (|case output
+ (&/$GenericClass "void" (&/$Nil))
+ (.visitInsn writer Opcodes/RETURN)
+
+ (&/$GenericClass "boolean" (&/$Nil))
+ (doto writer
+ &&/unwrap-boolean
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "byte" (&/$Nil))
+ (doto writer
+ &&/unwrap-byte
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "short" (&/$Nil))
+ (doto writer
+ &&/unwrap-short
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "int" (&/$Nil))
+ (doto writer
+ &&/unwrap-int
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "long" (&/$Nil))
+ (doto writer
+ &&/unwrap-long
+ (.visitInsn Opcodes/LRETURN))
+
+ (&/$GenericClass "float" (&/$Nil))
+ (doto writer
+ &&/unwrap-float
+ (.visitInsn Opcodes/FRETURN))
+
+ (&/$GenericClass "double" (&/$Nil))
+ (doto writer
+ &&/unwrap-double
+ (.visitInsn Opcodes/DRETURN))
+
+ (&/$GenericClass "char" (&/$Nil))
+ (doto writer
+ &&/unwrap-char
+ (.visitInsn Opcodes/IRETURN))
+
+ _
(.visitInsn writer Opcodes/ARETURN)))
-(defn ^:private compile-method-def [compile ^ClassWriter class-writer method-def]
- (|let [[=method-decl =body] method-def
- [=name =anns =gvars =exceptions =inputs =output] =method-decl
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- Opcodes/ACC_PUBLIC
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) =anns)
- _ (.visitCode =method)]
- _ (compile =body)
- :let [_ (doto =method
- (compile-method-return =output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))))
+(defn ^:private compile-method-def [compile ^ClassWriter class-writer ?super-class method-def]
+ (|case method-def
+ (&/$ConstructorMethodAnalysis ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
+ (|let [?output (&/V &/$GenericClass (&/T "void" (&/|list)))
+ =method-decl (&/T init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output)
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ Opcodes/ACC_PUBLIC
+ init-method
+ simple-signature
+ generic-signature
+ (->> ?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-sig (str "(" init-types ")" "V")
+ _ (&/|map (partial compile-annotation =method) ?anns)
+ _ (doto =method
+ (.visitCode)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig))]
+ _ (compile ?body)
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$VirtualMethodAnalysis ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|let [=method-decl (&/T ?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output)
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ Opcodes/ACC_PUBLIC
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ _ (compile ?body)
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$OverridenMethodAnalysis ?class-decl ?name ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|let [=method-decl (&/T ?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output)
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ Opcodes/ACC_PUBLIC
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ _ (compile ?body)
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+ ))
(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl]
(|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl
@@ -525,7 +591,6 @@
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type)))))
(let [clo-field-sig (&host-generics/->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)) ")"
@@ -574,7 +639,7 @@
_ (&/|map (partial compile-annotation =class) ?anns)
_ (&/|map (partial compile-field =class)
?fields)]
- _ (&/map% (partial compile-method-def compile =class) ?methods)
+ _ (&/map% (partial compile-method-def compile =class ?super-class) ?methods)
_ (|case ??ctor-args
(&/$Some ctor-args)
(add-anon-class-<init> =class compile full-name ?super-class env ctor-args)
@@ -612,7 +677,7 @@
(&/|list)
(&/|list)
(&/|list)
- (&/|list (&/T "arg" object-class))
+ (&/|list object-class)
object-class))]
(compile-jvm-interface nil interface-decl ?supers ?anns ?methods))))))
@@ -695,7 +760,7 @@
(.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name <from-class>))
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from-class>) <from-method> <from-sig>)
(.visitInsn <op>)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]]
+ (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]]
(return nil)))
compile-jvm-d2f Opcodes/D2F "java.lang.Double" "doubleValue" "()D" "java.lang.Float" "(F)V"
@@ -734,7 +799,7 @@
(.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host-generics/->bytecode-class-name <from2-class>) <from2-method> <from2-sig>))]
:let [_ (doto *writer*
(.visitInsn <op>)
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) "<init>" <to-sig>))]]
+ (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name <to-class>) init-method <to-sig>))]]
(return nil)))
compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V"
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 2f0a1829c..c196496ab 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -185,22 +185,9 @@
(doto writer
(.visitInsn Opcodes/ACONST_NULL))))
-(defn ^:private dummy-return [^MethodVisitor writer super-class ??ctor-args name output]
+(defn ^:private dummy-return [^MethodVisitor writer output]
(case output
- "void" (if (= "<init>" name)
- (|let [(&/$Some ctor-args) ??ctor-args
- ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
- (doto writer
- (.visitVarInsn Opcodes/ALOAD 0)
- (-> (doto (dummy-value arg-type)
- (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name 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 (&host-generics/->bytecode-class-name super-class) "<init>" (str "(" ctor-arg-types ")V"))
- (.visitInsn Opcodes/RETURN)))
- (.visitInsn writer Opcodes/RETURN))
+ "void" (.visitInsn writer Opcodes/RETURN)
"boolean" (doto writer
(.visitLdcInsn false)
(.visitInsn Opcodes/IRETURN))
@@ -230,10 +217,83 @@
(.visitInsn Opcodes/ACONST_NULL)
(.visitInsn Opcodes/ARETURN))))
+(def init-method-name "<init>")
+
+(defn ^:private dummy-ctor [^MethodVisitor writer super-class ctor-args]
+ (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (-> (doto (dummy-value arg-type)
+ (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name 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 (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V"))
+ (.visitInsn Opcodes/RETURN))))
+
+(defn ^:private compile-dummy-method [^ClassWriter =class super-class method-def]
+ (|case method-def
+ (&/$ConstructorMethodSyntax =anns =gvars =exceptions =inputs =ctor-args body)
+ (|let [=output (&/V &/$GenericClass (&/T "void" (&/|list)))
+ method-decl [init-method-name =anns =gvars =exceptions (&/|map &/|second =inputs) =output]
+ [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
+ (do (println 'compile-dummy-method
+ (&/adt->text =exceptions)
+ (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq)
+ simple-signature
+ generic-signature)
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC
+ init-method-name
+ simple-signature
+ generic-signature
+ (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ .visitCode
+ (dummy-ctor super-class =ctor-args)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+ (&/$VirtualMethodSyntax =name =anns =gvars =exceptions =inputs =output body)
+ (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output]
+ [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC
+ =name
+ simple-signature
+ generic-signature
+ (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ .visitCode
+ (dummy-return =output)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+
+ (&/$OverridenMethodSyntax =class-decl =name =anns =gvars =exceptions =inputs =output body)
+ (|let [method-decl [=name =anns =gvars =exceptions (&/|map &/|second =inputs) =output]
+ [simple-signature generic-signature] (&host-generics/method-signatures method-decl)
+ _ (prn 'OverridenMethodSyntax =name
+ simple-signature
+ generic-signature
+ (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq))]
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC
+ =name
+ simple-signature
+ generic-signature
+ (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
+ .visitCode
+ (dummy-return =output)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+
+ _
+ (assert false (println-str 'compile-dummy-method (&/adt->text method-def)))
+ ))
+
(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods]
(|do [module &/get-module-name
:let [[?name ?params] class-decl
full-name (str module "/" ?name)
+ _ (println 'use-dummy-class full-name ;; (&/adt->text methods)
+ (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class))
+ (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq))
class-signature (&host-generics/gclass-decl->signature class-decl interfaces)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
@@ -243,29 +303,19 @@
(->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))))
_ (&/|map (fn [field]
(|let [[=name =anns =type] field]
- (doto (.visitField =class Opcodes/ACC_PUBLIC =name
- (&host-generics/->type-signature =type) nil nil)
- (.visitEnd))))
+ (do (prn 'use-dummy-class/=name =name (&host-generics/->type-signature =type) (&/adt->text =type))
+ (doto (.visitField =class Opcodes/ACC_PUBLIC =name
+ (&host-generics/->type-signature =type) nil nil)
+ (.visitEnd)))))
fields)
- _ (&/|map (fn [method-decl]
- (prn 'use-dummy-class (count method-decl) method-decl)
- (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl
- [simple-signature generic-signature] (&host-generics/method-signatures method-decl)]
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String)))
- .visitCode
- (dummy-return super-class ctor-args =name =output)
- (.visitMaxs 0 0)
- (.visitEnd))))
- methods)
+ _ (&/|map (partial compile-dummy-method =class super-class) methods)
bytecode (.toByteArray (doto =class .visitEnd))]
^ClassLoader loader &/loader
!classes &/classes
:let [real-name (str (&host-generics/->class-name module) "." ?name)
_ (prn 'use-dummy-class/_0 ?name real-name)
_ (swap! !classes assoc real-name bytecode)
+ ;; _ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str "target/jvm/" full-name ".class")))]
+ ;; (.write stream bytecode))
_ (.loadClass loader real-name)]]
(return nil)))
diff --git a/src/lux/host/generics.clj b/src/lux/host/generics.clj
index 79b28b2ef..ccedf70ae 100644
--- a/src/lux/host/generics.clj
+++ b/src/lux/host/generics.clj
@@ -56,8 +56,18 @@
(str "T" name ";")
(&/$GenericClass name params)
- (let [params* (str "<" (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")]
- (str "L" (->bytecode-class-name name) params* ";"))
+ (case name
+ "void" "V"
+ "boolean" "Z"
+ "byte" "B"
+ "short" "S"
+ "int" "I"
+ "long" "L"
+ "float" "F"
+ "double" "D"
+ "char" "C"
+ (let [params* (str "<" (->> params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">")]
+ (str "L" (->bytecode-class-name name) params* ";")))
(&/$GenericArray param)
(str "[" (gclass->signature param))))
@@ -86,7 +96,10 @@
(->type-signature name)
(&/$GenericArray param)
- (str "[" (gclass->simple-signature param)))))
+ (str "[" (gclass->simple-signature param))
+
+ _
+ (assert false (str 'gclass->simple-signature " " (&/adt->text gclass))))))
(let [object-bc-name (->bytecode-class-name "java.lang.Object")]
(defn gclass->bytecode-class-name [gclass]
@@ -103,9 +116,9 @@
(defn method-signatures [method-decl]
(|let [[=name =anns =gvars =exceptions =inputs =output] method-decl
- simple-signature (str "(" (&/fold str "" (&/|map (comp gclass->simple-signature &/|second) =inputs)) ")" (gclass->simple-signature =output))
+ simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output))
generic-signature (str "<" (->> =gvars (&/|interpose " ") (&/fold str "")) ">"
- "(" (&/fold str "" (&/|map (comp gclass->signature &/|second) =inputs)) ")"
+ "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")"
(gclass->signature =output)
(->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))]
(&/T simple-signature generic-signature)))