- Migrated Scheme back-end to stdlib.

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)))