From c60426c60a137b454f6177dcb2d563a942dde75f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 13 Feb 2019 18:44:02 -0400 Subject: - WIP: Moved some of the JS compiler machinery over to stdlib. - DRYed the reference translation machinery. --- .../luxc/lang/translation/js/primitive.jvm.lux | 41 -- .../luxc/lang/translation/js/reference.jvm.lux | 36 -- .../luxc/lang/translation/js/runtime.jvm.lux | 669 ------------------- .../luxc/lang/translation/js/structure.jvm.lux | 31 - stdlib/source/lux/data/text.lux | 11 +- stdlib/source/lux/host/js.lux | 120 +++- stdlib/source/lux/tool/compiler/phase.lux | 2 +- .../source/lux/tool/compiler/phase/translation.lux | 10 +- .../phase/translation/common/reference.lux | 70 ++ .../compiler/phase/translation/js/primitive.lux | 53 ++ .../compiler/phase/translation/js/reference.lux | 12 + .../tool/compiler/phase/translation/js/runtime.lux | 718 +++++++++++++++++++++ .../compiler/phase/translation/js/structure.lux | 32 + .../phase/translation/scheme/primitive.jvm.lux | 34 +- .../phase/translation/scheme/reference.jvm.lux | 52 +- .../phase/translation/scheme/runtime.jvm.lux | 11 +- .../phase/translation/scheme/structure.jvm.lux | 9 +- 17 files changed, 1029 insertions(+), 882 deletions(-) delete mode 100644 new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/js/reference.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux delete mode 100644 new-luxc/source/luxc/lang/translation/js/structure.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux diff --git a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux deleted file mode 100644 index e69291007..000000000 --- a/new-luxc/source/luxc/lang/translation/js/primitive.jvm.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - lux - (lux (control pipe) - (data [bit] - [number] - text/format) - [macro "meta/" Monad]) - [//] - (// [".T" runtime]) - (luxc (lang (host [js #+ JS Expression Statement])))) - -(def: #export translate-bit - (-> Bit (Meta Expression)) - (|>> %b meta/wrap)) - -(def: low-mask Nat (dec (bit.left-shift +32 +1))) - -(def: #export (translate-int value) - (-> Int (Meta Expression)) - (let [high (|> value (bit.logical-right-shift +32) %i) - low (|> value (bit.and low-mask) %i)] - (meta/wrap (format runtimeT.int//new "(" high "," low ")")))) - -(def: #export translate-frac - (-> Frac (Meta Expression)) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "Infinity")] - - [(f/= number.negative-infinity)] - [(new> "-Infinity")] - - [(f/= number.not-a-number)] - [(new> "NaN")] - - ## else - [%f]) - meta/wrap)) - -(def: #export translate-text - (-> Text (Meta Expression)) - (|>> %t meta/wrap)) diff --git a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux deleted file mode 100644 index 69a0075b1..000000000 --- a/new-luxc/source/luxc/lang/translation/js/reference.jvm.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - lux - (lux [macro] - (data [text] - text/format)) - (luxc ["&" lang] - (lang [".L" variable #+ Variable Register] - (host [js #+ JS Expression Statement]))) - [//] - (// [".T" runtime])) - -(do-template [ ] - [(def: #export ( register) - (-> Register Expression) - (format (%i (.int register)))) - - (def: #export ( register) - (-> Register (Meta Expression)) - (:: macro.Monad wrap ( register)))] - - [closure translate-captured "c"] - [variable translate-local "v"]) - -(def: #export (translate-variable var) - (-> Variable (Meta Expression)) - (if (variableL.captured? var) - (translate-captured (variableL.captured-register var)) - (translate-local (.nat var)))) - -(def: #export global - (-> Name Expression) - //.definition-name) - -(def: #export (translate-definition name) - (-> Name (Meta Expression)) - (:: macro.Monad 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 deleted file mode 100644 index af47bffce..000000000 --- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux +++ /dev/null @@ -1,669 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data text/format) - [macro] - (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: (flag value) - (-> Bit JS) - (if value - (%t "") - "null")) - -(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 Bit Expression Expression) - (variant' (%i (.int tag)) (flag last?) value)) - -(def: none - Expression - (variant +0 #0 unit)) - -(def: some - (-> Expression Expression) - (variant +1 #1)) - -(def: left - (-> Expression Expression) - (variant +0 #0)) - -(def: right - (-> Expression Expression) - (variant +1 #1)) - -(type: Runtime JS) - -(def: (runtime-name name) - (-> Text Text) - (format prefix "$" name)) - -(def: (feature name definition) - (-> Text (-> Text Expression) Statement) - (format "var " name " = " (definition name) ";\n")) - -(syntax: (runtime-implementation-name {runtime-name s.local-identifier}) - (wrap (list (code.local-identifier (format "__" runtime-name))))) - -(template: (runtime: ) - (def: #export Text (runtime-name )) - (`` (def: ((~' ~~) (runtime-implementation-name )) - Runtime - (feature - (function ((~' _) (~' @)) - ))))) - -(def: #export (int value) - (-> Int Expression) - (format "({" - //.int-high-field " : " (|> value .nat //.high .int %i) - ", " - //.int-low-field " : " (|> value .nat //.low .int %i) - "})")) - -(def: #export frac - (-> Frac Expression) - js.number) - -(runtime: lux//try "runTry" - (format "(function " @ "(op) {" - (format "try {" - (format "return " (right "op(null)") ";") - "}" - "catch(ex) {" - (format "return " (left "ex.toString()") ";") - "}") - "})")) - -(runtime: lux//program-args "programArgs" - (format "(function " @ "() {" - (format "if(typeof process !== 'undefined' && process.argv) {" - (format (format "var result = " none ";") - "for(var idx = process.argv.length-1; idx >= 0; idx--) {" - (format "result = " (some "[process.argv[idx],result]") ";") - "}") - (format "return result;") - "}" - "else {" - (format "return " none ";") - "}") - "})")) - -(def: runtime//lux - Runtime - (format __lux//try - __lux//program-args)) - -(runtime: product//left "product_left" - (format "(function " @ "(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ## No need for recursion - "return product[index];" - "}" - "else {" - ## Needs recursion - "return " @ "(product[product.length - 1], (index_min_length - product.length));" - "}" - "})")) - -(runtime: product//right "product_right" - (format "(function " @ "(product,index) {" - "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ## Last element. - "return product[index];" - "}" - "else if(product.length < index_min_length) {" - ## Needs recursion - "return " @ "(product[product.length - 1], (index_min_length - product.length));" - "}" - "else {" - ## Must slice - "return product.slice(index);" - "}" - "})")) - -(runtime: sum//get "sum_get" - (let [no-match "return null;" - sum-tag (format "sum." //.variant-tag-field) - sum-flag (format "sum." //.variant-flag-field) - sum-value (format "sum." //.variant-value-field) - is-last? (format sum-flag " === ''") - extact-match (format "return " sum-value ";") - test-recursion (format "if(" is-last? ") {" - ## Must recurse. - "return " @ "(" sum-value ", (wantedTag - " sum-tag "), wantsLast);" - "}" - "else { " no-match " }")] - (format "(function " @ "(sum,wantedTag,wantsLast) {" - "if(wantedTag === " sum-tag ") {" - (format "if(" sum-flag " === wantsLast) {" extact-match "}" - "else {" test-recursion "}") - "}" - (format "else if(wantedTag > " sum-tag ") {" test-recursion "}") - (format "else if(wantedTag < " sum-tag " && wantsLast === '') {" - (let [updated-sum (variant' (format "(" sum-tag " - wantedTag)") sum-flag sum-value)] - (format "return " updated-sum ";")) - "}") - "else { " no-match " }" - "})"))) - -(def: runtime//adt - Runtime - (format __product//left - __product//right - __sum//get)) - -(runtime: int//new "makeI64" - (format "(function " @ "(high,low) {" - "return { H: (high|0), L: (low|0)};" - "})")) - -(runtime: int//2^16 "TWO_PWR_16" - "(1 << 16)") - -(runtime: int//2^32 "TWO_PWR_32" - (format "(" int//2^16 " * " int//2^16 ")")) - -(runtime: int//2^64 "TWO_PWR_64" - (format "(" int//2^32 " * " int//2^32 ")")) - -(runtime: int//2^63 "TWO_PWR_63" - (format "(" int//2^64 " / 2)")) - -(runtime: int//unsigned-low "getLowBitsUnsigned" - (format "(function " @ "(i64) {" - "return (i64.L >= 0) ? i64.L : (" int//2^32 " + i64.L);" - "})")) - -(runtime: int//to-number "toNumberI64" - (format "(function " @ "(i64) {" - "return (i64.H * " int//2^32 ") + " int//unsigned-low "(i64);" - "})")) - -(runtime: int//zero "ZERO" - "{ H: (0|0), L: (0|0)}") - -(runtime: int//min "MIN_VALUE_I64" - "{ H: (0x80000000|0), L: (0|0)}") - -(runtime: int//max "MAX_VALUE_I64" - "{ H: (0x7FFFFFFF|0), L: (0xFFFFFFFF|0)}") - -(runtime: int//one "ONE" - "{ H: (0|0), L: (1|0)}") - -(runtime: int//= "eqI64" - (format "(function " @ "(l,r) {" - "return (l.H === r.H) && (l.L === r.L);" - "})")) - -(runtime: int//+ "addI64" - (format "(function " @ "(l,r) {" - "var l48 = l.H >>> 16;" - "var l32 = l.H & 0xFFFF;" - "var l16 = l.L >>> 16;" - "var l00 = l.L & 0xFFFF;" - - "var r48 = r.H >>> 16;" - "var r32 = r.H & 0xFFFF;" - "var r16 = r.L >>> 16;" - "var r00 = r.L & 0xFFFF;" - - "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" - "x00 += l00 + r00;" - "x16 += x00 >>> 16;" - "x00 &= 0xFFFF;" - "x16 += l16 + r16;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x32 += l32 + r32;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x48 += l48 + r48;" - "x48 &= 0xFFFF;" - - "return " int//new "((x48 << 16) | x32, (x16 << 16) | x00);" - "})")) - -(template: (bit-operation: ) - (runtime: - (format "(function " (~' @) "(input,mask) {" - "return " int//new "(input.H " " mask.H, input.L " " mask.L);" - "})"))) - -(bit-operation: bit//and "andI64" "&") -(bit-operation: bit//or "orI64" "|") -(bit-operation: bit//xor "xorI64" "^") - -(runtime: bit//not "notI64" - (format "(function " @ "(i64) {" - "return " int//new "(~i64.H,~i64.L);" - "})")) - -(runtime: int//negate "negateI64" - (format "(function " @ "(i64) {" - (format "if(" int//= "(" int//min ",i64)) {" - "return " int//min ";" - "}") - (format "else {" - "return " int//+ "(" bit//not "(i64)," int//one ");" - "}") - "})")) - -(runtime: int//-one "NEG_ONE" - (js.apply int//negate (list int//one))) - -(runtime: int//from-number "fromNumberI64" - (format "(function " @ "(num) {" - (format "if(isNaN(num)) {" - "return " int//zero ";" - "}") - (format "else if(num <= -" int//2^63 ") {" - "return " int//min ";" - "}") - (format "else if((num + 1) >= " int//2^63 ") {" - "return " int//max ";" - "}") - (format "else if(num < 0) {" - "return " int//negate "(" @ "(-num));" - "}") - (format "else {" - "return " int//new "((num / " int//2^32 "), (num % " int//2^32 "));" - "}") - "})")) - -(runtime: bit//left-shift "shlI64" - (format "(function " @ "(input,shift) {" - "shift &= 63;" - (format "if(shift === 0) {" - "return input;" - "}" - "else {" - (format "if (shift < 32) {" - "var high = (input.H << shift) | (input.L >>> (32 - shift));" - "var low = input.L << shift;" - "return " int//new "(high, low);" - "}" - "else {" - "var high = (input.L << (shift - 32));" - "return " int//new "(high, 0);" - "}") - "}") - "})")) - -(runtime: bit//arithmetic-right-shift "shrI64" - (format "(function " @ "(input,shift) {" - "shift &= 63;" - (format "if(shift === 0) {" - "return input;" - "}" - "else {" - (format "if (shift < 32) {" - "var high = input.H >> shift;" - "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return " int//new "(high, low);" - "}" - "else {" - "var low = (input.H >> (shift - 32));" - "var high = input.H >= 0 ? 0 : -1;" - "return " int//new "(high, low);" - "}") - "}") - "})")) - -(runtime: bit//logical-right-shift "ushrI64" - (format "(function " @ "(input,shift) {" - "shift &= 63;" - (format "if(shift === 0) {" - "return input;" - "}" - "else {" - (format "if (shift < 32) {" - "var high = input.H >>> shift;" - "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return " int//new "(high, low);" - "}" - "else if(shift === 32) {" - "return " int//new "(0, input.H);" - "}" - "else {" - "var low = (input.H >>> (shift - 32));" - "return " int//new "(0, low);" - "}") - "}") - "})")) - -(def: runtime//bit - Runtime - (format __bit//and - __bit//or - __bit//xor - __bit//not - __bit//left-shift - __bit//arithmetic-right-shift - __bit//logical-right-shift)) - -(runtime: int//- "subI64" - (format "(function " @ "(l,r) {" - "return " int//+ "(l, " int//negate "(r));" - "})")) - -(runtime: int//* "mulI64" - (format "(function " @ "(l,r) {" - "if (l.H < 0) {" - (format "if (r.H < 0) {" - ## Both are negative - "return " @ "( " int//negate "(l), " int//negate "(r));" - "}" - "else {" - ## Left is negative - "return " int//negate "(" @ "( " int//negate "(l),r));" - "}") - "}" - "else if (r.H < 0) {" - ## Right is negative - "return " int//negate "(" @ "(l, " int//negate "(r)));" - "}" - ## Both are positive - "else {" - "var l48 = l.H >>> 16;" - "var l32 = l.H & 0xFFFF;" - "var l16 = l.L >>> 16;" - "var l00 = l.L & 0xFFFF;" - - "var r48 = r.H >>> 16;" - "var r32 = r.H & 0xFFFF;" - "var r16 = r.L >>> 16;" - "var r00 = r.L & 0xFFFF;" - - "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" - "x00 += l00 * r00;" - "x16 += x00 >>> 16;" - "x00 &= 0xFFFF;" - "x16 += l16 * r00;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x16 += l00 * r16;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x32 += l32 * r00;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x32 += l16 * r16;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x32 += l00 * r32;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" - "x48 &= 0xFFFF;" - - "return " int//new "((x48 << 16) | x32, (x16 << 16) | x00);" - "}" - "})")) - -(runtime: int//< "ltI64" - (format "(function " @ "(l,r) {" - "var ln = l.H < 0;" - "var rn = r.H < 0;" - "if(ln && !rn) { return true; }" - "if(!ln && rn) { return false; }" - "return (" int//- "(l,r).H < 0);" - "})")) - -(def: ( 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" - (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//left-shift - (list (recur (js.apply bit//arithmetic-right-shift - (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" - (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 - (format __int//2^16 - __int//2^32 - __int//2^64 - __int//2^63 - __int//unsigned-low - __int//zero - __int//new - __int//min - __int//max - __int//one - __int//= - __int//+ - __int//negate - __int//to-number - __int//from-number - __int//- - __int//* - __int//< - __int/// - __int//%)) - -(runtime: text//index "index" - (format "(function " @ "(text,part,start) {" - "var idx = text.indexOf(part," int//to-number "(start));" - (format (format "if(idx === -1) {" - "return " none ";" - "}") - (format "else {" - (format "return " (some (format int//from-number "(idx)")) ";") - "}")) - "})")) - -(runtime: text//clip "clip" - (format "(function " @ "(text,from,to) {" - (format "if(from.L > text.length || to.L > text.length) {" - (format "return " none ";") - "}" - "else {" - (format "return " (some "text.substring(from.L,to.L)") ";") - "}") - "})")) - -(runtime: text//char "textChar" - (format "(function " @ "(text,idx) {" - "var result = text.charCodeAt(idx.L);" - (format "if(result === NaN) {" - (format "return " none ";") - "}" - "else {" - (format "return " (some (format int//from-number "(result)")) ";") - "}") - "})")) - -(def: runtime//text - Runtime - (format __text//index - __text//clip - __text//char)) - -(runtime: io//log "log" - (format "(function " @ "(message) {" - "if(typeof console !== \"undefined\" && console.log) { console.log(message); }" - "else if(typeof print !== \"undefined\") { print(message); }" - "return " unit ";" - "})")) - -(runtime: io//error "error" - (format "(function " @ "(message) {" - "throw new Error(message);" - "})")) - -(def: runtime//io - Runtime - (format __io//log - __io//error)) - -(runtime: js//get "jsGetField" - (format "(function " @ "(object, field) {" - "var temp = object[field];" - (format "if(temp !== undefined) {" - (format "return " (some "temp") ";") - "}" - "else {" - (format "return " none ";") - "}") - "})")) - -(runtime: js//set "jsSetField" - (format "(function " @ "(object, field, input) {" - "object[field] = input;" - "return object;" - "})")) - -(runtime: js//delete "jsDeleteField" - (format "(function " @ "(object, field) {" - "delete object[field];" - "return object;" - "})")) - -(runtime: js//call "jsObjectCall" - (format "(function " @ "(object, method, args) {" - "return object[method].apply(object, args);" - "})")) - -(def: runtime//js - Runtime - (format __js//get - __js//set - __js//delete - __js//call)) - -(def: runtime - Runtime - (format runtime//lux - runtime//adt - runtime//bit - runtime//int - runtime//text - runtime//io - runtime//js)) - -(def: #export artifact Text (format prefix ".js")) - -(def: #export translate - (Meta (Process Any)) - (do macro.Monad - [_ //.init-module-buffer - _ (//.save-js runtime)] - (//.save-module! artifact))) diff --git a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux deleted file mode 100644 index 580f48807..000000000 --- a/new-luxc/source/luxc/lang/translation/js/structure.jvm.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format) - [macro]) - (luxc ["&" lang] - (lang [synthesis #+ Synthesis] - (host [js #+ JS Expression Statement]))) - [//] - (// [".T" runtime])) - -(def: #export (translate-tuple translate elemsS+) - (-> (-> Synthesis (Meta Expression)) (List Synthesis) (Meta Expression)) - (case elemsS+ - #.Nil - (:: macro.Monad wrap runtimeT.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do macro.Monad - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (format "[" (text.join-with "," elemsT+) "]"))))) - -(def: #export (translate-variant translate tag tail? valueS) - (-> (-> Synthesis (Meta Expression)) Nat Bit Synthesis (Meta Expression)) - (do macro.Monad - [valueT (translate valueS)] - (wrap (runtimeT.variant tag tail? valueT)))) 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 [ + + +] + [(`` (def: #export ( function) + (-> Expression (~~ (template.splice +)) Computation) + (.function (_ (~~ (template.splice +))) + (..apply/* function (list (~~ (template.splice +))))))) + + (`` (do-template [ ] + [(def: #export ( (..var )))] + + (~~ (template.splice +))))] + + [apply/1 [_0] [Expression] + [[not-a-number? "isNaN"]]] + + [apply/2 [_0 _1] [Expression Expression] + []] + + [apply/3 [_0 _1 _2] [Expression Expression Expression] + []] + ) + (do-template [ ] [(def: #export ( 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 [ ] + [(def: #export + (-> Expression Computation) + (|>> :representation (text.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 [ ] + [(def: #export + (-> Location Statement) + (|>> :representation + (text.suffix ) + :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 [] [(exception: #export () @@ -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 [ ] + [(type: #export + ( 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 [ ] + [(runtime: ( left right) + (_.return (i64//new ( (_.the ..i64-high-field left) + (_.the ..i64-high-field right)) + ( (_.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 [ ] + [(def: #export + (-> (Operation Expression)) + (|>> /////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 [ ] - [(def: #export - (-> Register Var) - (|>> .int %i (format ) _.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 [ ] [(type: #export 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)) -- cgit v1.2.3