1 files changed, 245 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux
new file mode 100644
index 000000000..1c55abf83
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux
@@ -0,0 +1,245 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["e" error]
+    ["." product]
+    ["." text
+     format]
+    [number (#+ hex)]
+    [collection
+     ["." list ("#/." functor)]
+     ["dict" dictionary (#+ Dictionary)]]]
+   ["." macro (#+ with-gensyms)
+    ["." code]
+    ["s" syntax (#+ syntax:)]]
+   [host (#+ import:)]]
+  [///
+   ["." runtime (#+ Operation Phase Handler Bundle)]
+   ["//." ///
+    ["." synthesis (#+ Synthesis)]
+    ["." extension
+     ["." bundle]]
+    [///
+     [host
+      ["_" scheme (#+ Expression Computation)]]]]])
+
+(syntax: (Vector {size s.nat} elemT)
+  (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export Nullary (-> (Vector 0 Expression) Computation))
+(type: #export Unary   (-> (Vector 1 Expression) Computation))
+(type: #export Binary  (-> (Vector 2 Expression) Computation))
+(type: #export Trinary (-> (Vector 3 Expression) Computation))
+(type: #export Variadic (-> (List Expression) Computation))
+
+(syntax: (arity: {name s.local-identifier} {arity s.nat})
+  (with-gensyms [g!_ g!extension g!name g!phase g!inputs]
+    (do @
+      [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
+      (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
+                       (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation)
+                           Handler)
+                       (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs))
+                         (case (~ g!inputs)
+                           (^ (list (~+ g!input+)))
+                           (do /////.monad
+                             [(~+ (|> g!input+
+                                      (list/map (function (_ g!input)
+                                                  (list g!input (` ((~ g!phase) (~ g!input))))))
+                                      list.concat))]
+                             ((~' wrap) ((~ g!extension) [(~+ g!input+)])))
+
+                           (~' _)
+                           (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))]))))))))))
+
+(arity: nullary 0)
+(arity: unary 1)
+(arity: binary 2)
+(arity: trinary 3)
+
+(def: #export (variadic extension)
+  (-> Variadic Handler)
+  (function (_ extension-name)
+    (function (_ phase inputsS)
+      (do /////.monad
+        [inputsI (monad.map @ phase inputsS)]
+        (wrap (extension inputsI))))))
+
+(def: bundle::lux
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is?" (binary (product.uncurry _.eq?/2)))
+      (bundle.install "try" (unary runtime.lux//try))))
+
+(do-template [<name> <op>]
+  [(def: (<name> [subjectO paramO])
+     Binary
+     (<op> paramO subjectO))]
+  
+  [bit::and _.bit-and/2]
+  [bit::or  _.bit-or/2]
+  [bit::xor _.bit-xor/2]
+  )
+
+(def: (bit::left-shift [subjectO paramO])
+  Binary
+  (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO)
+                        subjectO))
+
+(def: (bit::arithmetic-right-shift [subjectO paramO])
+  Binary
+  (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1)))
+                        subjectO))
+
+(def: (bit::logical-right-shift [subjectO paramO])
+  Binary
+  (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
+
+(def: bundle::bit
+  Bundle
+  (<| (bundle.prefix "bit")
+      (|> bundle.empty
+          (bundle.install "and" (binary bit::and))
+          (bundle.install "or" (binary bit::or))
+          (bundle.install "xor" (binary bit::xor))
+          (bundle.install "left-shift" (binary bit::left-shift))
+          (bundle.install "logical-right-shift" (binary bit::logical-right-shift))
+          (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift))
+          )))
+
+(import: java/lang/Double
+  (#static MIN_VALUE Double)
+  (#static MAX_VALUE Double))
+
+(do-template [<name> <const> <encode>]
+  [(def: (<name> _)
+     Nullary
+     (<encode> <const>))]
+
+  [frac::smallest (Double::MIN_VALUE)            _.float]
+  [frac::min      (f/* -1.0 (Double::MAX_VALUE)) _.float]
+  [frac::max      (Double::MAX_VALUE)            _.float]
+  )
+
+(do-template [<name> <op>]
+  [(def: (<name> [subjectO paramO])
+     Binary
+     (|> subjectO (<op> paramO)))]
+
+  [int::+ _.+/2]
+  [int::- _.-/2]
+  [int::* _.*/2]
+  [int::/ _.quotient/2]
+  [int::% _.remainder/2]
+  )
+
+(do-template [<name> <op>]
+  [(def: (<name> [subjectO paramO])
+     Binary
+     (<op> paramO subjectO))]
+
+  [frac::+ _.+/2]
+  [frac::- _.-/2]
+  [frac::* _.*/2]
+  [frac::/ _.//2]
+  [frac::% _.mod/2]
+  [frac::= _.=/2]
+  [frac::< _.</2]
+
+  [text::= _.string=?/2]
+  [text::< _.string<?/2]
+  )
+
+(do-template [<name> <cmp>]
+  [(def: (<name> [subjectO paramO])
+     Binary
+     (<cmp> paramO subjectO))]
+
+  [int::= _.=/2]
+  [int::< _.</2]
+  )
+
+(def: int::char (|>> _.integer->char/1 _.string/1))
+
+(def: bundle::int
+  Bundle
+  (<| (bundle.prefix "int")
+      (|> bundle.empty
+          (bundle.install "+" (binary int::+))
+          (bundle.install "-" (binary int::-))
+          (bundle.install "*" (binary int::*))
+          (bundle.install "/" (binary int::/))
+          (bundle.install "%" (binary int::%))
+          (bundle.install "=" (binary int::=))
+          (bundle.install "<" (binary int::<))
+          (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0)))))
+          (bundle.install "char" (unary int::char)))))
+
+(def: bundle::frac
+  Bundle
+  (<| (bundle.prefix "frac")
+      (|> bundle.empty
+          (bundle.install "+" (binary frac::+))
+          (bundle.install "-" (binary frac::-))
+          (bundle.install "*" (binary frac::*))
+          (bundle.install "/" (binary frac::/))
+          (bundle.install "%" (binary frac::%))
+          (bundle.install "=" (binary frac::=))
+          (bundle.install "<" (binary frac::<))
+          (bundle.install "smallest" (nullary frac::smallest))
+          (bundle.install "min" (nullary frac::min))
+          (bundle.install "max" (nullary frac::max))
+          (bundle.install "to-int" (unary _.exact/1))
+          (bundle.install "encode" (unary _.number->string/1))
+          (bundle.install "decode" (unary runtime.frac//decode)))))
+
+(def: (text::char [subjectO paramO])
+  Binary
+  (_.string/1 (_.string-ref/2 subjectO paramO)))
+
+(def: (text::clip [subjectO startO endO])
+  Trinary
+  (_.substring/3 subjectO startO endO))
+
+(def: bundle::text
+  Bundle
+  (<| (bundle.prefix "text")
+      (|> bundle.empty
+          (bundle.install "=" (binary text::=))
+          (bundle.install "<" (binary text::<))
+          (bundle.install "concat" (binary (product.uncurry _.string-append/2)))
+          (bundle.install "size" (unary _.string-length/1))
+          (bundle.install "char" (binary text::char))
+          (bundle.install "clip" (trinary text::clip)))))
+
+(def: (io::log input)
+  Unary
+  (_.begin (list (_.display/1 input)
+                 _.newline/0)))
+
+(def: (void code)
+  (-> Expression Computation)
+  (_.begin (list code (_.string synthesis.unit))))
+
+(def: bundle::io
+  Bundle
+  (<| (bundle.prefix "io")
+      (|> bundle.empty
+          (bundle.install "log" (unary (|>> io::log ..void)))
+          (bundle.install "error" (unary _.raise/1))
+          (bundle.install "exit" (unary _.exit/1))
+          (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit))))))))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "lux")
+      (|> bundle::lux
+          (dict.merge bundle::bit)
+          (dict.merge bundle::int)
+          (dict.merge bundle::frac)
+          (dict.merge bundle::text)
+          (dict.merge bundle::io)
+          )))