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/generator/procedure | |
parent | 71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff) |
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/generator/procedure')
-rw-r--r-- | new-luxc/source/luxc/generator/procedure/common.jvm.lux | 708 | ||||
-rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 763 |
2 files changed, 0 insertions, 1471 deletions
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux deleted file mode 100644 index dffbcb64e..000000000 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ /dev/null @@ -1,708 +0,0 @@ -(;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]) - (generator ["&;" common] - ["&;" 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) - &runtime;someI - ($i;GOTO @end) - ($i;label @is-null) - $i;POP - &runtime;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 - &runtime;someI - ($i;GOTO @end) - ($i;label @not-found) - $i;POP - &runtime;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/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux deleted file mode 100644 index 9222b2e4a..000000000 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ /dev/null @@ -1,763 +0,0 @@ -(;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]) - (generator ["&;" common] - ["&;" runtime])) - ["@" ../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) - ))) |