diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux | 372 |
1 files changed, 372 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux new file mode 100644 index 000000000..eae90e771 --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux @@ -0,0 +1,372 @@ +(.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 ["_" common-lisp #+ 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 + (` (_.defparameter (~ $runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.defun (~ $runtime) (list (~+ argsLC+)) + (~ definition)))))))))))) + +(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)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.handler-case + (list [(_.bool true) error + (..left (_.format/3 _.nil (_.string "~A") (@@ error)))]) + (..right (_.funcall (list ..unit) (@@ op)))))) + +(runtime: (lux//program-args program-args) + (with-vars [loop input output] + (_.labels (list [loop [(_.poly (list input output)) + (_.if (_.null (@@ input)) + (@@ output) + (_.funcall (list (_.cdr (@@ input)) + (..some (_.vector (list (_.car (@@ input)) (@@ output))))) + (_.function (@@ loop))))]]) + (_.funcall (list (_.reverse (@@ program-args)) + ..none) + (_.function (@@ loop)))))) + +(def: runtime//lux + Runtime + (_.progn (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Expression) + (|>> (_.+ (_.int 1)))) + +(def: product-element + (-> Expression Expression Expression) + _.svref) + +(def: (product-tail product) + (-> Expression Expression) + (_.svref product (|> (_.length product) (_.- (_.int 1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Expression) + (|> min-length (_.- (_.length product)))) + +(runtime: (product//left product index) + (with-vars [$index_min_length] + (_.let (list [$index_min_length (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) + (with-vars [$index_min_length $product_length] + (_.let (list [$index_min_length (minimum-index-length (@@ index))] + [$product_length (_.length (@@ product))]) + (<| (_.if (|> (@@ $product_length) (_.= (@@ $index_min_length))) + ## Last element. + (product-element (@@ product) (@@ index))) + (_.if (|> (@@ $product_length) (_.< (@@ $index_min_length))) + ## Needs recursion + (product//right (product-tail (@@ product)) + (updated-index (@@ $index_min_length) (@@ product)))) + ## Must slice + (_.subseq/3 (@@ product) (@@ index) (@@ $product_length)))))) + +(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) (_.equal (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get (@@ sum-value) + (|> (@@ wanted_tag) (_.- (@@ sum-tag))) + (@@ wants_last)) + no-match)] + (<| (_.destructuring-bind [(_.poly (list variant-tag sum-tag sum-flag sum-value)) + (@@ sum)]) + (_.if (|> (@@ wanted_tag) (_.= (@@ sum-tag))) + (_.if (|> (@@ sum-flag) (_.equal (@@ wants_last))) + (@@ sum-value) + test-recursion)) + (_.if (|> (@@ wanted_tag) (_.> (@@ sum-tag))) + test-recursion) + (_.if (_.and (list (|> (@@ wants_last) (_.equal (_.string ""))) + (|> (@@ wanted_tag) (_.< (@@ sum-tag))))) + (variant' (|> (@@ sum-tag) (_.- (@@ wanted_tag))) (@@ sum-flag) (@@ sum-value))) + no-match)))) + +(def: runtime//adt + Runtime + (_.progn (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//shift-right shift input) + (_.if (_.= (_.int 0) (@@ shift)) + (@@ input) + (|> (@@ input) + (_.ash (_.* (_.int -1) (@@ shift))) + (_.logand (_.int (hex "7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Runtime + (_.progn (list @@bit//shift-right))) + +(do-template [<name> <top-cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (_.and (list (|> value (_.>= (_.int 0))) + (|> value (<top-cmp> top)))))] + + [within? _.<] + [up-to? _.<=] + ) + +(runtime: (text//char idx text) + (_.if (|> (@@ idx) (within? (_.length (@@ text)))) + (..some (_.char-int/1 (_.char/2 (@@ text) (@@ idx)))) + ..none)) + +(runtime: (text//clip from to text) + (_.if (_.and (list (|> (@@ to) (within? (_.length (@@ text)))) + (|> (@@ from) (up-to? (@@ to))))) + (..some (_.subseq/3 (@@ text) (@@ from) (@@ to))) + ..none)) + +(runtime: (text//index reference start space) + (with-vars [index] + (_.let (list [index (_.search/start2 (@@ reference) (@@ space) (@@ start))]) + (_.if (@@ index) + (..some (@@ index)) + ..none)))) + +(def: runtime//text + Runtime + (_.progn (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 + (_.error (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [temp] + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + (_.let (list [temp (_.svref (@@ array) (@@ idx))]) + (_.if (_.null (@@ temp)) + ..none + (..some (@@ temp))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + (_.progn + (list (_.setf! (_.svref (@@ array) (@@ idx)) (@@ value)) + (@@ array))))) + +(def: runtime//array + Runtime + (_.progn + (list @@array//get + @@array//put))) + +(runtime: (atom//compare-and-swap atom old new) + (with-vars [temp] + (_.let (list [temp (_.svref (@@ atom) (_.int 0))]) + (_.if (_.eq (@@ old) (@@ temp)) + (_.progn + (list (_.setf! (_.svref (@@ atom) (_.int 0)) (@@ new)) + (_.bool true))) + (_.bool false))))) + +(def: runtime//atom + Runtime + @@atom//compare-and-swap) + +(runtime: (box//write value box) + (_.progn + (list + (_.setf! (_.svref (@@ box) (_.int 0)) (@@ value)) + ..unit))) + +(def: runtime//box + Runtime + (_.progn (list @@box//write))) + +(runtime: (io//exit code) + (_.progn + (list (_.conditional+ (list "sbcl") + (_.$apply (_.global "sb-ext:quit") (list (@@ code)))) + (_.conditional+ (list "clisp") + (_.$apply (_.global "ext:exit") (list (@@ code)))) + (_.conditional+ (list "ccl") + (_.$apply (_.global "ccl:quit") (list (@@ code)))) + (_.conditional+ (list "allegro") + (_.$apply (_.global "excl:exit") (list (@@ code)))) + (_.$apply (_.global "cl-user::quit") (list (@@ code)))))) + +(runtime: (io//current-time _) + (|> _.get-universal-time + (_.* (_.int 1_000)))) + +(def: runtime//io + (_.progn (list @@io//exit + @@io//current-time))) + +(def: process//incoming + SVar + (_.var (lang.normalize-name "process//incoming"))) + +(runtime: (process//loop _) + (_.if (_.not (_.null (@@ process//incoming))) + (with-vars [queue process] + (_.let (list [queue (@@ process//incoming)]) + (_.progn (list (_.setq! process//incoming (_.list (list))) + (_.map/3 _.nil + (_.lambda (_.poly (list process)) + (_.funcall (list ..unit) (@@ process))) + (@@ queue)) + (process//loop ..unit))))) + ..unit)) + +(runtime: (process//schedule milli-seconds procedure) + (_.progn + (list + (_.if (_.= (_.int 0) (@@ milli-seconds)) + (_.setq! process//incoming (_.cons (@@ procedure) (@@ process//incoming))) + (with-vars [start scheduled now diff _ignored] + (_.let (list [start (io//current-time ..unit)]) + (_.labels (list [scheduled [(_.poly+ (list) _ignored) + (_.let (list [now (io//current-time ..unit)] + [diff (|> (@@ now) (_.- (@@ start)))]) + (_.if (|> (@@ diff) (_.>= (@@ milli-seconds))) + (_.funcall (list ..unit) (@@ procedure)) + (process//schedule (|> (@@ milli-seconds) (_.- (@@ diff))) + (_.function (@@ scheduled)))))]]) + (_.setq! process//incoming (_.cons (_.function (@@ scheduled)) + (@@ process//incoming))))))) + ..unit))) + +(def: runtime//process + Runtime + (_.progn (list (_.defparameter process//incoming (_.list (list))) + @@process//loop + @@process//schedule))) + +(def: runtime + Runtime + (_.progn (list runtime//lux + runtime//bit + runtime//adt + 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))) |