Re-named "lux/platform" to "lux/tool".

11 files changed, 1068 insertions, 0 deletions

diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux
new file mode 100644
index 000000000..92b55cb80
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux
@@ -0,0 +1,177 @@
+(.module:
+  [lux (#- case let if)
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." number]
+    ["." text
+     format]
+    [collection
+     ["." list ("#/." functor fold)]
+     [set (#+ Set)]]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." reference]
+   ["/." /// ("#/." monad)
+    ["." synthesis (#+ Synthesis Path)]
+    [//
+     [reference (#+ Register)]
+     [//
+      [host
+       ["_" scheme (#+ Expression Computation Var)]]]]]])
+
+(def: #export (let translate [valueS register bodyS])
+  (-> Phase [Synthesis Register Synthesis]
+      (Operation Computation))
+  (do ////.monad
+    [valueO (translate valueS)
+     bodyO (translate bodyS)]
+    (wrap (_.let (list [(reference.local' register) valueO])
+            bodyO))))
+
+(def: #export (record-get translate valueS pathP)
+  (-> Phase Synthesis (List [Nat Bit])
+      (Operation Expression))
+  (do ////.monad
+    [valueO (translate valueS)]
+    (wrap (list/fold (function (_ [idx tail?] source)
+                       (.let [method (.if tail?
+                                       runtime.product//right
+                                       runtime.product//left)]
+                         (method source (_.int (:coerce Int idx)))))
+                     valueO
+                     pathP))))
+
+(def: #export (if translate [testS thenS elseS])
+  (-> Phase [Synthesis Synthesis Synthesis]
+      (Operation Computation))
+  (do ////.monad
+    [testO (translate testS)
+     thenO (translate thenS)
+     elseO (translate elseS)]
+    (wrap (_.if testO thenO elseO))))
+
+(def: @savepoint (_.var "lux_pm_cursor_savepoint"))
+
+(def: @cursor (_.var "lux_pm_cursor"))
+
+(def: top _.length/1)
+
+(def: (push! value var)
+  (-> Expression Var Computation)
+  (_.set! var (_.cons/2 value var)))
+
+(def: (pop! var)
+  (-> Var Computation)
+  (_.set! var var))
+
+(def: (push-cursor! value)
+  (-> Expression Computation)
+  (push! value @cursor))
+
+(def: save-cursor!
+  Computation
+  (push! @cursor @savepoint))
+
+(def: restore-cursor!
+  Computation
+  (_.set! @cursor (_.car/1 @savepoint)))
+
+(def: cursor-top
+  Computation
+  (_.car/1 @cursor))
+
+(def: pop-cursor!
+  Computation
+  (pop! @cursor))
+
+(def: pm-error (_.string "PM-ERROR"))
+
+(def: fail-pm! (_.raise/1 pm-error))
+
+(def: @temp (_.var "lux_pm_temp"))
+
+(exception: #export (unrecognized-path)
+  "")
+
+(def: $alt_error (_.var "alt_error"))
+
+(def: (pm-catch handler)
+  (-> Expression Computation)
+  (_.lambda [(list $alt_error) #.None]
+       (_.if (|> $alt_error (_.eqv?/2 pm-error))
+         handler
+         (_.raise/1 $alt_error))))
+
+(def: (pattern-matching' translate pathP)
+  (-> Phase Path (Operation Expression))
+  (.case pathP
+    (^ (synthesis.path/then bodyS))
+    (translate bodyS)
+
+    #synthesis.Pop
+    (/////wrap pop-cursor!)
+
+    (#synthesis.Bind register)
+    (/////wrap (_.define (reference.local' register) [(list) #.None]
+                         cursor-top))
+
+    (^template [<tag> <format> <=>]
+      (^ (<tag> value))
+      (/////wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
+                         fail-pm!)))
+    ([synthesis.path/bit  _.bool          _.eqv?/2]
+     [synthesis.path/i64  (<| _.int .int) _.=/2]
+     [synthesis.path/f64  _.float         _.=/2]
+     [synthesis.path/text _.string        _.eqv?/2])
+
+    (^template [<pm> <flag> <prep>]
+      (^ (<pm> idx))
+      (/////wrap (_.let (list [@temp (|> idx <prep> .int _.int (runtime.sum//get cursor-top <flag>))])
+                   (_.if (_.null?/1 @temp)
+                     fail-pm!
+                     (push-cursor! @temp)))))
+    ([synthesis.side/left  _.nil         (<|)]
+     [synthesis.side/right (_.string "") inc])
+
+    (^template [<pm> <getter> <prep>]
+      (^ (<pm> idx))
+      (/////wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!)))
+    ([synthesis.member/left  runtime.product//left  (<|)]
+     [synthesis.member/right runtime.product//right inc])
+
+    (^template [<tag> <computation>]
+      (^ (<tag> leftP rightP))
+      (do ////.monad
+        [leftO (pattern-matching' translate leftP)
+         rightO (pattern-matching' translate rightP)]
+        (wrap <computation>)))
+    ([synthesis.path/seq (_.begin (list leftO
+                                        rightO))]
+     [synthesis.path/alt (_.with-exception-handler
+                           (pm-catch (_.begin (list restore-cursor!
+                                                    rightO)))
+                           (_.lambda [(list) #.None]
+                                (_.begin (list save-cursor!
+                                               leftO))))])
+    
+    _
+    (////.throw unrecognized-path [])))
+
+(def: (pattern-matching translate pathP)
+  (-> Phase Path (Operation Computation))
+  (do ////.monad
+    [pattern-matching! (pattern-matching' translate pathP)]
+    (wrap (_.with-exception-handler
+            (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching.")))
+            (_.lambda [(list) #.None]
+                 pattern-matching!)))))
+
+(def: #export (case translate [valueS pathP])
+  (-> Phase [Synthesis Path] (Operation Computation))
+  (do ////.monad
+    [valueO (translate valueS)]
+    (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))]
+                               [@savepoint (_.list/* (list))])))
+        (pattern-matching translate pathP))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux
new file mode 100644
index 000000000..53d7bbbcb
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux
@@ -0,0 +1,59 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]]]
+  [//
+   [runtime (#+ Phase)]
+   ["." primitive]
+   ["." structure]
+   ["." reference]
+   ["." function]
+   ["." case]
+   ["." loop]
+   ["." ///
+    ["." synthesis]
+    ["." extension]]])
+
+(def: #export (translate synthesis)
+  Phase
+  (case synthesis
+    (^template [<tag> <generator>]
+      (^ (<tag> value))
+      (<generator> value))
+    ([synthesis.bit  primitive.bit]
+     [synthesis.i64  primitive.i64]
+     [synthesis.f64  primitive.f64]
+     [synthesis.text primitive.text])
+
+    (^ (synthesis.variant variantS))
+    (structure.variant translate variantS)
+
+    (^ (synthesis.tuple members))
+    (structure.tuple translate members)
+
+    (#synthesis.Reference reference)
+    (reference.reference reference)
+
+    (^ (synthesis.branch/case case))
+    (case.case translate case)
+
+    (^ (synthesis.branch/let let))
+    (case.let translate let)
+
+    (^ (synthesis.branch/if if))
+    (case.if translate if)
+
+    (^ (synthesis.loop/scope scope))
+    (loop.scope translate scope)
+
+    (^ (synthesis.loop/recur updates))
+    (loop.recur translate updates)
+
+    (^ (synthesis.function/abstraction abstraction))
+    (function.function translate abstraction)
+
+    (^ (synthesis.function/apply application))
+    (function.apply translate application)
+
+    (#synthesis.Extension extension)
+    (extension.apply translate extension)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux
new file mode 100644
index 000000000..a40b4953f
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux
@@ -0,0 +1,15 @@
+(.module:
+  [lux #*
+   [data
+    [collection
+     ["." dictionary]]]]
+  [//
+   [runtime (#+ Bundle)]]
+  [/
+   ["." common]
+   ["." host]])
+
+(def: #export bundle
+  Bundle
+  (|> common.bundle
+      (dictionary.merge host.bundle)))
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)
+          )))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux
new file mode 100644
index 000000000..b8b2b7612
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux
@@ -0,0 +1,11 @@
+(.module:
+  [lux #*]
+  [///
+   [runtime (#+ Bundle)]
+   [///
+    [extension
+     ["." bundle]]]])
+
+(def: #export bundle
+  Bundle
+  bundle.empty)
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux
new file mode 100644
index 000000000..fe08b6a50
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux
@@ -0,0 +1,92 @@
+(.module:
+  [lux (#- function)
+   [control
+    ["." monad (#+ do)]
+    pipe]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("#/." functor)]]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." reference]
+   ["/." //
+    ["//." // ("#/." monad)
+     [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
+     [synthesis (#+ Synthesis)]
+     [//
+      [reference (#+ Register Variable)]
+      ["." name]
+      [//
+       [host
+        ["_" scheme (#+ Expression Computation Var)]]]]]]])
+
+(def: #export (apply translate [functionS argsS+])
+  (-> Phase (Application Synthesis) (Operation Computation))
+  (do ////.monad
+    [functionO (translate functionS)
+     argsO+ (monad.map @ translate argsS+)]
+    (wrap (_.apply/* functionO argsO+))))
+
+(def: (with-closure function-name inits function-definition)
+  (-> Text (List Expression) Computation (Operation Computation))
+  (let [@closure (_.var (format function-name "___CLOSURE"))]
+    (/////wrap
+     (case inits
+       #.Nil
+       function-definition
+
+       _
+       (_.letrec (list [@closure
+                        (_.lambda [(|> (list.enumerate inits)
+                                  (list/map (|>> product.left reference.foreign')))
+                              #.None]
+                             function-definition)])
+                 (_.apply/* @closure inits))))))
+
+(def: @curried (_.var "curried"))
+(def: @missing (_.var "missing"))
+
+(def: input
+  (|>> inc reference.local'))
+
+(def: #export (function translate [environment arity bodyS])
+  (-> Phase (Abstraction Synthesis) (Operation Computation))
+  (do ////.monad
+    [[function-name bodyO] (///.with-context
+                             (do @
+                               [function-name ///.context]
+                               (///.with-anchor (_.var function-name)
+                                 (translate bodyS))))
+     closureO+ (monad.map @ reference.variable environment)
+     #let [arityO (|> arity .int _.int)
+           @num-args (_.var "num_args")
+           @function (_.var function-name)
+           apply-poly (.function (_ args func)
+                        (_.apply/2 (_.global "apply") func args))]]
+    (with-closure function-name closureO+
+      (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)]
+                                      (_.let (list [@num-args (_.length/1 @curried)])
+                                        (<| (_.if (|> @num-args (_.=/2 arityO))
+                                              (<| (_.let (list [(reference.local' 0) @function]))
+                                                  (_.let-values (list [[(|> (list.indices arity)
+                                                                            (list/map ..input))
+                                                                        #.None]
+                                                                       (_.apply/2 (_.global "apply") (_.global "values") @curried)]))
+                                                  bodyO))
+                                            (_.if (|> @num-args (_.>/2 arityO))
+                                              (let [arity-args (runtime.slice (_.int +0) arityO @curried)
+                                                    output-func-args (runtime.slice arityO
+                                                                                    (|> @num-args (_.-/2 arityO))
+                                                                                    @curried)]
+                                                (|> @function
+                                                    (apply-poly arity-args)
+                                                    (apply-poly output-func-args))))
+                                            ## (|> @num-args (_.</2 arityO))
+                                            (_.lambda [(list) (#.Some @missing)]
+                                                 (|> @function
+                                                     (apply-poly (_.append/2 @curried @missing)))))))])
+                @function))
+    ))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux
new file mode 100644
index 000000000..0d85654c1
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux
@@ -0,0 +1,41 @@
+(.module:
+  [lux (#- Scope)
+   [control
+    ["." monad (#+ do)]]
+   [data
+    ["." product]
+    ["." text
+     format]
+    [collection
+     ["." list ("#/." functor)]]]]
+  [//
+   [runtime (#+ Operation Phase)]
+   ["." reference]
+   ["/." //
+    ["//." //
+     [synthesis (#+ Scope Synthesis)]
+     [///
+      [host
+       ["_" scheme (#+ Computation Var)]]]]]])
+
+(def: @scope (_.var "scope"))
+
+(def: #export (scope translate [start initsS+ bodyS])
+  (-> Phase (Scope Synthesis) (Operation Computation))
+  (do ////.monad
+    [initsO+ (monad.map @ translate initsS+)
+     bodyO (///.with-anchor @scope
+             (translate bodyS))]
+    (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+
+                                            list.enumerate
+                                            (list/map (|>> product.left (n/+ start) reference.local')))
+                                        #.None]
+                                       bodyO)])
+                    (_.apply/* @scope initsO+)))))
+
+(def: #export (recur translate argsS+)
+  (-> Phase (List Synthesis) (Operation Computation))
+  (do ////.monad
+    [@scope ///.anchor
+     argsO+ (monad.map @ translate argsS+)]
+    (wrap (_.apply/* @scope argsO+))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
new file mode 100644
index 000000000..dc643bcbc
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
@@ -0,0 +1,25 @@
+(.module:
+  [lux (#- i64)]
+  [//
+   [runtime (#+ Operation)]
+   [// (#+ State)
+    ["//." // ("#/." monad)
+     [///
+      [host
+       ["_" scheme (#+ Expression)]]]]]])
+
+(def: #export bit
+  (-> Bit (Operation Expression))
+  (|>> _.bool /////wrap))
+
+(def: #export i64
+  (-> (I64 Any) (Operation Expression))
+  (|>> .int _.int /////wrap))
+
+(def: #export f64
+  (-> Frac (Operation Expression))
+  (|>> _.float /////wrap))
+
+(def: #export text
+  (-> Text (Operation Expression))
+  (|>> _.string /////wrap))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux
new file mode 100644
index 000000000..161d2adea
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux
@@ -0,0 +1,48 @@
+(.module:
+  [lux #*
+   [control
+    pipe]
+   [data
+    [text
+     format]]]
+  [//
+   [runtime (#+ Operation)]
+   ["/." //
+    ["//." // ("#/." monad)
+     [analysis (#+ Variant Tuple)]
+     [synthesis (#+ Synthesis)]
+     [//
+      ["." reference (#+ Register Variable Reference)]
+      [//
+       [host
+        ["_" scheme (#+ Expression Global Var)]]]]]]])
+
+(do-template [<name> <prefix>]
+  [(def: #export <name>
+     (-> Register Var)
+     (|>> .int %i (format <prefix>) _.var))]
+
+  [local'   "l"]
+  [foreign' "f"]
+  )
+
+(def: #export variable
+  (-> Variable (Operation Var))
+  (|>> (case> (#reference.Local register)
+              (local' register)
+              
+              (#reference.Foreign register)
+              (foreign' register))
+       /////wrap))
+
+(def: #export constant
+  (-> Name (Operation Global))
+  (|>> ///.remember (/////map _.global)))
+
+(def: #export reference
+  (-> Reference (Operation Expression))
+  (|>> (case> (#reference.Constant value)
+              (..constant value)
+              
+              (#reference.Variable value)
+              (..variable value))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux
new file mode 100644
index 000000000..d254e8c7d
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux
@@ -0,0 +1,322 @@
+(.module:
+  [lux #*
+   [control
+    ["p" parser ("#/." monad)]
+    [monad (#+ do)]]
+   [data
+    [number (#+ hex)]
+    [text
+     format]
+    [collection
+     ["." list ("#/." monad)]]]
+   ["." function]
+   [macro
+    ["." code]
+    ["s" syntax (#+ syntax:)]]]
+  ["." ///
+   ["//." //
+    [analysis (#+ Variant)]
+    ["." synthesis]
+    [//
+     ["." name]
+     [//
+      [host
+       ["_" scheme (#+ Expression Computation Var)]]]]]])
+
+(do-template [<name> <base>]
+  [(type: #export <name>
+     (<base> Var Expression Expression))]
+
+  [Operation ///.Operation]
+  [Phase ///.Phase]
+  [Handler ///.Handler]
+  [Bundle ///.Bundle]
+  )
+
+(def: prefix Text "LuxRuntime")
+
+(def: unit (_.string synthesis.unit))
+
+(def: #export variant-tag "lux-variant")
+
+(def: (flag value)
+  (-> Bit Computation)
+  (if value
+    (_.string "")
+    _.nil))
+
+(def: (variant' tag last? value)
+  (-> Expression Expression Expression Computation)
+  (<| (_.cons/2 (_.symbol ..variant-tag))
+      (_.cons/2 tag)
+      (_.cons/2 last?)
+      value))
+
+(def: #export (variant [lefts right? value])
+  (-> (Variant Expression) Computation)
+  (variant' (_.int (.int lefts)) (flag right?) value))
+
+(def: #export none
+  Computation
+  (variant [0 #0 ..unit]))
+
+(def: #export some
+  (-> Expression Computation)
+  (|>> [0 #1] ..variant))
+
+(def: #export left
+  (-> Expression Computation)
+  (|>> [0 #0] ..variant))
+
+(def: #export right
+  (-> Expression Computation)
+  (|>> [0 #1] ..variant))
+
+(def: declaration
+  (s.Syntax [Text (List Text)])
+  (p.either (p.and s.local-identifier (p/wrap (list)))
+            (s.form (p.and s.local-identifier (p.some s.local-identifier)))))
+
+(syntax: (runtime: {[name args] declaration}
+           definition)
+  (let [implementation (code.local-identifier (format "@@" name))
+        runtime (format prefix "__" (name.normalize name))
+        @runtime (` (_.var (~ (code.text runtime))))
+        argsC+ (list/map code.local-identifier args)
+        argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`))
+                          args)
+        declaration (` ((~ (code.local-identifier name))
+                        (~+ argsC+)))
+        type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression)))
+                    _.Computation))]
+    (wrap (list (` (def: (~' #export) (~ declaration)
+                     (~ type)
+                     (~ (case argsC+
+                          #.Nil
+                          @runtime
+
+                          _
+                          (` (_.apply/* (~ @runtime) (list (~+ argsC+))))))))
+                (` (def: (~ implementation)
+                     _.Computation
+                     (~ (case argsC+
+                          #.Nil
+                          (` (_.define (~ @runtime) [(list) #.None] (~ definition)))
+
+                          _
+                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
+                                           (list/map (function (_ [left right])
+                                                       (list left right)))
+                                           list/join))]
+                               (_.define (~ @runtime) [(list (~+ argsLC+)) #.None]
+                                         (~ definition))))))))))))
+
+(runtime: (slice offset length list)
+  (<| (_.if (_.null?/1 list)
+        list)
+      (_.if (|> offset (_.>/2 (_.int +0)))
+        (slice (|> offset (_.-/2 (_.int +1)))
+               length
+               (_.cdr/1 list)))
+      (_.if (|> length (_.>/2 (_.int +0)))
+        (_.cons/2 (_.car/1 list)
+                  (slice offset
+                         (|> length (_.-/2 (_.int +1)))
+                         (_.cdr/1 list))))
+      _.nil))
+
+(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))}
+                   body)
+  (wrap (list (` (let [(~+ (|> vars
+                               (list/map (function (_ var)
+                                           (list (code.local-identifier var)
+                                                 (` (_.var (~ (code.text (format "LRV__" (name.normalize var)))))))))
+                               list/join))]
+                   (~ body))))))
+
+(runtime: (lux//try op)
+  (with-vars [error]
+    (_.with-exception-handler
+      (_.lambda [(list error) #.None]
+                (..left error))
+      (_.lambda [(list) #.None]
+                (..right (_.apply/* op (list ..unit)))))))
+
+(runtime: (lux//program-args program-args)
+  (with-vars [@loop @input @output]
+    (_.letrec (list [@loop (_.lambda [(list @input @output) #.None]
+                                     (_.if (_.eqv?/2 _.nil @input)
+                                       @output
+                                       (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))])
+              (_.apply/2 @loop (_.reverse/1 program-args) ..none))))
+
+(def: runtime//lux
+  Computation
+  (_.begin (list @@lux//try
+                 @@lux//program-args)))
+
+(def: minimum-index-length
+  (-> Expression Computation)
+  (|>> (_.+/2 (_.int +1))))
+
+(def: product-element
+  (-> Expression Expression Computation)
+  (function.flip _.vector-ref/2))
+
+(def: (product-tail product)
+  (-> Expression Computation)
+  (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1)))))
+
+(def: (updated-index min-length product)
+  (-> Expression Expression Computation)
+  (|> min-length (_.-/2 (_.length/1 product))))
+
+(runtime: (product//left product index)
+  (let [@index_min_length (_.var "index_min_length")]
+    (_.begin
+     (list (_.define @index_min_length [(list) #.None]
+                     (minimum-index-length index))
+           (_.if (|> product _.length/1 (_.>/2 @index_min_length))
+             ## No need for recursion
+             (product-element index product)
+             ## Needs recursion
+             (product//left (product-tail product)
+                            (updated-index @index_min_length product)))))))
+
+(runtime: (product//right product index)
+  (let [@index_min_length (_.var "index_min_length")
+        @product_length (_.var "product_length")
+        @slice (_.var "slice")
+        last-element? (|> @product_length (_.=/2 @index_min_length))
+        needs-recursion? (|> @product_length (_.</2 @index_min_length))]
+    (_.begin
+     (list
+      (_.define @index_min_length [(list) #.None] (minimum-index-length index))
+      (_.define @product_length [(list) #.None] (_.length/1 product))
+      (<| (_.if last-element?
+            (product-element index product))
+          (_.if needs-recursion?
+            (product//right (product-tail product)
+                            (updated-index @index_min_length product)))
+          ## Must slice
+          (_.begin
+           (list (_.define @slice [(list) #.None]
+                           (_.make-vector/1 (|> @product_length (_.-/2 index))))
+                 (_.vector-copy!/5 @slice (_.int +0) product index @product_length)
+                 @slice)))))))
+
+(runtime: (sum//get sum last? wanted-tag)
+  (with-vars [variant-tag sum-tag sum-flag sum-value]
+    (let [no-match _.nil
+          is-last? (|> sum-flag (_.eqv?/2 (_.string "")))
+          test-recursion (_.if is-last?
+                           ## Must recurse.
+                           (sum//get sum-value
+                                     (|> wanted-tag (_.-/2 sum-tag))
+                                     last?)
+                           no-match)]
+      (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None]
+                               (_.apply/* (_.global "apply") (list (_.global "values") sum))]))
+          (_.if (|> wanted-tag (_.=/2 sum-tag))
+            (_.if (|> sum-flag (_.eqv?/2 last?))
+              sum-value
+              test-recursion))
+          (_.if (|> wanted-tag (_.>/2 sum-tag))
+            test-recursion)
+          (_.if (_.and (list (|> last? (_.eqv?/2 (_.string "")))
+                             (|> wanted-tag (_.</2 sum-tag))))
+            (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value))
+          no-match))))
+
+(def: runtime//adt
+  Computation
+  (_.begin (list @@product//left
+                 @@product//right
+                 @@sum//get)))
+
+(runtime: (bit//logical-right-shift shift input)
+  (_.if (_.=/2 (_.int +0) shift)
+    input
+    (|> input
+        (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift))
+        (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF"))))))
+
+(def: runtime//bit
+  Computation
+  (_.begin (list @@bit//logical-right-shift)))
+
+(runtime: (frac//decode input)
+  (with-vars [@output]
+    (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)])
+      (_.if (_.and (list (_.not/1 (_.=/2 @output @output))
+                         (_.not/1 (_.eqv?/2 (_.string "+nan.0") input))))
+        ..none
+        (..some @output)))))
+
+(def: runtime//frac
+  Computation
+  (_.begin
+   (list @@frac//decode)))
+
+(def: (check-index-out-of-bounds array idx body)
+  (-> Expression Expression Expression Computation)
+  (_.if (|> idx (_.<=/2 (_.length/1 array)))
+    body
+    (_.raise/1 (_.string "Array index out of bounds!"))))
+
+(runtime: (array//get array idx)
+  (with-vars [@temp]
+    (<| (check-index-out-of-bounds array idx)
+        (_.let (list [@temp (_.vector-ref/2 array idx)])
+          (_.if (|> @temp (_.eqv?/2 _.nil))
+            ..none
+            (..some @temp))))))
+
+(runtime: (array//put array idx value)
+  (<| (check-index-out-of-bounds array idx)
+      (_.begin
+       (list (_.vector-set!/3 array idx value)
+             array))))
+
+(def: runtime//array
+  Computation
+  (_.begin
+   (list @@array//get
+         @@array//put)))
+
+(runtime: (box//write value box)
+  (_.begin
+   (list
+    (_.vector-set!/3 box (_.int +0) value)
+    ..unit)))
+
+(def: runtime//box
+  Computation
+  (_.begin (list @@box//write)))
+
+(runtime: (io//current-time _)
+  (|> (_.apply/* (_.global "current-second") (list))
+      (_.*/2 (_.int +1_000))
+      _.exact/1))
+
+(def: runtime//io
+  (_.begin (list @@io//current-time)))
+
+(def: runtime
+  Computation
+  (_.begin (list @@slice
+                 runtime//lux
+                 runtime//bit
+                 runtime//adt
+                 runtime//frac
+                 runtime//array
+                 runtime//box
+                 runtime//io
+                 )))
+
+(def: #export translate
+  (Operation Any)
+  (///.with-buffer
+    (do ////.monad
+      [_ (///.save! ["" ..prefix] ..runtime)]
+      (///.save-buffer! ""))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
new file mode 100644
index 000000000..dc1b88591
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
@@ -0,0 +1,33 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." primitive]
+   ["." ///
+    [analysis (#+ Variant Tuple)]
+    ["." synthesis (#+ Synthesis)]
+    [///
+     [host
+      ["_" scheme (#+ Expression)]]]]])
+
+(def: #export (tuple translate elemsS+)
+  (-> Phase (Tuple Synthesis) (Operation Expression))
+  (case elemsS+
+    #.Nil
+    (primitive.text synthesis.unit)
+
+    (#.Cons singletonS #.Nil)
+    (translate singletonS)
+
+    _
+    (do ///.monad
+      [elemsT+ (monad.map @ translate elemsS+)]
+      (wrap (_.vector/* elemsT+)))))
+
+(def: #export (variant translate [lefts right? valueS])
+  (-> Phase (Variant Synthesis) (Operation Expression))
+  (do ///.monad
+    [valueT (translate valueS)]
+    (wrap (runtime.variant [lefts right? valueT]))))