diff options
author | Eduardo Julian | 2017-11-01 00:51:45 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-11-01 00:51:45 -0400 |
commit | 012f6bd41e527479dddbccbdab10daa78fd9a0fd (patch) | |
tree | 621f344a09acd52736f343d94582b3f1a2f0c5f9 /new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux | |
parent | 71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff) |
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux | 761 |
1 files changed, 761 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux new file mode 100644 index 000000000..c222e42cf --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -0,0 +1,761 @@ +(;module: + lux + (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/" Monad<Meta>] + (meta [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + (analysis (procedure ["&;" host])) + ["ls" synthesis])) + ["@" ../common]) + +(do-template [<name> <inst>] + [(def: <name> + $;Inst + <inst>)] + + [L2S (|>. $i;L2I $i;I2S)] + [L2B (|>. $i;L2I $i;I2B)] + [L2C (|>. $i;L2I $i;I2C)] + ) + +(do-template [<name> <unwrap> <conversion> <wrap>] + [(def: (<name> inputI) + @;Unary + (if (is $i;NOP <conversion>) + (|>. inputI + ($i;unwrap <unwrap>) + ($i;wrap <wrap>)) + (|>. inputI + ($i;unwrap <unwrap>) + <conversion> + ($i;wrap <wrap>))))] + + [convert//double-to-float #$;Double $i;D2F #$;Float] + [convert//double-to-int #$;Double $i;D2I #$;Int] + [convert//double-to-long #$;Double $i;D2L #$;Long] + [convert//float-to-double #$;Float $i;F2D #$;Double] + [convert//float-to-int #$;Float $i;F2I #$;Int] + [convert//float-to-long #$;Float $i;F2L #$;Long] + [convert//int-to-byte #$;Int $i;I2B #$;Byte] + [convert//int-to-char #$;Int $i;I2C #$;Char] + [convert//int-to-double #$;Int $i;I2D #$;Double] + [convert//int-to-float #$;Int $i;I2F #$;Float] + [convert//int-to-long #$;Int $i;I2L #$;Long] + [convert//int-to-short #$;Int $i;I2S #$;Short] + [convert//long-to-double #$;Long $i;L2D #$;Double] + [convert//long-to-float #$;Long $i;L2F #$;Float] + [convert//long-to-int #$;Long $i;L2I #$;Int] + [convert//long-to-short #$;Long L2S #$;Short] + [convert//long-to-byte #$;Long L2B #$;Byte] + [convert//long-to-char #$;Long L2C #$;Char] + [convert//char-to-byte #$;Char $i;I2B #$;Byte] + [convert//char-to-short #$;Char $i;I2S #$;Short] + [convert//char-to-int #$;Char $i;NOP #$;Int] + [convert//char-to-long #$;Char $i;I2L #$;Long] + [convert//byte-to-long #$;Byte $i;I2L #$;Long] + [convert//short-to-long #$;Short $i;I2L #$;Long] + ) + +(def: conversion-procs + @;Bundle + (<| (@;prefix "convert") + (|> (dict;new text;Hash<Text>) + (@;install "double-to-float" (@;unary convert//double-to-float)) + (@;install "double-to-int" (@;unary convert//double-to-int)) + (@;install "double-to-long" (@;unary convert//double-to-long)) + (@;install "float-to-double" (@;unary convert//float-to-double)) + (@;install "float-to-int" (@;unary convert//float-to-int)) + (@;install "float-to-long" (@;unary convert//float-to-long)) + (@;install "int-to-byte" (@;unary convert//int-to-byte)) + (@;install "int-to-char" (@;unary convert//int-to-char)) + (@;install "int-to-double" (@;unary convert//int-to-double)) + (@;install "int-to-float" (@;unary convert//int-to-float)) + (@;install "int-to-long" (@;unary convert//int-to-long)) + (@;install "int-to-short" (@;unary convert//int-to-short)) + (@;install "long-to-double" (@;unary convert//long-to-double)) + (@;install "long-to-float" (@;unary convert//long-to-float)) + (@;install "long-to-int" (@;unary convert//long-to-int)) + (@;install "long-to-short" (@;unary convert//long-to-short)) + (@;install "long-to-byte" (@;unary convert//long-to-byte)) + (@;install "long-to-char" (@;unary convert//long-to-char)) + (@;install "char-to-byte" (@;unary convert//char-to-byte)) + (@;install "char-to-short" (@;unary convert//char-to-short)) + (@;install "char-to-int" (@;unary convert//char-to-int)) + (@;install "char-to-long" (@;unary convert//char-to-long)) + (@;install "byte-to-long" (@;unary convert//byte-to-long)) + (@;install "short-to-long" (@;unary convert//short-to-long)) + ))) + +(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>] + [(def: (<name> [xI yI]) + @;Binary + (|>. xI ($i;unwrap <unwrapX>) + yI ($i;unwrap <unwrapY>) + <op> ($i;wrap <wrap>)))] + + [int//+ $i;IADD #$;Int #$;Int #$;Int] + [int//- $i;ISUB #$;Int #$;Int #$;Int] + [int//* $i;IMUL #$;Int #$;Int #$;Int] + [int/// $i;IDIV #$;Int #$;Int #$;Int] + [int//% $i;IREM #$;Int #$;Int #$;Int] + [int//and $i;IAND #$;Int #$;Int #$;Int] + [int//or $i;IOR #$;Int #$;Int #$;Int] + [int//xor $i;IXOR #$;Int #$;Int #$;Int] + [int//shl $i;ISHL #$;Int #$;Int #$;Int] + [int//shr $i;ISHR #$;Int #$;Int #$;Int] + [int//ushr $i;IUSHR #$;Int #$;Int #$;Int] + + [long//+ $i;LADD #$;Long #$;Long #$;Long] + [long//- $i;LSUB #$;Long #$;Long #$;Long] + [long//* $i;LMUL #$;Long #$;Long #$;Long] + [long/// $i;LDIV #$;Long #$;Long #$;Long] + [long//% $i;LREM #$;Long #$;Long #$;Long] + [long//and $i;LAND #$;Long #$;Long #$;Long] + [long//or $i;LOR #$;Long #$;Long #$;Long] + [long//xor $i;LXOR #$;Long #$;Long #$;Long] + [long//shl $i;LSHL #$;Long #$;Int #$;Long] + [long//shr $i;LSHR #$;Long #$;Int #$;Long] + [long//ushr $i;LUSHR #$;Long #$;Int #$;Long] + + [float//+ $i;FADD #$;Float #$;Float #$;Float] + [float//- $i;FSUB #$;Float #$;Float #$;Float] + [float//* $i;FMUL #$;Float #$;Float #$;Float] + [float/// $i;FDIV #$;Float #$;Float #$;Float] + [float//% $i;FREM #$;Float #$;Float #$;Float] + + [double//+ $i;DADD #$;Double #$;Double #$;Double] + [double//- $i;DSUB #$;Double #$;Double #$;Double] + [double//* $i;DMUL #$;Double #$;Double #$;Double] + [double/// $i;DDIV #$;Double #$;Double #$;Double] + [double//% $i;DREM #$;Double #$;Double #$;Double] + ) + +(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>] + [(def: (<name> [xI yI]) + @;Binary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. xI ($i;unwrap <unwrapX>) + yI ($i;unwrap <unwrapY>) + (<op> @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end))))] + + [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean] + [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean] + + [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean] + [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean] + ) + +(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>] + [(def: (<name> [xI yI]) + @;Binary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. xI ($i;unwrap <unwrapX>) + yI ($i;unwrap <unwrapY>) + <op> + ($i;int <reference>) + ($i;IF_ICMPEQ @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end))))] + + [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean] + [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean] + + [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean] + [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean] + + [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean] + [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean] + ) + +(def: int-procs + @;Bundle + (<| (@;prefix "int") + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary int//+)) + (@;install "-" (@;binary int//-)) + (@;install "*" (@;binary int//*)) + (@;install "/" (@;binary int///)) + (@;install "%" (@;binary int//%)) + (@;install "=" (@;binary int//=)) + (@;install "<" (@;binary int//<)) + (@;install "and" (@;binary int//and)) + (@;install "or" (@;binary int//or)) + (@;install "xor" (@;binary int//xor)) + (@;install "shl" (@;binary int//shl)) + (@;install "shr" (@;binary int//shr)) + (@;install "ushr" (@;binary int//ushr)) + ))) + +(def: long-procs + @;Bundle + (<| (@;prefix "long") + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary long//+)) + (@;install "-" (@;binary long//-)) + (@;install "*" (@;binary long//*)) + (@;install "/" (@;binary long///)) + (@;install "%" (@;binary long//%)) + (@;install "=" (@;binary long//=)) + (@;install "<" (@;binary long//<)) + (@;install "and" (@;binary long//and)) + (@;install "or" (@;binary long//or)) + (@;install "xor" (@;binary long//xor)) + (@;install "shl" (@;binary long//shl)) + (@;install "shr" (@;binary long//shr)) + (@;install "ushr" (@;binary long//ushr)) + ))) + +(def: float-procs + @;Bundle + (<| (@;prefix "float") + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary float//+)) + (@;install "-" (@;binary float//-)) + (@;install "*" (@;binary float//*)) + (@;install "/" (@;binary float///)) + (@;install "%" (@;binary float//%)) + (@;install "=" (@;binary float//=)) + (@;install "<" (@;binary float//<)) + ))) + +(def: double-procs + @;Bundle + (<| (@;prefix "double") + (|> (dict;new text;Hash<Text>) + (@;install "+" (@;binary double//+)) + (@;install "-" (@;binary double//-)) + (@;install "*" (@;binary double//*)) + (@;install "/" (@;binary double///)) + (@;install "%" (@;binary double//%)) + (@;install "=" (@;binary double//=)) + (@;install "<" (@;binary double//<)) + ))) + +(def: char-procs + @;Bundle + (<| (@;prefix "char") + (|> (dict;new text;Hash<Text>) + (@;install "=" (@;binary char//=)) + (@;install "<" (@;binary char//<)) + ))) + +(def: (array//length arrayI) + @;Unary + (|>. arrayI + $i;ARRAYLENGTH + $i;I2L + ($i;wrap #$;Long))) + +(def: (array//new proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) + (do meta;Monad<Meta> + [lengthI (generate lengthS) + #let [arrayJT ($t;array level (case class + "boolean" $t;boolean + "byte" $t;byte + "short" $t;short + "int" $t;int + "long" $t;long + "float" $t;float + "double" $t;double + "char" $t;char + _ ($t;class class (list))))]] + (wrap (|>. lengthI + ($i;unwrap #$;Long) + $i;L2I + ($i;array arrayJT)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//read proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] idxS arrayS)) + (do meta;Monad<Meta> + [arrayI (generate arrayS) + idxI (generate idxS) + #let [loadI (case class + "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) + "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) + "short" (|>. $i;SALOAD ($i;wrap #$;Short)) + "int" (|>. $i;IALOAD ($i;wrap #$;Int)) + "long" (|>. $i;LALOAD ($i;wrap #$;Long)) + "float" (|>. $i;FALOAD ($i;wrap #$;Float)) + "double" (|>. $i;DALOAD ($i;wrap #$;Double)) + "char" (|>. $i;CALOAD ($i;wrap #$;Char)) + _ $i;AALOAD)]] + (wrap (|>. arrayI + idxI + ($i;unwrap #$;Long) + $i;L2I + loadI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (array//write proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] idxS valueS arrayS)) + (do meta;Monad<Meta> + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS) + #let [storeI (case class + "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) + "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) + "short" (|>. ($i;unwrap #$;Short) $i;SASTORE) + "int" (|>. ($i;unwrap #$;Int) $i;IASTORE) + "long" (|>. ($i;unwrap #$;Long) $i;LASTORE) + "float" (|>. ($i;unwrap #$;Float) $i;FASTORE) + "double" (|>. ($i;unwrap #$;Double) $i;DASTORE) + "char" (|>. ($i;unwrap #$;Char) $i;CASTORE) + _ $i;AASTORE)]] + (wrap (|>. arrayI + $i;DUP + idxI + ($i;unwrap #$;Long) + $i;L2I + valueI + storeI))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: array-procs + @;Bundle + (<| (@;prefix "array") + (|> (dict;new text;Hash<Text>) + (@;install "length" (@;unary array//length)) + (@;install "new" array//new) + (@;install "read" array//read) + (@;install "write" array//write) + ))) + +(def: (object//null _) + @;Nullary + $i;NULL) + +(def: (object//null? objectI) + @;Unary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. objectI + ($i;IFNULL @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end)))) + +(def: (object//synchronized [monitorI exprI]) + @;Binary + (|>. monitorI + $i;DUP + $i;MONITORENTER + exprI + $i;SWAP + $i;MONITOREXIT)) + +(def: (object//throw exceptionI) + @;Unary + (|>. exceptionI + $i;ATHROW)) + +(def: (object//class proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)])) + (do meta;Monad<Meta> + [] + (wrap (|>. ($i;string class) + ($i;INVOKESTATIC "java.lang.Class" "forName" + ($t;method (list ($t;class "java.lang.String" (list))) + (#;Some ($t;class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (object//instance? proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] objectS)) + (do meta;Monad<Meta> + [objectI (generate objectS)] + (wrap (|>. objectI + ($i;INSTANCEOF class) + ($i;wrap #$;Boolean)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: object-procs + @;Bundle + (<| (@;prefix "object") + (|> (dict;new text;Hash<Text>) + (@;install "null" (@;nullary object//null)) + (@;install "null?" (@;unary object//null?)) + (@;install "synchronized" (@;binary object//synchronized)) + (@;install "throw" (@;unary object//throw)) + (@;install "class" object//class) + (@;install "instance?" object//instance?) + ))) + +(def: primitives + (Dict Text $;Primitive) + (|> (list ["boolean" #$;Boolean] + ["byte" #$;Byte] + ["short" #$;Short] + ["int" #$;Int] + ["long" #$;Long] + ["float" #$;Float] + ["double" #$;Double] + ["char" #$;Char]) + (dict;from-list text;Hash<Text>))) + +(def: (static//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) + (do meta;Monad<Meta> + [] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap ($i;GETSTATIC class field ($t;class unboxed (list)))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (static//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) + (do meta;Monad<Meta> + [valueI (generate valueS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. valueI + ($i;unwrap primitive) + ($i;PUTSTATIC class field (#$;Primitive primitive)) + ($i;string hostL;unit)))) + + #;None + (wrap (|>. valueI + ($i;CHECKCAST class) + ($i;PUTSTATIC class field ($t;class class (list))) + ($i;string hostL;unit))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//get proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) + (do meta;Monad<Meta> + [objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field (#$;Primitive primitive)) + ($i;wrap primitive)))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + ($i;GETFIELD class field ($t;class unboxed (list))))))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (virtual//put proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) + (do meta;Monad<Meta> + [valueI (generate valueS) + objectI (generate objectS)] + (case (dict;get unboxed primitives) + (#;Some primitive) + (let [primitive (case unboxed + "boolean" #$;Boolean + "byte" #$;Byte + "short" #$;Short + "int" #$;Int + "long" #$;Long + "float" #$;Float + "double" #$;Double + "char" #$;Char + _ (undefined))] + (wrap (|>. objectI + ($i;CHECKCAST class) + $i;DUP + valueI + ($i;unwrap primitive) + ($i;PUTFIELD class field (#$;Primitive primitive))))) + + #;None + (wrap (|>. objectI + ($i;CHECKCAST class) + $i;DUP + valueI + ($i;CHECKCAST unboxed) + ($i;PUTFIELD class field ($t;class unboxed (list))))))) + + _ + (&;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& [_ (#;Tuple (list [_ (#;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 hostL;unit)) + + (#;Some type) + (case type + (#$;Primitive primitive) + (|>. returnI ($i;wrap primitive)) + + _ + returnI))) + +(def: (invoke//static proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;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& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;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& [_ (#;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") + (|> (dict;new text;Hash<Text>) + (dict;merge (<| (@;prefix "static") + (|> (dict;new text;Hash<Text>) + (@;install "get" static//get) + (@;install "put" static//put)))) + (dict;merge (<| (@;prefix "virtual") + (|> (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 + @;Bundle + (<| (@;prefix "jvm") + (|> (dict;new text;Hash<Text>) + (dict;merge conversion-procs) + (dict;merge int-procs) + (dict;merge long-procs) + (dict;merge float-procs) + (dict;merge double-procs) + (dict;merge char-procs) + (dict;merge array-procs) + (dict;merge object-procs) + (dict;merge member-procs) + ))) |