diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux | 425 |
1 files changed, 425 insertions, 0 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 new file mode 100644 index 000000000..585c80c86 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/scheme/runtime.jvm.lux @@ -0,0 +1,425 @@ +(.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//shift-right 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//shift-right))) + +(def: int-high (bit//shift-right (_.int 32))) +(def: int-low (_.bit-and (_.int (hex "FFFFFFFF")))) + +(runtime: (nat//< param subject) + (with-vars [pH sH] + (_.let (list [pH (int-high (@@ param))] + [sH (int-high (@@ subject))]) + (_.or (list (_.< (@@ pH) (@@ sH)) + (_.and (list (_.= (@@ pH) (@@ sH)) + (_.< (int-low (@@ param)) (int-low (@@ subject)))))))))) + +(runtime: (nat/// param subject) + (_.if (_.< (_.int 0) (@@ param)) + (_.if (nat//< (@@ param) (@@ subject)) + (_.int 0) + (_.int 1)) + (with-vars [quotient] + (_.let (list [quotient (|> (@@ subject) + (bit//shift-right (_.int 1)) + (_.quotient (@@ param)) + (_.arithmetic-shift (_.int 1)))]) + (let [remainder (_.- (_.* (@@ param) (@@ quotient)) + (@@ subject))] + (_.if (_.not (nat//< (@@ param) remainder)) + (_.+ (_.int 1) (@@ quotient)) + (@@ quotient))))))) + +(runtime: (nat//% param subject) + (let [flat (|> (@@ subject) + (nat/// (@@ param)) + (_.* (@@ param)))] + (|> (@@ subject) (_.- flat)))) + +(def: runtime//nat + Runtime + (_.begin + (list @@nat//< + @@nat/// + @@nat//%))) + +(runtime: (frac//to-deg input) + (with-vars [two32 shifted] + (_.let* (list [two32 (|> (_.float 2.0) (_.expt (_.float 32.0)))] + [shifted (|> (@@ input) (_.mod (_.float 1.0)) (_.* (@@ two32)))]) + (let [low (|> (@@ shifted) (_.mod (_.float 1.0)) (_.* (@@ two32)) as-integer) + high (|> (@@ shifted) as-integer)] + (|> high + (_.arithmetic-shift (_.int 32)) + (_.+ low)))))) + +(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//to-deg + @@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//future procedure) + (_.begin (list (_.set! process//incoming (_.cons (@@ procedure) (@@ process//incoming))) + ..unit))) + +(runtime: (process//schedule milli-seconds 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)))))) + +(def: runtime//process + Runtime + (_.begin (list (_.define process//incoming (list) (_.list (list))) + @@process//loop + @@process//future + @@process//schedule))) + +(def: runtime + Runtime + (_.begin (list @@list-slice + runtime//lux + runtime//bit + runtime//adt + runtime//nat + 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 Unit)) + (do macro.Monad<Meta> + [_ //.init-module-buffer + _ (//.save runtime)] + (//.save-module! artifact))) |