aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2018-02-23 23:10:28 -0400
committerEduardo Julian2018-02-23 23:10:28 -0400
commit0bd93d82eb7a50b9ce8be42800c388e87e6ca9bf (patch)
tree847453417dbf6bf76be82efd498074029162d38b /new-luxc/source
parentc8e2898611fa759cbe7c2ac84738b5b403575664 (diff)
- Added a code-generation utility module for JS.
Diffstat (limited to 'new-luxc/source')
-rw-r--r--new-luxc/source/luxc/lang/host/js.lux106
-rw-r--r--new-luxc/source/luxc/lang/translation/js.lux9
-rw-r--r--new-luxc/source/luxc/lang/translation/js/case.jvm.lux43
-rw-r--r--new-luxc/source/luxc/lang/translation/js/eval.jvm.lux5
-rw-r--r--new-luxc/source/luxc/lang/translation/js/expression.jvm.lux5
-rw-r--r--new-luxc/source/luxc/lang/translation/js/function.jvm.lux11
-rw-r--r--new-luxc/source/luxc/lang/translation/js/loop.jvm.lux11
-rw-r--r--new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux15
-rw-r--r--new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux7
-rw-r--r--new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux23
-rw-r--r--new-luxc/source/luxc/lang/translation/js/reference.jvm.lux13
-rw-r--r--new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux235
-rw-r--r--new-luxc/source/luxc/lang/translation/js/statement.jvm.lux7
-rw-r--r--new-luxc/source/luxc/lang/translation/js/structure.jvm.lux7
14 files changed, 318 insertions, 179 deletions
diff --git a/new-luxc/source/luxc/lang/host/js.lux b/new-luxc/source/luxc/lang/host/js.lux
new file mode 100644
index 000000000..b4c5acd58
--- /dev/null
+++ b/new-luxc/source/luxc/lang/host/js.lux
@@ -0,0 +1,106 @@
+(.module:
+ [lux #- or and function]
+ (lux (data [text]
+ text/format
+ (coll [list "list/" Functor<List> Fold<List>]))))
+
+(type: #export JS Text)
+
+(type: #export Expression JS)
+
+(type: #export Statement JS)
+
+(def: #export (number value)
+ (-> Frac Expression)
+ (%f value))
+
+(def: #export (string value)
+ (-> Text Expression)
+ (%t value))
+
+(def: #export (apply func args)
+ (-> Expression (List Expression) Expression)
+ (format func "(" (text.join-with "," args) ")"))
+
+(def: #export (var! name value)
+ (-> Text (Maybe Expression) Statement)
+ (case value
+ #.None
+ (format "var " name ";")
+
+ (#.Some value)
+ (format "var " name " = " value ";")))
+
+(def: #export (set! name value)
+ (-> Text Expression Statement)
+ (format name " = " value ";"))
+
+(def: #export (if! test then! else!)
+ (-> Expression Statement Statement Statement)
+ (format "if(" test ") "
+ then!
+ " else "
+ else!))
+
+(def: #export (cond! clauses else!)
+ (-> (List [Expression Statement]) Statement Statement)
+ (list/fold (.function [[test then!] next!]
+ (if! test then! next!))
+ else!
+ clauses))
+
+(def: #export (block! statements)
+ (-> (List Statement) Statement)
+ (format "{" (text.join-with "" statements) "}"))
+
+(def: #export (while! test body)
+ (-> Expression (List Statement) Statement)
+ (format "while(" test ") " (block! body)))
+
+(def: #export (throw! message)
+ (-> Expression Statement)
+ (format "throw Error(" message ");"))
+
+(def: #export (return! value)
+ (-> Expression Statement)
+ (format "return " value ";"))
+
+(def: #export (function name args body)
+ (-> Text (List Text) (List Statement) Expression)
+ (let [args (format "(" (text.join-with ", " args) ")")
+ function (format "function " name args " " (block! body))]
+ (format "(" function ")")))
+
+(def: #export (? test then else)
+ (-> Expression Expression Expression Expression)
+ (format "(" test " ? " then " : " else ")"))
+
+(def: #export (object fields)
+ (-> (List [Text Expression]) Expression)
+ (format "{"
+ (|> fields
+ (list/map (.function [[key val]]
+ (format key ": " val)))
+ (text.join-with ", "))
+ "}"))
+
+(do-template [<name> <op>]
+ [(def: #export (<name> param subject)
+ (-> Expression Expression Expression)
+ (format "(" subject " " <op> " " param ")"))]
+
+ [= "="]
+ [< "<"]
+ [<= "<="]
+ [> ">"]
+ [>= ">="]
+ [+ "+"]
+ [- "-"]
+ [* "*"]
+ [/ "/"]
+ [% "%"]
+ [or "||"]
+ [and "&&"]
+ [bit-or "|"]
+ [bit-and "&"]
+ )
diff --git a/new-luxc/source/luxc/lang/translation/js.lux b/new-luxc/source/luxc/lang/translation/js.lux
index a28d9c3db..063c01e25 100644
--- a/new-luxc/source/luxc/lang/translation/js.lux
+++ b/new-luxc/source/luxc/lang/translation/js.lux
@@ -14,15 +14,10 @@
[host #+ class: interface: object]
(world [file #+ File]))
(luxc [lang]
- (lang [".L" variable #+ Register])
+ (lang [".L" variable #+ Register]
+ (host [js #+ JS Expression Statement]))
[".C" io]))
-(type: #export JS Text)
-
-(type: #export Expression JS)
-
-(type: #export Statement JS)
-
(host.import java/lang/Object
(toString [] String))
diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
index cbb0e6c77..7c624c102 100644
--- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux
@@ -6,15 +6,16 @@
(coll [list "list/" Fold<List>]))
[macro #+ "meta/" Monad<Meta>])
(luxc [lang]
- (lang ["ls" synthesis]))
+ (lang ["ls" synthesis]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" runtime]
[".T" primitive]
[".T" reference]))
(def: #export (translate-let translate register valueS bodyS)
- (-> (-> ls.Synthesis (Meta //.Expression)) Nat ls.Synthesis ls.Synthesis
- (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis
+ (Meta Expression))
(do macro.Monad<Meta>
[valueJS (translate valueS)
bodyJS (translate bodyS)]
@@ -24,8 +25,8 @@
"})()"))))
(def: #export (translate-record-get translate valueS path)
- (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis (List [Nat Bool])
- (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool])
+ (Meta Expression))
(do macro.Monad<Meta>
[valueJS (translate valueS)]
(wrap (list/fold (function [[idx tail?] source]
@@ -35,50 +36,50 @@
path))))
(def: #export (translate-if testJS thenJS elseJS)
- (-> //.Expression //.Expression //.Expression
- //.Expression)
+ (-> Expression Expression Expression
+ Expression)
(format "(" testJS " ? " thenJS " : " elseJS ")"))
(def: savepoint
- //.Expression
+ Expression
"pm_cursor_savepoint")
(def: cursor
- //.Expression
+ Expression
"pm_cursor")
(def: (push-cursor value)
- (-> //.Expression //.Expression)
+ (-> Expression Expression)
(format cursor ".push(" value ");"))
(def: save-cursor
- //.Statement
+ Statement
(format savepoint ".push(" cursor ".slice());"))
(def: restore-cursor
- //.Statement
+ Statement
(format cursor " = " savepoint ".pop();"))
(def: peek-cursor
- //.Expression
+ Expression
(format cursor "[" cursor ".length - 1]"))
(def: pop-cursor
- //.Statement
+ Statement
(format cursor ".pop();"))
(def: pm-error
- //.Expression
+ Expression
(%t "PM-ERROR"))
(def: fail-pattern-matching
- //.Statement
+ Statement
(format "throw " pm-error ";"))
(exception: #export Unrecognized-Path)
(def: (translate-pattern-matching' translate path)
- (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
(case path
(^code ("lux case exec" (~ bodyS)))
(do macro.Monad<Meta>
@@ -154,7 +155,7 @@
))
(def: report-pattern-matching-error
- //.Statement
+ Statement
(format "if(ex === " pm-error ") {"
"throw \"Invalid expression for pattern-matching.\";"
"}"
@@ -163,7 +164,7 @@
"}"))
(def: (translate-pattern-matching translate path)
- (-> (-> ls.Synthesis (Meta //.Expression)) Code (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression))
(do macro.Monad<Meta>
[pmJS (translate-pattern-matching' translate path)]
(wrap (format "try {" pmJS "}"
@@ -172,13 +173,13 @@
"}"))))
(def: (initialize-pattern-matching stack-init)
- (-> //.Expression //.Statement)
+ (-> Expression Statement)
(format "var temp;"
"var " cursor " = [" stack-init "];"
"var " savepoint " = [];"))
(def: #export (translate-case translate valueS path)
- (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis Code (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression))
(do macro.Monad<Meta>
[valueJS (translate valueS)
pmJS (translate-pattern-matching translate path)]
diff --git a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
index 50cfe833c..d4546ca4c 100644
--- a/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/eval.jvm.lux
@@ -7,7 +7,8 @@
text/format
(coll [array]))
[host])
- (luxc [lang])
+ (luxc [lang]
+ (lang (host [js #+ JS Expression Statement])))
[//])
(host.import java/lang/Object
@@ -154,7 +155,7 @@
(exception: #export Cannot-Evaluate)
(def: #export (eval code)
- (-> //.Expression (Meta Top))
+ (-> Expression (Meta Top))
(function [compiler]
(case (|> compiler
(get@ #.host)
diff --git a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
index 1bde82766..9fbaca3d2 100644
--- a/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/expression.jvm.lux
@@ -10,7 +10,8 @@
(luxc ["&" lang]
(lang [".L" variable #+ Variable Register]
[".L" extension]
- ["ls" synthesis]))
+ ["ls" synthesis]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" runtime]
[".T" primitive]
@@ -25,7 +26,7 @@
(exception: #export Unrecognized-Synthesis)
(def: #export (translate synthesis)
- (-> ls.Synthesis (Meta //.Expression))
+ (-> ls.Synthesis (Meta Expression))
(case synthesis
(^code [])
(:: macro.Monad<Meta> wrap runtimeT.unit)
diff --git a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux b/new-luxc/source/luxc/lang/translation/js/function.jvm.lux
index b0865a16e..b3c6761cd 100644
--- a/new-luxc/source/luxc/lang/translation/js/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/function.jvm.lux
@@ -7,13 +7,14 @@
[macro])
(luxc ["&" lang]
(lang ["ls" synthesis]
- [".L" variable #+ Variable]))
+ [".L" variable #+ Variable]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" reference]
[".T" loop]))
(def: #export (translate-apply translate functionS argsS+)
- (-> (-> ls.Synthesis (Meta //.Expression)) ls.Synthesis (List ls.Synthesis) (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List ls.Synthesis) (Meta Expression))
(do macro.Monad<Meta>
[functionJS (translate functionS)
argsJS+ (monad.map @ translate argsS+)]
@@ -23,7 +24,7 @@
(format "var " (referenceT.variable (n/inc register)) " = arguments[" (|> register nat-to-int %i) "];"))
(def: (with-closure inits function)
- (-> (List //.Expression) //.Expression //.Expression)
+ (-> (List Expression) Expression Expression)
(let [closure (case inits
#.Nil
(list)
@@ -36,9 +37,9 @@
";})(" (text.join-with "," inits) ")")))
(def: #export (translate-function translate env arity bodyS)
- (-> (-> ls.Synthesis (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression))
(List Variable) ls.Arity ls.Synthesis
- (Meta //.Expression))
+ (Meta Expression))
(do macro.Monad<Meta>
[[function-name bodyJS] (//.with-sub-context
(do @
diff --git a/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux
index 9315508e8..657982556 100644
--- a/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/loop.jvm.lux
@@ -6,13 +6,14 @@
(coll [list "list/" Functor<List>]))
[macro])
(luxc [lang]
- (lang ["ls" synthesis]))
+ (lang ["ls" synthesis]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" reference]))
(def: #export (translate-loop translate offset initsS+ bodyS)
- (-> (-> ls.Synthesis (Meta //.Expression)) Nat (List ls.Synthesis) ls.Synthesis
- (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) Nat (List ls.Synthesis) ls.Synthesis
+ (Meta Expression))
(do macro.Monad<Meta>
[loop-name (:: @ map (|>> %code lang.normalize-name)
(macro.gensym "loop"))
@@ -26,8 +27,8 @@
"})(" (text.join-with "," initsJS+) ")"))))
(def: #export (translate-recur translate argsS+)
- (-> (-> ls.Synthesis (Meta //.Expression)) (List ls.Synthesis)
- (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) (List ls.Synthesis)
+ (Meta Expression))
(do macro.Monad<Meta>
[[loop-name offset] //.anchor
argsJS+ (monad.map @ translate argsS+)]
diff --git a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux
index 860cc7fae..2e1bf8389 100644
--- a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux
@@ -6,16 +6,17 @@
text/format)
[macro "meta/" Monad<Meta>])
[//]
- (// [".T" runtime]))
+ (// [".T" runtime])
+ (luxc (lang (host [js #+ JS Expression Statement]))))
(def: #export translate-bool
- (-> Bool (Meta //.Expression))
+ (-> Bool (Meta Expression))
(|>> %b meta/wrap))
(def: low-mask Nat (n/dec (bit.shift-left +32 +1)))
(def: #export (translate-nat value)
- (-> Nat (Meta //.Expression))
+ (-> Nat (Meta Expression))
(let [high (|> value
(bit.shift-right +32)
nat-to-int %i)
@@ -25,7 +26,7 @@
(meta/wrap (format runtimeT.int//new "(" high "," low ")"))))
(def: #export translate-int
- (-> Int (Meta //.Expression))
+ (-> Int (Meta Expression))
(|>> int-to-nat translate-nat))
(def: deg-to-nat
@@ -33,11 +34,11 @@
(|>> (:! Nat)))
(def: #export translate-deg
- (-> Deg (Meta //.Expression))
+ (-> Deg (Meta Expression))
(|>> deg-to-nat translate-nat))
(def: #export translate-frac
- (-> Frac (Meta //.Expression))
+ (-> Frac (Meta Expression))
(|>> (cond> [(f/= number.positive-infinity)]
[(new> "Infinity")]
@@ -52,5 +53,5 @@
meta/wrap))
(def: #export translate-text
- (-> Text (Meta //.Expression))
+ (-> Text (Meta Expression))
(|>> %t meta/wrap))
diff --git a/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux
index 66c7fe6f5..afedc42e0 100644
--- a/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/procedure.jvm.lux
@@ -6,7 +6,8 @@
text/format
(coll [dict])))
(luxc ["&" lang]
- (lang ["ls" synthesis]))
+ (lang ["ls" synthesis]
+ (host [js #+ JS Expression Statement])))
[//]
(/ ["/." common]
["/." host]))
@@ -19,8 +20,8 @@
(dict.merge /host.procedures)))
(def: #export (translate-procedure translate name args)
- (-> (-> ls.Synthesis (Meta //.Expression)) Text (List ls.Synthesis)
- (Meta //.Expression))
+ (-> (-> ls.Synthesis (Meta Expression)) Text (List ls.Synthesis)
+ (Meta Expression))
(<| (maybe.default (&.throw Unknown-Procedure (%t name)))
(do maybe.Monad<Maybe>
[proc (dict.get name procedures)]
diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
index efef6084c..49bf7fe27 100644
--- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
@@ -14,7 +14,8 @@
[host])
(luxc ["&" lang]
(lang ["la" analysis]
- ["ls" synthesis]))
+ ["ls" synthesis]
+ (host [js #+ JS Expression Statement])))
[///]
(/// [".T" runtime]
[".T" case]
@@ -23,10 +24,10 @@
## [Types]
(type: #export Translator
- (-> ls.Synthesis (Meta ///.Expression)))
+ (-> ls.Synthesis (Meta Expression)))
(type: #export Proc
- (-> Translator (List ls.Synthesis) (Meta ///.Expression)))
+ (-> Translator (List ls.Synthesis) (Meta Expression)))
(type: #export Bundle
(Dict Text Proc))
@@ -34,11 +35,11 @@
(syntax: (Vector [size s.nat] elemT)
(wrap (list (` [(~+ (list.repeat size elemT))]))))
-(type: #export Nullary (-> (Vector +0 ///.Expression) ///.Expression))
-(type: #export Unary (-> (Vector +1 ///.Expression) ///.Expression))
-(type: #export Binary (-> (Vector +2 ///.Expression) ///.Expression))
-(type: #export Trinary (-> (Vector +3 ///.Expression) ///.Expression))
-(type: #export Variadic (-> (List ///.Expression) ///.Expression))
+(type: #export Nullary (-> (Vector +0 Expression) Expression))
+(type: #export Unary (-> (Vector +1 Expression) Expression))
+(type: #export Binary (-> (Vector +2 Expression) Expression))
+(type: #export Trinary (-> (Vector +3 Expression) Expression))
+(type: #export Variadic (-> (List Expression) Expression))
## [Utils]
(def: #export (install name unnamed)
@@ -64,7 +65,7 @@
(do @
[g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
(wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc))
- (-> (-> (..Vector (~ (code.nat arity)) ///.Expression) ///.Expression)
+ (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression)
(-> Text ..Proc))
(function [(~ g!name)]
(function [(~ g!translate) (~ g!inputs)]
@@ -94,11 +95,11 @@
(wrap (proc inputsI))))))
(def: (self-contained content)
- (-> ///.Expression ///.Expression)
+ (-> Expression Expression)
(format "(" content ")"))
(def: (void action)
- (-> ///.Expression ///.Expression)
+ (-> Expression Expression)
(format "(" action "," runtimeT.unit ")"))
## [Procedures]
diff --git a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
index d9e508193..0c5cc3a44 100644
--- a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux
@@ -4,32 +4,33 @@
(data [text]
text/format))
(luxc ["&" lang]
- (lang [".L" variable #+ Variable Register]))
+ (lang [".L" variable #+ Variable Register]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" runtime]))
(do-template [<register> <translation> <prefix>]
[(def: #export (<register> register)
- (-> Register //.Expression)
+ (-> Register Expression)
(format <prefix> (%i (nat-to-int register))))
(def: #export (<translation> register)
- (-> Register (Meta //.Expression))
+ (-> Register (Meta Expression))
(:: macro.Monad<Meta> wrap (<register> register)))]
[closure translate-captured "c"]
[variable translate-local "v"])
(def: #export (translate-variable var)
- (-> Variable (Meta //.Expression))
+ (-> Variable (Meta Expression))
(if (variableL.captured? var)
(translate-captured (variableL.captured-register var))
(translate-local (int-to-nat var))))
(def: #export global
- (-> Ident //.Expression)
+ (-> Ident Expression)
//.definition-name)
(def: #export (translate-definition name)
- (-> Ident (Meta //.Expression))
+ (-> Ident (Meta Expression))
(:: macro.Monad<Meta> wrap (global name)))
diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
index 70f648be1..f002ccd1f 100644
--- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
@@ -6,54 +6,53 @@
(macro [code]
["s" syntax #+ syntax:])
[io #+ Process])
- [//])
+ [//]
+ (luxc (lang (host [js #+ JS Expression Statement]))))
(def: prefix Text "LuxRuntime")
-(def: #export unit //.Expression (%t //.unit))
+(def: #export unit Expression (%t //.unit))
(def: (flag value)
- (-> Bool //.JS)
+ (-> Bool JS)
(if value
(%t "")
"null"))
-(def: (variant-js tag last? value)
- (-> //.Expression //.Expression //.Expression //.Expression)
- (format "{"
- //.variant-tag-field ": " tag ","
- //.variant-flag-field ": " last? ","
- //.variant-value-field ": " value
- "}"))
+(def: (variant' tag last? value)
+ (-> Expression Expression Expression Expression)
+ (js.object (list [//.variant-tag-field tag]
+ [//.variant-flag-field last?]
+ [//.variant-value-field value])))
(def: #export (variant tag last? value)
- (-> Nat Bool //.Expression //.Expression)
- (variant-js (%i (nat-to-int tag)) (flag last?) value))
+ (-> Nat Bool Expression Expression)
+ (variant' (%i (nat-to-int tag)) (flag last?) value))
(def: none
- //.Expression
+ Expression
(variant +0 false unit))
(def: some
- (-> //.Expression //.Expression)
+ (-> Expression Expression)
(variant +1 true))
(def: left
- (-> //.Expression //.Expression)
+ (-> Expression Expression)
(variant +0 false))
(def: right
- (-> //.Expression //.Expression)
+ (-> Expression Expression)
(variant +1 true))
-(type: Runtime //.JS)
+(type: Runtime JS)
(def: (runtime-name name)
(-> Text Text)
(format prefix "$" name))
(def: (feature name definition)
- (-> Text (-> Text //.Expression) //.Statement)
+ (-> Text (-> Text Expression) Statement)
(format "var " name " = " (definition name) ";\n"))
(syntax: (runtime-implementation-name [runtime-name s.local-symbol])
@@ -68,16 +67,16 @@
<js-definition>)))))
(def: #export (int value)
- (-> Int //.Expression)
+ (-> Int Expression)
(format "({"
//.int-high-field " : " (|> value int-to-nat //.high nat-to-int %i)
", "
//.int-low-field " : " (|> value int-to-nat //.low nat-to-int %i)
"})"))
-(def: #export (frac value)
- (-> Frac //.Expression)
- (%f value))
+(def: #export frac
+ (-> Frac Expression)
+ js.number)
(runtime: lux//try "runTry"
(format "(function " @ "(op) {"
@@ -157,7 +156,7 @@
"}"
(format "else if(wantedTag > " sum-tag ") {" test-recursion "}")
(format "else if(wantedTag < " sum-tag " && wantsLast === '') {"
- (let [updated-sum (variant-js (format "(" sum-tag " - wantedTag)") sum-flag sum-value)]
+ (let [updated-sum (variant' (format "(" sum-tag " - wantedTag)") sum-flag sum-value)]
(format "return " updated-sum ";"))
"}")
"else { " no-match " }"
@@ -266,6 +265,9 @@
"}")
"})"))
+(runtime: int//-one "NEG_ONE"
+ (js.apply int//negate (list int//one)))
+
(runtime: int//from-number "fromNumberI64"
(format "(function " @ "(num) {"
(format "if(isNaN(num)) {"
@@ -449,90 +451,115 @@
"return (" int//- "(l,r).H < 0);"
"})"))
+(def: (<I param subject)
+ (-> Expression Expression Expression)
+ (js.apply int//< (list subject param)))
+
+(def: (<=I param subject)
+ (-> Expression Expression Expression)
+ (js.or (js.apply int//< (list subject param))
+ (js.apply int//= (list subject param))))
+
+(def: (>I param subject)
+ (-> Expression Expression Expression)
+ (js.apply int//< (list param subject)))
+
+(def: (>=I param subject)
+ (-> Expression Expression Expression)
+ (js.or (js.apply int//< (list param subject))
+ (js.apply int//= (list subject param))))
+
+(def: (=I reference sample)
+ (-> Expression Expression Expression)
+ (js.apply int//= (list sample reference)))
+
(runtime: int/// "divI64"
- (format "(function " @ "(l,r) {"
- (format "if((r.H === 0) && (r.L === 0)) {"
- ## Special case: R = 0
- "throw new Error('Cannot divide by zero!');"
- "}"
- "else if((l.H === 0) && (l.L === 0)) {"
- ## Special case: L = 0
- "return l;"
- "}")
- (format "if(" int//= "(l," int//min ")) {"
- ## Special case: L = MIN
- (format "if(" int//= "(r," int//one ") || " int//= "(r, " int//negate "(" int//one "))) {"
- ## Special case: L = MIN, R = 1|-1
- "return " int//min ";"
- "}"
- ## Special case: L = R = MIN
- "else if(" int//= "(r," int//min ")) {"
- "return " int//one ";"
- "}"
- ## Special case: L = MIN
- "else {"
- "var halfL = " bit//signed-shift-right "(l,1);"
- "var approx = " bit//shift-left "(" @ "(halfL,r),1);"
- (format "if((approx.H === 0) && (approx.L === 0)) {"
- (format "if(r.H < 0) {"
- "return " int//one ";"
- "}"
- "else {"
- "return " int//negate "(" int//one ");"
- "}")
- "}"
- "else {"
- "var rem = " int//- "(l," int//* "(r,approx));"
- "return " int//+ "(approx," @ "(rem,r));"
- "}")
- "}")
- "}"
- "else if(" int//= "(r," int//min ")) {"
- ## Special case: R = MIN
- "return " int//new "(0,0);"
- "}")
- ## Special case: negatives
- (format "if(l.H < 0) {"
- (format "if(r.H < 0) {"
- ## Both are negative
- "return " @ "( " int//negate "(l), " int//negate "(r));"
- "}"
- "else {"
- ## Only L is negative
- "return " int//negate "(" @ "( " int//negate "(l),r));"
- "}")
- "}"
- "else if(r.H < 0) {"
- ## R is negative
- "return " int//negate "(" @ "(l, " int//negate "(r)));"
- "}")
- ## Common case
- (format "var res = " int//zero ";"
- "var rem = l;"
- (format "while(" int//< "(r,rem) || " int//= "(r,rem)) {"
- "var approx = Math.max(1, Math.floor(" int//to-number "(rem) / " int//to-number "(r)));"
- "var log2 = Math.ceil(Math.log(approx) / Math.LN2);"
- "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);"
- "var approxRes = " int//from-number "(approx);"
- "var approxRem = " int//* "(approxRes,r);"
- (format "while((approxRem.H < 0) || " int//< "(rem,approxRem)) {"
- "approx -= delta;"
- "approxRes = " int//from-number "(approx);"
- "approxRem = " int//* "(approxRes,r);"
- "}")
- (format "if((approxRes.H === 0) && (approxRes.L === 0)) {"
- "approxRes = " int//one ";"
- "}")
- "res = " int//+ "(res,approxRes);"
- "rem = " int//- "(rem,approxRem);"
- "}")
- "return res;")
- "})"))
+ (let [negate (|>> (list) (js.apply int//negate))
+ negative? (function [value]
+ (js.apply int//< (list value int//zero)))
+ valid-division-check [(=I int//zero "parameter")
+ (js.throw! (js.string "Cannot divide by zero!"))]
+ short-circuit-check [(=I int//zero "subject")
+ (js.return! int//zero)]
+ recur (function [subject parameter]
+ (js.apply @ (list subject parameter)))]
+ (js.function @ (list "subject" "parameter")
+ (list (js.cond! (list valid-division-check
+ short-circuit-check
+
+ [(=I int//min "subject")
+ (js.cond! (list [(js.or (=I int//one "parameter")
+ (=I int//-one "parameter"))
+ (js.return! int//min)]
+ [(=I int//min "parameter")
+ (js.return! int//one)])
+ (js.block! (list (js.var! "approximation"
+ (#.Some (js.apply bit//shift-left
+ (list (recur (js.apply bit//signed-shift-right
+ (list "subject" (js.number 1.0)))
+ "parameter")
+ (js.number 1.0)))))
+ (js.if! (=I int//zero "approximation")
+ (js.return! (js.? (negative? "parameter")
+ int//one
+ int//-one))
+ (let [remainder (js.apply int//- (list "subject"
+ (js.apply int//* (list "parameter"
+ "approximation"))))
+ result (js.apply int//+ (list "approximation"
+ (recur remainder
+ "parameter")))]
+ (js.return! result))))))]
+ [(=I int//min "parameter")
+ (js.return! int//zero)]
+
+ [(negative? "subject")
+ (js.return! (js.? (negative? "parameter")
+ (recur (negate "subject")
+ (negate "parameter"))
+ (negate (recur (negate "subject")
+ "parameter"))))]
+
+ [(negative? "parameter")
+ (js.return! (negate (recur "subject" (negate "parameter"))))])
+ (js.block! (list (js.var! "result" (#.Some int//zero))
+ (js.var! "remainder" (#.Some "subject"))
+ (js.while! (>=I "parameter" "remainder")
+ (let [rough-estimate (js.apply "Math.floor" (list (js./ (js.apply int//to-number (list "parameter"))
+ (js.apply int//to-number (list "remainder")))))
+ log2 (js./ "Math.LN2"
+ (js.apply "Math.log" (list "approximate")))
+ approx-result (js.apply int//from-number (list "approximate"))
+ approx-remainder (js.apply int//* (list "approximate_result" "parameter"))]
+ (list (js.var! "approximate" (#.Some (js.apply "Math.max" (list (js.number 1.0)
+ rough-estimate))))
+ (js.var! "log2" (#.Some (js.apply "Math.ceil" (list log2))))
+ (js.var! "delta" (#.Some (js.? (js.<= (js.number 48.0) "log2")
+ (js.number 1.0)
+ (js.apply "Math.pow" (list (js.number 2.0)
+ (js.- (js.number 48.0)
+ "log2"))))))
+ (js.var! "approximate_result" (#.Some approx-result))
+ (js.var! "approximate_remainder" (#.Some approx-remainder))
+ (js.while! (js.or (negative? "approximate_remainder")
+ (>I "remainder"
+ "approximate_remainder"))
+ (list (js.set! "approximate" (js.- "delta" "approximate"))
+ (js.set! "approximate_result" approx-result)
+ (js.set! "approximate_remainder" approx-remainder)))
+ (js.block! (list (js.set! "result" (js.apply int//+ (list "result"
+ (js.? (=I int//zero "approximate_result")
+ int//one
+ "approximate_result"))))
+ (js.set! "remainder" (js.apply int//- (list "remainder" "approximate_remainder"))))))))
+ (js.return! "result")))
+ )))))
(runtime: int//% "remI64"
- (format "(function " @ "(l,r) {"
- "return " int//- "(l," int//* "(" int/// "(l,r),r));"
- "})"))
+ (js.function @ (list "subject" "parameter")
+ (list (let [flat (js.apply int//* (list (js.apply int/// (list "subject" "parameter"))
+ "parameter"))]
+ (js.return! (js.apply int//- (list "subject" flat)))))))
(def: runtime//int
Runtime
diff --git a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
index a2c0c6510..7bcd8e112 100644
--- a/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/statement.jvm.lux
@@ -3,14 +3,15 @@
(lux (control [monad #+ do])
[macro]
(data text/format))
- (luxc (lang [".L" module]))
+ (luxc (lang [".L" module]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" runtime]
[".T" reference]
[".T" eval]))
(def: #export (translate-def name expressionT expressionJS metaV)
- (-> Text Type //.Expression Code (Meta Unit))
+ (-> Text Type Expression Code (Meta Unit))
(do macro.Monad<Meta>
[current-module macro.current-module-name
#let [def-ident [current-module name]]]
@@ -39,7 +40,7 @@
)))
(def: #export (translate-program programJS)
- (-> //.Expression (Meta //.Statement))
+ (-> Expression (Meta Statement))
(macro.fail "translate-program NOT IMPLEMENTED YET")
## (hostT.save (format "var " (referenceT.variable +0) " = " runtimeT.lux//program-args "();"
## "(" programJS ")(null);"))
diff --git a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux
index 54f578bee..df7215dba 100644
--- a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux
@@ -5,12 +5,13 @@
text/format)
[macro])
(luxc ["&" lang]
- (lang [synthesis #+ Synthesis]))
+ (lang [synthesis #+ Synthesis]
+ (host [js #+ JS Expression Statement])))
[//]
(// [".T" runtime]))
(def: #export (translate-tuple translate elemsS+)
- (-> (-> Synthesis (Meta //.Expression)) (List Synthesis) (Meta //.Expression))
+ (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression))
(case elemsS+
#.Nil
(:: macro.Monad<Meta> wrap runtimeT.unit)
@@ -24,7 +25,7 @@
(wrap (format "[" (text.join-with "," elemsT+) "]")))))
(def: #export (translate-variant translate tag tail? valueS)
- (-> (-> Synthesis (Meta //.Expression)) Nat Bool Synthesis (Meta //.Expression))
+ (-> (-> Synthesis (Meta Expression)) Nat Bool Synthesis (Meta Expression))
(do macro.Monad<Meta>
[valueT (translate valueS)]
(wrap (runtimeT.variant tag tail? valueT))))