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 | |
parent | 71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff) |
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/procedure')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux | 707 | ||||
-rw-r--r-- | new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux | 761 |
2 files changed, 1468 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux new file mode 100644 index 000000000..80becb058 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -0,0 +1,707 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + [dict #+ Dict])) + [meta #+ with-gensyms] + (meta [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" base] + [";L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + (lang ["la" analysis] + ["ls" synthesis] + (translation [";T" runtime])))) + +(host;import java.lang.Long + (#static MIN_VALUE Long) + (#static MAX_VALUE Long)) + +(host;import java.lang.Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double) + (#static NaN Double) + (#static POSITIVE_INFINITY Double) + (#static NEGATIVE_INFINITY Double)) + +## [Types] +(type: #export Generator + (-> ls;Synthesis (Meta $;Inst))) + +(type: #export Proc + (-> Generator (List ls;Synthesis) (Meta $;Inst))) + +(type: #export Bundle + (Dict Text Proc)) + +(syntax: (Vector [size s;nat] elemT) + (wrap (list (` [(~@ (list;repeat size elemT))])))) + +(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst)) +(type: #export Unary (-> (Vector +1 $;Inst) $;Inst)) +(type: #export Binary (-> (Vector +2 $;Inst) $;Inst)) +(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst)) + +## [Utils] +(def: $Object $;Type ($t;class "java.lang.Object" (list))) +(def: $Object-Array $;Type ($t;array +1 $Object)) +(def: $String $;Type ($t;class "java.lang.String" (list))) +(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) +(def: $Function $;Type ($t;class hostL;function-class (list))) + +(def: #export (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict;put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict;entries + (list/map (function [[key val]] [(format prefix " " key) val])) + (dict;from-list text;Hash<Text>))) + +(def: (wrong-arity proc expected actual) + (-> Text Nat Nat Text) + (format "Wrong number of arguments for " (%t proc) "\n" + "Expected: " (|> expected nat-to-int %i) "\n" + " Actual: " (|> actual nat-to-int %i))) + +(syntax: (arity: [name s;local-symbol] [arity s;nat]) + (with-gensyms [g!proc g!name g!generate g!inputs] + (do @ + [g!input+ (monad;seq @ (list;repeat arity (meta;gensym "input")))] + (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc)) + (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst) + (-> Text ;;Proc)) + (function [(~ g!name)] + (function [(~ g!generate) (~ g!inputs)] + (case (~ g!inputs) + (^ (list (~@ g!input+))) + (do meta;Monad<Meta> + [(~@ (|> g!input+ + (list/map (function [g!input] + (list g!input (` ((~ g!generate) (~ g!input)))))) + list;concat))] + ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) + + (~' _) + (meta;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +## [Instructions] +(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long))) +(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I)) + +(def: (array-writeI arrayI idxI elemI) + (-> $;Inst $;Inst $;Inst + $;Inst) + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + $i;DUP + idxI jvm-intI + elemI + $i;AASTORE)) + +(def: (predicateI tester) + (-> (-> $;Label $;Inst) + $;Inst) + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. (tester @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) + ))) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftI rightI]) + Binary + (|>. leftI + rightI + (predicateI $i;IF_ACMPEQ))) + +(def: try-method + $;Method + ($t;method (list $Function) (#;Some $Object-Array) (list))) +(def: (lux//try riskyI) + Unary + (|>. riskyI + ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) + +(def: (lux//noop valueI) + Unary + valueI) + +## [[Bits]] +(do-template [<name> <op>] + [(def: (<name> [inputI maskI]) + Binary + (|>. inputI ($i;unwrap #$;Long) + maskI ($i;unwrap #$;Long) + <op> ($i;wrap #$;Long)))] + + [bit//and $i;LAND] + [bit//or $i;LOR] + [bit//xor $i;LXOR] + ) + +(def: (bit//count inputI) + Unary + (|>. inputI ($i;unwrap #$;Long) + ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false) + lux-intI)) + +(do-template [<name> <op>] + [(def: (<name> [inputI shiftI]) + Binary + (|>. inputI ($i;unwrap #$;Long) + shiftI jvm-intI + <op> + ($i;wrap #$;Long)))] + + [bit//shift-left $i;LSHL] + [bit//shift-right $i;LSHR] + [bit//unsigned-shift-right $i;LUSHR] + ) + +## [[Arrays]] +(def: (array//new lengthI) + Unary + (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object)))) + +(def: (array//get [arrayI idxI]) + Binary + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@end]) + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + idxI jvm-intI + $i;AALOAD + $i;DUP + ($i;IFNULL @is-null) + runtimeT;someI + ($i;GOTO @end) + ($i;label @is-null) + $i;POP + runtimeT;noneI + ($i;label @end)))) + +(def: (array//put [arrayI idxI elemI]) + Trinary + (array-writeI arrayI idxI elemI)) + +(def: (array//remove [arrayI idxI]) + Binary + (array-writeI arrayI idxI $i;NULL)) + +(def: (array//size arrayI) + Unary + (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array)) + $i;ARRAYLENGTH + lux-intI)) + +## [[Numbers]] +(def: nat-method + $;Method + ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) + +(def: deg-method $;Method nat-method) + +(def: compare-nat-method + $;Method + ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) + +(do-template [<name> <const> <wrapper>] + [(def: (<name> _) + Nullary + (|>. <const> <wrapper>))] + + [nat//min ($i;long 0) ($i;wrap #$;Long)] + [nat//max ($i;long -1) ($i;wrap #$;Long)] + + [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)] + [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)] + + [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)] + [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)] + [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)] + [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)] + [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)] + [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)] + + [deg//min ($i;long 0) ($i;wrap #$;Long)] + [deg//max ($i;long -1) ($i;wrap #$;Long)] + ) + +(do-template [<name> <unwrap> <wrap> <op>] + [(def: (<name> [subjectI paramI]) + Binary + (|>. subjectI <unwrap> + paramI <unwrap> + <op> + <wrap>))] + + [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] + [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM] + + [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] + [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] + + [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] + [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] + [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL] + [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV] + [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM] + + [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] + [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] + [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) + ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] + [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] + [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] + [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] + ) + +(do-template [<eq> <lt> <unwrap> <cmp>] + [(do-template [<name> <reference>] + [(def: (<name> [subjectI paramI]) + Binary + (|>. subjectI <unwrap> + paramI <unwrap> + <cmp> + ($i;int <reference>) + (predicateI $i;IF_ICMPEQ)))] + [<eq> 0] + [<lt> -1])] + + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] + [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP] + [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] + ) + +(do-template [<name> <prepare> <transform>] + [(def: (<name> inputI) + Unary + (|>. inputI <prepare> <transform>))] + + [nat//to-int id id] + [nat//to-char ($i;unwrap #$;Long) + (<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false) + $i;I2C $i;L2I)] + + [int//to-nat id id] + [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)] + + [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] + [frac//to-deg ($i;unwrap #$;Double) + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg" + ($t;method (list $t;double) (#;Some $t;long) (list)) false))] + [frac//encode ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)] + [frac//decode ($i;CHECKCAST "java.lang.String") + ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + + [deg//to-frac ($i;unwrap #$;Long) + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac" + ($t;method (list $t;long) (#;Some $t;double) (list)) false))] + ) + +## [[Text]] +(do-template [<name> <class> <method> <post> <outputT>] + [(def: (<name> inputI) + Unary + (|>. inputI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false) + <post>))] + + [text//size "java.lang.String" "length" lux-intI $t;int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] + [text//trim "java.lang.String" "trim" id $String] + [text//upper-case "java.lang.String" "toUpperCase" id $String] + [text//lower-case "java.lang.String" "toLowerCase" id $String] + ) + +(do-template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [subjectI paramI]) + Binary + (|>. subjectI <pre-subject> + paramI <pre-param> + <op> <post>))] + + [text//eq id id + ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean)] + [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false) + (predicateI $i;IF_ICMPEQ)] + [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) + id] + [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean)] + [text//char ($i;CHECKCAST "java.lang.String") jvm-intI + ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + lux-intI] + ) + +(do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>] + [(def: (<name> [subjectI paramI extraI]) + Trinary + (|>. subjectI <pre-subject> + paramI <pre-param> + extraI <pre-extra> + <op>))] + + [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI + ($i;INVOKESTATIC hostL;runtime-class "text_clip" + ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] + [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] + ) + +(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list))) +(do-template [<name> <method>] + [(def: (<name> [textI partI startI]) + Trinary + (<| $i;with-label (function [@not-found]) + $i;with-label (function [@end]) + (|>. textI ($i;CHECKCAST "java.lang.String") + partI ($i;CHECKCAST "java.lang.String") + startI jvm-intI + ($i;INVOKEVIRTUAL "java.lang.String" <method> index-method false) + $i;DUP + ($i;int -1) + ($i;IF_ICMPEQ @not-found) + lux-intI + runtimeT;someI + ($i;GOTO @end) + ($i;label @not-found) + $i;POP + runtimeT;noneI + ($i;label @end))))] + + [text//index "indexOf"] + [text//last-index "lastIndexOf"] + ) + +## [[Math]] +(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list))) +(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list))) + +(do-template [<name> <method>] + [(def: (<name> inputI) + Unary + (|>. inputI + ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false) + ($i;wrap #$;Double)))] + + [math//cos "cos"] + [math//sin "sin"] + [math//tan "tan"] + [math//acos "acos"] + [math//asin "asin"] + [math//atan "atan"] + [math//cosh "cosh"] + [math//sinh "sinh"] + [math//tanh "tanh"] + [math//exp "exp"] + [math//log "log"] + [math//root2 "sqrt"] + [math//root3 "cbrt"] + [math//ceil "ceil"] + [math//floor "floor"] + ) + +(do-template [<name> <method>] + [(def: (<name> [inputI paramI]) + Binary + (|>. inputI ($i;unwrap #$;Double) + paramI ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false) + ($i;wrap #$;Double)))] + + [math//atan2 "atan2"] + [math//pow "pow"] + ) + +(def: (math//round inputI) + Unary + (|>. inputI + ($i;unwrap #$;Double) + ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false) + $i;L2D + ($i;wrap #$;Double))) + +## [[IO]] +(def: string-method $;Method ($t;method (list $String) #;None (list))) +(def: (io//log messageI) + Unary + (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) + messageI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) + ($i;string hostL;unit))) + +(def: (io//error messageI) + Unary + (|>. ($i;NEW "java.lang.Error") + $i;DUP + messageI + ($i;CHECKCAST "java.lang.String") + ($i;INVOKESPECIAL "java.lang.Error" "<init>" string-method false) + $i;ATHROW)) + +(def: (io//exit codeI) + Unary + (|>. codeI jvm-intI + ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false) + $i;NULL)) + +(def: (io//current-time []) + Nullary + (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false) + ($i;wrap #$;Long))) + +## [[Atoms]] +(def: atom-class Text "java.util.concurrent.atomic.AtomicReference") +(def: (atom//new initI) + Unary + (|>. ($i;NEW atom-class) + $i;DUP + initI + ($i;INVOKESPECIAL atom-class "<init>" ($t;method (list $Object) #;None (list)) false))) + +(def: (atom//read atomI) + Unary + (|>. atomI + ($i;CHECKCAST atom-class) + ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false))) + +(def: (atom//compare-and-swap [atomI oldI newI]) + Trinary + (|>. atomI + ($i;CHECKCAST atom-class) + oldI + newI + ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false) + ($i;wrap #$;Boolean))) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) + lux-intI)) + +(def: (process//future procedureI) + Unary + (|>. procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "future" + ($t;method (list $Function) (#;Some $Object) (list)) false))) + +(def: (process//schedule [millisecondsI procedureI]) + Binary + (|>. millisecondsI ($i;unwrap #$;Long) + procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "schedule" + ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) + +## [Bundles] +(def: lux-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "lux noop" (unary lux//noop)) + (install "lux is" (binary lux//is)) + (install "lux try" (unary lux//try)))) + +(def: bit-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "bit count" (unary bit//count)) + (install "bit and" (binary bit//and)) + (install "bit or" (binary bit//or)) + (install "bit xor" (binary bit//xor)) + (install "bit shift-left" (binary bit//shift-left)) + (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "bit shift-right" (binary bit//shift-right)) + )) + +(def: nat-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "nat +" (binary nat//add)) + (install "nat -" (binary nat//sub)) + (install "nat *" (binary nat//mul)) + (install "nat /" (binary nat//div)) + (install "nat %" (binary nat//rem)) + (install "nat =" (binary nat//eq)) + (install "nat <" (binary nat//lt)) + (install "nat min" (nullary nat//min)) + (install "nat max" (nullary nat//max)) + (install "nat to-int" (unary nat//to-int)) + (install "nat to-char" (unary nat//to-char)))) + +(def: int-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "int +" (binary int//add)) + (install "int -" (binary int//sub)) + (install "int *" (binary int//mul)) + (install "int /" (binary int//div)) + (install "int %" (binary int//rem)) + (install "int =" (binary int//eq)) + (install "int <" (binary int//lt)) + (install "int min" (nullary int//min)) + (install "int max" (nullary int//max)) + (install "int to-nat" (unary int//to-nat)) + (install "int to-frac" (unary int//to-frac)))) + +(def: deg-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "deg +" (binary deg//add)) + (install "deg -" (binary deg//sub)) + (install "deg *" (binary deg//mul)) + (install "deg /" (binary deg//div)) + (install "deg %" (binary deg//rem)) + (install "deg =" (binary deg//eq)) + (install "deg <" (binary deg//lt)) + (install "deg scale" (binary deg//scale)) + (install "deg reciprocal" (binary deg//reciprocal)) + (install "deg min" (nullary deg//min)) + (install "deg max" (nullary deg//max)) + (install "deg to-frac" (unary deg//to-frac)))) + +(def: frac-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "frac +" (binary frac//add)) + (install "frac -" (binary frac//sub)) + (install "frac *" (binary frac//mul)) + (install "frac /" (binary frac//div)) + (install "frac %" (binary frac//rem)) + (install "frac =" (binary frac//eq)) + (install "frac <" (binary frac//lt)) + (install "frac smallest" (nullary frac//smallest)) + (install "frac min" (nullary frac//min)) + (install "frac max" (nullary frac//max)) + (install "frac not-a-number" (nullary frac//not-a-number)) + (install "frac positive-infinity" (nullary frac//positive-infinity)) + (install "frac negative-infinity" (nullary frac//negative-infinity)) + (install "frac to-deg" (unary frac//to-deg)) + (install "frac to-int" (unary frac//to-int)) + (install "frac encode" (unary frac//encode)) + (install "frac decode" (unary frac//decode)))) + +(def: text-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "text =" (binary text//eq)) + (install "text <" (binary text//lt)) + (install "text append" (binary text//append)) + (install "text index" (trinary text//index)) + (install "text size" (unary text//size)) + (install "text hash" (unary text//hash)) + (install "text replace" (trinary text//replace)) + (install "text char" (binary text//char)) + (install "text clip" (trinary text//clip)) + )) + +(def: array-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "array new" (unary array//new)) + (install "array get" (binary array//get)) + (install "array put" (trinary array//put)) + (install "array remove" (binary array//remove)) + (install "array size" (unary array//size)) + )) + +(def: math-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "math cos" (unary math//cos)) + (install "math sin" (unary math//sin)) + (install "math tan" (unary math//tan)) + (install "math acos" (unary math//acos)) + (install "math asin" (unary math//asin)) + (install "math atan" (unary math//atan)) + (install "math cosh" (unary math//cosh)) + (install "math sinh" (unary math//sinh)) + (install "math tanh" (unary math//tanh)) + (install "math exp" (unary math//exp)) + (install "math log" (unary math//log)) + (install "math root2" (unary math//root2)) + (install "math root3" (unary math//root3)) + (install "math ceil" (unary math//ceil)) + (install "math floor" (unary math//floor)) + (install "math round" (unary math//round)) + (install "math atan2" (binary math//atan2)) + (install "math pow" (binary math//pow)) + )) + +(def: io-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "io log" (unary io//log)) + (install "io error" (unary io//error)) + (install "io exit" (unary io//exit)) + (install "io current-time" (nullary io//current-time)))) + +(def: atom-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "atom new" (unary atom//new)) + (install "atom read" (unary atom//read)) + (install "atom compare-and-swap" (trinary atom//compare-and-swap)))) + +(def: process-procs + Bundle + (|> (dict;new text;Hash<Text>) + (install "process concurrency-level" (nullary process//concurrency-level)) + (install "process future" (unary process//future)) + (install "process schedule" (binary process//schedule)) + )) + +(def: #export procedures + Bundle + (|> (dict;new text;Hash<Text>) + (dict;merge lux-procs) + (dict;merge bit-procs) + (dict;merge nat-procs) + (dict;merge int-procs) + (dict;merge deg-procs) + (dict;merge frac-procs) + (dict;merge text-procs) + (dict;merge array-procs) + (dict;merge math-procs) + (dict;merge io-procs) + (dict;merge atom-procs) + (dict;merge process-procs) + )) 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) + ))) |