aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2019-05-21 19:51:14 -0400
committerEduardo Julian2019-05-21 19:51:14 -0400
commiteb59547eae1753c9aed1ee887e44c825c1b32c05 (patch)
treeaabce6250366d4f71ae64c50bde8b8bb717ac636 /stdlib/source
parent814d5e86f6475e18d671be5149c9a9747e93d455 (diff)
WIP: Separate Scheme compiler.
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/target/scheme.lux112
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux42
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux123
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux133
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux6
5 files changed, 185 insertions, 231 deletions
diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux
index 820ff8c83..886d2ba88 100644
--- a/stdlib/source/lux/target/scheme.lux
+++ b/stdlib/source/lux/target/scheme.lux
@@ -1,15 +1,14 @@
(.module:
[lux (#- Code int or and if function cond let)
[control
- [pipe (#+ new> cond> case>)]
- ["." function]]
+ [pipe (#+ new> cond> case>)]]
[data
[number
["." frac]]
["." text
format]
[collection
- ["." list ("#;." functor fold)]]]
+ ["." list ("#@." functor fold)]]]
[macro
["." template]]
[type
@@ -44,25 +43,25 @@
(def: #export var (-> Text Var) (|>> :abstraction))
- (def: (arguments [vars rest])
+ (def: (arguments [mandatory rest])
(-> Arguments (Code Any))
(case rest
(#.Some rest)
- (case vars
+ (case mandatory
#.Nil
rest
_
(|> (format " . " (:representation rest))
- (format (|> vars
- (list;map ..code)
+ (format (|> mandatory
+ (list@map ..code)
(text.join-with " ")))
(text.enclose ["(" ")"])
:abstraction))
#.None
- (|> vars
- (list;map ..code)
+ (|> mandatory
+ (list@map ..code)
(text.join-with " ")
(text.enclose ["(" ")"])
:abstraction)))
@@ -129,14 +128,15 @@
(|>> :abstraction))
(def: form
- (-> (List (Code Any)) Text)
- (|>> (list;map ..code)
+ (-> (List (Code Any)) Code)
+ (|>> (list@map ..code)
(text.join-with " ")
- (text.enclose ["(" ")"])))
+ (text.enclose ["(" ")"])
+ :abstraction))
(def: #export (apply/* func args)
(-> Expression (List Expression) Computation)
- (:abstraction (..form (#.Cons func args))))
+ (..form (#.Cons func args)))
(template [<name> <function>]
[(def: #export <name>
@@ -193,7 +193,7 @@
[[append/2 "append"]
[cons/2 "cons"]
[make-vector/2 "make-vector"]
- [vector-ref/2 "vector-ref"]
+ ## [vector-ref/2 "vector-ref"]
[list-tail/2 "list-tail"]
[map/2 "map"]
[string-ref/2 "string-ref"]
@@ -207,6 +207,23 @@
[[vector-copy!/5 "vector-copy!"]]]
)
+ ## TODO: define "vector-ref/2" like a normal apply/2 function.
+ ## "vector-ref/2" as an 'invoke' is problematic, since it only works
+ ## in Kawa.
+ ## However, the way Kawa defines "vector-ref" causes trouble,
+ ## because it does a runtime type-check which throws an error when
+ ## it checks against custom values/objects/classes made for
+ ## JVM<->Scheme interop.
+ ## There are 2 ways to deal with this:
+ ## 0. To fork Kawa, and get rid of the type-check so the normal
+ ## "vector-ref" can be used instead.
+ ## 1. To carry on, and then, when it's time to compile the compiler
+ ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'.
+ ## Either way, the 'invoke' needs to go away.
+ (def: #export (vector-ref/2 vector index)
+ (-> Expression Expression Computation)
+ (..form (list (..var "invoke") vector (..symbol "getRaw") index)))
+
(template [<lux-name> <scheme-name>]
[(def: #export (<lux-name> param subject)
(-> Expression Expression Computation)
@@ -238,7 +255,7 @@
(template [<lux-name> <scheme-name>]
[(def: #export <lux-name>
(-> (List Expression) Computation)
- (|>> (list& (..global <scheme-name>)) ..form :abstraction))]
+ (|>> (list& (..global <scheme-name>)) ..form))]
[or "or"]
[and "and"]
@@ -247,20 +264,17 @@
(template [<lux-name> <scheme-name> <var> <pre>]
[(def: #export (<lux-name> bindings body)
(-> (List [<var> Expression]) Expression Computation)
- (:abstraction
- (..form (list (..global <scheme-name>)
- (|> bindings
- (list;map (.function (_ [binding/name binding/value])
- (:abstraction
- (..form (list (<pre> binding/name)
- binding/value)))))
- ..form
- :abstraction)
- body))))]
-
- [let "let" Var function.identity]
- [let* "let*" Var function.identity]
- [letrec "letrec" Var function.identity]
+ (..form (list (..global <scheme-name>)
+ (|> bindings
+ (list@map (.function (_ [binding/name binding/value])
+ (..form (list (|> binding/name <pre>)
+ binding/value))))
+ ..form)
+ body)))]
+
+ [let "let" Var (<|)]
+ [let* "let*" Var (<|)]
+ [letrec "letrec" Var (<|)]
[let-values "let-values" Arguments ..arguments]
[let*-values "let*-values" Arguments ..arguments]
[letrec-values "letrec-values" Arguments ..arguments]
@@ -268,17 +282,15 @@
(def: #export (if test then else)
(-> Expression Expression Expression Computation)
- (:abstraction
- (..form (list (..global "if") test then else))))
+ (..form (list (..global "if") test then else)))
(def: #export (when test then)
(-> Expression Expression Computation)
- (:abstraction
- (..form (list (..global "when") test then))))
+ (..form (list (..global "when") test then)))
(def: #export (cond clauses else)
(-> (List [Expression Expression]) Expression Computation)
- (|> (list;fold (.function (_ [test then] next)
+ (|> (list@fold (.function (_ [test then] next)
(if test then next))
else
(list.reverse clauses))
@@ -287,31 +299,31 @@
(def: #export (lambda arguments body)
(-> Arguments Expression Computation)
- (:abstraction
- (..form (list (..global "lambda")
- (..arguments arguments)
- body))))
+ (..form (list (..global "lambda")
+ (..arguments arguments)
+ body)))
- (def: #export (define name arguments body)
+ (def: #export (define-function name arguments body)
(-> Var Arguments Expression Computation)
- (:abstraction
- (..form (list (..global "define")
- (|> arguments
- (update@ #mandatory (|>> (#.Cons name)))
- ..arguments)
- body))))
+ (..form (list (..global "define")
+ (|> arguments
+ (update@ #mandatory (|>> (#.Cons name)))
+ ..arguments)
+ body)))
+
+ (def: #export (define-constant name value)
+ (-> Var Expression Computation)
+ (..form (list (..global "define") name value)))
(def: #export begin
(-> (List Expression) Computation)
- (|>> (#.Cons (..global "begin")) ..form :abstraction))
+ (|>> (#.Cons (..global "begin")) ..form))
(def: #export (set! name value)
(-> Var Expression Computation)
- (:abstraction
- (..form (list (..global "set!") name value))))
+ (..form (list (..global "set!") name value)))
(def: #export (with-exception-handler handler body)
(-> Expression Expression Computation)
- (:abstraction
- (..form (list (..global "with-exception-handler") handler body))))
+ (..form (list (..global "with-exception-handler") handler body)))
)
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
index d4cd440fb..04d3bae1d 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux
@@ -9,7 +9,7 @@
["." text
format]
[collection
- ["." list ("#;." functor fold)]]]
+ ["." list ("#@." functor fold)]]]
[target
["_" scheme (#+ Expression Computation Var)]]]
["." // #_
@@ -17,7 +17,7 @@
["#." primitive]
["#/" // #_
["#." reference]
- ["#/" // ("#;." monad)
+ ["#/" // ("#@." monad)
["#/" // #_
[reference (#+ Register)]
["#." synthesis (#+ Synthesis Path)]]]]])
@@ -35,15 +35,18 @@
bodyO))))
(def: #export (record-get generate valueS pathP)
- (-> Phase Synthesis (List [Nat Bit])
+ (-> Phase Synthesis (List (Either Nat Nat))
(Operation Expression))
(do ////.monad
[valueO (generate valueS)]
- (wrap (list;fold (function (_ [idx tail?] source)
- (.let [method (.if tail?
- //runtime.product//right
- //runtime.product//left)]
- (method source (_.int (.int idx)))))
+ (wrap (list@fold (function (_ side source)
+ (.let [method (.case side
+ (^template [<side> <accessor>]
+ (<side> lefts)
+ (<accessor> (_.int (.int lefts))))
+ ([#.Left //runtime.tuple//left]
+ [#.Right //runtime.tuple//right]))]
+ (method source)))
valueO
pathP))))
@@ -98,9 +101,9 @@
(def: (pm-catch handler)
(-> Expression Computation)
(_.lambda [(list @alt-error) #.None]
- (_.if (|> @alt-error (_.eqv?/2 pm-error))
- handler
- (_.raise/1 @alt-error))))
+ (_.if (|> @alt-error (_.eqv?/2 pm-error))
+ handler
+ (_.raise/1 @alt-error))))
(def: (pattern-matching' generate pathP)
(-> Phase Path (Operation Expression))
@@ -109,15 +112,14 @@
(generate bodyS)
#/////synthesis.Pop
- (////;wrap pop-cursor!)
+ (////@wrap pop-cursor!)
(#/////synthesis.Bind register)
- (////;wrap (_.define (..register register) [(list) #.None]
- cursor-top))
+ (////@wrap (_.define-constant (..register register) ..cursor-top))
(^template [<tag> <format> <=>]
(^ (<tag> value))
- (////;wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
+ (////@wrap (_.when (|> value <format> (<=> cursor-top) _.not/1)
fail-pm!)))
([/////synthesis.path/bit //primitive.bit _.eqv?/2]
[/////synthesis.path/i64 (<| //primitive.i64 .int) _.=/2]
@@ -126,18 +128,18 @@
(^template [<pm> <flag> <prep>]
(^ (<pm> idx))
- (////;wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
+ (////@wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get cursor-top <flag>))])
(_.if (_.null?/1 @temp)
fail-pm!
(push-cursor! @temp)))))
([/////synthesis.side/left _.nil (<|)]
[/////synthesis.side/right (_.string "") inc])
- (^template [<pm> <getter> <prep>]
+ (^template [<pm> <getter>]
(^ (<pm> idx))
- (////;wrap (|> idx <prep> .int _.int (<getter> cursor-top) push-cursor!)))
- ([/////synthesis.member/left //runtime.product//left (<|)]
- [/////synthesis.member/right //runtime.product//right inc])
+ (////@wrap (push-cursor! (<getter> (_.int (.int idx)) cursor-top))))
+ ([/////synthesis.member/left //runtime.tuple//left]
+ [/////synthesis.member/right //runtime.tuple//right])
(^template [<tag> <computation>]
(^ (<tag> leftP rightP))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
index f33cb9599..6701bc078 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux
@@ -82,36 +82,24 @@
Binary
(<op> paramO subjectO))]
- [bit::and _.bit-and/2]
- [bit::or _.bit-or/2]
- [bit::xor _.bit-xor/2]
+ [i64::and _.bit-and/2]
+ [i64::or _.bit-or/2]
+ [i64::xor _.bit-xor/2]
)
-(def: (bit::left-shift [subjectO paramO])
+(def: (i64::left-shift [subjectO paramO])
Binary
(_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO)
subjectO))
-(def: (bit::arithmetic-right-shift [subjectO paramO])
+(def: (i64::arithmetic-right-shift [subjectO paramO])
Binary
(_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1)))
subjectO))
-(def: (bit::logical-right-shift [subjectO paramO])
+(def: (i64::logical-right-shift [subjectO paramO])
Binary
- (///runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
-
-(def: bundle::bit
- Bundle
- (<| (bundle.prefix "bit")
- (|> bundle.empty
- (bundle.install "and" (binary bit::and))
- (bundle.install "or" (binary bit::or))
- (bundle.install "xor" (binary bit::xor))
- (bundle.install "left-shift" (binary bit::left-shift))
- (bundle.install "logical-right-shift" (binary bit::logical-right-shift))
- (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift))
- )))
+ (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO))
(import: java/lang/Double
(#static MIN_VALUE Double)
@@ -122,9 +110,9 @@
Nullary
(<encode> <const>))]
- [frac::smallest (Double::MIN_VALUE) _.float]
- [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float]
- [frac::max (Double::MAX_VALUE) _.float]
+ [f64::smallest (Double::MIN_VALUE) _.float]
+ [f64::min (f/* -1.0 (Double::MAX_VALUE)) _.float]
+ [f64::max (Double::MAX_VALUE) _.float]
)
(template [<name> <op>]
@@ -132,11 +120,11 @@
Binary
(|> subjectO (<op> paramO)))]
- [int::+ _.+/2]
- [int::- _.-/2]
- [int::* _.*/2]
- [int::/ _.quotient/2]
- [int::% _.remainder/2]
+ [i64::+ _.+/2]
+ [i64::- _.-/2]
+ [i64::* _.*/2]
+ [i64::/ _.quotient/2]
+ [i64::% _.remainder/2]
)
(template [<name> <op>]
@@ -144,13 +132,13 @@
Binary
(<op> paramO subjectO))]
- [frac::+ _.+/2]
- [frac::- _.-/2]
- [frac::* _.*/2]
- [frac::/ _.//2]
- [frac::% _.mod/2]
- [frac::= _.=/2]
- [frac::< _.</2]
+ [f64::+ _.+/2]
+ [f64::- _.-/2]
+ [f64::* _.*/2]
+ [f64::/ _.//2]
+ [f64::% _.mod/2]
+ [f64::= _.=/2]
+ [f64::< _.</2]
[text::= _.string=?/2]
[text::< _.string<?/2]
@@ -161,41 +149,47 @@
Binary
(<cmp> paramO subjectO))]
- [int::= _.=/2]
- [int::< _.</2]
+ [i64::= _.=/2]
+ [i64::< _.</2]
)
-(def: int::char (|>> _.integer->char/1 _.string/1))
+(def: i64::char (|>> _.integer->char/1 _.string/1))
-(def: bundle::int
+(def: bundle::i64
Bundle
- (<| (bundle.prefix "int")
+ (<| (bundle.prefix "i64")
(|> bundle.empty
- (bundle.install "+" (binary int::+))
- (bundle.install "-" (binary int::-))
- (bundle.install "*" (binary int::*))
- (bundle.install "/" (binary int::/))
- (bundle.install "%" (binary int::%))
- (bundle.install "=" (binary int::=))
- (bundle.install "<" (binary int::<))
- (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0)))))
- (bundle.install "char" (unary int::char)))))
-
-(def: bundle::frac
+ (bundle.install "and" (binary i64::and))
+ (bundle.install "or" (binary i64::or))
+ (bundle.install "xor" (binary i64::xor))
+ (bundle.install "left-shift" (binary i64::left-shift))
+ (bundle.install "logical-right-shift" (binary i64::logical-right-shift))
+ (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift))
+ (bundle.install "+" (binary i64::+))
+ (bundle.install "-" (binary i64::-))
+ (bundle.install "*" (binary i64::*))
+ (bundle.install "/" (binary i64::/))
+ (bundle.install "%" (binary i64::%))
+ (bundle.install "=" (binary i64::=))
+ (bundle.install "<" (binary i64::<))
+ (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0)))))
+ (bundle.install "char" (unary i64::char)))))
+
+(def: bundle::f64
Bundle
- (<| (bundle.prefix "frac")
+ (<| (bundle.prefix "f64")
(|> bundle.empty
- (bundle.install "+" (binary frac::+))
- (bundle.install "-" (binary frac::-))
- (bundle.install "*" (binary frac::*))
- (bundle.install "/" (binary frac::/))
- (bundle.install "%" (binary frac::%))
- (bundle.install "=" (binary frac::=))
- (bundle.install "<" (binary frac::<))
- (bundle.install "smallest" (nullary frac::smallest))
- (bundle.install "min" (nullary frac::min))
- (bundle.install "max" (nullary frac::max))
- (bundle.install "to-int" (unary _.exact/1))
+ (bundle.install "+" (binary f64::+))
+ (bundle.install "-" (binary f64::-))
+ (bundle.install "*" (binary f64::*))
+ (bundle.install "/" (binary f64::/))
+ (bundle.install "%" (binary f64::%))
+ (bundle.install "=" (binary f64::=))
+ (bundle.install "<" (binary f64::<))
+ (bundle.install "smallest" (nullary f64::smallest))
+ (bundle.install "min" (nullary f64::min))
+ (bundle.install "max" (nullary f64::max))
+ (bundle.install "i64" (unary _.exact/1))
(bundle.install "encode" (unary _.number->string/1))
(bundle.install "decode" (unary ///runtime.frac//decode)))))
@@ -240,9 +234,8 @@
Bundle
(<| (bundle.prefix "lux")
(|> bundle::lux
- (dict.merge bundle::bit)
- (dict.merge bundle::int)
- (dict.merge bundle::frac)
+ (dict.merge bundle::i64)
+ (dict.merge bundle::f64)
(dict.merge bundle::text)
(dict.merge bundle::io)
)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
index 3fe02a55d..94269b4aa 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux
@@ -38,8 +38,6 @@
(def: unit (_.string /////synthesis.unit))
-(def: #export variant-tag "lux-variant")
-
(def: (flag value)
(-> Bit Computation)
(if value
@@ -48,8 +46,7 @@
(def: (variant' tag last? value)
(-> Expression Expression Expression Computation)
- (<| (_.cons/2 (_.symbol ..variant-tag))
- (_.cons/2 tag)
+ (<| (_.cons/2 tag)
(_.cons/2 last?)
value))
@@ -102,15 +99,15 @@
_.Computation
(~ (case argsC+
#.Nil
- (` (_.define (~ @runtime) [(list) #.None] (~ definition)))
+ (` (_.define-constant (~ @runtime) [(list) #.None] (~ definition)))
_
(` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
(list;map (function (_ [left right])
(list left right)))
list;join))]
- (_.define (~ @runtime) [(list (~+ argsLC+)) #.None]
- (~ definition))))))))))))
+ (_.define-function (~ @runtime) [(list (~+ argsLC+)) #.None]
+ (~ definition))))))))))))
(runtime: (slice offset length list)
(<| (_.if (_.null?/1 list)
@@ -156,58 +153,40 @@
(_.begin (list @@lux//try
@@lux//program-args)))
-(def: minimum-index-length
- (-> Expression Computation)
- (|>> (_.+/2 (_.int +1))))
-
-(def: product-element
- (-> Expression Expression Computation)
- (function.flip _.vector-ref/2))
-
-(def: (product-tail product)
+(def: last-index
(-> Expression Computation)
- (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1)))))
+ (|>> _.length/1 (_.-/2 (_.int +1))))
-(def: (updated-index min-length product)
- (-> Expression Expression Computation)
- (|> min-length (_.-/2 (_.length/1 product))))
-
-(runtime: (product//left product index)
- (let [@index_min_length (_.var "index_min_length")]
+(runtime: (tuple//left lefts tuple)
+ (with-vars [last-index-right]
(_.begin
- (list (_.define @index_min_length [(list) #.None]
- (minimum-index-length index))
- (_.if (|> product _.length/1 (_.>/2 @index_min_length))
+ (list (_.define-constant last-index-right (..last-index tuple))
+ (_.if (_.>/2 lefts last-index-right)
## No need for recursion
- (product-element index product)
+ (_.vector-ref/2 tuple lefts)
## 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")
- last-element? (|> @product_length (_.=/2 @index_min_length))
- needs-recursion? (|> @product_length (_.</2 @index_min_length))]
+ (tuple//left (_.-/2 last-index-right lefts)
+ (_.vector-ref/2 tuple last-index-right)))))))
+
+(runtime: (tuple//right lefts tuple)
+ (with-vars [last-index-right right-index @slice]
(_.begin
- (list
- (_.define @index_min_length [(list) #.None] (minimum-index-length index))
- (_.define @product_length [(list) #.None] (_.length/1 product))
- (<| (_.if last-element?
- (product-element index product))
- (_.if needs-recursion?
- (product//right (product-tail product)
- (updated-index @index_min_length product)))
- ## Must slice
- (_.begin
- (list (_.define @slice [(list) #.None]
- (_.make-vector/1 (|> @product_length (_.-/2 index))))
- (_.vector-copy!/5 @slice (_.int +0) product index @product_length)
- @slice)))))))
+ (list (_.define-constant last-index-right (..last-index tuple))
+ (_.define-constant right-index (_.+/2 (_.int +1) lefts))
+ (_.cond (list [(_.=/2 right-index last-index-right)
+ (_.vector-ref/2 tuple right-index)]
+ [(_.>/2 right-index last-index-right)
+ ## Needs recursion.
+ (tuple//right (_.-/2 last-index-right lefts)
+ (_.vector-ref/2 tuple last-index-right))])
+ (_.begin
+ (list (_.define-constant @slice (_.make-vector/1 (_.-/2 right-index (_.length/1 tuple))))
+ (_.vector-copy!/5 @slice (_.int +0) tuple right-index (_.length/1 tuple))
+ @slice))))
+ )))
(runtime: (sum//get sum last? wanted-tag)
- (with-vars [variant-tag sum-tag sum-flag sum-value]
+ (with-vars [sum-tag sum-flag sum-value]
(let [no-match _.nil
is-last? (|> sum-flag (_.eqv?/2 (_.string "")))
test-recursion (_.if is-last?
@@ -216,8 +195,10 @@
(|> wanted-tag (_.-/2 sum-tag))
last?)
no-match)]
- (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None]
- (_.apply/* (_.global "apply") (list (_.global "values") sum))]))
+ (<| (_.let (list [sum-tag (_.car/1 sum)]
+ [sum-value (_.cdr/1 sum)]))
+ (_.let (list [sum-flag (_.car/1 sum-value)]
+ [sum-value (_.cdr/1 sum-value)]))
(_.if (|> wanted-tag (_.=/2 sum-tag))
(_.if (|> sum-flag (_.eqv?/2 last?))
sum-value
@@ -231,11 +212,11 @@
(def: runtime//adt
Computation
- (_.begin (list @@product//left
- @@product//right
+ (_.begin (list @@tuple//left
+ @@tuple//right
@@sum//get)))
-(runtime: (bit//logical-right-shift shift input)
+(runtime: (i64//logical-right-shift shift input)
(_.if (_.=/2 (_.int +0) shift)
input
(|> input
@@ -244,7 +225,7 @@
(def: runtime//bit
Computation
- (_.begin (list @@bit//logical-right-shift)))
+ (_.begin (list @@i64//logical-right-shift)))
(runtime: (frac//decode input)
(with-vars [@output]
@@ -259,42 +240,6 @@
(_.begin
(list @@frac//decode)))
-(def: (check-index-out-of-bounds array idx body)
- (-> Expression Expression Expression Computation)
- (_.if (|> idx (_.<=/2 (_.length/1 array)))
- body
- (_.raise/1 (_.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/2 array idx)])
- (_.if (|> @temp (_.eqv?/2 _.nil))
- ..none
- (..some @temp))))))
-
-(runtime: (array//put array idx value)
- (<| (check-index-out-of-bounds array idx)
- (_.begin
- (list (_.vector-set!/3 array idx value)
- array))))
-
-(def: runtime//array
- Computation
- (_.begin
- (list @@array//get
- @@array//put)))
-
-(runtime: (box//write value box)
- (_.begin
- (list
- (_.vector-set!/3 box (_.int +0) value)
- ..unit)))
-
-(def: runtime//box
- Computation
- (_.begin (list @@box//write)))
-
(runtime: (io//current-time _)
(|> (_.apply/* (_.global "current-second") (list))
(_.*/2 (_.int +1,000))
@@ -310,8 +255,6 @@
runtime//bit
runtime//adt
runtime//frac
- runtime//array
- runtime//box
runtime//io
)))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
index e101effeb..f435442cc 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux
@@ -30,4 +30,8 @@
(-> Phase (Variant Synthesis) (Operation Expression))
(do ///.monad
[valueT (generate valueS)]
- (wrap (runtime.variant [lefts right? valueT]))))
+ (wrap (runtime.variant [(if right?
+ (inc lefts)
+ lefts)
+ right?
+ valueT]))))