diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux | 375 |
1 files changed, 0 insertions, 375 deletions
diff --git a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux deleted file mode 100644 index c3f149eeb..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,375 +0,0 @@ -(.module: - lux - (lux (control ["p" parser "p/" Monad<Parser>] - [monad #+ do]) - (data [bit] - [number #+ hex] - text/format - (coll [list "list/" Monad<List>])) - [macro] - (macro [code] - ["s" syntax #+ syntax:]) - [io #+ Process]) - [//] - (luxc [lang] - (lang (host ["_" scheme #+ SVar Expression @@])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (_.string //.unit)) - -(def: (flag value) - (-> Bool Expression) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Expression) - (<| (_.cons (_.symbol //.variant-tag)) - (_.cons tag) - (_.cons last?) - value)) - -(def: #export (variant tag last? value) - (-> Nat Bool Expression Expression) - (variant' (_.int (:! Int tag)) (flag last?) value)) - -(def: #export none - Expression - (variant +0 false unit)) - -(def: #export some - (-> Expression Expression) - (variant +1 true)) - -(def: #export left - (-> Expression Expression) - (variant +0 false)) - -(def: #export right - (-> Expression Expression) - (variant +1 true)) - -(type: Runtime Expression) - -(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 "__" (lang.normalize-name name)) - $runtime (` (_.var (~ (code.text runtime)))) - @runtime (` (@@ (~ $runtime))) - argsC+ (list/map code.local-symbol args) - argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-symbol name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Expression))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Expression - (~ (case argsC+ - #.Nil - (` (_.define (~ $runtime) (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.define (~ $runtime) (list (~+ argsLC+)) - (~ definition)))))))))))) - -(runtime: (list-slice offset length list) - (<| (_.if (_.null? (@@ list)) - (@@ list)) - (_.if (|> (@@ offset) (_.> (_.int 0))) - (list-slice (|> (@@ offset) (_.- (_.int 1))) - (@@ length) - (_.cdr (@@ list)))) - (_.if (|> (@@ length) (_.> (_.int 0))) - (_.cons (_.car (@@ list)) - (list-slice (@@ offset) - (|> (@@ length) (_.- (_.int 1))) - (_.cdr (@@ 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__" (lang.normalize-name var))))))))) - list/join))] - (~ body)))))) - -(def: as-integer - (-> Expression Expression) - (_.apply1 (_.global "exact"))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda (_.poly (list error)) - (..left (@@ error))) - (_.lambda (_.poly (list)) - (..right (_.apply (@@ op) (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [loop input output] - (_.letrec (list [loop (_.lambda (_.poly (list input output)) - (_.if (_.eqv? _.nil (@@ input)) - (@@ output) - (_.apply (@@ loop) - (list (_.cdr (@@ input)) - (..some (_.vector (list (_.car (@@ input)) (@@ output))))))))]) - (_.apply (@@ loop) (list (_.apply (_.global "reverse") (list (@@ program-args))) - ..none))))) - -(def: runtime//lux - Runtime - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Expression) - (|>> (_.+ (_.int 1)))) - -(def: product-element - (-> Expression Expression Expression) - _.vector-ref) - -(def: (product-tail product) - (-> Expression Expression) - (_.vector-ref product (|> (_.length product) (_.- (_.int 1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Expression) - (|> min-length (_.- (_.length product)))) - -(runtime: (product//left product index) - (let [$index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define $index_min_length (list) - (minimum-index-length (@@ index))) - (_.if (|> (_.length (@@ product)) (_.> (@@ $index_min_length))) - ## No need for recursion - (product-element (@@ product) (@@ index)) - ## 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")] - (_.begin - (list - (_.define $index_min_length (list) (minimum-index-length (@@ index))) - (_.define $product_length (list) (_.length (@@ product))) - (<| (_.if ## Last element. - (|> (@@ $product_length) (_.= (@@ $index_min_length))) - (product-element (@@ product) (@@ index))) - (_.if ## Needs recursion - (|> (@@ $product_length) (_.< (@@ $index_min_length))) - (product//right (product-tail (@@ product)) - (updated-index (@@ $index_min_length) (@@ product)))) - ## Must slice - (_.begin - (list (_.define $slice (list) - (_.make-vector (|> (@@ $product_length) - (_.- (@@ index))))) - (_.vector-copy! (@@ $slice) (_.int 0) - (@@ product) (@@ index) (@@ $product_length)) - (@@ $slice)))))))) - -(runtime: (sum//get sum wanted_tag wants_last) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> (@@ sum-flag) (_.eqv? (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get (@@ sum-value) - (|> (@@ wanted_tag) (_.- (@@ sum-tag))) - (@@ wants_last)) - no-match)] - (<| (_.let-values (list [(_.poly (list variant-tag sum-tag sum-flag sum-value)) - (_.apply (_.global "apply") (list (_.global "values") (@@ sum)))])) - (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag))) - (_.if (|> (@@ sum-flag) (_.eqv? (@@ wants_last))) - (@@ sum-value) - test-recursion)) - (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag))) - test-recursion) - (_.if (_.and (list (|> (@@ wants_last) (_.eqv? (_.string ""))) - (|> (@@ wanted_tag) (_.< (@@ sum-tag))))) - (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value))) - no-match)))) - -(def: runtime//adt - Runtime - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.= (_.int 0) (@@ shift)) - (@@ input) - (|> (@@ input) - (_.arithmetic-shift (_.* (_.int -1) (@@ shift))) - (_.bit-and (_.int (hex "7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Runtime - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [output] - (_.let (list [output ((_.apply1 (_.global "string->number")) (@@ input))]) - (_.if (_.and (list (_.not (_.= (@@ output) (@@ output))) - (_.not (_.eqv? (_.string "+nan.0") (@@ input))))) - ..none - (..some (@@ output)))))) - -(def: runtime//frac - Runtime - (_.begin - (list @@frac//decode))) - -## (def: runtime//text -## Runtime -## (_.begin (list @@text//index -## @@text//clip -## @@text//char))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Expression) - (_.if (|> idx (_.<= (_.length array))) - body - (_.raise (_.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 (@@ array) (@@ idx))]) - (_.if (|> (@@ temp) (_.eqv? _.nil)) - ..none - (..some (@@ temp))))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds (@@ array) (@@ idx)) - (_.begin - (list (_.vector-set! (@@ array) (@@ idx) (@@ value)) - (@@ array))))) - -(def: runtime//array - Runtime - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (atom//compare-and-swap atom old new) - (with-vars [temp] - (_.let (list [temp (_.vector-ref (@@ atom) (_.int 0))]) - (_.if (_.eq? (@@ old) (@@ temp)) - (_.begin - (list (_.vector-set! (@@ atom) (_.int 0) (@@ new)) - (_.bool true))) - (_.bool false))))) - -(def: runtime//atom - Runtime - @@atom//compare-and-swap) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set! (@@ box) (_.int 0) (@@ value)) - ..unit))) - -(def: runtime//box - Runtime - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply (_.global "current-second") (list)) - (_.* (_.int 1_000)) - as-integer)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: process//incoming - SVar - (_.var (lang.normalize-name "process//incoming"))) - -(runtime: (process//loop _) - (_.when (_.not (_.null? (@@ process//incoming))) - (with-vars [queue process] - (_.let (list [queue (@@ process//incoming)]) - (_.begin (list (_.set! process//incoming (_.list (list))) - (_.apply (_.global "map") - (list (_.lambda (_.poly (list process)) - (_.apply (@@ process) (list ..unit))) - (@@ queue))) - (process//loop ..unit))))))) - -(runtime: (process//schedule milli-seconds procedure) - (let [process//future (function (_ process) - (_.set! process//incoming (_.cons process (@@ process//incoming))))] - (_.begin - (list - (_.if (_.= (_.int 0) (@@ milli-seconds)) - (process//future (@@ procedure)) - (with-vars [start process now _ignored] - (_.let (list [start (io//current-time ..unit)]) - (_.letrec (list [process (_.lambda _ignored - (_.let (list [now (io//current-time ..unit)]) - (_.if (|> (@@ now) (_.- (@@ start)) (_.>= (@@ milli-seconds))) - (_.apply (@@ procedure) (list ..unit)) - (process//future (@@ process)))))]) - (process//future (@@ process)))))) - ..unit)))) - -(def: runtime//process - Runtime - (_.begin (list (_.define process//incoming (list) (_.list (list))) - @@process//loop - @@process//schedule))) - -(def: runtime - Runtime - (_.begin (list @@list-slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - ## runtime//text - runtime//array - runtime//atom - runtime//box - runtime//io - runtime//process - ))) - -(def: #export artifact Text (format prefix //.file-extension)) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad<Meta> - [_ //.init-module-buffer - _ (//.save runtime)] - (//.save-module! artifact))) |