diff options
author | Eduardo Julian | 2017-10-19 00:22:47 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-10-19 00:22:47 -0400 |
commit | 6c24a9830cfbf32fbbb6fbfd6f2b7354cb994605 (patch) | |
tree | 3a374d8b90aec63c46fda35917048e702f1fde84 /new-luxc | |
parent | 7c521f1e042a723be225457fa2b5e42f3a681ada (diff) |
- Compilation for method invocation.
Diffstat (limited to '')
4 files changed, 263 insertions, 27 deletions
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index d4029b15b..63931c6f2 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -1128,10 +1128,16 @@ (do meta;Monad<Meta> [#let [argsT (list/map product;left argsTC)] [methodT exceptionsT] (methods class method #Virtual argsT) - [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC))) + #let [[objectA argsA] (case allA + (#;Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] [unboxed castT] (infer-out outputT)] (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method) - (#la;Text unboxed) (decorate-inputs argsT argsA))))) + (#la;Text unboxed) objectA (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) @@ -1186,8 +1192,7 @@ [methodT exceptionsT] (constructor-methods class argsT) [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC)) [unboxed castT] (infer-out outputT)] - (wrap (#la;Procedure proc (list& (#la;Text class) - (#la;Text unboxed) (decorate-inputs argsT argsA))))) + (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA))))) _ (&;fail (format "Wrong syntax for '" proc "'."))))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 1951076c3..f515e86ac 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -9,7 +9,7 @@ [host #+ do-to] [meta] (meta [code] - ["s" syntax #+ syntax:])) + ["s" syntax #+ syntax:])) ["$" ..] (.. ["$t" type])) @@ -29,6 +29,8 @@ <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE T_BYTE T_SHORT T_INT T_LONG) <class> (declare CHECKCAST NEW INSTANCEOF) + <member> (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD + INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE) <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2 POP POP2 SWAP) @@ -37,10 +39,10 @@ GOTO) <var> (declare ILOAD LLOAD DLOAD ALOAD ISTORE LSTORE ASTORE) - <arithmethic> (declare IADD ISUB IMUL IDIV IREM - LADD LSUB LMUL LDIV LREM LCMP - FADD FSUB FMUL FDIV FREM FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DCMPG DCMPL) + <arithmetic> (declare IADD ISUB IMUL IDIV IREM + LADD LSUB LMUL LDIV LREM LCMP + FADD FSUB FMUL FDIV FREM FCMPG FCMPL + DADD DSUB DMUL DDIV DREM DCMPG DCMPL) <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR LAND LOR LXOR LSHL LSHR LUSHR) <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY @@ -69,19 +71,12 @@ <var> - <arithmethic> + <arithmetic> <bit-wise> <array> - (#static GETSTATIC int) - (#static PUTSTATIC int) - (#static GETFIELD int) - (#static PUTFIELD int) - - (#static INVOKESTATIC int) - (#static INVOKESPECIAL int) - (#static INVOKEVIRTUAL int) + <member> (#static ATHROW int) @@ -171,7 +166,7 @@ ## Integer bitwise [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR] - ## Long arithmethic + ## Long arithmetic [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP] @@ -265,9 +260,10 @@ (do-to visitor (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))] - [INVOKESTATIC Opcodes.INVOKESTATIC] - [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] - [INVOKESPECIAL Opcodes.INVOKESPECIAL] + [INVOKESTATIC Opcodes.INVOKESTATIC] + [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] + [INVOKESPECIAL Opcodes.INVOKESPECIAL] + [INVOKEINTERFACE Opcodes.INVOKEINTERFACE] ) (do-template [<name>] diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index f754422c3..a25c67feb 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -1,11 +1,16 @@ (;module: lux - (lux (control [monad #+ do]) - (data [text "text/" Eq<Text>] - text/format + (lux (control [monad #+ do] + ["p" parser "parser/" Monad<Parser>] + ["ex" exception #+ exception:]) + (data [product] + ["e" error] + [text "text/" Eq<Text>] + (text format + ["l" lexer]) (coll [list "list/" Functor<List>] [dict #+ Dict])) - [meta #+ with-gensyms] + [meta #+ with-gensyms "meta/" Monad<Meta>] (meta [code] ["s" syntax #+ syntax:]) [host]) @@ -568,6 +573,157 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) +(exception: #export Invalid-Syntax-For-Argument-Generation) + +(def: base-type + (l;Lexer $;Type) + ($_ p;either + (p;after (l;this "boolean") (parser/wrap $t;boolean)) + (p;after (l;this "byte") (parser/wrap $t;byte)) + (p;after (l;this "short") (parser/wrap $t;short)) + (p;after (l;this "int") (parser/wrap $t;int)) + (p;after (l;this "long") (parser/wrap $t;long)) + (p;after (l;this "float") (parser/wrap $t;float)) + (p;after (l;this "double") (parser/wrap $t;double)) + (p;after (l;this "char") (parser/wrap $t;char)) + (parser/map (function [name] + ($t;class name (list))) + (l;many (l;none-of "["))) + )) + +(def: java-type + (l;Lexer $;Type) + (do p;Monad<Parser> + [raw base-type + nesting (p;some (l;this "[]"))] + (wrap ($t;array (list;size nesting) raw)))) + +(def: (generate-type argD) + (-> Text (Meta $;Type)) + (case (l;run argD java-type) + (#e;Error error) + (&;fail error) + + (#e;Success type) + (meta/wrap type))) + +(def: (prepare-input inputT inputI) + (-> $;Type $;Inst $;Inst) + (case inputT + (#$;Primitive primitive) + (|>. inputI ($i;unwrap primitive)) + + (#$;Generic generic) + (case generic + (^or (#$;Var _) (#$;Wildcard _)) + (|>. inputI ($i;CHECKCAST "java.lang.Object")) + + (#$;Class class-name _) + (|>. inputI ($i;CHECKCAST class-name))) + + _ + (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) + +(def: (generate-args generate argsS) + (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) + (Meta (List [$;Type $;Inst]))) + (case argsS + #;Nil + (meta/wrap #;Nil) + + (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail)) + (do meta;Monad<Meta> + [argT (generate-type argD) + argI (:: @ map (prepare-input argT) (generate argS)) + =tail (generate-args generate tail)] + (wrap (list& [argT argI] =tail))) + + _ + (&;throw Invalid-Syntax-For-Argument-Generation ""))) + +(def: (method-return-type description) + (-> Text (Meta (Maybe $;Type))) + (case description + "void" + (meta/wrap #;None) + + _ + (:: meta;Monad<Meta> map (|>. #;Some) (generate-type description)))) + +(def: (prepare-return returnT returnI) + (-> (Maybe $;Type) $;Inst $;Inst) + (case returnT + #;None + (|>. returnI + ($i;string &runtime;unit)) + + (#;Some type) + (case type + (#$;Primitive primitive) + (|>. returnI ($i;wrap primitive)) + + _ + returnI))) + +(def: (invoke//static proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& (#ls;Text class) (#ls;Text method) + (#ls;Text unboxed) argsS)) + (do meta;Monad<Meta> + [argsTI (generate-args generate argsS) + returnT (method-return-type unboxed) + #let [callI (|>. ($i;fuse (list/map product;right argsTI)) + ($i;INVOKESTATIC class method + ($t;method (list/map product;left argsTI) returnT (list)) + false))]] + (wrap (prepare-return returnT callI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(do-template [<name> <invoke> <interface?>] + [(def: (<name> proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& (#ls;Text class) (#ls;Text method) + (#ls;Text unboxed) objectS argsS)) + (do meta;Monad<Meta> + [objectI (generate objectS) + argsTI (generate-args generate argsS) + returnT (method-return-type unboxed) + #let [callI (|>. objectI + ($i;CHECKCAST class) + ($i;fuse (list/map product;right argsTI)) + (<invoke> class method + ($t;method (list/map product;left argsTI) returnT (list)) + <interface?>))]] + (wrap (prepare-return returnT callI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'."))))] + + [invoke//virtual $i;INVOKEVIRTUAL false] + [invoke//special $i;INVOKESPECIAL false] + [invoke//interface $i;INVOKEINTERFACE true] + ) + +(def: (invoke//constructor proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& (#ls;Text class) argsS)) + (do meta;Monad<Meta> + [argsTI (generate-args generate argsS)] + (wrap (|>. ($i;NEW class) + $i;DUP + ($i;fuse (list/map product;right argsTI)) + ($i;INVOKESPECIAL class "<init>" + ($t;method (list/map product;left argsTI) #;None (list)) + false)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + (def: member-procs @;Bundle (<| (@;prefix "member") @@ -580,6 +736,14 @@ (|> (dict;new text;Hash<Text>) (@;install "get" virtual//get) (@;install "put" virtual//put)))) + (dict;merge (<| (@;prefix "invoke") + (|> (dict;new text;Hash<Text>) + (@;install "static" invoke//static) + (@;install "virtual" invoke//virtual) + (@;install "special" invoke//special) + (@;install "interface" invoke//interface) + (@;install "constructor" invoke//constructor) + ))) ))) (def: #export procedures diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 0cfd47538..ba90a00e3 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -7,7 +7,7 @@ ["e" error] [bit] [bool "bool/" Eq<Bool>] - [number "int/" Number<Int>] + [number "int/" Number<Int> Codec<Text,Int>] [text "text/" Eq<Text>] text/format (coll [list])) @@ -470,3 +470,74 @@ (test "jvm member virtual put" false) )) + +(host;import java.lang.Object) + +(host;import (java.util.ArrayList a)) + +(context: "Member [Method]" + [sample (|> r;int (:: @ map (|>. int/abs (i.% 100)))) + #let [object-longS (|> (#ls;Int sample) + (list (#ls;Text "java.lang.Object")) #ls;Tuple) + intS (|> (#ls;Int sample) + (list) (#ls;Procedure "jvm convert long-to-int") + (list (#ls;Text "int")) #ls;Tuple) + coded-intS (|> (#ls;Text (int/encode sample)) + (list (#ls;Text "java.lang.String")) #ls;Tuple) + array-listS (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.util.ArrayList") intS))]] + ($_ seq + (test "jvm member invoke static" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (#ls;Procedure "jvm member invoke static" + (list (#ls;Text "java.lang.Long") + (#ls;Text "decode") + (#ls;Text "java.lang.Long") + coded-intS)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (i.= sample (:! Int outputG)) + + (#e;Error error) + false))) + (test "jvm member invoke virtual" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> object-longS + (list (#ls;Text "java.lang.Object") + (#ls;Text "equals") + (#ls;Text "boolean") + (#ls;Int sample)) + (#ls;Procedure "jvm member invoke virtual")))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (:! Bool outputG) + + (#e;Error error) + false))) + (test "jvm member invoke interface" + (|> (do meta;Monad<Meta> + [sampleI (@;generate (#ls;Procedure "jvm member invoke interface" + (list (#ls;Text "java.util.Collection") + (#ls;Text "add") + (#ls;Text "boolean") + array-listS + object-longS)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (:! Bool outputG) + + (#e;Error error) + false))) + (test "jvm member invoke constructor" + (|> (do meta;Monad<Meta> + [sampleI (@;generate array-listS)] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (host;instance? ArrayList (:! Object outputG)) + + (#e;Error error) + false))) + )) |