From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 8 Jan 2018 21:40:06 -0400 Subject: - Moved all translation code under the JVM path (in preparation for porting the JS back-end). --- .../lang/translation/jvm/procedure/common.jvm.lux | 809 +++++++++++++++++++++ .../lang/translation/jvm/procedure/host.jvm.lux | 761 +++++++++++++++++++ 2 files changed, 1570 insertions(+) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure') diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux new file mode 100644 index 000000000..c7513fd6e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -0,0 +1,809 @@ +(.module: + lux + (lux (control [monad #+ do] + ["p" parser] + ["ex" exception #+ exception:]) + (data ["e" error] + [text] + text/format + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + ["ls" synthesis])) + (/// [".T" runtime] + [".T" case] + [".T" function] + [".T" loop])) + +(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 Translator + (-> ls.Synthesis (Meta $.Inst))) + +(type: #export Proc + (-> Translator (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)) +(type: #export Variadic (-> (List $.Inst) $.Inst)) + +## [Utils] +(def: $Object $.Type ($t.class "java.lang.Object" (list))) +(def: $Object-Array $.Type ($t.array +1 $Object)) +(def: $Variant $.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))) + +(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!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.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!translate) (~ g!inputs)] + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do macro.Monad + [(~+ (|> g!input+ + (list/map (function [g!input] + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) + + (~' _) + (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) + +(arity: nullary +0) +(arity: unary +1) +(arity: binary +2) +(arity: trinary +3) + +(def: #export (variadic proc) + (-> Variadic (-> Text Proc)) + (function [proc-name] + (function [translate inputsS] + (do macro.Monad + [inputsI (monad.map @ translate inputsS)] + (wrap (proc inputsI)))))) + +## [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) + ))) + +(def: unitI $.Inst ($i.string hostL.unit)) + +## [Procedures] +## [[Lux]] +(def: (lux//is [leftI rightI]) + Binary + (|>> leftI + rightI + (predicateI $i.IF_ACMPEQ))) + +(def: (lux//if [testI thenI elseI]) + Trinary + (caseT.translate-if testI thenI elseI)) + +(def: (lux//try riskyI) + Unary + (|>> riskyI + ($i.CHECKCAST hostL.function-class) + ($i.INVOKESTATIC hostL.runtime-class "try" + ($t.method (list $Function) (#.Some $Object-Array) (list)) + false))) + +(def: (lux//noop valueI) + Unary + valueI) + +(exception: #export Wrong-Syntax) +(def: #export (wrong-syntax procedure args) + (-> Text (List ls.Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code.tuple args)))) + +(def: lux//loop + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) + (#e.Success [offset initsS+ bodyS]) + (loopT.translate-loop translate offset initsS+ bodyS) + + (#e.Error error) + (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) + ))) + +(def: lux//recur + (-> Text Proc) + (function [proc-name] + (function [translate inputsS] + (loopT.translate-recur translate inputsS)))) + +## [[Bits]] +(do-template [ ] + [(def: ( [inputI maskI]) + Binary + (|>> inputI ($i.unwrap #$.Long) + maskI ($i.unwrap #$.Long) + ($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 [ ] + [(def: ( [inputI shiftI]) + Binary + (|>> inputI ($i.unwrap #$.Long) + shiftI jvm-intI + + ($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.binary-name "java.lang.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 [ ] + [(def: ( _) + Nullary + (|>> ($i.wrap )))] + + [nat//min ($i.long 0) #$.Long] + [nat//max ($i.long -1) #$.Long] + + [int//min ($i.long Long::MIN_VALUE) #$.Long] + [int//max ($i.long Long::MAX_VALUE) #$.Long] + + [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] + [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] + [frac//max ($i.double Double::MAX_VALUE) #$.Double] + [frac//not-a-number ($i.double Double::NaN) #$.Double] + [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] + [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] + + [deg//min ($i.long 0) #$.Long] + [deg//max ($i.long -1) #$.Long] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI ($i.unwrap ) + paramI ($i.unwrap ) + + ($i.wrap )))] + + [int//add #$.Long $i.LADD] + [int//sub #$.Long $i.LSUB] + [int//mul #$.Long $i.LMUL] + [int//div #$.Long $i.LDIV] + [int//rem #$.Long $i.LREM] + + [nat//add #$.Long $i.LADD] + [nat//sub #$.Long $i.LSUB] + [nat//mul #$.Long $i.LMUL] + [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)] + [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)] + + [frac//add #$.Double $i.DADD] + [frac//sub #$.Double $i.DSUB] + [frac//mul #$.Double $i.DMUL] + [frac//div #$.Double $i.DDIV] + [frac//rem #$.Double $i.DREM] + + [deg//add #$.Long $i.LADD] + [deg//sub #$.Long $i.LSUB] + [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)] + [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)] + [deg//rem #$.Long $i.LSUB] + [deg//scale #$.Long $i.LMUL] + [deg//reciprocal #$.Long $i.LDIV] + ) + +(do-template [ ] + [(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI + paramI + + ($i.int ) + (predicateI $i.IF_ICMPEQ)))] + [ 0] + [ -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 [ ] + [(def: ( inputI) + Unary + (|>> inputI ))] + + [nat//to-int id id] + [nat//char ($i.unwrap #$.Long) + ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] + + [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 [ ] + [(def: ( inputI) + Unary + (|>> inputI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) false) + ))] + + [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 "java.lang.String" "toUpperCase" id $String] + [text//lower "java.lang.String" "toLowerCase" id $String] + ) + +(do-template [ ] + [(def: ( [subjectI paramI]) + Binary + (|>> subjectI + paramI + ))] + + [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) ($i.int -1))] + [text//concat ($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 $Variant) (list)) false) + id] + ) + +(do-template [ ] + [(def: ( [subjectI paramI extraI]) + Trinary + (|>> subjectI + paramI + extraI + ))] + + [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 $Variant) (list)) false)] + [text//replace-once ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] + [text//replace-all ($i.CHECKCAST "java.lang.String") + (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) + ($i.CHECKCAST "java.lang.String")) + ($i.CHECKCAST "java.lang.String") + ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] + ) + +(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) +(do-template [ ] + [(def: ( [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" 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 [ ] + [(def: ( inputI) + Unary + (|>> inputI + ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" 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 [ ] + [(def: ( [inputI paramI]) + Binary + (|>> inputI ($i.unwrap #$.Double) + paramI ($i.unwrap #$.Double) + ($i.INVOKESTATIC "java.lang.Math" 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) + unitI)) + +(def: (io//error messageI) + Unary + (|>> ($i.NEW "java.lang.Error") + $i.DUP + messageI + ($i.CHECKCAST "java.lang.String") + ($i.INVOKESPECIAL "java.lang.Error" "" 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 "" ($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))) + +## [[Box]] +(def: empty-boxI + $.Inst + (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) + +(def: check-boxI + $.Inst + ($i.CHECKCAST ($t.descriptor $Object-Array))) + +(def: (box//new initI) + Unary + (|>> empty-boxI + $i.DUP ($i.int 0) initI $i.AASTORE)) + +(def: (box//read boxI) + Unary + (|>> boxI check-boxI + ($i.int 0) $i.AALOAD)) + +(def: (box//write [valueI boxI]) + Binary + (|>> boxI check-boxI + ($i.int 0) valueI $i.AASTORE + unitI)) + +## [[Processes]] +(def: (process//concurrency-level []) + Nullary + (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) + ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) + 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) + (install "noop" (unary lux//noop)) + (install "is" (binary lux//is)) + (install "try" (unary lux//try)) + (install "if" (trinary lux//if)) + (install "loop" lux//loop) + (install "recur" lux//recur) + )) + +(def: bit-procs + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash) + (install "count" (unary bit//count)) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "shift-left" (binary bit//shift-left)) + (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "shift-right" (binary bit//shift-right)) + ))) + +(def: nat-procs + Bundle + (<| (prefix "nat") + (|> (dict.new text.Hash) + (install "+" (binary nat//add)) + (install "-" (binary nat//sub)) + (install "*" (binary nat//mul)) + (install "/" (binary nat//div)) + (install "%" (binary nat//rem)) + (install "=" (binary nat//eq)) + (install "<" (binary nat//lt)) + (install "min" (nullary nat//min)) + (install "max" (nullary nat//max)) + (install "to-int" (unary nat//to-int)) + (install "char" (unary nat//char))))) + +(def: int-procs + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//eq)) + (install "<" (binary int//lt)) + (install "min" (nullary int//min)) + (install "max" (nullary int//max)) + (install "to-nat" (unary int//to-nat)) + (install "to-frac" (unary int//to-frac))))) + +(def: deg-procs + Bundle + (<| (prefix "deg") + (|> (dict.new text.Hash) + (install "+" (binary deg//add)) + (install "-" (binary deg//sub)) + (install "*" (binary deg//mul)) + (install "/" (binary deg//div)) + (install "%" (binary deg//rem)) + (install "=" (binary deg//eq)) + (install "<" (binary deg//lt)) + (install "scale" (binary deg//scale)) + (install "reciprocal" (binary deg//reciprocal)) + (install "min" (nullary deg//min)) + (install "max" (nullary deg//max)) + (install "to-frac" (unary deg//to-frac))))) + +(def: frac-procs + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//eq)) + (install "<" (binary frac//lt)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-deg" (unary frac//to-deg)) + (install "to-int" (unary frac//to-int)) + (install "encode" (unary frac//encode)) + (install "decode" (unary frac//decode))))) + +(def: text-procs + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash) + (install "=" (binary text//eq)) + (install "<" (binary text//lt)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary text//size)) + (install "hash" (unary text//hash)) + (install "replace-once" (trinary text//replace-once)) + (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary text//upper)) + (install "lower" (unary text//lower)) + ))) + +(def: array-procs + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary array//size)) + ))) + +(def: math-procs + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash) + (install "cos" (unary math//cos)) + (install "sin" (unary math//sin)) + (install "tan" (unary math//tan)) + (install "acos" (unary math//acos)) + (install "asin" (unary math//asin)) + (install "atan" (unary math//atan)) + (install "cosh" (unary math//cosh)) + (install "sinh" (unary math//sinh)) + (install "tanh" (unary math//tanh)) + (install "exp" (unary math//exp)) + (install "log" (unary math//log)) + (install "root2" (unary math//root2)) + (install "root3" (unary math//root3)) + (install "ceil" (unary math//ceil)) + (install "floor" (unary math//floor)) + (install "round" (unary math//round)) + (install "atan2" (binary math//atan2)) + (install "pow" (binary math//pow)) + ))) + +(def: io-procs + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash) + (install "log" (unary io//log)) + (install "error" (unary io//error)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary io//current-time))))) + +(def: atom-procs + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +(def: box-procs + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash) + (install "new" (unary box//new)) + (install "read" (unary box//read)) + (install "write" (binary box//write))))) + +(def: process-procs + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "future" (unary process//future)) + (install "schedule" (binary process//schedule)) + ))) + +(def: #export procedures + Bundle + (<| (prefix "lux") + (|> (dict.new text.Hash) + (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 box-procs) + (dict.merge process-procs) + ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux new file mode 100644 index 000000000..30d17cac3 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux @@ -0,0 +1,761 @@ +(.module: + lux + (lux (control [monad #+ do] + ["p" parser "parser/" Monad] + ["ex" exception #+ exception:]) + (data [product] + ["e" error] + [text "text/" Eq] + (text format + ["l" lexer]) + (coll [list "list/" Functor] + [dict #+ Dict])) + [macro "macro/" Monad] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (luxc ["&" lang] + (lang [".L" host] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst])) + ["la" analysis] + (extension (analysis ["&." host])) + ["ls" synthesis])) + (// ["@" common])) + +(exception: #export Invalid-Syntax-For-JVM-Type) +(exception: #export Invalid-Syntax-For-Argument-Generation) + +(do-template [ ] + [(def: + $.Inst + )] + + [L2S (|>> $i.L2I $i.I2S)] + [L2B (|>> $i.L2I $i.I2B)] + [L2C (|>> $i.L2I $i.I2C)] + ) + +(do-template [ ] + [(def: ( inputI) + @.Unary + (if (is $i.NOP ) + (|>> inputI + ($i.unwrap ) + ($i.wrap )) + (|>> inputI + ($i.unwrap ) + + ($i.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) + (@.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 [ ] + [(def: ( [xI yI]) + @.Binary + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + ($i.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 [ ] + [(def: ( [xI yI]) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + ( @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 [ ] + [(def: ( [xI yI]) + @.Binary + (<| $i.with-label (function [@then]) + $i.with-label (function [@end]) + (|>> xI ($i.unwrap ) + yI ($i.unwrap ) + + ($i.int ) + ($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) + (@.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) + (@.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) + (@.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) + (@.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) + (@.install "=" (@.binary char//=)) + (@.install "<" (@.binary char//<)) + ))) + +(def: (array//length arrayI) + @.Unary + (|>> arrayI + $i.ARRAYLENGTH + $i.I2L + ($i.wrap #$.Long))) + +(def: (array//new proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) + (do macro.Monad + [lengthI (translate 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)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (array//read proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] idxS arrayS)) + (do macro.Monad + [arrayI (translate arrayS) + idxI (translate 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))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (array//write proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] idxS valueS arrayS)) + (do macro.Monad + [arrayI (translate arrayS) + idxI (translate idxS) + valueI (translate 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))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: array-procs + @.Bundle + (<| (@.prefix "array") + (|> (dict.new text.Hash) + (@.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 translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)])) + (do macro.Monad + [] + (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)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (object//instance? proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] objectS)) + (do macro.Monad + [objectI (translate objectS)] + (wrap (|>> objectI + ($i.INSTANCEOF class) + ($i.wrap #$.Boolean)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: object-procs + @.Bundle + (<| (@.prefix "object") + (|> (dict.new text.Hash) + (@.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))) + +(def: (static//get proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) + (do macro.Monad + [] + (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)))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (static//put proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) + (do macro.Monad + [valueI (translate 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))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (virtual//get proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) + (do macro.Monad + [objectI (translate 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))))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: (virtual//put proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) + (do macro.Monad + [valueI (translate valueS) + objectI (translate 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))))))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(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 + [raw base-type + nesting (p.some (l.this "[]"))] + (wrap ($t.array (list.size nesting) raw)))) + +(def: (translate-type argD) + (-> Text (Meta $.Type)) + (case (l.run argD java-type) + (#e.Error error) + (&.throw Invalid-Syntax-For-JVM-Type argD) + + (#e.Success type) + (macro/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: (translate-args translate argsS) + (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis) + (Meta (List [$.Type $.Inst]))) + (case argsS + #.Nil + (macro/wrap #.Nil) + + (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail)) + (do macro.Monad + [argT (translate-type argD) + argI (:: @ map (prepare-input argT) (translate argS)) + =tail (translate-args translate tail)] + (wrap (list& [argT argI] =tail))) + + _ + (&.throw Invalid-Syntax-For-Argument-Generation ""))) + +(def: (method-return-type description) + (-> Text (Meta (Maybe $.Type))) + (case description + "void" + (macro/wrap #.None) + + _ + (macro/map (|>> #.Some) (translate-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 translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] argsS)) + (do macro.Monad + [argsTI (translate-args translate 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))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(do-template [ ] + [(def: ( proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] [_ (#.Text method)] + [_ (#.Text unboxed)] objectS argsS)) + (do macro.Monad + [objectI (translate objectS) + argsTI (translate-args translate argsS) + returnT (method-return-type unboxed) + #let [callI (|>> objectI + ($i.CHECKCAST class) + ($i.fuse (list/map product.right argsTI)) + ( class method + ($t.method (list/map product.left argsTI) returnT (list)) + ))]] + (wrap (prepare-return returnT callI))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] + + [invoke//virtual $i.INVOKEVIRTUAL false] + [invoke//special $i.INVOKESPECIAL false] + [invoke//interface $i.INVOKEINTERFACE true] + ) + +(def: (invoke//constructor proc translate inputs) + (-> Text @.Proc) + (case inputs + (^ (list& [_ (#.Text class)] argsS)) + (do macro.Monad + [argsTI (translate-args translate argsS)] + (wrap (|>> ($i.NEW class) + $i.DUP + ($i.fuse (list/map product.right argsTI)) + ($i.INVOKESPECIAL class "" + ($t.method (list/map product.left argsTI) #.None (list)) + false)))) + + _ + (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) + +(def: member-procs + @.Bundle + (<| (@.prefix "member") + (|> (dict.new text.Hash) + (dict.merge (<| (@.prefix "static") + (|> (dict.new text.Hash) + (@.install "get" static//get) + (@.install "put" static//put)))) + (dict.merge (<| (@.prefix "virtual") + (|> (dict.new text.Hash) + (@.install "get" virtual//get) + (@.install "put" virtual//put)))) + (dict.merge (<| (@.prefix "invoke") + (|> (dict.new text.Hash) + (@.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) + (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) + ))) -- cgit v1.2.3