diff options
Diffstat (limited to 'stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux | 450 |
1 files changed, 450 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux new file mode 100644 index 000000000..8bfdb9193 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux @@ -0,0 +1,450 @@ +(.module: + [lux (#- Type) + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<s>" synthesis (#+ Parser)]]] + [data + ["." product] + [number + ["." i32] + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] + [encoding + ["." signed (#+ S4)]] + ["." type (#+ Type) + [category (#+ Primitive Class)]]]]] + ["." ///// #_ + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["///" jvm #_ + ["#." value] + ["#." runtime (#+ Operation Phase Bundle Handler)] + ["#." function #_ + ["#" abstract]]]] + [extension + ["#extension" /] + ["#." bundle]] + [// + ["/#." synthesis (#+ Synthesis %synthesis)] + [/// + ["#" phase]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation (Bytecode Any)))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run parser input) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) + +(def: $Boolean (type.class "java.lang.Boolean" (list))) +(def: $Double (type.class "java.lang.Double" (list))) +(def: $Character (type.class "java.lang.Character" (list))) +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $Object (type.class "java.lang.Object" (list))) +(def: $PrintStream (type.class "java.io.PrintStream" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Error (type.class "java.lang.Error" (list))) + +(def: lux-int + (Bytecode Any) + ($_ _.compose + _.i2l + (///value.wrap type.long))) + +(def: jvm-int + (Bytecode Any) + ($_ _.compose + (///value.unwrap type.long) + _.l2i)) + +(def: ensure-string + (Bytecode Any) + (_.checkcast $String)) + +(def: (predicate bytecode) + (-> (-> Label (Bytecode Any)) + (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + (bytecode @then) + (_.getstatic $Boolean "FALSE" $Boolean) + (_.goto @end) + (_.set-label @then) + (_.getstatic $Boolean "TRUE" $Boolean) + (_.set-label @end) + ))) + +## 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 [inputS elseS conditionalsS]) + (do /////.monad + [@end ///runtime.forge-label + inputG (phase inputS) + elseG (phase elseS) + conditionalsG+ (: (Operation (List [(List [S4 Label]) + (Bytecode Any)])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch) + @branch ///runtime.forge-label] + (wrap [(list@map (function (_ char) + [(try.assume (signed.s4 (.int char))) @branch]) + chars) + ($_ _.compose + (_.set-label @branch) + branchG + (_.goto @end))]))) + conditionalsS)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + (monad.seq _.monad))]] + (wrap (do _.monad + [@else _.new-label] + ($_ _.compose + inputG (///value.unwrap type.long) _.l2i + (_.lookupswitch @else table) + conditionalsG + (_.set-label @else) + elseG + (_.set-label @end) + )))))])) + +(def: (lux::is [referenceG sampleG]) + (Binary (Bytecode Any)) + ($_ _.compose + referenceG + sampleG + (..predicate _.if-acmpeq))) + +(def: (lux::try riskyG) + (Unary (Bytecode Any)) + ($_ _.compose + riskyG + (_.checkcast ///function.class) + ///runtime.try)) + +(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)))) + +(template [<name> <op>] + [(def: (<name> [maskG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + maskG (///value.unwrap type.long) + <op> (///value.wrap type.long)))] + + [i64::and _.land] + [i64::or _.lor] + [i64::xor _.lxor] + ) + +(template [<name> <op>] + [(def: (<name> [shiftG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + shiftG ..jvm-int + <op> (///value.wrap type.long)))] + + [i64::left-shift _.lshl] + [i64::arithmetic-right-shift _.lshr] + [i64::logical-right-shift _.lushr] + ) + +(import: #long java/lang/Double + (#static MIN_VALUE double) + (#static MAX_VALUE double)) + +(template [<name> <const>] + [(def: (<name> _) + (Nullary (Bytecode Any)) + ($_ _.compose + (_.double <const>) + (///value.wrap type.double)))] + + [f64::smallest (java/lang/Double::MIN_VALUE)] + [f64::min (f.* -1.0 (java/lang/Double::MAX_VALUE))] + [f64::max (java/lang/Double::MAX_VALUE)] + ) + +(template [<name> <type> <op>] + [(def: (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <op> (///value.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> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <cmp> + <reference> + (..predicate _.if-icmpeq)))] + + [<eq> _.iconst-0] + [<lt> _.iconst-m1])] + + [i64::= i64::< type.long _.lcmp] + [f64::= f64::< type.double _.dcmpg] + ) + +(def: (to-string class from) + (-> (Type Class) (Type Primitive) (Bytecode Any)) + (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) + +(template [<name> <prepare> <transform>] + [(def: (<name> inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + <prepare> + <transform>))] + + [i64::f64 + (///value.unwrap type.long) + ($_ _.compose + _.l2d + (///value.wrap type.double))] + + [i64::char + (///value.unwrap type.long) + ($_ _.compose + _.l2i + _.i2c + (..to-string ..$Character type.char))] + + [f64::i64 + (///value.unwrap type.double) + ($_ _.compose + _.d2l + (///value.wrap type.long))] + + [f64::encode + (///value.unwrap type.double) + (..to-string ..$Double type.double)] + + [f64::decode + ..ensure-string + ///runtime.decode-frac] + ) + +(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: (text::size inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + ..ensure-string + (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) + ..lux-int)) + +(def: no-op (Bytecode Any) (_@wrap [])) + +(template [<name> <pre-subject> <pre-param> <op> <post>] + [(def: (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG <pre-subject> + paramG <pre-param> + <op> <post>))] + + [text::= ..no-op ..no-op + (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) + (///value.wrap type.boolean)] + [text::< ..ensure-string ..ensure-string + (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) + (..predicate _.iflt)] + [text::char ..ensure-string ..jvm-int + (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) + ..lux-int] + ) + +(def: (text::concat [leftG rightG]) + (Binary (Bytecode Any)) + ($_ _.compose + leftG ..ensure-string + rightG ..ensure-string + (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) + +(def: (text::clip [startG endG subjectG]) + (Trinary (Bytecode Any)) + ($_ _.compose + subjectG ..ensure-string + startG ..jvm-int + endG ..jvm-int + (_.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 [startG partG textG]) + (Trinary (Bytecode Any)) + (do _.monad + [@not-found _.new-label + @end _.new-label] + ($_ _.compose + textG ..ensure-string + partG ..ensure-string + startG ..jvm-int + (_.invokevirtual ..$String "indexOf" index-method) + _.dup + _.iconst-m1 + (_.if-icmpeq @not-found) + ..lux-int + ///runtime.some-injection + (_.goto @end) + (_.set-label @not-found) + _.pop + ///runtime.none-injection + (_.set-label @end)))) + +(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: string-method (type.method [(list ..$String) type.void (list)])) +(def: (io::log messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.getstatic ..$System "out" ..$PrintStream) + messageG + ..ensure-string + (_.invokevirtual ..$PrintStream "println" ..string-method) + ///runtime.unit)) + +(def: (io::error messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.new ..$Error) + _.dup + messageG + ..ensure-string + (_.invokespecial ..$Error "<init>" ..string-method) + _.athrow)) + +(def: exit-method (type.method [(list type.int) type.void (list)])) +(def: (io::exit codeG) + (Unary (Bytecode Any)) + ($_ _.compose + codeG ..jvm-int + (_.invokestatic ..$System "exit" ..exit-method) + _.aconst-null)) + +(def: time-method (type.method [(list) type.long (list)])) +(def: (io::current-time _) + (Nullary (Bytecode Any)) + ($_ _.compose + (_.invokestatic ..$System "currentTimeMillis" ..time-method) + (///value.wrap type.long))) + +(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)))) |