diff options
Diffstat (limited to '')
12 files changed, 466 insertions, 138 deletions
diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index b109fc2fb..810256534 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -82,7 +82,7 @@ (~~ (static @.js)) (let [output ("js array read" index array)] - (if ("js undefined?" output) + (if ("js object undefined?" output) #.None (#.Some output)))})) #.None)) diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 2752903a7..e4d24f709 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -9,7 +9,7 @@ abstract] [world [binary (#+ Binary)]] - [host (#+ import:)]]) + ["." host]]) ## https://docs.oracle.com/javase/8/docs/technotes/guides/intl/encoding.doc.html @@ -171,14 +171,25 @@ (|>> :representation)) ) -(with-expansions [<for-jvm> (as-is (import: #long java/lang/String +(with-expansions [<for-jvm> (as-is (host.import: #long java/lang/String (new [[byte] java/lang/String]) (getBytes [java/lang/String] [byte])))] (`` (for {(~~ (static @.old)) (as-is <for-jvm>) (~~ (static @.jvm)) - (as-is <for-jvm>)}))) + (as-is <for-jvm>) + + (~~ (static @.js)) + (as-is (host.import: Uint8Array) + + (host.import: TextEncoder + (new [host.String]) + (encode [host.String] Uint8Array)) + + (host.import: TextDecoder + (new [host.String]) + (decode [Uint8Array] host.String)))}))) (def: #export (to-utf8 value) (-> Text Binary) @@ -190,7 +201,11 @@ (:coerce java/lang/String value)) (~~ (static @.jvm)) - (java/lang/String::getBytes (..name ..utf-8) value)}))) + (java/lang/String::getBytes (..name ..utf-8) value) + + (~~ (static @.js)) + (|> (TextEncoder::new [(..name ..utf-8)]) + (TextEncoder::encode [value]))}))) (def: #export (from-utf8 value) (-> Binary (Error Text)) @@ -198,7 +213,11 @@ (#error.Success (java/lang/String::new value (..name ..utf-8))) (~~ (static @.jvm)) - (#error.Success (java/lang/String::new value (..name ..utf-8)))}))) + (#error.Success (java/lang/String::new value (..name ..utf-8))) + + (~~ (static @.js)) + (#error.Success (|> (TextDecoder::new [(..name ..utf-8)]) + (TextDecoder::decode [value])))}))) (structure: #export UTF-8 (Codec Binary Text) (def: encode ..to-utf8) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index ecca052e2..20dc2ed5e 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -1,21 +1,30 @@ (.module: [lux #* + [abstract + [monad (#+ do)]] [control - ["p" parser - ["s" code (#+ Parser)]]] + ["<>" parser + ["<c>" code (#+ Parser)]]] [data + ["." product] + [text + format] [collection - ["." list ("#@." fold)]]] + ["." list ("#@." functor)]]] [type abstract] - [macro (#+ with-gensyms) + ["." macro (#+ with-gensyms) [syntax (#+ syntax:)] - ["." code]]]) + ["." code] + ["." template]]]) -(template [<name> <type>] - [(abstract: #export <name> {} Any)] +(abstract: #export (Object brand) {} Any) + +(template [<name>] + [(with-expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> {} Any) + (type: #export <name> (Object <brand>)))] - [Object] [Function] [Symbol] [Null] @@ -29,3 +38,126 @@ [Number Frac] [Boolean Bit] ) + +(type: Nullable [Bit Code]) + +(def: nullable + (Parser Nullable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<c>.this! token))) + (<>.after (<>.not (<c>.this! token))) + <c>.any))) + +(type: Constructor (List Nullable)) + +(def: constructor + (Parser Constructor) + (<c>.form (<>.after (<c>.this! (' new)) + (<c>.tuple (<>.some ..nullable))))) + +(type: Field [Text Nullable]) + +(def: field + (Parser Field) + (<c>.form ($_ <>.and + <c>.local-identifier + ..nullable))) + +(type: Method [Text (List Nullable) Nullable]) + +(def: method + (Parser Method) + (<c>.form ($_ <>.and + <c>.local-identifier + (<c>.tuple (<>.some ..nullable)) + ..nullable))) + +(type: Member + (#Constructor Constructor) + (#Field Field) + (#Method Method)) + +(def: member + (Parser Member) + ($_ <>.or + ..constructor + ..field + ..method + )) + +(def: input-variables + (-> (List Nullable) (List [Bit Code])) + (|>> list.enumerate + (list@map (function (_ [idx [nullable? type]]) + [nullable? (|> idx %n code.local-identifier)])))) + +(def: (nullable-type [nullable? type]) + (-> Nullable Code) + (if nullable? + (` (.Maybe (~ type))) + type)) + +(def: (with-null g!temp [nullable? input]) + (-> Code [Bit Code] Code) + (if nullable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.None + ("js object null"))) + input)) + +(def: (without-null g!temp [nullable? outputT] output) + (-> Code Nullable Code Code) + (if nullable? + (` (let [(~ g!temp) (~ output)] + (if ("js object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + output)) + +(syntax: #export (import: {class <c>.local-identifier} + {members (<>.some member)}) + (with-gensyms [g!object g!temp] + (let [g!type (code.local-identifier class) + qualify (: (-> Text Code) + (|>> (format class "::") code.local-identifier))] + (wrap (list& (` (type: (~ g!type) (..Object (primitive (~ (code.text class)))))) + (list@map (function (_ member) + (case member + (#Constructor inputsT) + (let [g!inputs (input-variables inputsT)] + (` (def: ((~ (qualify "new")) + [(~+ (list@map product.right g!inputs))]) + (-> [(~+ (list@map nullable-type inputsT))] + (~ g!type)) + (:assume + ("js object new" + ("js constant" (~ (code.text class))) + [(~+ (list@map (with-null g!temp) g!inputs))]))))) + + (#Field [field fieldT]) + (` (def: ((~ (qualify field)) + (~ g!object)) + (-> (~ g!type) + (~ (nullable-type fieldT))) + (:assume + (~ (without-null g!temp fieldT (` ("js object get" (~ (code.text field)) (~ g!object)))))))) + + (#Method [method inputsT outputT]) + (let [g!inputs (input-variables inputsT)] + (` (def: ((~ (qualify method)) + [(~+ (list@map product.right g!inputs))] + (~ g!object)) + (-> [(~+ (list@map nullable-type inputsT))] + (~ g!type) + (~ (nullable-type outputT))) + (:assume + (~ (without-null g!temp + outputT + (` ("js object do" + (~ (code.text method)) + (~ g!object) + [(~+ (list@map (with-null g!temp) g!inputs))])))))))))) + members)))))) diff --git a/stdlib/source/lux/target/js.lux b/stdlib/source/lux/target/js.lux index 526621236..c89d59415 100644 --- a/stdlib/source/lux/target/js.lux +++ b/stdlib/source/lux/target/js.lux @@ -282,7 +282,7 @@ (def: #export (set name value) (-> Location Expression Statement) - (:abstraction (format (:representation (set' name value)) ..statement-suffix))) + (:abstraction (format (:representation name) " = " (:representation value) ..statement-suffix))) (def: #export (throw message) (-> Expression Statement) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux index d8285532b..d04e04ec9 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/js.lux @@ -15,7 +15,7 @@ [target ["_" js]]] ["." // #_ - ["#." lux (#+ custom)] + ["/" lux (#+ custom)] ["/#" // ["#." bundle] ["/#" // ("#@." monad) @@ -103,6 +103,57 @@ (///bundle.install "delete" array::delete) ))) +(def: object::new + Handler + (custom + [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any))) + (function (_ extension phase [constructorC inputsC]) + (do ////.monad + [constructorA (typeA.with-type Any + (phase constructorC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.infer .Any)] + (wrap (#/////analysis.Extension extension (list& constructorA inputsA)))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <c>.text <c>.any) + (function (_ extension phase [fieldC objectC]) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + _ (typeA.infer .Any)] + (wrap (#/////analysis.Extension extension (list (/////analysis.text fieldC) + objectA)))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any))) + (function (_ extension phase [methodC objectC inputsC]) + (do ////.monad + [objectA (typeA.with-type Any + (phase objectC)) + inputsA (monad.map @ (|>> phase (typeA.with-type Any)) inputsC) + _ (typeA.infer .Any)] + (wrap (#/////analysis.Extension extension (list& (/////analysis.text methodC) + objectA + inputsA)))))])) + +(def: bundle::object + Bundle + (<| (///bundle.prefix "object") + (|> ///bundle.empty + (///bundle.install "new" object::new) + (///bundle.install "get" object::get) + (///bundle.install "do" object::do) + (///bundle.install "null" (/.nullary Any)) + (///bundle.install "null?" (/.unary Any Bit)) + (///bundle.install "undefined" (/.nullary Any)) + (///bundle.install "undefined?" (/.unary Any Bit)) + ))) + (def: js::constant Handler (custom @@ -124,23 +175,12 @@ _ (typeA.infer Any)] (wrap (#/////analysis.Extension extension (list& abstractionA inputsA)))))])) -(def: js::undefined? - Handler - (custom - [<c>.any - (function (_ extension phase [valueC]) - (do ////.monad - [valueA (typeA.with-type Any - (phase valueC)) - _ (typeA.infer Bit)] - (wrap (#/////analysis.Extension extension (list valueA)))))])) - (def: #export bundle Bundle (<| (///bundle.prefix "js") (|> ///bundle.empty (///bundle.install "constant" js::constant) (///bundle.install "apply" js::apply) - (///bundle.install "undefined?" js::undefined?) (dictionary.merge bundle::array) + (dictionary.merge bundle::object) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux index 843db713d..65c355ecf 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/common-lisp/runtime.lux @@ -190,8 +190,8 @@ test-recursion! (_.if sum-flag ## Must iterate. ($_ _.progn - (_.setq sum sum-value) - (_.setq wantedTag (_.- sum-tag wantedTag))) + (_.setq wantedTag (_.- sum-tag wantedTag)) + (_.setq sum sum-value)) no-match!)] (<| (_.progn (_.setq sum-tag (_.nth/2 [(_.int +0) sum]))) (_.progn (_.setq sum-flag (_.nth/2 [(_.int +1) sum]))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux index c2e0f667e..9e066b88d 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux @@ -220,21 +220,20 @@ ([/////synthesis.path/seq _.then] [/////synthesis.path/alt alternation]))) -(def: (pattern-matching stack-init generate pathP) - (-> Expression Phase Path (Operation Statement)) +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Statement)) (do ////.monad [pattern-matching! (pattern-matching' generate pathP)] (wrap ($_ _.then (_.do-while _.false pattern-matching!) - (_.statement (//runtime.io//log stack-init)) (_.throw (_.string case.pattern-matching-error)))))) (def: #export (case generate [valueS pathP]) (-> Phase [Synthesis Path] (Operation Computation)) (do ////.monad [stack-init (generate valueS) - path! (pattern-matching stack-init generate pathP) + path! (pattern-matching generate pathP) #let [closure (<| (_.closure (list)) ($_ _.then (_.declare @temp) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux index 3cf3c6c07..bb3d6138d 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux @@ -3,6 +3,7 @@ [abstract ["." monad (#+ do)]] [control + ["." function] ["<>" parser ["<s>" synthesis (#+ Parser)]]] [data @@ -70,6 +71,55 @@ (bundle.install "delete" (binary array::delete)) ))) +(def: object::new + (..custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase [constructorS inputsS]) + (do /////.monad + [constructorG (phase constructorS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.new constructorG inputsG))))])) + +(def: object::get + Handler + (custom + [($_ <>.and <s>.text <s>.any) + (function (_ extension phase [fieldS objectS]) + (do /////.monad + [objectG (phase objectS)] + (wrap (_.the fieldS objectG))))])) + +(def: object::do + Handler + (custom + [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase [methodS objectS inputsS]) + (do /////.monad + [objectG (phase objectS) + inputsG (monad.map @ phase inputsS)] + (wrap (_.do methodS inputsG objectG))))])) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.= <unit>))] + + [object::null object::null? _.null] + [object::undefined object::undefined? _.undefined] + ) + +(def: object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (nullary object::null)) + (bundle.install "null?" (unary object::null?)) + (bundle.install "undefined" (nullary object::undefined)) + (bundle.install "undefined?" (unary object::undefined?)) + ))) + (def: js::constant (..custom [<s>.text @@ -87,20 +137,12 @@ inputsG (monad.map @ phase inputsS)] (wrap (_.apply/* abstractionG inputsG))))])) -(def: js::undefined? - (..custom - [<s>.any - (function (_ extension phase valueS) - (|> valueS - phase - (:: /////.monad map (_.= _.undefined))))])) - (def: #export bundle Bundle (<| (bundle.prefix "js") (|> bundle.empty (bundle.install "constant" js::constant) (bundle.install "apply" js::apply) - (bundle.install "undefined?" js::undefined?) (dictionary.merge ..array) + (dictionary.merge ..object) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux index 9be09d142..54a15b036 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux @@ -215,19 +215,22 @@ extact-match! (_.return sum-value) test-recursion! (_.if is-last? ## Must recurse. - (_.return (sum//get sum-value (_.- sum-tag wanted-tag) wants-last)) + ($_ _.then + (_.set wanted-tag (_.- sum-tag wanted-tag)) + (_.set sum sum-value)) 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!))) + (<| (_.while (_.boolean true)) + (_.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 @@ -656,7 +659,10 @@ end!)] [(|> print _.type-of (_.= (_.string "undefined")) _.not) ($_ _.then - (_.statement (_.apply/1 print (_.apply/1 (_.var "JSON.stringify") message))) + (_.statement (_.apply/1 print (_.? (_.= (_.string "string") + (_.type-of message)) + message + (_.apply/1 (_.var "JSON.stringify") message)))) end!)]) end!))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux index a5a22917e..4af1c01ac 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/php/runtime.lux @@ -218,7 +218,7 @@ is-last? (_.= (_.string "") sum-flag) test-recursion! (_.if is-last? ## Must recurse. - (_.return (sum//get sum-value (_.- sum-tag wantedTag) wantsLast)) + (_.return (sum//get sum-value wantsLast (_.- sum-tag wantedTag))) no-match!)] ($_ _.then (_.echo (_.string "sum//get ")) (_.echo (_.count/1 sum)) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux index 7d55f0faf..4a617e29c 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux @@ -192,8 +192,8 @@ test-recursion (_.if is-last? ## Must recurse. (sum//get sum-value - (|> wanted-tag (_.-/2 sum-tag)) - last?) + last? + (|> wanted-tag (_.-/2 sum-tag))) no-match)] (<| (_.let (list [sum-tag (_.car/1 sum)] [sum-value (_.cdr/1 sum)])) diff --git a/stdlib/source/lux/world/binary.lux b/stdlib/source/lux/world/binary.lux index 9599ae2f0..463f99a5a 100644 --- a/stdlib/source/lux/world/binary.lux +++ b/stdlib/source/lux/world/binary.lux @@ -1,6 +1,6 @@ (.module: [lux (#- i64) - ["." host (#+ import:)] + ["." host] ["@" target] [abstract [monad (#+ do)] @@ -15,7 +15,7 @@ [text format] [collection - [array (#+)]]]]) + ["." array]]]]) (exception: #export (index-out-of-bounds {size Nat} {index Nat}) (exception.report @@ -35,42 +35,83 @@ (with-expansions [<for-jvm> (as-is (type: #export Binary (host.type [byte])) - (import: #long java/lang/Object) + (host.import: #long java/lang/Object) - (import: #long java/lang/System + (host.import: #long java/lang/System (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void)) - (import: #long java/util/Arrays + (host.import: #long java/util/Arrays (#static copyOfRange [[byte] int int] [byte]) - (#static equals [[byte] [byte]] boolean)))] + (#static equals [[byte] [byte]] boolean)) + + (def: byte-mask + Nat + (|> i64.bits-per-byte i64.mask .nat)) + + (def: i64 + (-> (primitive "java.lang.Byte") Nat) + (|>> host.byte-to-long (:coerce Nat) (i64.and ..byte-mask))) + + (def: byte + (-> Nat (primitive "java.lang.Byte")) + (`` (for {(~~ (static @.old)) + (|>> .int host.long-to-byte) + + (~~ (static @.jvm)) + (|>> .int (:coerce (primitive "java.lang.Long")) host.long-to-byte)}))))] (`` (for {(~~ (static @.old)) (as-is <for-jvm>) (~~ (static @.jvm)) - (as-is <for-jvm>)}))) + (as-is <for-jvm>) + + (~~ (static @.js)) + (as-is (host.import: ArrayBuffer + (new [host.Number])) + + (host.import: Uint8Array + (new [ArrayBuffer]) + (length host.Number)) + + (type: #export Binary Uint8Array))}))) -(def: byte-mask - I64 - (|> i64.bits-per-byte i64.mask .i64)) +(template: (!size binary) + (`` (for {(~~ (static @.old)) + (host.array-length binary) + + (~~ (static @.jvm)) + (host.array-length binary) -(def: i64 - (-> (primitive "java.lang.Byte") I64) - (|>> host.byte-to-long (:coerce I64) (i64.and ..byte-mask))) + (~~ (static @.js)) + (.frac-to-nat (Uint8Array::length binary))}))) -(def: byte - (-> (I64 Any) (primitive "java.lang.Byte")) +(template: (!read idx binary) (`` (for {(~~ (static @.old)) - (|>> .int host.long-to-byte) + (..i64 (host.array-read idx binary)) (~~ (static @.jvm)) - (|>> .int (:coerce (primitive "java.lang.Long")) host.long-to-byte)}))) + (..i64 (host.array-read idx binary)) -(template: (!size binary) + (~~ (static @.js)) + (|> binary + (: ..Binary) + (:coerce (array.Array .Frac)) + ("js array read" idx) + .frac-to-nat)}))) + +(template: (!write idx value binary) (`` (for {(~~ (static @.old)) - (host.array-length binary) + (host.array-write idx (..byte value) binary) (~~ (static @.jvm)) - (host.array-length binary)}))) + (host.array-write idx (..byte value) binary) + + (~~ (static @.js)) + (|> binary + (: ..Binary) + (:coerce (array.Array .Frac)) + ("js array write" idx (.nat-to-frac value)) + (:coerce ..Binary))}))) (def: #export size (-> Binary Nat) @@ -82,116 +123,165 @@ (|>> (host.array byte)) (~~ (static @.jvm)) - (|>> (host.array byte))}))) + (|>> (host.array byte)) + + (~~ (static @.js)) + (|>> .nat-to-frac [] ArrayBuffer::new Uint8Array::new)}))) (def: #export (read/8 idx binary) - (-> Nat Binary (Error I64)) + (-> Nat Binary (Error Nat)) (if (n/< (..!size binary) idx) - (#error.Success (..i64 (host.array-read idx binary))) + (#error.Success (!read idx binary)) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (read/16 idx binary) - (-> Nat Binary (Error I64)) + (-> Nat Binary (Error Nat)) (if (n/< (..!size binary) (n/+ 1 idx)) (#error.Success ($_ i64.or - (i64.left-shift 8 (..i64 (host.array-read idx binary))) - (..i64 (host.array-read (n/+ 1 idx) binary)))) + (i64.left-shift 8 (!read idx binary)) + (!read (n/+ 1 idx) binary))) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (read/32 idx binary) - (-> Nat Binary (Error I64)) + (-> Nat Binary (Error Nat)) (if (n/< (..!size binary) (n/+ 3 idx)) (#error.Success ($_ i64.or - (i64.left-shift 24 (..i64 (host.array-read idx binary))) - (i64.left-shift 16 (..i64 (host.array-read (n/+ 1 idx) binary))) - (i64.left-shift 8 (..i64 (host.array-read (n/+ 2 idx) binary))) - (..i64 (host.array-read (n/+ 3 idx) binary)))) + (i64.left-shift 24 (!read idx binary)) + (i64.left-shift 16 (!read (n/+ 1 idx) binary)) + (i64.left-shift 8 (!read (n/+ 2 idx) binary)) + (!read (n/+ 3 idx) binary))) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (read/64 idx binary) - (-> Nat Binary (Error I64)) + (-> Nat Binary (Error Nat)) (if (n/< (..!size binary) (n/+ 7 idx)) (#error.Success ($_ i64.or - (i64.left-shift 56 (..i64 (host.array-read idx binary))) - (i64.left-shift 48 (..i64 (host.array-read (n/+ 1 idx) binary))) - (i64.left-shift 40 (..i64 (host.array-read (n/+ 2 idx) binary))) - (i64.left-shift 32 (..i64 (host.array-read (n/+ 3 idx) binary))) - (i64.left-shift 24 (..i64 (host.array-read (n/+ 4 idx) binary))) - (i64.left-shift 16 (..i64 (host.array-read (n/+ 5 idx) binary))) - (i64.left-shift 8 (..i64 (host.array-read (n/+ 6 idx) binary))) - (..i64 (host.array-read (n/+ 7 idx) binary)))) + (i64.left-shift 56 (!read idx binary)) + (i64.left-shift 48 (!read (n/+ 1 idx) binary)) + (i64.left-shift 40 (!read (n/+ 2 idx) binary)) + (i64.left-shift 32 (!read (n/+ 3 idx) binary)) + (i64.left-shift 24 (!read (n/+ 4 idx) binary)) + (i64.left-shift 16 (!read (n/+ 5 idx) binary)) + (i64.left-shift 8 (!read (n/+ 6 idx) binary)) + (!read (n/+ 7 idx) binary))) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (write/8 idx value binary) - (-> Nat (I64 Any) Binary (Error Binary)) + (-> Nat Nat Binary (Error Binary)) (if (n/< (..!size binary) idx) (exec (|> binary - (host.array-write idx (..byte value))) + (!write idx value)) (#error.Success binary)) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (write/16 idx value binary) - (-> Nat (I64 Any) Binary (Error Binary)) + (-> Nat Nat Binary (Error Binary)) (if (n/< (..!size binary) (n/+ 1 idx)) (exec (|> binary - (host.array-write idx (..byte (i64.logic-right-shift 8 value))) - (host.array-write (n/+ 1 idx) (..byte value))) + (!write idx (i64.logic-right-shift 8 value)) + (!write (n/+ 1 idx) value)) (#error.Success binary)) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (write/32 idx value binary) - (-> Nat (I64 Any) Binary (Error Binary)) + (-> Nat Nat Binary (Error Binary)) (if (n/< (..!size binary) (n/+ 3 idx)) (exec (|> binary - (host.array-write idx (..byte (i64.logic-right-shift 24 value))) - (host.array-write (n/+ 1 idx) (..byte (i64.logic-right-shift 16 value))) - (host.array-write (n/+ 2 idx) (..byte (i64.logic-right-shift 8 value))) - (host.array-write (n/+ 3 idx) (..byte value))) + (!write idx (i64.logic-right-shift 24 value)) + (!write (n/+ 1 idx) (i64.logic-right-shift 16 value)) + (!write (n/+ 2 idx) (i64.logic-right-shift 8 value)) + (!write (n/+ 3 idx) value)) (#error.Success binary)) (exception.throw index-out-of-bounds [(..!size binary) idx]))) (def: #export (write/64 idx value binary) - (-> Nat (I64 Any) Binary (Error Binary)) + (-> Nat Nat Binary (Error Binary)) (if (n/< (..!size binary) (n/+ 7 idx)) (exec (|> binary - (host.array-write idx (..byte (i64.logic-right-shift 56 value))) - (host.array-write (n/+ 1 idx) (..byte (i64.logic-right-shift 48 value))) - (host.array-write (n/+ 2 idx) (..byte (i64.logic-right-shift 40 value))) - (host.array-write (n/+ 3 idx) (..byte (i64.logic-right-shift 32 value))) - (host.array-write (n/+ 4 idx) (..byte (i64.logic-right-shift 24 value))) - (host.array-write (n/+ 5 idx) (..byte (i64.logic-right-shift 16 value))) - (host.array-write (n/+ 6 idx) (..byte (i64.logic-right-shift 8 value))) - (host.array-write (n/+ 7 idx) (..byte value))) + (!write idx (i64.logic-right-shift 56 value)) + (!write (n/+ 1 idx) (i64.logic-right-shift 48 value)) + (!write (n/+ 2 idx) (i64.logic-right-shift 40 value)) + (!write (n/+ 3 idx) (i64.logic-right-shift 32 value)) + (!write (n/+ 4 idx) (i64.logic-right-shift 24 value)) + (!write (n/+ 5 idx) (i64.logic-right-shift 16 value)) + (!write (n/+ 6 idx) (i64.logic-right-shift 8 value)) + (!write (n/+ 7 idx) value)) (#error.Success binary)) (exception.throw index-out-of-bounds [(..!size binary) idx]))) -(def: #export (slice from to binary) - (-> Nat Nat Binary (Error Binary)) - (let [size (..!size binary)] - (cond (not (n/<= to from)) - (exception.throw inverted-slice [size from to]) - - (not (and (n/< size from) - (n/< size to))) - (exception.throw slice-out-of-bounds [size from to]) - - ## else - (#error.Success (java/util/Arrays::copyOfRange binary (.int from) (.int (inc to))))))) - -(def: #export (slice' from binary) - (-> Nat Binary (Error Binary)) - (slice from (dec (..!size binary)) binary)) - (structure: #export equivalence (Equivalence Binary) (def: (= reference sample) (`` (for {(~~ (static @.old)) (java/util/Arrays::equals reference sample) (~~ (static @.jvm)) - (java/util/Arrays::equals reference sample)})))) + (java/util/Arrays::equals reference sample)} + (let [limit (!size reference)] + (and (n/= limit + (!size sample)) + (loop [idx 0] + (if (n/< limit idx) + (and (n/= (!read idx reference) + (!read idx sample)) + (recur (inc idx))) + true)))))))) + +(`` (for {(~~ (static @.old)) + (as-is) + + (~~ (static @.jvm)) + (as-is)} + + ## Default + (exception: #export (cannot-copy-bytes {source-input Nat} + {target-output Nat}) + (exception.report + ["Source input space" (%n source-input)] + ["Target output space" (%n target-output)])))) (def: #export (copy bytes source-offset source target-offset target) (-> Nat Nat Binary Nat Binary (Error Binary)) - (do error.monad - [_ (java/lang/System::arraycopy source (.int source-offset) target (.int target-offset) (.int bytes))] - (wrap target))) + (with-expansions [<for-jvm> (as-is (do error.monad + [_ (java/lang/System::arraycopy source (.int source-offset) target (.int target-offset) (.int bytes))] + (wrap target)))] + (`` (for {(~~ (static @.old)) + <for-jvm> + + (~~ (static @.jvm)) + <for-jvm>} + + ## Default + (let [source-input (n/- source-offset (!size source)) + target-output (n/- target-offset (!size target))] + (if (n/<= target-output source-input) + (loop [idx 0] + (if (n/< source-input idx) + (exec (!write (n/+ target-offset idx) + (!read (n/+ source-offset idx) source) + target) + (recur (inc idx))) + (#error.Success target))) + (exception.throw ..cannot-copy-bytes [source-input target-output]))))))) + +(def: #export (slice from to binary) + (-> Nat Nat Binary (Error Binary)) + (let [size (..!size binary)] + (if (n/<= to from) + (if (and (n/< size from) + (n/< size to)) + (with-expansions [<for-jvm> (as-is (#error.Success (java/util/Arrays::copyOfRange binary (.int from) (.int (inc to)))))] + (`` (for {(~~ (static @.old)) + <for-jvm> + + (~~ (static @.jvm)) + <for-jvm>} + + ## Default + (let [how-many (n/- from to)] + (..copy how-many from binary 0 (..create how-many)))))) + (exception.throw slice-out-of-bounds [size from to])) + (exception.throw inverted-slice [size from to])))) + +(def: #export (slice' from binary) + (-> Nat Binary (Error Binary)) + (slice from (dec (..!size binary)) binary)) |