diff options
Diffstat (limited to 'new-luxc/source/luxc')
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 13 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 32 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 172 |
3 files changed, 191 insertions, 26 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 |