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 | 316 |
1 files changed, 0 insertions, 316 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 deleted file mode 100644 index 5fa6179c7..000000000 --- a/new-luxc/source/luxc/lang/translation/common-lisp/runtime.jvm.lux +++ /dev/null @@ -1,316 +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 ["_" common-lisp #+ SVar Expression @@])))) - -(def: prefix Text "LuxRuntime") - -(def: #export unit Expression (_.string //.unit)) - -(def: (flag value) - (-> Bit 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 Bit Expression Expression) - (variant' (_.int (:coerce Int tag)) (flag last?) value)) - -(def: #export none - Expression - (variant +0 #0 unit)) - -(def: #export some - (-> Expression Expression) - (variant +1 #1)) - -(def: #export left - (-> Expression Expression) - (variant +0 #0)) - -(def: #export right - (-> Expression Expression) - (variant +1 #1)) - -(type: Runtime Expression) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.seq s.local-identifier (p/wrap (list))) - (s.form (p.seq s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (lang.normalize-name name)) - $runtime (` (_.var (~ (code.text runtime)))) - @runtime (` (@@ (~ $runtime))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier 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-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) - list/join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.handler-case - (list [(_.bool #1) 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//logical-right-shift shift input) - (_.if (_.= (_.int 0) (@@ shift)) - (@@ input) - (|> (@@ input) - (_.ash (_.* (_.int -1) (@@ shift))) - (_.logand (_.int (hex "7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Runtime - (_.progn (list @@bit//logical-right-shift))) - -(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: (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: runtime - Runtime - (_.progn (list runtime//lux - runtime//bit - runtime//adt - runtime//text - runtime//array - runtime//box - runtime//io))) - -(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))) |