diff options
Diffstat (limited to 'stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux')
| -rw-r--r-- | stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux | 362 |
1 files changed, 362 insertions, 0 deletions
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! "")))) |