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). --- .../luxc/lang/translation/procedure/common.jvm.lux | 809 --------------------- .../luxc/lang/translation/procedure/host.jvm.lux | 761 ------------------- 2 files changed, 1570 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux (limited to 'new-luxc/source/luxc/lang/translation/procedure') diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux deleted file mode 100644 index 84c42244e..000000000 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ /dev/null @@ -1,809 +0,0 @@ -(.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] - (translation [".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/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux deleted file mode 100644 index f737e81fc..000000000 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ /dev/null @@ -1,761 +0,0 @@ -(.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