aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux')
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux388
1 files changed, 388 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
new file mode 100644
index 000000000..383415c0a
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
@@ -0,0 +1,388 @@
+(.module:
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ [number
+ ["f" frac]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary]]]
+ [target
+ [jvm
+ ["." type]]]
+ [tool
+ [compiler
+ ["." phase]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ ["." 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 Archive s (Operation Inst))]
+ Handler))
+ (function (_ extension-name phase archive input)
+ (case (<s>.run parser input)
+ (#try.Success input')
+ (handler extension-name phase archive 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 archive [input else conditionals])
+ (<| _.with-label (function (_ @end))
+ _.with-label (function (_ @else))
+ (do {@ phase.monad}
+ [inputG (phase archive input)
+ elseG (phase archive else)
+ conditionalsG+ (: (Operation (List [(List [Int Label])
+ Inst]))
+ (monad.map @ (function (_ [chars branch])
+ (do @
+ [branchG (phase archive 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))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 00:24:32 +0000