aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/data/text.lux11
-rw-r--r--stdlib/source/lux/host/js.lux120
-rw-r--r--stdlib/source/lux/tool/compiler/phase.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux70
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux53
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux718
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux32
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux52
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux11
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux9
13 files changed, 1029 insertions, 105 deletions
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
index 9be782e65..29bbd98ab 100644
--- a/stdlib/source/lux/data/text.lux
+++ b/stdlib/source/lux/data/text.lux
@@ -233,11 +233,18 @@
"" #1
_ #0))
+(def: #export (prefix param subject)
+ (-> Text Text Text)
+ ("lux text concat" param subject))
+
+(def: #export (suffix param subject)
+ (-> Text Text Text)
+ ("lux text concat" subject param))
+
(def: #export (enclose [left right] content)
{#.doc "Surrounds the given content text with left and right side additions."}
(-> [Text Text] Text Text)
- (let [(^open ".") ..monoid]
- ($_ "lux text concat" left content right)))
+ ($_ "lux text concat" left content right))
(def: #export (enclose' boundary content)
{#.doc "Surrounds the given content text with the same boundary text."}
diff --git a/stdlib/source/lux/host/js.lux b/stdlib/source/lux/host/js.lux
index e10c0395f..fbaf12fc3 100644
--- a/stdlib/source/lux/host/js.lux
+++ b/stdlib/source/lux/host/js.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- Code or and function if cond undefined false true)
+ [lux (#- Code or and function if cond undefined for false true not)
[control
[pipe (#+ case>)]]
[data
@@ -49,6 +49,9 @@
[undefined "undefined"]
[false "false"]
[true "true"]
+ [positive-infinity "Infinity"]
+ [negative-infinity "-Infinity"]
+ [not-a-number "NaN"]
)
(def: #export boolean
@@ -102,11 +105,11 @@
:abstraction))
(def: #export (the field object)
- (-> Var Expression Access)
- (:abstraction (format (:representation object) "." (:representation field))))
+ (-> Text Expression Access)
+ (:abstraction (format (:representation object) "." field)))
(def: #export (do method inputs object)
- (-> Var (List Expression) Expression Access)
+ (-> Text (List Expression) Expression Access)
(|> (format (:representation (..the method object))
(|> inputs
(list/map ..code)
@@ -116,7 +119,7 @@
:abstraction))
(def: #export object
- (-> (List [Text Computation]) Computation)
+ (-> (List [Text Expression]) Computation)
(|>> (list/map (.function (_ [key val])
(format (:representation (..string key)) ..field-separator (:representation val))))
(text.join-with ..argument-separator)
@@ -130,9 +133,16 @@
(def: #export (then pre post)
(-> Statement Statement Statement)
- (:abstraction (format (:representation pre) " " (:representation post))))
+ (:abstraction (format (text.suffix ..statement-suffix
+ (:representation pre))
+ " "
+ (:representation post))))
- (def: block (-> Statement Text) (|>> :representation (text.enclose ["{" "}"])))
+ (def: block
+ (-> Statement Text)
+ (|>> :representation
+ (text.suffix ..statement-suffix)
+ (text.enclose ["{" "}"])))
(def: #export (function name inputs body)
(-> Var (List Var) Statement Computation)
@@ -160,7 +170,7 @@
..argument
:abstraction))
- (def: #export (apply function inputs)
+ (def: #export (apply/* function inputs)
(-> Expression (List Expression) Computation)
(|> inputs
(list/map ..code)
@@ -169,6 +179,27 @@
(format (:representation function))
:abstraction))
+ (do-template [<apply> <arg>+ <type>+ <function>+]
+ [(`` (def: #export (<apply> function)
+ (-> Expression (~~ (template.splice <type>+)) Computation)
+ (.function (_ (~~ (template.splice <arg>+)))
+ (..apply/* function (list (~~ (template.splice <arg>+)))))))
+
+ (`` (do-template [<definition> <function>]
+ [(def: #export <definition> (<apply> (..var <function>)))]
+
+ (~~ (template.splice <function>+))))]
+
+ [apply/1 [_0] [Expression]
+ [[not-a-number? "isNaN"]]]
+
+ [apply/2 [_0 _1] [Expression Expression]
+ []]
+
+ [apply/3 [_0 _1 _2] [Expression Expression Expression]
+ []]
+ )
+
(do-template [<name> <op>]
[(def: #export (<name> param subject)
(-> Expression Expression Computation)
@@ -188,12 +219,27 @@
[/ "/"]
[% "%"]
+ [left-shift "<<"]
+ [arithmetic-right-shift ">>"]
+ [logic-right-shift ">>>"]
+
[or "||"]
[and "&&"]
+ [bit-xor "^"]
[bit-or "|"]
[bit-and "&"]
)
+ (do-template [<name> <prefix>]
+ [(def: #export <name>
+ (-> Expression Computation)
+ (|>> :representation (text.prefix <prefix>) ..argument :abstraction))]
+
+ [not "!"]
+ [bit-not "~"]
+ [negate "-"]
+ )
+
(def: #export (i32 value)
{#.doc "A 32-bit integer expression."}
(-> Int Computation)
@@ -214,21 +260,37 @@
..argument
:abstraction))
+ (def: #export statement
+ (-> Expression Statement)
+ (|>> :transmutation))
+
(def: #export use-strict
Statement
- (:abstraction (format text.double-quote "use strict" text.double-quote ..statement-suffix)))
+ (:abstraction (format text.double-quote "use strict" text.double-quote)))
(def: #export (declare name)
(-> Var Statement)
- (:abstraction (format "var " (:representation name) ..statement-suffix)))
+ (:abstraction (format "var " (:representation name))))
(def: #export (define name value)
(-> Var Expression Statement)
- (:abstraction (format "var " (:representation name) " = " (:representation value) ..statement-suffix)))
+ (:abstraction (format "var " (:representation name) " = " (:representation value))))
(def: #export (set name value)
(-> Location Expression Statement)
- (:abstraction (format (:representation name) " = " (:representation value) ..statement-suffix)))
+ (:abstraction (format (:representation name) " = " (:representation value))))
+
+ (def: #export (throw message)
+ (-> Expression Statement)
+ (:abstraction (format "throw new Error(" (:representation message) ")")))
+
+ (def: #export (return value)
+ (-> Expression Statement)
+ (:abstraction (format "return " (:representation value))))
+
+ (def: #export (delete value)
+ (-> Location Statement)
+ (:abstraction (format "delete " (:representation value))))
(def: #export (if test then! else!)
(-> Expression Statement Statement Statement)
@@ -242,17 +304,31 @@
(:abstraction (format "while(" (:representation test) ") "
(..block body))))
- (def: #export (throw message)
- (-> Expression Statement)
- (:abstraction (format "throw Error(" (:representation message) ")" ..statement-suffix)))
-
- (def: #export (return value)
- (-> Expression Statement)
- (:abstraction (format "return " (:representation value) ..statement-suffix)))
+ (def: #export (try body [exception catch])
+ (-> Statement [Var Statement] Statement)
+ (:abstraction (format "try "
+ (..block body)
+ " catch(" (:representation exception) ") "
+ (..block body))))
- (def: #export (delete value)
- (-> Location Statement)
- (:abstraction (format "delete " (:representation value) ..statement-suffix)))
+ (def: #export (for var init condition update iteration)
+ (-> Var Expression Expression Statement Statement Statement)
+ (:abstraction (format "for(" (:representation (..define var init))
+ ..statement-suffix " " (:representation condition)
+ ..statement-suffix " " (:representation update)
+ ")"
+ (..block iteration))))
+
+ (do-template [<name> <js>]
+ [(def: #export <name>
+ (-> Location Statement)
+ (|>> :representation
+ (text.suffix <js>)
+ :abstraction))]
+
+ [++ "++"]
+ [-- "--"]
+ )
)
(def: #export (cond clauses else!)
diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux
index 66abcc6cd..909b7e9e9 100644
--- a/stdlib/source/lux/tool/compiler/phase.lux
+++ b/stdlib/source/lux/tool/compiler/phase.lux
@@ -20,7 +20,7 @@
(state.State' Error s o))
(def: #export monad
- (state.monad error.monad))
+ (state.with-state error.monad))
(type: #export (Phase s i o)
(-> i (Operation s o)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation.lux b/stdlib/source/lux/tool/compiler/phase/translation.lux
index d8522adcd..6ee7f3841 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation.lux
@@ -13,10 +13,10 @@
["." row (#+ Row)]
["." dictionary (#+ Dictionary)]]]
[world
- [file (#+ File)]]]
+ [file (#+ Path)]]]
["." //
- ["." extension]]
- [//synthesis (#+ Synthesis)])
+ [synthesis (#+ Synthesis)]
+ ["." extension]])
(do-template [<name>]
[(exception: #export (<name>)
@@ -61,7 +61,7 @@
(type: #export (Buffer statement) (Row [Name statement]))
-(type: #export (Outputs statement) (Dictionary File (Buffer statement)))
+(type: #export (Outputs statement) (Dictionary Path (Buffer statement)))
(type: #export (State anchor expression statement)
{#context Context
@@ -216,7 +216,7 @@
(def: #export (save-buffer! target)
(All [anchor expression statement]
- (-> File (Operation anchor expression statement Any)))
+ (-> Path (Operation anchor expression statement Any)))
(do //.monad
[buffer ..buffer]
(extension.update (update@ #outputs (dictionary.put target buffer)))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux
new file mode 100644
index 000000000..5d85bfd16
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux
@@ -0,0 +1,70 @@
+(.module:
+ [lux #*
+ [control
+ pipe]
+ [data
+ [text
+ format]]
+ [type (#+ :share)]]
+ [//
+ ["/." //
+ ["//." // ("#/." monad)
+ [synthesis (#+ Synthesis)]
+ [//
+ ["." reference (#+ Register Variable Reference)]]]]])
+
+(signature: #export (System expression)
+ (: (-> Register expression)
+ local)
+ (: (-> Register expression)
+ foreign)
+ (: (All [anchor statement]
+ (-> Variable (///.Operation anchor expression statement)))
+ variable)
+ (: (All [anchor statement]
+ (-> Name (///.Operation anchor expression statement)))
+ constant)
+ (: (All [anchor statement]
+ (-> Reference (///.Operation anchor expression statement)))
+ reference))
+
+(def: (variable-maker prefix variable)
+ (All [expression]
+ (-> Text (-> Text expression)
+ (-> Register expression)))
+ (|>> .int %i (format prefix) variable))
+
+(def: #export (system constant variable)
+ (All [expression]
+ (-> (-> Text expression) (-> Text expression)
+ (System expression)))
+ (let [local (variable-maker "l" variable)
+ foreign (variable-maker "f" variable)
+ variable (:share [expression]
+ {(-> Text expression)
+ variable}
+ {(All [anchor statement]
+ (-> Variable (///.Operation anchor expression statement)))
+ (|>> (case> (#reference.Local register)
+ (local register)
+
+ (#reference.Foreign register)
+ (foreign register))
+ /////wrap)})
+ constant (:share [expression]
+ {(-> Text expression)
+ constant}
+ {(All [anchor statement]
+ (-> Name (///.Operation anchor expression statement)))
+ (|>> ///.remember (/////map constant))})]
+ (structure
+ (def: local local)
+ (def: foreign foreign)
+ (def: variable variable)
+ (def: constant constant)
+ (def: reference
+ (|>> (case> (#reference.Constant value)
+ (constant value)
+
+ (#reference.Variable value)
+ (variable value)))))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
new file mode 100644
index 000000000..d99eec0e9
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux
@@ -0,0 +1,53 @@
+(.module:
+ [lux (#- int)
+ [control
+ [pipe (#+ cond> new>)]]
+ [data
+ [number
+ ["." i64]
+ ["." frac]]
+ [text
+ format]]
+ [host
+ ["_" js (#+ Expression)]]]
+ [//
+ ["//." runtime (#+ Operation)]
+ [//
+ ["//." // ("#/." monad)]]])
+
+(def: #export bit
+ (-> Bit (Operation Expression))
+ (|>> _.boolean /////wrap))
+
+(def: high
+ (-> Int Int)
+ (i64.logic-right-shift 32))
+
+(def: low
+ (-> Int Int)
+ (let [mask (dec (i64.left-shift 32 1))]
+ (|>> (i64.and mask))))
+
+(def: #export (int value)
+ (-> Int (Operation Expression))
+ (/////wrap (//runtime.i64//new (|> value ..high _.i32)
+ (|> value ..low _.i32))))
+
+(def: #export frac
+ (-> Frac (Operation Expression))
+ (|>> (cond> [(f/= frac.positive-infinity)]
+ [(new> _.positive-infinity [])]
+
+ [(f/= frac.negative-infinity)]
+ [(new> _.negative-infinity [])]
+
+ [(f/= frac.not-a-number)]
+ [(new> _.not-a-number [])]
+
+ ## else
+ [_.number])
+ /////wrap))
+
+(def: #export text
+ (-> Text (Operation Expression))
+ (|>> _.string /////wrap))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux
new file mode 100644
index 000000000..0e4cd1489
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux
@@ -0,0 +1,12 @@
+(.module:
+ [lux #*
+ [host
+ ["_" js (#+ Expression)]]]
+ [//
+ [//
+ [common
+ ["." reference]]]])
+
+(def: #export system
+ (reference.system (: (-> Text Expression) _.var)
+ (: (-> Text Expression) _.var)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux
new file mode 100644
index 000000000..c8e86dcb5
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux
@@ -0,0 +1,718 @@
+(.module:
+ [lux #*
+ ["." function]
+ [control
+ [monad (#+ do)]
+ ["p" parser]]
+ [data
+ [number (#+ hex)]
+ ["." text
+ format]
+ [collection
+ ["." list ("#/." functor)]]]
+ ["." macro
+ ["." code]
+ ["s" syntax (#+ syntax:)]]
+ [host
+ ["_" js (#+ Expression Var Computation Statement)]]]
+ ["." ///
+ ["//." //
+ ["." synthesis]]]
+ )
+
+(do-template [<name> <base>]
+ [(type: #export <name>
+ (<base> Var Expression Statement))]
+
+ [Operation ///.Operation]
+ [Phase ///.Phase]
+ [Handler ///.Handler]
+ [Bundle ///.Bundle]
+ )
+
+(type: #export (Generator i)
+ (-> i Phase (Operation Expression)))
+
+(def: prefix Text "LuxRuntime")
+
+(def: #export variant-tag-field "_lux_tag")
+(def: #export variant-flag-field "_lux_flag")
+(def: #export variant-value-field "_lux_value")
+
+(def: #export unit Computation (_.string synthesis.unit))
+
+(def: #export (flag value)
+ (-> Bit Computation)
+ (if value
+ (_.string "")
+ _.null))
+
+(def: #export (variant tag last? value)
+ (-> Expression Expression Expression Computation)
+ (_.object (list [..variant-tag-field tag]
+ [..variant-flag-field last?]
+ [..variant-value-field value])))
+
+(def: none
+ Computation
+ (..variant (_.i32 +0) (flag #0) unit))
+
+(def: some
+ (-> Expression Computation)
+ (..variant (_.i32 +1) (flag #1)))
+
+(def: left
+ (-> Expression Computation)
+ (..variant (_.i32 +0) (flag #0)))
+
+(def: right
+ (-> Expression Computation)
+ (..variant (_.i32 +1) (flag #1)))
+
+(def: sanitize
+ (-> Text Text)
+ (|>> (text.replace-all "/" "_SL")
+ (text.replace-all "-" "_DS")
+ (text.replace-all "^" "_CR")
+ (text.replace-all "=" "_EQ")
+ (text.replace-all "+" "_PL")
+ (text.replace-all "*" "_ST")))
+
+(def: variable
+ (-> Text Var)
+ (|>> ..sanitize
+ _.var))
+
+(def: runtime-name
+ (-> Text Var)
+ (|>> ..sanitize
+ (format prefix "$")
+ _.var))
+
+(def: (feature name definition)
+ (-> Var (-> Var Expression) Statement)
+ (_.define name (definition name)))
+
+(syntax: (code-name {definition-name s.local-identifier})
+ (wrap (list (code.local-identifier (format "@" definition-name)))))
+
+(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))}
+ body)
+ (wrap (list (` (let [(~+ (|> vars
+ (list/map (function (_ var)
+ (list (code.local-identifier var)
+ (` (_.var (~ (code.text var)))))))
+ list.concat))]
+ (~ body))))))
+
+(syntax: (runtime: {declaration (p.or s.local-identifier
+ (s.form (p.and s.local-identifier
+ (p.some s.local-identifier))))}
+ code)
+ (case declaration
+ (#.Left name)
+ (macro.with-gensyms [g!_]
+ (let [nameC (code.local-identifier name)
+ code-nameC (code.local-identifier (format "@" name))
+ runtime-nameC (` (runtime-name (~ (code.text name))))]
+ (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC)))
+ (` (def: (~ code-nameC)
+ Statement
+ (..feature (~ runtime-nameC)
+ (function ((~ g!_) (~ nameC))
+ (~ code)))))))))
+
+ (#.Right [name inputs])
+ (macro.with-gensyms [g!_]
+ (let [nameC (code.local-identifier name)
+ code-nameC (code.local-identifier (format "@" name))
+ runtime-nameC (` (runtime-name (~ (code.text name))))
+ inputsC (list/map code.local-identifier inputs)
+ inputs-typesC (list/map (function.constant (` _.Expression)) inputs)]
+ (wrap (list (` (def: #export ((~ nameC) (~+ inputsC))
+ (-> (~+ inputs-typesC) Computation)
+ (_.apply/* (~ runtime-nameC) (list (~+ inputsC)))))
+ (` (def: (~ code-nameC)
+ Statement
+ (..feature (~ runtime-nameC)
+ (function ((~ g!_) (~ g!_))
+ (..with-vars [(~+ inputsC)]
+ (_.function (~ g!_) (list (~+ inputsC))
+ (~ code)))))))))))))
+
+(runtime: (lux//try op)
+ (with-vars [ex]
+ (_.try (_.return (_.apply/1 op ..unit))
+ [ex (_.return (|> ex (_.do "toString" (list))))])))
+
+(def: length (_.the "length"))
+
+(runtime: (lux//program-args)
+ (with-vars [process output idx]
+ (_.if (_.and (_.not (_.= (_.type-of process)
+ _.undefined))
+ (|> process (_.the "argv")))
+ ($_ _.then
+ (_.define output ..none)
+ (_.for idx
+ (|> process (_.the "argv") ..length (_.- (_.i32 +1)))
+ (_.>= (_.i32 +0) idx)
+ (_.-- idx)
+ (_.set output (..some (_.array (list (|> process (_.the "argv") (_.at idx))
+ output)))))
+ (_.return output))
+ (_.return ..none))))
+
+(def: runtime//lux
+ Statement
+ ($_ _.then
+ @lux//try
+ @lux//program-args
+ ))
+
+(runtime: (product//left product index)
+ (with-vars [index-min-length]
+ ($_ _.then
+ (_.define index-min-length (_.+ (_.i32 +1) index))
+ (_.if (_.> index-min-length
+ (..length product))
+ ## No need for recursion.
+ (_.return (_.at index product))
+ ## Needs recursion.
+ (_.return (product//left (_.at (|> product ..length (_.- (_.i32 +1)))
+ product)
+ (_.- (..length product)
+ index-min-length)))
+ ))))
+
+(runtime: (product//right product index)
+ (with-vars [index-min-length]
+ ($_ _.then
+ (_.define index-min-length (_.+ (_.i32 +1) index))
+ (_.cond (list [(_.= index-min-length
+ (..length product))
+ ## Last element.
+ (_.return (_.at index product))]
+ [(_.< index-min-length
+ (..length product))
+ ## Needs recursion.
+ (_.return (product//right (_.at (|> product ..length (_.- (_.i32 +1)))
+ product)
+ (_.- (..length product)
+ index-min-length)))])
+ ## Must slice
+ (_.return (_.do "slice" (list index) product))))))
+
+(runtime: (sum//get sum wanted-tag wants-last)
+ (let [no-match! (_.return _.null)
+ sum-tag (|> sum (_.the ..variant-tag-field))
+ sum-flag (|> sum (_.the ..variant-flag-field))
+ sum-value (|> sum (_.the ..variant-value-field))
+ is-last? (_.= ..unit sum-flag)
+ extact-match! (_.return sum-value)
+ test-recursion! (_.if is-last?
+ ## Must recurse.
+ (_.return (sum//get sum-value (_.- sum-tag wanted-tag) wants-last))
+ no-match!)
+ extrac-sub-variant! (_.return (..variant (_.- wanted-tag sum-tag) sum-flag sum-value))]
+ (_.cond (list [(_.= wanted-tag sum-tag)
+ (_.if (_.= wants-last sum-flag)
+ extact-match!
+ test-recursion!)]
+ [(_.< wanted-tag sum-tag)
+ test-recursion!]
+ [(_.and (_.> wanted-tag sum-tag)
+ (_.= ..unit wants-last))
+ extrac-sub-variant!])
+ no-match!)))
+
+(def: runtime//structure
+ Statement
+ ($_ _.then
+ @product//left
+ @product//right
+ @sum//get
+ ))
+
+(def: #export i64-high-field Text "H")
+(def: #export i64-low-field Text "L")
+
+(runtime: (i64//new high low)
+ (_.return (_.object (list [..i64-high-field high]
+ [..i64-low-field low]))))
+
+(runtime: i64//2^16
+ (_.left-shift (_.i32 +16) (_.i32 +1)))
+
+(runtime: i64//2^32
+ (_.* i64//2^16 i64//2^16))
+
+(runtime: i64//2^64
+ (_.* i64//2^32 i64//2^32))
+
+(runtime: i64//2^63
+ (|> i64//2^64 (_./ (_.i32 +2))))
+
+(runtime: (i64//unsigned-low i64)
+ (_.return (_.? (|> i64 (_.the ..i64-low-field) (_.>= (_.i32 +0)))
+ (|> i64 (_.the ..i64-low-field))
+ (|> i64 (_.the ..i64-low-field) (_.+ i64//2^32)))))
+
+(runtime: (i64//to-number i64)
+ (_.return (|> i64 (_.the ..i64-high-field) (_.* i64//2^32)
+ (_.+ (i64//unsigned-low i64)))))
+
+(runtime: i64//zero
+ (i64//new (_.i32 +0) (_.i32 +0)))
+
+(runtime: i64//min
+ (i64//new (_.i32 (hex "+80000000")) (_.i32 +0)))
+
+(runtime: i64//max
+ (i64//new (_.i32 (hex "+7FFFFFFF")) (_.i32 (hex "+FFFFFFFF"))))
+
+(runtime: i64//one
+ (i64//new (_.i32 +0) (_.i32 +1)))
+
+(runtime: (i64//= left right)
+ (_.return (_.and (_.= (_.the ..i64-high-field left)
+ (_.the ..i64-high-field right))
+ (_.= (_.the ..i64-low-field left)
+ (_.the ..i64-low-field right)))))
+
+(runtime: (i64//+ left right)
+ (let [up-16 (_.left-shift (_.i32 +16))
+ high-16 (_.logic-right-shift (_.i32 +16))
+ low-16 (_.bit-and (_.i32 (hex "+FFFF")))
+ hh (|>> (_.the ..i64-high-field) high-16)
+ hl (|>> (_.the ..i64-high-field) low-16)
+ lh (|>> (_.the ..i64-low-field) high-16)
+ ll (|>> (_.the ..i64-low-field) low-16)]
+ (with-vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.define l48 (hh left))
+ (_.define l32 (hl left))
+ (_.define l16 (lh left))
+ (_.define l00 (ll left))
+
+ (_.define r48 (hh right))
+ (_.define r32 (hl right))
+ (_.define r16 (lh right))
+ (_.define r00 (ll right))
+
+ (_.define x00 (_.+ l00 r00))
+ (_.define x16 (high-16 x00))
+ (_.set x00 (low-16 x00))
+ (_.set x16 (|> x16 (_.+ l16) (_.+ r16)))
+ (_.define x32 (high-16 x16))
+ (_.set x16 (low-16 x16))
+ (_.set x32 (|> x32 (_.+ l32) (_.+ r32)))
+ (_.define x48 (|> (high-16 x32) (_.+ l48) (_.+ r48) low-16))
+ (_.set x32 (low-16 x32))
+
+ (_.return (i64//new (_.bit-or (up-16 x48) x32)
+ (_.bit-or (up-16 x16) x00)))
+ ))))
+
+(do-template [<name> <op>]
+ [(runtime: (<name> left right)
+ (_.return (i64//new (<op> (_.the ..i64-high-field left)
+ (_.the ..i64-high-field right))
+ (<op> (_.the ..i64-low-field left)
+ (_.the ..i64-low-field right)))))]
+
+ [i64//xor _.bit-xor]
+ [i64//or _.bit-or]
+ [i64//and _.bit-and]
+ )
+
+(runtime: (i64//not value)
+ (_.return (i64//new (_.bit-not (_.the ..i64-high-field value))
+ (_.bit-not (_.the ..i64-low-field value)))))
+
+(runtime: (i64//negate value)
+ (_.if (i64//= i64//min value)
+ (_.return i64//min)
+ (_.return (i64//+ (i64//not value) i64//one))))
+
+(runtime: i64//-one
+ (i64//negate i64//one))
+
+(runtime: (i64//from-number value)
+ (_.cond (list [(_.not-a-number? value)
+ (_.return i64//zero)]
+ [(_.<= (_.negate i64//2^63) value)
+ (_.return i64//min)]
+ [(|> value (_.+ (_.i32 +1)) (_.>= i64//2^63))
+ (_.return i64//max)]
+ [(|> value (_.< (_.i32 +0)))
+ (_.return (|> value _.negate i64//from-number i64//negate))])
+ (_.return (i64//new (_./ i64//2^32 value)
+ (_.% i64//2^32 value)))))
+
+(def: (cap-shift! shift)
+ (-> Var Statement)
+ (_.set shift (|> shift (_.bit-and (_.i32 +63)))))
+
+(def: (no-shift! shift input)
+ (-> Var Var [Expression Statement])
+ [(|> shift (_.= (_.i32 +0)))
+ (_.return input)])
+
+(def: small-shift?
+ (-> Var Expression)
+ (|>> (_.< (_.i32 +32))))
+
+(runtime: (i64//left-shift input shift)
+ ($_ _.then
+ (..cap-shift! shift)
+ (_.cond (list (..no-shift! shift input)
+ [(..small-shift? shift)
+ (let [high (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift shift))
+ (|> input (_.the ..i64-low-field) (_.logic-right-shift (_.- shift (_.i32 +32)))))
+ low (|> input (_.the ..i64-low-field) (_.left-shift shift))]
+ (_.return (i64//new high low)))])
+ (let [high (|> input (_.the ..i64-low-field) (_.left-shift (_.- (_.i32 +32) shift)))]
+ (_.return (i64//new high (_.i32 +0)))))))
+
+(runtime: (i64//arithmetic-right-shift input shift)
+ ($_ _.then
+ (..cap-shift! shift)
+ (_.cond (list (..no-shift! shift input)
+ [(..small-shift? shift)
+ (let [high (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift shift))
+ low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift)
+ (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))]
+ (_.return (i64//new high low)))])
+ (let [high (_.? (|> input (_.the ..i64-high-field) (_.>= (_.i32 +0)))
+ (_.i32 +0)
+ (_.i32 -1))
+ low (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift (_.- (_.i32 +32) shift)))]
+ (_.return (i64//new high low))))))
+
+(runtime: (i64//logic-right-shift input shift)
+ ($_ _.then
+ (..cap-shift! shift)
+ (_.cond (list (..no-shift! shift input)
+ [(..small-shift? shift)
+ (let [high (|> input (_.the ..i64-high-field) (_.logic-right-shift shift))
+ low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift)
+ (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))]
+ (_.return (i64//new high low)))]
+ [(|> shift (_.= (_.i32 +32)))
+ (_.return (i64//new (_.i32 +0) (|> input (_.the ..i64-high-field))))])
+ (_.return (i64//new (_.i32 +0)
+ (|> input (_.the ..i64-high-field) (_.logic-right-shift (_.- (_.i32 +32) shift))))))))
+
+(def: runtime//bit
+ Statement
+ ($_ _.then
+ @i64//and
+ @i64//or
+ @i64//xor
+ @i64//not
+ @i64//left-shift
+ @i64//arithmetic-right-shift
+ @i64//logic-right-shift
+ ))
+
+(runtime: (i64//- left right)
+ (_.return (i64//+ left (i64//negate right))))
+
+(runtime: (i64//* left right)
+ (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))]
+ (_.cond (list [(negative? left)
+ (_.if (negative? right)
+ ## Both are negative
+ (_.return (i64//* (i64//negate left) (i64//negate right)))
+ ## Left is negative
+ (_.return (i64//negate (i64//* (i64//negate left) right))))]
+ [(negative? right)
+ ## Right is negative
+ (_.return (i64//negate (i64//* left (i64//negate right))))])
+ ## Both are positive
+ (let [up-16 (_.left-shift (_.i32 +16))
+ high-16 (_.logic-right-shift (_.i32 +16))
+ low-16 (_.bit-and (_.i32 (hex "+FFFF")))
+ hh (|>> (_.the ..i64-high-field) high-16)
+ hl (|>> (_.the ..i64-high-field) low-16)
+ lh (|>> (_.the ..i64-low-field) high-16)
+ ll (|>> (_.the ..i64-low-field) low-16)]
+ (with-vars [l48 l32 l16 l00
+ r48 r32 r16 r00
+ x48 x32 x16 x00]
+ ($_ _.then
+ (_.define l48 (hh left))
+ (_.define l32 (hl left))
+ (_.define l16 (lh left))
+ (_.define l00 (ll left))
+
+ (_.define r48 (hh right))
+ (_.define r32 (hl right))
+ (_.define r16 (lh right))
+ (_.define r00 (ll right))
+
+ (_.define x00 (_.* l00 r00))
+ (_.define x16 (high-16 x00))
+ (_.set x00 (low-16 x00))
+
+ (_.set x16 (|> x16 (_.+ (_.* l16 r00))))
+ (_.define x32 (high-16 x16)) (_.set x16 (low-16 x16))
+ (_.set x16 (|> x16 (_.+ (_.* l00 r16))))
+ (_.set x32 (|> x32 (_.+ (high-16 x16)))) (_.set x16 (low-16 x16))
+
+ (_.set x32 (|> x32 (_.+ (_.* l32 r00))))
+ (_.define x48 (high-16 x32)) (_.set x32 (low-16 x32))
+ (_.set x32 (|> x32 (_.+ (_.* l16 r16))))
+ (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32))
+ (_.set x32 (|> x32 (_.+ (_.* l00 r32))))
+ (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32))
+
+ (_.set x48 (|> x48
+ (_.+ (_.* l48 r00))
+ (_.+ (_.* l32 r16))
+ (_.+ (_.* l16 r32))
+ (_.+ (_.* l00 r48))
+ low-16))
+
+ (_.return (i64//new (_.bit-or (up-16 x48) x32)
+ (_.bit-or (up-16 x16) x00)))
+ ))))))
+
+(runtime: (i64//< left right)
+ (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))]
+ (with-vars [-left? -right?]
+ ($_ _.then
+ (_.define -left? (negative? left))
+ (_.define -right? (negative? right))
+ (_.cond (list [(_.and -left? (_.not right))
+ (_.return _.true)]
+ [(_.and (_.not -left?) right)
+ (_.return _.false)])
+ (_.return (negative? (i64//- left right))))))))
+
+(def: (i64//<= subject param)
+ (-> Expression Expression Expression)
+ (_.or (i64//< subject param)
+ (i64//= subject param)))
+
+(runtime: (i64/// subject parameter)
+ (let [negative? (function (_ value)
+ (i64//< value i64//zero))
+ valid-division-check [(i64//= i64//zero parameter)
+ (_.throw (_.string "Cannot divide by zero!"))]
+ short-circuit-check [(i64//= i64//zero subject)
+ (_.return i64//zero)]]
+ (_.cond (list valid-division-check
+ short-circuit-check
+
+ [(i64//= i64//min subject)
+ (_.cond (list [(_.or (i64//= i64//one parameter)
+ (i64//= i64//-one parameter))
+ (_.return i64//min)]
+ [(i64//= i64//min parameter)
+ (_.return i64//one)])
+ (with-vars [approximation]
+ ($_ _.then
+ (_.define approximation (i64//left-shift (i64/// (i64//arithmetic-right-shift subject (_.i32 +1))
+ parameter)
+ (_.i32 +1)))
+ (_.if (i64//= i64//zero approximation)
+ (_.return (_.? (negative? parameter)
+ i64//one
+ i64//-one))
+ (let [remainder (i64//- subject
+ (i64//* parameter
+ approximation))
+ result (i64//+ approximation
+ (i64/// remainder
+ parameter))]
+ (_.return result))))))]
+ [(i64//= i64//min parameter)
+ (_.return i64//zero)]
+
+ [(negative? subject)
+ (_.return (_.? (negative? parameter)
+ (i64/// (i64//negate subject)
+ (i64//negate parameter))
+ (i64//negate (i64/// (i64//negate subject)
+ parameter))))]
+
+ [(negative? parameter)
+ (_.return (i64//negate (i64/// subject (i64//negate parameter))))])
+ (with-vars [result remainder]
+ ($_ _.then
+ (_.define result i64//zero)
+ (_.define remainder subject)
+ (_.while (i64//<= remainder parameter)
+ (with-vars [approximate approximate-result approximate-remainder log2 delta]
+ (let [rough-estimate (|> (i64//to-number remainder)
+ (_./ (i64//to-number parameter))
+ (_.apply/1 (_.var "Math.floor")))
+ approximate-result' (i64//from-number approximate)
+ approx-remainder (i64//* approximate-result parameter)]
+ ($_ _.then
+ (_.define approximate (_.apply/2 (_.var "Math.max") (_.i32 +1) rough-estimate))
+ (_.define log2 (|> approximate
+ (_.apply/1 (_.var "Math.log"))
+ (_./ (_.var "Math.LN2"))
+ (_.apply/1 (_.var "Math.ceil"))))
+ (_.define delta (_.? (_.<= (_.i32 +48) log2)
+ (_.i32 +1)
+ (_.apply/2 (_.var "Math.pow")
+ (_.i32 +2)
+ (_.- (_.i32 +48)
+ log2))))
+ (_.define approximate-result approximate-result')
+ (_.define approximate-remainder approx-remainder)
+ (_.while (_.or (negative? approximate-remainder)
+ (i64//< remainder
+ approximate-remainder))
+ ($_ _.then
+ (_.set approximate (_.- delta approximate))
+ (_.set approximate-result approximate-result')
+ (_.set approximate-remainder approx-remainder)))
+ (_.set result (i64//+ result
+ (_.? (i64//= i64//zero approximate-result)
+ i64//one
+ approximate-result)))
+ (_.set remainder (i64//- remainder approximate-remainder))))))
+ (_.return result)))
+ )))
+
+(runtime: (i64//% subject parameter)
+ (let [flat (i64//* (i64/// subject parameter)
+ parameter)]
+ (_.return (i64//- subject flat))))
+
+(def: runtime//i64
+ Statement
+ ($_ _.then
+ @i64//2^16
+ @i64//2^32
+ @i64//2^64
+ @i64//2^63
+ @i64//unsigned-low
+ @i64//zero
+ @i64//new
+ @i64//min
+ @i64//max
+ @i64//one
+ @i64//=
+ @i64//+
+ @i64//negate
+ @i64//to-number
+ @i64//from-number
+ @i64//-
+ @i64//*
+ @i64//<
+ @i64///
+ @i64//%
+ runtime//bit
+ ))
+
+(runtime: (text//index text part start)
+ (with-vars [idx]
+ ($_ _.then
+ (_.define idx (|> text (_.do "indexOf" (list part (i64//to-number start)))))
+ (_.if (_.= (_.i32 -1) idx)
+ (_.return ..none)
+ (_.return (..some (i64//from-number idx)))))))
+
+(runtime: (text//clip text start end)
+ (let [out-of-bounds? (|>> (_.the ..i64-low-field) (_.> (..length text)))]
+ (_.if (_.or (out-of-bounds? start)
+ (out-of-bounds? end))
+ (_.return ..none)
+ (_.return (..some (|> text (_.do "substring" (list (_.the ..i64-low-field start)
+ (_.the ..i64-low-field end)))))))))
+
+(runtime: (text//char text idx)
+ (with-vars [result]
+ ($_ _.then
+ (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64-low-field idx)))))
+ (_.if (_.not-a-number? result)
+ (_.return ..none)
+ (_.return (..some (i64//from-number result)))))))
+
+(def: runtime//text
+ Statement
+ ($_ _.then
+ @text//index
+ @text//clip
+ @text//char
+ ))
+
+(runtime: (io//log message)
+ (with-vars [console print]
+ (let [end! (_.return ..unit)]
+ (_.cond (list [(|> console _.type-of (_.= _.undefined) _.not
+ (_.and (_.the "log" console)))
+ ($_ _.then
+ (_.statement (|> console (_.do "log" (list message))))
+ end!)]
+ [(|> print _.type-of (_.= _.undefined) _.not)
+ ($_ _.then
+ (_.statement (_.apply/1 print message))
+ end!)])
+ end!))))
+
+(runtime: (io//error message)
+ (_.throw message))
+
+(def: runtime//io
+ Statement
+ ($_ _.then
+ @io//log
+ @io//error
+ ))
+
+(runtime: (js//get object field)
+ (with-vars [temp]
+ (_.if (|> temp (_.= _.undefined) _.not)
+ (_.return (..some temp))
+ (_.return ..none))))
+
+(runtime: (js//set object field input)
+ ($_ _.then
+ (_.set (_.at field object) input)
+ (_.return object)))
+
+(runtime: (js//delete object field)
+ ($_ _.then
+ (_.delete (_.at field object))
+ (_.return object)))
+
+(runtime: (js//call object method inputs)
+ (_.return (_.apply/2 (_.at method object) object inputs)))
+
+(def: runtime//js
+ Statement
+ ($_ _.then
+ @js//get
+ @js//set
+ @js//delete
+ @js//call
+ ))
+
+(def: runtime
+ Statement
+ ($_ _.then
+ runtime//lux
+ runtime//structure
+ runtime//i64
+ runtime//text
+ runtime//io
+ runtime//js
+ ))
+
+(def: #export artifact Text (format prefix ".js"))
+
+(def: #export translate
+ (Operation Any)
+ (///.with-buffer
+ (do ////.monad
+ [_ (///.save! ["" ..prefix] ..runtime)]
+ (///.save-buffer! ..artifact))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux
new file mode 100644
index 000000000..4949ddacf
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux
@@ -0,0 +1,32 @@
+(.module:
+ [lux #*
+ [control
+ ["." monad (#+ do)]]
+ [host
+ ["_" js (#+ Expression)]]]
+ [//
+ ["//." runtime (#+ Generator)]
+ ["//." primitive]
+ ["//." ///
+ [analysis (#+ Variant Tuple)]
+ ["." synthesis (#+ Synthesis)]]])
+
+(def: #export (tuple elemsS+ translate)
+ (Generator (Tuple Synthesis))
+ (case elemsS+
+ #.Nil
+ (//primitive.text synthesis.unit)
+
+ (#.Cons singletonS #.Nil)
+ (translate singletonS)
+
+ _
+ (do /////.monad
+ [elemsT+ (monad.map @ translate elemsS+)]
+ (wrap (_.array elemsT+)))))
+
+(def: #export (variant [lefts right? valueS] translate)
+ (Generator (Variant Synthesis))
+ (do /////.monad
+ [valueT (translate valueS)]
+ (wrap (//runtime.variant (_.i32 (.int lefts)) (//runtime.flag right?) valueT))))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
index dc643bcbc..86bf44c0f 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux
@@ -1,25 +1,19 @@
(.module:
- [lux (#- i64)]
+ [lux (#- i64)
+ [host
+ ["_" scheme (#+ Expression)]]]
[//
[runtime (#+ Operation)]
- [// (#+ State)
- ["//." // ("#/." monad)
- [///
- [host
- ["_" scheme (#+ Expression)]]]]]])
+ [//
+ ["//." // ("#/." monad)]]])
-(def: #export bit
- (-> Bit (Operation Expression))
- (|>> _.bool /////wrap))
+(do-template [<name> <type> <code>]
+ [(def: #export <name>
+ (-> <type> (Operation Expression))
+ (|>> <code> /////wrap))]
-(def: #export i64
- (-> (I64 Any) (Operation Expression))
- (|>> .int _.int /////wrap))
-
-(def: #export f64
- (-> Frac (Operation Expression))
- (|>> _.float /////wrap))
-
-(def: #export text
- (-> Text (Operation Expression))
- (|>> _.string /////wrap))
+ [bit Bit _.bool]
+ [i64 Int _.int]
+ [f64 Frac _.float]
+ [text Text _.string]
+ )
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux
index 161d2adea..b28cb1898 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux
@@ -1,48 +1,12 @@
(.module:
[lux #*
- [control
- pipe]
- [data
- [text
- format]]]
+ [host
+ ["_" scheme (#+ Expression)]]]
[//
- [runtime (#+ Operation)]
- ["/." //
- ["//." // ("#/." monad)
- [analysis (#+ Variant Tuple)]
- [synthesis (#+ Synthesis)]
- [//
- ["." reference (#+ Register Variable Reference)]
- [//
- [host
- ["_" scheme (#+ Expression Global Var)]]]]]]])
+ [//
+ [common
+ ["." reference]]]])
-(do-template [<name> <prefix>]
- [(def: #export <name>
- (-> Register Var)
- (|>> .int %i (format <prefix>) _.var))]
-
- [local' "l"]
- [foreign' "f"]
- )
-
-(def: #export variable
- (-> Variable (Operation Var))
- (|>> (case> (#reference.Local register)
- (local' register)
-
- (#reference.Foreign register)
- (foreign' register))
- /////wrap))
-
-(def: #export constant
- (-> Name (Operation Global))
- (|>> ///.remember (/////map _.global)))
-
-(def: #export reference
- (-> Reference (Operation Expression))
- (|>> (case> (#reference.Constant value)
- (..constant value)
-
- (#reference.Variable value)
- (..variable value))))
+(def: #export system
+ (reference.system (: (-> Text Expression) _.global)
+ (: (-> Text Expression) _.var)))
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux
index d254e8c7d..904f40726 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux
@@ -1,5 +1,6 @@
(.module:
[lux #*
+ ["." function]
[control
["p" parser ("#/." monad)]
[monad (#+ do)]]
@@ -9,19 +10,17 @@
format]
[collection
["." list ("#/." monad)]]]
- ["." function]
[macro
["." code]
- ["s" syntax (#+ syntax:)]]]
+ ["s" syntax (#+ syntax:)]]
+ [host
+ ["_" scheme (#+ Expression Computation Var)]]]
["." ///
["//." //
[analysis (#+ Variant)]
["." synthesis]
[//
- ["." name]
- [//
- [host
- ["_" scheme (#+ Expression Computation Var)]]]]]])
+ ["." name]]]])
(do-template [<name> <base>]
[(type: #export <name>
diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
index dc1b88591..aa4742fb1 100644
--- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux
@@ -1,16 +1,15 @@
(.module:
[lux #*
[control
- ["." monad (#+ do)]]]
+ ["." monad (#+ do)]]
+ [host
+ ["_" scheme (#+ Expression)]]]
[//
["." runtime (#+ Operation Phase)]
["." primitive]
["." ///
[analysis (#+ Variant Tuple)]
- ["." synthesis (#+ Synthesis)]
- [///
- [host
- ["_" scheme (#+ Expression)]]]]])
+ ["." synthesis (#+ Synthesis)]]])
(def: #export (tuple translate elemsS+)
(-> Phase (Tuple Synthesis) (Operation Expression))