diff options
Diffstat (limited to '')
10 files changed, 245 insertions, 74 deletions
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux index 35c44af0d..62ef08f4b 100644 --- a/stdlib/source/lux/data/format/binary.lux +++ b/stdlib/source/lux/data/format/binary.lux @@ -60,7 +60,7 @@ (def: #export (run writer value) (All [a] (-> (Writer a) a Binary)) - (instance (writer value))) + (..instance (writer value))) (template [<name> <size> <write>] [(def: #export <name> diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 4622c8be9..3296f78c4 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -204,7 +204,9 @@ (pack [Text] RubyString))) @.php - (as_is (host.import: (unpack [host.String host.String] Binary)) + (as_is (host.import: Almost_Binary) + (host.import: (unpack [host.String host.String] Almost_Binary)) + (host.import: (array_values [Almost_Binary] Binary)) (def: php_byte_array_format "C*"))} (as_is))) @@ -249,7 +251,10 @@ (RubyString::bytes [])) @.php - (..unpack [..php_byte_array_format value])})) + (|> (..unpack [..php_byte_array_format value]) + ..array_values + ("php object new" "ArrayObject") + (:coerce Binary))})) (def: (utf8\decode value) (-> Binary (Try Text)) diff --git a/stdlib/source/lux/target/php.lux b/stdlib/source/lux/target/php.lux index f76d9cdc0..9ef2511a7 100644 --- a/stdlib/source/lux/target/php.lux +++ b/stdlib/source/lux/target/php.lux @@ -281,17 +281,25 @@ ["chr"] ["print"] ["exit"] - ["iconv_strlen"] ["strlen"]]] + ["iconv_strlen"] ["strlen"] + ["log"] + ["ceil"] + ["floor"] + ["is_nan"]]] [2 [["intdiv"] + ["fmod"] + ["number_format"] ["array_key_exists"] ["call_user_func_array"] ["array_slice"] ["array_push"] ["pack"] ["unpack"] - ["iconv_strpos"] ["strpos"]]] + ["iconv_strpos"] ["strpos"] + ["pow"] + ["max"]]] [3 [["array_fill"] @@ -390,9 +398,15 @@ [concat "."] ) - (def: #export not - (-> Computation Computation) - (|>> :representation (format "!") :abstraction)) + (template [<unary> <name>] + [(def: #export <name> + (-> Computation Computation) + (|>> :representation (format <unary>) :abstraction))] + + ["!" not] + ["~" bit_not] + ["-" negate] + ) (def: #export (set var value) (-> Location Expression Computation) @@ -400,6 +414,10 @@ ..group :abstraction)) + (def: #export (set! var value) + (-> Location Expression Statement) + (:abstraction (format (:representation var) " = " (:representation value) ";"))) + (def: #export (set? var) (-> Var Computation) (..apply/1 [var] (..constant "isset"))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux index 70437ea89..603abc6ec 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux @@ -118,6 +118,16 @@ (for {@.php host.Function} Any)) +(def: object::new + Handler + (custom + [($_ <>.and <c>.text (<>.some <c>.any)) + (function (_ extension phase archive [constructor inputsC]) + (do {! phase.monad} + [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))])) + (def: object::get Handler (custom @@ -148,6 +158,7 @@ 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 ..Null)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux index 7dbc8bacc..19e8c8e12 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux @@ -104,6 +104,10 @@ (/.install "try" (unary //runtime.lux//try)) )) +(def: (left_shift [parameter subject]) + (Binary Expression) + (_.bit_shl (_.% (_.int +64) parameter) subject)) + (def: i64_procs Bundle (<| (/.prefix "i64") @@ -111,13 +115,13 @@ (/.install "and" (binary (product.uncurry _.bit_and))) (/.install "or" (binary (product.uncurry _.bit_or))) (/.install "xor" (binary (product.uncurry _.bit_xor))) - (/.install "left-shift" (binary (product.uncurry _.bit_shl))) + (/.install "left-shift" (binary ..left_shift)) (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) (/.install "=" (binary (product.uncurry _.==))) - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) (/.install "<" (binary (product.uncurry _.<))) - (/.install "*" (binary (product.uncurry _.*))) + (/.install "+" (binary (product.uncurry //runtime.i64//+))) + (/.install "-" (binary (product.uncurry //runtime.i64//-))) + (/.install "*" (binary (product.uncurry //runtime.i64//*))) (/.install "/" (binary (function (_ [parameter subject]) (_.intdiv/2 [subject parameter])))) (/.install "%" (binary (product.uncurry _.%))) @@ -127,21 +131,25 @@ (def: (f64//% [parameter subject]) (Binary Expression) - (_./ (_.float +1.0) (_.% parameter subject))) + (_.fmod/2 [subject parameter])) + +(def: (f64//encode subject) + (Unary Expression) + (_.number_format/2 [subject (_.int +17)])) (def: f64_procs Bundle (<| (/.prefix "f64") (|> /.empty + (/.install "=" (binary (product.uncurry _.==))) + (/.install "<" (binary (product.uncurry _.<))) (/.install "+" (binary (product.uncurry _.+))) (/.install "-" (binary (product.uncurry _.-))) (/.install "*" (binary (product.uncurry _.*))) (/.install "/" (binary (product.uncurry _./))) (/.install "%" (binary ..f64//%)) - (/.install "=" (binary (product.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) (/.install "i64" (unary _.intval/1)) - (/.install "encode" (unary _.strval/1)) + (/.install "encode" (unary ..f64//encode)) (/.install "decode" (unary //runtime.f64//decode))))) (def: (text//clip [paramO extraO subjectO]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux index 794d4aff2..d93fd04ff 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux @@ -59,6 +59,14 @@ (/.install "delete" (binary array::delete)) ))) +(def: object::new + (custom + [($_ <>.and <s>.text (<>.some <s>.any)) + (function (_ extension phase archive [constructor inputsS]) + (do {! ////////phase.monad} + [inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.new (_.constant constructor) inputsG))))])) + (def: object::get Handler (custom @@ -89,6 +97,7 @@ Bundle (<| (/.prefix "object") (|> /.empty + (/.install "new" object::new) (/.install "get" object::get) (/.install "do" object::do) (/.install "null" (nullary object::null)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux index f434e9dbd..5a4375dad 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -524,20 +524,6 @@ (_.bit_or (up_16 x16) x00))) )))) -## (runtime: (i64//* parameter subject) -## (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))] -## (_.cond (list [(negative? subject) -## (_.if (negative? parameter) -## ## Both are negative -## (_.return (i64//*' (i64//negate parameter) (i64//negate subject))) -## ## Subject is negative -## (_.return (i64//negate (i64//*' parameter (i64//negate subject)))))] -## [(negative? parameter) -## ## Parameter is negative -## (_.return (i64//negate (i64//*' (i64//negate parameter) subject)))]) -## ## Both are positive -## (_.return (i64//*' parameter subject))))) - (runtime: (i64//< parameter subject) (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))] (with_vars [-subject? -parameter?] @@ -665,7 +651,6 @@ @i64//to_number @i64//from_number @i64//- - ## @i64//*' @i64//* @i64//< @i64/// diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux index 7838ce804..242519aa9 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux @@ -6,7 +6,7 @@ [number ["." frac]]] [target - ["_" php (#+ Literal)]]] + ["_" php (#+ Literal Expression)]]] ["." // #_ ["#." runtime]]) @@ -14,9 +14,13 @@ (-> Bit Literal) _.bool) -(def: #export i64 - (-> (I64 Any) Literal) - (|>> .int _.int)) +(def: #export (i64 value) + (-> (I64 Any) Expression) + (let [h32 (|> value //runtime.high .int _.int) + l32 (|> value //runtime.low .int _.int)] + (|> h32 + (_.bit_shl (_.int +32)) + (_.bit_or l32)))) (def: #export f64 (-> Frac Literal) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux index bdf18462a..651e3854f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux @@ -163,7 +163,7 @@ (runtime: (array//write idx value array) ($_ _.then - (_.; (_.set (_.nth idx array) value)) + (_.set! (_.nth idx array) value) (_.return array))) (def: runtime//array @@ -180,12 +180,12 @@ (|>> _.count/1 (_.- (_.int +1)))) (with_expansions [<recur> (as_is ($_ _.then - (_.; (_.set lefts (_.- last_index_right lefts))) - (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (_.set! lefts (_.- last_index_right lefts)) + (_.set! tuple (_.nth last_index_right tuple))))] (runtime: (tuple//make size values) (_.if ..jphp? ($_ _.then - (_.; (_.set (..tuple_size values) size)) + (_.set! (..tuple_size values) size) (_.return values)) ## https://www.php.net/manual/en/language.operators.assignment.php ## https://www.php.net/manual/en/language.references.php @@ -199,8 +199,8 @@ (<| (_.while (_.bool true)) ($_ _.then (_.if ..jphp? - (_.; (_.set last_index_right (..jphp_last_index tuple))) - (_.; (_.set last_index_right (..normal_last_index tuple)))) + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) (_.if (_.> lefts last_index_right) ## No need for recursion (_.return (_.nth lefts tuple)) @@ -211,13 +211,13 @@ (runtime: (tuple//slice offset input) (with_vars [size index output] ($_ _.then - (_.; (_.set size (..array//length input))) - (_.; (_.set index (_.int +0))) - (_.; (_.set output (_.array/* (list)))) + (_.set! size (..array//length input)) + (_.set! index (_.int +0)) + (_.set! output (_.array/* (list))) (<| (_.while (|> index (_.+ offset) (_.< size))) ($_ _.then - (_.; (_.set (_.nth index output) (_.nth (_.+ offset index) input))) - (_.; (_.set index (_.+ (_.int +1) index))) + (_.set! (_.nth index output) (_.nth (_.+ offset index) input)) + (_.set! index (_.+ (_.int +1) index)) )) (_.return (..tuple//make (_.- offset size) output)) ))) @@ -227,9 +227,9 @@ (<| (_.while (_.bool true)) ($_ _.then (_.if ..jphp? - (_.; (_.set last_index_right (..jphp_last_index tuple))) - (_.; (_.set last_index_right (..normal_last_index tuple)))) - (_.; (_.set right_index (_.+ (_.int +1) lefts))) + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) + (_.set! right_index (_.+ (_.int +1) lefts)) (_.cond (list [(_.=== last_index_right right_index) (_.return (_.nth right_index tuple))] [(_.> last_index_right right_index) @@ -239,7 +239,7 @@ (_.return (..tuple//make (_.- right_index (..tuple_size tuple)) (..tuple//slice right_index tuple))) (_.return (..tuple//make (_.- right_index (_.count/1 tuple)) - (_.array_slice/2 [tuple right_index]))))) + (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index]))))) ))))) (def: #export variant_tag_field "_lux_tag") @@ -285,8 +285,8 @@ test_recursion! (_.if is_last? ## Must recurse. ($_ _.then - (_.; (_.set wantedTag (_.- sum_tag wantedTag))) - (_.; (_.set sum sum_value))) + (_.set! wantedTag (_.- sum_tag wantedTag)) + (_.set! sum sum_value)) no_match!)] (<| (_.while (_.bool true)) (_.cond (list [(_.=== sum_tag wantedTag) @@ -315,7 +315,7 @@ (runtime: (lux//try op) (with_vars [value] (_.try ($_ _.then - (_.; (_.set value (_.apply/1 op [..unit]))) + (_.set! value (_.apply/1 op [..unit])) (_.return (..right value))) (list (with_vars [error] {#_.class (_.constant "Exception") @@ -325,9 +325,9 @@ (runtime: (lux//program_args inputs) (with_vars [head tail] ($_ _.then - (_.; (_.set tail ..none)) + (_.set! tail ..none) (<| (_.for_each (_.array_reverse/1 inputs) head) - (_.; (_.set tail (..some (_.array/* (list head tail)))))) + (_.set! tail (..some (_.array/* (list head tail))))) (_.return tail)))) (def: runtime//lux @@ -337,6 +337,15 @@ @lux//program_args )) +(def: #export high + (-> (I64 Any) (I64 Any)) + (i64.right_shift 32)) + +(def: #export low + (-> (I64 Any) (I64 Any)) + (let [mask (dec (i64.left_shift 32 1))] + (|>> (i64.and mask)))) + (runtime: (i64//right_shift param subject) (let [## The mask has to be calculated this way instead of in a more straightforward way ## because in some languages, 1<<63 = max_negative_value @@ -351,10 +360,12 @@ (_.bit_shl (_.int +1)) (_.+ (_.int +1)))] ($_ _.then - (_.; (_.set param (_.% (_.int +64) param))) - (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask)))))) + (_.set! param (_.% (_.int +64) param)) + (_.if (_.=== (_.int +0) param) + (_.return subject) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask))))))) (runtime: (i64//char code) (_.if ..jphp? @@ -365,11 +376,129 @@ [(_.string "UTF-32LE") (_.string "UTF-8")] _.iconv/3)))) +(runtime: (i64//+ parameter subject) + (let [high_16 (..i64//right_shift (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shift (_.int +48)) + hl (|>> (..i64//right_shift (_.int +32)) cap_16) + lh (|>> (..i64//right_shift (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.+ l00 r00)) + + (_.set! x16 (|> (high_16 x00) + (_.+ l16) + (_.+ r16))) + (_.set! x00 (low_16 x00)) + + (_.set! x32 (|> (high_16 x16) + (_.+ l32) + (_.+ r32))) + (_.set! x16 (low_16 x16)) + + (_.set! x48 (|> (high_16 x32) + (_.+ l48) + (_.+ r48) + low_16)) + (_.set! x32 (low_16 x32)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + +(runtime: (i64//negate value) + (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))] + (_.if (_.=== i64//min value) + (_.return i64//min) + (_.return (..i64//+ (_.int +1) (_.bit_not value)))))) + +(runtime: (i64//- parameter subject) + (_.return (..i64//+ (..i64//negate parameter) subject))) + +(runtime: (i64//* parameter subject) + (let [high_16 (..i64//right_shift (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shift (_.int +48)) + hl (|>> (..i64//right_shift (_.int +32)) cap_16) + lh (|>> (..i64//right_shift (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.* l00 r00)) + (_.set! x16 (high_16 x00)) + (_.set! x00 (low_16 x00)) + + (_.set! x16 (|> x16 (_.+ (_.* l16 r00)))) + (_.set! 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)))) + (_.set! 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)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + (def: runtime//i64 Statement ($_ _.then @i64//right_shift @i64//char + @i64//+ + @i64//negate + @i64//- + @i64//* )) (runtime: (text//size value) @@ -378,18 +507,20 @@ (_.return (_.iconv_strlen/1 [value])))) (runtime: (text//index subject param start) - (with_vars [idx] - (_.if ..jphp? - ($_ _.then - (_.; (_.set idx (_.strpos/3 [subject param start]))) - (_.if (_.=== (_.bool false) idx) - (_.return ..none) - (_.return (..some idx)))) - ($_ _.then - (_.; (_.set idx (_.iconv_strpos/3 [subject param start]))) - (_.if (_.=== (_.bool false) idx) - (_.return ..none) - (_.return (..some idx))))))) + (_.if (_.=== (_.string "") param) + (_.return (..some (_.int +0))) + (with_vars [idx] + (_.if ..jphp? + ($_ _.then + (_.set! idx (_.strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))) + ($_ _.then + (_.set! idx (_.iconv_strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))))))) (def: (within? top value) (-> Expression Expression Computation) @@ -425,7 +556,7 @@ (runtime: (f64//decode value) (with_vars [output] ($_ _.then - (_.; (_.set output (_.floatval/1 value))) + (_.set! output (_.floatval/1 value)) (_.if (_.=== (_.float +0.0) output) (_.if ($_ _.or (_.=== (_.string "0.0") output) diff --git a/stdlib/source/test/lux/control/remember.lux b/stdlib/source/test/lux/control/remember.lux index 1002e3a11..168f29f12 100644 --- a/stdlib/source/test/lux/control/remember.lux +++ b/stdlib/source/test/lux/control/remember.lux @@ -28,8 +28,8 @@ ["." /]}) (def: deadline (Random Date) random.date) -(def: message (Random Text) (random.ascii/lower 10)) -(def: focus (Random Code) (random\map code.text (random.ascii/upper 10))) +(def: message (Random Text) (random\map %.bit random.bit)) +(def: focus (Random Code) (random\map code.bit random.bit)) (def: (to_remember macro deadline message focus) (-> Name Date Text (Maybe Code) Code) |