diff options
Diffstat (limited to 'stdlib/source/lux/language/compiler/translation')
10 files changed, 1220 insertions, 0 deletions
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..39b5bdae1 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux @@ -0,0 +1,170 @@ +(.module: + [lux #- case let if] + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (collection [list "list/" Functor<List> Fold<List>] + [set #+ Set]))) + (///// [reference #+ Register] + (host ["_" scheme #+ Expression Computation Var]) + [compiler #+ "operation/" Monad<Operation>] + (compiler [synthesis #+ Synthesis Path])) + [//runtime #+ Operation Translator] + [//reference]) + +(def: #export (let translate [valueS register bodyS]) + (-> Translator [Synthesis Register Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(//reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Translator Synthesis (List [Nat Bool]) + (Operation Expression)) + (do compiler.Monad<Operation> + [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]) + (-> Translator [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do compiler.Monad<Operation> + [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) + (-> Translator Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (operation/wrap pop-cursor!) + + (#synthesis.Bind register) + (operation/wrap (_.define (//reference.local' register) [(list) #.None] + cursor-top)) + + (^template [<tag> <format> <=>] + (^ (<tag> value)) + (operation/wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bool _.bool _.eqv?/2] + [synthesis.path/i64 _.int _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (operation/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)) + (operation/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 compiler.Monad<Operation> + [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))))]) + + _ + (compiler.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Translator Path (Operation Computation)) + (do compiler.Monad<Operation> + [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]) + (-> Translator [Synthesis Path] (Operation Computation)) + (do compiler.Monad<Operation> + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..a654fe4d0 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux @@ -0,0 +1,54 @@ +(.module: + lux + (lux (control [monad #+ do])) + (///// [compiler] + (compiler [synthesis] + [extension])) + [//runtime #+ Translator] + [//primitive] + [//structure] + [//reference] + [//function] + [//case] + [//loop]) + +(def: #export (translate synthesis) + Translator + (case synthesis + (^template [<tag> <generator>] + (^ (<tag> value)) + (<generator> value)) + ([synthesis.bool //primitive.bool] + [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))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..9fa0abc55 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux @@ -0,0 +1,32 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [maybe] + text/format + (collection ["dict" dictionary #+ Dictionary]))) + (///// [reference #+ Register Variable] + (host ["_" scheme #+ Computation]) + [compiler "operation/" Monad<Operation>] + (compiler [synthesis #+ Synthesis])) + [//runtime #+ Operation Translator] + [/common] + ## [/host] + ) + +(exception: #export (unknown-extension {message Text}) + message) + +(def: extensions + /common.Bundle + (|> /common.extensions + ## (dict.merge /host.extensions) + )) + +(def: #export (extension translate name args) + (-> Translator Text (List Synthesis) + (Operation Computation)) + (<| (maybe.default (compiler.throw unknown-extension (%t name))) + (do maybe.Monad<Maybe> + [ext (dict.get name extensions)] + (wrap (ext translate args))))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..11743b076 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,376 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + [text] + text/format + [number #+ hex] + (collection [list "list/" Functor<List>] + ["dict" dictionary #+ Dictionary])) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax:]) + [host]) + (////// (host ["_" scheme #+ Expression Computation]) + [compiler] + (compiler [synthesis #+ Synthesis])) + [///runtime #+ Operation Translator]) + +## [Types] +(type: #export Extension + (-> Translator (List Synthesis) (Operation Computation))) + +(type: #export Bundle + (Dictionary Text Extension)) + +(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)) + +## [Utils] +(def: #export (install name unnamed) + (-> Text (-> Text Extension) + (-> Bundle Bundle)) + (dict.put name (unnamed name))) + +(def: #export (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dict.from-list text.Hash<Text>))) + +(exception: #export (wrong-arity {extension Text} {expected Nat} {actual Nat}) + (ex.report ["Extension" (%t extension)] + ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)])) + +(syntax: (arity: {name s.local-symbol} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!translate g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + (-> Text ..Extension)) + (function ((~ g!_) (~ g!name)) + (function ((~ g!_) (~ g!translate) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do compiler.Monad<Operation> + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!translate) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (compiler.throw wrong-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 (-> Text Extension)) + (function (_ extension-name) + (function (_ translate inputsS) + (do compiler.Monad<Operation> + [inputsI (monad.map @ translate inputsS)] + (wrap (extension inputsI)))))) + +## [Extensions] +## [[Lux]] +(def: extensions/lux + Bundle + (|> (dict.new text.Hash<Text>) + (install "is?" (binary (product.uncurry _.eq?/2))) + (install "try" (unary ///runtime.lux//try)))) + +## [[Bits]] +(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: extensions/bit + Bundle + (<| (prefix "bit") + (|> (dict.new text.Hash<Text>) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left-shift)) + (install "logical-right-shift" (binary bit//logical-right-shift)) + (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) + ))) + +## [[Arrays]] +(def: (array//new size0) + Unary + (_.make-vector/2 size0 _.nil)) + +(def: (array//get [arrayO idxO]) + Binary + (///runtime.array//get arrayO idxO)) + +(def: (array//put [arrayO idxO elemO]) + Trinary + (///runtime.array//put arrayO idxO elemO)) + +(def: (array//remove [arrayO idxO]) + Binary + (///runtime.array//put arrayO idxO _.nil)) + +(def: extensions/array + Bundle + (<| (prefix "array") + (|> (dict.new text.Hash<Text>) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary _.vector-length/1)) + ))) + +## [[Numbers]] +(host.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: extensions/int + Bundle + (<| (prefix "int") + (|> (dict.new text.Hash<Text>) + (install "+" (binary int//+)) + (install "-" (binary int//-)) + (install "*" (binary int//*)) + (install "/" (binary int///)) + (install "%" (binary int//%)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary (|>> (_.//2 (_.float 1.0))))) + (install "char" (unary int//char))))) + +(def: extensions/frac + Bundle + (<| (prefix "frac") + (|> (dict.new text.Hash<Text>) + (install "+" (binary frac//+)) + (install "-" (binary frac//-)) + (install "*" (binary frac//*)) + (install "/" (binary frac///)) + (install "%" (binary frac//%)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "to-int" (unary _.exact/1)) + (install "encode" (unary _.number->string/1)) + (install "decode" (unary ///runtime.frac//decode))))) + +## [[Text]] +(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: extensions/text + Bundle + (<| (prefix "text") + (|> (dict.new text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary (product.uncurry _.string-append/2))) + (install "size" (unary _.string-length/1)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip))))) + +## [[Math]] +(def: (math//pow [subject param]) + Binary + (_.expt/2 param subject)) + +(def: math-func + (-> Text Unary) + (|>> _.global _.apply/1)) + +(def: extensions/math + Bundle + (<| (prefix "math") + (|> (dict.new text.Hash<Text>) + (install "cos" (unary (math-func "cos"))) + (install "sin" (unary (math-func "sin"))) + (install "tan" (unary (math-func "tan"))) + (install "acos" (unary (math-func "acos"))) + (install "asin" (unary (math-func "asin"))) + (install "atan" (unary (math-func "atan"))) + (install "exp" (unary (math-func "exp"))) + (install "log" (unary (math-func "log"))) + (install "ceil" (unary (math-func "ceiling"))) + (install "floor" (unary (math-func "floor"))) + (install "pow" (binary math//pow)) + ))) + +## [[IO]] +(def: (io//log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: extensions/io + Bundle + (<| (prefix "io") + (|> (dict.new text.Hash<Text>) + (install "log" (unary (|>> io//log ..void))) + (install "error" (unary _.raise/1)) + (install "exit" (unary _.exit/1)) + (install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string synthesis.unit)))))))) + +## [[Atoms]] +(def: atom//new + Unary + (|>> (list) _.vector/*)) + +(def: (atom//read atom) + Unary + (_.vector-ref/2 atom (_.int 0))) + +(def: (atom//compare-and-swap [atomO oldO newO]) + Trinary + (///runtime.atom//compare-and-swap atomO oldO newO)) + +(def: extensions/atom + Bundle + (<| (prefix "atom") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) + +## [[Box]] +(def: (box//write [valueO boxO]) + Binary + (///runtime.box//write valueO boxO)) + +(def: extensions/box + Bundle + (<| (prefix "box") + (|> (dict.new text.Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "write" (binary box//write))))) + +## [[Processes]] +(def: (process//parallelism-level []) + Nullary + (_.int 1)) + +(def: extensions/process + Bundle + (<| (prefix "process") + (|> (dict.new text.Hash<Text>) + (install "parallelism-level" (nullary process//parallelism-level)) + (install "schedule" (binary (product.uncurry ///runtime.process//schedule))) + ))) + +## [Bundles] +(def: #export extensions + Bundle + (<| (prefix "lux") + (|> extensions/lux + (dict.merge extensions/bit) + (dict.merge extensions/int) + (dict.merge extensions/frac) + (dict.merge extensions/text) + (dict.merge extensions/array) + (dict.merge extensions/math) + (dict.merge extensions/io) + (dict.merge extensions/atom) + (dict.merge extensions/box) + (dict.merge extensions/process) + ))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..1ac433ec4 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux @@ -0,0 +1,85 @@ +(.module: + [lux #- function] + (lux (control [monad #+ do] + pipe) + (data [product] + text/format + (collection [list "list/" Functor<List>]))) + (///// [reference #+ Register Variable] + [name] + (host ["_" scheme #+ Expression Computation Var]) + [compiler "operation/" Monad<Operation>] + (compiler [analysis #+ Variant Tuple Environment Arity Abstraction Application Analysis] + [synthesis #+ Synthesis])) + [///] + [//runtime #+ Operation Translator] + [//primitive] + [//reference]) + +(def: #export (apply translate [functionS argsS+]) + (-> Translator (Application Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [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"))] + (operation/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]) + (-> Translator (Abstraction Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [[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.n/range +0 (dec 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/language/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..f77f7cf10 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux @@ -0,0 +1,36 @@ +(.module: + [lux #- Scope] + (lux (control [monad #+ do]) + (data [product] + [text] + text/format + (collection [list "list/" Functor<List>])) + [macro]) + (///// (host ["_" scheme #+ Computation Var]) + [compiler] + (compiler [synthesis #+ Scope Synthesis])) + [///] + [//runtime #+ Operation Translator] + [//reference]) + +(def: @scope (_.var "scope")) + +(def: #export (scope translate [start initsS+ bodyS]) + (-> Translator (Scope Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [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+) + (-> Translator (List Synthesis) (Operation Computation)) + (do compiler.Monad<Operation> + [@scope ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..e78df5b74 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/primitive.jvm.lux @@ -0,0 +1,22 @@ +(.module: + [lux #- i64] + [/// #+ State] + (///// [compiler #+ "operation/" Monad<Operation>] + (host ["_" scheme #+ Expression])) + [//runtime #+ Operation]) + +(def: #export bool + (-> Bool (Operation Expression)) + (|>> _.bool operation/wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int operation/wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float operation/wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..e1cb6a642 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux @@ -0,0 +1,54 @@ +(.module: + lux + (lux (control pipe) + (data text/format)) + (///// [reference #+ Register Variable Reference] + [name] + (host ["_" scheme #+ Expression Var]) + [compiler "operation/" Monad<Operation>] + (compiler [analysis #+ Variant Tuple] + [synthesis #+ Synthesis])) + [//runtime #+ Operation Translator] + [//primitive]) + +(do-template [<name> <prefix>] + [(def: #export <name> + (-> Register Var) + (|>> .int %i (format <prefix>) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable' + (-> Variable Var) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)))) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> ..variable' + operation/wrap)) + +(def: #export constant' + (-> Ident Var) + (|>> name.definition _.var)) + +(def: #export constant + (-> Ident (Operation Var)) + (|>> constant' operation/wrap)) + +(def: #export reference' + (-> Reference Expression) + (|>> (case> (#reference.Constant value) + (..constant' value) + + (#reference.Variable value) + (..variable' value)))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> reference' operation/wrap)) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..89707cdc4 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux @@ -0,0 +1,362 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [number #+ hex] + text/format + (collection [list "list/" Monad<List>])) + [function] + (macro [code] + ["s" syntax #+ syntax:])) + [/// #+ State] + (///// [name] + (host ["_" scheme #+ Expression Computation Var]) + [compiler] + (compiler [analysis #+ Variant] + [synthesis]))) + +(type: #export Operation + (compiler.Operation (State Var Expression))) + +(type: #export Translator + (///.Translator Var Expression)) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bool 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 false ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [+0 false] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [+0 true] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-symbol (p/wrap (list))) + (s.form (p.seq s.local-symbol (p.some s.local-symbol))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-symbol (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-symbol args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-symbol 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-symbol))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-symbol 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: (atom//compare-and-swap atom old new) + (with-vars [@temp] + (_.let (list [@temp (_.vector-ref/2 atom (_.int 0))]) + (_.if (_.eq?/2 old @temp) + (_.begin + (list (_.vector-set!/3 atom (_.int 0) new) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Computation + @@atom//compare-and-swap) + +(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: process//incoming + Var + (_.var (name.normalize "process//incoming"))) + +(runtime: (process//loop _) + (_.when (_.not/1 (_.null?/1 process//incoming)) + (with-vars [queue process] + (_.let (list [queue process//incoming]) + (_.begin (list (_.set! process//incoming (_.list/* (list))) + (_.map/2 (_.lambda [(list process) #.None] + (_.apply/1 process ..unit)) + queue) + (process//loop ..unit))))))) + +(runtime: (process//schedule milli-seconds procedure) + (let [process//future (function (_ process) + (_.set! process//incoming (_.cons/2 process process//incoming)))] + (_.begin + (list + (_.if (_.=/2 (_.int 0) milli-seconds) + (process//future procedure) + (with-vars [@start @process @now @ignored] + (_.let (list [@start (io//current-time ..unit)]) + (_.letrec (list [@process (_.lambda [(list) (#.Some @ignored)] + (_.let (list [@now (io//current-time ..unit)]) + (_.if (|> @now (_.-/2 @start) (_.>=/2 milli-seconds)) + (_.apply/1 procedure ..unit) + (process//future @process))))]) + (process//future @process))))) + ..unit)))) + +(def: runtime//process + Computation + (_.begin (list (_.define process//incoming [(list) #.None] (_.list/* (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//atom + runtime//box + runtime//io + runtime//process + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do compiler.Monad<Operation> + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..c3b93e7a1 --- /dev/null +++ b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux @@ -0,0 +1,29 @@ +(.module: + lux + (lux (control [monad #+ do])) + (///// (host ["_" scheme #+ Expression]) + [compiler] + (compiler [analysis #+ Variant Tuple] + [synthesis #+ Synthesis])) + [//runtime #+ Operation Translator] + [//primitive]) + +(def: #export (tuple translate elemsS+) + (-> Translator (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (//primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do compiler.Monad<Operation> + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Translator (Variant Synthesis) (Operation Expression)) + (do compiler.Monad<Operation> + [valueT (translate valueS)] + (wrap (//runtime.variant [lefts right? valueT])))) |