diff options
author | Eduardo Julian | 2019-09-17 21:51:05 -0400 |
---|---|---|
committer | Eduardo Julian | 2019-09-17 21:51:05 -0400 |
commit | f0a95ee657fef968df1f5f88dc741256e1153e63 (patch) | |
tree | 539e0d1b8b70f8eba4e2905e1ba8da00fc7e3bf5 /new-luxc/source/luxc/lang/translation/jvm/extension/common.lux | |
parent | 4049370ec0d0bec578b8fcb83700d020e81386c4 (diff) |
Some refactoring.
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/extension/common.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/extension/common.lux | 385 |
1 files changed, 385 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux new file mode 100644 index 000000000..a46813232 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/extension/common.lux @@ -0,0 +1,385 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["<>" parser + ["<s>" synthesis (#+ Parser)]] + ["ex" exception (#+ exception:)]] + [data + ["." product] + [number + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["." type + ["." signature]]]] + [tool + [compiler + ["." synthesis (#+ Synthesis %synthesis)] + ["." phase + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + ["." extension + ["." bundle]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) + ["_" inst]]]]] + ["." /// + ["." runtime]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Object (type.class "java.lang.Object" (list))) + +(def: lux-intI Inst (|>> _.I2L (_.wrap type.long))) +(def: jvm-intI Inst (|>> (_.unwrap type.long) _.L2I)) +(def: check-stringI Inst (_.CHECKCAST $String)) + +(def: (predicateI tester) + (-> (-> Label Inst) + Inst) + (let [$Boolean (type.class "java.lang.Boolean" (list))] + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> (tester @then) + (_.GETSTATIC $Boolean "FALSE" $Boolean) + (_.GOTO @end) + (_.label @then) + (_.GETSTATIC $Boolean "TRUE" $Boolean) + (_.label @end) + )))) + +(def: unitI Inst (_.string synthesis.unit)) + +## TODO: Get rid of this ASAP +(def: lux::syntax-char-case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension-name phase [input else conditionals]) + (<| _.with-label (function (_ @end)) + _.with-label (function (_ @else)) + (do phase.monad + [inputG (phase input) + elseG (phase else) + conditionalsG+ (: (Operation (List [(List [Int Label]) + Inst])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch)] + (wrap (<| _.with-label (function (_ @branch)) + [(list@map (function (_ char) + [(.int char) @branch]) + chars) + (|>> (_.label @branch) + branchG + (_.GOTO @end))])))) + conditionals)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + _.fuse)]] + (wrap (|>> inputG (_.unwrap type.long) _.L2I + (_.LOOKUPSWITCH @else table) + conditionalsG + (_.label @else) + elseG + (_.label @end) + )))))])) + +(def: (lux::is [referenceI sampleI]) + (Binary Inst) + (|>> referenceI + sampleI + (predicateI _.IF_ACMPEQ))) + +(def: (lux::try riskyI) + (Unary Inst) + (|>> riskyI + (_.CHECKCAST ///.$Function) + (_.INVOKESTATIC ///.$Runtime "try" runtime.try))) + +(template [<name> <op>] + [(def: (<name> [maskI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + maskI (_.unwrap type.long) + <op> (_.wrap type.long)))] + + [i64::and _.LAND] + [i64::or _.LOR] + [i64::xor _.LXOR] + ) + +(template [<name> <op>] + [(def: (<name> [shiftI inputI]) + (Binary Inst) + (|>> inputI (_.unwrap type.long) + shiftI jvm-intI + <op> + (_.wrap type.long)))] + + [i64::left-shift _.LSHL] + [i64::arithmetic-right-shift _.LSHR] + [i64::logical-right-shift _.LUSHR] + ) + +(template [<name> <const> <type>] + [(def: (<name> _) + (Nullary Inst) + (|>> <const> (_.wrap <type>)))] + + [f64::smallest (_.double (Double::MIN_VALUE)) type.double] + [f64::min (_.double (f.* -1.0 (Double::MAX_VALUE))) type.double] + [f64::max (_.double (Double::MAX_VALUE)) type.double] + ) + +(template [<name> <type> <op>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) + <op> + (_.wrap <type>)))] + + [i64::+ type.long _.LADD] + [i64::- type.long _.LSUB] + [i64::* type.long _.LMUL] + [i64::/ type.long _.LDIV] + [i64::% type.long _.LREM] + + [f64::+ type.double _.DADD] + [f64::- type.double _.DSUB] + [f64::* type.double _.DMUL] + [f64::/ type.double _.DDIV] + [f64::% type.double _.DREM] + ) + +(template [<eq> <lt> <type> <cmp>] + [(template [<name> <reference>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI (_.unwrap <type>) + paramI (_.unwrap <type>) + <cmp> + (_.int <reference>) + (predicateI _.IF_ICMPEQ)))] + + [<eq> +0] + [<lt> -1])] + + [i64::= i64::< type.long _.LCMP] + [f64::= f64::< type.double _.DCMPG] + ) + +(template [<name> <prepare> <transform>] + [(def: (<name> inputI) + (Unary Inst) + (|>> inputI <prepare> <transform>))] + + [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)] + [i64::char (_.unwrap type.long) + ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list type.char) $String (list)]))))] + + [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)] + [f64::encode (_.unwrap type.double) + (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list type.double) $String (list)]))] + [f64::decode ..check-stringI + (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list $String) ///.$Variant (list)]))] + ) + +(def: (text::size inputI) + (Unary Inst) + (|>> inputI + ..check-stringI + (_.INVOKEVIRTUAL $String "length" (type.method [(list) type.int (list)])) + lux-intI)) + +(template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [paramI subjectI]) + (Binary Inst) + (|>> subjectI <pre-subject> + paramI <pre-param> + <op> <post>))] + + [text::= (<|) (<|) + (_.INVOKEVIRTUAL $Object "equals" (type.method [(list $Object) type.boolean (list)])) + (_.wrap type.boolean)] + [text::< ..check-stringI ..check-stringI + (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list $String) type.int (list)])) + (predicateI _.IFLT)] + [text::char ..check-stringI jvm-intI + (_.INVOKEVIRTUAL $String "charAt" (type.method [(list type.int) type.char (list)])) + lux-intI] + ) + +(def: (text::concat [leftI rightI]) + (Binary Inst) + (|>> leftI ..check-stringI + rightI ..check-stringI + (_.INVOKEVIRTUAL $String "concat" (type.method [(list $String) $String (list)])))) + +(def: (text::clip [startI endI subjectI]) + (Trinary Inst) + (|>> subjectI ..check-stringI + startI jvm-intI + endI jvm-intI + (_.INVOKEVIRTUAL $String "substring" (type.method [(list type.int type.int) $String (list)])))) + +(def: index-method (type.method [(list $String type.int) type.int (list)])) +(def: (text::index [startI partI textI]) + (Trinary Inst) + (<| _.with-label (function (_ @not-found)) + _.with-label (function (_ @end)) + (|>> textI ..check-stringI + partI ..check-stringI + startI jvm-intI + (_.INVOKEVIRTUAL $String "indexOf" index-method) + _.DUP + (_.int -1) + (_.IF_ICMPEQ @not-found) + lux-intI + runtime.someI + (_.GOTO @end) + (_.label @not-found) + _.POP + runtime.noneI + (_.label @end)))) + +(def: string-method (type.method [(list $String) type.void (list)])) +(def: (io::log messageI) + (Unary Inst) + (let [$PrintStream (type.class "java.io.PrintStream" (list))] + (|>> (_.GETSTATIC $System "out" $PrintStream) + messageI + ..check-stringI + (_.INVOKEVIRTUAL $PrintStream "println" string-method) + unitI))) + +(def: (io::error messageI) + (Unary Inst) + (let [$Error (type.class "java.lang.Error" (list))] + (|>> (_.NEW $Error) + _.DUP + messageI + ..check-stringI + (_.INVOKESPECIAL $Error "<init>" string-method) + _.ATHROW))) + +(def: (io::exit codeI) + (Unary Inst) + (|>> codeI jvm-intI + (_.INVOKESTATIC $System "exit" (type.method [(list type.int) type.void (list)])) + _.NULL)) + +(def: (io::current-time _) + (Nullary Inst) + (|>> (_.INVOKESTATIC $System "currentTimeMillis" (type.method [(list) type.long (list)])) + (_.wrap type.long))) + +(def: bundle::lux + Bundle + (|> (: Bundle bundle.empty) + (bundle.install "syntax char case!" lux::syntax-char-case!) + (bundle.install "is" (binary lux::is)) + (bundle.install "try" (unary lux::try)))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> (: Bundle bundle.empty) + (bundle.install "and" (binary i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left-shift)) + (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "f64" (unary i64::f64)) + (bundle.install "char" (unary i64::char))))) + +(def: bundle::f64 + Bundle + (<| (bundle.prefix "f64") + (|> (: Bundle bundle.empty) + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "smallest" (nullary f64::smallest)) + (bundle.install "min" (nullary f64::min)) + (bundle.install "max" (nullary f64::max)) + (bundle.install "i64" (unary f64::i64)) + (bundle.install "encode" (unary f64::encode)) + (bundle.install "decode" (unary f64::decode))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary text::concat)) + (bundle.install "index" (trinary text::index)) + (bundle.install "size" (unary text::size)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> (: Bundle bundle.empty) + (bundle.install "log" (unary io::log)) + (bundle.install "error" (unary io::error)) + (bundle.install "exit" (unary io::exit)) + (bundle.install "current-time" (nullary io::current-time))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge bundle::i64) + (dictionary.merge bundle::f64) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io)))) |