From 12a1849090a819ad1e7e9209791b727908e202d3 Mon Sep 17 00:00:00 2001 From: Techcable Date: Thu, 25 Aug 2022 20:46:44 -0700 Subject: [PATCH 001/138] Add utilities for contains? and contains-key? This is significantly clearer than using (not (nil? (index-of col val))) Most major programming languages offer some sort of contains function (Python, Java, C, Rust). The only exception I know of is C. --- src/boot/boot.janet | 83 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 83 insertions(+) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index ad869e00..eae23a3d 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -120,6 +120,9 @@ (defn indexed? "Check if x is an array or tuple." [x] (def t (type x)) (if (= t :array) true (= t :tuple))) +(defn collection? "Check if x is an array, tuple, table, or struct" [x] + (def t (type x)) + (if (= t :array) true (if (= t :tuple) true (if (= t :table) true (= t :struct))))) (defn truthy? "Check if x is truthy." [x] (if x true false)) (defn true? "Check if x is true." [x] (= x true)) (defn false? "Check if x is false." [x] (= x false)) @@ -1194,6 +1197,86 @@ (def kw (keyword prefix (slice alias 1 -2))) ~(def ,alias :dyn ,;more ,kw)) + +(defn- collection-type-error [val] + (errorf "Expected a collection (tuple|array|table|struct), but got %t" val)) + +(defn contains-value? + ```Checks if a collection contains the specified value. + + Semantically equivalent to `(contains? (values dict) val)`, + but implemented more efficiently. + + Unlike contains-key?, this has worst-case O(n) performance. + Noe that tables or structs (dictionaries) never contain null keys``` + [collection target-val] + # Avoid allocating intermediate array for dictionary + # This works for both dictionaries and sequences + (cond + (indexed? collection) (not (nil? (index-of target-val collection))) + (dictionary? collection) + (do + (var res false) + (var k (next collection nil)) + (unless (or (nil? k) (nil? target-val)) + (while true + (def val (in collection k)) + (cond + # We found a result, this will break the loop + (= val target-val) (do + (set res true) + (break)) + # Reached end of dictionary + (nil? k) (break)) + (set k (next collection k)))) + res) + (collection-type-error collection))) + +(defn contains-key? + ```Checks if a collection contains the specified key. + + Functions the same as contains? for dictionaries (table/structs). + Arrays and tuples are indexed by integer keys, and this function simply + checks if the index is valid. + + If this function succeeds, then a call to `(in collection key)` is guarenteed + to succeed as well. + + For dictionaries, this should be (approximate) O(1) time due to the + guarentees of table/struct. + For arrays and tuples it should likewise be O(1) because it is simply a comparison. + + Note that this intentionally excludes string (and buffer types), for the same reasons + as `contains?` does. + + Noe that tables or structs (dictionaries) never contain null keys``` + [collection key] + (assert (collection? collection) (collection-type-error collection)) + (not (nil? (get collection key)))) + +(defn contains? + ```Checks if a collection contains the specified value (or key). + + For tables and structs, this only checks the keys, + and not the values. + + For arrays and tuples this takes O(n) time, + while for tables and structs this takes (average) O(1) time. + + This intentionally throws an error when strings are encountered. Technically, + strings are an iterable type, they will succeed with `next` and `index-of`. + Interpreting a string as an iterable type, one would expect this to check "contains byte". + However, the user would very probably expect "contains substring". + Therefore, we intentionally forbid strings (and other buffer types). + + Note that dictionaries never contain null keys``` + [collection val] + (cond + (indexed? collection) (not (nil? (index-of val collection))) + (dictionary? collection) (not (nil? (get collection val))) + (collection-type-error collection))) + + (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. Use this to prevent keyword collisions between dynamic bindings.``) (defdyn *out* "Where normal print functions print output to.") From 765eb84c33672cc08908687e1a98085187019665 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 12:23:02 -0700 Subject: [PATCH 002/138] on bad type, contains? shuld return false (not error) Note this actually changes behavior from a thin wrapper over `index-of`. This is because `(index-of 3 3)` throws "error: expected iterable type, got 3" --- src/boot/boot.janet | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index eae23a3d..bbc9de5c 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1198,9 +1198,6 @@ ~(def ,alias :dyn ,;more ,kw)) -(defn- collection-type-error [val] - (errorf "Expected a collection (tuple|array|table|struct), but got %t" val)) - (defn contains-value? ```Checks if a collection contains the specified value. @@ -1230,7 +1227,7 @@ (nil? k) (break)) (set k (next collection k)))) res) - (collection-type-error collection))) + false)) (defn contains-key? ```Checks if a collection contains the specified key. @@ -1251,7 +1248,6 @@ Noe that tables or structs (dictionaries) never contain null keys``` [collection key] - (assert (collection? collection) (collection-type-error collection)) (not (nil? (get collection key)))) (defn contains? @@ -1274,7 +1270,7 @@ (cond (indexed? collection) (not (nil? (index-of val collection))) (dictionary? collection) (not (nil? (get collection val))) - (collection-type-error collection))) + false)) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. From 699f9622d7662af42c2e0ed409ec2ff4f1c9e2a9 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 14:24:54 -0700 Subject: [PATCH 003/138] Warn about index-of type errors when not iterable This is just documentation of existing behavior, it does not change anything. The reason index-of throws a type error on non-iterable types is because `next` does. This is hardcoded into the JOP_NEXT opcode (see src/core/value.c:janet_next_impl). Unfortunately, there is currently no corresponding `iterable?` check. --- src/boot/boot.janet | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index bbc9de5c..1609facc 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1072,7 +1072,9 @@ (defn index-of ``Find the first key associated with a value x in a data structure, acting like a reverse lookup. Will not look at table prototypes. - Returns `dflt` if not found.`` + Returns `dflt` if not found. + + This will throw an error if `ind` is not iterable.`` [x ind &opt dflt] (var k (next ind nil)) (var ret dflt) From 927e9e4e4d59569bda4e1fe51d1362d122f7c495 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 14:22:27 -0700 Subject: [PATCH 004/138] Make contains? consistently iterate over values. Remove `contains-value?` because it is now redundant. Clarify in the documentation that it checks dictionary values. --- src/boot/boot.janet | 76 +++++++++++++-------------------------------- 1 file changed, 22 insertions(+), 54 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 1609facc..8559ce80 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1200,60 +1200,23 @@ ~(def ,alias :dyn ,;more ,kw)) -(defn contains-value? - ```Checks if a collection contains the specified value. - - Semantically equivalent to `(contains? (values dict) val)`, - but implemented more efficiently. - - Unlike contains-key?, this has worst-case O(n) performance. - Noe that tables or structs (dictionaries) never contain null keys``` - [collection target-val] - # Avoid allocating intermediate array for dictionary - # This works for both dictionaries and sequences - (cond - (indexed? collection) (not (nil? (index-of target-val collection))) - (dictionary? collection) - (do - (var res false) - (var k (next collection nil)) - (unless (or (nil? k) (nil? target-val)) - (while true - (def val (in collection k)) - (cond - # We found a result, this will break the loop - (= val target-val) (do - (set res true) - (break)) - # Reached end of dictionary - (nil? k) (break)) - (set k (next collection k)))) - res) - false)) - (defn contains-key? ```Checks if a collection contains the specified key. - Functions the same as contains? for dictionaries (table/structs). - Arrays and tuples are indexed by integer keys, and this function simply - checks if the index is valid. + Semantically equivalent to `(not (nil? (get collection key)))`. + + Arrays, tuples, and buffer types (string/keyword) are indexed by integer keys. + For those types, this function simply checks if the index is valid. If this function succeeds, then a call to `(in collection key)` is guarenteed to succeed as well. - For dictionaries, this should be (approximate) O(1) time due to the - guarentees of table/struct. - For arrays and tuples it should likewise be O(1) because it is simply a comparison. - - Note that this intentionally excludes string (and buffer types), for the same reasons - as `contains?` does. - - Noe that tables or structs (dictionaries) never contain null keys``` + Note that tables or structs (dictionaries) never contain null keys``` [collection key] (not (nil? (get collection key)))) (defn contains? - ```Checks if a collection contains the specified value (or key). + ```Checks if a collection, buffer, or any other iterable type contains the specified value. For tables and structs, this only checks the keys, and not the values. @@ -1261,18 +1224,23 @@ For arrays and tuples this takes O(n) time, while for tables and structs this takes (average) O(1) time. - This intentionally throws an error when strings are encountered. Technically, - strings are an iterable type, they will succeed with `next` and `index-of`. - Interpreting a string as an iterable type, one would expect this to check "contains byte". - However, the user would very probably expect "contains substring". - Therefore, we intentionally forbid strings (and other buffer types). - - Note that dictionaries never contain null keys``` + Warning: For buffer types (strings, buffers, keywords), this checks if the specified byte is present. + Technically, buffers and strings are an iterable type, they will also work with `next` and `index-of`. + + If the type is not iterable, this will return false. + + NOTE on strings: `(contains? str val) will only check for byte values of `val`, not substrings. + In other words is `(contains? "foo bar" foo") will return false (because "foo" is not an integer byte). + If you want to check for a substring in a buffer, then use `(not (nil? (string/find substr :foo)))` + + In general this function has O(n) performance, since it requires iterating over all the values. + + Note that tables or structs (dictionaries) never contain null values``` [collection val] - (cond - (indexed? collection) (not (nil? (index-of val collection))) - (dictionary? collection) (not (nil? (get collection val))) - false)) + # NOTE: index-of throws excpetion if `collection` is not iterable + # + # guard against that + (try (not (nil? (index-of val collection))) false)) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. From 754b61c5930d3d2db37d9d5ba2b637b44bd5bbc6 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 15:17:20 -0700 Subject: [PATCH 005/138] Clarify documentation of contains? Also contains-value? --- src/boot/boot.janet | 48 +++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 8559ce80..2a2252ce 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1202,44 +1202,46 @@ (defn contains-key? ```Checks if a collection contains the specified key. - + Semantically equivalent to `(not (nil? (get collection key)))`. - - Arrays, tuples, and buffer types (string/keyword) are indexed by integer keys. - For those types, this function simply checks if the index is valid. - + + Arrays, tuples, and buffer types (string, buffer, keyword, symbol) are all indexed by integer keys. + For those types, this function simply checks if the index is less than the length. + If this function succeeds, then a call to `(in collection key)` is guarenteed to succeed as well. - + Note that tables or structs (dictionaries) never contain null keys``` [collection key] (not (nil? (get collection key)))) (defn contains? - ```Checks if a collection, buffer, or any other iterable type contains the specified value. - - For tables and structs, this only checks the keys, - and not the values. - - For arrays and tuples this takes O(n) time, - while for tables and structs this takes (average) O(1) time. + ```Checks if a collection contains the specified value. + + This supports any iterable type by way of the `next` function. + This includes buffers, dictionaries, arrays, fibers, and possibly abstract types. + + For tables and structs, this checks the values, not the keys. + For arrays, tuples (and any other iterable type), this simply checks if any of the values are eqyak. + + For buffer types (strings, buffers, keywords), this checks if the specified byte is present. + This is because, buffer types (strings, keywords, symbols) are iterable types, with byte values. + This means they will also work with `next` and `index-of`. + + However, it also means this function will not check for substrings, only integer bytes. + In other words is `(contains? "foo bar" "foo")` is always false, because "foo" is not an integer byte + If you want to check for a substring in a buffer, then use `(not (nil? (string/find substr buffer)))` - Warning: For buffer types (strings, buffers, keywords), this checks if the specified byte is present. - Technically, buffers and strings are an iterable type, they will also work with `next` and `index-of`. - If the type is not iterable, this will return false. - - NOTE on strings: `(contains? str val) will only check for byte values of `val`, not substrings. - In other words is `(contains? "foo bar" foo") will return false (because "foo" is not an integer byte). - If you want to check for a substring in a buffer, then use `(not (nil? (string/find substr :foo)))` - + This is in contrast to `index-of` and `next`, which will throw a type error. + In general this function has O(n) performance, since it requires iterating over all the values. - + Note that tables or structs (dictionaries) never contain null values``` [collection val] # NOTE: index-of throws excpetion if `collection` is not iterable # - # guard against that + # We want to guard against that (try (not (nil? (index-of val collection))) false)) From 7203c046f91b140895bbc90df592929b7539d6df Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 15:23:52 -0700 Subject: [PATCH 006/138] Remove collection? type test No longer used to guard the type tests. --- src/boot/boot.janet | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 2a2252ce..fd338855 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -120,9 +120,6 @@ (defn indexed? "Check if x is an array or tuple." [x] (def t (type x)) (if (= t :array) true (= t :tuple))) -(defn collection? "Check if x is an array, tuple, table, or struct" [x] - (def t (type x)) - (if (= t :array) true (if (= t :tuple) true (if (= t :table) true (= t :struct))))) (defn truthy? "Check if x is truthy." [x] (if x true false)) (defn true? "Check if x is true." [x] (= x true)) (defn false? "Check if x is false." [x] (= x false)) From f778e8bbd17560a65b167f5691998d522cc5a9a1 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 15:35:26 -0700 Subject: [PATCH 007/138] Fix incorrect usage of the test macro I need unit tests.... --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index fd338855..17a6601a 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1239,7 +1239,7 @@ # NOTE: index-of throws excpetion if `collection` is not iterable # # We want to guard against that - (try (not (nil? (index-of val collection))) false)) + (try (not (nil? (index-of val collection))) [[_] false])) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. From a20612478e8783feb708ac818144cc2f2537eaf4 Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 20:36:17 -0700 Subject: [PATCH 008/138] Remove try from contains?, allowing type errors MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit > Remove the try. In dynamic languages, the usual idea is garbage in, garbage out. You misunderstood my point about the type error. “Test” functions are not special in that regard. > - @bakpakin --- src/boot/boot.janet | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 17a6601a..8d443f2f 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1236,10 +1236,7 @@ Note that tables or structs (dictionaries) never contain null values``` [collection val] - # NOTE: index-of throws excpetion if `collection` is not iterable - # - # We want to guard against that - (try (not (nil? (index-of val collection))) [[_] false])) + (not (nil? (index-of val collection)))) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. From c099ec05eecf8e494510762f5a396797c292d7bc Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 20:38:57 -0700 Subject: [PATCH 009/138] Remove documentation on type error from index-of Three reasons: 1. This same behavior is not documented on the `next` function 2. This function does not throw the error directly, it only throws an error because `next` does. 3. Following the same idea as the previous commit, this behavior is more or less implementation-defined for nonsensical types > In dynamic languages, the usual idea is garbage in, garbage out. Various other documentation cleanup. --- src/boot/boot.janet | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 8d443f2f..dff8efb1 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1069,9 +1069,7 @@ (defn index-of ``Find the first key associated with a value x in a data structure, acting like a reverse lookup. Will not look at table prototypes. - Returns `dflt` if not found. - - This will throw an error if `ind` is not iterable.`` + Returns `dflt` if not found.`` [x ind &opt dflt] (var k (next ind nil)) (var ret dflt) @@ -1219,18 +1217,16 @@ This includes buffers, dictionaries, arrays, fibers, and possibly abstract types. For tables and structs, this checks the values, not the keys. - For arrays, tuples (and any other iterable type), this simply checks if any of the values are eqyak. + For arrays, tuples (and any other iterable type), this simply checks if any of the values are equal. For buffer types (strings, buffers, keywords), this checks if the specified byte is present. - This is because, buffer types (strings, keywords, symbols) are iterable types, with byte values. + This is because, buffer types (strings, keywords, symbols) are simply sequences, with byte values. This means they will also work with `next` and `index-of`. - However, it also means this function will not check for substrings, only integer bytes. + However, it also means this function will not check for substrings, only integer bytes (which could be unexpected). In other words is `(contains? "foo bar" "foo")` is always false, because "foo" is not an integer byte - If you want to check for a substring in a buffer, then use `(not (nil? (string/find substr buffer)))` - - If the type is not iterable, this will return false. - This is in contrast to `index-of` and `next`, which will throw a type error. + If you want to check for a substring in a buffer, then use `(truthy? (string/find substr buffer))`, + or just `(if (string/find substr buffer) then else)` In general this function has O(n) performance, since it requires iterating over all the values. From e78a3d1c1978c6f351cdddf42162344251528b0d Mon Sep 17 00:00:00 2001 From: Techcable Date: Fri, 26 Aug 2022 21:46:15 -0700 Subject: [PATCH 010/138] Add unit tests for contains? --- test/suite0010.janet | 68 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) diff --git a/test/suite0010.janet b/test/suite0010.janet index 34cf608c..bb1d051a 100644 --- a/test/suite0010.janet +++ b/test/suite0010.janet @@ -33,6 +33,74 @@ (assert (= nil (index-of (chr "a") "")) "index-of 9") (assert (= nil (index-of 10 @[])) "index-of 10") (assert (= nil (index-of 10 @[1 2 3])) "index-of 11") +# NOTE: These is a motivation for the contains? and contains-key? functions below + +# returns false despite key present +(assert (= false (index-of 8 {true 7 false 8})) "index-of corner key (false) 1") +(assert (= false (index-of 8 @{false 8})) "index-of corner key (false) 2") +# still returns null +(assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") + +# contains? +(assert (= false (contains? [] "foo")) "contains? 1") +(assert (= true (contains? [4 7 1 3] 4)) "contains? 2") +(assert (= false (contains? [4 7 1 3] 22)) "contains? 3") +(assert (= false (contains? @[1 2 3] 4)) "contains? 4") +(assert (= true (contains? @[:a :b :c] :a)) "contains? 5") +(assert (= false (contains? {} :foo)) "contains? 6") +(assert (= true (contains? {:a :A :b :B} :A)) "contains? 7") +(assert (= true (contains? {:a :A :b :B} :A)) "contains? 7") +(assert (= true (contains? @{:a :A :b :B} :A)) "contains? 8") +(assert (= true (contains? "abc" (chr "a"))) "contains? 9") +(assert (= false (contains? "abc" "1")) "contains? 10") +# weird true/false corner cases, should align with "index-of corner key {k}" cases +(assert (= true (contains? {true 7 false 8} 8)) "contains? corner key (false) 1") +(assert (= true (contains? @{false 8} 8)) "contains? corner key (false) 2") +(assert (= false (contains? {false 8} 7)) "contains? corner key (false) 3") + +# contains-key? +(do + (var test-contains-key-auto 0) + (defn test-contains-key [col key expected &keys {:name name}] + ``Test that contains-key has the outcome `expected`, and that if + the result is true, then ensure (in key) does not fail either`` + (assert (boolean? expected)) + (default name (string "contains-key? " (++ test-contains-key-auto))) + (assert (= expected (contains-key? col key)) name) + (if + # guarenteed by `contains-key?` to never fail + expected (in col key) + # if `contains-key?` is false, then `in` should fail (for indexed types) + # + # For dictionary types, it should return nil + (let [[success retval] (protect (in col key))] + (def should-succeed (dictionary? col)) + (assert + (= success should-succeed) + (string/format + "%s: expected (in col key) to %s, but got %q" + name (if expected "succeed" "fail") retval))))) + + (test-contains-key [] 0 false) # 1 + (test-contains-key [4 7 1 3] 2 true) # 2 + (test-contains-key [4 7 1 3] 22 false) # 3 + (test-contains-key @[1 2 3] 4 false) # 4 + (test-contains-key @[:a :b :c] 2 true) # 5 + (test-contains-key {} :foo false) # 6 + (test-contains-key {:a :A :b :B} :a true) # 7 + (test-contains-key {:a :A :b :B} :A false) # 8 + (test-contains-key @{:a :A :b :B} :a true) # 9 + (test-contains-key "abc" 1 true) # 10 + (test-contains-key "abc" 4 false) # 11 + # weird true/false corner cases + # + # Tries to mimic the corresponding corner cases in contains? and index-of, + # but with keys/values inverted + # + # in the first two cases (truthy? (get val col)) would have given false negatives + (test-contains-key {7 true 8 false} 8 true :name "contains-key? corner value (false) 1") + (test-contains-key @{8 false} 8 true :name "contains-key? corner value (false) 2") + (test-contains-key @{8 false} 7 false :name "contains-key? corner value (false) 3")) # Regression (assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463") From d3bb06cfd6f548d6eeec2fd4f21cce9cd5932c06 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Thu, 11 May 2023 07:33:14 +0200 Subject: [PATCH 011/138] Updated Makefile for better cross-compilation support. Building janet requires janet_boot to be run on the host at build time; - $(UNAME) can now be overridden from the make cmdline - Added $(RUN) variable to allow a emulator to be specified - Added ".exe" extension to binaries when using MINGW Examples: Cross compiling for win32 and running under wine: ``` make test \ CC=i686-w64-mingw32-gcc \ LD=i686-w64-mingw32-gcc \ UNAME=MINGW \ RUN=wine Janet 1.27.0-ad7c3bed mingw/x86/gcc - '(doc)' for help ``` Cross compiling for aarch64 and running under qemu: ``` make repl \ CC=aarch64-none-linux-gnu-gcc \ LD=aarch64-none-linux-gnu-gcc \ RUN="qemu-aarch64 -L /tmp/aarch64/" Janet 1.27.0-ad7c3bed linux/aarch64/gcc - '(doc)' for help ``` --- Makefile | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/Makefile b/Makefile index 6aa76508..f9aebce6 100644 --- a/Makefile +++ b/Makefile @@ -31,6 +31,7 @@ LIBDIR?=$(PREFIX)/lib JANET_BUILD?="\"$(shell git log --pretty=format:'%h' -n 1 2> /dev/null || echo local)\"" CLIBS=-lm -lpthread JANET_TARGET=build/janet +JANET_BOOT=build/janet_boot JANET_IMPORT_LIB=build/janet.lib JANET_LIBRARY=build/libjanet.so JANET_STATIC_LIBRARY=build/libjanet.a @@ -47,6 +48,7 @@ HOSTCC?=$(CC) HOSTAR?=$(AR) CFLAGS?=-O2 LDFLAGS?=-rdynamic +RUN:=$(RUN) COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 -g $(COMMON_CFLAGS) @@ -56,7 +58,7 @@ BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) LDCONFIG:=ldconfig "$(LIBDIR)" # Check OS -UNAME:=$(shell uname -s) +UNAME?=$(shell uname -s) ifeq ($(UNAME), Darwin) CLIBS:=$(CLIBS) -ldl SONAME_SETTER:=-Wl,-install_name, @@ -82,6 +84,8 @@ endif ifeq ($(findstring MINGW,$(UNAME)), MINGW) CLIBS:=-lws2_32 -lpsapi -lwsock32 LDFLAGS:=-Wl,--out-implib,$(JANET_IMPORT_LIB) + JANET_TARGET:=$(JANET_TARGET).exe + JANET_BOOT:=$(JANET_BOOT).exe endif $(shell mkdir -p build/core build/c build/boot) @@ -163,12 +167,12 @@ $(JANET_BOOT_OBJECTS): $(JANET_BOOT_HEADERS) build/%.boot.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile $(CC) $(BOOT_CFLAGS) -o $@ -c $< -build/janet_boot: $(JANET_BOOT_OBJECTS) +$(JANET_BOOT): $(JANET_BOOT_OBJECTS) $(CC) $(BOOT_CFLAGS) -o $@ $(JANET_BOOT_OBJECTS) $(CLIBS) # Now the reason we bootstrap in the first place -build/c/janet.c: build/janet_boot src/boot/boot.janet - build/janet_boot . JANET_PATH '$(JANET_PATH)' > $@ +build/c/janet.c: $(JANET_BOOT) src/boot/boot.janet + $(RUN) $(JANET_BOOT) . JANET_PATH '$(JANET_PATH)' > $@ cksum $@ ######################## @@ -185,7 +189,7 @@ build/c/shell.c: src/mainclient/shell.c cp $< $@ build/janet.h: $(JANET_TARGET) src/include/janet.h $(JANETCONF_HEADER) - ./$(JANET_TARGET) tools/patch-header.janet src/include/janet.h $(JANETCONF_HEADER) $@ + $(RUN) ./$(JANET_TARGET) tools/patch-header.janet src/include/janet.h $(JANETCONF_HEADER) $@ build/janetconf.h: $(JANETCONF_HEADER) cp $< $@ @@ -214,7 +218,7 @@ $(JANET_STATIC_LIBRARY): build/janet.o build/shell.o TEST_SCRIPTS=$(wildcard test/suite*.janet) repl: $(JANET_TARGET) - ./$(JANET_TARGET) + $(RUN) ./$(JANET_TARGET) debug: $(JANET_TARGET) $(DEBUGGER) ./$(JANET_TARGET) @@ -225,8 +229,8 @@ valgrind: $(JANET_TARGET) $(VALGRIND_COMMAND) ./$(JANET_TARGET) test: $(JANET_TARGET) $(TEST_PROGRAMS) - for f in test/suite*.janet; do ./$(JANET_TARGET) "$$f" || exit; done - for f in examples/*.janet; do ./$(JANET_TARGET) -k "$$f"; done + for f in test/suite*.janet; do $(RUN) ./$(JANET_TARGET) "$$f" || exit; done + for f in examples/*.janet; do $(RUN) ./$(JANET_TARGET) -k "$$f"; done valtest: $(JANET_TARGET) $(TEST_PROGRAMS) for f in test/suite*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) "$$f" || exit; done @@ -265,7 +269,7 @@ build/janet-%.tar.gz: $(JANET_TARGET) \ docs: build/doc.html build/doc.html: $(JANET_TARGET) tools/gendoc.janet - $(JANET_TARGET) tools/gendoc.janet > build/doc.html + $(RUN) $(JANET_TARGET) tools/gendoc.janet > build/doc.html ######################## ##### Installation ##### @@ -281,7 +285,7 @@ build/janet.pc: $(JANET_TARGET) echo "Name: janet" >> $@ echo "Url: https://janet-lang.org" >> $@ echo "Description: Library for the Janet programming language." >> $@ - $(JANET_TARGET) -e '(print "Version: " janet/version)' >> $@ + $(RUN) $(JANET_TARGET) -e '(print "Version: " janet/version)' >> $@ echo 'Cflags: -I$${includedir}' >> $@ echo 'Libs: -L$${libdir} -ljanet' >> $@ echo 'Libs.private: $(CLIBS)' >> $@ @@ -321,7 +325,7 @@ install-jpm-git: $(JANET_TARGET) JANET_HEADERPATH='$(INCLUDEDIR)/janet' \ JANET_BINPATH='$(BINDIR)' \ JANET_LIBPATH='$(LIBDIR)' \ - ../../$(JANET_TARGET) ./bootstrap.janet + $(RUN) ../../$(JANET_TARGET) ./bootstrap.janet uninstall: -rm '$(DESTDIR)$(BINDIR)/janet' @@ -341,7 +345,7 @@ format: grammar: build/janet.tmLanguage build/janet.tmLanguage: tools/tm_lang_gen.janet $(JANET_TARGET) - $(JANET_TARGET) $< > $@ + $(RUN) $(JANET_TARGET) $< > $@ compile-commands: # Requires pip install copmiledb From 20ada86761f4c7a973acffe3709b29d426c27f0a Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Fri, 12 May 2023 19:08:26 -0500 Subject: [PATCH 012/138] Fix NAN typo. --- src/core/math.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/math.c b/src/core/math.c index c65294d0..c5aea93f 100644 --- a/src/core/math.c +++ b/src/core/math.c @@ -317,7 +317,7 @@ static double janet_gcd(double x, double y) { #ifdef NAN return NAN; #else - return 0.0 \ 0.0; + return 0.0 / 0.0; #endif } if (isinf(x) || isinf(y)) return INFINITY; From fba1fdabe4f8869da8058b767702d93b9db45747 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 13 May 2023 09:44:30 -0500 Subject: [PATCH 013/138] Update short-fn to fix #1123 Symbols are renamed on expansion to avoid the issue. --- CHANGELOG.md | 2 ++ src/boot/boot.janet | 15 +++++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0451db51..5d0bf7ef 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. ## Unreleased - ??? +- Various bug fixes +- Make nested short-fn's behave a bit more predictably (it is still not recommended to nest short-fns). - Add `os/strftime` for date formatting. - Fix `ev/select` on threaded channels sometimes live-locking. - Support the `NO_COLOR` environment variable to turn off VT100 color codes in repl (and in scripts). diff --git a/src/boot/boot.janet b/src/boot/boot.janet index c120abb0..0ccda788 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2209,6 +2209,7 @@ (defn saw-special-arg [num] (set max-param-seen (max max-param-seen num))) + (def prefix (gensym)) (defn on-binding [x] (if (string/has-prefix? '$ x) @@ -2216,22 +2217,24 @@ (= '$ x) (do (saw-special-arg 0) - '$0) + (symbol prefix '$0)) (= '$& x) (do (set vararg true) - x) + (symbol prefix x)) :else (do (def num (scan-number (string/slice x 1))) (if (nat? num) - (saw-special-arg num)) - x)) + (do + (saw-special-arg num) + (symbol prefix x)) + x))) x)) (def expanded (macex arg on-binding)) (def name-splice (if name [name] [])) - (def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol '$ i))) - ~(fn ,;name-splice [,;fn-args ,;(if vararg ['& '$&] [])] ,expanded)) + (def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol prefix '$ i))) + ~(fn ,;name-splice [,;fn-args ,;(if vararg ['& (symbol prefix '$&)] [])] ,expanded)) ### ### From 358f5a03bf9c003c32df8728253ba1e282fe3d69 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 13 May 2023 09:59:55 -0500 Subject: [PATCH 014/138] Version bump to 1.28.0 --- CHANGELOG.md | 2 +- Makefile | 4 ++-- meson.build | 2 +- src/conf/janetconf.h | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d0bf7ef..26252642 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,7 @@ # Changelog All notable changes to this project will be documented in this file. -## Unreleased - ??? +## 1.28.0 - 2023-05-13 - Various bug fixes - Make nested short-fn's behave a bit more predictably (it is still not recommended to nest short-fns). - Add `os/strftime` for date formatting. diff --git a/Makefile b/Makefile index f9aebce6..f2432311 100644 --- a/Makefile +++ b/Makefile @@ -180,9 +180,9 @@ build/c/janet.c: $(JANET_BOOT) src/boot/boot.janet ######################## ifeq ($(UNAME), Darwin) -SONAME=libjanet.1.27.dylib +SONAME=libjanet.1.28.dylib else -SONAME=libjanet.so.1.27 +SONAME=libjanet.so.1.28 endif build/c/shell.c: src/mainclient/shell.c diff --git a/meson.build b/meson.build index 02e6d96d..e521538f 100644 --- a/meson.build +++ b/meson.build @@ -20,7 +20,7 @@ project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], - version : '1.27.0') + version : '1.28.0') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 8b030b50..13d7f4ff 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -4,10 +4,10 @@ #define JANETCONF_H #define JANET_VERSION_MAJOR 1 -#define JANET_VERSION_MINOR 27 +#define JANET_VERSION_MINOR 28 #define JANET_VERSION_PATCH 0 #define JANET_VERSION_EXTRA "" -#define JANET_VERSION "1.27.0" +#define JANET_VERSION "1.28.0" /* #define JANET_BUILD "local" */ From 398833ebe333efa751c52d2fa0f0a940d1d9878b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 14 May 2023 09:18:54 -0500 Subject: [PATCH 015/138] Enable FFI module unconditionally. --- src/conf/janetconf.h | 4 ++-- src/include/janet.h | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 13d7f4ff..73e39d55 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -6,8 +6,8 @@ #define JANET_VERSION_MAJOR 1 #define JANET_VERSION_MINOR 28 #define JANET_VERSION_PATCH 0 -#define JANET_VERSION_EXTRA "" -#define JANET_VERSION "1.28.0" +#define JANET_VERSION_EXTRA "-dev" +#define JANET_VERSION "1.28.0-dev" /* #define JANET_BUILD "local" */ diff --git a/src/include/janet.h b/src/include/janet.h index c88cd35c..941a6c35 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -182,7 +182,7 @@ extern "C" { /* Enable or disable the FFI library. Currently, FFI only enabled on * x86-64 operating systems. */ #ifndef JANET_NO_FFI -#if !defined(__EMSCRIPTEN__) && (defined(__x86_64__) || defined(_M_X64)) +#if !defined(__EMSCRIPTEN__) #define JANET_FFI #endif #endif From 88d0c2ca0f8102df3d18cc8cbf9076296a3952e6 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 15 May 2023 12:15:36 +0200 Subject: [PATCH 016/138] add net/setsockopt --- src/core/net.c | 94 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) diff --git a/src/core/net.c b/src/core/net.c index 8ebbdb53..8c911f92 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -872,6 +872,98 @@ JANET_CORE_FN(cfun_stream_flush, return argv[0]; } +struct sockopt_type { + const char *name; + int level; + int optname; + enum JanetType type; +}; + +// List of supported socket options; The type JANET_POINTER is used +// for options that require special handling depending on the type. +static const struct sockopt_type sockopt_type_list[] = { + { "SO_BROADCAST", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, + { "SO_REUSEADDR", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, + { "SO_KEEPALIVE", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, + { "IP_MULTICAST_TTL", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, + { "IP_ADD_MEMBERSHIP", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, + { "IP_DROP_MEMBERSHIP", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, + { "IPV6_JOIN_GROUP", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, + { "IPV6_LEAVE_GROUP", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, + { NULL } +}; + +JANET_CORE_FN(cfun_net_setsockopt, + "(net/setsockopt stream option value)", + "set socket options.\n" + "\n" + "supported options and associated value types:\n" + "- :SO_BROADCAST boolean\n" + "- :SO_REUSEADDR boolean\n" + "- :SO_KEEPALIVE boolean\n" + "- :IP_MULTICAST_TTL number\n" + "- :IP_ADD_MEMBERSHIP string\n" + "- :IP_DROP_MEMBERSHIP string\n" + "- :IPV6_JOIN_GROUP string\n" + "- :IPV6_LEAVE_GROUP string\n") { + janet_arity(argc, 3, 3); + JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); + janet_stream_flags(stream, JANET_STREAM_SOCKET); + JanetKeyword optstr = janet_getkeyword(argv, 1); + + const struct sockopt_type *st = sockopt_type_list; + while(st->name) { + if (janet_cstrcmp(optstr, st->name) == 0) { + break; + } + st++; + } + + if(st->name == NULL) { + janet_panicf("unknown socket option %q", argv[1]); + } + + union { + int v_int; + struct ip_mreq v_mreq; + struct ipv6_mreq v_mreq6; + } val; + + void *optval = (void *)&val; + socklen_t optlen = 0; + + if(st->type == JANET_BOOLEAN) { + val.v_int = janet_getboolean(argv, 2); + optlen = sizeof(val.v_int); + } else if(st->type == JANET_NUMBER) { + val.v_int = janet_getinteger(argv, 2); + optlen = sizeof(val.v_int); + } else if(st->optname == IP_ADD_MEMBERSHIP || st->optname == IP_DROP_MEMBERSHIP) { + const char *addr = janet_getcstring(argv, 2); + memset(&val.v_mreq, 0, sizeof val.v_mreq); + val.v_mreq.imr_interface.s_addr = htonl(INADDR_ANY); + val.v_mreq.imr_multiaddr.s_addr = inet_addr(addr); + optlen = sizeof(val.v_mreq); + } else if(st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) { + const char *addr = janet_getcstring(argv, 2); + memset(&val.v_mreq6, 0, sizeof val.v_mreq6); + val.v_mreq6.ipv6mr_interface = 0; + inet_pton(AF_INET6, addr, &val.v_mreq6.ipv6mr_multiaddr); + optlen = sizeof(val.v_mreq6); + } else { + janet_panicf("invalid socket option type"); + } + + janet_assert(optlen != 0, "invalid socket option value"); + + int r = setsockopt((JSock) stream->handle, st->level, st->optname, optval, optlen); + if(r == -1) { + janet_panicf("setsockopt(%q): %s", argv[1], strerror(errno)); + } + + return janet_wrap_nil(); +} + static const JanetMethod net_stream_methods[] = { {"chunk", cfun_stream_chunk}, {"close", janet_cfun_stream_close}, @@ -886,6 +978,7 @@ static const JanetMethod net_stream_methods[] = { {"evchunk", janet_cfun_stream_chunk}, {"evwrite", janet_cfun_stream_write}, {"shutdown", cfun_net_shutdown}, + {"setsockopt", cfun_net_setsockopt}, {NULL, NULL} }; @@ -910,6 +1003,7 @@ void janet_lib_net(JanetTable *env) { JANET_CORE_REG("net/peername", cfun_net_getpeername), JANET_CORE_REG("net/localname", cfun_net_getsockname), JANET_CORE_REG("net/address-unpack", cfun_net_address_unpack), + JANET_CORE_REG("net/setsockopt", cfun_net_setsockopt), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, net_cfuns); From 68c35feaea4d2ad76c54593f0e4f3623f48da086 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 15 May 2023 12:33:37 +0200 Subject: [PATCH 017/138] Formatting --- src/core/net.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/core/net.c b/src/core/net.c index 8c911f92..ac97554a 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -894,32 +894,32 @@ static const struct sockopt_type sockopt_type_list[] = { }; JANET_CORE_FN(cfun_net_setsockopt, - "(net/setsockopt stream option value)", - "set socket options.\n" - "\n" - "supported options and associated value types:\n" - "- :SO_BROADCAST boolean\n" - "- :SO_REUSEADDR boolean\n" - "- :SO_KEEPALIVE boolean\n" - "- :IP_MULTICAST_TTL number\n" - "- :IP_ADD_MEMBERSHIP string\n" - "- :IP_DROP_MEMBERSHIP string\n" - "- :IPV6_JOIN_GROUP string\n" - "- :IPV6_LEAVE_GROUP string\n") { + "(net/setsockopt stream option value)", + "set socket options.\n" + "\n" + "supported options and associated value types:\n" + "- :SO_BROADCAST boolean\n" + "- :SO_REUSEADDR boolean\n" + "- :SO_KEEPALIVE boolean\n" + "- :IP_MULTICAST_TTL number\n" + "- :IP_ADD_MEMBERSHIP string\n" + "- :IP_DROP_MEMBERSHIP string\n" + "- :IPV6_JOIN_GROUP string\n" + "- :IPV6_LEAVE_GROUP string\n") { janet_arity(argc, 3, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); JanetKeyword optstr = janet_getkeyword(argv, 1); const struct sockopt_type *st = sockopt_type_list; - while(st->name) { + while (st->name) { if (janet_cstrcmp(optstr, st->name) == 0) { break; } st++; } - if(st->name == NULL) { + if (st->name == NULL) { janet_panicf("unknown socket option %q", argv[1]); } @@ -932,19 +932,19 @@ JANET_CORE_FN(cfun_net_setsockopt, void *optval = (void *)&val; socklen_t optlen = 0; - if(st->type == JANET_BOOLEAN) { + if (st->type == JANET_BOOLEAN) { val.v_int = janet_getboolean(argv, 2); optlen = sizeof(val.v_int); - } else if(st->type == JANET_NUMBER) { + } else if (st->type == JANET_NUMBER) { val.v_int = janet_getinteger(argv, 2); optlen = sizeof(val.v_int); - } else if(st->optname == IP_ADD_MEMBERSHIP || st->optname == IP_DROP_MEMBERSHIP) { + } else if (st->optname == IP_ADD_MEMBERSHIP || st->optname == IP_DROP_MEMBERSHIP) { const char *addr = janet_getcstring(argv, 2); memset(&val.v_mreq, 0, sizeof val.v_mreq); val.v_mreq.imr_interface.s_addr = htonl(INADDR_ANY); val.v_mreq.imr_multiaddr.s_addr = inet_addr(addr); optlen = sizeof(val.v_mreq); - } else if(st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) { + } else if (st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) { const char *addr = janet_getcstring(argv, 2); memset(&val.v_mreq6, 0, sizeof val.v_mreq6); val.v_mreq6.ipv6mr_interface = 0; @@ -957,7 +957,7 @@ JANET_CORE_FN(cfun_net_setsockopt, janet_assert(optlen != 0, "invalid socket option value"); int r = setsockopt((JSock) stream->handle, st->level, st->optname, optval, optlen); - if(r == -1) { + if (r == -1) { janet_panicf("setsockopt(%q): %s", argv[1], strerror(errno)); } From ab8c5a0b5fff91ade10772ad8aa52ca0eb2338df Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 15 May 2023 15:25:09 +0200 Subject: [PATCH 018/138] net/setsockopt optname symbols are now lower case --- src/core/net.c | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/core/net.c b/src/core/net.c index ac97554a..32319305 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -882,14 +882,14 @@ struct sockopt_type { // List of supported socket options; The type JANET_POINTER is used // for options that require special handling depending on the type. static const struct sockopt_type sockopt_type_list[] = { - { "SO_BROADCAST", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, - { "SO_REUSEADDR", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, - { "SO_KEEPALIVE", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, - { "IP_MULTICAST_TTL", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, - { "IP_ADD_MEMBERSHIP", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, - { "IP_DROP_MEMBERSHIP", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, - { "IPV6_JOIN_GROUP", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, - { "IPV6_LEAVE_GROUP", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, + { "so_broadcast", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, + { "so_reuseaddr", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, + { "so_keepalive", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, + { "ip_multicast_ttl", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, + { "ip_add_membership", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, + { "ip_drop_membership", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, + { "ipv6_join_group", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, + { "ipv6_leave_group", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, { NULL } }; @@ -898,14 +898,14 @@ JANET_CORE_FN(cfun_net_setsockopt, "set socket options.\n" "\n" "supported options and associated value types:\n" - "- :SO_BROADCAST boolean\n" - "- :SO_REUSEADDR boolean\n" - "- :SO_KEEPALIVE boolean\n" - "- :IP_MULTICAST_TTL number\n" - "- :IP_ADD_MEMBERSHIP string\n" - "- :IP_DROP_MEMBERSHIP string\n" - "- :IPV6_JOIN_GROUP string\n" - "- :IPV6_LEAVE_GROUP string\n") { + "- :so_broadcast boolean\n" + "- :so_reuseaddr boolean\n" + "- :so_keepalive boolean\n" + "- :ip_multicast_ttl number\n" + "- :ip_add_membership string\n" + "- :ip_drop_membership string\n" + "- :ipv6_join_group string\n" + "- :ipv6_leave_group string\n") { janet_arity(argc, 3, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); From 2a6c615becc2268ec1ea52b80a1cea5e86cb778a Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 15 May 2023 16:55:09 +0200 Subject: [PATCH 019/138] features.h: define _DARWIN_C_SOURCE for __APPLE__ --- src/core/features.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core/features.h b/src/core/features.h index 0adb136a..f2522500 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -36,6 +36,10 @@ # endif #endif +#if defined(__APPLE__) +#define _DARWIN_C_SOURCE +#endif + /* Needed for sched.h for cpu count */ #ifdef __linux__ #define _GNU_SOURCE From 0b58e505ee7a298433cb781d3f5a86a6a10a3b88 Mon Sep 17 00:00:00 2001 From: tionis Date: Sun, 14 May 2023 15:16:27 +0200 Subject: [PATCH 020/138] os/proc-kill now accepts an optional signal to send --- src/core/os.c | 108 ++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 104 insertions(+), 4 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 64a03470..0c348466 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -624,12 +624,96 @@ JANET_CORE_FN(os_proc_wait, #endif } +#ifndef JANET_WINDOWS +struct keyword_signal { + const char *keyword; + int signal; +}; +static const struct keyword_signal signal_keywords[] = { + {"kill", SIGKILL}, + {"int", SIGINT}, + {"abrt", SIGABRT}, + {"fpe", SIGFPE}, + {"ill", SIGILL}, + {"segv", SIGSEGV}, +#ifdef SIGTERM + {"term", SIGTERM}, +#endif +#ifdef SIGARLM + {"alrm", SIGALRM}, +#endif +#ifdef SIGHUP + {"hup", SIGHUP}, +#endif +#ifdef SIGPIPE + {"pipe", SIGPIPE}, + #endif +#ifdef SIGQUIT + {"quit", SIGQUIT}, +#endif +#ifdef SIGUSR1 + {"usr1", SIGUSR1}, +#endif +#ifdef SIGUSR2 + {"usr2", SIGUSR2}, +#endif +#ifdef SIGCHLD + {"chld", SIGCHLD}, +#endif +#ifdef SIGCONT + {"cont", SIGCONT}, +#endif +#ifdef SIGSTOP + {"stop", SIGSTOP}, +#endif +#ifdef SIGTSTP + {"tstp", SIGTSTP}, +#endif +#ifdef SIGTTIN + {"ttin", SIGTTIN}, +#endif +#ifdef SIGTTOU + {"ttou", SIGTTOU}, +#endif +#ifdef SIGBUS + {"bus", SIGBUS}, +#endif +#ifdef SIGPOLL + {"poll", SIGPOLL}, +#endif +#ifdef SIGPROF + {"prof", SIGPROF}, +#endif +#ifdef SIGSYS + {"sys", SIGSYS}, +#endif +#ifdef SIGTRAP + {"trap", SIGTRAP}, +#endif +#ifdef SIGURG + {"urg", SIGURG}, +#endif +#ifdef SIGVTALRM + {"vtlarm", SIGVTALRM}, +#endif +#ifdef SIGXCPU + {"xcpu", SIGXCPU}, +#endif +#ifdef SIGXFSZ + {"xfsz", SIGXFSZ}, +#endif + {NULL, 0}, +}; +#endif + JANET_CORE_FN(os_proc_kill, - "(os/proc-kill proc &opt wait)", + "(os/proc-kill proc &opt wait signal)", "Kill a subprocess by sending SIGKILL to it on posix systems, or by closing the process " "handle on windows. If `wait` is truthy, will wait for the process to finish and " - "returns the exit code. Otherwise, returns `proc`.") { - janet_arity(argc, 1, 2); + "returns the exit code. Otherwise, returns `proc`. If signal is specified send it instead." + "Signal is ignored on windows. Signal keywords are named after their C counterparts but in" + "lowercase with the leading `SIG` stripped") { + janet_arity(argc, 1, 3); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); if (proc->flags & JANET_PROC_WAITED) { janet_panicf("cannot kill process that has already finished"); @@ -643,7 +727,23 @@ JANET_CORE_FN(os_proc_kill, CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); #else - int status = kill(proc->pid, SIGKILL); + int signal = SIGKILL; + if(argc == 3){ + int signal = -1; + JanetKeyword signal_kw = janet_getkeyword(argv, 2); + const struct keyword_signal *ptr = signal_keywords; + while (ptr->keyword){ + if(!janet_cstrcmp(signal_kw, ptr->keyword)){ + signal = ptr->signal; + break; + } + ptr++; + } + if(signal == -1){ + janet_panic("undefined signal"); + } + } + int status = kill(proc->pid, signal); if (status) { janet_panic(strerror(errno)); } From 71d51c160d784e9c83d1e77434b9efe80c42924e Mon Sep 17 00:00:00 2001 From: tionis Date: Tue, 16 May 2023 13:27:52 +0200 Subject: [PATCH 021/138] added simple test for signal handling in os/proc-kill using :kill --- test/suite0009.janet | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/suite0009.janet b/test/suite0009.janet index 6b61797a..1d4368b9 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -52,6 +52,11 @@ (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) +(let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] + (os/proc-kill p false :kill) + (def retval (os/proc-wait p)) + (assert (not= retval 24) "Process was *not* terminated by parent")) + # Parallel subprocesses (defn calc-1 From 56d72ec4c5d49f4e5bd8d6af8e59cadf421fcef9 Mon Sep 17 00:00:00 2001 From: tionis Date: Tue, 16 May 2023 16:58:42 +0200 Subject: [PATCH 022/138] support sending signals to processes on windows --- src/core/os.c | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 0c348466..425785b0 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -624,7 +624,6 @@ JANET_CORE_FN(os_proc_wait, #endif } -#ifndef JANET_WINDOWS struct keyword_signal { const char *keyword; int signal; @@ -704,29 +703,19 @@ static const struct keyword_signal signal_keywords[] = { #endif {NULL, 0}, }; -#endif JANET_CORE_FN(os_proc_kill, "(os/proc-kill proc &opt wait signal)", "Kill a subprocess by sending SIGKILL to it on posix systems, or by closing the process " "handle on windows. If `wait` is truthy, will wait for the process to finish and " "returns the exit code. Otherwise, returns `proc`. If signal is specified send it instead." - "Signal is ignored on windows. Signal keywords are named after their C counterparts but in" - "lowercase with the leading `SIG` stripped") { + "Signal keywords are named after their C counterparts but in lowercase with the leading " + "`SIG` stripped") { janet_arity(argc, 1, 3); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); if (proc->flags & JANET_PROC_WAITED) { janet_panicf("cannot kill process that has already finished"); } -#ifdef JANET_WINDOWS - if (proc->flags & JANET_PROC_CLOSED) { - janet_panicf("cannot close process handle that is already closed"); - } - proc->flags |= JANET_PROC_CLOSED; - TerminateProcess(proc->pHandle, 1); - CloseHandle(proc->pHandle); - CloseHandle(proc->tHandle); -#else int signal = SIGKILL; if(argc == 3){ int signal = -1; @@ -743,6 +732,22 @@ JANET_CORE_FN(os_proc_kill, janet_panic("undefined signal"); } } +#ifdef JANET_WINDOWS + if (proc->flags & JANET_PROC_CLOSED) { + janet_panicf("cannot close process handle that is already closed"); + } + proc->flags |= JANET_PROC_CLOSED; + if(signal == SIGKILL){ + TerminateProcess(proc->pHandle, 1); + }else{ + int status = kill(proc->pid, signal); + if (status) { + janet_panic(strerror(errno)); + } + } + CloseHandle(proc->pHandle); + CloseHandle(proc->tHandle); +#else int status = kill(proc->pid, signal); if (status) { janet_panic(strerror(errno)); From 0f35acade1d9c4958f711fd3d84b4eb55736b14f Mon Sep 17 00:00:00 2001 From: tionis Date: Tue, 16 May 2023 18:47:38 +0200 Subject: [PATCH 023/138] use SIGTERM for os/proc-kill signal test --- src/core/os.c | 8 +++++--- test/suite0009.janet | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 425785b0..c1ab5622 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -629,7 +629,9 @@ struct keyword_signal { int signal; }; static const struct keyword_signal signal_keywords[] = { +#ifdef SIGKILL {"kill", SIGKILL}, +#endif {"int", SIGINT}, {"abrt", SIGABRT}, {"fpe", SIGFPE}, @@ -716,9 +718,8 @@ JANET_CORE_FN(os_proc_kill, if (proc->flags & JANET_PROC_WAITED) { janet_panicf("cannot kill process that has already finished"); } - int signal = SIGKILL; + int signal = -1; if(argc == 3){ - int signal = -1; JanetKeyword signal_kw = janet_getkeyword(argv, 2); const struct keyword_signal *ptr = signal_keywords; while (ptr->keyword){ @@ -737,7 +738,7 @@ JANET_CORE_FN(os_proc_kill, janet_panicf("cannot close process handle that is already closed"); } proc->flags |= JANET_PROC_CLOSED; - if(signal == SIGKILL){ + if(signal == -1){ TerminateProcess(proc->pHandle, 1); }else{ int status = kill(proc->pid, signal); @@ -748,6 +749,7 @@ JANET_CORE_FN(os_proc_kill, CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); #else + if(signal == -1){signal=SIGKILL;} int status = kill(proc->pid, signal); if (status) { janet_panic(strerror(errno)); diff --git a/test/suite0009.janet b/test/suite0009.janet index 1d4368b9..99f5232e 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -53,7 +53,7 @@ (assert (not= retval 24) "Process was *not* terminated by parent")) (let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] - (os/proc-kill p false :kill) + (os/proc-kill p false :term) (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) From ac5f1fe1bea045064893950f167f312f8a290ac1 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Tue, 16 May 2023 19:44:31 +0200 Subject: [PATCH 024/138] enable debug symbols in janet binary; strip target at 'make instal' --- Makefile | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index f2432311..50d759a8 100644 --- a/Makefile +++ b/Makefile @@ -47,11 +47,11 @@ SONAME_SETTER=-Wl,-soname, HOSTCC?=$(CC) HOSTAR?=$(AR) CFLAGS?=-O2 -LDFLAGS?=-rdynamic +LDFLAGS?=-rdynamic -g RUN:=$(RUN) -COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC -BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 -g $(COMMON_CFLAGS) +COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC -g +BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) # For installation @@ -223,7 +223,7 @@ repl: $(JANET_TARGET) debug: $(JANET_TARGET) $(DEBUGGER) ./$(JANET_TARGET) -VALGRIND_COMMAND=valgrind --leak-check=full +VALGRIND_COMMAND=valgrind --leak-check=full --quiet valgrind: $(JANET_TARGET) $(VALGRIND_COMMAND) ./$(JANET_TARGET) @@ -293,6 +293,7 @@ build/janet.pc: $(JANET_TARGET) install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/janet.h mkdir -p '$(DESTDIR)$(BINDIR)' cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet' + strip '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet' ln -sf -T ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' || true #fixme bsd From d6f5a060ed9d1d88977595b50031f267eabe09bf Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 16 May 2023 21:00:31 -0500 Subject: [PATCH 025/138] Squashed commit of the following: commit 725b8749464895e21c761f1c5479692335282f62 Author: Calvin Rose Date: Tue May 16 20:58:34 2023 -0500 Update header file. commit 38bf2a5131694cc8f6c7ee2a7e70c768dc51f68f Author: Calvin Rose Date: Tue May 16 19:43:22 2023 -0500 Run experiment on bsd. --- src/core/features.h | 5 +++-- src/core/net.c | 38 +++++++++++++++++++------------------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src/core/features.h b/src/core/features.h index f2522500..46caff58 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -26,9 +26,10 @@ #define JANET_FEATURES_H_defined #if defined(__NetBSD__) || defined(__APPLE__) || defined(__OpenBSD__) \ - || defined(__bsdi__) || defined(__DragonFly__) + || defined(__bsdi__) || defined(__DragonFly__) || defined(__FreeBSD__) /* Use BSD source on any BSD systems, include OSX */ # define _BSD_SOURCE +# define _POSIX_C_SOURCE 200809L #else /* Use POSIX feature flags */ # ifndef _POSIX_C_SOURCE @@ -66,7 +67,7 @@ #endif /* Needed for several things when building with -std=c99. */ -#if !__BSD_VISIBLE && defined(__DragonFly__) +#if !__BSD_VISIBLE && (defined(__DragonFly__) || defined(__FreeBSD__)) #define __BSD_VISIBLE 1 #endif diff --git a/src/core/net.c b/src/core/net.c index 32319305..843f36f8 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -879,18 +879,18 @@ struct sockopt_type { enum JanetType type; }; -// List of supported socket options; The type JANET_POINTER is used -// for options that require special handling depending on the type. +/* List of supported socket options; The type JANET_POINTER is used + * for options that require special handling depending on the type. */ static const struct sockopt_type sockopt_type_list[] = { - { "so_broadcast", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, - { "so_reuseaddr", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, - { "so_keepalive", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, - { "ip_multicast_ttl", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, - { "ip_add_membership", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, - { "ip_drop_membership", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, - { "ipv6_join_group", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, - { "ipv6_leave_group", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, - { NULL } + { "so-broadcast", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, + { "so-reuseaddr", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, + { "so-keepalive", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, + { "ip-multicast-ttl", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, + { "ip-add-membership", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, + { "ip-drop-membership", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, + { "ipv6-join-group", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, + { "ipv6-leave-group", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, + { NULL, 0, 0, JANET_POINTER } }; JANET_CORE_FN(cfun_net_setsockopt, @@ -898,14 +898,14 @@ JANET_CORE_FN(cfun_net_setsockopt, "set socket options.\n" "\n" "supported options and associated value types:\n" - "- :so_broadcast boolean\n" - "- :so_reuseaddr boolean\n" - "- :so_keepalive boolean\n" - "- :ip_multicast_ttl number\n" - "- :ip_add_membership string\n" - "- :ip_drop_membership string\n" - "- :ipv6_join_group string\n" - "- :ipv6_leave_group string\n") { + "- :so-broadcast boolean\n" + "- :so-reuseaddr boolean\n" + "- :so-keepalive boolean\n" + "- :ip-multicast-ttl number\n" + "- :ip-add-membership string\n" + "- :ip-drop-membership string\n" + "- :ipv6-join-group string\n" + "- :ipv6-leave-group string\n") { janet_arity(argc, 3, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); From 148917d4caa79784fb00905bbb4b807e4964b05b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 16 May 2023 21:10:18 -0500 Subject: [PATCH 026/138] Move -g to CFLAGS to make it easier to remove/customize --- Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 50d759a8..f5595310 100644 --- a/Makefile +++ b/Makefile @@ -46,11 +46,11 @@ SONAME_SETTER=-Wl,-soname, # For cross compilation HOSTCC?=$(CC) HOSTAR?=$(AR) -CFLAGS?=-O2 -LDFLAGS?=-rdynamic -g +CFLAGS?=-O2 -g +LDFLAGS?=-rdynamic RUN:=$(RUN) -COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC -g +COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) From 8d78fb1f6b8f2b4a4bd1b729f4fce4d3e2e3f7b1 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Tue, 16 May 2023 17:10:16 +0200 Subject: [PATCH 027/138] changed net/connect to be non-blocking / asynchronous --- src/core/ev.c | 42 +++++++++++++++++++++++++++++++++++++++++- src/core/net.c | 31 +++++++++++++++++++++---------- src/include/janet.h | 1 + 3 files changed, 63 insertions(+), 11 deletions(-) diff --git a/src/core/ev.c b/src/core/ev.c index 8a904745..290a1442 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -2456,7 +2456,8 @@ void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, in typedef enum { JANET_ASYNC_WRITEMODE_WRITE, JANET_ASYNC_WRITEMODE_SEND, - JANET_ASYNC_WRITEMODE_SENDTO + JANET_ASYNC_WRITEMODE_SENDTO, + JANET_ASYNC_WRITEMODE_CONNECT } JanetWriteMode; typedef struct { @@ -2480,6 +2481,31 @@ typedef struct { #endif } StateWrite; +static JanetAsyncStatus handle_connect(JanetListenerState *s) { +#ifdef JANET_WINDOWS + int res = 0; + int size = sizeof(res); + int r = getsockopt((SOCKET)s->stream->handle, SOL_SOCKET, SO_ERROR, (char *)&res, &size); +#else + int res = 0; + socklen_t size = sizeof res; + int r = getsockopt(s->stream->handle, SOL_SOCKET, SO_ERROR, &res, &size); +#endif + if (r == 0) { + if (res == 0) { + janet_schedule(s->fiber, janet_wrap_abstract(s->stream)); + } else { + // TODO help needed. janet_stream_close(s->stream); + janet_cancel(s->fiber, janet_cstringv(strerror(res))); + } + } else { + // TODO help needed. janet_stream_close(s->stream); + janet_cancel(s->fiber, janet_ev_lasterr()); + } + return JANET_ASYNC_STATUS_DONE; +} + + JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) { StateWrite *state = (StateWrite *) s; switch (event) { @@ -2509,6 +2535,11 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) } break; case JANET_ASYNC_EVENT_USER: { +#ifdef JANET_NET + if (state->mode == JANET_ASYNC_WRITEMODE_CONNECT) { + return handle_connect(s); + } +#endif /* Begin write */ int32_t len; const uint8_t *bytes; @@ -2572,6 +2603,11 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) janet_cancel(s->fiber, janet_cstringv("stream hup")); return JANET_ASYNC_STATUS_DONE; case JANET_ASYNC_EVENT_WRITE: { +#ifdef JANET_NET + if (state->mode == JANET_ASYNC_WRITEMODE_CONNECT) { + return handle_connect(s); + } +#endif int32_t start, len; const uint8_t *bytes; start = state->start; @@ -2674,6 +2710,10 @@ void janet_ev_sendto_buffer(JanetStream *stream, JanetBuffer *buf, void *dest, i void janet_ev_sendto_string(JanetStream *stream, JanetString str, void *dest, int flags) { janet_ev_write_generic(stream, (void *) str, dest, JANET_ASYNC_WRITEMODE_SENDTO, 0, flags); } + +void janet_ev_connect(JanetStream *stream, int flags) { + janet_ev_write_generic(stream, NULL, NULL, JANET_ASYNC_WRITEMODE_CONNECT, 0, flags); +} #endif /* For a pipe ID */ diff --git a/src/core/net.c b/src/core/net.c index 843f36f8..36c598af 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -477,14 +477,20 @@ JANET_CORE_FN(cfun_net_connect, } } + /* Wrap socket in abstract type JanetStream */ + JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE); + + /* Set the socket to non-blocking mode */ + janet_net_socknoblock(sock); + /* Connect to socket */ #ifdef JANET_WINDOWS int status = WSAConnect(sock, addr, addrlen, NULL, NULL, NULL, NULL); - Janet lasterr = janet_ev_lasterr(); + int err = WSAGetLastError(); freeaddrinfo(ai); #else int status = connect(sock, addr, addrlen); - Janet lasterr = janet_ev_lasterr(); + int err = errno; if (is_unix) { janet_free(ai); } else { @@ -492,17 +498,22 @@ JANET_CORE_FN(cfun_net_connect, } #endif - if (status == -1) { - JSOCKCLOSE(sock); - janet_panicf("could not connect socket: %V", lasterr); + if (status != 0) { +#ifdef JANET_WINDOWS + if (err != WSAEWOULDBLOCK) { +#else + if (err != EINPROGRESS) { +#endif + JSOCKCLOSE(sock); + Janet lasterr = janet_ev_lasterr(); + janet_panicf("could not connect socket: %V", lasterr); + } } - /* Set up the socket for non-blocking IO after connect - TODO - non-blocking connect? */ - janet_net_socknoblock(sock); + /* Handle the connect() result in the event loop*/ + janet_ev_connect(stream, MSG_NOSIGNAL); - /* Wrap socket in abstract type JanetStream */ - JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE); - return janet_wrap_abstract(stream); + janet_await(); } static const char *serverify_socket(JSock sfd) { diff --git a/src/include/janet.h b/src/include/janet.h index 941a6c35..130973dc 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -1479,6 +1479,7 @@ JANET_API void janet_ev_readchunk(JanetStream *stream, JanetBuffer *buf, int32_t JANET_API void janet_ev_recv(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); JANET_API void janet_ev_recvchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); JANET_API void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); +JANET_API void janet_ev_connect(JanetStream *stream, int flags); #endif /* Write async to a stream */ From c3e28bc9246fca8247308c79e7d1cff3807772e3 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Thu, 18 May 2023 14:09:06 +0200 Subject: [PATCH 028/138] added deferred closing of streams after async connect() fails --- src/core/ev.c | 21 +++++++++++++++++++-- src/core/net.c | 2 +- src/include/janet.h | 1 + 3 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/core/ev.c b/src/core/ev.c index 290a1442..31b0a2f6 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1502,6 +1502,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) { state = state->_next; } } + /* Close the stream if requested and no more listeners are left */ + if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) { + janet_stream_close(stream); + } } } } @@ -1656,6 +1660,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { janet_unlisten(state, 0); state = next_state; } + /* Close the stream if requested and no more listeners are left */ + if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) { + janet_stream_close(stream); + } } } } @@ -1854,6 +1862,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { state = next_state; } + /* Close the stream if requested and no more listeners are left */ + if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) { + janet_stream_close(stream); + } } } } @@ -1970,6 +1982,11 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { status3 == JANET_ASYNC_STATUS_DONE || status4 == JANET_ASYNC_STATUS_DONE) janet_unlisten(state, 0); + /* Close the stream if requested and no more listeners are left */ + JanetStream *stream = state->stream; + if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) { + janet_stream_close(stream); + } } } @@ -2495,11 +2512,11 @@ static JanetAsyncStatus handle_connect(JanetListenerState *s) { if (res == 0) { janet_schedule(s->fiber, janet_wrap_abstract(s->stream)); } else { - // TODO help needed. janet_stream_close(s->stream); + s->stream->flags |= JANET_STREAM_TOCLOSE; janet_cancel(s->fiber, janet_cstringv(strerror(res))); } } else { - // TODO help needed. janet_stream_close(s->stream); + s->stream->flags |= JANET_STREAM_TOCLOSE; janet_cancel(s->fiber, janet_ev_lasterr()); } return JANET_ASYNC_STATUS_DONE; diff --git a/src/core/net.c b/src/core/net.c index 36c598af..e628bce1 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -480,7 +480,7 @@ JANET_CORE_FN(cfun_net_connect, /* Wrap socket in abstract type JanetStream */ JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE); - /* Set the socket to non-blocking mode */ + /* Set up the socket for non-blocking IO before connecting */ janet_net_socknoblock(sock); /* Connect to socket */ diff --git a/src/include/janet.h b/src/include/janet.h index 130973dc..1064380b 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -568,6 +568,7 @@ typedef void *JanetAbstract; #define JANET_STREAM_WRITABLE 0x400 #define JANET_STREAM_ACCEPTABLE 0x800 #define JANET_STREAM_UDPSERVER 0x1000 +#define JANET_STREAM_TOCLOSE 0x10000 typedef enum { JANET_ASYNC_EVENT_INIT, From a6a097c111eb4087389ce73050c847bdd1175e7f Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Thu, 18 May 2023 14:20:38 +0200 Subject: [PATCH 029/138] Add CI test for mingw/wine on linux --- .github/workflows/test.yml | 17 +++++++++++++++++ src/core/features.h | 5 +++++ 2 files changed, 22 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 6dde896c..c620c513 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -57,3 +57,20 @@ jobs: - name: Build the project shell: cmd run: make -j CC=gcc + + test-mingw-linux: + name: Build and test with Mingw on Linux + Wine + runs-on: ubuntu-latest + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Setup Mingw and wine + run: | + sudo dpkg --add-architecture i386 + sudo apt-get update + sudo apt-get install libstdc++6:i386 libgcc-s1:i386 + sudo apt-get install gcc-mingw-w64-x86-64-win32 wine wine32 wine64 + - name: Compile the project + run: make clean && make CC=x86_64-w64-mingw32-gcc LD=x86_64-w64-mingw32-gcc UNAME=MINGW RUN=wine + - name: Test the project + run: make test UNAME=MINGW RUN=wine diff --git a/src/core/features.h b/src/core/features.h index 46caff58..b3e1f752 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -50,6 +50,11 @@ #define WIN32_LEAN_AND_MEAN #endif +/* needed for inet_pton and InitializeSRWLock */ +#ifdef __MINGW32__ +#define _WIN32_WINNT _WIN32_WINNT_VISTA +#endif + /* Needed for realpath on linux, as well as pthread rwlocks. */ #ifndef _XOPEN_SOURCE #define _XOPEN_SOURCE 600 From 89debac8f6ffbff573abbb5395a7924cea217e4c Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Fri, 19 May 2023 20:00:59 +0200 Subject: [PATCH 030/138] Fixed janet_loop1_impl stream use after dealloc --- src/core/ev.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/ev.c b/src/core/ev.c index 31b0a2f6..fd3a7b9a 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1969,6 +1969,7 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { JanetAsyncStatus status3 = JANET_ASYNC_STATUS_NOT_DONE; JanetAsyncStatus status4 = JANET_ASYNC_STATUS_NOT_DONE; state->event = pfd; + JanetStream *stream = state->stream; if (mask & POLLOUT) status1 = state->machine(state, JANET_ASYNC_EVENT_WRITE); if (mask & POLLIN) @@ -1983,7 +1984,6 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { status4 == JANET_ASYNC_STATUS_DONE) janet_unlisten(state, 0); /* Close the stream if requested and no more listeners are left */ - JanetStream *stream = state->stream; if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) { janet_stream_close(stream); } From 56d927c72dd621e122bf95eef8144c362cf35870 Mon Sep 17 00:00:00 2001 From: tionis Date: Fri, 19 May 2023 21:18:48 +0200 Subject: [PATCH 031/138] added thaw to complement freeze --- src/boot/boot.janet | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 0ccda788..1195ce11 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2142,6 +2142,19 @@ :buffer (string x) x)) +(defn thaw + `Thaw an object (make it mutable) and do a deep copy, making + child value also mutable. Closures, fibers, and abstract + types will not be recursively thawed, but all other types will` + [ds] + (case (type ds) + :table (walk-dict thaw ds) + :struct (walk-dict thaw ds) + :array (walk-ind thaw ds) + :tuple (walk-ind thaw ds) + :string (buffer ds) + ds)) + (defn macex ``Expand macros completely. `on-binding` is an optional callback for whenever a normal symbolic binding From 320ba80ca1b7a3ddd3e0f3f7895e3ae406e63fc9 Mon Sep 17 00:00:00 2001 From: tionis Date: Sat, 20 May 2023 14:00:33 +0200 Subject: [PATCH 032/138] added support for tables/structs with prototypes in thaw --- src/boot/boot.janet | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 1195ce11..eb745ab1 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2148,8 +2148,8 @@ types will not be recursively thawed, but all other types will` [ds] (case (type ds) - :table (walk-dict thaw ds) - :struct (walk-dict thaw ds) + :table (walk-dict thaw (table/proto-flatten ds)) + :struct (walk-dict thaw (struct/proto-flatten ds)) :array (walk-ind thaw ds) :tuple (walk-ind thaw ds) :string (buffer ds) From 2f966883d92e7433904c3f9038684d723ee1fa82 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 20 May 2023 07:42:50 -0500 Subject: [PATCH 033/138] Fix #1145 - variadic imperative arith. macros. Also update CHANGELOG --- CHANGELOG.md | 4 ++++ src/boot/boot.janet | 10 +++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 26252642..d9f78e14 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ # Changelog All notable changes to this project will be documented in this file. +## ??? - Unreleased +- Make imperative arithmetic macros variadic +- `ev/connect` now yields to the event loop instead of blocking while waiting for an ACK. + ## 1.28.0 - 2023-05-13 - Various bug fixes - Make nested short-fn's behave a bit more predictably (it is still not recommended to nest short-fns). diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 0ccda788..bdd80f54 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -147,11 +147,11 @@ (defn dec "Returns x - 1." [x] (- x 1)) (defmacro ++ "Increments the var x by 1." [x] ~(set ,x (,+ ,x ,1))) (defmacro -- "Decrements the var x by 1." [x] ~(set ,x (,- ,x ,1))) -(defmacro += "Increments the var x by n." [x n] ~(set ,x (,+ ,x ,n))) -(defmacro -= "Decrements the var x by n." [x n] ~(set ,x (,- ,x ,n))) -(defmacro *= "Shorthand for (set x (\\* x n))." [x n] ~(set ,x (,* ,x ,n))) -(defmacro /= "Shorthand for (set x (/ x n))." [x n] ~(set ,x (,/ ,x ,n))) -(defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n))) +(defmacro += "Increments the var x by n." [x & ns] ~(set ,x (,+ ,x ,;ns))) +(defmacro -= "Decrements the var x by n." [x & ns] ~(set ,x (,- ,x ,;ns))) +(defmacro *= "Shorthand for (set x (\\* x n))." [x & ns] ~(set ,x (,* ,x ,;ns))) +(defmacro /= "Shorthand for (set x (/ x n))." [x & ns] ~(set ,x (,/ ,x ,;ns))) +(defmacro %= "Shorthand for (set x (% x n))." [x & ns] ~(set ,x (,% ,x ,;ns))) (defmacro assert "Throw an error if x is not truthy. Will not evaluate `err` if x is truthy." From fc8c6a429eafacb88097aaf3ec7de17871a14013 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 20 May 2023 07:45:18 -0500 Subject: [PATCH 034/138] Modulo should not be variadic. --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index bdd80f54..616c1e53 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -151,7 +151,7 @@ (defmacro -= "Decrements the var x by n." [x & ns] ~(set ,x (,- ,x ,;ns))) (defmacro *= "Shorthand for (set x (\\* x n))." [x & ns] ~(set ,x (,* ,x ,;ns))) (defmacro /= "Shorthand for (set x (/ x n))." [x & ns] ~(set ,x (,/ ,x ,;ns))) -(defmacro %= "Shorthand for (set x (% x n))." [x & ns] ~(set ,x (,% ,x ,;ns))) +(defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n))) (defmacro assert "Throw an error if x is not truthy. Will not evaluate `err` if x is truthy." From 9cc0645a1e40944a0523a237bda10f050e342e55 Mon Sep 17 00:00:00 2001 From: tionis Date: Sat, 20 May 2023 17:35:25 +0200 Subject: [PATCH 035/138] added test for thaw and freeze --- src/boot/boot.janet | 4 ++-- test/suite0010.janet | 9 +++++++++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index eb745ab1..0186a4e2 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2148,10 +2148,10 @@ types will not be recursively thawed, but all other types will` [ds] (case (type ds) - :table (walk-dict thaw (table/proto-flatten ds)) - :struct (walk-dict thaw (struct/proto-flatten ds)) :array (walk-ind thaw ds) :tuple (walk-ind thaw ds) + :table (walk-dict thaw (table/proto-flatten ds)) + :struct (walk-dict thaw (struct/proto-flatten ds)) :string (buffer ds) ds)) diff --git a/test/suite0010.janet b/test/suite0010.janet index 5ac0cd16..b41142e8 100644 --- a/test/suite0010.janet +++ b/test/suite0010.janet @@ -253,4 +253,13 @@ # Check missing struct proto bug. (assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil)) "missing struct proto") +# Test thaw and freeze +(def table-to-freeze @{:c 22 :b [1 2 3 4] :d @"test" :e "test2"}) +(def table-to-freeze-with-inline-proto @{:a @[1 2 3] :b @[1 2 3 4] :c 22 :d @"test" :e @"test2"}) +(def struct-to-thaw (struct/with-proto {:a [1 2 3]} :c 22 :b [1 2 3 4] :d "test" :e "test2")) +(table/setproto table-to-freeze @{:a @[1 2 3]}) +(assert (deep= {:a [1 2 3] :b [1 2 3 4] :c 22 :d "test" :e "test2"} (freeze table-to-freeze))) +(assert (deep= table-to-freeze-with-inline-proto (thaw table-to-freeze))) +(assert (deep= table-to-freeze-with-inline-proto (thaw struct-to-thaw))) + (end-suite) From 61132d6c4068937b5e4181c08a9122270823506c Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 20 May 2023 08:41:12 +0200 Subject: [PATCH 036/138] os/time and janet_gettime now use CLOCK_MONOTONIC instead of CLOCK_REALTIM, this matches the description from the documentation of os/clock. Fixes issue #1144 --- src/core/util.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/util.c b/src/core/util.c index 3c50bc94..4e7f8c22 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -902,7 +902,7 @@ int janet_gettime(struct timespec *spec) { } #else int janet_gettime(struct timespec *spec) { - return clock_gettime(CLOCK_REALTIME, spec); + return clock_gettime(CLOCK_MONOTONIC, spec); } #endif #endif From aaf3d08bcd9ba75792cd99f9c866f8ab0ce9fb0c Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 20 May 2023 11:41:25 +0200 Subject: [PATCH 037/138] Added 'source' argument to os/clock to select the clock source --- src/core/os.c | 30 ++++++++++++++++++++++++------ src/core/util.c | 16 ++++++++++++++-- src/core/util.h | 7 ++++++- 3 files changed, 44 insertions(+), 9 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 64a03470..7a932f86 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1278,14 +1278,32 @@ JANET_CORE_FN(os_time, } JANET_CORE_FN(os_clock, - "(os/clock)", - "Return the number of whole + fractional seconds since some fixed point in time. The clock " - "is guaranteed to be non-decreasing in real time.") { + "(os/clock &opt source)", + "Return the number of whole + fractional seconds of the requested clock source.\n\n" + "The `source` argument is the identifier of the particular clock source to use, when not " + "specified the default is `:realtime`:\n" + "- :realtime: Return the real (i.e., wall-clock) time. This clock is affected by discontinuous " + " jumps in the system time\n" + "- :monotonic: Return the number of whole + fractional seconds since some fixed point in " + " time. The clock is guaranteed to be non-decreasing in real time.\n" + "- :cputime: Return the CPU time consumed by this process (i.e. all threads in the process)\n") { janet_sandbox_assert(JANET_SANDBOX_HRTIME); - janet_fixarity(argc, 0); - (void) argv; + janet_arity(argc, 0, 1); + enum JanetTimeSource source = JANET_TIME_REALTIME; + if (argc == 1) { + JanetKeyword sourcestr = janet_getkeyword(argv, 0); + if (janet_cstrcmp(sourcestr, "realtime") == 0) { + source = JANET_TIME_REALTIME; + } else if (janet_cstrcmp(sourcestr, "monotonic") == 0) { + source = JANET_TIME_MONOTONIC; + } else if (janet_cstrcmp(sourcestr, "cputime") == 0) { + source = JANET_TIME_CPUTIME; + } else { + janet_panicf("expected :real-time, :monotonic, or :cputime, got %v", argv[0]); + } + } struct timespec tv; - if (janet_gettime(&tv)) janet_panic("could not get time"); + if (janet_gettime(&tv, source)) janet_panic("could not get time"); double dtime = tv.tv_sec + (tv.tv_nsec / 1E9); return janet_wrap_number(dtime); } diff --git a/src/core/util.c b/src/core/util.c index 4e7f8c22..78d51336 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -901,8 +901,20 @@ int janet_gettime(struct timespec *spec) { return 0; } #else -int janet_gettime(struct timespec *spec) { - return clock_gettime(CLOCK_MONOTONIC, spec); +int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { + clockid_t cid = JANET_TIME_REALTIME; + switch (source) { + case JANET_TIME_REALTIME: + cid = CLOCK_REALTIME; + break; + case JANET_TIME_MONOTONIC: + cid = CLOCK_MONOTONIC; + break; + case JANET_TIME_CPUTIME: + cid = CLOCK_PROCESS_CPUTIME_ID; + break; + } + return clock_gettime(cid, spec); } #endif #endif diff --git a/src/core/util.h b/src/core/util.h index b8f9cc90..3fe7b858 100644 --- a/src/core/util.h +++ b/src/core/util.h @@ -126,7 +126,12 @@ void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetReg /* Clock gettime */ #ifdef JANET_GETTIME -int janet_gettime(struct timespec *spec); +enum JanetTimeSource { + JANET_TIME_REALTIME, + JANET_TIME_MONOTONIC, + JANET_TIME_CPUTIME +}; +int janet_gettime(struct timespec *spec, enum JanetTimeSource source); #endif /* strdup */ From e8e5f66f4cd2d5ae5fc2594662806a7f05407831 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 20 May 2023 12:00:15 +0200 Subject: [PATCH 038/138] Implement janet_gettime() for win32 and macos; need testing --- src/core/os.c | 6 ++-- src/core/util.c | 79 ++++++++++++++++++++++++++++++++----------------- 2 files changed, 55 insertions(+), 30 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 7a932f86..bf5673b7 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1280,8 +1280,8 @@ JANET_CORE_FN(os_time, JANET_CORE_FN(os_clock, "(os/clock &opt source)", "Return the number of whole + fractional seconds of the requested clock source.\n\n" - "The `source` argument is the identifier of the particular clock source to use, when not " - "specified the default is `:realtime`:\n" + "The `source` argument selects the clock source to use, when not specified the default " + "is `:realtime`:\n" "- :realtime: Return the real (i.e., wall-clock) time. This clock is affected by discontinuous " " jumps in the system time\n" "- :monotonic: Return the number of whole + fractional seconds since some fixed point in " @@ -1299,7 +1299,7 @@ JANET_CORE_FN(os_clock, } else if (janet_cstrcmp(sourcestr, "cputime") == 0) { source = JANET_TIME_CPUTIME; } else { - janet_panicf("expected :real-time, :monotonic, or :cputime, got %v", argv[0]); + janet_panicf("expected :realtime, :monotonic, or :cputime, got %v", argv[0]); } } struct timespec tv; diff --git a/src/core/util.c b/src/core/util.c index 78d51336..623ef57e 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -875,44 +875,69 @@ int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *index_buffe /* Clock shims for various platforms */ #ifdef JANET_GETTIME #ifdef JANET_WINDOWS -int janet_gettime(struct timespec *spec) { - FILETIME ftime; - GetSystemTimeAsFileTime(&ftime); - int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32); - /* Windows epoch is January 1, 1601 apparently */ - wintime -= 116444736000000000LL; - spec->tv_sec = wintime / 10000000LL; - /* Resolution is 100 nanoseconds. */ - spec->tv_nsec = wintime % 10000000LL * 100; +#include +int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { + if (source == JANET_TIME_REALTIME) { + FILETIME ftime; + GetSystemTimeAsFileTime(&ftime); + int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32); + /* Windows epoch is January 1, 1601 apparently */ + wintime -= 116444736000000000LL; + spec->tv_sec = wintime / 10000000LL; + /* Resolution is 100 nanoseconds. */ + spec->tv_nsec = wintime % 10000000LL * 100; + } else if (source == JANET_TIME_MONOTONIC) { + LARGE_INTEGER count; + LARGE_INTEGER perf_freq; + QueryPerformanceCounter(&count); + QueryPerformanceFrequency(&perf_freq); + spec->tv_sec = count.QuadPart / perf_freq.QuadPart; + spec->tv_nsec = (count.QuadPart % perf_freq.QuadPart) * 1000000000 / perf_freq.QuadPart; + } else if (source == JANET_TIME_CPUTIME) { + float tmp = clock(); + spec->tv_sec = tmp / CLOCKS_PER_SEC; + spec->tv_nsec = (tmp - spec->tv_sec * CLOCKS_PER_SEC) * 1e9 / CLOCKS_PER_SEC; + } return 0; } /* clock_gettime() wasn't available on Mac until 10.12. */ #elif defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_12) #include #include -int janet_gettime(struct timespec *spec) { - clock_serv_t cclock; - mach_timespec_t mts; - host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); - clock_get_time(cclock, &mts); - mach_port_deallocate(mach_task_self(), cclock); - spec->tv_sec = mts.tv_sec; - spec->tv_nsec = mts.tv_nsec; +int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { + if (source == JANET_TIME_REALTIME) { + clock_serv_t cclock; + mach_timespec_t mts; + host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock); + clock_get_time(cclock, &mts); + mach_port_deallocate(mach_task_self(), cclock); + spec->tv_sec = mts.tv_sec; + spec->tv_nsec = mts.tv_nsec; + } else if (source == JANET_TIME_MONOTONIC) { + clock_serv_t cclock; + int nsecs; + mach_msg_type_number_t count; + host_get_clock_service(mach_host_self(), clock, &cclock); + clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count); + mach_port_deallocate(mach_task_self(), cclock); + clock_getres(CLOCK_MONOTONIC, spec); + } + if (source == JANET_TIME_CPUTIME) { + clock_t tmp = clock(); + spec->tv_sec = tmp; + spec->tv_nsec = (tmp - spec->tv_sec) * 1.0e9; + } return 0; } #else int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { clockid_t cid = JANET_TIME_REALTIME; - switch (source) { - case JANET_TIME_REALTIME: - cid = CLOCK_REALTIME; - break; - case JANET_TIME_MONOTONIC: - cid = CLOCK_MONOTONIC; - break; - case JANET_TIME_CPUTIME: - cid = CLOCK_PROCESS_CPUTIME_ID; - break; + if (source == JANET_TIME_REALTIME) { + cid = CLOCK_REALTIME; + } else if (source == JANET_TIME_MONOTONIC) { + cid = CLOCK_MONOTONIC; + } else if (source == JANET_TIME_CPUTIME) { + cid = CLOCK_PROCESS_CPUTIME_ID; } return clock_gettime(cid, spec); } From 80db6821097f34a59758088797ada8667896603a Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 20 May 2023 13:55:43 +0200 Subject: [PATCH 039/138] Added tests for os/clock --- test/suite0007.janet | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/suite0007.janet b/test/suite0007.janet index c60a9678..f8f74bea 100644 --- a/test/suite0007.janet +++ b/test/suite0007.janet @@ -333,4 +333,29 @@ (assert (pos? (length (gensym))) "gensym not empty, regression #753") + +# os/clock + +(defmacro measure-time [clocks & body] + (def t1 (gensym)) + (def t2 (gensym)) + ~(do + (def ,t1 (map |(os/clock $) ,clocks)) + ,;body + (def ,t2 (map |(os/clock $) ,clocks)) + (zipcoll ,clocks [ (- (,t2 0) (,t1 0)) (- (,t2 1) (,t1 1)) (- (,t2 2) (,t1 2))])) +) + +# Spin for 0.1 seconds +(def dt (measure-time [:realtime :monotonic :cputime] + (def t1 (os/clock :monotonic)) + (while (< (- (os/clock :monotonic) t1) 0.1) true))) +(assert (> (dt :monotonic) 0.10)) +(assert (> (dt :cputime) 0.05)) + +# Sleep for 0.1 seconds +(def dt (measure-time [:realtime :monotonic :cputime] (os/sleep 0.1))) +(assert (> (dt :monotonic) 0.10)) +(assert (< (dt :cputime) 0.05)) + (end-suite) From 30c47d685dee8628cf45c22dcff0db803566442e Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 20 May 2023 14:16:36 +0200 Subject: [PATCH 040/138] Fixed :cputime because msdn does not implement clock() properly --- src/core/util.c | 10 ++++++---- test/suite0007.janet | 8 ++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/core/util.c b/src/core/util.c index 623ef57e..a699965e 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -892,11 +892,13 @@ int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { QueryPerformanceCounter(&count); QueryPerformanceFrequency(&perf_freq); spec->tv_sec = count.QuadPart / perf_freq.QuadPart; - spec->tv_nsec = (count.QuadPart % perf_freq.QuadPart) * 1000000000 / perf_freq.QuadPart; + spec->tv_nsec = (long)((count.QuadPart % perf_freq.QuadPart) * 1000000000 / perf_freq.QuadPart); } else if (source == JANET_TIME_CPUTIME) { - float tmp = clock(); - spec->tv_sec = tmp / CLOCKS_PER_SEC; - spec->tv_nsec = (tmp - spec->tv_sec * CLOCKS_PER_SEC) * 1e9 / CLOCKS_PER_SEC; + FILETIME creationTime, exitTime, kernelTime, userTime; + GetProcessTimes(GetCurrentProcess(), &creationTime, &exitTime, &kernelTime, &userTime); + int64_t tmp = ((int64_t)userTime.dwHighDateTime << 32) + userTime.dwLowDateTime; + spec->tv_sec = tmp / 10000000LL; + spec->tv_nsec = tmp % 10000000LL * 100; } return 0; } diff --git a/test/suite0007.janet b/test/suite0007.janet index f8f74bea..e59b049c 100644 --- a/test/suite0007.janet +++ b/test/suite0007.janet @@ -334,16 +334,16 @@ (assert (pos? (length (gensym))) "gensym not empty, regression #753") -# os/clock +# os/clock. These tests might prove fragile under CI because they +# rely on measured time. We'll see. (defmacro measure-time [clocks & body] - (def t1 (gensym)) - (def t2 (gensym)) + (def [t1 t2] [(gensym) (gensym)]) ~(do (def ,t1 (map |(os/clock $) ,clocks)) ,;body (def ,t2 (map |(os/clock $) ,clocks)) - (zipcoll ,clocks [ (- (,t2 0) (,t1 0)) (- (,t2 1) (,t1 1)) (- (,t2 2) (,t1 2))])) + (zipcoll ,clocks (map |(- ;$) (map tuple ,t2 ,t1)))) ) # Spin for 0.1 seconds From e53c03028fbf9ba832bb6f51cdbd7e6daa7f91d4 Mon Sep 17 00:00:00 2001 From: tionis Date: Sun, 21 May 2023 15:44:02 +0200 Subject: [PATCH 041/138] ignoring signals on windows in os/proc-kill again --- src/core/os.c | 33 ++++++++++++++------------------- 1 file changed, 14 insertions(+), 19 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index c1ab5622..55c4c7d3 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -628,6 +628,8 @@ struct keyword_signal { const char *keyword; int signal; }; + +#ifndef JANET_WINDOWS static const struct keyword_signal signal_keywords[] = { #ifdef SIGKILL {"kill", SIGKILL}, @@ -705,6 +707,7 @@ static const struct keyword_signal signal_keywords[] = { #endif {NULL, 0}, }; +#endif JANET_CORE_FN(os_proc_kill, "(os/proc-kill proc &opt wait signal)", @@ -712,12 +715,21 @@ JANET_CORE_FN(os_proc_kill, "handle on windows. If `wait` is truthy, will wait for the process to finish and " "returns the exit code. Otherwise, returns `proc`. If signal is specified send it instead." "Signal keywords are named after their C counterparts but in lowercase with the leading " - "`SIG` stripped") { + "`SIG` stripped. Signals are ignored on windows.") { janet_arity(argc, 1, 3); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); if (proc->flags & JANET_PROC_WAITED) { janet_panicf("cannot kill process that has already finished"); } +#ifdef JANET_WINDOWS + if (proc->flags & JANET_PROC_CLOSED) { + janet_panicf("cannot close process handle that is already closed"); + } + proc->flags |= JANET_PROC_CLOSED; + TerminateProcess(proc->pHandle, 1); + CloseHandle(proc->pHandle); + CloseHandle(proc->tHandle); +#else int signal = -1; if(argc == 3){ JanetKeyword signal_kw = janet_getkeyword(argv, 2); @@ -733,24 +745,7 @@ JANET_CORE_FN(os_proc_kill, janet_panic("undefined signal"); } } -#ifdef JANET_WINDOWS - if (proc->flags & JANET_PROC_CLOSED) { - janet_panicf("cannot close process handle that is already closed"); - } - proc->flags |= JANET_PROC_CLOSED; - if(signal == -1){ - TerminateProcess(proc->pHandle, 1); - }else{ - int status = kill(proc->pid, signal); - if (status) { - janet_panic(strerror(errno)); - } - } - CloseHandle(proc->pHandle); - CloseHandle(proc->tHandle); -#else - if(signal == -1){signal=SIGKILL;} - int status = kill(proc->pid, signal); + int status = kill(proc->pid, signal == -1 ? SIGKILL : signal); if (status) { janet_panic(strerror(errno)); } From 4dfc869b8a17ff16d0290daac021e6479cb62db3 Mon Sep 17 00:00:00 2001 From: tionis Date: Sun, 21 May 2023 15:55:11 +0200 Subject: [PATCH 042/138] fixed formatting in src/core/os.c --- src/core/os.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 8f076cbc..4d3a3448 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -650,7 +650,7 @@ static const struct keyword_signal signal_keywords[] = { #endif #ifdef SIGPIPE {"pipe", SIGPIPE}, - #endif +#endif #ifdef SIGQUIT {"quit", SIGQUIT}, #endif @@ -731,17 +731,17 @@ JANET_CORE_FN(os_proc_kill, CloseHandle(proc->tHandle); #else int signal = -1; - if(argc == 3){ + if (argc == 3) { JanetKeyword signal_kw = janet_getkeyword(argv, 2); const struct keyword_signal *ptr = signal_keywords; - while (ptr->keyword){ - if(!janet_cstrcmp(signal_kw, ptr->keyword)){ + while (ptr->keyword) { + if (!janet_cstrcmp(signal_kw, ptr->keyword)) { signal = ptr->signal; break; } ptr++; } - if(signal == -1){ + if (signal == -1) { janet_panic("undefined signal"); } } From 63353b98cd114e33ba4816cec642fe262f803d71 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sun, 21 May 2023 20:18:32 +0200 Subject: [PATCH 043/138] improved error messages for special forms --- src/core/specials.c | 12 ++++++------ src/core/value.c | 22 ++++++++++++---------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/core/specials.c b/src/core/specials.c index 8f40cdd7..b9bfc748 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -264,7 +264,7 @@ static const Janet *janetc_make_sourcemap(JanetCompiler *c) { static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 2) { - janetc_cerror(opts.compiler, "expected 2 arguments"); + janetc_cerror(opts.compiler, "expected 2 arguments to set"); return janetc_cslot(janet_wrap_nil()); } JanetFopts subopts = janetc_fopts_default(opts.compiler); @@ -335,11 +335,11 @@ static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv) return tab; } -static JanetSlot dohead(JanetCompiler *c, JanetFopts opts, Janet *head, int32_t argn, const Janet *argv) { +static JanetSlot dohead(const char *kind, JanetCompiler *c, JanetFopts opts, Janet *head, int32_t argn, const Janet *argv) { JanetFopts subopts = janetc_fopts_default(c); JanetSlot ret; if (argn < 2) { - janetc_cerror(c, "expected at least 2 arguments"); + janetc_error(c, janet_formatc("expected at least 2 arguments to %s", kind)); return janetc_cslot(janet_wrap_nil()); } *head = argv[0]; @@ -404,7 +404,7 @@ static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; Janet head; JanetTable *attr_table = handleattr(c, argn, argv); - JanetSlot ret = dohead(c, opts, &head, argn, argv); + JanetSlot ret = dohead("var", c, opts, &head, argn, argv); if (c->result.status == JANET_COMPILE_ERROR) return janetc_cslot(janet_wrap_nil()); destructure(c, argv[0], ret, varleaf, attr_table); @@ -454,7 +454,7 @@ static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) { Janet head; opts.flags &= ~JANET_FOPTS_HINT; JanetTable *attr_table = handleattr(c, argn, argv); - JanetSlot ret = dohead(c, opts, &head, argn, argv); + JanetSlot ret = dohead("def", c, opts, &head, argn, argv); if (c->result.status == JANET_COMPILE_ERROR) return janetc_cslot(janet_wrap_nil()); destructure(c, argv[0], ret, defleaf, attr_table); @@ -708,7 +708,7 @@ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) uint8_t ifnjmp = JOP_JUMP_IF_NOT; if (argn < 2) { - janetc_cerror(c, "expected at least 2 arguments"); + janetc_cerror(c, "expected at least 2 arguments to while"); return janetc_cslot(janet_wrap_nil()); } diff --git a/src/core/value.c b/src/core/value.c index 36e381cd..423b1714 100644 --- a/src/core/value.c +++ b/src/core/value.c @@ -439,20 +439,21 @@ int janet_compare(Janet x, Janet y) { return status - 2; } -static int32_t getter_checkint(Janet key, int32_t max) { +static int32_t getter_checkint(JanetType type, Janet key, int32_t max) { if (!janet_checkint(key)) goto bad; int32_t ret = janet_unwrap_integer(key); if (ret < 0) goto bad; if (ret >= max) goto bad; return ret; bad: - janet_panicf("expected integer key in range [0, %d), got %v", max, key); + janet_panicf("expected integer key for %s in range [0, %d), got %v", janet_type_names[type], max, key); } /* Gets a value and returns. Can panic. */ Janet janet_in(Janet ds, Janet key) { Janet value; - switch (janet_type(ds)) { + JanetType type = janet_type(ds); + switch (type) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, ds); break; @@ -464,19 +465,19 @@ Janet janet_in(Janet ds, Janet key) { break; case JANET_ARRAY: { JanetArray *array = janet_unwrap_array(ds); - int32_t index = getter_checkint(key, array->count); + int32_t index = getter_checkint(type, key, array->count); value = array->data[index]; break; } case JANET_TUPLE: { const Janet *tuple = janet_unwrap_tuple(ds); int32_t len = janet_tuple_length(tuple); - value = tuple[getter_checkint(key, len)]; + value = tuple[getter_checkint(type, key, len)]; break; } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(ds); - int32_t index = getter_checkint(key, buffer->count); + int32_t index = getter_checkint(type, key, buffer->count); value = janet_wrap_integer(buffer->data[index]); break; } @@ -484,7 +485,7 @@ Janet janet_in(Janet ds, Janet key) { case JANET_SYMBOL: case JANET_KEYWORD: { const uint8_t *str = janet_unwrap_string(ds); - int32_t index = getter_checkint(key, janet_string_length(str)); + int32_t index = getter_checkint(type, key, janet_string_length(str)); value = janet_wrap_integer(str[index]); break; } @@ -752,13 +753,14 @@ void janet_putindex(Janet ds, int32_t index, Janet value) { } void janet_put(Janet ds, Janet key, Janet value) { - switch (janet_type(ds)) { + JanetType type = janet_type(ds); + switch (type) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_ARRAY | JANET_TFLAG_BUFFER | JANET_TFLAG_TABLE, ds); case JANET_ARRAY: { JanetArray *array = janet_unwrap_array(ds); - int32_t index = getter_checkint(key, INT32_MAX - 1); + int32_t index = getter_checkint(type, key, INT32_MAX - 1); if (index >= array->count) { janet_array_setcount(array, index + 1); } @@ -767,7 +769,7 @@ void janet_put(Janet ds, Janet key, Janet value) { } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(ds); - int32_t index = getter_checkint(key, INT32_MAX - 1); + int32_t index = getter_checkint(type, key, INT32_MAX - 1); if (!janet_checkint(value)) janet_panicf("can only put integers in buffers, got %v", value); if (index >= buffer->count) { From 77732a8f44eb1c62f0be9b48d13e042fb7788cce Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 21 May 2023 13:36:11 -0500 Subject: [PATCH 044/138] inet_test change. --- src/core/net.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/net.c b/src/core/net.c index e628bce1..37d4b486 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -953,7 +953,7 @@ JANET_CORE_FN(cfun_net_setsockopt, const char *addr = janet_getcstring(argv, 2); memset(&val.v_mreq, 0, sizeof val.v_mreq); val.v_mreq.imr_interface.s_addr = htonl(INADDR_ANY); - val.v_mreq.imr_multiaddr.s_addr = inet_addr(addr); + inet_pton(AF_INET, addr, &val.v_mreq.imr_multiaddr.s_addr); optlen = sizeof(val.v_mreq); } else if (st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) { const char *addr = janet_getcstring(argv, 2); From 50a19bd8705e17d0b1101954d7a18ea660833faf Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 22 May 2023 20:53:03 +0200 Subject: [PATCH 045/138] Fix warning in janet_gettime() --- src/core/util.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/util.c b/src/core/util.c index a699965e..9f4ed951 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -933,7 +933,7 @@ int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { } #else int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { - clockid_t cid = JANET_TIME_REALTIME; + clockid_t cid = CLOCK_REALTIME; if (source == JANET_TIME_REALTIME) { cid = CLOCK_REALTIME; } else if (source == JANET_TIME_MONOTONIC) { From 41943746e4c919e9555530a77c1b45e2b7ba462b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 22 May 2023 20:40:30 -0500 Subject: [PATCH 046/138] Fix #1149 - deep-not= should only return true/false. Also improve perf at same time. --- src/boot/boot.janet | 20 ++++++++++++++++++-- test/suite0001.janet | 2 ++ 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 3f953c43..a6097660 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2114,8 +2114,24 @@ (or (not= tx (type y)) (case tx - :tuple (or (not= (length x) (length y)) (some identity (map deep-not= x y))) - :array (or (not= (length x) (length y)) (some identity (map deep-not= x y))) + :tuple (or (not= (length x) (length y)) + (do + (var ret false) + (forv i 0 (length x) + (def xx (in x i)) + (def yy (in y i)) + (if (deep-not= xx yy) + (break (set ret true)))) + ret)) + :array (or (not= (length x) (length y)) + (do + (var ret false) + (forv i 0 (length x) + (def xx (in x i)) + (def yy (in y i)) + (if (deep-not= xx yy) + (break (set ret true)))) + ret)) :struct (deep-not= (kvs x) (kvs y)) :table (deep-not= (table/to-struct x) (table/to-struct y)) :buffer (not= (string x) (string y)) diff --git a/test/suite0001.janet b/test/suite0001.janet index cbe356c7..ccda77e4 100644 --- a/test/suite0001.janet +++ b/test/suite0001.janet @@ -329,6 +329,8 @@ (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222])) (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111])) +(assert (= false (deep-not= [1] [1])) "issue #1149") + # Sort function (assert (deep= (range 99) From b4e3dbf3311bc47ac78a80d36688890d9ad81935 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 22 May 2023 18:44:27 +0200 Subject: [PATCH 047/138] Improved various error messages when handling unexpected types. error: bad slot #1, expected string|symbol|keyword|buffer, got ... error: bad slot #1, expected a string, symbol, keyword or buffer, got ... bad s64 initializer: "donkey" can not convert string "donkey" to s64 --- src/core/inttypes.c | 4 ++-- src/core/pp.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/inttypes.c b/src/core/inttypes.c index 7073d9aa..7c2fef33 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -138,7 +138,7 @@ int64_t janet_unwrap_s64(Janet x) { break; } } - janet_panicf("bad s64 initializer: %t", x); + janet_panicf("can not convert %t %q to 64 bit signed integer", x, x); return 0; } @@ -169,7 +169,7 @@ uint64_t janet_unwrap_u64(Janet x) { break; } } - janet_panicf("bad u64 initializer: %t", x); + janet_panicf("can not convert %t %q to a 64 bit unsigned integer", x, x); return 0; } diff --git a/src/core/pp.c b/src/core/pp.c index d058cb1e..f5fc6f9d 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -736,7 +736,7 @@ static void pushtypes(JanetBuffer *buffer, int types) { if (first) { first = 0; } else { - janet_buffer_push_u8(buffer, '|'); + janet_buffer_push_cstring(buffer, (types == 1) ? " or " : ", "); } janet_buffer_push_cstring(buffer, janet_type_names[i]); } From e9f2d1aca7df0d67365574d970bd86c6f31ae510 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Tue, 23 May 2023 06:58:52 +0200 Subject: [PATCH 048/138] changed some error messages 'x|y' -> 'x or y' --- src/core/corelib.c | 2 +- src/core/ev.c | 2 +- src/core/peg.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/corelib.c b/src/core/corelib.c index ce6b20b9..0d72c118 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -458,7 +458,7 @@ JANET_CORE_FN(janet_core_getproto, ? janet_wrap_struct(janet_struct_proto(st)) : janet_wrap_nil(); } - janet_panicf("expected struct|table, got %v", argv[0]); + janet_panicf("expected struct or table, got %v", argv[0]); } JANET_CORE_FN(janet_core_struct, diff --git a/src/core/ev.c b/src/core/ev.c index fd3a7b9a..a7056b9c 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -2911,7 +2911,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { JanetFiber *fiber; if (!janet_checktype(fiberv, JANET_FIBER)) { if (!janet_checktype(fiberv, JANET_FUNCTION)) { - janet_panicf("expected function|fiber, got %v", fiberv); + janet_panicf("expected function or fiber, got %v", fiberv); } JanetFunction *func = janet_unwrap_function(fiberv); if (func->def->min_arity > 1) { diff --git a/src/core/peg.c b/src/core/peg.c index 5057494a..a814e65f 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -1100,7 +1100,7 @@ static void spec_matchtime(Builder *b, int32_t argc, const Janet *argv) { Janet fun = argv[1]; if (!janet_checktype(fun, JANET_FUNCTION) && !janet_checktype(fun, JANET_CFUNCTION)) { - peg_panicf(b, "expected function|cfunction, got %v", fun); + peg_panicf(b, "expected function or cfunction, got %v", fun); } uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; uint32_t cindex = emit_constant(b, fun); From b3a92363f849230a87ea088d021ca932196c6bb3 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 22 May 2023 19:19:54 +0200 Subject: [PATCH 049/138] Add docstring to string/format --- src/core/string.c | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/core/string.c b/src/core/string.c index e7957edf..d7baf86b 100644 --- a/src/core/string.c +++ b/src/core/string.c @@ -535,7 +535,30 @@ JANET_CORE_FN(cfun_string_join, JANET_CORE_FN(cfun_string_format, "(string/format format & values)", "Similar to C's `snprintf`, but specialized for operating with Janet values. Returns " - "a new string.") { + "a new string.\n\n" + "The following conversion specifiers are supported, where the upper case specifiers generate " + "upper case output:\n" + "- `c`: ASCII character.\n" + "- `d`, `i`: integer, formatted as a decimal number.\n" + "- `x`, `X`: integer, formatted as a hexadecimal number.\n" + "- `o`: integer, formatted as an octal number.\n" + "- `f`, `F`: floating point number, formatted as a decimal number.\n" + "- `e`, `E`: floating point number, formatted in scientific notation.\n" + "- `g`, `G`: floating point number, formatted in its shortest form.\n" + "- `a`, `A`: floating point number, formatted as a hexadecimal number.\n" + "- `s`: formatted as a string, precision indicates padding and maximum length.\n" + "- `t`: emit the type of the given value.\n" + "- `v`: format with (describe x)" + "- `V`: format with (string x)" + "- `j`: format to jdn (Janet data notation).\n" + "\n" + "The following conversion specifiers are used for \"pretty-printing\", where the upper-case " + "variants generate colored output. These speficiers can take a precision " + "argument to specify the maximum nesting depth to print.\n" + "- `p`, `P`: pretty format, truncating if necessary\n" + "- `m`, `M`: pretty format without truncating.\n" + "- `q`, `Q`: pretty format on one line, truncating if necessary.\n" + "- `n`, `N`: pretty format on one line without truncation.\n") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_buffer(0); const char *strfrmt = (const char *) janet_getstring(argv, 0); From 71bde11e9599835ab31adb77de4d58444bf6671c Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 23 May 2023 19:38:07 -0500 Subject: [PATCH 050/138] Allow one argument to while. --- src/core/specials.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/specials.c b/src/core/specials.c index b9bfc748..c186245f 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -707,8 +707,8 @@ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) uint8_t ifjmp = JOP_JUMP_IF; uint8_t ifnjmp = JOP_JUMP_IF_NOT; - if (argn < 2) { - janetc_cerror(c, "expected at least 2 arguments to while"); + if (argn < 1) { + janetc_cerror(c, "expected at least 1 argument to while"); return janetc_cslot(janet_wrap_nil()); } From 909c9060809303ddb4533cf841f51e7b8694e266 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 23 May 2023 20:08:57 -0500 Subject: [PATCH 051/138] Fix yields inside nested fibers. --- src/core/vm.c | 1 + test/suite0001.janet | 7 +++++++ 2 files changed, 8 insertions(+) diff --git a/src/core/vm.c b/src/core/vm.c index 3a29e207..b7e67df1 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -1423,6 +1423,7 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { *out = in; janet_fiber_set_status(fiber, sig); + fiber->last_value = child->last_value; return sig; } /* Check if we need any special handling for certain opcodes */ diff --git a/test/suite0001.janet b/test/suite0001.janet index ccda77e4..3d156d32 100644 --- a/test/suite0001.janet +++ b/test/suite0001.janet @@ -360,4 +360,11 @@ (assert (= (or 1) 1) "or 1") (assert (= (or) nil) "or with no arguments") +(def yielder + (coro + (defer (yield :end) + (repeat 5 (yield :item))))) +(def items (seq [x :in yielder] x)) +(assert (deep= @[:item :item :item :item :item :end] items) "yield within nested fibers") + (end-suite) From 64e3cdeb2b37dd1b03d35ad211327cff1980f964 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Wed, 24 May 2023 16:39:49 +0200 Subject: [PATCH 052/138] Add file/lines iterator --- src/boot/boot.janet | 13 +++++++++++++ test/suite0009.janet | 13 +++++++++++++ 2 files changed, 26 insertions(+) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index a6097660..bf39ce44 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1749,6 +1749,19 @@ (printf (dyn *pretty-format* "%q") x) (flush)) +(defn file/lines + "Return an iterator over the lines of a file" + [file-or-path &opt mode] + (default mode :r) + (if (bytes? file-or-path) + (coro + (with [f (file/open file-or-path mode)] + (while (def line (file/read f :line)) + (yield line)))) + (coro + (while (def line (file/read file-or-path :line)) + (yield line))))) + ### ### ### Pattern Matching diff --git a/test/suite0009.janet b/test/suite0009.janet index 99f5232e..2b9b2205 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -102,6 +102,19 @@ (os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f}) (file/flush f))) +# each-line iterator + +(assert-no-error "file/lines iterator" + (def outstream (os/open "unique.txt" :wct)) + (def buf1 "123\n456\n") + (defer (:close outstream) + (:write outstream buf1)) + (var buf2 "") + (each line (file/lines "unique.txt") + (set buf2 (string buf2 line))) + (assert (= buf1 buf2) "file/lines iterator") + (os/rm "unique.txt")) + # Issue #593 (assert-no-error "file writing 3" (def outfile (file/open "unique.txt" :w)) From 672b705fafd92d762c9f6d8e51ff03faedc4a6be Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Thu, 25 May 2023 18:12:38 +0700 Subject: [PATCH 053/138] Allow mapcat et al to accept multiple iterable arguments #1159 --- src/boot/boot.janet | 142 +++++++++++++++++++++----------------------- 1 file changed, 68 insertions(+), 74 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index a6097660..3be1c411 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -923,67 +923,65 @@ (set k (next ind k))) ret) +(defmacro- map-aggregator + `Aggregation logic for various map functions.` + [maptype res val] + (case maptype + :map ~(array/push ,res ,val) + :mapcat ~(array/concat ,res ,val) + :keep ~(if (def y ,val) (array/push ,res y)) + :count ~(if ,val (++ ,res)) + :some ~(if (def y ,val) (do (set ,res y) (break))) + :all ~(if (def y ,val) nil (do (set ,res y) (break))))) + +(defmacro- map-n + `Generates efficient map logic for a specific number of + indexed beyond the first.` + [n maptype res f ind inds] + ~(do + (def ,(seq [k :range [0 n]] (symbol 'ind k)) ,inds) + ,;(seq [k :range [0 n]] ~(var ,(symbol 'key k) nil)) + (each x ,ind + ,;(seq [k :range [0 n]] + ~(if (= nil (set ,(symbol 'key k) (next ,(symbol 'ind k) ,(symbol 'key k)))) (break))) + (map-aggregator ,maptype ,res (,f x ,;(seq [k :range [0 n]] ~(in ,(symbol 'ind k) ,(symbol 'key k)))))))) + +(defmacro- map-template + [maptype res f ind inds] + ~(do + (def ninds (length ,inds)) + (case ninds + 0 (each x ,ind (map-aggregator ,maptype ,res (,f x))) + ,;(kvs(tabseq [k :range [1 5]] k ~(map-n ,k ,maptype ,res ,f ,ind ,inds))) + (do + (def iter-keys (array/new-filled ninds)) + (def call-buffer (array/new-filled ninds)) + (var done false) + (each x ,ind + (forv i 0 ninds + (let [old-key (in iter-keys i) + ii (in ,inds i) + new-key (next ii old-key)] + (if (= nil new-key) + (do (set done true) (break)) + (do (set (iter-keys i) new-key) (set (call-buffer i) (in ii new-key)))))) + (if done (break)) + (map-aggregator ,maptype ,res (,f x ;call-buffer))))))) + (defn map `Map a function over every value in a data structure and return an array of the results.` - [f & inds] - (def ninds (length inds)) - (if (= 0 ninds) (error "expected at least 1 indexed collection")) + [f ind & inds] (def res @[]) - (def [i1 i2 i3 i4] inds) - (case ninds - 1 (each x i1 (array/push res (f x))) - 2 (do - (var k1 nil) - (var k2 nil) - (while true - (if (= nil (set k1 (next i1 k1))) (break)) - (if (= nil (set k2 (next i2 k2))) (break)) - (array/push res (f (in i1 k1) (in i2 k2))))) - 3 (do - (var k1 nil) - (var k2 nil) - (var k3 nil) - (while true - (if (= nil (set k1 (next i1 k1))) (break)) - (if (= nil (set k2 (next i2 k2))) (break)) - (if (= nil (set k3 (next i3 k3))) (break)) - (array/push res (f (in i1 k1) (in i2 k2) (in i3 k3))))) - 4 (do - (var k1 nil) - (var k2 nil) - (var k3 nil) - (var k4 nil) - (while true - (if (= nil (set k1 (next i1 k1))) (break)) - (if (= nil (set k2 (next i2 k2))) (break)) - (if (= nil (set k3 (next i3 k3))) (break)) - (if (= nil (set k4 (next i4 k4))) (break)) - (array/push res (f (in i1 k1) (in i2 k2) (in i3 k3) (in i4 k4))))) - (do - (def iterkeys (array/new-filled ninds)) - (var done false) - (def call-buffer @[]) - (while true - (forv i 0 ninds - (let [old-key (in iterkeys i) - ii (in inds i) - new-key (next ii old-key)] - (if (= nil new-key) - (do (set done true) (break)) - (do (set (iterkeys i) new-key) (array/push call-buffer (in ii new-key)))))) - (if done (break)) - (array/push res (f ;call-buffer)) - (array/clear call-buffer)))) + (map-template :map res f ind inds) res) (defn mapcat ``Map a function over every element in an array or tuple and use `array/concat` to concatenate the results.`` - [f ind] + [f ind & inds] (def res @[]) - (each x ind - (array/concat res (f x))) + (map-template :mapcat res f ind inds) res) (defn filter @@ -999,23 +997,19 @@ (defn count ``Count the number of items in `ind` for which `(pred item)` is true.`` - [pred ind] - (var counter 0) - (each item ind - (if (pred item) - (++ counter))) - counter) + [pred ind & inds] + (var res 0) + (map-template :count res pred ind inds) + res) (defn keep ``Given a predicate `pred`, return a new array containing the truthy results of applying `pred` to each element in the indexed collection `ind`. This is different from `filter` which returns an array of the original elements where the predicate is truthy.`` - [pred ind] + [pred ind & inds] (def res @[]) - (each item ind - (if-let [y (pred item)] - (array/push res y))) + (map-template :keep res pred ind inds) res) (defn range @@ -2090,21 +2084,21 @@ ret) (defn all - ``Returns true if `(pred item)` returns a truthy value for every item in `xs`. - Otherwise, returns the first falsey `(pred item)` result encountered. - Returns true if `xs` is empty.`` - [pred xs] - (var ret true) - (loop [x :in xs :while ret] (set ret (pred x))) - ret) + ``Returns true if `(pred item)` is truthy for every item in `ind`. + Otherwise, returns the first falsey result encountered. + Returns true if `ind` is empty.`` + [pred ind & inds] + (var res true) + (map-template :all res pred ind inds) + res) (defn some - ``Returns nil if all `xs` are false or nil, otherwise returns the result of the - first truthy predicate, `(pred x)`.`` - [pred xs] - (var ret nil) - (loop [x :in xs :while (not ret)] (if-let [y (pred x)] (set ret y))) - ret) + ``Returns nil if `(pred item)` is false or nil for every item in `ind`. + Otherwise, returns the first truthy result encountered.`` + [pred ind & inds] + (var res nil) + (map-template :some res pred ind inds) + res) (defn deep-not= ``Like `not=`, but mutable types (arrays, tables, buffers) are considered From 3602f5aa5d58a0a688dde6ddb3842a41f95c0f52 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Thu, 25 May 2023 18:27:31 +0700 Subject: [PATCH 054/138] Update boot.janet `kvs` is not yet defined at this point. --- src/boot/boot.janet | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 3be1c411..5cdc54b0 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -952,7 +952,10 @@ (def ninds (length ,inds)) (case ninds 0 (each x ,ind (map-aggregator ,maptype ,res (,f x))) - ,;(kvs(tabseq [k :range [1 5]] k ~(map-n ,k ,maptype ,res ,f ,ind ,inds))) + 1 (map-n 1 ,maptype ,res ,f ,ind ,inds) + 2 (map-n 2 ,maptype ,res ,f ,ind ,inds) + 3 (map-n 3 ,maptype ,res ,f ,ind ,inds) + 4 (map-n 4 ,maptype ,res ,f ,ind ,inds) (do (def iter-keys (array/new-filled ninds)) (def call-buffer (array/new-filled ninds)) From bad73baf983cb5c48ba568e071495965051a50a5 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Fri, 26 May 2023 19:08:00 +0700 Subject: [PATCH 055/138] Add test cases for variadic arguments to map-like functions --- test/suite0001.janet | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/suite0001.janet b/test/suite0001.janet index 3d156d32..2b41c536 100644 --- a/test/suite0001.janet +++ b/test/suite0001.janet @@ -323,11 +323,25 @@ (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300]) @[111 222 333])) (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]) @[1111 2222 3333])) (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000]) @[11111 22222 33333])) +(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000] [100000 200000 300000]) @[111111 222222 333333])) # Mapping uses the shortest sequence (assert (deep= (map + [1 2 3 4] [10 20 30]) @[11 22 33])) (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222])) (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111])) +(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000] []) @[])) + +# Variadic arguments to map-like functions +(assert (deep= (mapcat tuple [1 2 3 4] [5 6 7 8]) @[1 5 2 6 3 7 4 8])) +(assert (deep= (keep |(if (> $1 0) (/ $0 $1)) [1 2 3 4 5] [1 2 1 0 1]) @[1 1 3 5])) + +(assert (= (count = [1 3 2 4 3 5 4 2 1] [1 2 3 4 5 4 3 2 1]) 4)) + +(assert (= (some not= (range 5) (range 5)) nil)) +(assert (= (some = [1 2 3 4 5] [5 4 3 2 1]) true)) + +(assert (= (all = (range 5) (range 5)) true)) +(assert (= (all not= [1 2 3 4 5] [5 4 3 2 1]) false)) (assert (= false (deep-not= [1] [1])) "issue #1149") From 09345ec7864fd2d1b1ccc3f6e042c91743b72876 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Fri, 26 May 2023 17:50:26 +0200 Subject: [PATCH 056/138] file/linex now only acceps a file, not a path name --- src/boot/boot.janet | 17 ++++++----------- test/suite0009.janet | 5 +++-- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index bf39ce44..f05914c5 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1749,18 +1749,13 @@ (printf (dyn *pretty-format* "%q") x) (flush)) + (defn file/lines - "Return an iterator over the lines of a file" - [file-or-path &opt mode] - (default mode :r) - (if (bytes? file-or-path) - (coro - (with [f (file/open file-or-path mode)] - (while (def line (file/read f :line)) - (yield line)))) - (coro - (while (def line (file/read file-or-path :line)) - (yield line))))) + "Return an iterator over the lines of a file." + [file] + (coro + (while (def line (file/read file :line)) + (yield line)))) ### ### diff --git a/test/suite0009.janet b/test/suite0009.janet index 2b9b2205..c0c26ab0 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -110,8 +110,9 @@ (defer (:close outstream) (:write outstream buf1)) (var buf2 "") - (each line (file/lines "unique.txt") - (set buf2 (string buf2 line))) + (with [f (file/open "unique.txt" :r)] + (each line (file/lines f) + (set buf2 (string buf2 line)))) (assert (= buf1 buf2) "file/lines iterator") (os/rm "unique.txt")) From a2812ec5eb4bf297fb07edd0ef8df425fc1ad447 Mon Sep 17 00:00:00 2001 From: Charlotte Koch Date: Sat, 27 May 2023 14:22:11 -0700 Subject: [PATCH 057/138] More portable method of installing janet.h -> janet/janet.h symlink --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index f5595310..d6d7330d 100644 --- a/Makefile +++ b/Makefile @@ -296,7 +296,7 @@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc strip '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet' - ln -sf -T ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' || true #fixme bsd + ln -sf ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' mkdir -p '$(DESTDIR)$(JANET_PATH)' mkdir -p '$(DESTDIR)$(LIBDIR)' if test $(UNAME) = Darwin ; then \ From 4aca94154f910dd1567d1dfb4bfc3a0bb6390fcd Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 28 May 2023 15:28:17 -0500 Subject: [PATCH 058/138] Be more selective when testing FFI. In the future, we really should get more FFI testing for partially supported FFI on various platforms. --- test/suite0012.janet | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/suite0012.janet b/test/suite0012.janet index 834e1628..267575ea 100644 --- a/test/suite0012.janet +++ b/test/suite0012.janet @@ -28,7 +28,8 @@ (assert (= (thunk) 1) "delay 3") (assert (= counter 1) "delay 4") -(def has-ffi (dyn 'ffi/native)) +# We should get ARM support... +(def has-ffi (and (dyn 'ffi/native) (= (os/arch) :x64))) # FFI check (compwhen has-ffi From e64a0175b10b02f75cd9f8ccea3f7bab0a27dd55 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 29 May 2023 19:50:14 +0200 Subject: [PATCH 059/138] change janet_formatbv() to handle int/unsigned int instead of long/unsigned long on '%d' and '%u' format specifiers. --- src/core/pp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/pp.c b/src/core/pp.c index f5fc6f9d..abeb7ce3 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -846,7 +846,7 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { } case 'd': case 'i': { - int64_t n = va_arg(args, long); + int64_t n = va_arg(args, int); nb = snprintf(item, MAX_ITEM, form, n); break; } @@ -854,7 +854,7 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { case 'X': case 'o': case 'u': { - uint64_t n = va_arg(args, unsigned long); + uint64_t n = va_arg(args, unsigned int); nb = snprintf(item, MAX_ITEM, form, n); break; } From d13788a4edb6d86ce8fed0c8fba1cfd64ff0f458 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Mon, 29 May 2023 22:02:06 +0200 Subject: [PATCH 060/138] Updated documentation for buffer/push-at --- src/core/buffer.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core/buffer.c b/src/core/buffer.c index 55931ead..84f8fe08 100644 --- a/src/core/buffer.c +++ b/src/core/buffer.c @@ -324,7 +324,8 @@ static void buffer_push_impl(JanetBuffer *buffer, Janet *argv, int32_t argc_offs JANET_CORE_FN(cfun_buffer_push_at, "(buffer/push-at buffer index & xs)", - "Same as buffer/push, but inserts new data at index `index`.") { + "Same as buffer/push, but copies the new data into the buffer " + " at index `index`.") { janet_arity(argc, 2, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t index = janet_getinteger(argv, 1); From 4782a76bcab1d6ad6af4a1bc821d6b3604d5300b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 29 May 2023 16:10:48 -0500 Subject: [PATCH 061/138] Add inital bytecode optimizations for #1163 This removes unnecessary movn, movf, lds, and a few other instructions. Any instructions that has not side effects and writes to a slot that isn't used can be removed. A number of other optimizations can follow from this: - Implement the def-aliasing-var optimization better - This function can be iterated as a fix point until no more instructions are removed. - If we implement slot renaming, then we no longer need to free slots and can simplify the initial code generation a lot. --- Makefile | 2 +- src/core/bytecode.c | 274 +++++++++++++++++++++++++++++++++++++++++++ src/core/compile.c | 4 + src/core/compile.h | 4 + src/core/regalloc.c | 10 ++ src/core/regalloc.h | 1 + src/core/specials.c | 12 +- test/suite0015.janet | 14 ++- 8 files changed, 313 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index d6d7330d..cd5cfb3f 100644 --- a/Makefile +++ b/Makefile @@ -51,7 +51,7 @@ LDFLAGS?=-rdynamic RUN:=$(RUN) COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC -BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) +BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) -g BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) # For installation diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 31faa5bf..185bccab 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -25,6 +25,7 @@ #include #include "gc.h" #include "util.h" +#include "regalloc.h" #endif /* Look up table for instructions */ @@ -106,6 +107,279 @@ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = { JINT_SSS /* JOP_CANCEL, */ }; +/* Remove all noops while preserving jumps and debugging information. + * Useful as part of a filtering compiler pass. */ +void janet_bytecode_remove_noops(JanetFuncDef *def) { + + /* Get an instruction rewrite map so we can rewrite jumps */ + uint32_t *pc_map = janet_smalloc(sizeof(uint32_t) * (1 + def->bytecode_length)); + uint32_t new_bytecode_length = 0; + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + uint32_t opcode = instr & 0x7F; + pc_map[i] = new_bytecode_length; + if (opcode != JOP_NOOP) { + new_bytecode_length++; + } + } + pc_map[def->bytecode_length] = new_bytecode_length; + + /* Linear scan rewrite bytecode and sourcemap. Also fix jumps. */ + int32_t j = 0; + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + uint32_t opcode = instr & 0x7F; + int32_t old_jump_target = 0; + int32_t new_jump_target = 0; + switch (opcode) { + case JOP_NOOP: + continue; + case JOP_JUMP: + /* relative pc is in DS field of instruction */ + old_jump_target = i + (((int32_t)instr) >> 8); + new_jump_target = pc_map[old_jump_target]; + instr += (new_jump_target - old_jump_target + (i - j)) << 8; + break; + case JOP_JUMP_IF: + case JOP_JUMP_IF_NIL: + case JOP_JUMP_IF_NOT: + case JOP_JUMP_IF_NOT_NIL: + /* relative pc is in ES field of instruction */ + old_jump_target = i + (((int32_t)instr) >> 16); + new_jump_target = pc_map[old_jump_target]; + instr += (new_jump_target - old_jump_target + (i - j)) << 16; + break; + default: + break; + } + def->bytecode[j] = instr; + if (def->sourcemap != NULL) { + def->sourcemap[j] = def->sourcemap[i]; + } + j++; + } + + /* Rewrite symbolmap */ + for (int32_t i = 0; i < def->symbolmap_length; i++) { + JanetSymbolMap *sm = def->symbolmap + i; + /* Don't rewrite upvalue mappings */ + if (sm->birth_pc < UINT32_MAX) { + sm->birth_pc = pc_map[sm->birth_pc]; + sm->death_pc = pc_map[sm->death_pc]; + } + } + + def->bytecode_length = new_bytecode_length; + janet_sfree(pc_map); +} + +/* Remove redundant loads, moves and other instructions if possible and convert them to + * noops. Input is assumed valid bytecode. */ +void janet_bytecode_movopt(JanetFuncDef *def) { + JanetcRegisterAllocator ra; + janetc_regalloc_init(&ra); + + /* Look for slots that have writes but no reads (and aren't in the closure bitset). */ + if (def->closure_bitset != NULL) { + for (int32_t i = 0; i < def->slotcount; i++) { + int32_t index = i >> 5; + uint32_t mask = 1U << (((uint32_t) i) & 31); + if (def->closure_bitset[index] & mask) { + janetc_regalloc_touch(&ra, i); + } + } + } + +#define AA ((instr >> 8) & 0xFF) +#define BB ((instr >> 16) & 0xFF) +#define CC (instr >> 24) +#define DD (instr >> 8) +#define EE (instr >> 16) + + /* Check reads and writes */ + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + switch (instr & 0x7F) { + + /* Group instructions my how they read from slots */ + + /* No reads or writes */ + default: + janet_assert(0, "unhandled instruction"); + case JOP_JUMP: + case JOP_NOOP: + case JOP_RETURN_NIL: + /* Write A */ + case JOP_LOAD_INTEGER: + case JOP_LOAD_CONSTANT: + case JOP_LOAD_UPVALUE: + case JOP_CLOSURE: + /* Write D */ + case JOP_LOAD_NIL: + case JOP_LOAD_TRUE: + case JOP_LOAD_FALSE: + case JOP_LOAD_SELF: + case JOP_MAKE_ARRAY: + case JOP_MAKE_BUFFER: + case JOP_MAKE_STRING: + case JOP_MAKE_STRUCT: + case JOP_MAKE_TABLE: + case JOP_MAKE_TUPLE: + case JOP_MAKE_BRACKET_TUPLE: + break; + + /* Read A */ + case JOP_ERROR: + case JOP_TYPECHECK: + case JOP_JUMP_IF: + case JOP_JUMP_IF_NOT: + case JOP_JUMP_IF_NIL: + case JOP_JUMP_IF_NOT_NIL: + case JOP_SET_UPVALUE: + /* Write E, Read A */ + case JOP_MOVE_FAR: + janetc_regalloc_touch(&ra, AA); + break; + + /* Read B */ + case JOP_SIGNAL: + /* Write A, Read B */ + case JOP_ADD_IMMEDIATE: + case JOP_MULTIPLY_IMMEDIATE: + case JOP_DIVIDE_IMMEDIATE: + case JOP_SHIFT_LEFT_IMMEDIATE: + case JOP_SHIFT_RIGHT_IMMEDIATE: + case JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE: + case JOP_GREATER_THAN_IMMEDIATE: + case JOP_LESS_THAN_IMMEDIATE: + case JOP_EQUALS_IMMEDIATE: + case JOP_NOT_EQUALS_IMMEDIATE: + case JOP_GET_INDEX: + janetc_regalloc_touch(&ra, BB); + break; + + /* Read D */ + case JOP_RETURN: + case JOP_PUSH: + case JOP_PUSH_ARRAY: + case JOP_TAILCALL: + janetc_regalloc_touch(&ra, DD); + break; + + /* Write A, Read E */ + case JOP_MOVE_NEAR: + case JOP_LENGTH: + case JOP_BNOT: + case JOP_CALL: + janetc_regalloc_touch(&ra, EE); + break; + + /* Read A, B */ + case JOP_PUT_INDEX: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, BB); + break; + + /* Read A, E */ + case JOP_PUSH_2: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, EE); + break; + + /* Read B, C */ + case JOP_PROPAGATE: + /* Write A, Read B and C */ + case JOP_BAND: + case JOP_BOR: + case JOP_BXOR: + case JOP_ADD: + case JOP_SUBTRACT: + case JOP_MULTIPLY: + case JOP_DIVIDE: + case JOP_MODULO: + case JOP_REMAINDER: + case JOP_SHIFT_LEFT: + case JOP_SHIFT_RIGHT: + case JOP_SHIFT_RIGHT_UNSIGNED: + case JOP_GREATER_THAN: + case JOP_LESS_THAN: + case JOP_EQUALS: + case JOP_COMPARE: + case JOP_IN: + case JOP_GET: + case JOP_GREATER_THAN_EQUAL: + case JOP_LESS_THAN_EQUAL: + case JOP_NOT_EQUALS: + case JOP_CANCEL: + case JOP_RESUME: + case JOP_NEXT: + janetc_regalloc_touch(&ra, BB); + janetc_regalloc_touch(&ra, CC); + break; + + /* Read A, B, C */ + case JOP_PUT: + case JOP_PUSH_3: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, BB); + janetc_regalloc_touch(&ra, CC); + break; + } + } + + /* Iterate and set noops on instructions that make writes that no one ever reads. + * Only set noops for instructions with no side effects - moves, loads, etc. that can't + * raise errors (outside of systemic errors like oom or stack overflow). */ + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + switch (instr & 0x7F) { + default: + break; + /* Write D */ + case JOP_LOAD_NIL: + case JOP_LOAD_TRUE: + case JOP_LOAD_FALSE: + case JOP_LOAD_SELF: + case JOP_MAKE_ARRAY: + case JOP_MAKE_TUPLE: + case JOP_MAKE_BRACKET_TUPLE: { + if (!janetc_regalloc_check(&ra, DD)) { + def->bytecode[i] = JOP_NOOP; + } + } + break; + /* Write E, Read A */ + case JOP_MOVE_FAR: { + if (!janetc_regalloc_check(&ra, EE)) { + def->bytecode[i] = JOP_NOOP; + } + } + break; + /* Write A, Read E */ + case JOP_MOVE_NEAR: + /* Write A, Read B */ + case JOP_GET_INDEX: + /* Write A */ + case JOP_LOAD_INTEGER: + case JOP_LOAD_CONSTANT: + case JOP_LOAD_UPVALUE: + case JOP_CLOSURE: { + if (!janetc_regalloc_check(&ra, AA)) { + def->bytecode[i] = JOP_NOOP; + } + } + break; + } + } + + janetc_regalloc_deinit(&ra); +#undef AA +#undef BB +#undef CC +#undef DD +#undef EE +} + /* Verify some bytecode */ int janet_verify(JanetFuncDef *def) { int vargs = !!(def->flags & JANET_FUNCDEF_FLAG_VARARG); diff --git a/src/core/compile.c b/src/core/compile.c index 656cdd3d..29a57273 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -989,6 +989,10 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { /* Pop the scope */ janetc_popscope(c); + /* Do basic optimization */ + janet_bytecode_movopt(def); + janet_bytecode_remove_noops(def); + return def; } diff --git a/src/core/compile.h b/src/core/compile.h index 39dfa8a8..5863c0b8 100644 --- a/src/core/compile.h +++ b/src/core/compile.h @@ -267,4 +267,8 @@ JanetSlot janetc_cslot(Janet x); /* Search for a symbol */ JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym); +/* Bytecode optimization */ +void janet_bytecode_movopt(JanetFuncDef *def); +void janet_bytecode_remove_noops(JanetFuncDef *def); + #endif diff --git a/src/core/regalloc.c b/src/core/regalloc.c index 1b8b7071..5df2a242 100644 --- a/src/core/regalloc.c +++ b/src/core/regalloc.c @@ -27,6 +27,8 @@ #include "util.h" #endif +/* The JanetRegisterAllocator is really just a bitset. */ + void janetc_regalloc_init(JanetcRegisterAllocator *ra) { ra->chunks = NULL; ra->count = 0; @@ -139,6 +141,14 @@ void janetc_regalloc_free(JanetcRegisterAllocator *ra, int32_t reg) { ra->chunks[chunk] &= ~ithbit(bit); } +/* Check if a register is set. */ +int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg) { + int32_t chunk = reg >> 5; + int32_t bit = reg & 0x1F; + while (chunk >= ra->count) pushchunk(ra); + return !!(ra->chunks[chunk] & ithbit(bit)); +} + /* Get a register that will fit in 8 bits (< 256). Do not call this * twice with the same value of nth without calling janetc_regalloc_free * on the returned register before. */ diff --git a/src/core/regalloc.h b/src/core/regalloc.h index b7521a52..c02e4757 100644 --- a/src/core/regalloc.h +++ b/src/core/regalloc.h @@ -56,5 +56,6 @@ int32_t janetc_regalloc_temp(JanetcRegisterAllocator *ra, JanetcRegisterTemp nth void janetc_regalloc_freetemp(JanetcRegisterAllocator *ra, int32_t reg, JanetcRegisterTemp nth); void janetc_regalloc_clone(JanetcRegisterAllocator *dest, JanetcRegisterAllocator *src); void janetc_regalloc_touch(JanetcRegisterAllocator *ra, int32_t reg); +int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg); #endif diff --git a/src/core/specials.c b/src/core/specials.c index c186245f..30977416 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -354,7 +354,17 @@ static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, Janet int isUnnamedRegister = !(ret.flags & JANET_SLOT_NAMED) && ret.index > 0 && ret.envindex >= 0; - if (!isUnnamedRegister) { + /* optimization for `(def x my-def)` - don't emit a movn/movf instruction, we can just alias my-def */ + /* TODO - implement optimization for `(def x my-var)` correctly as well w/ de-aliasing */ + int canAlias = !(flags & JANET_SLOT_MUTABLE) && + !(ret.flags & JANET_SLOT_MUTABLE) && + (ret.flags & JANET_SLOT_NAMED) && + (ret.index >= 0) && + (ret.envindex == -1); + if (canAlias) { + ret.flags &= ~JANET_SLOT_MUTABLE; + isUnnamedRegister = 1; /* don't free slot after use - is an alias for another slot */ + } else if (!isUnnamedRegister) { /* Slot is not able to be named */ JanetSlot localslot = janetc_farslot(c); janetc_copy(c, localslot, ret); diff --git a/test/suite0015.janet b/test/suite0015.janet index b747389a..bb00a9b6 100644 --- a/test/suite0015.janet +++ b/test/suite0015.janet @@ -4,7 +4,7 @@ (start-suite 15) (assert (deep= (in (disasm (defn a [] (def x 10) x)) :symbolmap) - @[[0 3 0 'a] [1 3 1 'x]]) + @[[0 2 0 'a] [0 2 1 'x]]) "symbolslots when *debug* is true") (defn a [arg] @@ -33,11 +33,11 @@ (def y 20) (def z 30) (+ x y z)))) :symbolmap) - @[[0 7 0 'arg] - [0 7 1 'a] - [1 7 2 'x] - [2 7 3 'y] - [3 7 4 'z]]) + @[[0 6 0 'arg] + [0 6 1 'a] + [0 6 2 'x] + [1 6 3 'y] + [2 6 4 'z]]) "arg & inner symbolslots") # buffer/push-at @@ -45,4 +45,6 @@ (assert (deep= @"abc456789" (buffer/push-at @"abc123" 3 "456789")) "buffer/push-at 2") (assert (deep= @"abc423" (buffer/push-at @"abc123" 3 "4")) "buffer/push-at 3") +(assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing") + (end-suite) From fcca9bbab3d64ed51259745dec2dfaffcc20c3d1 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 29 May 2023 18:05:14 -0500 Subject: [PATCH 062/138] Add recursion to the pruning optimization. --- src/core/bytecode.c | 345 +++++++++++++++++++++++--------------------- 1 file changed, 177 insertions(+), 168 deletions(-) diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 185bccab..122d050f 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -177,18 +177,22 @@ void janet_bytecode_remove_noops(JanetFuncDef *def) { * noops. Input is assumed valid bytecode. */ void janet_bytecode_movopt(JanetFuncDef *def) { JanetcRegisterAllocator ra; - janetc_regalloc_init(&ra); + int recur = 1; - /* Look for slots that have writes but no reads (and aren't in the closure bitset). */ - if (def->closure_bitset != NULL) { - for (int32_t i = 0; i < def->slotcount; i++) { - int32_t index = i >> 5; - uint32_t mask = 1U << (((uint32_t) i) & 31); - if (def->closure_bitset[index] & mask) { - janetc_regalloc_touch(&ra, i); + /* Iterate this until no more instructions can be removed. */ + while (recur) { + janetc_regalloc_init(&ra); + + /* Look for slots that have writes but no reads (and aren't in the closure bitset). */ + if (def->closure_bitset != NULL) { + for (int32_t i = 0; i < def->slotcount; i++) { + int32_t index = i >> 5; + uint32_t mask = 1U << (((uint32_t) i) & 31); + if (def->closure_bitset[index] & mask) { + janetc_regalloc_touch(&ra, i); + } } } - } #define AA ((instr >> 8) & 0xFF) #define BB ((instr >> 16) & 0xFF) @@ -196,188 +200,193 @@ void janet_bytecode_movopt(JanetFuncDef *def) { #define DD (instr >> 8) #define EE (instr >> 16) - /* Check reads and writes */ - for (int32_t i = 0; i < def->bytecode_length; i++) { - uint32_t instr = def->bytecode[i]; - switch (instr & 0x7F) { + /* Check reads and writes */ + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + switch (instr & 0x7F) { - /* Group instructions my how they read from slots */ + /* Group instructions my how they read from slots */ - /* No reads or writes */ - default: - janet_assert(0, "unhandled instruction"); - case JOP_JUMP: - case JOP_NOOP: - case JOP_RETURN_NIL: - /* Write A */ - case JOP_LOAD_INTEGER: - case JOP_LOAD_CONSTANT: - case JOP_LOAD_UPVALUE: - case JOP_CLOSURE: - /* Write D */ - case JOP_LOAD_NIL: - case JOP_LOAD_TRUE: - case JOP_LOAD_FALSE: - case JOP_LOAD_SELF: - case JOP_MAKE_ARRAY: - case JOP_MAKE_BUFFER: - case JOP_MAKE_STRING: - case JOP_MAKE_STRUCT: - case JOP_MAKE_TABLE: - case JOP_MAKE_TUPLE: - case JOP_MAKE_BRACKET_TUPLE: - break; + /* No reads or writes */ + default: + janet_assert(0, "unhandled instruction"); + case JOP_JUMP: + case JOP_NOOP: + case JOP_RETURN_NIL: + /* Write A */ + case JOP_LOAD_INTEGER: + case JOP_LOAD_CONSTANT: + case JOP_LOAD_UPVALUE: + case JOP_CLOSURE: + /* Write D */ + case JOP_LOAD_NIL: + case JOP_LOAD_TRUE: + case JOP_LOAD_FALSE: + case JOP_LOAD_SELF: + case JOP_MAKE_ARRAY: + case JOP_MAKE_BUFFER: + case JOP_MAKE_STRING: + case JOP_MAKE_STRUCT: + case JOP_MAKE_TABLE: + case JOP_MAKE_TUPLE: + case JOP_MAKE_BRACKET_TUPLE: + break; - /* Read A */ - case JOP_ERROR: - case JOP_TYPECHECK: - case JOP_JUMP_IF: - case JOP_JUMP_IF_NOT: - case JOP_JUMP_IF_NIL: - case JOP_JUMP_IF_NOT_NIL: - case JOP_SET_UPVALUE: - /* Write E, Read A */ - case JOP_MOVE_FAR: - janetc_regalloc_touch(&ra, AA); - break; + /* Read A */ + case JOP_ERROR: + case JOP_TYPECHECK: + case JOP_JUMP_IF: + case JOP_JUMP_IF_NOT: + case JOP_JUMP_IF_NIL: + case JOP_JUMP_IF_NOT_NIL: + case JOP_SET_UPVALUE: + /* Write E, Read A */ + case JOP_MOVE_FAR: + janetc_regalloc_touch(&ra, AA); + break; - /* Read B */ - case JOP_SIGNAL: - /* Write A, Read B */ - case JOP_ADD_IMMEDIATE: - case JOP_MULTIPLY_IMMEDIATE: - case JOP_DIVIDE_IMMEDIATE: - case JOP_SHIFT_LEFT_IMMEDIATE: - case JOP_SHIFT_RIGHT_IMMEDIATE: - case JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE: - case JOP_GREATER_THAN_IMMEDIATE: - case JOP_LESS_THAN_IMMEDIATE: - case JOP_EQUALS_IMMEDIATE: - case JOP_NOT_EQUALS_IMMEDIATE: - case JOP_GET_INDEX: - janetc_regalloc_touch(&ra, BB); - break; + /* Read B */ + case JOP_SIGNAL: + /* Write A, Read B */ + case JOP_ADD_IMMEDIATE: + case JOP_MULTIPLY_IMMEDIATE: + case JOP_DIVIDE_IMMEDIATE: + case JOP_SHIFT_LEFT_IMMEDIATE: + case JOP_SHIFT_RIGHT_IMMEDIATE: + case JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE: + case JOP_GREATER_THAN_IMMEDIATE: + case JOP_LESS_THAN_IMMEDIATE: + case JOP_EQUALS_IMMEDIATE: + case JOP_NOT_EQUALS_IMMEDIATE: + case JOP_GET_INDEX: + janetc_regalloc_touch(&ra, BB); + break; - /* Read D */ - case JOP_RETURN: - case JOP_PUSH: - case JOP_PUSH_ARRAY: - case JOP_TAILCALL: - janetc_regalloc_touch(&ra, DD); - break; + /* Read D */ + case JOP_RETURN: + case JOP_PUSH: + case JOP_PUSH_ARRAY: + case JOP_TAILCALL: + janetc_regalloc_touch(&ra, DD); + break; - /* Write A, Read E */ - case JOP_MOVE_NEAR: - case JOP_LENGTH: - case JOP_BNOT: - case JOP_CALL: - janetc_regalloc_touch(&ra, EE); - break; + /* Write A, Read E */ + case JOP_MOVE_NEAR: + case JOP_LENGTH: + case JOP_BNOT: + case JOP_CALL: + janetc_regalloc_touch(&ra, EE); + break; - /* Read A, B */ - case JOP_PUT_INDEX: - janetc_regalloc_touch(&ra, AA); - janetc_regalloc_touch(&ra, BB); - break; + /* Read A, B */ + case JOP_PUT_INDEX: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, BB); + break; - /* Read A, E */ - case JOP_PUSH_2: - janetc_regalloc_touch(&ra, AA); - janetc_regalloc_touch(&ra, EE); - break; + /* Read A, E */ + case JOP_PUSH_2: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, EE); + break; - /* Read B, C */ - case JOP_PROPAGATE: - /* Write A, Read B and C */ - case JOP_BAND: - case JOP_BOR: - case JOP_BXOR: - case JOP_ADD: - case JOP_SUBTRACT: - case JOP_MULTIPLY: - case JOP_DIVIDE: - case JOP_MODULO: - case JOP_REMAINDER: - case JOP_SHIFT_LEFT: - case JOP_SHIFT_RIGHT: - case JOP_SHIFT_RIGHT_UNSIGNED: - case JOP_GREATER_THAN: - case JOP_LESS_THAN: - case JOP_EQUALS: - case JOP_COMPARE: - case JOP_IN: - case JOP_GET: - case JOP_GREATER_THAN_EQUAL: - case JOP_LESS_THAN_EQUAL: - case JOP_NOT_EQUALS: - case JOP_CANCEL: - case JOP_RESUME: - case JOP_NEXT: - janetc_regalloc_touch(&ra, BB); - janetc_regalloc_touch(&ra, CC); - break; + /* Read B, C */ + case JOP_PROPAGATE: + /* Write A, Read B and C */ + case JOP_BAND: + case JOP_BOR: + case JOP_BXOR: + case JOP_ADD: + case JOP_SUBTRACT: + case JOP_MULTIPLY: + case JOP_DIVIDE: + case JOP_MODULO: + case JOP_REMAINDER: + case JOP_SHIFT_LEFT: + case JOP_SHIFT_RIGHT: + case JOP_SHIFT_RIGHT_UNSIGNED: + case JOP_GREATER_THAN: + case JOP_LESS_THAN: + case JOP_EQUALS: + case JOP_COMPARE: + case JOP_IN: + case JOP_GET: + case JOP_GREATER_THAN_EQUAL: + case JOP_LESS_THAN_EQUAL: + case JOP_NOT_EQUALS: + case JOP_CANCEL: + case JOP_RESUME: + case JOP_NEXT: + janetc_regalloc_touch(&ra, BB); + janetc_regalloc_touch(&ra, CC); + break; - /* Read A, B, C */ - case JOP_PUT: - case JOP_PUSH_3: - janetc_regalloc_touch(&ra, AA); - janetc_regalloc_touch(&ra, BB); - janetc_regalloc_touch(&ra, CC); - break; + /* Read A, B, C */ + case JOP_PUT: + case JOP_PUSH_3: + janetc_regalloc_touch(&ra, AA); + janetc_regalloc_touch(&ra, BB); + janetc_regalloc_touch(&ra, CC); + break; + } } - } - /* Iterate and set noops on instructions that make writes that no one ever reads. - * Only set noops for instructions with no side effects - moves, loads, etc. that can't - * raise errors (outside of systemic errors like oom or stack overflow). */ - for (int32_t i = 0; i < def->bytecode_length; i++) { - uint32_t instr = def->bytecode[i]; - switch (instr & 0x7F) { - default: + /* Iterate and set noops on instructions that make writes that no one ever reads. + * Only set noops for instructions with no side effects - moves, loads, etc. that can't + * raise errors (outside of systemic errors like oom or stack overflow). */ + recur = 0; + for (int32_t i = 0; i < def->bytecode_length; i++) { + uint32_t instr = def->bytecode[i]; + switch (instr & 0x7F) { + default: + break; + /* Write D */ + case JOP_LOAD_NIL: + case JOP_LOAD_TRUE: + case JOP_LOAD_FALSE: + case JOP_LOAD_SELF: + case JOP_MAKE_ARRAY: + case JOP_MAKE_TUPLE: + case JOP_MAKE_BRACKET_TUPLE: { + if (!janetc_regalloc_check(&ra, DD)) { + def->bytecode[i] = JOP_NOOP; + recur = 1; + } + } break; - /* Write D */ - case JOP_LOAD_NIL: - case JOP_LOAD_TRUE: - case JOP_LOAD_FALSE: - case JOP_LOAD_SELF: - case JOP_MAKE_ARRAY: - case JOP_MAKE_TUPLE: - case JOP_MAKE_BRACKET_TUPLE: { - if (!janetc_regalloc_check(&ra, DD)) { - def->bytecode[i] = JOP_NOOP; + /* Write E, Read A */ + case JOP_MOVE_FAR: { + if (!janetc_regalloc_check(&ra, EE)) { + def->bytecode[i] = JOP_NOOP; + recur = 1; + } } - } - break; - /* Write E, Read A */ - case JOP_MOVE_FAR: { - if (!janetc_regalloc_check(&ra, EE)) { - def->bytecode[i] = JOP_NOOP; + break; + /* Write A, Read E */ + case JOP_MOVE_NEAR: + /* Write A, Read B */ + case JOP_GET_INDEX: + /* Write A */ + case JOP_LOAD_INTEGER: + case JOP_LOAD_CONSTANT: + case JOP_LOAD_UPVALUE: + case JOP_CLOSURE: { + if (!janetc_regalloc_check(&ra, AA)) { + def->bytecode[i] = JOP_NOOP; + recur = 1; + } } + break; } - break; - /* Write A, Read E */ - case JOP_MOVE_NEAR: - /* Write A, Read B */ - case JOP_GET_INDEX: - /* Write A */ - case JOP_LOAD_INTEGER: - case JOP_LOAD_CONSTANT: - case JOP_LOAD_UPVALUE: - case JOP_CLOSURE: { - if (!janetc_regalloc_check(&ra, AA)) { - def->bytecode[i] = JOP_NOOP; - } - } - break; } - } - janetc_regalloc_deinit(&ra); + janetc_regalloc_deinit(&ra); #undef AA #undef BB #undef CC #undef DD #undef EE + } } /* Verify some bytecode */ From 7acb5c63e059d566e5c67262d108f1e604152654 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 29 May 2023 18:17:22 -0500 Subject: [PATCH 063/138] Remove bad windows10 check. --- src/mainclient/shell.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/mainclient/shell.c b/src/mainclient/shell.c index 06f61219..3c1b13fc 100644 --- a/src/mainclient/shell.c +++ b/src/mainclient/shell.c @@ -30,7 +30,6 @@ #ifdef _WIN32 #include #include -#include #ifndef ENABLE_VIRTUAL_TERMINAL_PROCESSING #define ENABLE_VIRTUAL_TERMINAL_PROCESSING 0x0004 #endif @@ -147,9 +146,8 @@ static void setup_console_output(void) { HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE); DWORD dwMode = 0; GetConsoleMode(hOut, &dwMode); - if (IsWindows10OrGreater()) { - dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING; - } + dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING; + dwMode |= ENABLE_PROCESSED_OUTPUT; SetConsoleMode(hOut, dwMode); if (IsValidCodePage(65001)) { SetConsoleOutputCP(65001); @@ -165,10 +163,8 @@ static int rawmode(void) { dwMode &= ~ENABLE_LINE_INPUT; dwMode &= ~ENABLE_INSERT_MODE; dwMode &= ~ENABLE_ECHO_INPUT; - if (IsWindows10OrGreater()) { - dwMode |= ENABLE_VIRTUAL_TERMINAL_INPUT; - dwMode &= ~ENABLE_PROCESSED_INPUT; - } + dwMode |= ENABLE_VIRTUAL_TERMINAL_INPUT; + dwMode &= ~ENABLE_PROCESSED_INPUT; if (!SetConsoleMode(hOut, dwMode)) return 1; gbl_israwmode = 1; return 0; @@ -183,10 +179,8 @@ static void norawmode(void) { dwMode |= ENABLE_LINE_INPUT; dwMode |= ENABLE_INSERT_MODE; dwMode |= ENABLE_ECHO_INPUT; - if (IsWindows10OrGreater()) { - dwMode &= ~ENABLE_VIRTUAL_TERMINAL_INPUT; - dwMode |= ENABLE_PROCESSED_INPUT; - } + dwMode &= ~ENABLE_VIRTUAL_TERMINAL_INPUT; + dwMode |= ENABLE_PROCESSED_INPUT; SetConsoleMode(hOut, dwMode); gbl_israwmode = 0; } From 40080b23aee54f8cd0275644ae0fc7c317a1579d Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Tue, 30 May 2023 16:57:17 +0200 Subject: [PATCH 064/138] Fixed net/connect binding address --- src/core/net.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/net.c b/src/core/net.c index 37d4b486..273eee36 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -460,7 +460,7 @@ JANET_CORE_FN(cfun_net_connect, if (binding) { struct addrinfo *rp = NULL; int did_bind = 0; - for (rp = ai; rp != NULL; rp = rp->ai_next) { + for (rp = binding; rp != NULL; rp = rp->ai_next) { if (bind(sock, rp->ai_addr, (int) rp->ai_addrlen) == 0) { did_bind = 1; break; From ad7bf806116fd98dad4bfd2fabfe4f918fe3f4db Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Tue, 30 May 2023 19:33:34 +0200 Subject: [PATCH 065/138] fix for crash on windows in src/core/ev.c: initialze state->fromlen before doing WSARecvFrom() to prevent crash (likely caused by the memcpy() of `state->from` at line 2301 with the memcpy length set to -1) --- src/core/ev.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core/ev.c b/src/core/ev.c index a7056b9c..f9e830b6 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -2320,6 +2320,7 @@ JanetAsyncStatus ev_machine_read(JanetListenerState *s, JanetAsyncEvent event) { if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { state->wbuf.len = (ULONG) chunk_size; state->wbuf.buf = (char *) state->chunk_buf; + state->fromlen = sizeof(state->from); status = WSARecvFrom((SOCKET) s->stream->handle, &state->wbuf, 1, NULL, &state->flags, &state->from, &state->fromlen, &state->overlapped, NULL); if (status && (WSA_IO_PENDING != WSAGetLastError())) { From 77189b6e66193cc03b824413cfcf65a1c20bb53d Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 31 May 2023 08:19:24 -0500 Subject: [PATCH 066/138] Fix some symbol mapping inside nested functions. --- src/core/bytecode.c | 1 + src/core/compile.c | 11 ++++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 122d050f..34383aa7 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -170,6 +170,7 @@ void janet_bytecode_remove_noops(JanetFuncDef *def) { } def->bytecode_length = new_bytecode_length; + def->bytecode = janet_realloc(def->bytecode, def->bytecode_length * sizeof(uint32_t)); janet_sfree(pc_map); } diff --git a/src/core/compile.c b/src/core/compile.c index 29a57273..a1a7db8c 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -971,12 +971,13 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { for (int32_t i = 0; i < janet_v_count(scope->syms); i++) { SymPair pair = scope->syms[i]; if (pair.sym2) { - if (pair.death_pc == UINT32_MAX) { - pair.death_pc = def->bytecode_length; - } JanetSymbolMap jsm; - jsm.birth_pc = pair.birth_pc; - jsm.death_pc = pair.death_pc; + if (pair.death_pc == UINT32_MAX) { + jsm.death_pc = def->bytecode_length; + } else { + jsm.death_pc = pair.death_pc - scope->bytecode_start; + } + jsm.birth_pc = pair.birth_pc - scope->bytecode_start; jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); From 644ac8caf8e8a1fa5b91d1827769c99d8009d37a Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 31 May 2023 12:26:27 -0500 Subject: [PATCH 067/138] Add compiler optimizations for #1163 - eachp Should result in much better bytecode in the simple case. --- src/boot/boot.janet | 2 +- src/core/specials.c | 101 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 81 insertions(+), 22 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 1d2a2b31..87953502 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -445,7 +445,7 @@ ,(case kind :each ~(,in ,ds ,k) :keys k - :pairs ~(,tuple ,k (,in ,ds ,k)))) + :pairs ~[,k (,in ,ds ,k)])) ,;body (set ,k (,next ,ds ,k)))))) diff --git a/src/core/specials.c b/src/core/specials.c index 30977416..d2a08909 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -306,12 +306,16 @@ static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) } /* Add attributes to a global def or var table */ -static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv) { +static JanetTable *handleattr(JanetCompiler *c, const char *kind, int32_t argn, const Janet *argv) { int32_t i; JanetTable *tab = janet_table(2); const char *binding_name = janet_type(argv[0]) == JANET_SYMBOL ? ((const char *)janet_unwrap_symbol(argv[0])) : ""; + if (argn < 2) { + janetc_error(c, janet_formatc("expected at least 2 arguments to %s", kind)); + return NULL; + } for (i = 1; i < argn - 1; i++) { Janet attr = argv[i]; switch (janet_type(attr)) { @@ -335,18 +339,51 @@ static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv) return tab; } -static JanetSlot dohead(const char *kind, JanetCompiler *c, JanetFopts opts, Janet *head, int32_t argn, const Janet *argv) { +typedef struct SlotHeadPair { + Janet lhs; + JanetSlot rhs; +} SlotHeadPair; + +SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopts opts, Janet lhs, Janet rhs) { + + /* Detect if we can do an optimization to avoid some allocations */ + int can_destructure_lhs = janet_checktype(lhs, JANET_TUPLE) + || janet_checktype(lhs, JANET_ARRAY); + int rhs_is_indexed = janet_checktype(rhs, JANET_ARRAY) + || (janet_checktype(rhs, JANET_TUPLE) && (janet_tuple_flag(janet_unwrap_tuple(rhs)) & JANET_TUPLE_FLAG_BRACKETCTOR)); + uint32_t has_drop = opts.flags & JANET_FOPTS_DROP; + JanetFopts subopts = janetc_fopts_default(c); - JanetSlot ret; - if (argn < 2) { - janetc_error(c, janet_formatc("expected at least 2 arguments to %s", kind)); - return janetc_cslot(janet_wrap_nil()); - } - *head = argv[0]; subopts.flags = opts.flags & ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP); + + if (has_drop && can_destructure_lhs && rhs_is_indexed) { + /* Code is of the form (def [a b] [1 2]), avoid the allocation of two tuples */ + JanetView view_lhs, view_rhs; + janet_indexed_view(lhs, &view_lhs.items, &view_lhs.len); + janet_indexed_view(rhs, &view_rhs.items, &view_rhs.len); + int found_amp = 0; + for (int32_t i = 0; i < view_lhs.len; i++) { + if (janet_symeq(view_lhs.items[i], "&")) { + found_amp = 1; + /* Good error will be generated later. */ + break; + } + } + if (!found_amp) { + for (int32_t i = 0; i < view_lhs.len; i++) { + Janet sub_rhs = view_rhs.len <= i ? janet_wrap_nil() : view_rhs.items[i]; + into = dohead_destructure(c, into, subopts, view_lhs.items[i], sub_rhs); + } + return into; + } + } + + /* No optimization, do the simple way */ subopts.hint = opts.hint; - ret = janetc_value(subopts, argv[argn - 1]); - return ret; + JanetSlot ret = janetc_value(subopts, rhs); + SlotHeadPair shp = {lhs, ret}; + janet_v_push(into, shp); + return into; } /* Def or var a symbol in a local scope */ @@ -412,12 +449,23 @@ static int varleaf( static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; - Janet head; - JanetTable *attr_table = handleattr(c, argn, argv); - JanetSlot ret = dohead("var", c, opts, &head, argn, argv); - if (c->result.status == JANET_COMPILE_ERROR) + JanetTable *attr_table = handleattr(c, "var", argn, argv); + if (c->result.status == JANET_COMPILE_ERROR) { return janetc_cslot(janet_wrap_nil()); - destructure(c, argv[0], ret, varleaf, attr_table); + } + SlotHeadPair *into = NULL; + into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]); + if (c->result.status == JANET_COMPILE_ERROR) { + janet_v_free(into); + return janetc_cslot(janet_wrap_nil()); + } + JanetSlot ret; + janet_assert(janet_v_count(into) > 0, "bad destructure"); + for (int32_t i = 0; i < janet_v_count(into); i++) { + destructure(c, into[i].lhs, into[i].rhs, varleaf, attr_table); + ret = into[i].rhs; + } + janet_v_free(into); return ret; } @@ -461,13 +509,24 @@ static int defleaf( static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; - Janet head; - opts.flags &= ~JANET_FOPTS_HINT; - JanetTable *attr_table = handleattr(c, argn, argv); - JanetSlot ret = dohead("def", c, opts, &head, argn, argv); - if (c->result.status == JANET_COMPILE_ERROR) + JanetTable *attr_table = handleattr(c, "def", argn, argv); + if (c->result.status == JANET_COMPILE_ERROR) { return janetc_cslot(janet_wrap_nil()); - destructure(c, argv[0], ret, defleaf, attr_table); + } + opts.flags &= ~JANET_FOPTS_HINT; + SlotHeadPair *into = NULL; + into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]); + if (c->result.status == JANET_COMPILE_ERROR) { + janet_v_free(into); + return janetc_cslot(janet_wrap_nil()); + } + JanetSlot ret; + janet_assert(janet_v_count(into) > 0, "bad destructure"); + for (int32_t i = 0; i < janet_v_count(into); i++) { + destructure(c, into[i].lhs, into[i].rhs, defleaf, attr_table); + ret = into[i].rhs; + } + janet_v_free(into); return ret; } From 14e33c295fc6edbabc1f63f945b08af0574ea7d4 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 31 May 2023 22:21:12 -0500 Subject: [PATCH 068/138] Make clock tests less fragile for CI. --- test/suite0007.janet | 29 ++++++----------------------- 1 file changed, 6 insertions(+), 23 deletions(-) diff --git a/test/suite0007.janet b/test/suite0007.janet index e59b049c..e6085cf2 100644 --- a/test/suite0007.janet +++ b/test/suite0007.janet @@ -333,29 +333,12 @@ (assert (pos? (length (gensym))) "gensym not empty, regression #753") +(assert-no-error (os/clock :realtime) "realtime clock") +(assert-no-error (os/clock :cputime) "cputime clock") +(assert-no-error (os/clock :monotonic) "monotonic clock") -# os/clock. These tests might prove fragile under CI because they -# rely on measured time. We'll see. - -(defmacro measure-time [clocks & body] - (def [t1 t2] [(gensym) (gensym)]) - ~(do - (def ,t1 (map |(os/clock $) ,clocks)) - ,;body - (def ,t2 (map |(os/clock $) ,clocks)) - (zipcoll ,clocks (map |(- ;$) (map tuple ,t2 ,t1)))) -) - -# Spin for 0.1 seconds -(def dt (measure-time [:realtime :monotonic :cputime] - (def t1 (os/clock :monotonic)) - (while (< (- (os/clock :monotonic) t1) 0.1) true))) -(assert (> (dt :monotonic) 0.10)) -(assert (> (dt :cputime) 0.05)) - -# Sleep for 0.1 seconds -(def dt (measure-time [:realtime :monotonic :cputime] (os/sleep 0.1))) -(assert (> (dt :monotonic) 0.10)) -(assert (< (dt :cputime) 0.05)) +(def before (os/clock :monotonic)) +(def after (os/clock :monotonic)) +(assert (>= after before) "monotonic clock is monotonic") (end-suite) From 5de889419ff26b710b706958bf99e180d084f564 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 31 May 2023 22:35:14 -0500 Subject: [PATCH 069/138] Rename contains? and contains-key? to has-value? and has-key? Shorten docstrings to be less like a tutorial. They get put into RAM and memory ain't free. --- src/boot/boot.janet | 46 +++++--------------------- test/suite0010.janet | 78 ++++++++++++++++++++++---------------------- 2 files changed, 47 insertions(+), 77 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 007afadb..0004f954 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1197,45 +1197,15 @@ ~(def ,alias :dyn ,;more ,kw)) -(defn contains-key? - ```Checks if a collection contains the specified key. - - Semantically equivalent to `(not (nil? (get collection key)))`. - - Arrays, tuples, and buffer types (string, buffer, keyword, symbol) are all indexed by integer keys. - For those types, this function simply checks if the index is less than the length. - - If this function succeeds, then a call to `(in collection key)` is guarenteed - to succeed as well. - - Note that tables or structs (dictionaries) never contain null keys``` - [collection key] - (not (nil? (get collection key)))) - -(defn contains? - ```Checks if a collection contains the specified value. - - This supports any iterable type by way of the `next` function. - This includes buffers, dictionaries, arrays, fibers, and possibly abstract types. - - For tables and structs, this checks the values, not the keys. - For arrays, tuples (and any other iterable type), this simply checks if any of the values are equal. - - For buffer types (strings, buffers, keywords), this checks if the specified byte is present. - This is because, buffer types (strings, keywords, symbols) are simply sequences, with byte values. - This means they will also work with `next` and `index-of`. - - However, it also means this function will not check for substrings, only integer bytes (which could be unexpected). - In other words is `(contains? "foo bar" "foo")` is always false, because "foo" is not an integer byte - If you want to check for a substring in a buffer, then use `(truthy? (string/find substr buffer))`, - or just `(if (string/find substr buffer) then else)` - - In general this function has O(n) performance, since it requires iterating over all the values. - - Note that tables or structs (dictionaries) never contain null values``` - [collection val] - (not (nil? (index-of val collection)))) +(defn has-key? + "Check if a data structure `ds` contains the key `key`." + [ds key] + (not= nil (get ds key))) +(defn has-value? + "Check if a data structure `ds` contains the value `value`. Will run in time proportional to the size of `ds`." + [ds value] + (not= nil (index-of value ds))) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. Use this to prevent keyword collisions between dynamic bindings.``) diff --git a/test/suite0010.janet b/test/suite0010.janet index d8cbe3f8..d17ecdd9 100644 --- a/test/suite0010.janet +++ b/test/suite0010.janet @@ -33,7 +33,7 @@ (assert (= nil (index-of (chr "a") "")) "index-of 9") (assert (= nil (index-of 10 @[])) "index-of 10") (assert (= nil (index-of 10 @[1 2 3])) "index-of 11") -# NOTE: These is a motivation for the contains? and contains-key? functions below +# NOTE: These is a motivation for the has-value? and has-key? functions below # returns false despite key present (assert (= false (index-of 8 {true 7 false 8})) "index-of corner key (false) 1") @@ -41,36 +41,36 @@ # still returns null (assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") -# contains? -(assert (= false (contains? [] "foo")) "contains? 1") -(assert (= true (contains? [4 7 1 3] 4)) "contains? 2") -(assert (= false (contains? [4 7 1 3] 22)) "contains? 3") -(assert (= false (contains? @[1 2 3] 4)) "contains? 4") -(assert (= true (contains? @[:a :b :c] :a)) "contains? 5") -(assert (= false (contains? {} :foo)) "contains? 6") -(assert (= true (contains? {:a :A :b :B} :A)) "contains? 7") -(assert (= true (contains? {:a :A :b :B} :A)) "contains? 7") -(assert (= true (contains? @{:a :A :b :B} :A)) "contains? 8") -(assert (= true (contains? "abc" (chr "a"))) "contains? 9") -(assert (= false (contains? "abc" "1")) "contains? 10") +# has-value? +(assert (= false (has-value? [] "foo")) "has-value? 1") +(assert (= true (has-value? [4 7 1 3] 4)) "has-value? 2") +(assert (= false (has-value? [4 7 1 3] 22)) "has-value? 3") +(assert (= false (has-value? @[1 2 3] 4)) "has-value? 4") +(assert (= true (has-value? @[:a :b :c] :a)) "has-value? 5") +(assert (= false (has-value? {} :foo)) "has-value? 6") +(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") +(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") +(assert (= true (has-value? @{:a :A :b :B} :A)) "has-value? 8") +(assert (= true (has-value? "abc" (chr "a"))) "has-value? 9") +(assert (= false (has-value? "abc" "1")) "has-value? 10") # weird true/false corner cases, should align with "index-of corner key {k}" cases -(assert (= true (contains? {true 7 false 8} 8)) "contains? corner key (false) 1") -(assert (= true (contains? @{false 8} 8)) "contains? corner key (false) 2") -(assert (= false (contains? {false 8} 7)) "contains? corner key (false) 3") +(assert (= true (has-value? {true 7 false 8} 8)) "has-value? corner key (false) 1") +(assert (= true (has-value? @{false 8} 8)) "has-value? corner key (false) 2") +(assert (= false (has-value? {false 8} 7)) "has-value? corner key (false) 3") -# contains-key? +# has-key? (do - (var test-contains-key-auto 0) - (defn test-contains-key [col key expected &keys {:name name}] - ``Test that contains-key has the outcome `expected`, and that if + (var test-has-key-auto 0) + (defn test-has-key [col key expected &keys {:name name}] + ``Test that has-key has the outcome `expected`, and that if the result is true, then ensure (in key) does not fail either`` (assert (boolean? expected)) - (default name (string "contains-key? " (++ test-contains-key-auto))) - (assert (= expected (contains-key? col key)) name) + (default name (string "has-key? " (++ test-has-key-auto))) + (assert (= expected (has-key? col key)) name) (if - # guarenteed by `contains-key?` to never fail + # guarenteed by `has-key?` to never fail expected (in col key) - # if `contains-key?` is false, then `in` should fail (for indexed types) + # if `has-key?` is false, then `in` should fail (for indexed types) # # For dictionary types, it should return nil (let [[success retval] (protect (in col key))] @@ -81,26 +81,26 @@ "%s: expected (in col key) to %s, but got %q" name (if expected "succeed" "fail") retval))))) - (test-contains-key [] 0 false) # 1 - (test-contains-key [4 7 1 3] 2 true) # 2 - (test-contains-key [4 7 1 3] 22 false) # 3 - (test-contains-key @[1 2 3] 4 false) # 4 - (test-contains-key @[:a :b :c] 2 true) # 5 - (test-contains-key {} :foo false) # 6 - (test-contains-key {:a :A :b :B} :a true) # 7 - (test-contains-key {:a :A :b :B} :A false) # 8 - (test-contains-key @{:a :A :b :B} :a true) # 9 - (test-contains-key "abc" 1 true) # 10 - (test-contains-key "abc" 4 false) # 11 + (test-has-key [] 0 false) # 1 + (test-has-key [4 7 1 3] 2 true) # 2 + (test-has-key [4 7 1 3] 22 false) # 3 + (test-has-key @[1 2 3] 4 false) # 4 + (test-has-key @[:a :b :c] 2 true) # 5 + (test-has-key {} :foo false) # 6 + (test-has-key {:a :A :b :B} :a true) # 7 + (test-has-key {:a :A :b :B} :A false) # 8 + (test-has-key @{:a :A :b :B} :a true) # 9 + (test-has-key "abc" 1 true) # 10 + (test-has-key "abc" 4 false) # 11 # weird true/false corner cases # - # Tries to mimic the corresponding corner cases in contains? and index-of, + # Tries to mimic the corresponding corner cases in has-value? and index-of, # but with keys/values inverted # # in the first two cases (truthy? (get val col)) would have given false negatives - (test-contains-key {7 true 8 false} 8 true :name "contains-key? corner value (false) 1") - (test-contains-key @{8 false} 8 true :name "contains-key? corner value (false) 2") - (test-contains-key @{8 false} 7 false :name "contains-key? corner value (false) 3")) + (test-has-key {7 true 8 false} 8 true :name "has-key? corner value (false) 1") + (test-has-key @{8 false} 8 true :name "has-key? corner value (false) 2") + (test-has-key @{8 false} 7 false :name "has-key? corner value (false) 3")) # Regression (assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463") From d0aa7ef5909c70f04918659fceabcc45d93f0e0d Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 1 Jun 2023 10:52:34 -0500 Subject: [PATCH 070/138] Add a few asserts to quiet some of the -fanalyze calls in gcc 13. --- src/core/debug.c | 1 + src/core/fiber.c | 5 ++++- src/core/pp.c | 2 +- src/core/specials.c | 1 + src/core/symcache.c | 1 + src/core/util.c | 6 +++--- src/core/vector.c | 2 +- src/core/vm.c | 8 ++++---- 8 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/core/debug.c b/src/core/debug.c index 685543bb..5f1ffe18 100644 --- a/src/core/debug.c +++ b/src/core/debug.c @@ -314,6 +314,7 @@ static Janet doframe(JanetStackFrame *frame) { if (frame->func && frame->pc) { Janet *stack = (Janet *)frame + JANET_FRAME_SIZE; JanetArray *slots; + janet_assert(def != NULL, "def != NULL"); off = (int32_t)(frame->pc - def->bytecode); janet_table_put(t, janet_ckeywordv("pc"), janet_wrap_integer(off)); if (def->sourcemap) { diff --git a/src/core/fiber.c b/src/core/fiber.c index af183c7b..8851e434 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -81,6 +81,7 @@ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t } fiber->stacktop = newstacktop; } + /* Don't panic on failure since we use this to implement janet_pcall */ if (janet_fiber_funcframe(fiber, callee)) return NULL; janet_fiber_frame(fiber)->flags |= JANET_STACKFRAME_ENTRANCE; #ifdef JANET_EV @@ -92,7 +93,9 @@ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t /* Create a new fiber with argn values on the stack. */ JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv) { - return janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv); + JanetFiber *result = janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv); + if (NULL == result) janet_panic("cannot create fiber"); + return result; } #ifdef JANET_DEBUG diff --git a/src/core/pp.c b/src/core/pp.c index abeb7ce3..7f20a48a 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -775,7 +775,7 @@ static const char *get_fmt_mapping(char c) { if (format_mappings[i].c == c) return format_mappings[i].mapping; } - return NULL; + janet_assert(0, "bad format mapping"); } static const char *scanformat( diff --git a/src/core/specials.c b/src/core/specials.c index d2a08909..5420f6c2 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -1019,6 +1019,7 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { for (i = 0; i < paramcount; i++) { Janet param = params[i]; if (!janet_checktype(param, JANET_SYMBOL)) { + janet_assert(janet_v_count(destructed_params) > j, "out of bounds"); JanetSlot reg = destructed_params[j++]; destructure(c, param, reg, defleaf, NULL); janetc_freeslot(c, reg); diff --git a/src/core/symcache.c b/src/core/symcache.c index 8da6dfa1..e1d9aeab 100644 --- a/src/core/symcache.c +++ b/src/core/symcache.c @@ -108,6 +108,7 @@ static const uint8_t **janet_symcache_findmem( } notfound: *success = 0; + janet_assert(firstEmpty != NULL, "symcache failed to get memory"); return firstEmpty; } diff --git a/src/core/util.c b/src/core/util.c index 9f4ed951..c0e3e564 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -499,7 +499,7 @@ typedef struct { static void namebuf_init(NameBuf *namebuf, const char *prefix) { size_t plen = strlen(prefix); namebuf->plen = plen; - namebuf->buf = janet_malloc(namebuf->plen + 256); + namebuf->buf = janet_smalloc(namebuf->plen + 256); if (NULL == namebuf->buf) { JANET_OUT_OF_MEMORY; } @@ -508,12 +508,12 @@ static void namebuf_init(NameBuf *namebuf, const char *prefix) { } static void namebuf_deinit(NameBuf *namebuf) { - janet_free(namebuf->buf); + janet_sfree(namebuf->buf); } static char *namebuf_name(NameBuf *namebuf, const char *suffix) { size_t slen = strlen(suffix); - namebuf->buf = janet_realloc(namebuf->buf, namebuf->plen + 2 + slen); + namebuf->buf = janet_srealloc(namebuf->buf, namebuf->plen + 2 + slen); if (NULL == namebuf->buf) { JANET_OUT_OF_MEMORY; } diff --git a/src/core/vector.c b/src/core/vector.c index 90ff60dc..b22603fe 100644 --- a/src/core/vector.c +++ b/src/core/vector.c @@ -40,7 +40,7 @@ void *janet_v_grow(void *v, int32_t increment, int32_t itemsize) { /* Convert a buffer to normal allocated memory (forget capacity) */ void *janet_v_flattenmem(void *v, int32_t itemsize) { - int32_t *p; + char *p; if (NULL == v) return NULL; size_t size = (size_t) itemsize * janet_v__cnt(v); p = janet_malloc(size); diff --git a/src/core/vm.c b/src/core/vm.c index b7e67df1..8d1a62bf 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -1513,14 +1513,14 @@ JanetSignal janet_pcall( JanetFiber *fiber; if (f && *f) { fiber = janet_fiber_reset(*f, fun, argc, argv); + if (NULL == fiber) { + *out = janet_cstringv("arity mismatch"); + return JANET_SIGNAL_ERROR; + } } else { fiber = janet_fiber(fun, 64, argc, argv); } if (f) *f = fiber; - if (!fiber) { - *out = janet_cstringv("arity mismatch"); - return JANET_SIGNAL_ERROR; - } return janet_continue(fiber, janet_wrap_nil(), out); } From 26a113927e75e4c1c8b57922c78c4c1e1164c3db Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 1 Jun 2023 12:47:59 -0500 Subject: [PATCH 071/138] Add handling for new bytecode optimizations. --- src/core/compile.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core/compile.c b/src/core/compile.c index a1a7db8c..05c19ba2 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -977,7 +977,8 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { } else { jsm.death_pc = pair.death_pc - scope->bytecode_start; } - jsm.birth_pc = pair.birth_pc - scope->bytecode_start; + /* Handle birth_pc == 0 correctly */ + jsm.birth_pc = pair.birth_pc ? pair.birth_pc - scope->bytecode_start : 0; jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); From e97299fc658df9ce0e14385ad698f63d7387d93b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 1 Jun 2023 13:01:59 -0500 Subject: [PATCH 072/138] Fix #1174 - bad debug info causing stack traversal to segfault. Coming from commit 77189b6e66193cc03b824413cfcf65a1c20bb53d, relating to changes in source mapping debug info, this caused a segfault when traversing a stack frame where the birth_pc was incredibly large due to wrap around. This fix prevents the wrap around and does saturating subtraction to 0. --- src/core/compile.c | 9 ++++++++- test/suite0015.janet | 11 +++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/core/compile.c b/src/core/compile.c index 05c19ba2..8ab0e3a2 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -978,7 +978,14 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { jsm.death_pc = pair.death_pc - scope->bytecode_start; } /* Handle birth_pc == 0 correctly */ - jsm.birth_pc = pair.birth_pc ? pair.birth_pc - scope->bytecode_start : 0; + if ((uint32_t) scope->bytecode_start > pair.birth_pc) { + jsm.birth_pc = 0; + } else { + jsm.birth_pc = pair.birth_pc - scope->bytecode_start; + } + janet_assert(jsm.birth_pc <= jsm.death_pc, "birth pc after death pc"); + janet_assert(jsm.birth_pc < (uint32_t) def->bytecode_length, "bad birth pc"); + janet_assert(jsm.death_pc <= (uint32_t) def->bytecode_length, "bad death pc"); jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); diff --git a/test/suite0015.janet b/test/suite0015.janet index bb00a9b6..aba27bd9 100644 --- a/test/suite0015.janet +++ b/test/suite0015.janet @@ -47,4 +47,15 @@ (assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing") +# Crash issue #1174 - bad debug info +(defn crash [] + (debug/stack (fiber/current))) +(do + (math/random) + (defn foo [_] + (crash) + 1) + (foo 0) + 10) + (end-suite) From 9675411f352be882b575c642ef25202489e2461f Mon Sep 17 00:00:00 2001 From: sogaiu <983021772@users.noreply.github.com> Date: Fri, 2 Jun 2023 07:04:07 +0900 Subject: [PATCH 073/138] Reorganize tests --- test/helper.janet | 17 +- test/suite-array.janet | 50 ++ test/suite-asm.janet | 55 ++ test/suite-boot.janet | 853 +++++++++++++++++++ test/suite-buffer.janet | 105 +++ test/{suite0013.janet => suite-capi.janet} | 39 +- test/suite-cfuns.janet | 34 + test/suite-compile.janet | 77 ++ test/suite-corelib.janet | 120 +++ test/suite-debug.janet | 34 + test/{suite0009.janet => suite-ev.janet} | 82 +- test/{suite0012.janet => suite-ffi.janet} | 14 +- test/suite-inttypes.janet | 232 +++++ test/suite-io.janet | 72 ++ test/suite-marsh.janet | 142 +++ test/suite-math.janet | 69 ++ test/suite-os.janet | 133 +++ test/suite-parse.janet | 169 ++++ test/suite-peg.janet | 664 +++++++++++++++ test/suite-pp.janet | 65 ++ test/suite-specials.janet | 202 +++++ test/{suite0002.janet => suite-string.janet} | 148 ++-- test/suite-strtod.janet | 44 + test/suite-struct.janet | 82 ++ test/suite-symcache.janet | 42 + test/suite-table.janet | 72 ++ test/suite-unknown.janet | 296 +++++++ test/suite-value.janet | 72 ++ test/suite-vm.janet | 142 +++ test/suite0000.janet | 437 ---------- test/suite0001.janet | 384 --------- test/suite0003.janet | 497 ----------- test/suite0004.janet | 86 -- test/suite0005.janet | 120 --- test/suite0006.janet | 272 ------ test/suite0007.janet | 344 -------- test/suite0008.janet | 384 --------- test/suite0010.janet | 333 -------- test/suite0011.janet | 108 --- test/suite0014.janet | 20 - test/suite0015.janet | 61 -- 41 files changed, 3998 insertions(+), 3174 deletions(-) create mode 100644 test/suite-array.janet create mode 100644 test/suite-asm.janet create mode 100644 test/suite-boot.janet create mode 100644 test/suite-buffer.janet rename test/{suite0013.janet => suite-capi.janet} (58%) create mode 100644 test/suite-cfuns.janet create mode 100644 test/suite-compile.janet create mode 100644 test/suite-corelib.janet create mode 100644 test/suite-debug.janet rename test/{suite0009.janet => suite-ev.janet} (87%) rename test/{suite0012.janet => suite-ffi.janet} (87%) create mode 100644 test/suite-inttypes.janet create mode 100644 test/suite-io.janet create mode 100644 test/suite-marsh.janet create mode 100644 test/suite-math.janet create mode 100644 test/suite-os.janet create mode 100644 test/suite-parse.janet create mode 100644 test/suite-peg.janet create mode 100644 test/suite-pp.janet create mode 100644 test/suite-specials.janet rename test/{suite0002.janet => suite-string.janet} (52%) create mode 100644 test/suite-strtod.janet create mode 100644 test/suite-struct.janet create mode 100644 test/suite-symcache.janet create mode 100644 test/suite-table.janet create mode 100644 test/suite-unknown.janet create mode 100644 test/suite-value.janet create mode 100644 test/suite-vm.janet delete mode 100644 test/suite0000.janet delete mode 100644 test/suite0001.janet delete mode 100644 test/suite0003.janet delete mode 100644 test/suite0004.janet delete mode 100644 test/suite0005.janet delete mode 100644 test/suite0006.janet delete mode 100644 test/suite0007.janet delete mode 100644 test/suite0008.janet delete mode 100644 test/suite0010.janet delete mode 100644 test/suite0011.janet delete mode 100644 test/suite0014.janet delete mode 100644 test/suite0015.janet diff --git a/test/helper.janet b/test/helper.janet index 05ab1db4..ce5389c4 100644 --- a/test/helper.janet +++ b/test/helper.janet @@ -2,7 +2,7 @@ (var num-tests-passed 0) (var num-tests-run 0) -(var suite-num 0) +(var suite-name 0) (var start-time 0) (def is-verbose (os/getenv "VERBOSE")) @@ -34,13 +34,20 @@ (def errsym (keyword (gensym))) ~(assert (not= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg)) -(defn start-suite [x] - (set suite-num x) +(defn start-suite [&opt x] + (default x (dyn :current-file)) + (set suite-name + (cond + (number? x) (string x) + (string? x) (string/slice x + (length "test/suite-") + (- (inc (length ".janet")))) + (string x))) (set start-time (os/clock)) - (eprint "Starting suite " x "...")) + (eprint "Starting suite " suite-name "...")) (defn end-suite [] (def delta (- (os/clock) start-time)) - (eprinf "Finished suite %d in %.3f seconds - " suite-num delta) + (eprinf "Finished suite %s in %.3f seconds - " suite-name delta) (eprint num-tests-passed " of " num-tests-run " tests passed.") (if (not= num-tests-passed num-tests-run) (os/exit 1))) diff --git a/test/suite-array.janet b/test/suite-array.janet new file mode 100644 index 00000000..6d2a1db9 --- /dev/null +++ b/test/suite-array.janet @@ -0,0 +1,50 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Array tests +# e05022f +(defn array= + "Check if two arrays are equal in an element by element comparison" + [a b] + (if (and (array? a) (array? b)) + (= (apply tuple a) (apply tuple b)))) +(assert (= (apply tuple @[1 2 3 4 5]) (tuple 1 2 3 4 5)) "array to tuple") +(def arr (array)) +(array/push arr :hello) +(array/push arr :world) +(assert (array= arr @[:hello :world]) "array comparison") +(assert (array= @[1 2 3 4 5] @[1 2 3 4 5]) "array comparison 2") +(assert (array= @[:one :two :three :four :five] + @[:one :two :three :four :five]) "array comparison 3") +(assert (array= (array/slice @[1 2 3] 0 2) @[1 2]) "array/slice 1") +(assert (array= (array/slice @[0 7 3 9 1 4] 2 -2) @[3 9 1]) "array/slice 2") + +# Array remove +# 687a3c9 +(assert (deep= (array/remove @[1 2 3 4 5] 2) @[1 2 4 5]) "array/remove 1") +(assert (deep= (array/remove @[1 2 3 4 5] 2 2) @[1 2 5]) "array/remove 2") +(assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3") +(assert (deep= (array/remove @[1 2 3 4 5] -3 200) @[1 2 3]) "array/remove 4") + +(end-suite) + diff --git a/test/suite-asm.janet b/test/suite-asm.janet new file mode 100644 index 00000000..7e230860 --- /dev/null +++ b/test/suite-asm.janet @@ -0,0 +1,55 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Assembly test +# Fibonacci sequence, implemented with naive recursion. +# a679f60 +(def fibasm (asm '{ + :arity 1 + :bytecode [ + (ltim 1 0 0x2) # $1 = $0 < 2 + (jmpif 1 :done) # if ($1) goto :done + (lds 1) # $1 = self + (addim 0 0 -0x1) # $0 = $0 - 1 + (push 0) # push($0), push argument for next function call + (call 2 1) # $2 = call($1) + (addim 0 0 -0x1) # $0 = $0 - 1 + (push 0) # push($0) + (call 0 1) # $0 = call($1) + (add 0 0 2) # $0 = $0 + $2 (integers) + :done + (ret 0) # return $0 + ] +})) + +(assert (= 0 (fibasm 0)) "fibasm 1") +(assert (= 1 (fibasm 1)) "fibasm 2") +(assert (= 55 (fibasm 10)) "fibasm 3") +(assert (= 6765 (fibasm 20)) "fibasm 4") + +# dacbe29 +(def f (asm (disasm (fn [x] (fn [y] (+ x y)))))) +(assert (= ((f 10) 37) 47) "asm environment tables") + +(end-suite) + diff --git a/test/suite-boot.janet b/test/suite-boot.janet new file mode 100644 index 00000000..902cdd1c --- /dev/null +++ b/test/suite-boot.janet @@ -0,0 +1,853 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Let +# 807f981 +(assert (= (let [a 1 b 2] (+ a b)) 3) "simple let") +(assert (= (let [[a b] @[1 2]] (+ a b)) 3) "destructured let") +(assert (= (let [[a [c d] b] @[1 (tuple 4 3) 2]] (+ a b c d)) 10) + "double destructured let") + +# Macros +# b305a7c +(defn dub [x] (+ x x)) +(assert (= 2 (dub 1)) "defn macro") +(do + (defn trip [x] (+ x x x)) + (assert (= 3 (trip 1)) "defn macro triple")) +(do + (var i 0) + (when true + (++ i) + (++ i) + (++ i) + (++ i) + (++ i) + (++ i)) + (assert (= i 6) "when macro")) + +# Add truthy? to core +# ded08b6 +(assert (= true ;(map truthy? [0 "" true @{} {} [] '()])) "truthy values") +(assert (= false ;(map truthy? [nil false])) "non-truthy values") + +## Polymorphic comparison -- Issue #272 +# 81d301a42 + +# confirm polymorphic comparison delegation to primitive comparators: +(assert (= 0 (cmp 3 3)) "compare-primitive integers (1)") +(assert (= -1 (cmp 3 5)) "compare-primitive integers (2)") +(assert (= 1 (cmp "foo" "bar")) "compare-primitive strings") +(assert (= 0 (compare 1 1)) "compare integers (1)") +(assert (= -1 (compare 1 2)) "compare integers (2)") +(assert (= 1 (compare "foo" "bar")) "compare strings (1)") + +(assert (compare< 1 2 3 4 5 6) "compare less than integers") +(assert (not (compare> 1 2 3 4 5 6)) "compare not greater than integers") +(assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals") +(assert (compare> 6 5 4 3 2 1) "compare greater than integers") +(assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals") +(assert (not (compare< 6.0 5.0 4.0 3.0 2.0 1.0)) "compare less than reals") +(assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers") +(assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) + "compare less than or equal to reals") +(assert (compare>= 6 5 4 4 3 2 1) + "compare greater than or equal to integers") +(assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) + "compare greater than or equal to reals") +(assert (compare< 1.0 nil false true + (fiber/new (fn [] 1)) + "hi" + (quote hello) + :hello + (array 1 2 3) + (tuple 1 2 3) + (table "a" "b" "c" "d") + (struct 1 2 3 4) + (buffer "hi") + (fn [x] (+ x x)) + print) "compare type ordering") + +# test polymorphic compare with 'objects' (table/setproto) +(def mynum + @{:type :mynum :v 0 :compare + (fn [self other] + (case (type other) + :number (cmp (self :v) other) + :table (when (= (get other :type) :mynum) + (cmp (self :v) (other :v)))))}) + +(let [n3 (table/setproto @{:v 3} mynum)] + (assert (= 0 (compare 3 n3)) "compare num to object (1)") + (assert (= -1 (compare n3 4)) "compare object to num (2)") + (assert (= 1 (compare (table/setproto @{:v 4} mynum) n3)) + "compare object to object") + (assert (compare< 2 n3 4) "compare< poly") + (assert (compare> 4 n3 2) "compare> poly") + (assert (compare<= 2 3 n3 4) "compare<= poly") + (assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly") + (assert (deep= (sorted @[4 5 n3 2] compare<) @[2 n3 4 5]) + "polymorphic sort")) + +# Add any? predicate to core +# 7478ad11 +(assert (= nil (any? [])) "any? 1") +(assert (= nil (any? [false nil])) "any? 2") +(assert (= nil (any? [nil false])) "any? 3") +(assert (= 1 (any? [1])) "any? 4") +(assert (nan? (any? [nil math/nan nil])) "any? 5") +(assert (= true + (any? [nil nil false nil nil true nil nil nil nil false :a nil])) + "any? 6") + +# Some higher order functions and macros +# 5e2de33 +(def my-array @[1 2 3 4 5 6]) +(def x (if-let [x (get my-array 5)] x)) +(assert (= x 6) "if-let") +(def x (if-let [y (get @{} :key)] 10 nil)) +(assert (not x) "if-let 2") + +(assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") +(def myfun (juxt + - * /)) +(assert (= [2 -2 2 0.5] (myfun 2)) "juxt") + +# Case statements +# 5249228 +(assert + (= :six (case (+ 1 2 3) + 1 :one + 2 :two + 3 :three + 4 :four + 5 :five + 6 :six + 7 :seven + 8 :eight + 9 :nine)) "case macro") + +(assert (= 7 (case :a :b 5 :c 6 :u 10 7)) "case with default") + +# Testing the seq, tabseq, catseq, and loop macros +# 547529e +(def xs (apply tuple (seq [x :range [0 10] :when (even? x)] + (tuple (/ x 2) x)))) +(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1") + +# 624be87c9 +(def xs (apply tuple (seq [x :down [8 -2] :when (even? x)] + (tuple (/ x 2) x)))) +(assert (= xs '((4 8) (3 6) (2 4) (1 2) (0 0))) "seq macro 2") + +# Looping idea +# 45f8db0 +(def xs + (seq [x :in [-1 0 1] y :in [-1 0 1] :when (not= x y 0)] (tuple x y))) +(def txs (apply tuple xs)) + +(assert (= txs [[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) + "nested seq") + +# 515891b03 +(assert (deep= (tabseq [i :in (range 3)] i (* 3 i)) + @{0 0 1 3 2 6})) + +(assert (deep= (tabseq [i :in (range 3)] i) + @{})) + +# ccd874fe4 +(def xs (catseq [x :range [0 3]] [x x])) +(assert (deep= xs @[0 0 1 1 2 2]) "catseq") + +# :range-to and :down-to +# e0c9910d8 +(assert (deep= (seq [x :range-to [0 10]] x) (seq [x :range [0 11]] x)) + "loop :range-to") +(assert (deep= (seq [x :down-to [10 0]] x) (seq [x :down [10 -1]] x)) + "loop :down-to") + +# 7880d7320 +(def res @{}) +(loop [[k v] :pairs @{1 2 3 4 5 6}] + (put res k v)) +(assert (and + (= (get res 1) 2) + (= (get res 3) 4) + (= (get res 5) 6)) "loop :pairs") + +# Issue #428 +# 08a3687eb +(var result nil) +(defn f [] (yield {:a :ok})) +(assert-no-error "issue 428 1" + (loop [{:a x} :in (fiber/new f)] (set result x))) +(assert (= result :ok) "issue 428 2") + +# Generators +# 184fe31e0 +(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x)) +(var gencount 0) +(loop [x :in gen] + (++ gencount) + (assert (pos? (% x 4)) "generate in loop")) +(assert (= gencount 75) "generate loop count") + +# Even and odd +# ff163a5ae +(assert (odd? 9) "odd? 1") +(assert (odd? -9) "odd? 2") +(assert (not (odd? 10)) "odd? 3") +(assert (not (odd? 0)) "odd? 4") +(assert (not (odd? -10)) "odd? 5") +(assert (not (odd? 1.1)) "odd? 6") +(assert (not (odd? -0.1)) "odd? 7") +(assert (not (odd? -1.1)) "odd? 8") +(assert (not (odd? -1.6)) "odd? 9") + +(assert (even? 10) "even? 1") +(assert (even? -10) "even? 2") +(assert (even? 0) "even? 3") +(assert (not (even? 9)) "even? 4") +(assert (not (even? -9)) "even? 5") +(assert (not (even? 0.1)) "even? 6") +(assert (not (even? -0.1)) "even? 7") +(assert (not (even? -10.1)) "even? 8") +(assert (not (even? -10.6)) "even? 9") + +# Map arities +# 25ded775a +(assert (deep= (map inc [1 2 3]) @[2 3 4])) +(assert (deep= (map + [1 2 3] [10 20 30]) @[11 22 33])) +(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300]) @[111 222 333])) +(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]) + @[1111 2222 3333])) +(assert (deep= (map + + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] + [10000 20000 30000]) + @[11111 22222 33333])) +# 77e62a2 +(assert (deep= (map + + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] + [10000 20000 30000] [100000 200000 300000]) + @[111111 222222 333333])) + +# Mapping uses the shortest sequence +# a69799aa4 +(assert (deep= (map + [1 2 3 4] [10 20 30]) @[11 22 33])) +(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222])) +(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111])) +# 77e62a2 +(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000] []) @[])) + +# Variadic arguments to map-like functions +# 77e62a2 +(assert (deep= (mapcat tuple [1 2 3 4] [5 6 7 8]) @[1 5 2 6 3 7 4 8])) +(assert (deep= (keep |(if (> $1 0) (/ $0 $1)) [1 2 3 4 5] [1 2 1 0 1]) + @[1 1 3 5])) + +(assert (= (count = [1 3 2 4 3 5 4 2 1] [1 2 3 4 5 4 3 2 1]) 4)) + +(assert (= (some not= (range 5) (range 5)) nil)) +(assert (= (some = [1 2 3 4 5] [5 4 3 2 1]) true)) + +(assert (= (all = (range 5) (range 5)) true)) +(assert (= (all not= [1 2 3 4 5] [5 4 3 2 1]) false)) + +# 4194374 +(assert (= false (deep-not= [1] [1])) "issue #1149") + +# Merge sort +# f5b29b8 +# Imperative (and verbose) merge sort merge +(defn merge-sort + [xs ys] + (def ret @[]) + (def xlen (length xs)) + (def ylen (length ys)) + (var i 0) + (var j 0) + # Main merge + (while (if (< i xlen) (< j ylen)) + (def xi (get xs i)) + (def yj (get ys j)) + (if (< xi yj) + (do (array/push ret xi) (set i (+ i 1))) + (do (array/push ret yj) (set j (+ j 1))))) + # Push rest of xs + (while (< i xlen) + (def xi (get xs i)) + (array/push ret xi) + (set i (+ i 1))) + # Push rest of ys + (while (< j ylen) + (def yj (get ys j)) + (array/push ret yj) + (set j (+ j 1))) + ret) + +(assert (apply <= (merge-sort @[1 3 5] @[2 4 6])) "merge sort merge 1") +(assert (apply <= (merge-sort @[1 2 3] @[4 5 6])) "merge sort merge 2") +(assert (apply <= (merge-sort @[1 3 5] @[2 4 6 6 6 9])) "merge sort merge 3") +(assert (apply <= (merge-sort '(1 3 5) @[2 4 6 6 6 9])) "merge sort merge 4") + +(assert (deep= @[1 2 3 4 5] (sort @[5 3 4 1 2])) "sort 1") +(assert (deep= @[{:a 1} {:a 4} {:a 7}] + (sort-by |($ :a) @[{:a 4} {:a 7} {:a 1}])) "sort 2") +(assert (deep= @[1 2 3 4 5] (sorted [5 3 4 1 2])) "sort 3") +(assert (deep= @[{:a 1} {:a 4} {:a 7}] + (sorted-by |($ :a) [{:a 4} {:a 7} {:a 1}])) "sort 4") + +# Sort function +# 2ca9300bf +(assert (deep= + (range 99) + (sort (mapcat (fn [[x y z]] [z y x]) (partition 3 (range 99))))) + "sort 5") +(assert (<= ;(sort (map (fn [x] (math/random)) (range 1000)))) "sort 6") + +# And and or +# c16a9d846 +(assert (= (and true true) true) "and true true") +(assert (= (and true false) false) "and true false") +(assert (= (and false true) false) "and false true") +(assert (= (and true true true) true) "and true true true") +(assert (= (and 0 1 2) 2) "and 0 1 2") +(assert (= (and 0 1 nil) nil) "and 0 1 nil") +(assert (= (and 1) 1) "and 1") +(assert (= (and) true) "and with no arguments") +(assert (= (and 1 true) true) "and with trailing true") +(assert (= (and 1 true 2) 2) "and with internal true") + +(assert (= (or true true) true) "or true true") +(assert (= (or true false) true) "or true false") +(assert (= (or false true) true) "or false true") +(assert (= (or false false) false) "or false true") +(assert (= (or true true false) true) "or true true false") +(assert (= (or 0 1 2) 0) "or 0 1 2") +(assert (= (or nil 1 2) 1) "or nil 1 2") +(assert (= (or 1) 1) "or 1") +(assert (= (or) nil) "or with no arguments") + +# And/or checks +# 6123c41f1 +(assert (= false (and false false)) "and 1") +(assert (= false (or false false)) "or 1") + +# Range +# a982f351d +(assert (deep= (range 10) @[0 1 2 3 4 5 6 7 8 9]) "range 1 argument") +(assert (deep= (range 5 10) @[5 6 7 8 9]) "range 2 arguments") +(assert (deep= (range 5 10 2) @[5 7 9]) "range 3 arguments") +# 11cd1279d +(assert (= (length (range 10)) 10) "(range 10)") +(assert (= (length (range 1 10)) 9) "(range 1 10)") +(assert (deep= @{:a 1 :b 2 :c 3} (zipcoll '[:a :b :c] '[1 2 3])) "zipcoll") + +# bc8be266f +(def- a 100) +(assert (= a 100) "def-") + +# bc8be266f +(assert (= :first + (match @[1 3 5] + @[x y z] :first + :second)) "match 1") + +(def val1 :avalue) +(assert (= :second + (match val1 + @[x y z] :first + :avalue :second + :third)) "match 2") + +(assert (= 100 + (match @[50 40] + @[x x] (* x 3) + @[x y] (+ x y 10) + 0)) "match 3") + +# Match checks +# 47e8f669f +(assert (= :hi (match nil nil :hi)) "match 1") +(assert (= :hi (match {:a :hi} {:a a} a)) "match 2") +(assert (= nil (match {:a :hi} {:a a :b b} a)) "match 3") +(assert (= nil (match [1 2] [a b c] a)) "match 4") +(assert (= 2 (match [1 2] [a b] b)) "match 5") +# db631097b +(assert (= [2 :a :b] (match [1 2 :a :b] [o & rest] rest)) "match 6") +(assert (= [] (match @[:a] @[x & r] r :fallback)) "match 7") +(assert (= :fallback (match @[1] @[x y & r] r :fallback)) "match 8") +(assert (= [1 2 3 4] (match @[1 2 3 4] @[x y z & r] [x y z ;r] :fallback)) + "match 9") + +# Test cases for #293 +# d3b9b8d45 +(assert (= :yes (match [1 2 3] [_ a _] :yes :no)) "match wildcard 1") +(assert (= :no (match [1 2 3] [__ a __] :yes :no)) "match wildcard 2") +(assert (= :yes (match [1 2 [1 2 3]] [_ a [_ _ _]] :yes :no)) + "match wildcard 3") +(assert (= :yes (match [1 2 3] (_ (even? 2)) :yes :no)) "match wildcard 4") +(assert (= :yes (match {:a 1} {:a _} :yes :no)) "match wildcard 5") +(assert (= false (match {:a 1 :b 2 :c 3} + {:a a :b _ :c _ :d _} :no + {:a _ :b _ :c _} false + :no)) "match wildcard 6") +(assert (= nil (match {:a 1 :b 2 :c 3} + {:a a :b _ :c _ :d _} :no + {:a _ :b _ :c _} nil + :no)) "match wildcard 7") +# issue #529 - 602010600 +(assert (= "t" (match [true nil] [true _] "t")) "match wildcard 8") + +# quoted match test +# 425a0fcf0 +(assert (= :yes (match 'john 'john :yes _ :nope)) "quoted literal match 1") +(assert (= :nope (match 'john ''john :yes _ :nope)) "quoted literal match 2") + +# Some macros +# 7880d7320 +(assert (= 2 (if-not 1 3 2)) "if-not 1") +(assert (= 3 (if-not false 3)) "if-not 2") +(assert (= 3 (if-not nil 3 2)) "if-not 3") +(assert (= nil (if-not true 3)) "if-not 4") + +(assert (= 4 (unless false (+ 1 2 3) 4)) "unless") + +# take +# 18da183ef +(assert (deep= (take 0 []) []) "take 1") +(assert (deep= (take 10 []) []) "take 2") +(assert (deep= (take 0 [1 2 3 4 5]) []) "take 3") +(assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4") +(assert (deep= (take -1 [:a :b :c]) []) "take 5") +# 34019222c +(assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3]) + "take from fiber") +# NB: repeatedly resuming a fiber created with `generate` includes a `nil` +# as the final element. Thus a generate of 2 elements will create an array +# of 3. +(assert (= (length (take 4 (generate [x :in [1 2]] x))) 2) + "take from short fiber") + +# take-until +# 18da183ef +(assert (deep= (take-until pos? @[]) []) "take-until 1") +(assert (deep= (take-until pos? @[1 2 3]) []) "take-until 2") +(assert (deep= (take-until pos? @[-1 -2 -3]) [-1 -2 -3]) "take-until 3") +(assert (deep= (take-until pos? @[-1 -2 3]) [-1 -2]) "take-until 4") +(assert (deep= (take-until pos? @[-1 1 -2]) [-1]) "take-until 5") +(assert (deep= (take-until |(= $ 115) "books") "book") "take-until 6") +(assert (deep= (take-until |(= $ 115) (generate [x :in "books"] x)) + @[98 111 111 107]) "take-until from fiber") + +# take-while +# 18da183ef +(assert (deep= (take-while neg? @[]) []) "take-while 1") +(assert (deep= (take-while neg? @[1 2 3]) []) "take-while 2") +(assert (deep= (take-while neg? @[-1 -2 -3]) [-1 -2 -3]) "take-while 3") +(assert (deep= (take-while neg? @[-1 -2 3]) [-1 -2]) "take-while 4") +(assert (deep= (take-while neg? @[-1 1 -2]) [-1]) "take-while 5") +(assert (deep= (take-while neg? (generate [x :in @[-1 1 -2]] x)) + @[-1]) "take-while from fiber") + +# drop +# 18da183ef +(assert (deep= (drop 0 []) []) "drop 1") +(assert (deep= (drop 10 []) []) "drop 2") +(assert (deep= (drop 0 [1 2 3 4 5]) [1 2 3 4 5]) "drop 3") +(assert (deep= (drop 10 [1 2 3]) []) "drop 4") +(assert (deep= (drop -1 [1 2 3]) [1 2]) "drop 5") +(assert (deep= (drop -10 [1 2 3]) []) "drop 6") +(assert (deep= (drop 1 "abc") "bc") "drop 7") +(assert (deep= (drop 10 "abc") "") "drop 8") +(assert (deep= (drop -1 "abc") "ab") "drop 9") +(assert (deep= (drop -10 "abc") "") "drop 10") +(assert-error :invalid-type (drop 3 {}) "drop 11") + +# drop-until +# 75dc08f +(assert (deep= (drop-until pos? @[]) []) "drop-until 1") +(assert (deep= (drop-until pos? @[1 2 3]) [1 2 3]) "drop-until 2") +(assert (deep= (drop-until pos? @[-1 -2 -3]) []) "drop-until 3") +(assert (deep= (drop-until pos? @[-1 -2 3]) [3]) "drop-until 4") +(assert (deep= (drop-until pos? @[-1 1 -2]) [1 -2]) "drop-until 5") +(assert (deep= (drop-until |(= $ 115) "books") "s") "drop-until 6") + +# Comment macro +# issue #110 - 698e89aba +(comment 1) +(comment 1 2) +(comment 1 2 3) +(comment 1 2 3 4) + +# comp should be variadic +# 5c83ebd75, 02ce3031 +(assert (= 10 ((comp +) 1 2 3 4)) "variadic comp 1") +(assert (= 11 ((comp inc +) 1 2 3 4)) "variadic comp 2") +(assert (= 12 ((comp inc inc +) 1 2 3 4)) "variadic comp 3") +(assert (= 13 ((comp inc inc inc +) 1 2 3 4)) "variadic comp 4") +(assert (= 14 ((comp inc inc inc inc +) 1 2 3 4)) "variadic comp 5") +(assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6") +(assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4)) + "variadic comp 7") + +# Function shorthand +# 44e752d73 +(assert (= (|(+ 1 2 3)) 6) "function shorthand 1") +(assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2") +(assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3") +(assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4") +(assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5") +(assert (= (|4) 4) "function shorthand 6") +(assert (= (((|||4))) 4) "function shorthand 7") +(assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8") +(assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9") +# 5f5147652 +(assert (= (|(+ $0 $99) ;(range 100)) 99) "function shorthand 10") + +# 655d4b3aa +(defn idx= [x y] (= (tuple/slice x) (tuple/slice y))) + +# Simple take, drop, etc. tests. +(assert (idx= (take 10 (range 100)) (range 10)) "take 10") +(assert (idx= (drop 10 (range 100)) (range 10 100)) "drop 10") + +# with-vars +# 6ceaf9d28 +(var abc 123) +(assert (= 356 (with-vars [abc 456] (- abc 100))) "with-vars 1") +(assert-error "with-vars 2" (with-vars [abc 456] (error :oops))) +(assert (= abc 123) "with-vars 3") + +# Top level unquote +# 2487162cc +(defn constantly + [] + (comptime (math/random))) + +(assert (= (constantly) (constantly)) "comptime 1") + +# issue #232 - b872ee024 +(assert-error "arity issue in macro" (eval '(each []))) +# c6b639b93 +(assert-error "comptime issue" (eval '(comptime (error "oops")))) + +# 962cd7e5f +(var counter 0) +(when-with [x nil |$] + (++ counter)) +(when-with [x 10 |$] + (+= counter 10)) + +(assert (= 10 counter) "when-with 1") + +(if-with [x nil |$] (++ counter) (+= counter 10)) +(if-with [x true |$] (+= counter 20) (+= counter 30)) + +(assert (= 40 counter) "if-with 1") + +# a45509d28 +(def a @[]) +(eachk x [:a :b :c :d] + (array/push a x)) +(assert (deep= (range 4) a) "eachk 1") + +# issue 609 - 1fcaffe +(with-dyns [:err @""] + (tracev (def my-unique-var-name true)) + (assert my-unique-var-name "tracev upscopes")) + +# Prompts and Labels +# 59d288c +(assert (= 10 (label a (for i 0 10 (if (= i 5) (return a 10))))) "label 1") + +(defn recur + [lab x y] + (when (= x y) (return lab :done)) + (def res (label newlab (recur (or lab newlab) (+ x 1) y))) + (if lab :oops res)) +(assert (= :done (recur nil 0 10)) "label 2") + +(assert (= 10 (prompt :a (for i 0 10 (if (= i 5) (return :a 10))))) + "prompt 1") + +(defn- inner-loop + [i] + (if (= i 5) + (return :a 10))) + +(assert (= 10 (prompt :a (for i 0 10 (inner-loop i)))) "prompt 2") + +(defn- inner-loop2 + [i] + (try + (if (= i 5) + (error 10)) + ([err] (return :a err)))) + +(assert (= 10 (prompt :a (for i 0 10 (inner-loop2 i)))) "prompt 3") + +# chr +# issue 304 - 77343e02e +(assert (= (chr "a") 97) "chr 1") + +# Reduce2 +# 3eb0927a2 +(assert (= (reduce + 0 (range 1 10)) (reduce2 + (range 10))) "reduce2 1") +# 65379741f +(assert (= (reduce * 1 (range 2 10)) (reduce2 * (range 1 10))) "reduce2 2") +(assert (= nil (reduce2 * [])) "reduce2 3") + +# Accumulate +# 3eb0927a2 +(assert (deep= (accumulate + 0 (range 5)) @[0 1 3 6 10]) "accumulate 1") +(assert (deep= (accumulate2 + (range 5)) @[0 1 3 6 10]) "accumulate2 1") +# 65379741f +(assert (deep= @[] (accumulate2 + [])) "accumulate2 2") +(assert (deep= @[] (accumulate 0 + [])) "accumulate 2") + +# in vs get regression +# issue #340 - b63a0796f +(assert (nil? (first @"")) "in vs get 1") +(assert (nil? (last @"")) "in vs get 1") + +# index-of +# 259812314 +(assert (= nil (index-of 10 [])) "index-of 1") +(assert (= nil (index-of 10 [1 2 3])) "index-of 2") +(assert (= 1 (index-of 2 [1 2 3])) "index-of 3") +(assert (= 0 (index-of :a [:a :b :c])) "index-of 4") +(assert (= nil (index-of :a {})) "index-of 5") +(assert (= :a (index-of :A {:a :A :b :B})) "index-of 6") +(assert (= :a (index-of :A @{:a :A :b :B})) "index-of 7") +(assert (= 0 (index-of (chr "a") "abc")) "index-of 8") +(assert (= nil (index-of (chr "a") "")) "index-of 9") +(assert (= nil (index-of 10 @[])) "index-of 10") +(assert (= nil (index-of 10 @[1 2 3])) "index-of 11") + +# e78a3d1 +# NOTE: These is a motivation for the has-value? and has-key? functions below + +# returns false despite key present +(assert (= false (index-of 8 {true 7 false 8})) + "index-of corner key (false) 1") +(assert (= false (index-of 8 @{false 8})) + "index-of corner key (false) 2") +# still returns null +(assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") + +# has-value? +(assert (= false (has-value? [] "foo")) "has-value? 1") +(assert (= true (has-value? [4 7 1 3] 4)) "has-value? 2") +(assert (= false (has-value? [4 7 1 3] 22)) "has-value? 3") +(assert (= false (has-value? @[1 2 3] 4)) "has-value? 4") +(assert (= true (has-value? @[:a :b :c] :a)) "has-value? 5") +(assert (= false (has-value? {} :foo)) "has-value? 6") +(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") +(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") +(assert (= true (has-value? @{:a :A :b :B} :A)) "has-value? 8") +(assert (= true (has-value? "abc" (chr "a"))) "has-value? 9") +(assert (= false (has-value? "abc" "1")) "has-value? 10") +# weird true/false corner cases, should align with "index-of corner +# key {k}" cases +(assert (= true (has-value? {true 7 false 8} 8)) + "has-value? corner key (false) 1") +(assert (= true (has-value? @{false 8} 8)) + "has-value? corner key (false) 2") +(assert (= false (has-value? {false 8} 7)) + "has-value? corner key (false) 3") + +# has-key? +(do + (var test-has-key-auto 0) + (defn test-has-key [col key expected &keys {:name name}] + ``Test that has-key has the outcome `expected`, and that if + the result is true, then ensure (in key) does not fail either`` + (assert (boolean? expected)) + (default name (string "has-key? " (++ test-has-key-auto))) + (assert (= expected (has-key? col key)) name) + (if + # guarenteed by `has-key?` to never fail + expected (in col key) + # if `has-key?` is false, then `in` should fail (for indexed types) + # + # For dictionary types, it should return nil + (let [[success retval] (protect (in col key))] + (def should-succeed (dictionary? col)) + (assert + (= success should-succeed) + (string/format + "%s: expected (in col key) to %s, but got %q" + name (if expected "succeed" "fail") retval))))) + + (test-has-key [] 0 false) # 1 + (test-has-key [4 7 1 3] 2 true) # 2 + (test-has-key [4 7 1 3] 22 false) # 3 + (test-has-key @[1 2 3] 4 false) # 4 + (test-has-key @[:a :b :c] 2 true) # 5 + (test-has-key {} :foo false) # 6 + (test-has-key {:a :A :b :B} :a true) # 7 + (test-has-key {:a :A :b :B} :A false) # 8 + (test-has-key @{:a :A :b :B} :a true) # 9 + (test-has-key "abc" 1 true) # 10 + (test-has-key "abc" 4 false) # 11 + # weird true/false corner cases + # + # Tries to mimic the corresponding corner cases in has-value? and + # index-of, but with keys/values inverted + # + # in the first two cases (truthy? (get val col)) would have given false + # negatives + (test-has-key {7 true 8 false} 8 true :name + "has-key? corner value (false) 1") + (test-has-key @{8 false} 8 true :name + "has-key? corner value (false) 2") + (test-has-key @{8 false} 7 false :name + "has-key? corner value (false) 3")) + +# Regression +# issue #463 - 7e7498350 +(assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463") + +# macex testing +# 7e7498350 +(assert (deep= (macex1 '~{1 2 3 4}) '~{1 2 3 4}) "macex1 qq struct") +(assert (deep= (macex1 '~@{1 2 3 4}) '~@{1 2 3 4}) "macex1 qq table") +(assert (deep= (macex1 '~(1 2 3 4)) '~[1 2 3 4]) "macex1 qq tuple") +(assert (= :brackets (tuple/type (1 (macex1 '~[1 2 3 4])))) + "macex1 qq bracket tuple") +(assert (deep= (macex1 '~@[1 2 3 4 ,blah]) '~@[1 2 3 4 ,blah]) + "macex1 qq array") + +# Sourcemaps in threading macros +# b6175e429 +(defn check-threading [macro expansion] + (def expanded (macex1 (tuple macro 0 '(x) '(y)))) + (assert (= expanded expansion) (string macro " expansion value")) + (def smap-x (tuple/sourcemap (get expanded 1))) + (def smap-y (tuple/sourcemap expanded)) + (def line first) + (defn column [t] (t 1)) + (assert (not= smap-x [-1 -1]) (string macro " x sourcemap existence")) + (assert (not= smap-y [-1 -1]) (string macro " y sourcemap existence")) + (assert (or (< (line smap-x) (line smap-y)) + (and (= (line smap-x) (line smap-y)) + (< (column smap-x) (column smap-y)))) + (string macro " relation between x and y sourcemap"))) + +(check-threading '-> '(y (x 0))) +(check-threading '->> '(y (x 0))) + +# keep-syntax +# b6175e429 +(let [brak '[1 2 3] + par '(1 2 3)] + + (tuple/setmap brak 2 1) + + (assert (deep= (keep-syntax brak @[1 2 3]) @[1 2 3]) + "keep-syntax brackets ignore array") + (assert (= (keep-syntax! brak @[1 2 3]) '[1 2 3]) + "keep-syntax! brackets replace array") + + (assert (= (keep-syntax! par (map inc @[1 2 3])) '(2 3 4)) + "keep-syntax! parens coerce array") + (assert (not= (keep-syntax! brak @[1 2 3]) '(1 2 3)) + "keep-syntax! brackets not parens") + (assert (not= (keep-syntax! par @[1 2 3]) '[1 2 3]) + "keep-syntax! parens not brackets") + (assert (= (tuple/sourcemap brak) + (tuple/sourcemap (keep-syntax! brak @[1 2 3]))) + "keep-syntax! brackets source map") + + (keep-syntax par brak) + (assert (not= (tuple/sourcemap brak) (tuple/sourcemap par)) + "keep-syntax no mutate") + (assert (= (keep-syntax 1 brak) brak) "keep-syntax brackets ignore type")) + +# Curenv +# 28439d822, f7c556e +(assert (= (curenv) (curenv 0)) "curenv 1") +(assert (= (table/getproto (curenv)) (curenv 1)) "curenv 2") +(assert (= nil (curenv 1000000)) "curenv 3") +(assert (= root-env (curenv 1)) "curenv 4") + +# Import macro test +# a31e079f9 +(assert-no-error "import macro 1" (macex '(import a :as b :fresh maybe))) +(assert (deep= ~(,import* "a" :as "b" :fresh maybe) + (macex '(import a :as b :fresh maybe))) "import macro 2") + +# #477 walk preserving bracket type +# 0a1d902f4 +(assert (= :brackets (tuple/type (postwalk identity '[]))) + "walk square brackets 1") +(assert (= :brackets (tuple/type (walk identity '[]))) + "walk square brackets 2") + +# Issue #751 +# 547fda6a4 +(def t {:side false}) +(assert (nil? (get-in t [:side :note])) "get-in with false value") +(assert (= (get-in t [:side :note] "dflt") "dflt") + "get-in with false value and default") + +# Evaluate stream with `dofile` +# 9cc4e4812 +(def [r w] (os/pipe)) +(:write w "(setdyn :x 10)") +(:close w) +(def stream-env (dofile r)) +(assert (= (stream-env :x) 10) "dofile stream 1") + +# Test thaw and freeze +# 9cc0645a1 +(def table-to-freeze @{:c 22 :b [1 2 3 4] :d @"test" :e "test2"}) +(def table-to-freeze-with-inline-proto + @{:a @[1 2 3] :b @[1 2 3 4] :c 22 :d @"test" :e @"test2"}) +(def struct-to-thaw + (struct/with-proto {:a [1 2 3]} :c 22 :b [1 2 3 4] :d "test" :e "test2")) +(table/setproto table-to-freeze @{:a @[1 2 3]}) + +(assert (deep= {:a [1 2 3] :b [1 2 3 4] :c 22 :d "test" :e "test2"} + (freeze table-to-freeze))) +(assert (deep= table-to-freeze-with-inline-proto (thaw table-to-freeze))) +(assert (deep= table-to-freeze-with-inline-proto (thaw struct-to-thaw))) + +# Make sure Carriage Returns don't end up in doc strings +# e528b86 +(assert (not (string/find "\r" + (get ((fiber/getenv (fiber/current)) 'cond) + :doc ""))) + "no \\r in doc strings") + +# cff718f37 +(var counter 0) +(def thunk (delay (++ counter))) +(assert (= (thunk) 1) "delay 1") +(assert (= counter 1) "delay 2") +(assert (= (thunk) 1) "delay 3") +(assert (= counter 1) "delay 4") + +(end-suite) + diff --git a/test/suite-buffer.janet b/test/suite-buffer.janet new file mode 100644 index 00000000..4c6e0b48 --- /dev/null +++ b/test/suite-buffer.janet @@ -0,0 +1,105 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Buffer blitting +# 16ebb1118 +(def b (buffer/new-filled 100)) +(buffer/bit-set b 100) +(buffer/bit-clear b 100) +(assert (zero? (sum b)) "buffer bit set and clear") +(buffer/bit-toggle b 101) +(assert (= 32 (sum b)) "buffer bit set and clear") + +(def b2 @"hello world") + +(buffer/blit b2 "joyto ") +(assert (= (string b2) "joyto world") "buffer/blit 1") + +(buffer/blit b2 "joyto" 6) +(assert (= (string b2) "joyto joyto") "buffer/blit 2") + +(buffer/blit b2 "abcdefg" 5 6) +(assert (= (string b2) "joytogjoyto") "buffer/blit 3") + +# Buffer push word +# e755f9830 +(def b3 @"") +(buffer/push-word b3 0xFF 0x11) +(assert (= 8 (length b3)) "buffer/push-word 1") +(assert (= "\xFF\0\0\0\x11\0\0\0" (string b3)) "buffer/push-word 2") +(buffer/clear b3) +(buffer/push-word b3 0xFFFFFFFF 0x1100) +(assert (= 8 (length b3)) "buffer/push-word 3") +(assert (= "\xFF\xFF\xFF\xFF\0\x11\0\0" (string b3)) "buffer/push-word 4") + +# Buffer push string +# 175925207 +(def b4 (buffer/new-filled 10 0)) +(buffer/push-string b4 b4) +(assert (= "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" (string b4)) + "buffer/push-buffer 1") +(def b5 @"123") +(buffer/push-string b5 "456" @"789") +(assert (= "123456789" (string b5)) "buffer/push-buffer 2") + +# some tests for buffer/format +# 029394d +(assert (= (string (buffer/format @"" "pi = %6.3f" math/pi)) "pi = 3.142") + "%6.3f") +(assert (= (string (buffer/format @"" "pi = %+6.3f" math/pi)) "pi = +3.142") + "%6.3f") +(assert (= (string (buffer/format @"" "pi = %40.20g" math/pi)) + "pi = 3.141592653589793116") "%6.3f") + +(assert (= (string (buffer/format @"" "🐼 = %6.3f" math/pi)) "🐼 = 3.142") + "UTF-8") +(assert (= (string (buffer/format @"" "π = %.8g" math/pi)) "π = 3.1415927") + "π") +(assert (= (string (buffer/format @"" "\xCF\x80 = %.8g" math/pi)) + "\xCF\x80 = 3.1415927") "\xCF\x80") + +# Regression #301 +# a3d4ecddb +(def b (buffer/new-filled 128 0x78)) +(assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1") + +(def a @"abcdefghijklm") +(assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2") +(assert (deep= @"bcde" (buffer/blit @"" a -1 1 5)) "buffer/blit 3") +(assert (deep= @"cde" (buffer/blit @"" a -1 2 5)) "buffer/blit 4") +(assert (deep= @"de" (buffer/blit @"" a -1 3 5)) "buffer/blit 5") + +# buffer/push-at +# c55d93512 +(assert (deep= @"abc456" (buffer/push-at @"abc123" 3 "456")) + "buffer/push-at 1") +(assert (deep= @"abc456789" (buffer/push-at @"abc123" 3 "456789")) + "buffer/push-at 2") +(assert (deep= @"abc423" (buffer/push-at @"abc123" 3 "4")) + "buffer/push-at 3") + +# 4782a76 +(assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing") + +(end-suite) + diff --git a/test/suite0013.janet b/test/suite-capi.janet similarity index 58% rename from test/suite0013.janet rename to test/suite-capi.janet index f64cee93..52f05433 100644 --- a/test/suite0013.janet +++ b/test/suite-capi.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2023 Calvin Rose & contributors +# Copyright (c) 2023 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to @@ -19,25 +19,26 @@ # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) -(start-suite 13) +(start-suite) -(assert (deep= (tabseq [i :in (range 3)] i (* 3 i)) - @{0 0 1 3 2 6})) +# Tuple types +# c6edf03ae +(assert (= (tuple/type '(1 2 3)) :parens) "normal tuple") +(assert (= (tuple/type [1 2 3]) :parens) "normal tuple 1") +(assert (= (tuple/type '[1 2 3]) :brackets) "bracketed tuple 2") +(assert (= (tuple/type (-> '(1 2 3) marshal unmarshal)) :parens) + "normal tuple marshalled/unmarshalled") +(assert (= (tuple/type (-> '[1 2 3] marshal unmarshal)) :brackets) + "normal tuple marshalled/unmarshalled") -(assert (deep= (tabseq [i :in (range 3)] i) - @{})) - -(def- sym-prefix-peg - (peg/compile - ~{:symchar (+ (range "\x80\xff" "AZ" "az" "09") (set "!$%&*+-./:@^_")) - :anchor (drop (cmt ($) ,|(= $ 0))) - :cap (* (+ (> -1 (not :symchar)) :anchor) (* ($) '(some :symchar))) - :recur (+ :cap (> -1 :recur)) - :main (> -1 :recur)})) - -(assert (deep= (peg/match sym-prefix-peg @"123" 3) @[0 "123"]) "peg lookback") -(assert (deep= (peg/match sym-prefix-peg @"1234" 4) @[0 "1234"]) "peg lookback 2") - -(assert (deep= (peg/replace-all '(* (<- 1) 1 (backmatch)) "xxx" "aba cdc efa") @"xxx xxx efa") "peg replace-all 1") +# Dynamic bindings +# 7918add47, 513d551d +(setdyn :a 10) +(assert (= 40 (with-dyns [:a 25 :b 15] (+ (dyn :a) (dyn :b)))) "dyn usage 1") +(assert (= 10 (dyn :a)) "dyn usage 2") +(assert (= nil (dyn :b)) "dyn usage 3") +(setdyn :a 100) +(assert (= 100 (dyn :a)) "dyn usage 4") (end-suite) + diff --git a/test/suite-cfuns.janet b/test/suite-cfuns.janet new file mode 100644 index 00000000..d06323bf --- /dev/null +++ b/test/suite-cfuns.janet @@ -0,0 +1,34 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Inline 3 argument get +# a1ea62a +(assert (= 10 (do (var a 10) (set a (get '{} :a a)))) "inline get 1") + +# Regression #24 +# f28477649 +(def t (put @{} :hi 1)) +(assert (deep= t @{:hi 1}) "regression #24") + +(end-suite) + diff --git a/test/suite-compile.janet b/test/suite-compile.janet new file mode 100644 index 00000000..e52c4057 --- /dev/null +++ b/test/suite-compile.janet @@ -0,0 +1,77 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Regression Test +# 0378ba78 +(assert (= 1 (((compile '(fn [] 1) @{})))) "regression test") + +# Fix a compiler bug in the do special form +# 3e1e2585 +(defn myfun [x] + (var a 10) + (set a (do + (def y x) + (if x 8 9)))) + +(assert (= (myfun true) 8) "check do form regression") +(assert (= (myfun false) 9) "check do form regression") + +# Check x:digits: works as symbol and not a hex number +# 5baf70f4 +(def x1 100) +(assert (= x1 100) "x1 as symbol") +(def X1 100) +(assert (= X1 100) "X1 as symbol") + +# Edge case should cause old compilers to fail due to +# if statement optimization +# 17283241 +(var var-a 1) +(var var-b (if false 2 (string "hello"))) + +(assert (= var-b "hello") "regression 1") + +# d28925fda +(assert (= (string '()) (string [])) "empty bracket tuple literal") + +# Bracket tuple issue +# 340a6c4 +(let [do 3] + (assert (= [3 1 2 3] [do 1 2 3]) "bracket tuples are never special forms")) +(assert (= ~(,defn 1 2 3) [defn 1 2 3]) "bracket tuples are never macros") +(assert (= ~(,+ 1 2 3) [+ 1 2 3]) "bracket tuples are never function calls") + +# Crash issue #1174 - bad debug info +# e97299f +(defn crash [] + (debug/stack (fiber/current))) +(do + (math/random) + (defn foo [_] + (crash) + 1) + (foo 0) + 10) + +(end-suite) + diff --git a/test/suite-corelib.janet b/test/suite-corelib.janet new file mode 100644 index 00000000..75753639 --- /dev/null +++ b/test/suite-corelib.janet @@ -0,0 +1,120 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# ac50f62 +(assert (= 10 (+ 1 2 3 4)) "addition") +(assert (= -8 (- 1 2 3 4)) "subtraction") +(assert (= 24 (* 1 2 3 4)) "multiplication") +# d6967a5 +(assert (= 4 (blshift 1 2)) "left shift") +(assert (= 1 (brshift 4 2)) "right shift") +# 7e46ead +(assert (< 1 2 3 4 5 6) "less than integers") +(assert (< 1.0 2.0 3.0 4.0 5.0 6.0) "less than reals") +(assert (> 6 5 4 3 2 1) "greater than integers") +(assert (> 6.0 5.0 4.0 3.0 2.0 1.0) "greater than reals") +(assert (<= 1 2 3 3 4 5 6) "less than or equal to integers") +(assert (<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "less than or equal to reals") +(assert (>= 6 5 4 4 3 2 1) "greater than or equal to integers") +(assert (>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "greater than or equal to reals") +(assert (= 7 (% 20 13)) "modulo 1") +(assert (= -7 (% -20 13)) "modulo 2") + +(assert (< 1.0 nil false true + (fiber/new (fn [] 1)) + "hi" + (quote hello) + :hello + (array 1 2 3) + (tuple 1 2 3) + (table "a" "b" "c" "d") + (struct 1 2 3 4) + (buffer "hi") + (fn [x] (+ x x)) + print) "type ordering") + +# b305a7c9b +(assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal") +# 277117165 +(assert (= (get {} 1) nil) "get nil from empty struct") +(assert (= (get @{} 1) nil) "get nil from empty table") +(assert (= (get {:boop :bap} :boop) :bap) "get non nil from struct") +(assert (= (get @{:boop :bap} :boop) :bap) "get non nil from table") +(assert (= (get @"\0" 0) 0) "get non nil from buffer") +(assert (= (get @"\0" 1) nil) "get nil from buffer oob") +(assert (put @{} :boop :bap) "can add to empty table") +(assert (put @{1 3} :boop :bap) "can add to non-empty table") +# 7e46ead +(assert (= 7 (bor 3 4)) "bit or") +(assert (= 0 (band 3 4)) "bit and") +# f41dab8 +(assert (= 0xFF (bxor 0x0F 0xF0)) "bit xor") +(assert (= 0xF0 (bxor 0xFF 0x0F)) "bit xor 2") + +# Some testing for not= +# 08f6c642d +(assert (not= 1 1 0) "not= 1") +(assert (not= 0 1 1) "not= 2") + +# Check if abstract test works +# d791077e2 +(assert (abstract? stdout) "abstract? stdout") +(assert (abstract? stdin) "abstract? stdin") +(assert (abstract? stderr) "abstract? stderr") +(assert (not (abstract? nil)) "not abstract? nil") +(assert (not (abstract? 1)) "not abstract? 1") +(assert (not (abstract? 3)) "not abstract? 3") +(assert (not (abstract? 5)) "not abstract? 5") + +# Module path expansion +# ff3bb6627 +(setdyn :current-file "some-dir/some-file") +(defn test-expand [path temp] + (string (module/expand-path path temp))) + +(assert (= (test-expand "abc" ":cur:/:all:") "some-dir/abc") + "module/expand-path 1") +(assert (= (test-expand "./abc" ":cur:/:all:") "some-dir/abc") + "module/expand-path 2") +(assert (= (test-expand "abc/def.txt" ":cur:/:name:") "some-dir/def.txt") + "module/expand-path 3") +(assert (= (test-expand "abc/def.txt" ":cur:/:dir:/sub/:name:") + "some-dir/abc/sub/def.txt") "module/expand-path 4") +# fc46030e7 +(assert (= (test-expand "/abc/../def.txt" ":all:") "/def.txt") + "module/expand-path 5") +(assert (= (test-expand "abc/../def.txt" ":all:") "def.txt") + "module/expand-path 6") +(assert (= (test-expand "../def.txt" ":all:") "../def.txt") + "module/expand-path 7") +(assert (= (test-expand "../././././abcd/../def.txt" ":all:") "../def.txt") + "module/expand-path 8") + +# module/expand-path regression +# issue #143 - e0fe8476a +(with-dyns [:syspath ".janet/.janet"] + (assert (= (string (module/expand-path "hello" ":sys:/:all:.janet")) + ".janet/.janet/hello.janet") "module/expand-path 1")) + +(end-suite) + diff --git a/test/suite-debug.janet b/test/suite-debug.janet new file mode 100644 index 00000000..3ed87e46 --- /dev/null +++ b/test/suite-debug.janet @@ -0,0 +1,34 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Simple function break +# a8afc5b81 +(debug/fbreak map 1) +(def f (fiber/new (fn [] (map inc [1 2 3])) :a)) +(resume f) +(assert (= :debug (fiber/status f)) "debug/fbreak") +(debug/unfbreak map 1) +(map inc [1 2 3]) + +(end-suite) + diff --git a/test/suite0009.janet b/test/suite-ev.janet similarity index 87% rename from test/suite0009.janet rename to test/suite-ev.janet index c0c26ab0..b2140f5f 100644 --- a/test/suite0009.janet +++ b/test/suite-ev.janet @@ -19,10 +19,10 @@ # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) -(start-suite 9) +(start-suite) # Subprocess - +# 5e1a8c86f (def janet (dyn :executable)) (repeat 10 @@ -30,18 +30,22 @@ (let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})] (os/proc-wait p) (def x (:read (p :out) :all)) - (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn pre close.")) + (assert (deep= "hello" (string/trim x)) + "capture stdout from os/spawn pre close.")) (let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})] (def x (:read (p :out) 1024)) (os/proc-wait p) - (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn post close.")) + (assert (deep= "hello" (string/trim x)) + "capture stdout from os/spawn post close.")) - (let [p (os/spawn [janet "-e" `(file/read stdin :line)`] :px {:in :pipe})] + (let [p (os/spawn [janet "-e" `(file/read stdin :line)`] :px + {:in :pipe})] (:write (p :in) "hello!\n") (assert-no-error "pipe stdin to process" (os/proc-wait p)))) -(let [p (os/spawn [janet "-e" `(print (file/read stdin :line))`] :px {:in :pipe :out :pipe})] +(let [p (os/spawn [janet "-e" `(print (file/read stdin :line))`] :px + {:in :pipe :out :pipe})] (:write (p :in) "hello!\n") (def x (:read (p :out) 1024)) (assert-no-error "pipe stdin to process 2" (os/proc-wait p)) @@ -58,11 +62,12 @@ (assert (not= retval 24) "Process was *not* terminated by parent")) # Parallel subprocesses - +# 5e1a8c86f (defn calc-1 "Run subprocess, read from stdout, then wait on subprocess." [code] - (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] + (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px + {:out :pipe})] (os/proc-wait p) (def output (:read (p :out) :all)) (parse output))) @@ -76,9 +81,13 @@ @[10 26 42]) "parallel subprocesses 1") (defn calc-2 - "Run subprocess, wait on subprocess, then read from stdout. Read only up to 10 bytes instead of :all" + `` + Run subprocess, wait on subprocess, then read from stdout. Read only up + to 10 bytes instead of :all + `` [code] - (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] + (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px + {:out :pipe})] (def output (:read (p :out) 10)) (os/proc-wait p) (parse output))) @@ -92,7 +101,7 @@ @[10 26 42]) "parallel subprocesses 2") # File piping - +# a1cc5ca04 (assert-no-error "file writing 1" (with [f (file/temp)] (os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f}))) @@ -102,8 +111,18 @@ (os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f}) (file/flush f))) -# each-line iterator +# Issue #593 +# a1cc5ca04 +(assert-no-error "file writing 3" + (def outfile (file/open "unique.txt" :w)) + (os/execute [janet "-e" "(pp (seq [i :range (1 10)] i))"] :p + {:out outfile}) + (file/flush outfile) + (file/close outfile) + (os/rm "unique.txt")) +# each-line iterator +# 70f13f1 (assert-no-error "file/lines iterator" (def outstream (os/open "unique.txt" :wct)) (def buf1 "123\n456\n") @@ -116,26 +135,20 @@ (assert (= buf1 buf2) "file/lines iterator") (os/rm "unique.txt")) -# Issue #593 -(assert-no-error "file writing 3" - (def outfile (file/open "unique.txt" :w)) - (os/execute [janet "-e" "(pp (seq [i :range (1 10)] i))"] :p {:out outfile}) - (file/flush outfile) - (file/close outfile) - (os/rm "unique.txt")) - # Ensure that the stream created by os/open works - +# e8a86013d (assert-no-error "File writing 4.1" (def outstream (os/open "unique.txt" :wct)) (defer (:close outstream) (:write outstream "123\n") (:write outstream "456\n")) # Cast to string to enable comparison - (assert (= "123\n456\n" (string (slurp "unique.txt"))) "File writing 4.2") + (assert (= "123\n456\n" (string (slurp "unique.txt"))) + "File writing 4.2") (os/rm "unique.txt")) # Test that the stream created by os/open can be read from +# 8d8a6534e (comment (assert-no-error "File reading 1.1" (def outstream (os/open "unique.txt" :wct)) @@ -145,17 +158,18 @@ (def outstream (os/open "unique.txt" :r)) (defer (:close outstream) - (assert (= "123\n456\n" (string (:read outstream :all))) "File reading 1.2")) + (assert (= "123\n456\n" (string (:read outstream :all))) + "File reading 1.2")) (os/rm "unique.txt"))) - # ev/gather - +# ev/gather +# 4f2d1cdc0 (assert (deep= @[1 2 3] (ev/gather 1 2 3)) "ev/gather 1") (assert (deep= @[] (ev/gather)) "ev/gather 2") (assert-error "ev/gather 3" (ev/gather 1 2 (error 3))) # Net testing - +# 2904c19ed (repeat 10 (defn handler @@ -184,6 +198,7 @@ (:close s)) # Test on both server and client +# 504411e (defn names-handler [stream] (defer (:close stream) @@ -194,6 +209,7 @@ (assert (= port 8000) "localname port server"))) # Test localname and peername +# 077bf5eba (repeat 10 (with [s (net/server "127.0.0.1" "8000" names-handler)] (repeat 10 @@ -206,7 +222,7 @@ (gccollect)) # Create pipe - +# 12f09ad2d (var pipe-counter 0) (def chan (ev/chan 10)) (let [[reader writer] (os/pipe)] @@ -222,6 +238,7 @@ (ev/close writer) (ev/take chan)) +# cff52ded5 (var result nil) (var fiber nil) (set fiber @@ -231,10 +248,11 @@ (ev/sleep 0) (ev/cancel fiber "boop") +# f0dbc2e (assert (os/execute [janet "-e" `(+ 1 2 3)`] :xp) "os/execute self") # Test some channel - +# e76b8da26 (def c1 (ev/chan)) (def c2 (ev/chan)) (def arr @[]) @@ -276,16 +294,17 @@ (assert (= (slice arr) (slice (range 100))) "ev/chan-close 3") # threaded channels - +# 868cdb9 (def ch (ev/thread-chan 2)) (def att (ev/thread-chan 109)) (assert att "`att` was nil after creation") (ev/give ch att) (ev/do-thread - (assert (ev/take ch) "channel packing bug for threaded abstracts on threaded channels.")) + (assert (ev/take ch) + "channel packing bug for threaded abstracts on threaded channels.")) # marshal channels - +# 76be8006a (def ch (ev/chan 10)) (ev/give ch "hello") (ev/give ch "world") @@ -296,3 +315,4 @@ (assert (= item2 "world")) (end-suite) + diff --git a/test/suite0012.janet b/test/suite-ffi.janet similarity index 87% rename from test/suite0012.janet rename to test/suite-ffi.janet index 267575ea..42fb95d4 100644 --- a/test/suite0012.janet +++ b/test/suite-ffi.janet @@ -19,19 +19,13 @@ # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) -(start-suite 12) - -(var counter 0) -(def thunk (delay (++ counter))) -(assert (= (thunk) 1) "delay 1") -(assert (= counter 1) "delay 2") -(assert (= (thunk) 1) "delay 3") -(assert (= counter 1) "delay 4") +(start-suite) # We should get ARM support... (def has-ffi (and (dyn 'ffi/native) (= (os/arch) :x64))) # FFI check +# d80356158 (compwhen has-ffi (ffi/context)) @@ -43,6 +37,7 @@ (memcpy buffer1 buffer2 4) (assert (= (string buffer1) "bbbb") "ffi 1 - memcpy")) +# cfaae47ce (compwhen has-ffi (assert (= 8 (ffi/size [:int :char])) "size unpacked struct 1") (assert (= 5 (ffi/size [:pack :int :char])) "size packed struct 1") @@ -50,7 +45,8 @@ (assert (= 4 (ffi/align [:int :char])) "align 1") (assert (= 1 (ffi/align [:pack :int :char])) "align 2") (assert (= 1 (ffi/align [:int :char :pack-all])) "align 3") - (assert (= 26 (ffi/size [:char :pack :int @[:char 21]])) "array struct size")) + (assert (= 26 (ffi/size [:char :pack :int @[:char 21]])) + "array struct size")) (end-suite) diff --git a/test/suite-inttypes.janet b/test/suite-inttypes.janet new file mode 100644 index 00000000..695bca1f --- /dev/null +++ b/test/suite-inttypes.janet @@ -0,0 +1,232 @@ +# Copyright (c) 2023 Calvin Rose & contributors +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# some tests for bigint +# 319575c +(def i64 int/s64) +(def u64 int/u64) + +(assert-no-error + "create some uint64 bigints" + (do + # from number + (def a (u64 10)) + # max double we can convert to int (2^53) + (def b (u64 0x1fffffffffffff)) + (def b (u64 (math/pow 2 53))) + # from string + (def c (u64 "0xffff_ffff_ffff_ffff")) + (def c (u64 "32rvv_vv_vv_vv")) + (def d (u64 "123456789")))) + +# Conversion back to an int32 +# 88db9751d +(assert (= (int/to-number (u64 0xFaFa)) 0xFaFa)) +(assert (= (int/to-number (i64 0xFaFa)) 0xFaFa)) +(assert (= (int/to-number (u64 9007199254740991)) 9007199254740991)) +(assert (= (int/to-number (i64 9007199254740991)) 9007199254740991)) +(assert (= (int/to-number (i64 -9007199254740991)) -9007199254740991)) + +(assert-error + "u64 out of bounds for safe integer" + (int/to-number (u64 "9007199254740993")) + + (assert-error + "s64 out of bounds for safe integer" + (int/to-number (i64 "-9007199254740993")))) + +(assert-error + "int/to-number fails on non-abstract types" + (int/to-number 1)) + +(assert-no-error + "create some int64 bigints" + (do + # from number + (def a (i64 -10)) + # max double we can convert to int (2^53) + (def b (i64 0x1fffffffffffff)) + (def b (i64 (math/pow 2 53))) + # from string + (def c (i64 "0x7fff_ffff_ffff_ffff")) + (def d (i64 "123456789")))) + +(assert-error + "bad initializers" + (do + # double to big to be converted to uint64 without truncation (2^53 + 1) + (def b (u64 (+ 0xffff_ffff_ffff_ff 1))) + (def b (u64 (+ (math/pow 2 53) 1))) + # out of range 65 bits + (def c (u64 "0x1ffffffffffffffff")) + # just to big + (def d (u64 "123456789123456789123456789")))) + +(assert (= (:/ (u64 "0xffff_ffff_ffff_ffff") 8 2) (u64 "0xfffffffffffffff")) + "bigint operations 1") +(assert (let [a (u64 0xff)] (= (:+ a a a a) (:* a 2 2))) + "bigint operations 2") + +# 5ae520a2c +(assert (= (string (i64 -123)) "-123") "i64 prints reasonably") +(assert (= (string (u64 123)) "123") "u64 prints reasonably") + +# 1db6d0e0b +(assert-error + "trap INT64_MIN / -1" + (:/ (int/s64 "-0x8000_0000_0000_0000") -1)) + +# int/s64 and int/u64 serialization +# 6aea7c7f7 +(assert (deep= (int/to-bytes (u64 0)) @"\x00\x00\x00\x00\x00\x00\x00\x00")) + +(assert (deep= (int/to-bytes (i64 1) :le) + @"\x01\x00\x00\x00\x00\x00\x00\x00")) +(assert (deep= (int/to-bytes (i64 1) :be) + @"\x00\x00\x00\x00\x00\x00\x00\x01")) +(assert (deep= (int/to-bytes (i64 -1)) + @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF")) +(assert (deep= (int/to-bytes (i64 -5) :be) + @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFB")) + +(assert (deep= (int/to-bytes (u64 1) :le) + @"\x01\x00\x00\x00\x00\x00\x00\x00")) +(assert (deep= (int/to-bytes (u64 1) :be) + @"\x00\x00\x00\x00\x00\x00\x00\x01")) +(assert (deep= (int/to-bytes (u64 300) :be) + @"\x00\x00\x00\x00\x00\x00\x01\x2C")) + +# int/s64 int/u64 to existing buffer +# bbb3e16fd +(let [buf1 @"" + buf2 @"abcd"] + (assert (deep= (int/to-bytes (i64 1) :le buf1) + @"\x01\x00\x00\x00\x00\x00\x00\x00")) + (assert (deep= buf1 @"\x01\x00\x00\x00\x00\x00\x00\x00")) + (assert (deep= (int/to-bytes (u64 300) :be buf2) + @"abcd\x00\x00\x00\x00\x00\x00\x01\x2C"))) + +# int/s64 and int/u64 paramater type checking +# 6aea7c7f7 +(assert-error + "bad value passed to int/to-bytes" + (int/to-bytes 1)) + +# 6aea7c7f7 +(assert-error + "invalid endianness passed to int/to-bytes" + (int/to-bytes (u64 0) :little)) + +# bbb3e16fd +(assert-error + "invalid buffer passed to int/to-bytes" + (int/to-bytes (u64 0) :little :buffer)) + +# Right hand operators +# 4fe005e3c +(assert (= (int/s64 (sum (range 10))) (sum (map int/s64 (range 10)))) + "right hand operators 1") +(assert (= (int/s64 + (product (range 1 10))) (product (map int/s64 (range 1 10)))) + "right hand operators 2") +(assert (= (int/s64 15) (bor 10 (int/s64 5)) (bor (int/s64 10) 5)) + "right hand operators 3") + +# Integer type checks +# 11067d7a5 +(assert (compare= 0 (- (int/u64 "1000") 1000)) "subtract from int/u64") + +(assert (odd? (int/u64 "1001")) "odd? 1") +(assert (not (odd? (int/u64 "1000"))) "odd? 2") +(assert (odd? (int/s64 "1001")) "odd? 3") +(assert (not (odd? (int/s64 "1000"))) "odd? 4") +(assert (odd? (int/s64 "-1001")) "odd? 5") +(assert (not (odd? (int/s64 "-1000"))) "odd? 6") + +(assert (even? (int/u64 "1000")) "even? 1") +(assert (not (even? (int/u64 "1001"))) "even? 2") +(assert (even? (int/s64 "1000")) "even? 3") +(assert (not (even? (int/s64 "1001"))) "even? 4") +(assert (even? (int/s64 "-1000")) "even? 5") +(assert (not (even? (int/s64 "-1001"))) "even? 6") + +# integer type operations +(defn modcheck [x y] + (assert (= (string (mod x y)) (string (mod (int/s64 x) y))) + (string "int/s64 (mod " x " " y ") expected " (mod x y) ", got " + (mod (int/s64 x) y))) + (assert (= (string (% x y)) (string (% (int/s64 x) y))) + (string "int/s64 (% " x " " y ") expected " (% x y) ", got " + (% (int/s64 x) y)))) + +(modcheck 1 2) +(modcheck 1 3) +(modcheck 4 2) +(modcheck 4 1) +(modcheck 10 3) +(modcheck 10 -3) +(modcheck -10 3) +(modcheck -10 -3) + +# Check for issue #1130 +# 7e65c2bda +(var d (int/s64 7)) +(mod 0 d) + +(var d (int/s64 7)) +(def result (seq [n :in (range -21 0)] (mod n d))) +(assert (deep= result + (map int/s64 @[0 1 2 3 4 5 6 0 1 2 3 4 5 6 0 1 2 3 4 5 6])) + "issue #1130") + +# issue #272 - 81d301a42 +(let [MAX_INT_64_STRING "9223372036854775807" + MAX_UINT_64_STRING "18446744073709551615" + MAX_INT_IN_DBL_STRING "9007199254740991" + NAN (math/log -1) + INF (/ 1 0) + MINUS_INF (/ -1 0) + compare-poly-tests + [[(int/s64 3) (int/u64 3) 0] + [(int/s64 -3) (int/u64 3) -1] + [(int/s64 3) (int/u64 2) 1] + [(int/s64 3) 3 0] [(int/s64 3) 4 -1] [(int/s64 3) -9 1] + [(int/u64 3) 3 0] [(int/u64 3) 4 -1] [(int/u64 3) -9 1] + [3 (int/s64 3) 0] [3 (int/s64 4) -1] [3 (int/s64 -5) 1] + [3 (int/u64 3) 0] [3 (int/u64 4) -1] [3 (int/u64 2) 1] + [(int/s64 MAX_INT_64_STRING) (int/u64 MAX_UINT_64_STRING) -1] + [(int/s64 MAX_INT_IN_DBL_STRING) + (scan-number MAX_INT_IN_DBL_STRING) 0] + [(int/u64 MAX_INT_IN_DBL_STRING) + (scan-number MAX_INT_IN_DBL_STRING) 0] + [(+ 1 (int/u64 MAX_INT_IN_DBL_STRING)) + (scan-number MAX_INT_IN_DBL_STRING) 1] + [(int/s64 0) INF -1] [(int/u64 0) INF -1] + [MINUS_INF (int/u64 0) -1] [MINUS_INF (int/s64 0) -1] + [(int/s64 1) NAN 0] [NAN (int/u64 1) 0]]] + (each [x y c] compare-poly-tests + (assert (= c (compare x y)) + (string/format "compare polymorphic %q %q %d" x y c)))) + +(end-suite) + diff --git a/test/suite-io.janet b/test/suite-io.janet new file mode 100644 index 00000000..dc16e3ee --- /dev/null +++ b/test/suite-io.janet @@ -0,0 +1,72 @@ +# Copyright (c) 2023 Calvin Rose & contributors +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Printing to buffers +# d47804d22 +(def out-buf @"") +(def err-buf @"") +(with-dyns [:out out-buf :err err-buf] + (print "Hello") + (prin "hi") + (eprint "Sup") + (eprin "not much.")) + +(assert (= (string out-buf) "Hello\nhi") "print and prin to buffer 1") +(assert (= (string err-buf) "Sup\nnot much.") + "eprint and eprin to buffer 1") + +# Printing to functions +# 4e263b8c3 +(def out-buf @"") +(defn prepend [x] + (with-dyns [:out out-buf] + (prin "> " x))) +(with-dyns [:out prepend] + (print "Hello world")) + +(assert (= (string out-buf) "> Hello world\n") + "print to buffer via function") + +# c2f844157, 3c523d66e +(with [f (file/temp)] + (assert (= 0 (file/tell f)) "start of file") + (file/write f "foo\n") + (assert (= 4 (file/tell f)) "after written string") + (file/flush f) + (file/seek f :set 0) + (assert (= 0 (file/tell f)) "start of file again") + (assert (= (string (file/read f :all)) "foo\n") "temp files work")) + +# issue #1055 - 2c927ea76 +(let [b @""] + (defn dummy [a b c] + (+ a b c)) + (trace dummy) + (defn errout [arg] + (buffer/push b arg)) + (assert (= 6 (with-dyns [*err* errout] (dummy 1 2 3))) + "trace to custom err function") + (assert (deep= @"trace (dummy 1 2 3)\n" b) "trace buffer correct")) + +(end-suite) + diff --git a/test/suite-marsh.janet b/test/suite-marsh.janet new file mode 100644 index 00000000..79196799 --- /dev/null +++ b/test/suite-marsh.janet @@ -0,0 +1,142 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Marshal + +# 98f2c6f +(def um-lookup (env-lookup (fiber/getenv (fiber/current)))) +(def m-lookup (invert um-lookup)) + +# 0cf10946b +(defn testmarsh [x msg] + (def marshx (marshal x m-lookup)) + (def out (marshal (unmarshal marshx um-lookup) m-lookup)) + (assert (= (string marshx) (string out)) msg)) + +(testmarsh nil "marshal nil") +(testmarsh false "marshal false") +(testmarsh true "marshal true") +(testmarsh 1 "marshal small integers") +(testmarsh -1 "marshal integers (-1)") +(testmarsh 199 "marshal small integers (199)") +(testmarsh 5000 "marshal medium integers (5000)") +(testmarsh -5000 "marshal small integers (-5000)") +(testmarsh 10000 "marshal large integers (10000)") +(testmarsh -10000 "marshal large integers (-10000)") +(testmarsh 1.0 "marshal double") +(testmarsh "doctordolittle" "marshal string") +(testmarsh :chickenshwarma "marshal symbol") +(testmarsh @"oldmcdonald" "marshal buffer") +(testmarsh @[1 2 3 4 5] "marshal array") +(testmarsh [tuple 1 2 3 4 5] "marshal tuple") +(testmarsh @{1 2 3 4} "marshal table") +(testmarsh {1 2 3 4} "marshal struct") +(testmarsh (fn [x] x) "marshal function 0") +(testmarsh (fn name [x] x) "marshal function 1") +(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2") +(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3") +(testmarsh map "marshal function 4") +(testmarsh reduce "marshal function 5") +(testmarsh (fiber/new (fn [] (yield 1) 2)) "marshal simple fiber 1") +(testmarsh (fiber/new (fn [&] (yield 1) 2)) "marshal simple fiber 2") + +# issue #53 - 1147482e6 +(def strct {:a @[nil]}) +(put (strct :a) 0 strct) +(testmarsh strct "cyclic struct") + +# More marshalling code +# issue #53 - 1147482e6 +(defn check-image + "Run a marshaling test using the make-image and load-image functions." + [x msg] + (def im (make-image x)) + # (printf "\nimage-hash: %d" (-> im string hash)) + (assert-no-error msg (load-image im))) + +(check-image (fn [] (fn [] 1)) "marshal nested functions") +(check-image (fiber/new (fn [] (fn [] 1))) + "marshal nested functions in fiber") +(check-image (fiber/new (fn [] (fiber/new (fn [] 1)))) + "marshal nested fibers") + +# issue #53 - f4908ebc4 +(def issue-53-x + (fiber/new + (fn [] + (var y (fiber/new (fn [] (print "1") (yield) (print "2"))))))) + +(check-image issue-53-x "issue 53 regression") + +# Marshal closure over non resumable fiber +# issue #317 - 7c4ffe9b9 +(do + (defn f1 + [a] + (defn f1 [] (++ (a 0))) + (defn f2 [] (++ (a 0))) + (error [f1 f2])) + (def [_ tup] (protect (f1 @[0]))) + (def [f1 f2] (unmarshal (marshal tup make-image-dict) load-image-dict)) + (assert (= 1 (f1)) "marshal-non-resumable-closure 1") + (assert (= 2 (f2)) "marshal-non-resumable-closure 2")) + +# Marshal closure over currently alive fiber +# issue #317 - 7c4ffe9b9 +(do + (defn f1 + [a] + (defn f1 [] (++ (a 0))) + (defn f2 [] (++ (a 0))) + (marshal [f1 f2] make-image-dict)) + (def [f1 f2] (unmarshal (f1 @[0]) load-image-dict)) + (assert (= 1 (f1)) "marshal-live-closure 1") + (assert (= 2 (f2)) "marshal-live-closure 2")) + +(do + (var a 1) + (defn b [x] (+ a x)) + (def c (unmarshal (marshal b))) + (assert (= 2 (c 1)) "marshal-on-stack-closure 1")) + +# Issue #336 cases - don't segfault +# b145d4786 +(assert-error "unmarshal errors 1" (unmarshal @"\xd6\xb9\xb9")) +(assert-error "unmarshal errors 2" (unmarshal @"\xd7bc")) +# 5bbd50785 +(assert-error "unmarshal errors 3" + (unmarshal "\xd3\x01\xd9\x01\x62\xcf\x03\x78\x79\x7a" + load-image-dict)) +# fcc610f53 +(assert-error "unmarshal errors 4" + (unmarshal + @"\xD7\xCD\0e/p\x98\0\0\x03\x01\x01\x01\x02\0\0\x04\0\xCEe/p../tools +\0\0\0/afl\0\0\x01\0erate\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE +\xA8\xDE\xDE\xDE\xDE\xDE\xDE\0\0\0\xDE\xDE_unmarshal_testcase3.ja +neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 +\0\0\0\0\0*\xFE\x01\04\x02\0\0'\x03\0\r\0\r\0\r\0\r" load-image-dict)) +# XXX: still needed? see 72beeeea +(gccollect) + +(end-suite) + diff --git a/test/suite-math.janet b/test/suite-math.janet new file mode 100644 index 00000000..235ecc43 --- /dev/null +++ b/test/suite-math.janet @@ -0,0 +1,69 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# First commit removing the integer number type +# 6b95326d7 +(assert (= 400 (math/sqrt 160000)) "sqrt(160000)=400") + +# RNGs +# aee168721 +(defn test-rng + [rng] + (assert (all identity (seq [i :range [0 1000]] + (<= (math/rng-int rng i) i))) "math/rng-int test") + (assert (all identity (seq [i :range [0 1000]] + (def x (math/rng-uniform rng)) + (and (>= x 0) (< x 1)))) + "math/rng-uniform test")) + +(def seedrng (math/rng 123)) +(for i 0 75 + (test-rng (math/rng (:int seedrng)))) + +# 70328437f +(assert (deep-not= (-> 123 math/rng (:buffer 16)) + (-> 456 math/rng (:buffer 16))) "math/rng-buffer 1") + +(assert-no-error "math/rng-buffer 2" (math/seedrandom "abcdefg")) + +# 027b2a8 +(defn assert-many [f n e] + (var good true) + (loop [i :range [0 n]] + (if (not (f)) + (set good false))) + (assert good e)) + +(assert-many (fn [] (>= 1 (math/random) 0)) 200 "(random) between 0 and 1") + +# 06aa0a124 +(assert (= (math/gcd 462 1071) 21) "math/gcd 1") +(assert (= (math/lcm 462 1071) 23562) "math/lcm 1") + +# math gamma +# e6babd8 +(assert (< 11899423.08 (math/gamma 11.5) 11899423.085) "math/gamma") +(assert (< 2605.1158 (math/log-gamma 500) 2605.1159) "math/log-gamma") + +(end-suite) + diff --git a/test/suite-os.janet b/test/suite-os.janet new file mode 100644 index 00000000..f88c997d --- /dev/null +++ b/test/suite-os.janet @@ -0,0 +1,133 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# OS Date test +# 719f7ba0c +(assert (deep= {:year-day 0 + :minutes 30 + :month 0 + :dst false + :seconds 0 + :year 2014 + :month-day 0 + :hours 20 + :week-day 3} + (os/date 1388608200)) "os/date") + +# OS mktime test +# 3ee43c3ab +(assert (= 1388608200 (os/mktime {:year-day 0 + :minutes 30 + :month 0 + :dst false + :seconds 0 + :year 2014 + :month-day 0 + :hours 20 + :week-day 3})) "os/mktime") + +(def now (os/time)) +(assert (= (os/mktime (os/date now)) now) "UTC os/mktime") +(assert (= (os/mktime (os/date now true) true) now) "local os/mktime") +(assert (= (os/mktime {:year 1970}) 0) "os/mktime default values") + +# OS strftime test +# 5cd729c4c +(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 0) "1970-01-01 00:00:00") + "strftime UTC epoch") +(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 1388608200) + "2014-01-01 20:30:00") + "strftime january 2014") +(assert (= (try (os/strftime "%%%d%t") ([err] err)) + "invalid conversion specifier '%t'") + "invalid conversion specifier") + +# 07db4c530 +(os/setenv "TESTENV1" "v1") +(os/setenv "TESTENV2" "v2") +(assert (= (os/getenv "TESTENV1") "v1") "getenv works") +(def environ (os/environ)) +(assert (= [(environ "TESTENV1") (environ "TESTENV2")] ["v1" "v2"]) + "environ works") + +# Ensure randomness puts n of pred into our buffer eventually +# 0ac5b243c +(defn cryptorand-check + [n pred] + (def max-attempts 10000) + (var attempts 0) + (while (not= attempts max-attempts) + (def cryptobuf (os/cryptorand 10)) + (when (= n (count pred cryptobuf)) + (break)) + (++ attempts)) + (not= attempts max-attempts)) + +(def v (math/rng-int (math/rng (os/time)) 100)) +(assert (cryptorand-check 0 |(= $ v)) "cryptorand skips value sometimes") +(assert (cryptorand-check 1 |(= $ v)) "cryptorand has value sometimes") + +(do + (def buf (buffer/new-filled 1)) + (os/cryptorand 1 buf) + (assert (= (in buf 0) 0) "cryptorand doesn't overwrite buffer") + (assert (= (length buf) 2) "cryptorand appends to buffer")) + +# 80db68210 +(assert-no-error (os/clock :realtime) "realtime clock") +(assert-no-error (os/clock :cputime) "cputime clock") +(assert-no-error (os/clock :monotonic) "monotonic clock") + +(def before (os/clock :monotonic)) +(def after (os/clock :monotonic)) +(assert (>= after before) "monotonic clock is monotonic") + +# Perm strings +# a0d61e45d +(assert (= (os/perm-int "rwxrwxrwx") 8r777) "perm 1") +(assert (= (os/perm-int "rwxr-xr-x") 8r755) "perm 2") +(assert (= (os/perm-int "rw-r--r--") 8r644) "perm 3") + +(assert (= (band (os/perm-int "rwxrwxrwx") 8r077) 8r077) "perm 4") +(assert (= (band (os/perm-int "rwxr-xr-x") 8r077) 8r055) "perm 5") +(assert (= (band (os/perm-int "rw-r--r--") 8r077) 8r044) "perm 6") + +(assert (= (os/perm-string 8r777) "rwxrwxrwx") "perm 7") +(assert (= (os/perm-string 8r755) "rwxr-xr-x") "perm 8") +(assert (= (os/perm-string 8r644) "rw-r--r--") "perm 9") + +# os/execute with environment variables +# issue #636 - 7e2c433ab +(assert (= 0 (os/execute [(dyn :executable) "-e" "(+ 1 2 3)"] :pe + (merge (os/environ) {"HELLO" "WORLD"}))) + "os/execute with env") + +# os/execute regressions +# 427f7c362 +(for i 0 10 + (assert (= i (os/execute [(dyn :executable) "-e" + (string/format "(os/exit %d)" i)] :p)) + (string "os/execute " i))) + +(end-suite) + diff --git a/test/suite-parse.janet b/test/suite-parse.janet new file mode 100644 index 00000000..aa091a61 --- /dev/null +++ b/test/suite-parse.janet @@ -0,0 +1,169 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# 7e46ead2f +(assert (not false) "false literal") +(assert true "true literal") +(assert (not nil) "nil literal") + +(assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand") + +# String literals +# 45f8db0 +(assert (= "abcd" "\x61\x62\x63\x64") "hex escapes") +(assert (= "\e" "\x1B") "escape character") +(assert (= "\x09" "\t") "tab character") + +# Long strings +# 7e6342720 +(assert (= "hello, world" `hello, world`) "simple long string") +(assert (= "hello, \"world\"" `hello, "world"`) + "long string with embedded quotes") +(assert (= "hello, \\\\\\ \"world\"" `hello, \\\ "world"`) + "long string with embedded quotes and backslashes") + +# +# Longstring indentation +# +# 7aa4241 +(defn reindent + "Reindent the contents of a longstring as the Janet parser would. + This include removing leading and trailing newlines." + [text indent] + + # Detect minimum indent + (var rewrite true) + (each index (string/find-all "\n" text) + (for i (+ index 1) (+ index indent 1) + (case (get text i) + nil (break) + (chr "\n") (break) + (chr " ") nil + (set rewrite false)))) + + # Only re-indent if no dedented characters. + (def str + (if rewrite + (peg/replace-all ~(* "\n" (between 0 ,indent " ")) "\n" text) + text)) + + (def first-nl (= (chr "\n") (first str))) + (def last-nl (= (chr "\n") (last str))) + (string/slice str (if first-nl 1 0) (if last-nl -2))) + +(defn reindent-reference + "Same as reindent but use parser functionality. Useful for + validating conformance." + [text indent] + (if (empty? text) (break text)) + (def source-code + (string (string/repeat " " indent) "``````" + text + "``````")) + (parse source-code)) + +(var indent-counter 0) +(defn check-indent + [text indent] + (++ indent-counter) + (let [a (reindent text indent) + b (reindent-reference text indent)] + (assert (= a b) + (string "indent " indent-counter " (indent=" indent ")")))) + +(check-indent "" 0) +(check-indent "\n" 0) +(check-indent "\n" 1) +(check-indent "\n\n" 0) +(check-indent "\n\n" 1) +(check-indent "\nHello, world!" 0) +(check-indent "\nHello, world!" 1) +(check-indent "Hello, world!" 0) +(check-indent "Hello, world!" 1) +(check-indent "\n Hello, world!" 4) +(check-indent "\n Hello, world!\n" 4) +(check-indent "\n Hello, world!\n " 4) +(check-indent "\n Hello, world!\n " 4) +(check-indent "\n Hello, world!\n dedented text\n " 4) +(check-indent "\n Hello, world!\n indented text\n " 4) + +# Symbols with @ character +# d68eae9 +(def @ 1) +(assert (= @ 1) "@ symbol") +(def @-- 2) +(assert (= @-- 2) "@-- symbol") +(def @hey 3) +(assert (= @hey 3) "@hey symbol") + +# Parser clone +# 43520ac67 +(def p (parser/new)) +(assert (= 7 (parser/consume p "(1 2 3 ")) "parser 1") +(def p2 (parser/clone p)) +(parser/consume p2 ") 1 ") +(parser/consume p ") 1 ") +(assert (deep= (parser/status p) (parser/status p2)) "parser 2") +(assert (deep= (parser/state p) (parser/state p2)) "parser 3") + +# Parser errors +# 976dfc719 +(defn parse-error [input] + (def p (parser/new)) + (parser/consume p input) + (parser/error p)) + +# Invalid utf-8 sequences +(assert (not= nil (parse-error @"\xc3\x28")) "reject invalid utf-8 symbol") +(assert (not= nil (parse-error @":\xc3\x28")) "reject invalid utf-8 keyword") + +# Parser line and column numbers +# 77b79e989 +(defn parser-location [input &opt location] + (def p (parser/new)) + (parser/consume p input) + (if location + (parser/where p ;location) + (parser/where p))) + +(assert (= [1 7] (parser-location @"(+ 1 2)")) "parser location 1") +(assert (= [5 7] (parser-location @"(+ 1 2)" [5])) "parser location 2") +(assert (= [10 10] (parser-location @"(+ 1 2)" [10 10])) "parser location 3") + +# Issue #861 - should be valgrind clean +# 39c6be7cb +(def step1 "(a b c d)\n") +(def step2 "(a b)\n") +(def p1 (parser/new)) +(parser/state p1) +(parser/consume p1 step1) +(loop [v :iterate (parser/produce p1)]) +(parser/state p1) +(def p2 (parser/clone p1)) +(parser/state p2) +(parser/consume p2 step2) +(loop [v :iterate (parser/produce p2)]) +(parser/state p2) + +(end-suite) + diff --git a/test/suite-peg.janet b/test/suite-peg.janet new file mode 100644 index 00000000..4e3603b3 --- /dev/null +++ b/test/suite-peg.janet @@ -0,0 +1,664 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Peg + +# 83f4a11bf +(defn check-match + [pat text should-match] + (def result (peg/match pat text)) + (assert (= (not should-match) (not result)) + (string "check-match " text))) + +# 798c88b4c +(defn check-deep + [pat text what] + (def result (peg/match pat text)) + (assert (deep= result what) (string "check-deep " text))) + +# Just numbers +# 83f4a11bf +(check-match '(* 4 -1) "abcd" true) +(check-match '(* 4 -1) "abc" false) +(check-match '(* 4 -1) "abcde" false) + +# Simple pattern +# 83f4a11bf +(check-match '(* (some (range "az" "AZ")) -1) "hello" true) +(check-match '(* (some (range "az" "AZ")) -1) "hello world" false) +(check-match '(* (some (range "az" "AZ")) -1) "1he11o" false) +(check-match '(* (some (range "az" "AZ")) -1) "" false) + +# Pre compile +# ff0d3a008 +(def pegleg (peg/compile '{:item "abc" :main (* :item "," :item -1)})) + +(peg/match pegleg "abc,abc") + +# Bad Grammars +# 192705113 +(assert-error "peg/compile error 1" (peg/compile nil)) +(assert-error "peg/compile error 2" (peg/compile @{})) +(assert-error "peg/compile error 3" (peg/compile '{:a "abc" :b "def"})) +(assert-error "peg/compile error 4" (peg/compile '(blarg "abc"))) +(assert-error "peg/compile error 5" (peg/compile '(1 2 3))) + +# IP address +# 40845b5c1 +(def ip-address + '{:d (range "09") + :0-4 (range "04") + :0-5 (range "05") + :byte (+ + (* "25" :0-5) + (* "2" :0-4 :d) + (* "1" :d :d) + (between 1 2 :d)) + :main (* :byte "." :byte "." :byte "." :byte)}) + +(check-match ip-address "10.240.250.250" true) +(check-match ip-address "0.0.0.0" true) +(check-match ip-address "1.2.3.4" true) +(check-match ip-address "256.2.3.4" false) +(check-match ip-address "256.2.3.2514" false) + +# Substitution test with peg +# d7626f8c5 +(def grammar '(accumulate (any (+ (/ "dog" "purple panda") (<- 1))))) +(defn try-grammar [text] + (assert (= (string/replace-all "dog" "purple panda" text) + (0 (peg/match grammar text))) text)) + +(try-grammar "i have a dog called doug the dog. he is good.") +(try-grammar "i have a dog called doug the dog. he is a good boy.") +(try-grammar "i have a dog called doug the do") +(try-grammar "i have a dog called doug the dog") +(try-grammar "i have a dog called doug the dogg") +(try-grammar "i have a dog called doug the doggg") +(try-grammar "i have a dog called doug the dogggg") + +# Peg CSV test +# 798c88b4c +(def csv + '{:field (+ + (* `"` (% (any (+ (<- (if-not `"` 1)) + (* (constant `"`) `""`)))) `"`) + (<- (any (if-not (set ",\n") 1)))) + :main (* :field (any (* "," :field)) (+ "\n" -1))}) + +(defn check-csv + [str res] + (check-deep csv str res)) + +(check-csv "1,2,3" @["1" "2" "3"]) +(check-csv "1,\"2\",3" @["1" "2" "3"]) +(check-csv ``1,"1""",3`` @["1" "1\"" "3"]) + +# Nested Captures +# 798c88b4c +(def grmr '(capture (* (capture "a") (capture 1) (capture "c")))) +(check-deep grmr "abc" @["a" "b" "c" "abc"]) +(check-deep grmr "acc" @["a" "c" "c" "acc"]) + +# Functions in grammar +# 798c88b4c +(def grmr-triple ~(% (any (/ (<- 1) ,(fn [x] (string x x x)))))) +(check-deep grmr-triple "abc" @["aaabbbccc"]) +(check-deep grmr-triple "" @[""]) +(check-deep grmr-triple " " @[" "]) + +(def counter ~(/ (group (any (<- 1))) ,length)) +(check-deep counter "abcdefg" @[7]) + +# Capture Backtracking +# ff0d3a008 +(check-deep '(+ (* (capture "c") "d") "ce") "ce" @[]) + +# Matchtime capture +# 192705113 +(def scanner (peg/compile ~(cmt (capture (some 1)) ,scan-number))) + +(check-deep scanner "123" @[123]) +(check-deep scanner "0x86" @[0x86]) +(check-deep scanner "-1.3e-7" @[-1.3e-7]) +(check-deep scanner "123A" nil) + +# Recursive grammars +# 170e785b7 +(def g '{:main (+ (* "a" :main "b") "c")}) + +(check-match g "c" true) +(check-match g "acb" true) +(check-match g "aacbb" true) +(check-match g "aadbb" false) + +# Back reference +# d0ec89c7c +(def wrapped-string + ~{:pad (any "=") + :open (* "[" (<- :pad :n) "[") + :close (* "]" (cmt (* (-> :n) (<- :pad)) ,=) "]") + :main (* :open (any (if-not :close 1)) :close -1)}) + +(check-match wrapped-string "[[]]" true) +(check-match wrapped-string "[==[a]==]" true) +(check-match wrapped-string "[==[]===]" false) +(check-match wrapped-string "[[blark]]" true) +(check-match wrapped-string "[[bl[ark]]" true) +(check-match wrapped-string "[[bl]rk]]" true) +(check-match wrapped-string "[[bl]rk]] " false) +(check-match wrapped-string "[=[bl]]rk]=] " false) +(check-match wrapped-string "[=[bl]==]rk]=] " false) +(check-match wrapped-string "[===[]==]===]" true) + +(def janet-longstring + ~{:delim (some "`") + :open (capture :delim :n) + :close (cmt (* (not (> -1 "`")) (-> :n) (<- (backmatch :n))) ,=) + :main (* :open (any (if-not :close 1)) :close -1)}) + +(check-match janet-longstring "`john" false) +(check-match janet-longstring "abc" false) +(check-match janet-longstring "` `" true) +(check-match janet-longstring "` `" true) +(check-match janet-longstring "`` ``" true) +(check-match janet-longstring "``` `` ```" true) +(check-match janet-longstring "`` ```" false) +(check-match janet-longstring "`a``b`" false) + +# Line and column capture +# 776ce586b +(def line-col (peg/compile '(any (* (line) (column) 1)))) +(check-deep line-col "abcd" @[1 1 1 2 1 3 1 4]) +(check-deep line-col "" @[]) +(check-deep line-col "abcd\n" @[1 1 1 2 1 3 1 4 1 5]) +(check-deep line-col "abcd\nz" @[1 1 1 2 1 3 1 4 1 5 2 1]) + +# Backmatch +# 711fe64a5 +(def backmatcher-1 '(* (capture (any "x") :1) "y" (backmatch :1) -1)) + +(check-match backmatcher-1 "y" true) +(check-match backmatcher-1 "xyx" true) +(check-match backmatcher-1 "xxxxxxxyxxxxxxx" true) +(check-match backmatcher-1 "xyxx" false) +(check-match backmatcher-1 (string (string/repeat "x" 73) "y") false) +(check-match backmatcher-1 (string (string/repeat "x" 10000) "y") false) +(check-match backmatcher-1 (string (string/repeat "x" 10000) "y" + (string/repeat "x" 10000)) true) + +(def backmatcher-2 '(* '(any "x") "y" (backmatch) -1)) + +(check-match backmatcher-2 "y" true) +(check-match backmatcher-2 "xyx" true) +(check-match backmatcher-2 "xxxxxxxyxxxxxxx" true) +(check-match backmatcher-2 "xyxx" false) +(check-match backmatcher-2 (string (string/repeat "x" 73) "y") false) +(check-match backmatcher-2 (string (string/repeat "x" 10000) "y") false) +(check-match backmatcher-2 (string (string/repeat "x" 10000) "y" + (string/repeat "x" 10000)) true) + +(def longstring-2 '(* '(some "`") + (some (if-not (backmatch) 1)) + (backmatch) -1)) + +(check-match longstring-2 "`john" false) +(check-match longstring-2 "abc" false) +(check-match longstring-2 "` `" true) +(check-match longstring-2 "` `" true) +(check-match longstring-2 "`` ``" true) +(check-match longstring-2 "``` `` ```" true) +(check-match longstring-2 "`` ```" false) + +# Optional +# 4eeadd746 +(check-match '(* (opt "hi") -1) "" true) +(check-match '(* (opt "hi") -1) "hi" true) +(check-match '(* (opt "hi") -1) "no" false) +(check-match '(* (? "hi") -1) "" true) +(check-match '(* (? "hi") -1) "hi" true) +(check-match '(* (? "hi") -1) "no" false) + +# Drop +# b4934cedd +(check-deep '(drop '"hello") "hello" @[]) +(check-deep '(drop "hello") "hello" @[]) + +# Add bytecode verification for peg unmarshaling +# e88a9af2f +# This should be valgrind clean. +(var pegi 3) +(defn marshpeg [p] + (assert (-> p peg/compile marshal unmarshal) + (string "peg marshal " (++ pegi)))) +(marshpeg '(* 1 2 (set "abcd") "asdasd" (+ "." 3))) +(marshpeg '(% (* (+ 1 2 3) (* "drop" "bear") '"hi"))) +(marshpeg '(> 123 "abcd")) +(marshpeg '{:main (* 1 "hello" :main)}) +(marshpeg '(range "AZ")) +(marshpeg '(if-not "abcdf" 123)) +(marshpeg '(error ($))) +(marshpeg '(* "abcd" (constant :hi))) +(marshpeg ~(/ "abc" ,identity)) +(marshpeg '(if-not "abcdf" 123)) +(marshpeg ~(cmt "abcdf" ,identity)) +(marshpeg '(group "abc")) + +# Peg swallowing errors +# 159651117 +(assert (try (peg/match ~(/ '1 ,(fn [x] (nil x))) "x") ([err] err)) + "errors should not be swallowed") +(assert (try ((fn [x] (nil x))) ([err] err)) + "errors should not be swallowed 2") + +# Check for bad memoization (+ :a) should mean different things in +# different contexts +# 8bc8709d0 +(def redef-a + ~{:a "abc" + :c (+ :a) + :main (* :c {:a "def" :main (+ :a)} -1)}) + +(check-match redef-a "abcdef" true) +(check-match redef-a "abcabc" false) +(check-match redef-a "defdef" false) + +# 54a04b589 +(def redef-b + ~{:pork {:pork "beef" :main (+ -1 (* 1 :pork))} + :main :pork}) + +(check-match redef-b "abeef" true) +(check-match redef-b "aabeef" false) +(check-match redef-b "aaaaaa" false) + +# Integer parsing +# 45feb5548 +(check-deep '(int 1) "a" @[(chr "a")]) +(check-deep '(uint 1) "a" @[(chr "a")]) +(check-deep '(int-be 1) "a" @[(chr "a")]) +(check-deep '(uint-be 1) "a" @[(chr "a")]) +(check-deep '(int 1) "\xFF" @[-1]) +(check-deep '(uint 1) "\xFF" @[255]) +(check-deep '(int-be 1) "\xFF" @[-1]) +(check-deep '(uint-be 1) "\xFF" @[255]) +(check-deep '(int 2) "\xFF\x7f" @[0x7fff]) +(check-deep '(int-be 2) "\x7f\xff" @[0x7fff]) +(check-deep '(uint 2) "\xff\x7f" @[0x7fff]) +(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) +(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) +(check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" + @[(int/u64 0x7fff)]) +(check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" + @[(int/s64 0x7fff)]) +(check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/u64 0x7fff)]) +(check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/s64 0x7fff)]) + +(check-deep '(* (int 2) -1) "123" nil) + +# to/thru bug +# issue #640 - 742469a8b +(check-deep '(to -1) "aaaa" @[]) +(check-deep '(thru -1) "aaaa" @[]) +(check-deep ''(to -1) "aaaa" @["aaaa"]) +(check-deep ''(thru -1) "aaaa" @["aaaa"]) +(check-deep '(to "b") "aaaa" nil) +(check-deep '(thru "b") "aaaa" nil) + +# unref +# 96513665d +(def grammar + (peg/compile + ~{:main (* :tagged -1) + :tagged (unref (replace (* :open-tag :value :close-tag) ,struct)) + :open-tag (* (constant :tag) "<" (capture :w+ :tag-name) ">") + :value (* (constant :value) (group (any (+ :tagged :untagged)))) + :close-tag (* "") + :untagged (capture (any (if-not "<" 1)))})) +(check-deep grammar "

foobar

" + @[{:tag "p" :value @[{:tag "em" :value @["foobar"]}]}]) +(check-deep grammar "

foobar

" @[{:tag "p" :value @["foobar"]}]) + +# Using a large test grammar +# cf05ff610 +(def- specials {'fn true + 'var true + 'do true + 'while true + 'def true + 'splice true + 'set true + 'unquote true + 'quasiquote true + 'quote true + 'if true}) + +(defn- check-number [text] (and (scan-number text) text)) + +(defn capture-sym + [text] + (def sym (symbol text)) + [(if (or (root-env sym) (specials sym)) :coresym :symbol) text]) + +(def grammar + ~{:ws (set " \v\t\r\f\n\0") + :readermac (set "';~,") + :symchars (+ (range "09" "AZ" "az" "\x80\xFF") + (set "!$%&*+-./:@^_|")) + :token (some :symchars) + :hex (range "09" "af" "AF") + :escape (* "\\" (+ (set "ntrvzf0e\"\\") + (* "x" :hex :hex) + (error (constant "bad hex escape")))) + :comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment)) + :symbol (/ ':token ,capture-sym) + :keyword (/ '(* ":" (any :symchars)) (constant :keyword)) + :constant (/ '(+ "true" "false" "nil") (constant :constant)) + :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"") + :string (/ ':bytes (constant :string)) + :buffer (/ '(* "@" :bytes) (constant :string)) + :long-bytes {:delim (some "`") + :open (capture :delim :n) + :close (cmt (* (not (> -1 "`")) (-> :n) '(backmatch :n)) + ,=) + :main (drop (* :open (any (if-not :close 1)) :close))} + :long-string (/ ':long-bytes (constant :string)) + :long-buffer (/ '(* "@" :long-bytes) (constant :string)) + :number (/ (cmt ':token ,check-number) (constant :number)) + :raw-value (+ :comment :constant :number :keyword + :string :buffer :long-string :long-buffer + :parray :barray :ptuple :btuple :struct :dict :symbol) + :value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws)) + :root (any :value) + :root2 (any (* :value :value)) + :ptuple (* '"(" :root (+ '")" (error ""))) + :btuple (* '"[" :root (+ '"]" (error ""))) + :struct (* '"{" :root2 (+ '"}" (error ""))) + :parray (* '"@" :ptuple) + :barray (* '"@" :btuple) + :dict (* '"@" :struct) + :main (+ :root (error ""))}) + +(def p (peg/compile grammar)) + +# Just make sure is valgrind clean. +(def p (-> p make-image load-image)) + +(assert (peg/match p "abc") "complex peg grammar 1") +(assert (peg/match p "[1 2 3 4]") "complex peg grammar 2") + +### +### Compiling brainfuck to Janet. +### +# 20d5d560f +(def- bf-peg + "Peg for compiling brainfuck into a Janet source ast." + (peg/compile + ~{:+ (/ '(some "+") ,(fn [x] ~(+= (DATA POS) ,(length x)))) + :- (/ '(some "-") ,(fn [x] ~(-= (DATA POS) ,(length x)))) + :> (/ '(some ">") ,(fn [x] ~(+= POS ,(length x)))) + :< (/ '(some "<") ,(fn [x] ~(-= POS ,(length x)))) + :. (* "." (constant (prinf "%c" (get DATA POS)))) + :loop (/ (* "[" :main "]") ,(fn [& captures] + ~(while (not= (get DATA POS) 0) + ,;captures))) + :main (any (+ :s :loop :+ :- :> :< :.))})) + +(defn bf + "Run brainfuck." + [text] + (eval + ~(let [DATA (array/new-filled 100 0)] + (var POS 50) + ,;(peg/match bf-peg text)))) + +(defn test-bf + "Test some bf for expected output." + [input output] + (def b @"") + (with-dyns [:out b] + (bf input)) + (assert (= (string output) (string b)) + (string "bf input '" + input + "' failed, expected " + (describe output) + ", got " + (describe (string b)) + "."))) + +(test-bf (string "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]" + ">>.>---.+++++++..+++.>>.<-.<.+++.------.--------" + ".>>+.>++.") "Hello World!\n") + +(test-bf (string ">++++++++" + "[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]" + ">-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------" + ".>>.+++.------.--------.>+.>+.") + "Hello World!\n") + +(test-bf (string "+[+[<<<+>>>>]+<-<-<<<+<++]<<.<++.<++..+++.<<++.<---" + ".>>.>.+++.------.>-.>>--.") + "Hello, World!") + +# Regression test +# issue #300 - 714bd61d5 +# Just don't segfault +(assert (peg/match '{:main (replace "S" {"S" :spade})} "S7") + "regression #300") + +# Lenprefix rule +# 8b5bcaee3 +(def peg (peg/compile ~(* (lenprefix (/ (* '(any (if-not ":" 1)) ":") + ,scan-number) 1) -1))) + +(assert (peg/match peg "5:abcde") "lenprefix 1") +(assert (not (peg/match peg "5:abcdef")) "lenprefix 2") +(assert (not (peg/match peg "5:abcd")) "lenprefix 3") + +# Packet capture +# 8b5bcaee3 +(def peg2 + (peg/compile + ~{# capture packet length in tag :header-len + :packet-header (* (/ ':d+ ,scan-number :header-len) ":") + + # capture n bytes from a backref :header-len + :packet-body '(lenprefix (-> :header-len) 1) + + # header, followed by body, and drop the :header-len capture + :packet (/ (* :packet-header :packet-body) ,|$1) + + # any exact seqence of packets (no extra characters) + :main (* (any :packet) -1)})) + +(assert (deep= @["a" "bb" "ccc"] (peg/match peg2 "1:a2:bb3:ccc")) + "lenprefix 4") +(assert (deep= @["a" "bb" "cccccc"] (peg/match peg2 "1:a2:bb6:cccccc")) + "lenprefix 5") +(assert (= nil (peg/match peg2 "1:a2:bb:5:cccccc")) "lenprefix 6") +(assert (= nil (peg/match peg2 "1:a2:bb:7:cccccc")) "lenprefix 7") + +# Issue #412 +# 677737d34 +(assert (peg/match '(* "a" (> -1 "a") "b") "abc") + "lookhead does not move cursor") + +# 6d096551f +(def peg3 + ~{:main (* "(" (thru ")"))}) + +(def peg4 (peg/compile ~(* (thru "(") '(to ")")))) + +(assert (peg/match peg3 "(12345)") "peg thru 1") +(assert (not (peg/match peg3 " (12345)")) "peg thru 2") +(assert (not (peg/match peg3 "(12345")) "peg thru 3") + +(assert (= "abc" (0 (peg/match peg4 "123(abc)"))) "peg thru/to 1") +(assert (= "abc" (0 (peg/match peg4 "(abc)"))) "peg thru/to 2") +(assert (not (peg/match peg4 "123(abc")) "peg thru/to 3") + +# 86e12369b +(def peg5 (peg/compile [3 "abc"])) + +(assert (:match peg5 "abcabcabc") "repeat alias 1") +(assert (:match peg5 "abcabcabcac") "repeat alias 2") +(assert (not (:match peg5 "abcabc")) "repeat alias 3") + +# Peg find and find-all +# c26f57362 +(def p "/usr/local/bin/janet") +(assert (= (peg/find '"n/" p) 13) "peg find 1") +(assert (not (peg/find '"t/" p)) "peg find 2") +(assert (deep= (peg/find-all '"/" p) @[0 4 10 14]) "peg find-all") + +# Peg replace and replace-all +# e548e1f6e +(defn check-replacer + [x y z] + (assert (= (string/replace x y z) (string (peg/replace x y z))) + "replacer test replace") + (assert (= (string/replace-all x y z) (string (peg/replace-all x y z))) + "replacer test replace-all")) +(check-replacer "abc" "Z" "abcabcabcabasciabsabc") +(check-replacer "abc" "Z" "") +(check-replacer "aba" "ZZZZZZ" "ababababababa") +(check-replacer "aba" "" "ababababababa") + +# 485099fd6 +(check-replacer "aba" string/ascii-upper "ababababababa") +(check-replacer "aba" 123 "ababababababa") +(assert (= (string (peg/replace-all ~(set "ab") string/ascii-upper "abcaa")) + "ABcAA") + "peg/replace-all cfunction") +(assert (= (string (peg/replace-all ~(set "ab") |$ "abcaa")) + "abcaa") + "peg/replace-all function") + +# 9dc7e8ed3 +(defn peg-test [name f peg subst text expected] + (assert (= (string (f peg subst text)) expected) name)) + +(peg-test "peg/replace has access to captures" + peg/replace + ~(sequence "." (capture (set "ab"))) + (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) + ".a.b.c" + ".a -> A, .b.c") + +(peg-test "peg/replace-all has access to captures" + peg/replace-all + ~(sequence "." (capture (set "ab"))) + (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) + ".a.b.c" + ".a -> A, .b -> B, .c") + +# Peg bug +# eab5f67c5 +(assert (deep= @[] (peg/match '(any 1) @"")) "peg empty pattern 1") +(assert (deep= @[] (peg/match '(any 1) (buffer))) "peg empty pattern 2") +(assert (deep= @[] (peg/match '(any 1) "")) "peg empty pattern 3") +(assert (deep= @[] (peg/match '(any 1) (string))) "peg empty pattern 4") +(assert (deep= @[] (peg/match '(* "test" (any 1)) @"test")) + "peg empty pattern 5") +(assert (deep= @[] (peg/match '(* "test" (any 1)) (buffer "test"))) + "peg empty pattern 6") + +# number pattern +# cccbdc164 +(assert (deep= @[111] (peg/match '(number :d+) "111")) + "simple number capture 1") +(assert (deep= @[255] (peg/match '(number :w+) "0xff")) + "simple number capture 2") + +# Marshal and unmarshal pegs +# 446ab037b +(def p (-> "abcd" peg/compile marshal unmarshal)) +(assert (peg/match p "abcd") "peg marshal 1") +(assert (peg/match p "abcdefg") "peg marshal 2") +(assert (not (peg/match p "zabcdefg")) "peg marshal 3") + +# to/thru bug +# issue #971 - a895219d2 +(def pattern + (peg/compile + '{:dd (sequence :d :d) + :sep (set "/-") + :date (sequence :dd :sep :dd) + :wsep (some (set " \t")) + :entry (group (sequence (capture :date) :wsep (capture :date))) + :main (some (thru :entry))})) + +(def alt-pattern + (peg/compile + '{:dd (sequence :d :d) + :sep (set "/-") + :date (sequence :dd :sep :dd) + :wsep (some (set " \t")) + :entry (group (sequence (capture :date) :wsep (capture :date))) + :main (some (choice :entry 1))})) + +(def text "1800-10-818-9-818 16/12\n17/12 19/12\n20/12 11/01") +(assert (deep= (peg/match pattern text) (peg/match alt-pattern text)) + "to/thru bug #971") + +# 14657a7 +(def- sym-prefix-peg + (peg/compile + ~{:symchar (+ (range "\x80\xff" "AZ" "az" "09") + (set "!$%&*+-./:@^_")) + :anchor (drop (cmt ($) ,|(= $ 0))) + :cap (* (+ (> -1 (not :symchar)) :anchor) (* ($) '(some :symchar))) + :recur (+ :cap (> -1 :recur)) + :main (> -1 :recur)})) + +(assert (deep= (peg/match sym-prefix-peg @"123" 3) @[0 "123"]) + "peg lookback") +(assert (deep= (peg/match sym-prefix-peg @"1234" 4) @[0 "1234"]) + "peg lookback 2") + +# issue #1027 - 356b39c6f +(assert (deep= (peg/replace-all '(* (<- 1) 1 (backmatch)) + "xxx" "aba cdc efa") + @"xxx xxx efa") + "peg replace-all 1") + +# issue #1026 - 9341081a4 +(assert (deep= + (peg/match '(not (* (constant 7) "a")) "hello") + @[]) "peg not") + +(assert (deep= + (peg/match '(if-not (* (constant 7) "a") "hello") "hello") + @[]) "peg if-not") + +(assert (deep= + (peg/match '(if-not (drop (* (constant 7) "a")) "hello") "hello") + @[]) "peg if-not drop") + +(assert (deep= + (peg/match '(if (not (* (constant 7) "a")) "hello") "hello") + @[]) "peg if not") + +(end-suite) + diff --git a/test/suite-pp.janet b/test/suite-pp.janet new file mode 100644 index 00000000..153cff09 --- /dev/null +++ b/test/suite-pp.janet @@ -0,0 +1,65 @@ +# Copyright (c) 2023 Calvin Rose & contributors +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Appending buffer to self +# 6b76ac3d1 +(with-dyns [:out @""] + (prin "abcd") + (prin (dyn :out)) + (prin (dyn :out)) + (assert (deep= (dyn :out) @"abcdabcdabcdabcd") "print buffer to self")) + +# Buffer self blitting, check for use after free +# bbcfaf128 +(def buf1 @"1234567890") +(buffer/blit buf1 buf1 -1) +(buffer/blit buf1 buf1 -1) +(buffer/blit buf1 buf1 -1) +(buffer/blit buf1 buf1 -1) +(assert (= (string buf1) (string/repeat "1234567890" 16)) + "buffer blit against self") + +# Check for bugs with printing self with buffer/format +# bbcfaf128 +(def buftemp @"abcd") +(assert (= (string (buffer/format buftemp "---%p---" buftemp)) + `abcd---@"abcd"---`) "buffer/format on self 1") +(def buftemp @"abcd") +(assert (= (string (buffer/format buftemp "---%p %p---" buftemp buftemp)) + `abcd---@"abcd" @"abcd"---`) "buffer/format on self 2") + +# 5c364e0 +(defn check-jdn [x] + (assert (deep= (parse (string/format "%j" x)) x) "round trip jdn")) + +(check-jdn 0) +(check-jdn nil) +(check-jdn []) +(check-jdn @[[] [] 1231 9.123123 -123123 0.1231231230001]) +(check-jdn -0.123123123123) +(check-jdn 12837192371923) +(check-jdn "a string") +(check-jdn @"a buffer") + +(end-suite) + diff --git a/test/suite-specials.janet b/test/suite-specials.janet new file mode 100644 index 00000000..288a1485 --- /dev/null +++ b/test/suite-specials.janet @@ -0,0 +1,202 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Regression Test #137 +# affcb5b45 +(def [a b c] (range 10)) +(assert (= a 0) "regression #137 (1)") +(assert (= b 1) "regression #137 (2)") +(assert (= c 2) "regression #137 (3)") + +(var [x y z] (range 10)) +(assert (= x 0) "regression #137 (4)") +(assert (= y 1) "regression #137 (5)") +(assert (= z 2) "regression #137 (6)") + +# Test destructuring +# 23dcfb986 +(do + (def test-tab @{:a 1 :b 2}) + (def {:a a :b b} test-tab) + (assert (= a 1) "dictionary destructuring 1") + (assert (= b 2) "dictionary destructuring 2")) +(do + (def test-tab @{'a 1 'b 2 3 4}) + (def {'a a 'b b (+ 1 2) c} test-tab) + (assert (= a 1) "dictionary destructuring 3") + (assert (= b 2) "dictionary destructuring 4") + (assert (= c 4) "dictionary destructuring 5 - expression as key")) + +# cb5af974a +(let [test-tuple [:a :b 1 2]] + (def [a b one two] test-tuple) + (assert (= a :a) "tuple destructuring 1") + (assert (= b :b) "tuple destructuring 2") + (assert (= two 2) "tuple destructuring 3")) +(let [test-tuple [:a :b 1 2]] + (def [a & rest] test-tuple) + (assert (= a :a) "tuple destructuring 4 - rest") + (assert (= rest [:b 1 2]) "tuple destructuring 5 - rest")) +(do + (def [a b & rest] [:a :b nil :d]) + (assert (= a :a) "tuple destructuring 6 - rest") + (assert (= b :b) "tuple destructuring 7 - rest") + (assert (= rest [nil :d]) "tuple destructuring 8 - rest")) + +# 71cffc973 +(do + (def [[a b] x & rest] [[1 2] :a :c :b :a]) + (assert (= a 1) "tuple destructuring 9 - rest") + (assert (= b 2) "tuple destructuring 10 - rest") + (assert (= x :a) "tuple destructuring 11 - rest") + (assert (= rest [:c :b :a]) "tuple destructuring 12 - rest")) + +# 651e12cfe +(do + (def [a b & rest] [:a :b]) + (assert (= a :a) "tuple destructuring 13 - rest") + (assert (= b :b) "tuple destructuring 14 - rest") + (assert (= rest []) "tuple destructuring 15 - rest")) + +(do + (def [[a b & r1] c & r2] [[:a :b 1 2] :c 3 4]) + (assert (= a :a) "tuple destructuring 16 - rest") + (assert (= b :b) "tuple destructuring 17 - rest") + (assert (= c :c) "tuple destructuring 18 - rest") + (assert (= r1 [1 2]) "tuple destructuring 19 - rest") + (assert (= r2 [3 4]) "tuple destructuring 20 - rest")) + +# Metadata +# ec2d7bf34 +(def foo-with-tags :a-tag :bar) +(assert (get (dyn 'foo-with-tags) :a-tag) + "extra keywords in def are metadata tags") + +(def foo-with-meta {:baz :quux} :bar) +(assert (= :quux (get (dyn 'foo-with-meta) :baz)) + "extra struct in def is metadata") + +(defn foo-fn-with-meta {:baz :quux} + "This is a function" + [x] + (identity x)) +(assert (= :quux (get (dyn 'foo-fn-with-meta) :baz)) + "extra struct in defn is metadata") +(assert (= "(foo-fn-with-meta x)\n\nThis is a function" + (get (dyn 'foo-fn-with-meta) :doc)) + "extra string in defn is docstring") + +# Break +# 4a111b38b +(var summation 0) +(for i 0 10 + (+= summation i) + (if (= i 7) (break))) +(assert (= summation 28) "break 1") + +(assert (= nil ((fn [] (break) 4))) "break 2") + +# Break with value +# 8ba112116 +# Shouldn't error out +(assert-no-error "break 3" (for i 0 10 (if (> i 8) (break i)))) +(assert-no-error "break 4" ((fn [i] (if (> i 8) (break i))) 100)) + +# No useless splices +# 7d57f8700 +(check-compile-error '((splice [1 2 3]) 0)) +(check-compile-error '(if ;[1 2] 5)) +(check-compile-error '(while ;[1 2 3] (print :hi))) +(check-compile-error '(def x ;[1 2 3])) +(check-compile-error '(fn [x] ;[x 1 2 3])) + +# No splice propagation +(check-compile-error '(+ 1 (do ;[2 3 4]) 5)) +(check-compile-error '(+ 1 (upscope ;[2 3 4]) 5)) +# compiler inlines when condition is constant, ensure that optimization +# doesn't break +(check-compile-error '(+ 1 (if true ;[3 4]))) +(check-compile-error '(+ 1 (if false nil ;[3 4]))) + +# Keyword arguments +# 3f137ed0b +(defn myfn [x y z &keys {:a a :b b :c c}] + (+ x y z a b c)) + +(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 3 :b 4 :c 5)) "keyword args 1") +(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 1 :b 6 :c 5 :d 11)) + "keyword args 2") + +# Named arguments +# 87fc339 +(defn named-arguments + [&named bob sally joe] + (+ bob sally joe)) + +(assert (= 15 (named-arguments :bob 3 :sally 5 :joe 7)) "named arguments 1") + +# a117252 +(defn named-opt-arguments + [&opt x &named a b c] + (+ x a b c)) + +(assert (= 10 (named-opt-arguments 1 :a 2 :b 3 :c 4)) "named arguments 2") + +# +# fn compilation special +# +# b8032ec61 +(defn myfn1 [[x y z] & more] + more) +(defn myfn2 [head & more] + more) +(assert (= (myfn1 [1 2 3] 4 5 6) (myfn2 [:a :b :c] 4 5 6)) + "destructuring and varargs") + +# Nested quasiquotation +# 4199c42fe +(def nested ~(a ~(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) +(assert (deep= nested '(a ~(b ,(+ 1 2) ,(foo 4 d) e) f)) + "nested quasiquote") + +# Regression #400 +# 7a84fc474 +(assert (= nil (while (and false false) + (fn []) + (error "should not happen"))) "strangeloop 1") +(assert (= nil (while (not= nil nil) + (fn []) + (error "should not happen"))) "strangeloop 2") + +# 919 +# a097537a0 +(defn test + [] + (var x 1) + (set x ~(,x ())) + x) + +(assert (= (test) '(1 ())) "issue #919") + +(end-suite) + diff --git a/test/suite0002.janet b/test/suite-string.janet similarity index 52% rename from test/suite0002.janet rename to test/suite-string.janet index bb249298..43774f2d 100644 --- a/test/suite0002.janet +++ b/test/suite-string.janet @@ -19,48 +19,20 @@ # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) -(start-suite 2) +(start-suite) -# Buffer stuff -(defn buffer= - [a b] - (= (string a) (string b))) +# 8a346ec +(assert (= (string/join @["one" "two" "three"]) "onetwothree") + "string/join 1 argument") +(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") + "string/join 2 arguments") +(assert (= (string/join @[] ", ") "") "string/join empty array") -(assert (buffer= @"abcd" @"abcd") "buffer equal 1") -(assert (buffer= @"abcd" (buffer "ab" "cd")) "buffer equal 2") -(assert (not= @"" @"") "buffer not equal 1") -(assert (not= @"abcd" @"abcd") "buffer not equal 2") - -(defn buffer-factory - [] - @"im am a buffer") - -(assert (not= (buffer-factory) (buffer-factory)) "buffer instantiation") - -(assert (= (length @"abcdef") 6) "buffer length") - -# Looping idea -(def xs - (seq [x :in [-1 0 1] y :in [-1 0 1] :when (not= x y 0)] (tuple x y))) -(def txs (apply tuple xs)) - -(assert (= txs [[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) "nested seq") - -# Generators -(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x)) -(var gencount 0) -(loop [x :in gen] - (++ gencount) - (assert (pos? (% x 4)) "generate in loop")) -(assert (= gencount 75) "generate loop count") - -# Check x:digits: works as symbol and not a hex number -(def x1 100) -(assert (= x1 100) "x1 as symbol") -(def X1 100) -(assert (= X1 100) "X1 as symbol") +(assert (= (string/find "123" "abc123def") 3) "string/find positive") +(assert (= (string/find "1234" "abc123def") nil) "string/find negative") # String functions +# f41dab8f6 (assert (= 3 (string/find "abc" " abcdefghijklmnop")) "string/find 1") (assert (= 0 (string/find "A" "A")) "string/find 2") (assert (string/has-prefix? "" "foo") "string/has-prefix? 1") @@ -69,52 +41,100 @@ (assert (string/has-suffix? "" "foo") "string/has-suffix? 1") (assert (string/has-suffix? "oo" "foo") "string/has-suffix? 2") (assert (not (string/has-suffix? "f" "foo")) "string/has-suffix? 3") -(assert (= (string/replace "X" "." "XXX...XXX...XXX") ".XX...XXX...XXX") "string/replace 1") -(assert (= (string/replace-all "X" "." "XXX...XXX...XXX") "...............") "string/replace-all 1") -(assert (= (string/replace-all "XX" "." "XXX...XXX...XXX") ".X....X....X") "string/replace-all 2") -(assert (= (string/replace "xx" string/ascii-upper "xxyxyxyxxxy") "XXyxyxyxxxy") "string/replace function") -(assert (= (string/replace-all "xx" string/ascii-upper "xxyxyxyxxxy") "XXyxyxyXXxy") "string/replace-all function") -(assert (= (string/replace "x" 12 "xyx") "12yx") "string/replace stringable") -(assert (= (string/replace-all "x" 12 "xyx") "12y12") "string/replace-all stringable") -(assert (= (string/ascii-lower "ABCabc&^%!@:;.") "abcabc&^%!@:;.") "string/ascii-lower") -(assert (= (string/ascii-upper "ABCabc&^%!@:;.") "ABCABC&^%!@:;.") "string/ascii-lower") +(assert (= (string/replace "X" "." "XXX...XXX...XXX") ".XX...XXX...XXX") + "string/replace 1") +(assert (= (string/replace-all "X" "." "XXX...XXX...XXX") "...............") + "string/replace-all 1") +(assert (= (string/replace-all "XX" "." "XXX...XXX...XXX") ".X....X....X") + "string/replace-all 2") +(assert (= (string/replace "xx" string/ascii-upper "xxyxyxyxxxy") + "XXyxyxyxxxy") "string/replace function") +(assert (= (string/replace-all "xx" string/ascii-upper "xxyxyxyxxxy") + "XXyxyxyXXxy") "string/replace-all function") +(assert (= (string/replace "x" 12 "xyx") "12yx") + "string/replace stringable") +(assert (= (string/replace-all "x" 12 "xyx") "12y12") + "string/replace-all stringable") +(assert (= (string/ascii-lower "ABCabc&^%!@:;.") "abcabc&^%!@:;.") + "string/ascii-lower") +(assert (= (string/ascii-upper "ABCabc&^%!@:;.") "ABCABC&^%!@:;.") + "string/ascii-lower") (assert (= (string/reverse "") "") "string/reverse 1") (assert (= (string/reverse "a") "a") "string/reverse 2") (assert (= (string/reverse "abc") "cba") "string/reverse 3") (assert (= (string/reverse "abcd") "dcba") "string/reverse 4") -(assert (= (string/join @["one" "two" "three"] ",") "one,two,three") "string/join 1") -(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") "string/join 2") -(assert (= (string/join @["one" "two" "three"]) "onetwothree") "string/join 3") +(assert (= (string/join @["one" "two" "three"] ",") "one,two,three") + "string/join 1") +(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") + "string/join 2") +(assert (= (string/join @["one" "two" "three"]) "onetwothree") + "string/join 3") (assert (= (string/join @[] "hi") "") "string/join 4") (assert (= (string/trim " abcd ") "abcd") "string/trim 1") (assert (= (string/trim "abcd \t\t\r\f") "abcd") "string/trim 2") (assert (= (string/trim "\n\n\t abcd") "abcd") "string/trim 3") (assert (= (string/trim "") "") "string/trim 4") (assert (= (string/triml " abcd ") "abcd ") "string/triml 1") -(assert (= (string/triml "\tabcd \t\t\r\f") "abcd \t\t\r\f") "string/triml 2") +(assert (= (string/triml "\tabcd \t\t\r\f") "abcd \t\t\r\f") + "string/triml 2") (assert (= (string/triml "abcd ") "abcd ") "string/triml 3") (assert (= (string/trimr " abcd ") " abcd") "string/trimr 1") (assert (= (string/trimr "\tabcd \t\t\r\f") "\tabcd") "string/trimr 2") (assert (= (string/trimr " abcd") " abcd") "string/trimr 3") -(assert (deep= (string/split "," "one,two,three") @["one" "two" "three"]) "string/split 1") -(assert (deep= (string/split "," "onetwothree") @["onetwothree"]) "string/split 2") -(assert (deep= (string/find-all "e" "onetwothree") @[2 9 10]) "string/find-all 1") -(assert (deep= (string/find-all "," "onetwothree") @[]) "string/find-all 2") +(assert (deep= (string/split "," "one,two,three") @["one" "two" "three"]) + "string/split 1") +(assert (deep= (string/split "," "onetwothree") @["onetwothree"]) + "string/split 2") +(assert (deep= (string/find-all "e" "onetwothree") @[2 9 10]) + "string/find-all 1") +(assert (deep= (string/find-all "," "onetwothree") @[]) + "string/find-all 2") +# b26a7bb22 (assert-error "string/find error 1" (string/find "" "abcd")) (assert-error "string/split error 1" (string/split "" "abcd")) (assert-error "string/replace error 1" (string/replace "" "." "abcd")) -(assert-error "string/replace-all error 1" (string/replace-all "" "." "abcdabcd")) +(assert-error "string/replace-all error 1" + (string/replace-all "" "." "abcdabcd")) (assert-error "string/find-all error 1" (string/find-all "" "abcd")) -# Check if abstract test works -(assert (abstract? stdout) "abstract? stdout") -(assert (abstract? stdin) "abstract? stdin") -(assert (abstract? stderr) "abstract? stderr") -(assert (not (abstract? nil)) "not abstract? nil") -(assert (not (abstract? 1)) "not abstract? 1") -(assert (not (abstract? 3)) "not abstract? 3") -(assert (not (abstract? 5)) "not abstract? 5") +# String bugs +# bcba0c027 +(assert (deep= (string/find-all "qq" "qqq") @[0 1]) "string/find-all 1") +(assert (deep= (string/find-all "q" "qqq") @[0 1 2]) "string/find-all 2") +(assert (deep= (string/split "qq" "1qqqqz") @["1" "" "z"]) "string/split 1") +(assert (deep= (string/split "aa" "aaa") @["" "a"]) "string/split 2") + +# some tests for string/format +# 0f0c415 +(assert (= (string/format "pi = %6.3f" math/pi) "pi = 3.142") "%6.3f") +(assert (= (string/format "pi = %+6.3f" math/pi) "pi = +3.142") "%6.3f") +(assert (= (string/format "pi = %40.20g" math/pi) + "pi = 3.141592653589793116") "%6.3f") + +(assert (= (string/format "🐼 = %6.3f" math/pi) "🐼 = 3.142") "UTF-8") +(assert (= (string/format "π = %.8g" math/pi) "π = 3.1415927") "π") +(assert (= (string/format "\xCF\x80 = %.8g" math/pi) "\xCF\x80 = 3.1415927") + "\xCF\x80") + +# String check-set +# b4e25e559 +(assert (string/check-set "abc" "a") "string/check-set 1") +(assert (not (string/check-set "abc" "z")) "string/check-set 2") +(assert (string/check-set "abc" "abc") "string/check-set 3") +(assert (string/check-set "abc" "") "string/check-set 4") +(assert (not (string/check-set "" "aabc")) "string/check-set 5") +(assert (not (string/check-set "abc" "abcdefg")) "string/check-set 6") + +# Trim empty string +# issue #174 - 9b605b27b +(assert (= "" (string/trim " ")) "string/trim regression") + +# Keyword and Symbol slice +# e9911fee4 +(assert (= :keyword (keyword/slice "some_keyword_slice" 5 12)) + "keyword slice") +(assert (= 'symbol (symbol/slice "some_symbol_slice" 5 11)) "symbol slice") (end-suite) diff --git a/test/suite-strtod.janet b/test/suite-strtod.janet new file mode 100644 index 00000000..f693b808 --- /dev/null +++ b/test/suite-strtod.janet @@ -0,0 +1,44 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Scan number +# 798c88b4c +(assert (= 1 (scan-number "1")) "scan-number 1") +(assert (= -1 (scan-number "-1")) "scan-number -1") +(assert (= 1.3e4 (scan-number "1.3e4")) "scan-number 1.3e4") + +# Issue #183 - just parse it :) +# 688d297a1 +1e-4000000000000000000000 + +# For undefined behavior sanitizer +# c876e63 +0xf&1fffFFFF + +# off by 1 error in inttypes +# a3e812b86 +(assert (= (int/s64 "-0x8000_0000_0000_0000") + (+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around") + +(end-suite) + diff --git a/test/suite-struct.janet b/test/suite-struct.janet new file mode 100644 index 00000000..e51b22f6 --- /dev/null +++ b/test/suite-struct.janet @@ -0,0 +1,82 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# 21bd960 +(assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2)) + "struct order does not matter 1") +# 42a88de +(assert (= (struct + :apple 1 + 6 :bork + '(1 2 3) 5) + (struct + 6 :bork + '(1 2 3) 5 + :apple 1)) "struct order does not matter 2") + +# Denormal structs +# 38a7e4faf +(assert (= (length {1 2 nil 3}) 1) "nil key struct literal") +(assert (= (length (struct 1 2 nil 3)) 1) "nil key struct ctor") + +(assert (= (length (struct (/ 0 0) 2 1 3)) 1) "nan key struct ctor") +(assert (= (length {1 2 (/ 0 0) 3}) 1) "nan key struct literal") + +(assert (= (length (struct 2 1 3 nil)) 1) "nil value struct ctor") +(assert (= (length {1 2 3 nil}) 1) "nil value struct literal") + +# Struct duplicate elements +# 8bc2987a7 +(assert (= {:a 3 :b 2} {:a 1 :b 2 :a 3}) "struct literal duplicate keys") +(assert (= {:a 3 :b 2} (struct :a 1 :b 2 :a 3)) + "struct constructor duplicate keys") + +# Struct prototypes +# 4d983e5 +(def x (struct/with-proto {1 2 3 4} 5 6)) +(def y (-> x marshal unmarshal)) +(def z {1 2 3 4}) +(assert (= 2 (get x 1)) "struct get proto value 1") +(assert (= 4 (get x 3)) "struct get proto value 2") +(assert (= 6 (get x 5)) "struct get proto value 3") +(assert (= x y) "struct proto marshal equality 1") +(assert (= (getproto x) (getproto y)) "struct proto marshal equality 2") +(assert (= 0 (cmp x y)) "struct proto comparison 1") +(assert (= 0 (cmp (getproto x) (getproto y))) "struct proto comparison 2") +(assert (not= (cmp x z) 0) "struct proto comparison 3") +(assert (not= (cmp y z) 0) "struct proto comparison 4") +(assert (not= x z) "struct proto comparison 5") +(assert (not= y z) "struct proto comparison 6") +(assert (= (x 5) 6) "struct proto get 1") +(assert (= (y 5) 6) "struct proto get 1") +(assert (deep= x y) "struct proto deep= 1") +(assert (deep-not= x z) "struct proto deep= 2") +(assert (deep-not= y z) "struct proto deep= 3") + +# Check missing struct proto bug +# 868ec1a7e, e08394c8 +(assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil)) + "missing struct proto") + +(end-suite) + diff --git a/test/suite-symcache.janet b/test/suite-symcache.janet new file mode 100644 index 00000000..8ad6d3a7 --- /dev/null +++ b/test/suite-symcache.janet @@ -0,0 +1,42 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Symbol function +# 5460ff1 +(assert (= (symbol "abc" 1 2 3) 'abc123) "symbol function") + +# Gensym tests +# 3ccd68843 +(assert (not= (gensym) (gensym)) "two gensyms not equal") +((fn [] + (def syms (table)) + (var counter 0) + (while (< counter 128) + (put syms (gensym) true) + (set counter (+ 1 counter))) + (assert (= (length syms) 128) "many symbols"))) + +# issue #753 - a78cbd91d +(assert (pos? (length (gensym))) "gensym not empty, regression #753") + +(end-suite) diff --git a/test/suite-table.janet b/test/suite-table.janet new file mode 100644 index 00000000..4234194b --- /dev/null +++ b/test/suite-table.janet @@ -0,0 +1,72 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Denormal tables +# 38a7e4faf +(assert (= (length @{1 2 nil 3}) 1) "nil key table literal") +(assert (= (length (table 1 2 nil 3)) 1) "nil key table ctor") + +(assert (= (length (table (/ 0 0) 2 1 3)) 1) "nan key table ctor") +(assert (= (length @{1 2 (/ 0 0) 3}) 1) "nan key table literal") + +(assert (= (length (table 2 1 3 nil)) 1) "nil value table ctor") +(assert (= (length @{1 2 3 nil}) 1) "nil value table literal") + +# Table duplicate elements +(assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys") +(assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3)) + "table constructor duplicate keys") + +## Table prototypes +# 027b2a81c +(def roottab @{ + :parentprop 123 +}) + +(def childtab @{ + :childprop 456 +}) + +(table/setproto childtab roottab) + +(assert (= 123 (get roottab :parentprop)) "table get 1") +(assert (= 123 (get childtab :parentprop)) "table get proto") +(assert (= nil (get roottab :childprop)) "table get 2") +(assert (= 456 (get childtab :childprop)) "proto no effect") + +# b3aed1356 +(assert-error + "table rawget regression" + (table/new -1)) + +# table/clone +# 392813667 +(defn check-table-clone [x msg] + (assert (= (table/to-struct x) (table/to-struct (table/clone x))) msg)) + +(check-table-clone @{:a 123 :b 34 :c :hello : 945 0 1 2 3 4 5} + "table/clone 1") +(check-table-clone @{} "table/clone 2") + +(end-suite) + diff --git a/test/suite-unknown.janet b/test/suite-unknown.janet new file mode 100644 index 00000000..58b6f9eb --- /dev/null +++ b/test/suite-unknown.janet @@ -0,0 +1,296 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# Set global variables to prevent some possible compiler optimizations +# that defeat point of the test +# 2771171 +(var zero 0) +(var one 1) +(var two 2) +(var three 3) +(var plus +) +(assert (= 22 (plus one (plus 1 2 two) (plus 8 (plus zero 1) 4 three))) + "nested function calls") + +# McCarthy's 91 function +# 2771171 +(var f91 nil) +(set f91 (fn [n] + (if (> n 100) + (- n 10) + (f91 (f91 (+ n 11)))))) +(assert (= 91 (f91 10)) "f91(10) = 91") +(assert (= 91 (f91 11)) "f91(11) = 91") +(assert (= 91 (f91 20)) "f91(20) = 91") +(assert (= 91 (f91 31)) "f91(31) = 91") +(assert (= 91 (f91 100)) "f91(100) = 91") +(assert (= 91 (f91 101)) "f91(101) = 91") +(assert (= 92 (f91 102)) "f91(102) = 92") +(assert (= 93 (f91 103)) "f91(103) = 93") +(assert (= 94 (f91 104)) "f91(104) = 94") + +# Fibonacci +# 23196ff +(def fib + (do + (var fib nil) + (set fib (fn [n] + (if (< n 2) + n + (+ (fib (- n 1)) (fib (- n 2)))))))) +(def fib2 + (fn fib2 [n] + (if (< n 2) + n + (+ (fib2 (- n 1)) (fib2 (- n 2)))))) + +(assert (= (fib 0) (fib2 0) 0) "fib(0)") +(assert (= (fib 1) (fib2 1) 1) "fib(1)") +(assert (= (fib 2) (fib2 2) 1) "fib(2)") +(assert (= (fib 3) (fib2 3) 2) "fib(3)") +(assert (= (fib 4) (fib2 4) 3) "fib(4)") +(assert (= (fib 5) (fib2 5) 5) "fib(5)") +(assert (= (fib 6) (fib2 6) 8) "fib(6)") +(assert (= (fib 7) (fib2 7) 13) "fib(7)") +(assert (= (fib 8) (fib2 8) 21) "fib(8)") +(assert (= (fib 9) (fib2 9) 34) "fib(9)") +(assert (= (fib 10) (fib2 10) 55) "fib(10)") + +# Closure in non function scope +# 911b0b1 +(def outerfun (fn [x y] + (def c (do + (def someval (+ 10 y)) + (def ctemp (if x (fn [] someval) (fn [] y))) + ctemp + )) + (+ 1 2 3 4 5 6 7) + c)) + +(assert (= ((outerfun 1 2)) 12) "inner closure 1") +(assert (= ((outerfun nil 2)) 2) "inner closure 2") +(assert (= ((outerfun false 3)) 3) "inner closure 3") + +# d6967a5 +((fn [] + (var accum 1) + (var counter 0) + (while (< counter 16) + (set accum (blshift accum 1)) + (set counter (+ 1 counter))) + (assert (= accum 65536) "loop in closure"))) + +(var accum 1) +(var counter 0) +(while (< counter 16) + (set accum (blshift accum 1)) + (set counter (+ 1 counter))) +(assert (= accum 65536) "loop globally") + +# Fiber tests +# 21bd960 +(def afiber (fiber/new (fn [] + (def x (yield)) + (error (string "hello, " x))) :ye)) + +(resume afiber) # first resume to prime +(def afiber-result (resume afiber "world!")) + +(assert (= afiber-result "hello, world!") "fiber error result") +(assert (= (fiber/status afiber) :error) "fiber error status") + +# Var arg tests +# f054586 +(def vargf (fn [more] (apply + more))) + +(assert (= 0 (vargf @[])) "var arg no arguments") +(assert (= 1 (vargf @[1])) "var arg no packed arguments") +(assert (= 3 (vargf @[1 2])) "var arg tuple size 1") +(assert (= 10 (vargf @[1 2 3 4])) "var arg tuple size 2, 2 normal args") +(assert (= 110 (vargf @[1 2 3 4 10 10 10 10 10 10 10 10 10 10])) + "var arg large tuple") + +# Higher order functions +# d9f24ef +(def compose (fn [f g] (fn [& xs] (f (apply g xs))))) + +(def -+ (compose - +)) +(def +- (compose + -)) + +(assert (= (-+ 1 2 3 4) -10) "compose - +") +(assert (= (+- 1 2 3 4) -8) "compose + -") +(assert (= ((compose -+ +-) 1 2 3 4) 8) "compose -+ +-") +(assert (= ((compose +- -+) 1 2 3 4) 10) "compose +- -+") + +# UTF-8 +# d9f24ef +#🐙🐙🐙🐙 + +(defn foo [Θa Θb Θc] 0) +(def 🦊 :fox) +(def 🐮 :cow) +(assert (= (string "🐼" 🦊 🐮) "🐼foxcow") "emojis 🙉 :)") +(assert (not= 🦊 "🦊") "utf8 strings are not symbols and vice versa") +(assert (= "\U01F637" "😷") "unicode escape 1") +(assert (= "\u2623" "\U002623" "☣") "unicode escape 2") +(assert (= "\u24c2" "\U0024c2" "Ⓜ") "unicode escape 3") +(assert (= "\u0061" "a") "unicode escape 4") + +# Test max triangle program +# c0e373f +# Find the maximum path from the top (root) +# of the triangle to the leaves of the triangle. + +(defn myfold [xs ys] + (let [xs1 [;xs 0] + xs2 [0 ;xs] + m1 (map + xs1 ys) + m2 (map + xs2 ys)] + (map max m1 m2))) + +(defn maxpath [t] + (extreme > (reduce myfold () t))) + +# Test it +# Maximum path is 3 -> 10 -> 3 -> 9 for a total of 25 +(def triangle '[ + [3] + [7 10] + [4 3 7] + [8 9 1 3] +]) + +(assert (= (maxpath triangle) 25) `max triangle`) + +# Large functions +# 6822400 +(def manydefs (seq [i :range [0 300]] + (tuple 'def (gensym) (string "value_" i)))) +(array/push manydefs (tuple * 10000 3 5 7 9)) +(def f (compile ['do ;manydefs] (fiber/getenv (fiber/current)))) +(assert (= (f) (* 10000 3 5 7 9)) "long function compilation") + +# Closure in while loop +# abe7d59 +(def closures (seq [i :range [0 5]] (fn [] i))) +(assert (= 0 ((get closures 0))) "closure in loop 0") +(assert (= 1 ((get closures 1))) "closure in loop 1") +(assert (= 2 ((get closures 2))) "closure in loop 2") +(assert (= 3 ((get closures 3))) "closure in loop 3") +(assert (= 4 ((get closures 4))) "closure in loop 4") + +# Another regression test - no segfaults +# 6b4824c +(defn afn [x] x) +(var afn-var afn) +(var identity-var identity) +(var map-var map) +(var not-var not) +(assert (= 1 (try (afn-var) ([err] 1))) "bad arity 1") +(assert (= 4 (try ((fn [x y] (+ x y)) 1) ([_] 4))) "bad arity 2") +(assert (= 1 (try (identity-var) ([err] 1))) "bad arity 3") +(assert (= 1 (try (map-var) ([err] 1))) "bad arity 4") +(assert (= 1 (try (not-var) ([err] 1))) "bad arity 5") + +# Detaching closure over non resumable fiber +# issue #317 - 7c4ffe9b9 +(do + (defn f1 + [a] + (defn f1 [] (++ (a 0))) + (defn f2 [] (++ (a 0))) + (error [f1 f2])) + (def [_ [f1 f2]] (protect (f1 @[0]))) + # At time of writing, mark phase can detach closure envs. + (gccollect) + (assert (= 1 (f1)) "detach-non-resumable-closure 1") + (assert (= 2 (f2)) "detach-non-resumable-closure 2")) + +# Dynamic defs +# ec65f03 +(def staticdef1 0) +(defn staticdef1-inc [] (+ 1 staticdef1)) +(assert (= 1 (staticdef1-inc)) "before redefinition without :redef") +(def staticdef1 1) +(assert (= 1 (staticdef1-inc)) "after redefinition without :redef") +(setdyn :redef true) +(def dynamicdef2 0) +(defn dynamicdef2-inc [] (+ 1 dynamicdef2)) +(assert (= 1 (dynamicdef2-inc)) "before redefinition with dyn :redef") +(def dynamicdef2 1) +(assert (= 2 (dynamicdef2-inc)) "after redefinition with dyn :redef") +(setdyn :redef nil) + +# missing symbols +# issue #914 - 1eb34989d +(defn lookup-symbol [sym] (defglobal sym 10) (dyn sym)) + +(setdyn :missing-symbol lookup-symbol) + +(assert (= (eval-string "(+ a 5)") 15) "lookup missing symbol") + +(setdyn :missing-symbol nil) +(setdyn 'a nil) + +(assert-error "compile error" (eval-string "(+ a 5)")) + +# 88813c4 +(assert (deep= (in (disasm (defn a [] (def x 10) x)) :symbolmap) + @[[0 2 0 'a] [0 2 1 'x]]) + "symbolmap when *debug* is true") + +(defn a [arg] + (def x 10) + (do + (def y 20) + (def z 30) + (+ x y z))) +(def symbolslots (in (disasm a) :symbolslots)) +(def f (asm (disasm a))) +(assert (deep= (in (disasm f) :symbolslots) + symbolslots) + "symbolslots survive disasm/asm") + +(comment + (setdyn *debug* true) + (setdyn :pretty-format "%.40M") + (def f (fn [x] (fn [y] (+ x y)))) + (assert (deep= (map last (in (disasm (f 10)) :symbolmap)) + @['x 'y]) + "symbolmap upvalues")) + +(assert (deep= (in (disasm (defn a [arg] + (def x 10) + (do + (def y 20) + (def z 30) + (+ x y z)))) :symbolmap) + @[[0 6 0 'arg] + [0 6 1 'a] + [0 6 2 'x] + [1 6 3 'y] + [2 6 4 'z]]) + "arg & inner symbolmap") + +(end-suite) + diff --git a/test/suite-value.janet b/test/suite-value.janet new file mode 100644 index 00000000..650cc99b --- /dev/null +++ b/test/suite-value.janet @@ -0,0 +1,72 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# 3e1e25854 +(def test-struct {'def 1 'bork 2 'sam 3 'a 'b 'het @[1 2 3 4 5]}) +(assert (= (get test-struct 'def) 1) "struct get") +(assert (= (get test-struct 'bork) 2) "struct get") +(assert (= (get test-struct 'sam) 3) "struct get") +(assert (= (get test-struct 'a) 'b) "struct get") +(assert (= :array (type (get test-struct 'het))) "struct get") + +# Buffer stuff +# 910cfd7dd +(defn buffer= + [a b] + (= (string a) (string b))) + +(assert (buffer= @"abcd" @"abcd") "buffer equal 1") +(assert (buffer= @"abcd" (buffer "ab" "cd")) "buffer equal 2") +(assert (not= @"" @"") "buffer not equal 1") +(assert (not= @"abcd" @"abcd") "buffer not equal 2") + +(defn buffer-factory + [] + @"im am a buffer") + +(assert (not= (buffer-factory) (buffer-factory)) "buffer instantiation") + +(assert (= (length @"abcdef") 6) "buffer length") + +# Tuple comparison +# da438a93e +(assert (< [1 2 3] [2 2 3]) "tuple comparison 1") +(assert (< [1 2 3] [2 2]) "tuple comparison 2") +(assert (< [1 2 3] [2 2 3 4]) "tuple comparison 3") +(assert (< [1 2 3] [1 2 3 4]) "tuple comparison 4") +(assert (< [1 2 3] [1 2 3 -1]) "tuple comparison 5") +(assert (> [1 2 3] [1 2]) "tuple comparison 6") + +# More numerical tests +# e05022f +(assert (= 1 1.0) "numerical equal 1") +(assert (= 0 0.0) "numerical equal 2") +(assert (= 0 -0.0) "numerical equal 3") +(assert (= 2_147_483_647 2_147_483_647.0) "numerical equal 4") +(assert (= -2_147_483_648 -2_147_483_648.0) "numerical equal 5") + +# issue #928 - d7ea122cf +(assert (= (hash 0) (hash (* -1 0))) "hash -0 same as hash 0") + +(end-suite) + diff --git a/test/suite-vm.janet b/test/suite-vm.janet new file mode 100644 index 00000000..5fc375a2 --- /dev/null +++ b/test/suite-vm.janet @@ -0,0 +1,142 @@ +# Copyright (c) 2023 Calvin Rose +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +# IN THE SOFTWARE. + +(import ./helper :prefix "" :exit true) +(start-suite) + +# More fiber semantics +# 0fd9224e4 +(var myvar 0) +(defn fiberstuff [&] + (++ myvar) + (def f (fiber/new (fn [&] (++ myvar) (debug) (++ myvar)))) + (resume f) + (++ myvar)) + +(def myfiber (fiber/new fiberstuff :dey)) + +(assert (= myvar 0) "fiber creation does not call fiber function") +(resume myfiber) +(assert (= myvar 2) "fiber debug statement breaks at proper point") +(assert (= (fiber/status myfiber) :debug) "fiber enters debug state") +(resume myfiber) +(assert (= myvar 4) "fiber resumes properly from debug state") +(assert (= (fiber/status myfiber) :dead) + "fiber properly dies from debug state") + +# yield tests +# 171c0ce +(def t (fiber/new (fn [&] (yield 1) (yield 2) 3))) + +(assert (= 1 (resume t)) "initial transfer to new fiber") +(assert (= 2 (resume t)) "second transfer to fiber") +(assert (= 3 (resume t)) "return from fiber") +(assert (= (fiber/status t) :dead) "finished fiber is dead") + +# Fix yields inside nested fibers +# 909c906 +(def yielder + (coro + (defer (yield :end) + (repeat 5 (yield :item))))) +(def items (seq [x :in yielder] x)) +(assert (deep= @[:item :item :item :item :item :end] items) + "yield within nested fibers") + +# Calling non functions +# b9c0fc820 +(assert (= 1 ({:ok 1} :ok)) "calling struct") +(assert (= 2 (@{:ok 2} :ok)) "calling table") +(assert (= :bad (try ((identity @{:ok 2}) :ok :no) ([err] :bad))) + "calling table too many arguments") +(assert (= :bad (try ((identity :ok) @{:ok 2} :no) ([err] :bad))) + "calling keyword too many arguments") +(assert (= :oops (try ((+ 2 -1) 1) ([err] :oops))) + "calling number fails") + +# Method test +# d5bab7262 +(def Dog @{:bark (fn bark [self what] + (string (self :name) " says " what "!"))}) +(defn make-dog + [name] + (table/setproto @{:name name} Dog)) + +(assert (= "fido" ((make-dog "fido") :name)) "oo 1") +(def spot (make-dog "spot")) +(assert (= "spot says hi!" (:bark spot "hi")) "oo 2") + +# Negative tests +# 67f26b7d7 +(assert-error "+ check types" (+ 1 ())) +(assert-error "- check types" (- 1 ())) +(assert-error "* check types" (* 1 ())) +(assert-error "/ check types" (/ 1 ())) +(assert-error "band check types" (band 1 ())) +(assert-error "bor check types" (bor 1 ())) +(assert-error "bxor check types" (bxor 1 ())) +(assert-error "bnot check types" (bnot ())) + +# Comparisons +# 10dcbc639 +(assert (> 1e23 100) "less than immediate 1") +(assert (> 1e23 1000) "less than immediate 2") +(assert (< 100 1e23) "greater than immediate 1") +(assert (< 1000 1e23) "greater than immediate 2") + +# Quasiquote bracketed tuples +# e239980da +(assert (= (tuple/type ~[1 2 3]) (tuple/type '[1 2 3])) + "quasiquote bracket tuples") + +# Regression #638 +# c68264802 +(compwhen + (dyn 'ev/go) + (assert + (= [true :caught] + (protect + (try + (do + (ev/sleep 0) + (with-dyns [] + (ev/sleep 0) + (error "oops"))) + ([err] :caught)))) + "regression #638")) + +# +# Test propagation of signals via fibers +# +# b8032ec61 +(def f (fiber/new (fn [] (error :abc) 1) :ei)) +(def res (resume f)) +(assert-error :abc (propagate res f) "propagate 1") + +# Cancel test +# 28439d822 +(def f (fiber/new (fn [&] (yield 1) (yield 2) (yield 3) 4) :yti)) +(assert (= 1 (resume f)) "cancel resume 1") +(assert (= 2 (resume f)) "cancel resume 2") +(assert (= :hi (cancel f :hi)) "cancel resume 3") +(assert (= :error (fiber/status f)) "cancel resume 4") + +(end-suite) + diff --git a/test/suite0000.janet b/test/suite0000.janet deleted file mode 100644 index 802d37eb..00000000 --- a/test/suite0000.janet +++ /dev/null @@ -1,437 +0,0 @@ -# Copyright (c) 2023 Calvin Rose -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 0) - -(assert (= 10 (+ 1 2 3 4)) "addition") -(assert (= -8 (- 1 2 3 4)) "subtraction") -(assert (= 24 (* 1 2 3 4)) "multiplication") -(assert (= 4 (blshift 1 2)) "left shift") -(assert (= 1 (brshift 4 2)) "right shift") -(assert (< 1 2 3 4 5 6) "less than integers") -(assert (< 1.0 2.0 3.0 4.0 5.0 6.0) "less than reals") -(assert (> 6 5 4 3 2 1) "greater than integers") -(assert (> 6.0 5.0 4.0 3.0 2.0 1.0) "greater than reals") -(assert (<= 1 2 3 3 4 5 6) "less than or equal to integers") -(assert (<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "less than or equal to reals") -(assert (>= 6 5 4 4 3 2 1) "greater than or equal to integers") -(assert (>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "greater than or equal to reals") -(assert (= 7 (% 20 13)) "modulo 1") -(assert (= -7 (% -20 13)) "modulo 2") - -(assert (< 1.0 nil false true - (fiber/new (fn [] 1)) - "hi" - (quote hello) - :hello - (array 1 2 3) - (tuple 1 2 3) - (table "a" "b" "c" "d") - (struct 1 2 3 4) - (buffer "hi") - (fn [x] (+ x x)) - print) "type ordering") - -(assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal") -(assert (= (get {} 1) nil) "get nil from empty struct") -(assert (= (get @{} 1) nil) "get nil from empty table") -(assert (= (get {:boop :bap} :boop) :bap) "get non nil from struct") -(assert (= (get @{:boop :bap} :boop) :bap) "get non nil from table") -(assert (= (get @"\0" 0) 0) "get non nil from buffer") -(assert (= (get @"\0" 1) nil) "get nil from buffer oob") -(assert (put @{} :boop :bap) "can add to empty table") -(assert (put @{1 3} :boop :bap) "can add to non-empty table") - -(assert (not false) "false literal") -(assert true "true literal") -(assert (not nil) "nil literal") -(assert (= 7 (bor 3 4)) "bit or") -(assert (= 0 (band 3 4)) "bit and") -(assert (= 0xFF (bxor 0x0F 0xF0)) "bit xor") -(assert (= 0xF0 (bxor 0xFF 0x0F)) "bit xor 2") - -# Set global variables to prevent some possible compiler optimizations that defeat point of the test -(var zero 0) -(var one 1) -(var two 2) -(var three 3) -(var plus +) -(assert (= 22 (plus one (plus 1 2 two) (plus 8 (plus zero 1) 4 three))) "nested function calls") - -# String literals -(assert (= "abcd" "\x61\x62\x63\x64") "hex escapes") -(assert (= "\e" "\x1B") "escape character") -(assert (= "\x09" "\t") "tab character") - -# McCarthy's 91 function -(var f91 nil) -(set f91 (fn [n] (if (> n 100) (- n 10) (f91 (f91 (+ n 11)))))) -(assert (= 91 (f91 10)) "f91(10) = 91") -(assert (= 91 (f91 11)) "f91(11) = 91") -(assert (= 91 (f91 20)) "f91(20) = 91") -(assert (= 91 (f91 31)) "f91(31) = 91") -(assert (= 91 (f91 100)) "f91(100) = 91") -(assert (= 91 (f91 101)) "f91(101) = 91") -(assert (= 92 (f91 102)) "f91(102) = 92") -(assert (= 93 (f91 103)) "f91(103) = 93") -(assert (= 94 (f91 104)) "f91(104) = 94") - -# Fibonacci -(def fib (do (var fib nil) (set fib (fn [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))))) -(def fib2 (fn fib2 [n] (if (< n 2) n (+ (fib2 (- n 1)) (fib2 (- n 2)))))) - -(assert (= (fib 0) (fib2 0) 0) "fib(0)") -(assert (= (fib 1) (fib2 1) 1) "fib(1)") -(assert (= (fib 2) (fib2 2) 1) "fib(2)") -(assert (= (fib 3) (fib2 3) 2) "fib(3)") -(assert (= (fib 4) (fib2 4) 3) "fib(4)") -(assert (= (fib 5) (fib2 5) 5) "fib(5)") -(assert (= (fib 6) (fib2 6) 8) "fib(6)") -(assert (= (fib 7) (fib2 7) 13) "fib(7)") -(assert (= (fib 8) (fib2 8) 21) "fib(8)") -(assert (= (fib 9) (fib2 9) 34) "fib(9)") -(assert (= (fib 10) (fib2 10) 55) "fib(10)") - -# Closure in non function scope -(def outerfun (fn [x y] - (def c (do - (def someval (+ 10 y)) - (def ctemp (if x (fn [] someval) (fn [] y))) - ctemp - )) - (+ 1 2 3 4 5 6 7) - c)) - -(assert (= ((outerfun 1 2)) 12) "inner closure 1") -(assert (= ((outerfun nil 2)) 2) "inner closure 2") -(assert (= ((outerfun false 3)) 3) "inner closure 3") - -(assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand") - -((fn [] - (var accum 1) - (var count 0) - (while (< count 16) - (set accum (blshift accum 1)) - (set count (+ 1 count))) - (assert (= accum 65536) "loop in closure"))) - -(var accum 1) -(var count 0) -(while (< count 16) - (set accum (blshift accum 1)) - (set count (+ 1 count))) -(assert (= accum 65536) "loop globally") - -(assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2)) "struct order does not matter 1") -(assert (= (struct - :apple 1 - 6 :bork - '(1 2 3) 5) - (struct - 6 :bork - '(1 2 3) 5 - :apple 1)) "struct order does not matter 2") - -# Symbol function - -(assert (= (symbol "abc" 1 2 3) 'abc123) "symbol function") - -# Fiber tests - -(def afiber (fiber/new (fn [] - (def x (yield)) - (error (string "hello, " x))) :ye)) - -(resume afiber) # first resume to prime -(def afiber-result (resume afiber "world!")) - -(assert (= afiber-result "hello, world!") "fiber error result") -(assert (= (fiber/status afiber) :error) "fiber error status") - -# yield tests - -(def t (fiber/new (fn [&] (yield 1) (yield 2) 3))) - -(assert (= 1 (resume t)) "initial transfer to new fiber") -(assert (= 2 (resume t)) "second transfer to fiber") -(assert (= 3 (resume t)) "return from fiber") -(assert (= (fiber/status t) :dead) "finished fiber is dead") - -# Var arg tests - -(def vargf (fn [more] (apply + more))) - -(assert (= 0 (vargf @[])) "var arg no arguments") -(assert (= 1 (vargf @[1])) "var arg no packed arguments") -(assert (= 3 (vargf @[1 2])) "var arg tuple size 1") -(assert (= 10 (vargf @[1 2 3 4])) "var arg tuple size 2, 2 normal args") -(assert (= 110 (vargf @[1 2 3 4 10 10 10 10 10 10 10 10 10 10])) "var arg large tuple") - -# Higher order functions - -(def compose (fn [f g] (fn [& xs] (f (apply g xs))))) - -(def -+ (compose - +)) -(def +- (compose + -)) - -(assert (= (-+ 1 2 3 4) -10) "compose - +") -(assert (= (+- 1 2 3 4) -8) "compose + -") -(assert (= ((compose -+ +-) 1 2 3 4) 8) "compose -+ +-") -(assert (= ((compose +- -+) 1 2 3 4) 10) "compose +- -+") - -# UTF-8 - -#🐙🐙🐙🐙 - -(defn foo [Θa Θb Θc] 0) -(def 🦊 :fox) -(def 🐮 :cow) -(assert (= (string "🐼" 🦊 🐮) "🐼foxcow") "emojis 🙉 :)") -(assert (not= 🦊 "🦊") "utf8 strings are not symbols and vice versa") -(assert (= "\U01F637" "😷") "unicode escape 1") -(assert (= "\u2623" "\U002623" "☣") "unicode escape 2") -(assert (= "\u24c2" "\U0024c2" "Ⓜ") "unicode escape 3") -(assert (= "\u0061" "a") "unicode escape 4") - -# Symbols with @ character - -(def @ 1) -(assert (= @ 1) "@ symbol") -(def @-- 2) -(assert (= @-- 2) "@-- symbol") -(def @hey 3) -(assert (= @hey 3) "@hey symbol") - -# Merge sort - -# Imperative (and verbose) merge sort merge -(defn merge - [xs ys] - (def ret @[]) - (def xlen (length xs)) - (def ylen (length ys)) - (var i 0) - (var j 0) - # Main merge - (while (if (< i xlen) (< j ylen)) - (def xi (get xs i)) - (def yj (get ys j)) - (if (< xi yj) - (do (array/push ret xi) (set i (+ i 1))) - (do (array/push ret yj) (set j (+ j 1))))) - # Push rest of xs - (while (< i xlen) - (def xi (get xs i)) - (array/push ret xi) - (set i (+ i 1))) - # Push rest of ys - (while (< j ylen) - (def yj (get ys j)) - (array/push ret yj) - (set j (+ j 1))) - ret) - -(assert (apply <= (merge @[1 3 5] @[2 4 6])) "merge sort merge 1") -(assert (apply <= (merge @[1 2 3] @[4 5 6])) "merge sort merge 2") -(assert (apply <= (merge @[1 3 5] @[2 4 6 6 6 9])) "merge sort merge 3") -(assert (apply <= (merge '(1 3 5) @[2 4 6 6 6 9])) "merge sort merge 4") - -(assert (deep= @[1 2 3 4 5] (sort @[5 3 4 1 2])) "sort 1") -(assert (deep= @[{:a 1} {:a 4} {:a 7}] (sort-by |($ :a) @[{:a 4} {:a 7} {:a 1}])) "sort 2") -(assert (deep= @[1 2 3 4 5] (sorted [5 3 4 1 2])) "sort 3") -(assert (deep= @[{:a 1} {:a 4} {:a 7}] (sorted-by |($ :a) [{:a 4} {:a 7} {:a 1}])) "sort 4") - -# Gensym tests - -(assert (not= (gensym) (gensym)) "two gensyms not equal") -((fn [] - (def syms (table)) - (var count 0) - (while (< count 128) - (put syms (gensym) true) - (set count (+ 1 count))) - (assert (= (length syms) 128) "many symbols"))) - -# Let - -(assert (= (let [a 1 b 2] (+ a b)) 3) "simple let") -(assert (= (let [[a b] @[1 2]] (+ a b)) 3) "destructured let") -(assert (= (let [[a [c d] b] @[1 (tuple 4 3) 2]] (+ a b c d)) 10) "double destructured let") - -# Macros - -(defn dub [x] (+ x x)) -(assert (= 2 (dub 1)) "defn macro") -(do - (defn trip [x] (+ x x x)) - (assert (= 3 (trip 1)) "defn macro triple")) -(do - (var i 0) - (when true - (++ i) - (++ i) - (++ i) - (++ i) - (++ i) - (++ i)) - (assert (= i 6) "when macro")) - -# Dynamic defs - -(def staticdef1 0) -(defn staticdef1-inc [] (+ 1 staticdef1)) -(assert (= 1 (staticdef1-inc)) "before redefinition without :redef") -(def staticdef1 1) -(assert (= 1 (staticdef1-inc)) "after redefinition without :redef") -(setdyn :redef true) -(def dynamicdef2 0) -(defn dynamicdef2-inc [] (+ 1 dynamicdef2)) -(assert (= 1 (dynamicdef2-inc)) "before redefinition with dyn :redef") -(def dynamicdef2 1) -(assert (= 2 (dynamicdef2-inc)) "after redefinition with dyn :redef") -(setdyn :redef nil) - -# Denormal tables and structs - -(assert (= (length {1 2 nil 3}) 1) "nil key struct literal") -(assert (= (length @{1 2 nil 3}) 1) "nil key table literal") -(assert (= (length (struct 1 2 nil 3)) 1) "nil key struct ctor") -(assert (= (length (table 1 2 nil 3)) 1) "nil key table ctor") - -(assert (= (length (struct (/ 0 0) 2 1 3)) 1) "nan key struct ctor") -(assert (= (length (table (/ 0 0) 2 1 3)) 1) "nan key table ctor") -(assert (= (length {1 2 nil 3}) 1) "nan key struct literal") -(assert (= (length @{1 2 nil 3}) 1) "nan key table literal") - -(assert (= (length (struct 2 1 3 nil)) 1) "nil value struct ctor") -(assert (= (length (table 2 1 3 nil)) 1) "nil value table ctor") -(assert (= (length {1 2 3 nil}) 1) "nil value struct literal") -(assert (= (length @{1 2 3 nil}) 1) "nil value table literal") - -# Regression Test -(assert (= 1 (((compile '(fn [] 1) @{})))) "regression test") - -# Regression Test #137 -(def [a b c] (range 10)) -(assert (= a 0) "regression #137 (1)") -(assert (= b 1) "regression #137 (2)") -(assert (= c 2) "regression #137 (3)") - -(var [x y z] (range 10)) -(assert (= x 0) "regression #137 (4)") -(assert (= y 1) "regression #137 (5)") -(assert (= z 2) "regression #137 (6)") - -(assert (= true ;(map truthy? [0 "" true @{} {} [] '()])) "truthy values") -(assert (= false ;(map truthy? [nil false])) "non-truthy values") - -# Struct and Table duplicate elements -(assert (= {:a 3 :b 2} {:a 1 :b 2 :a 3}) "struct literal duplicate keys") -(assert (= {:a 3 :b 2} (struct :a 1 :b 2 :a 3)) "struct constructor duplicate keys") -(assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys") -(assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3)) "table constructor duplicate keys") - -## Polymorphic comparison -- Issue #272 - -# confirm polymorphic comparison delegation to primitive comparators: -(assert (= 0 (cmp 3 3)) "compare-primitive integers (1)") -(assert (= -1 (cmp 3 5)) "compare-primitive integers (2)") -(assert (= 1 (cmp "foo" "bar")) "compare-primitive strings") -(assert (= 0 (compare 1 1)) "compare integers (1)") -(assert (= -1 (compare 1 2)) "compare integers (2)") -(assert (= 1 (compare "foo" "bar")) "compare strings (1)") - -(assert (compare< 1 2 3 4 5 6) "compare less than integers") -(assert (not (compare> 1 2 3 4 5 6)) "compare not greater than integers") -(assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals") -(assert (compare> 6 5 4 3 2 1) "compare greater than integers") -(assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals") -(assert (not (compare< 6.0 5.0 4.0 3.0 2.0 1.0)) "compare less than reals") -(assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers") -(assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "compare less than or equal to reals") -(assert (compare>= 6 5 4 4 3 2 1) "compare greater than or equal to integers") -(assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "compare greater than or equal to reals") -(assert (compare< 1.0 nil false true - (fiber/new (fn [] 1)) - "hi" - (quote hello) - :hello - (array 1 2 3) - (tuple 1 2 3) - (table "a" "b" "c" "d") - (struct 1 2 3 4) - (buffer "hi") - (fn [x] (+ x x)) - print) "compare type ordering") - -# test polymorphic compare with 'objects' (table/setproto) -(def mynum - @{:type :mynum :v 0 :compare - (fn [self other] - (case (type other) - :number (cmp (self :v) other) - :table (when (= (get other :type) :mynum) - (cmp (self :v) (other :v)))))}) - -(let [n3 (table/setproto @{:v 3} mynum)] - (assert (= 0 (compare 3 n3)) "compare num to object (1)") - (assert (= -1 (compare n3 4)) "compare object to num (2)") - (assert (= 1 (compare (table/setproto @{:v 4} mynum) n3)) "compare object to object") - (assert (compare< 2 n3 4) "compare< poly") - (assert (compare> 4 n3 2) "compare> poly") - (assert (compare<= 2 3 n3 4) "compare<= poly") - (assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly") - (assert (deep= (sorted @[4 5 n3 2] compare<) @[2 n3 4 5]) "polymorphic sort")) - -(let [MAX_INT_64_STRING "9223372036854775807" - MAX_UINT_64_STRING "18446744073709551615" - MAX_INT_IN_DBL_STRING "9007199254740991" - NAN (math/log -1) - INF (/ 1 0) - MINUS_INF (/ -1 0) - compare-poly-tests - [[(int/s64 3) (int/u64 3) 0] - [(int/s64 -3) (int/u64 3) -1] - [(int/s64 3) (int/u64 2) 1] - [(int/s64 3) 3 0] [(int/s64 3) 4 -1] [(int/s64 3) -9 1] - [(int/u64 3) 3 0] [(int/u64 3) 4 -1] [(int/u64 3) -9 1] - [3 (int/s64 3) 0] [3 (int/s64 4) -1] [3 (int/s64 -5) 1] - [3 (int/u64 3) 0] [3 (int/u64 4) -1] [3 (int/u64 2) 1] - [(int/s64 MAX_INT_64_STRING) (int/u64 MAX_UINT_64_STRING) -1] - [(int/s64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] - [(int/u64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] - [(+ 1 (int/u64 MAX_INT_IN_DBL_STRING)) (scan-number MAX_INT_IN_DBL_STRING) 1] - [(int/s64 0) INF -1] [(int/u64 0) INF -1] - [MINUS_INF (int/u64 0) -1] [MINUS_INF (int/s64 0) -1] - [(int/s64 1) NAN 0] [NAN (int/u64 1) 0]]] - (each [x y c] compare-poly-tests - (assert (= c (compare x y)) (string/format "compare polymorphic %q %q %d" x y c)))) - -(assert (= nil (any? [])) "any? 1") -(assert (= nil (any? [false nil])) "any? 2") -(assert (= nil (any? [nil false])) "any? 3") -(assert (= 1 (any? [1])) "any? 4") -(assert (nan? (any? [nil math/nan nil])) "any? 5") -(assert (= true (any? [nil nil false nil nil true nil nil nil nil false :a nil])) "any? 6") - -(end-suite) - diff --git a/test/suite0001.janet b/test/suite0001.janet deleted file mode 100644 index 2b41c536..00000000 --- a/test/suite0001.janet +++ /dev/null @@ -1,384 +0,0 @@ -# Copyright (c) 2023 Calvin Rose -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 1) - -(assert (= 400 (math/sqrt 160000)) "sqrt(160000)=400") - -(def test-struct {'def 1 'bork 2 'sam 3 'a 'b 'het @[1 2 3 4 5]}) -(assert (= (get test-struct 'def) 1) "struct get") -(assert (= (get test-struct 'bork) 2) "struct get") -(assert (= (get test-struct 'sam) 3) "struct get") -(assert (= (get test-struct 'a) 'b) "struct get") -(assert (= :array (type (get test-struct 'het))) "struct get") - -(defn myfun [x] - (var a 10) - (set a (do - (def y x) - (if x 8 9)))) - -(assert (= (myfun true) 8) "check do form regression") -(assert (= (myfun false) 9) "check do form regression") - -(defn assert-many [f n e] - (var good true) - (loop [i :range [0 n]] - (if (not (f)) - (set good false))) - (assert good e)) - -(assert-many (fn [] (>= 1 (math/random) 0)) 200 "(random) between 0 and 1") - -## Table prototypes - -(def roottab @{ - :parentprop 123 -}) - -(def childtab @{ - :childprop 456 -}) - -(table/setproto childtab roottab) - -(assert (= 123 (get roottab :parentprop)) "table get 1") -(assert (= 123 (get childtab :parentprop)) "table get proto") -(assert (= nil (get roottab :childprop)) "table get 2") -(assert (= 456 (get childtab :childprop)) "proto no effect") - -# Long strings - -(assert (= "hello, world" `hello, world`) "simple long string") -(assert (= "hello, \"world\"" `hello, "world"`) "long string with embedded quotes") -(assert (= "hello, \\\\\\ \"world\"" `hello, \\\ "world"`) - "long string with embedded quotes and backslashes") - -# More fiber semantics - -(var myvar 0) -(defn fiberstuff [&] - (++ myvar) - (def f (fiber/new (fn [&] (++ myvar) (debug) (++ myvar)))) - (resume f) - (++ myvar)) - -(def myfiber (fiber/new fiberstuff :dey)) - -(assert (= myvar 0) "fiber creation does not call fiber function") -(resume myfiber) -(assert (= myvar 2) "fiber debug statement breaks at proper point") -(assert (= (fiber/status myfiber) :debug) "fiber enters debug state") -(resume myfiber) -(assert (= myvar 4) "fiber resumes properly from debug state") -(assert (= (fiber/status myfiber) :dead) "fiber properly dies from debug state") - -# Test max triangle program - -# Find the maximum path from the top (root) -# of the triangle to the leaves of the triangle. - -(defn myfold [xs ys] - (let [xs1 [;xs 0] - xs2 [0 ;xs] - m1 (map + xs1 ys) - m2 (map + xs2 ys)] - (map max m1 m2))) - -(defn maxpath [t] - (extreme > (reduce myfold () t))) - -# Test it -# Maximum path is 3 -> 10 -> 3 -> 9 for a total of 25 - -(def triangle '[ - [3] - [7 10] - [4 3 7] - [8 9 1 3] -]) - -(assert (= (maxpath triangle) 25) `max triangle`) - -(assert (= (string/join @["one" "two" "three"]) "onetwothree") "string/join 1 argument") -(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") "string/join 2 arguments") -(assert (= (string/join @[] ", ") "") "string/join empty array") - -(assert (= (string/find "123" "abc123def") 3) "string/find positive") -(assert (= (string/find "1234" "abc123def") nil) "string/find negative") - -# Test destructuring -(do - (def test-tab @{:a 1 :b 2}) - (def {:a a :b b} test-tab) - (assert (= a 1) "dictionary destructuring 1") - (assert (= b 2) "dictionary destructuring 2")) -(do - (def test-tab @{'a 1 'b 2 3 4}) - (def {'a a 'b b (+ 1 2) c} test-tab) - (assert (= a 1) "dictionary destructuring 3") - (assert (= b 2) "dictionary destructuring 4") - (assert (= c 4) "dictionary destructuring 5 - expression as key")) -(let [test-tuple [:a :b 1 2]] - (def [a b one two] test-tuple) - (assert (= a :a) "tuple destructuring 1") - (assert (= b :b) "tuple destructuring 2") - (assert (= two 2) "tuple destructuring 3")) -(let [test-tuple [:a :b 1 2]] - (def [a & rest] test-tuple) - (assert (= a :a) "tuple destructuring 4 - rest") - (assert (= rest [:b 1 2]) "tuple destructuring 5 - rest")) -(do - (def [a b & rest] [:a :b nil :d]) - (assert (= a :a) "tuple destructuring 6 - rest") - (assert (= b :b) "tuple destructuring 7 - rest") - (assert (= rest [nil :d]) "tuple destructuring 8 - rest")) -(do - (def [[a b] x & rest] [[1 2] :a :c :b :a]) - (assert (= a 1) "tuple destructuring 9 - rest") - (assert (= b 2) "tuple destructuring 10 - rest") - (assert (= x :a) "tuple destructuring 11 - rest") - (assert (= rest [:c :b :a]) "tuple destructuring 12 - rest")) -(do - (def [a b & rest] [:a :b]) - (assert (= a :a) "tuple destructuring 13 - rest") - (assert (= b :b) "tuple destructuring 14 - rest") - (assert (= rest []) "tuple destructuring 15 - rest")) - -(do - (def [[a b & r1] c & r2] [[:a :b 1 2] :c 3 4]) - (assert (= a :a) "tuple destructuring 16 - rest") - (assert (= b :b) "tuple destructuring 17 - rest") - (assert (= c :c) "tuple destructuring 18 - rest") - (assert (= r1 [1 2]) "tuple destructuring 19 - rest") - (assert (= r2 [3 4]) "tuple destructuring 20 - rest")) - -# Marshal - -(def um-lookup (env-lookup (fiber/getenv (fiber/current)))) -(def m-lookup (invert um-lookup)) - -(defn testmarsh [x msg] - (def marshx (marshal x m-lookup)) - (def out (marshal (unmarshal marshx um-lookup) m-lookup)) - (assert (= (string marshx) (string out)) msg)) - -(testmarsh nil "marshal nil") -(testmarsh false "marshal false") -(testmarsh true "marshal true") -(testmarsh 1 "marshal small integers") -(testmarsh -1 "marshal integers (-1)") -(testmarsh 199 "marshal small integers (199)") -(testmarsh 5000 "marshal medium integers (5000)") -(testmarsh -5000 "marshal small integers (-5000)") -(testmarsh 10000 "marshal large integers (10000)") -(testmarsh -10000 "marshal large integers (-10000)") -(testmarsh 1.0 "marshal double") -(testmarsh "doctordolittle" "marshal string") -(testmarsh :chickenshwarma "marshal symbol") -(testmarsh @"oldmcdonald" "marshal buffer") -(testmarsh @[1 2 3 4 5] "marshal array") -(testmarsh [tuple 1 2 3 4 5] "marshal tuple") -(testmarsh @{1 2 3 4} "marshal table") -(testmarsh {1 2 3 4} "marshal struct") -(testmarsh (fn [x] x) "marshal function 0") -(testmarsh (fn name [x] x) "marshal function 1") -(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2") -(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3") -(testmarsh map "marshal function 4") -(testmarsh reduce "marshal function 5") -(testmarsh (fiber/new (fn [] (yield 1) 2)) "marshal simple fiber 1") -(testmarsh (fiber/new (fn [&] (yield 1) 2)) "marshal simple fiber 2") - -(def strct {:a @[nil]}) -(put (strct :a) 0 strct) -(testmarsh strct "cyclic struct") - -# Large functions -(def manydefs (seq [i :range [0 300]] (tuple 'def (gensym) (string "value_" i)))) -(array/push manydefs (tuple * 10000 3 5 7 9)) -(def f (compile ['do ;manydefs] (fiber/getenv (fiber/current)))) -(assert (= (f) (* 10000 3 5 7 9)) "long function compilation") - -# Some higher order functions and macros - -(def my-array @[1 2 3 4 5 6]) -(def x (if-let [x (get my-array 5)] x)) -(assert (= x 6) "if-let") -(def x (if-let [y (get @{} :key)] 10 nil)) -(assert (not x) "if-let 2") - -(assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") -(def myfun (juxt + - * /)) -(assert (= [2 -2 2 0.5] (myfun 2)) "juxt") - -# Case statements -(assert - (= :six (case (+ 1 2 3) - 1 :one - 2 :two - 3 :three - 4 :four - 5 :five - 6 :six - 7 :seven - 8 :eight - 9 :nine)) "case macro") - -(assert (= 7 (case :a :b 5 :c 6 :u 10 7)) "case with default") - -# Testing the loop and seq macros -(def xs (apply tuple (seq [x :range [0 10] :when (even? x)] (tuple (/ x 2) x)))) -(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1") - -(def xs (apply tuple (seq [x :down [8 -2] :when (even? x)] (tuple (/ x 2) x)))) -(assert (= xs '((4 8) (3 6) (2 4) (1 2) (0 0))) "seq macro 2") - -(def xs (catseq [x :range [0 3]] [x x])) -(assert (deep= xs @[0 0 1 1 2 2]) "catseq") - -# :range-to and :down-to -(assert (deep= (seq [x :range-to [0 10]] x) (seq [x :range [0 11]] x)) "loop :range-to") -(assert (deep= (seq [x :down-to [10 0]] x) (seq [x :down [10 -1]] x)) "loop :down-to") - -# Some testing for not= -(assert (not= 1 1 0) "not= 1") -(assert (not= 0 1 1) "not= 2") - -# Closure in while loop -(def closures (seq [i :range [0 5]] (fn [] i))) -(assert (= 0 ((get closures 0))) "closure in loop 0") -(assert (= 1 ((get closures 1))) "closure in loop 1") -(assert (= 2 ((get closures 2))) "closure in loop 2") -(assert (= 3 ((get closures 3))) "closure in loop 3") -(assert (= 4 ((get closures 4))) "closure in loop 4") - -# More numerical tests -(assert (= 1 1.0) "numerical equal 1") -(assert (= 0 0.0) "numerical equal 2") -(assert (= 0 -0.0) "numerical equal 3") -(assert (= 2_147_483_647 2_147_483_647.0) "numerical equal 4") -(assert (= -2_147_483_648 -2_147_483_648.0) "numerical equal 5") - -# Array tests - -(defn array= - "Check if two arrays are equal in an element by element comparison" - [a b] - (if (and (array? a) (array? b)) - (= (apply tuple a) (apply tuple b)))) -(assert (= (apply tuple @[1 2 3 4 5]) (tuple 1 2 3 4 5)) "array to tuple") -(def arr (array)) -(array/push arr :hello) -(array/push arr :world) -(assert (array= arr @[:hello :world]) "array comparison") -(assert (array= @[1 2 3 4 5] @[1 2 3 4 5]) "array comparison 2") -(assert (array= @[:one :two :three :four :five] @[:one :two :three :four :five]) "array comparison 3") -(assert (array= (array/slice @[1 2 3] 0 2) @[1 2]) "array/slice 1") -(assert (array= (array/slice @[0 7 3 9 1 4] 2 -2) @[3 9 1]) "array/slice 2") - -# Even and odd - -(assert (odd? 9) "odd? 1") -(assert (odd? -9) "odd? 2") -(assert (not (odd? 10)) "odd? 3") -(assert (not (odd? 0)) "odd? 4") -(assert (not (odd? -10)) "odd? 5") -(assert (not (odd? 1.1)) "odd? 6") -(assert (not (odd? -0.1)) "odd? 7") -(assert (not (odd? -1.1)) "odd? 8") -(assert (not (odd? -1.6)) "odd? 9") - -(assert (even? 10) "even? 1") -(assert (even? -10) "even? 2") -(assert (even? 0) "even? 3") -(assert (not (even? 9)) "even? 4") -(assert (not (even? -9)) "even? 5") -(assert (not (even? 0.1)) "even? 6") -(assert (not (even? -0.1)) "even? 7") -(assert (not (even? -10.1)) "even? 8") -(assert (not (even? -10.6)) "even? 9") - -# Map arities -(assert (deep= (map inc [1 2 3]) @[2 3 4])) -(assert (deep= (map + [1 2 3] [10 20 30]) @[11 22 33])) -(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300]) @[111 222 333])) -(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]) @[1111 2222 3333])) -(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000]) @[11111 22222 33333])) -(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000] [100000 200000 300000]) @[111111 222222 333333])) - -# Mapping uses the shortest sequence -(assert (deep= (map + [1 2 3 4] [10 20 30]) @[11 22 33])) -(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222])) -(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111])) -(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000] []) @[])) - -# Variadic arguments to map-like functions -(assert (deep= (mapcat tuple [1 2 3 4] [5 6 7 8]) @[1 5 2 6 3 7 4 8])) -(assert (deep= (keep |(if (> $1 0) (/ $0 $1)) [1 2 3 4 5] [1 2 1 0 1]) @[1 1 3 5])) - -(assert (= (count = [1 3 2 4 3 5 4 2 1] [1 2 3 4 5 4 3 2 1]) 4)) - -(assert (= (some not= (range 5) (range 5)) nil)) -(assert (= (some = [1 2 3 4 5] [5 4 3 2 1]) true)) - -(assert (= (all = (range 5) (range 5)) true)) -(assert (= (all not= [1 2 3 4 5] [5 4 3 2 1]) false)) - -(assert (= false (deep-not= [1] [1])) "issue #1149") - -# Sort function -(assert (deep= - (range 99) - (sort (mapcat (fn [[x y z]] [z y x]) (partition 3 (range 99))))) "sort 5") -(assert (<= ;(sort (map (fn [x] (math/random)) (range 1000)))) "sort 6") - -# And and or - -(assert (= (and true true) true) "and true true") -(assert (= (and true false) false) "and true false") -(assert (= (and false true) false) "and false true") -(assert (= (and true true true) true) "and true true true") -(assert (= (and 0 1 2) 2) "and 0 1 2") -(assert (= (and 0 1 nil) nil) "and 0 1 nil") -(assert (= (and 1) 1) "and 1") -(assert (= (and) true) "and with no arguments") -(assert (= (and 1 true) true) "and with trailing true") -(assert (= (and 1 true 2) 2) "and with internal true") - -(assert (= (or true true) true) "or true true") -(assert (= (or true false) true) "or true false") -(assert (= (or false true) true) "or false true") -(assert (= (or false false) false) "or false true") -(assert (= (or true true false) true) "or true true false") -(assert (= (or 0 1 2) 0) "or 0 1 2") -(assert (= (or nil 1 2) 1) "or nil 1 2") -(assert (= (or 1) 1) "or 1") -(assert (= (or) nil) "or with no arguments") - -(def yielder - (coro - (defer (yield :end) - (repeat 5 (yield :item))))) -(def items (seq [x :in yielder] x)) -(assert (deep= @[:item :item :item :item :item :end] items) "yield within nested fibers") - -(end-suite) diff --git a/test/suite0003.janet b/test/suite0003.janet deleted file mode 100644 index 17c9d2d1..00000000 --- a/test/suite0003.janet +++ /dev/null @@ -1,497 +0,0 @@ -# Copyright (c) 2023 Calvin Rose -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 3) - -(assert (= (length (range 10)) 10) "(range 10)") -(assert (= (length (range 1 10)) 9) "(range 1 10)") -(assert (deep= @{:a 1 :b 2 :c 3} (zipcoll '[:a :b :c] '[1 2 3])) "zipcoll") - -(def- a 100) -(assert (= a 100) "def-") - -(assert (= :first - (match @[1 3 5] - @[x y z] :first - :second)) "match 1") - -(def val1 :avalue) -(assert (= :second - (match val1 - @[x y z] :first - :avalue :second - :third)) "match 2") - -(assert (= 100 - (match @[50 40] - @[x x] (* x 3) - @[x y] (+ x y 10) - 0)) "match 3") - -# Edge case should cause old compilers to fail due to -# if statement optimization -(var var-a 1) -(var var-b (if false 2 (string "hello"))) - -(assert (= var-b "hello") "regression 1") - -# Scan number - -(assert (= 1 (scan-number "1")) "scan-number 1") -(assert (= -1 (scan-number "-1")) "scan-number -1") -(assert (= 1.3e4 (scan-number "1.3e4")) "scan-number 1.3e4") - -# Some macros - -(assert (= 2 (if-not 1 3 2)) "if-not 1") -(assert (= 3 (if-not false 3)) "if-not 2") -(assert (= 3 (if-not nil 3 2)) "if-not 3") -(assert (= nil (if-not true 3)) "if-not 4") - -(assert (= 4 (unless false (+ 1 2 3) 4)) "unless") - -(def res @{}) -(loop [[k v] :pairs @{1 2 3 4 5 6}] - (put res k v)) -(assert (and - (= (get res 1) 2) - (= (get res 3) 4) - (= (get res 5) 6)) "loop :pairs") - -# Another regression test - no segfaults -(defn afn [x] x) -(var afn-var afn) -(var identity-var identity) -(var map-var map) -(var not-var not) -(assert (= 1 (try (afn-var) ([err] 1))) "bad arity 1") -(assert (= 4 (try ((fn [x y] (+ x y)) 1) ([_] 4))) "bad arity 2") -(assert (= 1 (try (identity-var) ([err] 1))) "bad arity 3") -(assert (= 1 (try (map-var) ([err] 1))) "bad arity 4") -(assert (= 1 (try (not-var) ([err] 1))) "bad arity 5") - -# Assembly test -# Fibonacci sequence, implemented with naive recursion. -(def fibasm (asm '{ - :arity 1 - :bytecode [ - (ltim 1 0 0x2) # $1 = $0 < 2 - (jmpif 1 :done) # if ($1) goto :done - (lds 1) # $1 = self - (addim 0 0 -0x1) # $0 = $0 - 1 - (push 0) # push($0), push argument for next function call - (call 2 1) # $2 = call($1) - (addim 0 0 -0x1) # $0 = $0 - 1 - (push 0) # push($0) - (call 0 1) # $0 = call($1) - (add 0 0 2) # $0 = $0 + $2 (integers) - :done - (ret 0) # return $0 - ] -})) - -(assert (= 0 (fibasm 0)) "fibasm 1") -(assert (= 1 (fibasm 1)) "fibasm 2") -(assert (= 55 (fibasm 10)) "fibasm 3") -(assert (= 6765 (fibasm 20)) "fibasm 4") - -# Calling non functions - -(assert (= 1 ({:ok 1} :ok)) "calling struct") -(assert (= 2 (@{:ok 2} :ok)) "calling table") -(assert (= :bad (try ((identity @{:ok 2}) :ok :no) ([err] :bad))) "calling table too many arguments") -(assert (= :bad (try ((identity :ok) @{:ok 2} :no) ([err] :bad))) "calling keyword too many arguments") -(assert (= :oops (try ((+ 2 -1) 1) ([err] :oops))) "calling number fails") - -# Method test - -(def Dog @{:bark (fn bark [self what] (string (self :name) " says " what "!"))}) -(defn make-dog - [name] - (table/setproto @{:name name} Dog)) - -(assert (= "fido" ((make-dog "fido") :name)) "oo 1") -(def spot (make-dog "spot")) -(assert (= "spot says hi!" (:bark spot "hi")) "oo 2") - -# Negative tests - -(assert-error "+ check types" (+ 1 ())) -(assert-error "- check types" (- 1 ())) -(assert-error "* check types" (* 1 ())) -(assert-error "/ check types" (/ 1 ())) -(assert-error "band check types" (band 1 ())) -(assert-error "bor check types" (bor 1 ())) -(assert-error "bxor check types" (bxor 1 ())) -(assert-error "bnot check types" (bnot ())) - -# Buffer blitting - -(def b (buffer/new-filled 100)) -(buffer/bit-set b 100) -(buffer/bit-clear b 100) -(assert (zero? (sum b)) "buffer bit set and clear") -(buffer/bit-toggle b 101) -(assert (= 32 (sum b)) "buffer bit set and clear") - -(def b2 @"hello world") - -(buffer/blit b2 "joyto ") -(assert (= (string b2) "joyto world") "buffer/blit 1") - -(buffer/blit b2 "joyto" 6) -(assert (= (string b2) "joyto joyto") "buffer/blit 2") - -(buffer/blit b2 "abcdefg" 5 6) -(assert (= (string b2) "joytogjoyto") "buffer/blit 3") - -# Buffer self blitting, check for use after free -(def buf1 @"1234567890") -(buffer/blit buf1 buf1 -1) -(buffer/blit buf1 buf1 -1) -(buffer/blit buf1 buf1 -1) -(buffer/blit buf1 buf1 -1) -(assert (= (string buf1) (string/repeat "1234567890" 16)) "buffer blit against self") - -# Buffer push word - -(def b3 @"") -(buffer/push-word b3 0xFF 0x11) -(assert (= 8 (length b3)) "buffer/push-word 1") -(assert (= "\xFF\0\0\0\x11\0\0\0" (string b3)) "buffer/push-word 2") -(buffer/clear b3) -(buffer/push-word b3 0xFFFFFFFF 0x1100) -(assert (= 8 (length b3)) "buffer/push-word 3") -(assert (= "\xFF\xFF\xFF\xFF\0\x11\0\0" (string b3)) "buffer/push-word 4") - -# Buffer push string - -(def b4 (buffer/new-filled 10 0)) -(buffer/push-string b4 b4) -(assert (= "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" (string b4)) "buffer/push-buffer 1") -(def b5 @"123") -(buffer/push-string b5 "456" @"789") -(assert (= "123456789" (string b5)) "buffer/push-buffer 2") - -# Check for bugs with printing self with buffer/format - -(def buftemp @"abcd") -(assert (= (string (buffer/format buftemp "---%p---" buftemp)) `abcd---@"abcd"---`) "buffer/format on self 1") -(def buftemp @"abcd") -(assert (= (string (buffer/format buftemp "---%p %p---" buftemp buftemp)) `abcd---@"abcd" @"abcd"---`) "buffer/format on self 2") - -# Peg - -(defn check-match - [pat text should-match] - (def result (peg/match pat text)) - (assert (= (not should-match) (not result)) (string "check-match " text))) - -(defn check-deep - [pat text what] - (def result (peg/match pat text)) - (assert (deep= result what) (string "check-deep " text))) - -# Just numbers - -(check-match '(* 4 -1) "abcd" true) -(check-match '(* 4 -1) "abc" false) -(check-match '(* 4 -1) "abcde" false) - -# Simple pattern - -(check-match '(* (some (range "az" "AZ")) -1) "hello" true) -(check-match '(* (some (range "az" "AZ")) -1) "hello world" false) -(check-match '(* (some (range "az" "AZ")) -1) "1he11o" false) -(check-match '(* (some (range "az" "AZ")) -1) "" false) - -# Pre compile - -(def pegleg (peg/compile '{:item "abc" :main (* :item "," :item -1)})) - -(peg/match pegleg "abc,abc") - -# Bad Grammars - -(assert-error "peg/compile error 1" (peg/compile nil)) -(assert-error "peg/compile error 2" (peg/compile @{})) -(assert-error "peg/compile error 3" (peg/compile '{:a "abc" :b "def"})) -(assert-error "peg/compile error 4" (peg/compile '(blarg "abc"))) -(assert-error "peg/compile error 5" (peg/compile '(1 2 3))) - -# IP address - -(def ip-address - '{:d (range "09") - :0-4 (range "04") - :0-5 (range "05") - :byte (+ - (* "25" :0-5) - (* "2" :0-4 :d) - (* "1" :d :d) - (between 1 2 :d)) - :main (* :byte "." :byte "." :byte "." :byte)}) - -(check-match ip-address "10.240.250.250" true) -(check-match ip-address "0.0.0.0" true) -(check-match ip-address "1.2.3.4" true) -(check-match ip-address "256.2.3.4" false) -(check-match ip-address "256.2.3.2514" false) - -# Substitution test with peg - -(file/flush stderr) -(file/flush stdout) - -(def grammar '(accumulate (any (+ (/ "dog" "purple panda") (<- 1))))) -(defn try-grammar [text] - (assert (= (string/replace-all "dog" "purple panda" text) (0 (peg/match grammar text))) text)) - -(try-grammar "i have a dog called doug the dog. he is good.") -(try-grammar "i have a dog called doug the dog. he is a good boy.") -(try-grammar "i have a dog called doug the do") -(try-grammar "i have a dog called doug the dog") -(try-grammar "i have a dog called doug the dogg") -(try-grammar "i have a dog called doug the doggg") -(try-grammar "i have a dog called doug the dogggg") - -# Peg CSV test - -(def csv - '{:field (+ - (* `"` (% (any (+ (<- (if-not `"` 1)) (* (constant `"`) `""`)))) `"`) - (<- (any (if-not (set ",\n") 1)))) - :main (* :field (any (* "," :field)) (+ "\n" -1))}) - -(defn check-csv - [str res] - (check-deep csv str res)) - -(check-csv "1,2,3" @["1" "2" "3"]) -(check-csv "1,\"2\",3" @["1" "2" "3"]) -(check-csv ``1,"1""",3`` @["1" "1\"" "3"]) - -# Nested Captures - -(def grmr '(capture (* (capture "a") (capture 1) (capture "c")))) -(check-deep grmr "abc" @["a" "b" "c" "abc"]) -(check-deep grmr "acc" @["a" "c" "c" "acc"]) - -# Functions in grammar - -(def grmr-triple ~(% (any (/ (<- 1) ,(fn [x] (string x x x)))))) -(check-deep grmr-triple "abc" @["aaabbbccc"]) -(check-deep grmr-triple "" @[""]) -(check-deep grmr-triple " " @[" "]) - -(def counter ~(/ (group (any (<- 1))) ,length)) -(check-deep counter "abcdefg" @[7]) - -# Capture Backtracking - -(check-deep '(+ (* (capture "c") "d") "ce") "ce" @[]) - -# Matchtime capture - -(def scanner (peg/compile ~(cmt (capture (some 1)) ,scan-number))) - -(check-deep scanner "123" @[123]) -(check-deep scanner "0x86" @[0x86]) -(check-deep scanner "-1.3e-7" @[-1.3e-7]) -(check-deep scanner "123A" nil) - -# Recursive grammars - -(def g '{:main (+ (* "a" :main "b") "c")}) - -(check-match g "c" true) -(check-match g "acb" true) -(check-match g "aacbb" true) -(check-match g "aadbb" false) - -# Back reference - -(def wrapped-string - ~{:pad (any "=") - :open (* "[" (<- :pad :n) "[") - :close (* "]" (cmt (* (-> :n) (<- :pad)) ,=) "]") - :main (* :open (any (if-not :close 1)) :close -1)}) - -(check-match wrapped-string "[[]]" true) -(check-match wrapped-string "[==[a]==]" true) -(check-match wrapped-string "[==[]===]" false) -(check-match wrapped-string "[[blark]]" true) -(check-match wrapped-string "[[bl[ark]]" true) -(check-match wrapped-string "[[bl]rk]]" true) -(check-match wrapped-string "[[bl]rk]] " false) -(check-match wrapped-string "[=[bl]]rk]=] " false) -(check-match wrapped-string "[=[bl]==]rk]=] " false) -(check-match wrapped-string "[===[]==]===]" true) - -(def janet-longstring - ~{:delim (some "`") - :open (capture :delim :n) - :close (cmt (* (not (> -1 "`")) (-> :n) (<- (backmatch :n))) ,=) - :main (* :open (any (if-not :close 1)) :close -1)}) - -(check-match janet-longstring "`john" false) -(check-match janet-longstring "abc" false) -(check-match janet-longstring "` `" true) -(check-match janet-longstring "` `" true) -(check-match janet-longstring "`` ``" true) -(check-match janet-longstring "``` `` ```" true) -(check-match janet-longstring "`` ```" false) -(check-match janet-longstring "`a``b`" false) - -# Line and column capture - -(def line-col (peg/compile '(any (* (line) (column) 1)))) -(check-deep line-col "abcd" @[1 1 1 2 1 3 1 4]) -(check-deep line-col "" @[]) -(check-deep line-col "abcd\n" @[1 1 1 2 1 3 1 4 1 5]) -(check-deep line-col "abcd\nz" @[1 1 1 2 1 3 1 4 1 5 2 1]) - -# Backmatch - -(def backmatcher-1 '(* (capture (any "x") :1) "y" (backmatch :1) -1)) - -(check-match backmatcher-1 "y" true) -(check-match backmatcher-1 "xyx" true) -(check-match backmatcher-1 "xxxxxxxyxxxxxxx" true) -(check-match backmatcher-1 "xyxx" false) -(check-match backmatcher-1 "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxy" false) -(check-match backmatcher-1 (string (string/repeat "x" 10000) "y") false) -(check-match backmatcher-1 (string (string/repeat "x" 10000) "y" (string/repeat "x" 10000)) true) - -(def backmatcher-2 '(* '(any "x") "y" (backmatch) -1)) - -(check-match backmatcher-2 "y" true) -(check-match backmatcher-2 "xyx" true) -(check-match backmatcher-2 "xxxxxxxyxxxxxxx" true) -(check-match backmatcher-2 "xyxx" false) -(check-match backmatcher-2 "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxy" false) -(check-match backmatcher-2 (string (string/repeat "x" 10000) "y") false) -(check-match backmatcher-2 (string (string/repeat "x" 10000) "y" (string/repeat "x" 10000)) true) - -(def longstring-2 '(* '(some "`") (some (if-not (backmatch) 1)) (backmatch) -1)) - -(check-match longstring-2 "`john" false) -(check-match longstring-2 "abc" false) -(check-match longstring-2 "` `" true) -(check-match longstring-2 "` `" true) -(check-match longstring-2 "`` ``" true) -(check-match longstring-2 "``` `` ```" true) -(check-match longstring-2 "`` ```" false) - -# Optional - -(check-match '(* (opt "hi") -1) "" true) -(check-match '(* (opt "hi") -1) "hi" true) -(check-match '(* (opt "hi") -1) "no" false) -(check-match '(* (? "hi") -1) "" true) -(check-match '(* (? "hi") -1) "hi" true) -(check-match '(* (? "hi") -1) "no" false) - -# Drop - -(check-deep '(drop '"hello") "hello" @[]) -(check-deep '(drop "hello") "hello" @[]) - -# Regression #24 - -(def t (put @{} :hi 1)) -(assert (deep= t @{:hi 1}) "regression #24") - -# Peg swallowing errors -(assert (try (peg/match ~(/ '1 ,(fn [x] (nil x))) "x") ([err] err)) - "errors should not be swallowed") -(assert (try ((fn [x] (nil x))) ([err] err)) - "errors should not be swallowed 2") - -# Tuple types - -(assert (= (tuple/type '(1 2 3)) :parens) "normal tuple") -(assert (= (tuple/type [1 2 3]) :parens) "normal tuple 1") -(assert (= (tuple/type '[1 2 3]) :brackets) "bracketed tuple 2") -(assert (= (tuple/type (-> '(1 2 3) marshal unmarshal)) :parens) "normal tuple marshalled/unmarshalled") -(assert (= (tuple/type (-> '[1 2 3] marshal unmarshal)) :brackets) "normal tuple marshalled/unmarshalled") - -# Check for bad memoization (+ :a) should mean different things in different contexts. -(def redef-a - ~{:a "abc" - :c (+ :a) - :main (* :c {:a "def" :main (+ :a)} -1)}) - -(check-match redef-a "abcdef" true) -(check-match redef-a "abcabc" false) -(check-match redef-a "defdef" false) - -(def redef-b - ~{:pork {:pork "beef" :main (+ -1 (* 1 :pork))} - :main :pork}) - -(check-match redef-b "abeef" true) -(check-match redef-b "aabeef" false) -(check-match redef-b "aaaaaa" false) - -# Integer parsing - -(check-deep '(int 1) "a" @[(chr "a")]) -(check-deep '(uint 1) "a" @[(chr "a")]) -(check-deep '(int-be 1) "a" @[(chr "a")]) -(check-deep '(uint-be 1) "a" @[(chr "a")]) -(check-deep '(int 1) "\xFF" @[-1]) -(check-deep '(uint 1) "\xFF" @[255]) -(check-deep '(int-be 1) "\xFF" @[-1]) -(check-deep '(uint-be 1) "\xFF" @[255]) -(check-deep '(int 2) "\xFF\x7f" @[0x7fff]) -(check-deep '(int-be 2) "\x7f\xff" @[0x7fff]) -(check-deep '(uint 2) "\xff\x7f" @[0x7fff]) -(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) -(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) -(check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(int/u64 0x7fff)]) -(check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(int/s64 0x7fff)]) -(check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/u64 0x7fff)]) -(check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/s64 0x7fff)]) - -(check-deep '(* (int 2) -1) "123" nil) - -# to/thru bug -(check-deep '(to -1) "aaaa" @[]) -(check-deep '(thru -1) "aaaa" @[]) -(check-deep ''(to -1) "aaaa" @["aaaa"]) -(check-deep ''(thru -1) "aaaa" @["aaaa"]) -(check-deep '(to "b") "aaaa" nil) -(check-deep '(thru "b") "aaaa" nil) - -# unref -(def grammar - (peg/compile - ~{:main (* :tagged -1) - :tagged (unref (replace (* :open-tag :value :close-tag) ,struct)) - :open-tag (* (constant :tag) "<" (capture :w+ :tag-name) ">") - :value (* (constant :value) (group (any (+ :tagged :untagged)))) - :close-tag (* "") - :untagged (capture (any (if-not "<" 1)))})) -(check-deep grammar "

foobar

" @[{:tag "p" :value @[{:tag "em" :value @["foobar"]}]}]) -(check-deep grammar "

foobar

" @[{:tag "p" :value @["foobar"]}]) - -(end-suite) diff --git a/test/suite0004.janet b/test/suite0004.janet deleted file mode 100644 index e002b2f1..00000000 --- a/test/suite0004.janet +++ /dev/null @@ -1,86 +0,0 @@ -# Copyright (c) 2023 Calvin Rose -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 4) -# some tests for string/format and buffer/format - -(assert (= (string (buffer/format @"" "pi = %6.3f" math/pi)) "pi = 3.142") "%6.3f") -(assert (= (string (buffer/format @"" "pi = %+6.3f" math/pi)) "pi = +3.142") "%6.3f") -(assert (= (string (buffer/format @"" "pi = %40.20g" math/pi)) "pi = 3.141592653589793116") "%6.3f") - -(assert (= (string (buffer/format @"" "🐼 = %6.3f" math/pi)) "🐼 = 3.142") "UTF-8") -(assert (= (string (buffer/format @"" "π = %.8g" math/pi)) "π = 3.1415927") "π") -(assert (= (string (buffer/format @"" "\xCF\x80 = %.8g" math/pi)) "\xCF\x80 = 3.1415927") "\xCF\x80") - -(assert (= (string/format "pi = %6.3f" math/pi) "pi = 3.142") "%6.3f") -(assert (= (string/format "pi = %+6.3f" math/pi) "pi = +3.142") "%6.3f") -(assert (= (string/format "pi = %40.20g" math/pi) "pi = 3.141592653589793116") "%6.3f") - -(assert (= (string/format "🐼 = %6.3f" math/pi) "🐼 = 3.142") "UTF-8") -(assert (= (string/format "π = %.8g" math/pi) "π = 3.1415927") "π") -(assert (= (string/format "\xCF\x80 = %.8g" math/pi) "\xCF\x80 = 3.1415927") "\xCF\x80") - -# Range -(assert (deep= (range 10) @[0 1 2 3 4 5 6 7 8 9]) "range 1 argument") -(assert (deep= (range 5 10) @[5 6 7 8 9]) "range 2 arguments") -(assert (deep= (range 5 10 2) @[5 7 9]) "range 3 arguments") - -# More marshalling code - -(defn check-image - "Run a marshaling test using the make-image and load-image functions." - [x msg] - (def im (make-image x)) - # (printf "\nimage-hash: %d" (-> im string hash)) - (assert-no-error msg (load-image im))) - -(check-image (fn [] (fn [] 1)) "marshal nested functions") -(check-image (fiber/new (fn [] (fn [] 1))) "marshal nested functions in fiber") -(check-image (fiber/new (fn [] (fiber/new (fn [] 1)))) "marshal nested fibers") - -(def issue-53-x - (fiber/new - (fn [] - (var y (fiber/new (fn [] (print "1") (yield) (print "2"))))))) - -(check-image issue-53-x "issue 53 regression") - -# Bracket tuple issue - -(def do 3) -(assert (= [3 1 2 3] [do 1 2 3]) "bracket tuples are never special forms") -(assert (= ~(,defn 1 2 3) [defn 1 2 3]) "bracket tuples are never macros") -(assert (= ~(,+ 1 2 3) [+ 1 2 3]) "bracket tuples are never function calls") - -# Metadata - -(def foo-with-tags :a-tag :bar) -(assert (get (dyn 'foo-with-tags) :a-tag) "extra keywords in def are metadata tags") - -(def foo-with-meta {:baz :quux} :bar) -(assert (= :quux (get (dyn 'foo-with-meta) :baz)) "extra struct in def is metadata") - -(defn foo-fn-with-meta {:baz :quux} "This is a function" [x] (identity x)) -(assert (= :quux (get (dyn 'foo-fn-with-meta) :baz)) "extra struct in defn is metadata") -(assert (= "(foo-fn-with-meta x)\n\nThis is a function" (get (dyn 'foo-fn-with-meta) :doc)) "extra string in defn is docstring") - -(end-suite) - diff --git a/test/suite0005.janet b/test/suite0005.janet deleted file mode 100644 index 1733ae8b..00000000 --- a/test/suite0005.janet +++ /dev/null @@ -1,120 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 5) - -# Array remove - -(assert (deep= (array/remove @[1 2 3 4 5] 2) @[1 2 4 5]) "array/remove 1") -(assert (deep= (array/remove @[1 2 3 4 5] 2 2) @[1 2 5]) "array/remove 2") -(assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3") -(assert (deep= (array/remove @[1 2 3 4 5] -3 200) @[1 2 3]) "array/remove 4") - -# Break - -(var summation 0) -(for i 0 10 - (+= summation i) - (if (= i 7) (break))) -(assert (= summation 28) "break 1") - -(assert (= nil ((fn [] (break) 4))) "break 2") - -# Break with value - -# Shouldn't error out -(assert-no-error "break 3" (for i 0 10 (if (> i 8) (break i)))) -(assert-no-error "break 4" ((fn [i] (if (> i 8) (break i))) 100)) - -# take - -(assert (deep= (take 0 []) []) "take 1") -(assert (deep= (take 10 []) []) "take 2") -(assert (deep= (take 0 [1 2 3 4 5]) []) "take 3") -(assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4") -(assert (deep= (take -1 [:a :b :c]) []) "take 5") -(assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3]) "take from fiber") -# NB: repeatedly resuming a fiber created with `generate` includes a `nil` as -# the final element. Thus a generate of 2 elements will create an array of 3. -(assert (= (length (take 4 (generate [x :in [1 2]] x))) 2) "take from short fiber") - -# take-until - -(assert (deep= (take-until pos? @[]) []) "take-until 1") -(assert (deep= (take-until pos? @[1 2 3]) []) "take-until 2") -(assert (deep= (take-until pos? @[-1 -2 -3]) [-1 -2 -3]) "take-until 3") -(assert (deep= (take-until pos? @[-1 -2 3]) [-1 -2]) "take-until 4") -(assert (deep= (take-until pos? @[-1 1 -2]) [-1]) "take-until 5") -(assert (deep= (take-until |(= $ 115) "books") "book") "take-until 6") -(assert (deep= (take-until |(= $ 115) (generate [x :in "books"] x)) - @[98 111 111 107]) "take-until from fiber") - -# take-while - -(assert (deep= (take-while neg? @[]) []) "take-while 1") -(assert (deep= (take-while neg? @[1 2 3]) []) "take-while 2") -(assert (deep= (take-while neg? @[-1 -2 -3]) [-1 -2 -3]) "take-while 3") -(assert (deep= (take-while neg? @[-1 -2 3]) [-1 -2]) "take-while 4") -(assert (deep= (take-while neg? @[-1 1 -2]) [-1]) "take-while 5") -(assert (deep= (take-while neg? (generate [x :in @[-1 1 -2]] x)) - @[-1]) "take-while from fiber") - -# drop - -(assert (deep= (drop 0 []) []) "drop 1") -(assert (deep= (drop 10 []) []) "drop 2") -(assert (deep= (drop 0 [1 2 3 4 5]) [1 2 3 4 5]) "drop 3") -(assert (deep= (drop 10 [1 2 3]) []) "drop 4") -(assert (deep= (drop -1 [1 2 3]) [1 2]) "drop 5") -(assert (deep= (drop -10 [1 2 3]) []) "drop 6") -(assert (deep= (drop 1 "abc") "bc") "drop 7") -(assert (deep= (drop 10 "abc") "") "drop 8") -(assert (deep= (drop -1 "abc") "ab") "drop 9") -(assert (deep= (drop -10 "abc") "") "drop 10") -(assert-error :invalid-type (drop 3 {}) "drop 11") - -# drop-until - -(assert (deep= (drop-until pos? @[]) []) "drop-until 1") -(assert (deep= (drop-until pos? @[1 2 3]) [1 2 3]) "drop-until 2") -(assert (deep= (drop-until pos? @[-1 -2 -3]) []) "drop-until 3") -(assert (deep= (drop-until pos? @[-1 -2 3]) [3]) "drop-until 4") -(assert (deep= (drop-until pos? @[-1 1 -2]) [1 -2]) "drop-until 5") -(assert (deep= (drop-until |(= $ 115) "books") "s") "drop-until 6") - -# Quasiquote bracketed tuples -(assert (= (tuple/type ~[1 2 3]) (tuple/type '[1 2 3])) "quasiquote bracket tuples") - -# No useless splices -(check-compile-error '((splice [1 2 3]) 0)) -(check-compile-error '(if ;[1 2] 5)) -(check-compile-error '(while ;[1 2 3] (print :hi))) -(check-compile-error '(def x ;[1 2 3])) -(check-compile-error '(fn [x] ;[x 1 2 3])) - -# No splice propagation -(check-compile-error '(+ 1 (do ;[2 3 4]) 5)) -(check-compile-error '(+ 1 (upscope ;[2 3 4]) 5)) -# compiler inlines when condition is constant, ensure that optimization doesn't break -(check-compile-error '(+ 1 (if true ;[3 4]))) -(check-compile-error '(+ 1 (if false nil ;[3 4]))) - -(end-suite) diff --git a/test/suite0006.janet b/test/suite0006.janet deleted file mode 100644 index 1e8b7237..00000000 --- a/test/suite0006.janet +++ /dev/null @@ -1,272 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 6) - -# some tests for bigint - -(def i64 int/s64) -(def u64 int/u64) - -(assert-no-error - "create some uint64 bigints" - (do - # from number - (def a (u64 10)) - # max double we can convert to int (2^53) - (def b (u64 0x1fffffffffffff)) - (def b (u64 (math/pow 2 53))) - # from string - (def c (u64 "0xffff_ffff_ffff_ffff")) - (def c (u64 "32rvv_vv_vv_vv")) - (def d (u64 "123456789")))) - -# Conversion back to an int32 -(assert (= (int/to-number (u64 0xFaFa)) 0xFaFa)) -(assert (= (int/to-number (i64 0xFaFa)) 0xFaFa)) -(assert (= (int/to-number (u64 9007199254740991)) 9007199254740991)) -(assert (= (int/to-number (i64 9007199254740991)) 9007199254740991)) -(assert (= (int/to-number (i64 -9007199254740991)) -9007199254740991)) - -(assert-error - "u64 out of bounds for safe integer" - (int/to-number (u64 "9007199254740993")) - -(assert-error - "s64 out of bounds for safe integer" - (int/to-number (i64 "-9007199254740993")))) - -(assert-error - "int/to-number fails on non-abstract types" - (int/to-number 1)) - -(assert-no-error - "create some int64 bigints" - (do - # from number - (def a (i64 -10)) - # max double we can convert to int (2^53) - (def b (i64 0x1fffffffffffff)) - (def b (i64 (math/pow 2 53))) - # from string - (def c (i64 "0x7fff_ffff_ffff_ffff")) - (def d (i64 "123456789")))) - -(assert-error - "bad initializers" - (do - # double to big to be converted to uint64 without truncation (2^53 + 1) - (def b (u64 (+ 0xffff_ffff_ffff_ff 1))) - (def b (u64 (+ (math/pow 2 53) 1))) - # out of range 65 bits - (def c (u64 "0x1ffffffffffffffff")) - # just to big - (def d (u64 "123456789123456789123456789")))) - -(assert (= (:/ (u64 "0xffff_ffff_ffff_ffff") 8 2) (u64 "0xfffffffffffffff")) "bigint operations 1") -(assert (let [a (u64 0xff)] (= (:+ a a a a) (:* a 2 2))) "bigint operations 2") - -(assert (= (string (i64 -123)) "-123") "i64 prints reasonably") -(assert (= (string (u64 123)) "123") "u64 prints reasonably") - -(assert-error - "trap INT64_MIN / -1" - (:/ (int/s64 "-0x8000_0000_0000_0000") -1)) - -# int/s64 and int/u64 serialization -(assert (deep= (int/to-bytes (u64 0)) @"\x00\x00\x00\x00\x00\x00\x00\x00")) - -(assert (deep= (int/to-bytes (i64 1) :le) @"\x01\x00\x00\x00\x00\x00\x00\x00")) -(assert (deep= (int/to-bytes (i64 1) :be) @"\x00\x00\x00\x00\x00\x00\x00\x01")) -(assert (deep= (int/to-bytes (i64 -1)) @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF")) -(assert (deep= (int/to-bytes (i64 -5) :be) @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFB")) - -(assert (deep= (int/to-bytes (u64 1) :le) @"\x01\x00\x00\x00\x00\x00\x00\x00")) -(assert (deep= (int/to-bytes (u64 1) :be) @"\x00\x00\x00\x00\x00\x00\x00\x01")) -(assert (deep= (int/to-bytes (u64 300) :be) @"\x00\x00\x00\x00\x00\x00\x01\x2C")) - -# int/s64 int/u64 to existing buffer -(let [buf1 @"" - buf2 @"abcd"] - (assert (deep= (int/to-bytes (i64 1) :le buf1) @"\x01\x00\x00\x00\x00\x00\x00\x00")) - (assert (deep= buf1 @"\x01\x00\x00\x00\x00\x00\x00\x00")) - (assert (deep= (int/to-bytes (u64 300) :be buf2) @"abcd\x00\x00\x00\x00\x00\x00\x01\x2C"))) - -# int/s64 and int/u64 paramater type checking -(assert-error - "bad value passed to int/to-bytes" - (int/to-bytes 1)) - -(assert-error - "invalid endianness passed to int/to-bytes" - (int/to-bytes (u64 0) :little)) - -(assert-error - "invalid buffer passed to int/to-bytes" - (int/to-bytes (u64 0) :little :buffer)) - - -# Dynamic bindings -(setdyn :a 10) -(assert (= 40 (with-dyns [:a 25 :b 15] (+ (dyn :a) (dyn :b)))) "dyn usage 1") -(assert (= 10 (dyn :a)) "dyn usage 2") -(assert (= nil (dyn :b)) "dyn usage 3") -(setdyn :a 100) -(assert (= 100 (dyn :a)) "dyn usage 4") - -# Keyword arguments -(defn myfn [x y z &keys {:a a :b b :c c}] - (+ x y z a b c)) - -(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 3 :b 4 :c 5)) "keyword args 1") -(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 1 :b 6 :c 5 :d 11)) "keyword args 2") - -# Comment macro -(comment 1) -(comment 1 2) -(comment 1 2 3) -(comment 1 2 3 4) - -# Parser clone -(def p (parser/new)) -(assert (= 7 (parser/consume p "(1 2 3 ")) "parser 1") -(def p2 (parser/clone p)) -(parser/consume p2 ") 1 ") -(parser/consume p ") 1 ") -(assert (deep= (parser/status p) (parser/status p2)) "parser 2") -(assert (deep= (parser/state p) (parser/state p2)) "parser 3") - -# Parser errors -(defn parse-error [input] - (def p (parser/new)) - (parser/consume p input) - (parser/error p)) - -# Invalid utf-8 sequences -(assert (not= nil (parse-error @"\xc3\x28")) "reject invalid utf-8 symbol") -(assert (not= nil (parse-error @":\xc3\x28")) "reject invalid utf-8 keyword") - -# Parser line and column numbers -(defn parser-location [input &opt location] - (def p (parser/new)) - (parser/consume p input) - (if location - (parser/where p ;location) - (parser/where p))) - -(assert (= [1 7] (parser-location @"(+ 1 2)")) "parser location 1") -(assert (= [5 7] (parser-location @"(+ 1 2)" [5])) "parser location 2") -(assert (= [10 10] (parser-location @"(+ 1 2)" [10 10])) "parser location 3") - -# String check-set -(assert (string/check-set "abc" "a") "string/check-set 1") -(assert (not (string/check-set "abc" "z")) "string/check-set 2") -(assert (string/check-set "abc" "abc") "string/check-set 3") -(assert (string/check-set "abc" "") "string/check-set 4") -(assert (not (string/check-set "" "aabc")) "string/check-set 5") -(assert (not (string/check-set "abc" "abcdefg")) "string/check-set 6") - -# Marshal and unmarshal pegs -(def p (-> "abcd" peg/compile marshal unmarshal)) -(assert (peg/match p "abcd") "peg marshal 1") -(assert (peg/match p "abcdefg") "peg marshal 2") -(assert (not (peg/match p "zabcdefg")) "peg marshal 3") - -# This should be valgrind clean. -(var pegi 3) -(defn marshpeg [p] - (assert (-> p peg/compile marshal unmarshal) (string "peg marshal " (++ pegi)))) -(marshpeg '(* 1 2 (set "abcd") "asdasd" (+ "." 3))) -(marshpeg '(% (* (+ 1 2 3) (* "drop" "bear") '"hi"))) -(marshpeg '(> 123 "abcd")) -(marshpeg '{:main (* 1 "hello" :main)}) -(marshpeg '(range "AZ")) -(marshpeg '(if-not "abcdf" 123)) -(marshpeg '(error ($))) -(marshpeg '(* "abcd" (constant :hi))) -(marshpeg ~(/ "abc" ,identity)) -(marshpeg '(if-not "abcdf" 123)) -(marshpeg ~(cmt "abcdf" ,identity)) -(marshpeg '(group "abc")) - -# Module path expansion -(setdyn :current-file "some-dir/some-file") -(defn test-expand [path temp] - (string (module/expand-path path temp))) - -# Right hand operators -(assert (= (int/s64 (sum (range 10))) (sum (map int/s64 (range 10)))) "right hand operators 1") -(assert (= (int/s64 (product (range 1 10))) (product (map int/s64 (range 1 10)))) "right hand operators 2") -(assert (= (int/s64 15) (bor 10 (int/s64 5)) (bor (int/s64 10) 5)) "right hand operators 3") - -(assert (= (test-expand "abc" ":cur:/:all:") "some-dir/abc") "module/expand-path 1") -(assert (= (test-expand "./abc" ":cur:/:all:") "some-dir/abc") "module/expand-path 2") -(assert (= (test-expand "abc/def.txt" ":cur:/:name:") "some-dir/def.txt") "module/expand-path 3") -(assert (= (test-expand "abc/def.txt" ":cur:/:dir:/sub/:name:") "some-dir/abc/sub/def.txt") "module/expand-path 4") -(assert (= (test-expand "/abc/../def.txt" ":all:") "/def.txt") "module/expand-path 5") -(assert (= (test-expand "abc/../def.txt" ":all:") "def.txt") "module/expand-path 6") -(assert (= (test-expand "../def.txt" ":all:") "../def.txt") "module/expand-path 7") -(assert (= (test-expand "../././././abcd/../def.txt" ":all:") "../def.txt") "module/expand-path 8") - -# Integer type checks -(assert (compare= 0 (- (int/u64 "1000") 1000)) "subtract from int/u64") - -(assert (odd? (int/u64 "1001")) "odd? 1") -(assert (not (odd? (int/u64 "1000"))) "odd? 2") -(assert (odd? (int/s64 "1001")) "odd? 3") -(assert (not (odd? (int/s64 "1000"))) "odd? 4") -(assert (odd? (int/s64 "-1001")) "odd? 5") -(assert (not (odd? (int/s64 "-1000"))) "odd? 6") - -(assert (even? (int/u64 "1000")) "even? 1") -(assert (not (even? (int/u64 "1001"))) "even? 2") -(assert (even? (int/s64 "1000")) "even? 3") -(assert (not (even? (int/s64 "1001"))) "even? 4") -(assert (even? (int/s64 "-1000")) "even? 5") -(assert (not (even? (int/s64 "-1001"))) "even? 6") - -# integer type operations -(defn modcheck [x y] - (assert (= (string (mod x y)) (string (mod (int/s64 x) y))) - (string "int/s64 (mod " x " " y ") expected " (mod x y) ", got " - (mod (int/s64 x) y))) - (assert (= (string (% x y)) (string (% (int/s64 x) y))) - (string "int/s64 (% " x " " y ") expected " (% x y) ", got " - (% (int/s64 x) y)))) - -(modcheck 1 2) -(modcheck 1 3) -(modcheck 4 2) -(modcheck 4 1) -(modcheck 10 3) -(modcheck 10 -3) -(modcheck -10 3) -(modcheck -10 -3) - -# Check for issue #1130 -(var d (int/s64 7)) -(mod 0 d) - -(var d (int/s64 7)) -(def result (seq [n :in (range -21 0)] (mod n d))) -(assert (deep= result (map int/s64 @[0 1 2 3 4 5 6 0 1 2 3 4 5 6 0 1 2 3 4 5 6])) "issue #1130") - -(end-suite) diff --git a/test/suite0007.janet b/test/suite0007.janet deleted file mode 100644 index e6085cf2..00000000 --- a/test/suite0007.janet +++ /dev/null @@ -1,344 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 7) - -# Using a large test grammar - -(def- specials {'fn true - 'var true - 'do true - 'while true - 'def true - 'splice true - 'set true - 'unquote true - 'quasiquote true - 'quote true - 'if true}) - -(defn- check-number [text] (and (scan-number text) text)) - -(defn capture-sym - [text] - (def sym (symbol text)) - [(if (or (root-env sym) (specials sym)) :coresym :symbol) text]) - -(def grammar - ~{:ws (set " \v\t\r\f\n\0") - :readermac (set "';~,") - :symchars (+ (range "09" "AZ" "az" "\x80\xFF") (set "!$%&*+-./:@^_|")) - :token (some :symchars) - :hex (range "09" "af" "AF") - :escape (* "\\" (+ (set "ntrvzf0e\"\\") - (* "x" :hex :hex) - (error (constant "bad hex escape")))) - :comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment)) - :symbol (/ ':token ,capture-sym) - :keyword (/ '(* ":" (any :symchars)) (constant :keyword)) - :constant (/ '(+ "true" "false" "nil") (constant :constant)) - :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"") - :string (/ ':bytes (constant :string)) - :buffer (/ '(* "@" :bytes) (constant :string)) - :long-bytes {:delim (some "`") - :open (capture :delim :n) - :close (cmt (* (not (> -1 "`")) (-> :n) '(backmatch :n)) ,=) - :main (drop (* :open (any (if-not :close 1)) :close))} - :long-string (/ ':long-bytes (constant :string)) - :long-buffer (/ '(* "@" :long-bytes) (constant :string)) - :number (/ (cmt ':token ,check-number) (constant :number)) - :raw-value (+ :comment :constant :number :keyword - :string :buffer :long-string :long-buffer - :parray :barray :ptuple :btuple :struct :dict :symbol) - :value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws)) - :root (any :value) - :root2 (any (* :value :value)) - :ptuple (* '"(" :root (+ '")" (error ""))) - :btuple (* '"[" :root (+ '"]" (error ""))) - :struct (* '"{" :root2 (+ '"}" (error ""))) - :parray (* '"@" :ptuple) - :barray (* '"@" :btuple) - :dict (* '"@" :struct) - :main (+ :root (error ""))}) - -(def p (peg/compile grammar)) - -# Just make sure is valgrind clean. -(def p (-> p make-image load-image)) - -(assert (peg/match p "abc") "complex peg grammar 1") -(assert (peg/match p "[1 2 3 4]") "complex peg grammar 2") - -# -# fn compilation special -# -(defn myfn1 [[x y z] & more] - more) -(defn myfn2 [head & more] - more) -(assert (= (myfn1 [1 2 3] 4 5 6) (myfn2 [:a :b :c] 4 5 6)) "destructuring and varargs") - -# -# Test propagation of signals via fibers -# - -(def f (fiber/new (fn [] (error :abc) 1) :ei)) -(def res (resume f)) -(assert-error :abc (propagate res f) "propagate 1") - -# table/clone - -(defn check-table-clone [x msg] - (assert (= (table/to-struct x) (table/to-struct (table/clone x))) msg)) - -(check-table-clone @{:a 123 :b 34 :c :hello : 945 0 1 2 3 4 5} "table/clone 1") -(check-table-clone @{} "table/clone 1") - -# Make sure Carriage Returns don't end up in doc strings. - -(assert (not (string/find "\r" (get ((fiber/getenv (fiber/current)) 'cond) :doc ""))) "no \\r in doc strings") - -# module/expand-path regression -(with-dyns [:syspath ".janet/.janet"] - (assert (= (string (module/expand-path "hello" ":sys:/:all:.janet")) - ".janet/.janet/hello.janet") "module/expand-path 1")) - -# comp should be variadic -(assert (= 10 ((comp +) 1 2 3 4)) "variadic comp 1") -(assert (= 11 ((comp inc +) 1 2 3 4)) "variadic comp 2") -(assert (= 12 ((comp inc inc +) 1 2 3 4)) "variadic comp 3") -(assert (= 13 ((comp inc inc inc +) 1 2 3 4)) "variadic comp 4") -(assert (= 14 ((comp inc inc inc inc +) 1 2 3 4)) "variadic comp 5") -(assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6") -(assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4)) "variadic comp 7") - -# Function shorthand -(assert (= (|(+ 1 2 3)) 6) "function shorthand 1") -(assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2") -(assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3") -(assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4") -(assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5") -(assert (= (|4) 4) "function shorthand 6") -(assert (= (((|||4))) 4) "function shorthand 7") -(assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8") -(assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9") -(assert (= (|(+ $0 $99) ;(range 100)) 99) "function shorthand 10") - -# Simple function break -(debug/fbreak map 1) -(def f (fiber/new (fn [] (map inc [1 2 3])) :a)) -(resume f) -(assert (= :debug (fiber/status f)) "debug/fbreak") -(debug/unfbreak map 1) -(map inc [1 2 3]) - -(defn idx= [x y] (= (tuple/slice x) (tuple/slice y))) - -# Simple take, drop, etc. tests. -(assert (idx= (take 10 (range 100)) (range 10)) "take 10") -(assert (idx= (drop 10 (range 100)) (range 10 100)) "drop 10") - -# Printing to buffers -(def out-buf @"") -(def err-buf @"") -(with-dyns [:out out-buf :err err-buf] - (print "Hello") - (prin "hi") - (eprint "Sup") - (eprin "not much.")) - -(assert (= (string out-buf) "Hello\nhi") "print and prin to buffer 1") -(assert (= (string err-buf) "Sup\nnot much.") "eprint and eprin to buffer 1") - -# Printing to functions -(def out-buf @"") -(defn prepend [x] - (with-dyns [:out out-buf] - (prin "> " x))) -(with-dyns [:out prepend] - (print "Hello world")) - -(assert (= (string out-buf) "> Hello world\n") "print to buffer via function") - -(assert (= (string '()) (string [])) "empty bracket tuple literal") - -# with-vars -(var abc 123) -(assert (= 356 (with-vars [abc 456] (- abc 100))) "with-vars 1") -(assert-error "with-vars 2" (with-vars [abc 456] (error :oops))) -(assert (= abc 123) "with-vars 3") - -# Trim empty string -(assert (= "" (string/trim " ")) "string/trim regression") - -# RNGs - -(defn test-rng - [rng] - (assert (all identity (seq [i :range [0 1000]] - (<= (math/rng-int rng i) i))) "math/rng-int test") - (assert (all identity (seq [i :range [0 1000]] - (def x (math/rng-uniform rng)) - (and (>= x 0) (< x 1)))) - "math/rng-uniform test")) - -(def seedrng (math/rng 123)) -(for i 0 75 - (test-rng (math/rng (:int seedrng)))) - -(assert (deep-not= (-> 123 math/rng (:buffer 16)) - (-> 456 math/rng (:buffer 16))) "math/rng-buffer 1") - -(assert-no-error "math/rng-buffer 2" (math/seedrandom "abcdefg")) - -# OS Date test - -(assert (deep= {:year-day 0 - :minutes 30 - :month 0 - :dst false - :seconds 0 - :year 2014 - :month-day 0 - :hours 20 - :week-day 3} - (os/date 1388608200)) "os/date") - -# OS mktime test - -(assert (= 1388608200 (os/mktime {:year-day 0 - :minutes 30 - :month 0 - :dst false - :seconds 0 - :year 2014 - :month-day 0 - :hours 20 - :week-day 3})) "os/mktime") - -(def now (os/time)) -(assert (= (os/mktime (os/date now)) now) "UTC os/mktime") -(assert (= (os/mktime (os/date now true) true) now) "local os/mktime") -(assert (= (os/mktime {:year 1970}) 0) "os/mktime default values") - -# OS strftime test - -(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 0) "1970-01-01 00:00:00") "strftime UTC epoch") -(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 1388608200) "2014-01-01 20:30:00") "strftime january 2014") -(assert (= (try (os/strftime "%%%d%t") ([err] err)) "invalid conversion specifier '%t'") "invalid conversion specifier") - -# Appending buffer to self - -(with-dyns [:out @""] - (prin "abcd") - (prin (dyn :out)) - (prin (dyn :out)) - (assert (deep= (dyn :out) @"abcdabcdabcdabcd") "print buffer to self")) - -(os/setenv "TESTENV1" "v1") -(os/setenv "TESTENV2" "v2") -(assert (= (os/getenv "TESTENV1") "v1") "getenv works") -(def environ (os/environ)) -(assert (= [(environ "TESTENV1") (environ "TESTENV2")] ["v1" "v2"]) "environ works") - -# Issue #183 - just parse it :) -1e-4000000000000000000000 - -# Ensure randomness puts n of pred into our buffer eventually -(defn cryptorand-check - [n pred] - (def max-attempts 10000) - (var attempts 0) - (while (not= attempts max-attempts) - (def cryptobuf (os/cryptorand 10)) - (when (= n (count pred cryptobuf)) - (break)) - (++ attempts)) - (not= attempts max-attempts)) - -(def v (math/rng-int (math/rng (os/time)) 100)) -(assert (cryptorand-check 0 |(= $ v)) "cryptorand skips value sometimes") -(assert (cryptorand-check 1 |(= $ v)) "cryptorand has value sometimes") - -(do - (def buf (buffer/new-filled 1)) - (os/cryptorand 1 buf) - (assert (= (in buf 0) 0) "cryptorand doesn't overwrite buffer") - (assert (= (length buf) 2) "cryptorand appends to buffer")) - -# Nested quasiquotation - -(def nested ~(a ~(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) -(assert (deep= nested '(a ~(b ,(+ 1 2) ,(foo 4 d) e) f)) "nested quasiquote") - -# Top level unquote -(defn constantly - [] - (comptime (math/random))) - -(assert (= (constantly) (constantly)) "comptime 1") - -(assert-error "arity issue in macro" (eval '(each []))) -(assert-error "comptime issue" (eval '(comptime (error "oops")))) - -(with [f (file/temp)] - (assert (= 0 (file/tell f)) "start of file") - (file/write f "foo\n") - (assert (= 4 (file/tell f)) "after written string") - (file/flush f) - (file/seek f :set 0) - (assert (= 0 (file/tell f)) "start of file again") - (assert (= (string (file/read f :all)) "foo\n") "temp files work")) - -(var counter 0) -(when-with [x nil |$] - (++ counter)) -(when-with [x 10 |$] - (+= counter 10)) - -(assert (= 10 counter) "when-with 1") - -(if-with [x nil |$] (++ counter) (+= counter 10)) -(if-with [x true |$] (+= counter 20) (+= counter 30)) - -(assert (= 40 counter) "if-with 1") - -(def a @[]) -(eachk x [:a :b :c :d] - (array/push a x)) -(assert (deep= (range 4) a) "eachk 1") - - -(with-dyns [:err @""] - (tracev (def my-unique-var-name true)) - (assert my-unique-var-name "tracev upscopes")) - -(assert (pos? (length (gensym))) "gensym not empty, regression #753") - -(assert-no-error (os/clock :realtime) "realtime clock") -(assert-no-error (os/clock :cputime) "cputime clock") -(assert-no-error (os/clock :monotonic) "monotonic clock") - -(def before (os/clock :monotonic)) -(def after (os/clock :monotonic)) -(assert (>= after before) "monotonic clock is monotonic") - -(end-suite) diff --git a/test/suite0008.janet b/test/suite0008.janet deleted file mode 100644 index 1bec7190..00000000 --- a/test/suite0008.janet +++ /dev/null @@ -1,384 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 8) - -### -### Compiling brainfuck to Janet. -### - -(def- bf-peg - "Peg for compiling brainfuck into a Janet source ast." - (peg/compile - ~{:+ (/ '(some "+") ,(fn [x] ~(+= (DATA POS) ,(length x)))) - :- (/ '(some "-") ,(fn [x] ~(-= (DATA POS) ,(length x)))) - :> (/ '(some ">") ,(fn [x] ~(+= POS ,(length x)))) - :< (/ '(some "<") ,(fn [x] ~(-= POS ,(length x)))) - :. (* "." (constant (prinf "%c" (get DATA POS)))) - :loop (/ (* "[" :main "]") ,(fn [& captures] - ~(while (not= (get DATA POS) 0) - ,;captures))) - :main (any (+ :s :loop :+ :- :> :< :.))})) - -(defn bf - "Run brainfuck." - [text] - (eval - ~(let [DATA (array/new-filled 100 0)] - (var POS 50) - ,;(peg/match bf-peg text)))) - -(defn test-bf - "Test some bf for expected output." - [input output] - (def b @"") - (with-dyns [:out b] - (bf input)) - (assert (= (string output) (string b)) - (string "bf input '" - input - "' failed, expected " - (describe output) - ", got " - (describe (string b)) - "."))) - -(test-bf "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++." "Hello World!\n") - -(test-bf ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>-> -+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+.>+." - "Hello World!\n") - -(test-bf "+[+[<<<+>>>>]+<-<-<<<+<++]<<.<++.<++..+++.<<++.<---.>>.>.+++.------.>-.>>--." - "Hello, World!") - -# Prompts and Labels - -(assert (= 10 (label a (for i 0 10 (if (= i 5) (return a 10))))) "label 1") - -(defn recur - [lab x y] - (when (= x y) (return lab :done)) - (def res (label newlab (recur (or lab newlab) (+ x 1) y))) - (if lab :oops res)) -(assert (= :done (recur nil 0 10)) "label 2") - -(assert (= 10 (prompt :a (for i 0 10 (if (= i 5) (return :a 10))))) "prompt 1") - -(defn- inner-loop - [i] - (if (= i 5) - (return :a 10))) - -(assert (= 10 (prompt :a (for i 0 10 (inner-loop i)))) "prompt 2") - -(defn- inner-loop2 - [i] - (try - (if (= i 5) - (error 10)) - ([err] (return :a err)))) - -(assert (= 10 (prompt :a (for i 0 10 (inner-loop2 i)))) "prompt 3") - -# Match checks - -(assert (= :hi (match nil nil :hi)) "match 1") -(assert (= :hi (match {:a :hi} {:a a} a)) "match 2") -(assert (= nil (match {:a :hi} {:a a :b b} a)) "match 3") -(assert (= nil (match [1 2] [a b c] a)) "match 4") -(assert (= 2 (match [1 2] [a b] b)) "match 5") -(assert (= [2 :a :b] (match [1 2 :a :b] [o & rest] rest)) "match 6") -(assert (= [] (match @[:a] @[x & r] r :fallback)) "match 7") -(assert (= :fallback (match @[1] @[x y & r] r :fallback)) "match 8") -(assert (= [1 2 3 4] (match @[1 2 3 4] @[x y z & r] [x y z ;r] :fallback)) "match 9") - -# And/or checks - -(assert (= false (and false false)) "and 1") -(assert (= false (or false false)) "or 1") - -# #300 Regression test - -# Just don't segfault -(assert (peg/match '{:main (replace "S" {"S" :spade})} "S7") "regression #300") - -# Test cases for #293 -(assert (= :yes (match [1 2 3] [_ a _] :yes :no)) "match wildcard 1") -(assert (= :no (match [1 2 3] [__ a __] :yes :no)) "match wildcard 2") -(assert (= :yes (match [1 2 [1 2 3]] [_ a [_ _ _]] :yes :no)) "match wildcard 3") -(assert (= :yes (match [1 2 3] (_ (even? 2)) :yes :no)) "match wildcard 4") -(assert (= :yes (match {:a 1} {:a _} :yes :no)) "match wildcard 5") -(assert (= false (match {:a 1 :b 2 :c 3} {:a a :b _ :c _ :d _} :no {:a _ :b _ :c _} false :no)) "match wildcard 6") -(assert (= nil (match {:a 1 :b 2 :c 3} {:a a :b _ :c _ :d _} :no {:a _ :b _ :c _} nil :no)) "match wildcard 7") -(assert (= "t" (match [true nil] [true _] "t")) "match wildcard 8") - -# Regression #301 -(def b (buffer/new-filled 128 0x78)) -(assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1") - -(def a @"abcdefghijklm") -(assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2") -(assert (deep= @"bcde" (buffer/blit @"" a -1 1 5)) "buffer/blit 3") -(assert (deep= @"cde" (buffer/blit @"" a -1 2 5)) "buffer/blit 4") -(assert (deep= @"de" (buffer/blit @"" a -1 3 5)) "buffer/blit 5") - -# chr -(assert (= (chr "a") 97) "chr 1") - -# Detaching closure over non resumable fiber. -(do - (defn f1 - [a] - (defn f1 [] (++ (a 0))) - (defn f2 [] (++ (a 0))) - (error [f1 f2])) - (def [_ [f1 f2]] (protect (f1 @[0]))) - # At time of writing, mark phase can detach closure envs. - (gccollect) - (assert (= 1 (f1)) "detach-non-resumable-closure 1") - (assert (= 2 (f2)) "detach-non-resumable-closure 2")) - -# Marshal closure over non resumable fiber. -(do - (defn f1 - [a] - (defn f1 [] (++ (a 0))) - (defn f2 [] (++ (a 0))) - (error [f1 f2])) - (def [_ tup] (protect (f1 @[0]))) - (def [f1 f2] (unmarshal (marshal tup make-image-dict) load-image-dict)) - (assert (= 1 (f1)) "marshal-non-resumable-closure 1") - (assert (= 2 (f2)) "marshal-non-resumable-closure 2")) - -# Marshal closure over currently alive fiber. -(do - (defn f1 - [a] - (defn f1 [] (++ (a 0))) - (defn f2 [] (++ (a 0))) - (marshal [f1 f2] make-image-dict)) - (def [f1 f2] (unmarshal (f1 @[0]) load-image-dict)) - (assert (= 1 (f1)) "marshal-live-closure 1") - (assert (= 2 (f2)) "marshal-live-closure 2")) - -(do - (var a 1) - (defn b [x] (+ a x)) - (def c (unmarshal (marshal b))) - (assert (= 2 (c 1)) "marshal-on-stack-closure 1")) - -# Reduce2 - -(assert (= (reduce + 0 (range 1 10)) (reduce2 + (range 10))) "reduce2 1") -(assert (= (reduce * 1 (range 2 10)) (reduce2 * (range 1 10))) "reduce2 2") -(assert (= nil (reduce2 * [])) "reduce2 3") - -# Accumulate - -(assert (deep= (accumulate + 0 (range 5)) @[0 1 3 6 10]) "accumulate 1") -(assert (deep= (accumulate2 + (range 5)) @[0 1 3 6 10]) "accumulate2 1") -(assert (deep= @[] (accumulate2 + [])) "accumulate2 2") -(assert (deep= @[] (accumulate 0 + [])) "accumulate 2") - -# Perm strings - -(assert (= (os/perm-int "rwxrwxrwx") 8r777) "perm 1") -(assert (= (os/perm-int "rwxr-xr-x") 8r755) "perm 2") -(assert (= (os/perm-int "rw-r--r--") 8r644) "perm 3") - -(assert (= (band (os/perm-int "rwxrwxrwx") 8r077) 8r077) "perm 4") -(assert (= (band (os/perm-int "rwxr-xr-x") 8r077) 8r055) "perm 5") -(assert (= (band (os/perm-int "rw-r--r--") 8r077) 8r044) "perm 6") - -(assert (= (os/perm-string 8r777) "rwxrwxrwx") "perm 7") -(assert (= (os/perm-string 8r755) "rwxr-xr-x") "perm 8") -(assert (= (os/perm-string 8r644) "rw-r--r--") "perm 9") - -# Issue #336 cases - don't segfault - -(assert-error "unmarshal errors 1" (unmarshal @"\xd6\xb9\xb9")) -(assert-error "unmarshal errors 2" (unmarshal @"\xd7bc")) -(assert-error "unmarshal errors 3" (unmarshal "\xd3\x01\xd9\x01\x62\xcf\x03\x78\x79\x7a" load-image-dict)) -(assert-error "unmarshal errors 4" - (unmarshal - @"\xD7\xCD\0e/p\x98\0\0\x03\x01\x01\x01\x02\0\0\x04\0\xCEe/p../tools -\0\0\0/afl\0\0\x01\0erate\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE -\xA8\xDE\xDE\xDE\xDE\xDE\xDE\0\0\0\xDE\xDE_unmarshal_testcase3.ja -neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 -\0\0\0\0\0*\xFE\x01\04\x02\0\0'\x03\0\r\0\r\0\r\0\r" load-image-dict)) - -(gccollect) - -# in vs get regression -(assert (nil? (first @"")) "in vs get 1") -(assert (nil? (last @"")) "in vs get 1") - -# For undefined behavior sanitizer -0xf&1fffFFFF - -# Tuple comparison -(assert (< [1 2 3] [2 2 3]) "tuple comparison 1") -(assert (< [1 2 3] [2 2]) "tuple comparison 2") -(assert (< [1 2 3] [2 2 3 4]) "tuple comparison 3") -(assert (< [1 2 3] [1 2 3 4]) "tuple comparison 4") -(assert (< [1 2 3] [1 2 3 -1]) "tuple comparison 5") -(assert (> [1 2 3] [1 2]) "tuple comparison 6") - -# Lenprefix rule - -(def peg (peg/compile ~(* (lenprefix (/ (* '(any (if-not ":" 1)) ":") ,scan-number) 1) -1))) - -(assert (peg/match peg "5:abcde") "lenprefix 1") -(assert (not (peg/match peg "5:abcdef")) "lenprefix 2") -(assert (not (peg/match peg "5:abcd")) "lenprefix 3") - -# Packet capture - -(def peg2 - (peg/compile - ~{# capture packet length in tag :header-len - :packet-header (* (/ ':d+ ,scan-number :header-len) ":") - - # capture n bytes from a backref :header-len - :packet-body '(lenprefix (-> :header-len) 1) - - # header, followed by body, and drop the :header-len capture - :packet (/ (* :packet-header :packet-body) ,|$1) - - # any exact seqence of packets (no extra characters) - :main (* (any :packet) -1)})) - -(assert (deep= @["a" "bb" "ccc"] (peg/match peg2 "1:a2:bb3:ccc")) "lenprefix 4") -(assert (deep= @["a" "bb" "cccccc"] (peg/match peg2 "1:a2:bb6:cccccc")) "lenprefix 5") -(assert (= nil (peg/match peg2 "1:a2:bb:5:cccccc")) "lenprefix 6") -(assert (= nil (peg/match peg2 "1:a2:bb:7:cccccc")) "lenprefix 7") - -# Regression #400 -(assert (= nil (while (and false false) (fn []) (error "should not happen"))) "strangeloop 1") -(assert (= nil (while (not= nil nil) (fn []) (error "should not happen"))) "strangeloop 2") - -# Issue #412 -(assert (peg/match '(* "a" (> -1 "a") "b") "abc") "lookhead does not move cursor") - -(def peg3 - ~{:main (* "(" (thru ")"))}) - -(def peg4 (peg/compile ~(* (thru "(") '(to ")")))) - -(assert (peg/match peg3 "(12345)") "peg thru 1") -(assert (not (peg/match peg3 " (12345)")) "peg thru 2") -(assert (not (peg/match peg3 "(12345")) "peg thru 3") - -(assert (= "abc" (0 (peg/match peg4 "123(abc)"))) "peg thru/to 1") -(assert (= "abc" (0 (peg/match peg4 "(abc)"))) "peg thru/to 2") -(assert (not (peg/match peg4 "123(abc")) "peg thru/to 3") - -(def peg5 (peg/compile [3 "abc"])) - -(assert (:match peg5 "abcabcabc") "repeat alias 1") -(assert (:match peg5 "abcabcabcac") "repeat alias 2") -(assert (not (:match peg5 "abcabc")) "repeat alias 3") - -(defn check-jdn [x] - (assert (deep= (parse (string/format "%j" x)) x) "round trip jdn")) - -(check-jdn 0) -(check-jdn nil) -(check-jdn []) -(check-jdn @[[] [] 1231 9.123123 -123123 0.1231231230001]) -(check-jdn -0.123123123123) -(check-jdn 12837192371923) -(check-jdn "a string") -(check-jdn @"a buffer") - -# Issue 428 -(var result nil) -(defn f [] (yield {:a :ok})) -(assert-no-error "issue 428 1" (loop [{:a x} :in (fiber/new f)] (set result x))) -(assert (= result :ok) "issue 428 2") - -# Inline 3 argument get -(assert (= 10 (do (var a 10) (set a (get '{} :a a)))) "inline get 1") - -# Keyword and Symbol slice -(assert (= :keyword (keyword/slice "some_keyword_slice" 5 12)) "keyword slice") -(assert (= 'symbol (symbol/slice "some_symbol_slice" 5 11)) "symbol slice") - -# Peg find and find-all -(def p "/usr/local/bin/janet") -(assert (= (peg/find '"n/" p) 13) "peg find 1") -(assert (not (peg/find '"t/" p)) "peg find 2") -(assert (deep= (peg/find-all '"/" p) @[0 4 10 14]) "peg find-all") - -# Peg replace and replace-all -(defn check-replacer - [x y z] - (assert (= (string/replace x y z) (string (peg/replace x y z))) "replacer test replace") - (assert (= (string/replace-all x y z) (string (peg/replace-all x y z))) "replacer test replace-all")) -(check-replacer "abc" "Z" "abcabcabcabasciabsabc") -(check-replacer "abc" "Z" "") -(check-replacer "aba" "ZZZZZZ" "ababababababa") -(check-replacer "aba" "" "ababababababa") -(check-replacer "aba" string/ascii-upper "ababababababa") -(check-replacer "aba" 123 "ababababababa") - -(assert (= (string (peg/replace-all ~(set "ab") string/ascii-upper "abcaa")) - "ABcAA") - "peg/replace-all cfunction") -(assert (= (string (peg/replace-all ~(set "ab") |$ "abcaa")) - "abcaa") - "peg/replace-all function") - -(defn peg-test [name f peg subst text expected] - (assert (= (string (f peg subst text)) expected) name)) - -(peg-test "peg/replace has access to captures" - peg/replace - ~(sequence "." (capture (set "ab"))) - (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) - ".a.b.c" - ".a -> A, .b.c") - -(peg-test "peg/replace-all has access to captures" - peg/replace-all - ~(sequence "." (capture (set "ab"))) - (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) - ".a.b.c" - ".a -> A, .b -> B, .c") - -# Peg bug -(assert (deep= @[] (peg/match '(any 1) @"")) "peg empty pattern 1") -(assert (deep= @[] (peg/match '(any 1) (buffer))) "peg empty pattern 2") -(assert (deep= @[] (peg/match '(any 1) "")) "peg empty pattern 3") -(assert (deep= @[] (peg/match '(any 1) (string))) "peg empty pattern 4") -(assert (deep= @[] (peg/match '(* "test" (any 1)) @"test")) "peg empty pattern 5") -(assert (deep= @[] (peg/match '(* "test" (any 1)) (buffer "test"))) "peg empty pattern 6") - -# number pattern -(assert (deep= @[111] (peg/match '(number :d+) "111")) "simple number capture 1") -(assert (deep= @[255] (peg/match '(number :w+) "0xff")) "simple number capture 2") - -# quoted match test -(assert (= :yes (match 'john 'john :yes _ :nope)) "quoted literal match 1") -(assert (= :nope (match 'john ''john :yes _ :nope)) "quoted literal match 2") - -(end-suite) diff --git a/test/suite0010.janet b/test/suite0010.janet deleted file mode 100644 index d17ecdd9..00000000 --- a/test/suite0010.janet +++ /dev/null @@ -1,333 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 10) - -# index-of -(assert (= nil (index-of 10 [])) "index-of 1") -(assert (= nil (index-of 10 [1 2 3])) "index-of 2") -(assert (= 1 (index-of 2 [1 2 3])) "index-of 3") -(assert (= 0 (index-of :a [:a :b :c])) "index-of 4") -(assert (= nil (index-of :a {})) "index-of 5") -(assert (= :a (index-of :A {:a :A :b :B})) "index-of 6") -(assert (= :a (index-of :A @{:a :A :b :B})) "index-of 7") -(assert (= 0 (index-of (chr "a") "abc")) "index-of 8") -(assert (= nil (index-of (chr "a") "")) "index-of 9") -(assert (= nil (index-of 10 @[])) "index-of 10") -(assert (= nil (index-of 10 @[1 2 3])) "index-of 11") -# NOTE: These is a motivation for the has-value? and has-key? functions below - -# returns false despite key present -(assert (= false (index-of 8 {true 7 false 8})) "index-of corner key (false) 1") -(assert (= false (index-of 8 @{false 8})) "index-of corner key (false) 2") -# still returns null -(assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") - -# has-value? -(assert (= false (has-value? [] "foo")) "has-value? 1") -(assert (= true (has-value? [4 7 1 3] 4)) "has-value? 2") -(assert (= false (has-value? [4 7 1 3] 22)) "has-value? 3") -(assert (= false (has-value? @[1 2 3] 4)) "has-value? 4") -(assert (= true (has-value? @[:a :b :c] :a)) "has-value? 5") -(assert (= false (has-value? {} :foo)) "has-value? 6") -(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") -(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") -(assert (= true (has-value? @{:a :A :b :B} :A)) "has-value? 8") -(assert (= true (has-value? "abc" (chr "a"))) "has-value? 9") -(assert (= false (has-value? "abc" "1")) "has-value? 10") -# weird true/false corner cases, should align with "index-of corner key {k}" cases -(assert (= true (has-value? {true 7 false 8} 8)) "has-value? corner key (false) 1") -(assert (= true (has-value? @{false 8} 8)) "has-value? corner key (false) 2") -(assert (= false (has-value? {false 8} 7)) "has-value? corner key (false) 3") - -# has-key? -(do - (var test-has-key-auto 0) - (defn test-has-key [col key expected &keys {:name name}] - ``Test that has-key has the outcome `expected`, and that if - the result is true, then ensure (in key) does not fail either`` - (assert (boolean? expected)) - (default name (string "has-key? " (++ test-has-key-auto))) - (assert (= expected (has-key? col key)) name) - (if - # guarenteed by `has-key?` to never fail - expected (in col key) - # if `has-key?` is false, then `in` should fail (for indexed types) - # - # For dictionary types, it should return nil - (let [[success retval] (protect (in col key))] - (def should-succeed (dictionary? col)) - (assert - (= success should-succeed) - (string/format - "%s: expected (in col key) to %s, but got %q" - name (if expected "succeed" "fail") retval))))) - - (test-has-key [] 0 false) # 1 - (test-has-key [4 7 1 3] 2 true) # 2 - (test-has-key [4 7 1 3] 22 false) # 3 - (test-has-key @[1 2 3] 4 false) # 4 - (test-has-key @[:a :b :c] 2 true) # 5 - (test-has-key {} :foo false) # 6 - (test-has-key {:a :A :b :B} :a true) # 7 - (test-has-key {:a :A :b :B} :A false) # 8 - (test-has-key @{:a :A :b :B} :a true) # 9 - (test-has-key "abc" 1 true) # 10 - (test-has-key "abc" 4 false) # 11 - # weird true/false corner cases - # - # Tries to mimic the corresponding corner cases in has-value? and index-of, - # but with keys/values inverted - # - # in the first two cases (truthy? (get val col)) would have given false negatives - (test-has-key {7 true 8 false} 8 true :name "has-key? corner value (false) 1") - (test-has-key @{8 false} 8 true :name "has-key? corner value (false) 2") - (test-has-key @{8 false} 7 false :name "has-key? corner value (false) 3")) - -# Regression -(assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463") - -# macex testing -(assert (deep= (macex1 '~{1 2 3 4}) '~{1 2 3 4}) "macex1 qq struct") -(assert (deep= (macex1 '~@{1 2 3 4}) '~@{1 2 3 4}) "macex1 qq table") -(assert (deep= (macex1 '~(1 2 3 4)) '~[1 2 3 4]) "macex1 qq tuple") -(assert (= :brackets (tuple/type (1 (macex1 '~[1 2 3 4])))) "macex1 qq bracket tuple") -(assert (deep= (macex1 '~@[1 2 3 4 ,blah]) '~@[1 2 3 4 ,blah]) "macex1 qq array") - -# Sourcemaps in threading macros -(defn check-threading [macro expansion] - (def expanded (macex1 (tuple macro 0 '(x) '(y)))) - (assert (= expanded expansion) (string macro " expansion value")) - (def smap-x (tuple/sourcemap (get expanded 1))) - (def smap-y (tuple/sourcemap expanded)) - (def line first) - (defn column [t] (t 1)) - (assert (not= smap-x [-1 -1]) (string macro " x sourcemap existence")) - (assert (not= smap-y [-1 -1]) (string macro " y sourcemap existence")) - (assert (or (< (line smap-x) (line smap-y)) - (and (= (line smap-x) (line smap-y)) - (< (column smap-x) (column smap-y)))) - (string macro " relation between x and y sourcemap"))) - -(check-threading '-> '(y (x 0))) -(check-threading '->> '(y (x 0))) - -# keep-syntax -(let [brak '[1 2 3] - par '(1 2 3)] - - (tuple/setmap brak 2 1) - - (assert (deep= (keep-syntax brak @[1 2 3]) @[1 2 3]) "keep-syntax brackets ignore array") - (assert (= (keep-syntax! brak @[1 2 3]) '[1 2 3]) "keep-syntax! brackets replace array") - - (assert (= (keep-syntax! par (map inc @[1 2 3])) '(2 3 4)) "keep-syntax! parens coerce array") - (assert (not= (keep-syntax! brak @[1 2 3]) '(1 2 3)) "keep-syntax! brackets not parens") - (assert (not= (keep-syntax! par @[1 2 3]) '[1 2 3]) "keep-syntax! parens not brackets") - (assert (= (tuple/sourcemap brak) - (tuple/sourcemap (keep-syntax! brak @[1 2 3]))) "keep-syntax! brackets source map") - - (keep-syntax par brak) - (assert (not= (tuple/sourcemap brak) (tuple/sourcemap par)) "keep-syntax no mutate") - (assert (= (keep-syntax 1 brak) brak) "keep-syntax brackets ignore type")) - -# Cancel test -(def f (fiber/new (fn [&] (yield 1) (yield 2) (yield 3) 4) :yti)) -(assert (= 1 (resume f)) "cancel resume 1") -(assert (= 2 (resume f)) "cancel resume 2") -(assert (= :hi (cancel f :hi)) "cancel resume 3") -(assert (= :error (fiber/status f)) "cancel resume 4") - -# Curenv -(assert (= (curenv) (curenv 0)) "curenv 1") -(assert (= (table/getproto (curenv)) (curenv 1)) "curenv 2") -(assert (= nil (curenv 1000000)) "curenv 3") -(assert (= root-env (curenv 1)) "curenv 4") - -# Import macro test -(assert-no-error "import macro 1" (macex '(import a :as b :fresh maybe))) -(assert (deep= ~(,import* "a" :as "b" :fresh maybe) (macex '(import a :as b :fresh maybe))) "import macro 2") - -# #477 walk preserving bracket type -(assert (= :brackets (tuple/type (postwalk identity '[]))) "walk square brackets 1") -(assert (= :brackets (tuple/type (walk identity '[]))) "walk square brackets 2") - -# # off by 1 error in inttypes -(assert (= (int/s64 "-0x8000_0000_0000_0000") (+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around") - -# -# Longstring indentation -# - -(defn reindent - "Reindent a the contents of a longstring as the Janet parser would. - This include removing leading and trailing newlines." - [text indent] - - # Detect minimum indent - (var rewrite true) - (each index (string/find-all "\n" text) - (for i (+ index 1) (+ index indent 1) - (case (get text i) - nil (break) - (chr "\n") (break) - (chr " ") nil - (set rewrite false)))) - - # Only re-indent if no dedented characters. - (def str - (if rewrite - (peg/replace-all ~(* "\n" (between 0 ,indent " ")) "\n" text) - text)) - - (def first-nl (= (chr "\n") (first str))) - (def last-nl (= (chr "\n") (last str))) - (string/slice str (if first-nl 1 0) (if last-nl -2))) - -(defn reindent-reference - "Same as reindent but use parser functionality. Useful for validating conformance." - [text indent] - (if (empty? text) (break text)) - (def source-code - (string (string/repeat " " indent) "``````" - text - "``````")) - (parse source-code)) - -(var indent-counter 0) -(defn check-indent - [text indent] - (++ indent-counter) - (let [a (reindent text indent) - b (reindent-reference text indent)] - (assert (= a b) (string "indent " indent-counter " (indent=" indent ")")))) - -(check-indent "" 0) -(check-indent "\n" 0) -(check-indent "\n" 1) -(check-indent "\n\n" 0) -(check-indent "\n\n" 1) -(check-indent "\nHello, world!" 0) -(check-indent "\nHello, world!" 1) -(check-indent "Hello, world!" 0) -(check-indent "Hello, world!" 1) -(check-indent "\n Hello, world!" 4) -(check-indent "\n Hello, world!\n" 4) -(check-indent "\n Hello, world!\n " 4) -(check-indent "\n Hello, world!\n " 4) -(check-indent "\n Hello, world!\n dedented text\n " 4) -(check-indent "\n Hello, world!\n indented text\n " 4) - -# String bugs -(assert (deep= (string/find-all "qq" "qqq") @[0 1]) "string/find-all 1") -(assert (deep= (string/find-all "q" "qqq") @[0 1 2]) "string/find-all 2") -(assert (deep= (string/split "qq" "1qqqqz") @["1" "" "z"]) "string/split 1") -(assert (deep= (string/split "aa" "aaa") @["" "a"]) "string/split 2") - -# Comparisons -(assert (> 1e23 100) "less than immediate 1") -(assert (> 1e23 1000) "less than immediate 2") -(assert (< 100 1e23) "greater than immediate 1") -(assert (< 1000 1e23) "greater than immediate 2") - -# os/execute with environment variables -(assert (= 0 (os/execute [(dyn :executable) "-e" "(+ 1 2 3)"] :pe (merge (os/environ) {"HELLO" "WORLD"}))) "os/execute with env") - -# Regression #638 -(compwhen - (dyn 'ev/go) - (assert - (= [true :caught] - (protect - (try - (do - (ev/sleep 0) - (with-dyns [] - (ev/sleep 0) - (error "oops"))) - ([err] :caught)))) - "regression #638")) - - -# Struct prototypes -(def x (struct/with-proto {1 2 3 4} 5 6)) -(def y (-> x marshal unmarshal)) -(def z {1 2 3 4}) -(assert (= 2 (get x 1)) "struct get proto value 1") -(assert (= 4 (get x 3)) "struct get proto value 2") -(assert (= 6 (get x 5)) "struct get proto value 3") -(assert (= x y) "struct proto marshal equality 1") -(assert (= (getproto x) (getproto y)) "struct proto marshal equality 2") -(assert (= 0 (cmp x y)) "struct proto comparison 1") -(assert (= 0 (cmp (getproto x) (getproto y))) "struct proto comparison 2") -(assert (not= (cmp x z) 0) "struct proto comparison 3") -(assert (not= (cmp y z) 0) "struct proto comparison 4") -(assert (not= x z) "struct proto comparison 5") -(assert (not= y z) "struct proto comparison 6") -(assert (= (x 5) 6) "struct proto get 1") -(assert (= (y 5) 6) "struct proto get 1") -(assert (deep= x y) "struct proto deep= 1") -(assert (deep-not= x z) "struct proto deep= 2") -(assert (deep-not= y z) "struct proto deep= 3") - -# Issue #751 -(def t {:side false}) -(assert (nil? (get-in t [:side :note])) "get-in with false value") -(assert (= (get-in t [:side :note] "dflt") "dflt") - "get-in with false value and default") - -(assert (= (math/gcd 462 1071) 21) "math/gcd 1") -(assert (= (math/lcm 462 1071) 23562) "math/lcm 1") - -# Evaluate stream with `dofile` -(def [r w] (os/pipe)) -(:write w "(setdyn :x 10)") -(:close w) -(def stream-env (dofile r)) -(assert (= (stream-env :x) 10) "dofile stream 1") - -# Issue #861 - should be valgrind clean -(def step1 "(a b c d)\n") -(def step2 "(a b)\n") -(def p1 (parser/new)) -(parser/state p1) -(parser/consume p1 step1) -(loop [v :iterate (parser/produce p1)]) -(parser/state p1) -(def p2 (parser/clone p1)) -(parser/state p2) -(parser/consume p2 step2) -(loop [v :iterate (parser/produce p2)]) -(parser/state p2) - -# Check missing struct proto bug. -(assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil)) "missing struct proto") - -# Test thaw and freeze -(def table-to-freeze @{:c 22 :b [1 2 3 4] :d @"test" :e "test2"}) -(def table-to-freeze-with-inline-proto @{:a @[1 2 3] :b @[1 2 3 4] :c 22 :d @"test" :e @"test2"}) -(def struct-to-thaw (struct/with-proto {:a [1 2 3]} :c 22 :b [1 2 3 4] :d "test" :e "test2")) -(table/setproto table-to-freeze @{:a @[1 2 3]}) -(assert (deep= {:a [1 2 3] :b [1 2 3 4] :c 22 :d "test" :e "test2"} (freeze table-to-freeze))) -(assert (deep= table-to-freeze-with-inline-proto (thaw table-to-freeze))) -(assert (deep= table-to-freeze-with-inline-proto (thaw struct-to-thaw))) - -(end-suite) diff --git a/test/suite0011.janet b/test/suite0011.janet deleted file mode 100644 index 65a3ad69..00000000 --- a/test/suite0011.janet +++ /dev/null @@ -1,108 +0,0 @@ -# Copyright (c) 2023 Calvin Rose & contributors -# -# Permission is hereby granted, free of charge, to any person obtaining a copy -# of this software and associated documentation files (the "Software"), to -# deal in the Software without restriction, including without limitation the -# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or -# sell copies of the Software, and to permit persons to whom the Software is -# furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS -# IN THE SOFTWARE. - -(import ./helper :prefix "" :exit true) -(start-suite 11) - -# math gamma - -(assert (< 11899423.08 (math/gamma 11.5) 11899423.085) "math/gamma") -(assert (< 2605.1158 (math/log-gamma 500) 2605.1159) "math/log-gamma") - -# missing symbols - -(defn lookup-symbol [sym] (defglobal sym 10) (dyn sym)) - -(setdyn :missing-symbol lookup-symbol) - -(assert (= (eval-string "(+ a 5)") 15) "lookup missing symbol") - -(setdyn :missing-symbol nil) -(setdyn 'a nil) - -(assert-error "compile error" (eval-string "(+ a 5)")) - -# 919 -(defn test - [] - (var x 1) - (set x ~(,x ())) - x) - -(assert (= (test) '(1 ())) "issue #919") - -(assert (= (hash 0) (hash (* -1 0))) "hash -0 same as hash 0") - -# os/execute regressions -(for i 0 10 - (assert (= i (os/execute [(dyn :executable) "-e" (string/format "(os/exit %d)" i)] :p)) (string "os/execute " i))) - -# to/thru bug -(def pattern - (peg/compile - '{:dd (sequence :d :d) - :sep (set "/-") - :date (sequence :dd :sep :dd) - :wsep (some (set " \t")) - :entry (group (sequence (capture :date) :wsep (capture :date))) - :main (some (thru :entry))})) - -(def alt-pattern - (peg/compile - '{:dd (sequence :d :d) - :sep (set "/-") - :date (sequence :dd :sep :dd) - :wsep (some (set " \t")) - :entry (group (sequence (capture :date) :wsep (capture :date))) - :main (some (choice :entry 1))})) - -(def text "1800-10-818-9-818 16/12\n17/12 19/12\n20/12 11/01") -(assert (deep= (peg/match pattern text) (peg/match alt-pattern text)) "to/thru bug #971") - -(assert-error - "table rawget regression" - (table/new -1)) - -# Named arguments -(defn named-arguments - [&named bob sally joe] - (+ bob sally joe)) - -(assert (= 15 (named-arguments :bob 3 :sally 5 :joe 7)) "named arguments 1") - -(defn named-opt-arguments - [&opt x &named a b c] - (+ x a b c)) - -(assert (= 10 (named-opt-arguments 1 :a 2 :b 3 :c 4)) "named arguments 2") - -(let [b @""] - (defn dummy [a b c] - (+ a b c)) - (trace dummy) - (defn errout [arg] - (buffer/push b arg)) - (assert (= 6 (with-dyns [*err* errout] (dummy 1 2 3))) "trace to custom err function") - (assert (deep= @"trace (dummy 1 2 3)\n" b) "trace buffer correct")) - -(def f (asm (disasm (fn [x] (fn [y] (+ x y)))))) -(assert (= ((f 10) 37) 47) "asm environment tables") - -(end-suite) diff --git a/test/suite0014.janet b/test/suite0014.janet deleted file mode 100644 index c4fb40fa..00000000 --- a/test/suite0014.janet +++ /dev/null @@ -1,20 +0,0 @@ -(import ./helper :prefix "" :exit true) -(start-suite 14) - -(assert (deep= - (peg/match '(not (* (constant 7) "a")) "hello") - @[]) "peg not") - -(assert (deep= - (peg/match '(if-not (* (constant 7) "a") "hello") "hello") - @[]) "peg if-not") - -(assert (deep= - (peg/match '(if-not (drop (* (constant 7) "a")) "hello") "hello") - @[]) "peg if-not drop") - -(assert (deep= - (peg/match '(if (not (* (constant 7) "a")) "hello") "hello") - @[]) "peg if not") - -(end-suite) diff --git a/test/suite0015.janet b/test/suite0015.janet deleted file mode 100644 index aba27bd9..00000000 --- a/test/suite0015.janet +++ /dev/null @@ -1,61 +0,0 @@ -# test *debug* flags - -(import ./helper :prefix "" :exit true) -(start-suite 15) - -(assert (deep= (in (disasm (defn a [] (def x 10) x)) :symbolmap) - @[[0 2 0 'a] [0 2 1 'x]]) - "symbolslots when *debug* is true") - -(defn a [arg] - (def x 10) - (do - (def y 20) - (def z 30) - (+ x y z))) -(def symbolslots (in (disasm a) :symbolslots)) -(def f (asm (disasm a))) -(assert (deep= (in (disasm f) :symbolslots) - symbolslots) - "symbolslots survive disasm/asm") - -(comment - (setdyn *debug* true) - (setdyn :pretty-format "%.40M") - (def f (fn [x] (fn [y] (+ x y)))) - (assert (deep= (map last (in (disasm (f 10)) :symbolmap)) - @['x 'y]) - "symbolslots upvalues")) - -(assert (deep= (in (disasm (defn a [arg] - (def x 10) - (do - (def y 20) - (def z 30) - (+ x y z)))) :symbolmap) - @[[0 6 0 'arg] - [0 6 1 'a] - [0 6 2 'x] - [1 6 3 'y] - [2 6 4 'z]]) - "arg & inner symbolslots") - -# buffer/push-at -(assert (deep= @"abc456" (buffer/push-at @"abc123" 3 "456")) "buffer/push-at 1") -(assert (deep= @"abc456789" (buffer/push-at @"abc123" 3 "456789")) "buffer/push-at 2") -(assert (deep= @"abc423" (buffer/push-at @"abc123" 3 "4")) "buffer/push-at 3") - -(assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing") - -# Crash issue #1174 - bad debug info -(defn crash [] - (debug/stack (fiber/current))) -(do - (math/random) - (defn foo [_] - (crash) - 1) - (foo 0) - 10) - -(end-suite) From e0ea844d50690ea54c4faa02e34a51f7176fbcc9 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Fri, 2 Jun 2023 10:52:13 +0200 Subject: [PATCH 074/138] added os/isatty, do not enable colors if stdout is not a tty --- src/boot/boot.janet | 4 +++- src/core/os.c | 18 ++++++++++++++++++ 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 0004f954..7d7afcf2 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -3903,7 +3903,9 @@ (if-let [jp (getenv-alias "JANET_PATH")] (setdyn *syspath* jp)) (if-let [jprofile (getenv-alias "JANET_PROFILE")] (setdyn *profilepath* jprofile)) - (set colorize (not (getenv-alias "NO_COLOR"))) + (set colorize (and + (not (getenv-alias "NO_COLOR")) + (os/isatty stdout))) (defn- get-lint-level [i] diff --git a/src/core/os.c b/src/core/os.c index 4d3a3448..d59bec98 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1431,6 +1431,23 @@ JANET_CORE_FN(os_sleep, return janet_wrap_nil(); } +JANET_CORE_FN(os_isatty, + "(os/isatty &opt file)", + "Returns true if `file` is a terminal. If `file` is not specified, " + "it will default to standard output.") { + janet_arity(argc, 0, 1); + FILE *f = (argc == 1) ? janet_getfile(argv, 0, NULL) : stdout; +#ifdef JANET_WINDOWS + int fd = _fileno(f); + if (fd == -1) janet_panicv(janet_ev_lasterr()); + return janet_wrap_boolean(_isatty(fd)); +#else + int fd = fileno(f); + if (fd == -1) janet_panicv(janet_ev_lasterr()); + return janet_wrap_boolean(isatty(fd)); +#endif +} + JANET_CORE_FN(os_cwd, "(os/cwd)", "Returns the current working directory.") { @@ -2469,6 +2486,7 @@ void janet_lib_os(JanetTable *env) { JANET_CORE_REG("os/date", os_date), /* not high resolution */ JANET_CORE_REG("os/strftime", os_strftime), JANET_CORE_REG("os/sleep", os_sleep), + JANET_CORE_REG("os/isatty", os_isatty), /* env functions */ JANET_CORE_REG("os/environ", os_environ), From c0f5f97ddb53c2e6328c0965f2db1aaa1ef6a9ae Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Sat, 3 Jun 2023 18:59:19 +0200 Subject: [PATCH 075/138] Added misc tests to increase test coverage --- test/helper.janet | 7 +++++-- test/suite-array.janet | 31 +++++++++++++++++++++++++++++++ test/suite-buffer.janet | 15 +++++++++++++++ test/suite-corelib.janet | 21 +++++++++++++++++++++ test/suite-inttypes.janet | 26 ++++++++++++++++++++++++++ test/suite-io.janet | 10 ++++++++++ test/suite-parse.janet | 23 +++++++++++++++++++++++ test/suite-struct.janet | 12 ++++++++++++ 8 files changed, 143 insertions(+), 2 deletions(-) diff --git a/test/helper.janet b/test/helper.janet index ce5389c4..93b19704 100644 --- a/test/helper.janet +++ b/test/helper.janet @@ -14,9 +14,12 @@ (++ num-tests-run) (when x (++ num-tests-passed)) (def str (string e)) + (def frame (last (debug/stack (fiber/current)))) + (def line-info (string/format "%s:%d" + (frame :source) (frame :source-line))) (if x - (when is-verbose (eprintf "\e[32m✔\e[0m %s: %v" (describe e) x)) - (eprintf "\e[31m✘\e[0m %s: %v" (describe e) x)) + (when is-verbose (eprintf "\e[32m✔\e[0m %s: %s: %v" line-info (describe e) x)) + (eprintf "\e[31m✘\e[0m %s: %s: %v" line-info (describe e) x)) x) (defmacro assert-error diff --git a/test/suite-array.janet b/test/suite-array.janet index 6d2a1db9..3773b2ef 100644 --- a/test/suite-array.janet +++ b/test/suite-array.janet @@ -46,5 +46,36 @@ (assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3") (assert (deep= (array/remove @[1 2 3 4 5] -3 200) @[1 2 3]) "array/remove 4") + +# array/peek +(assert (nil? (array/peek @[])) "array/peek empty") + +# array/fill +(assert (deep= (array/fill @[1 1] 2) @[2 2]) "array/fill 1") + +# array/concat +(assert (deep= (array/concat @[1 2] @[3 4] 5 6) @[1 2 3 4 5 6]) "array/concat 1") +(def a @[1 2]) +(assert (deep= (array/concat a a) @[1 2 1 2]) "array/concat self") + +# array/insert +(assert (deep= (array/insert @[:a :a :a :a] 2 :b :b) @[:a :a :b :b :a :a]) "array/insert 1") +(assert (deep= (array/insert @[:a :b] -1 :c :d) @[:a :b :c :d]) "array/insert 2") + +# array/remove +(assert-error "removal index 3 out of range [0,2]" (array/remove @[1 2] 3)) +(assert-error "expected non-negative integer for argument n, got -1" (array/remove @[1 2] 1 -1)) + +# array/pop +(assert (= (array/pop @[1]) 1) "array/pop 1") +(assert (= (array/pop @[]) nil) "array/pop empty") + +# Code coverage +(def a @[1]) +(array/pop a) +(array/trim a) +(array/ensure @[1 1] 6 2) + + (end-suite) diff --git a/test/suite-buffer.janet b/test/suite-buffer.janet index 4c6e0b48..8feb4c1c 100644 --- a/test/suite-buffer.janet +++ b/test/suite-buffer.janet @@ -27,8 +27,11 @@ (buffer/bit-set b 100) (buffer/bit-clear b 100) (assert (zero? (sum b)) "buffer bit set and clear") +(assert (= false (buffer/bit b 101)) "bit get false") (buffer/bit-toggle b 101) +(assert (= true (buffer/bit b 101)) "bit get true") (assert (= 32 (sum b)) "buffer bit set and clear") +(assert-error "invalid bit index 1000" (buffer/bit-toggle b 1000)) (def b2 @"hello world") @@ -41,6 +44,17 @@ (buffer/blit b2 "abcdefg" 5 6) (assert (= (string b2) "joytogjoyto") "buffer/blit 3") +# buffer/push + +(assert (deep= (buffer/push @"AA" @"BB") @"AABB") "buffer/push buffer") +(assert (deep= (buffer/push @"AA" 66 66) @"AABB") "buffer/push int") +(def b @"AA") +(assert (deep= (buffer/push b b) @"AAAA") "buffer/push buffer self") + +# buffer/push-byte +(assert (deep= (buffer/push-byte @"AA" 66) @"AAB") "buffer/push-byte") +(assert-error "bad slot #1, expected 32 bit signed integer" (buffer/push-byte @"AA" :flap)) + # Buffer push word # e755f9830 (def b3 @"") @@ -51,6 +65,7 @@ (buffer/push-word b3 0xFFFFFFFF 0x1100) (assert (= 8 (length b3)) "buffer/push-word 3") (assert (= "\xFF\xFF\xFF\xFF\0\x11\0\0" (string b3)) "buffer/push-word 4") +(assert-error "cannot convert 0.5 to machine word" (buffer/push-word @"" 0.5)) # Buffer push string # 175925207 diff --git a/test/suite-corelib.janet b/test/suite-corelib.janet index 75753639..165207d5 100644 --- a/test/suite-corelib.janet +++ b/test/suite-corelib.janet @@ -28,6 +28,13 @@ # d6967a5 (assert (= 4 (blshift 1 2)) "left shift") (assert (= 1 (brshift 4 2)) "right shift") +# unsigned shift +(assert (= 32768 (brushift 0x80000000 16)) "right shift unsigned 1") +(assert (= -32768 (brshift 0x80000000 16)) "right shift unsigned 2") +# non-immediate forms +(assert (= 32768 (brushift 0x80000000 (+ 0 16))) "right shift unsigned non-immediate") +(assert (= -32768 (brshift 0x80000000 (+ 0 16))) "right shift non-immediate") +(assert (= 32768 (blshift 1 (+ 0 15))) "left shift non-immediate") # 7e46ead (assert (< 1 2 3 4 5 6) "less than integers") (assert (< 1.0 2.0 3.0 4.0 5.0 6.0) "less than reals") @@ -116,5 +123,19 @@ (assert (= (string (module/expand-path "hello" ":sys:/:all:.janet")) ".janet/.janet/hello.janet") "module/expand-path 1")) +# int? +(assert (int? 1) "int? 1") +(assert (int? -1) "int? -1") +(assert (not (int? true)) "int? true") +(assert (not (int? 3.14)) "int? 3.14") +(assert (not (int? 8589934592)) "int? 8589934592") + +# memcmp +(assert (= (memcmp "123helloabcd" "1234helloabc" 5 3 4) 0) "memcmp 1") +(assert (< (memcmp "123hellaabcd" "1234helloabc" 5 3 4) 0) "memcmp 2") +(assert (> (memcmp "123helloabcd" "1234hellaabc" 5 3 4) 0) "memcmp 3") +(assert-error "invalid offset-a: 1" (memcmp "a" "b" 1 1 0)) +(assert-error "invalid offset-b: 1" (memcmp "a" "b" 1 0 1)) + (end-suite) diff --git a/test/suite-inttypes.janet b/test/suite-inttypes.janet index 695bca1f..554128b4 100644 --- a/test/suite-inttypes.janet +++ b/test/suite-inttypes.janet @@ -228,5 +228,31 @@ (assert (= c (compare x y)) (string/format "compare polymorphic %q %q %d" x y c)))) +# marshal +(def m1 (u64 3141592654)) +(def m2 (unmarshal (marshal m1))) +(assert (= m1 m2) "marshal/unmarshal") + +# compare u64/u64 +(assert (= (compare (u64 1) (u64 2)) -1) "compare 1") +(assert (= (compare (u64 1) (u64 1)) 0) "compare 2") +(assert (= (compare (u64 2) (u64 1)) +1) "compare 3") + +# compare i64/i64 +(assert (= (compare (i64 -1) (i64 +1)) -1) "compare 4") +(assert (= (compare (i64 +1) (i64 +1)) 0) "compare 5") +(assert (= (compare (i64 +1) (i64 -1)) +1) "compare 6") + +# compare u64/i64 +(assert (= (compare (u64 1) (i64 2)) -1) "compare 7") +(assert (= (compare (u64 1) (i64 -1)) +1) "compare 8") +(assert (= (compare (u64 -1) (i64 -1)) +1) "compare 9") + +# compare i64/u64 +(assert (= (compare (i64 1) (u64 2)) -1) "compare 10") +(assert (= (compare (i64 -1) (u64 1)) -1) "compare 11") +(assert (= (compare (i64 -1) (u64 -1)) -1) "compare 12") + + (end-suite) diff --git a/test/suite-io.janet b/test/suite-io.janet index dc16e3ee..826ae755 100644 --- a/test/suite-io.janet +++ b/test/suite-io.janet @@ -68,5 +68,15 @@ "trace to custom err function") (assert (deep= @"trace (dummy 1 2 3)\n" b) "trace buffer correct")) + +# xprintf +(def b @"") +(defn to-b [a] (buffer/push b a)) +(xprintf to-b "123") +(assert (deep= b @"123\n") "xprintf to buffer") + + +(assert-error "cannot print to 3" (xprintf 3 "123")) + (end-suite) diff --git a/test/suite-parse.janet b/test/suite-parse.janet index aa091a61..94154120 100644 --- a/test/suite-parse.janet +++ b/test/suite-parse.janet @@ -165,5 +165,28 @@ (loop [v :iterate (parser/produce p2)]) (parser/state p2) +# parser delimiter errors +(defn test-error [delim fmt] + (def p (parser/new)) + (parser/consume p delim) + (parser/eof p) + (def msg (string/format fmt delim)) + (assert (= (parser/error p) msg) "delimiter error")) +(each c [ "(" "{" "[" "\"" "``" ] + (test-error c "unexpected end of source, %s opened at line 1, column 1")) + +# parser/insert +(def p (parser/new)) +(parser/consume p "(") +(parser/insert p "hello") +(parser/consume p ")") +(assert (= (parser/produce p) ["hello"])) + +(def p (parser/new)) +(parser/consume p `("hel`) +(parser/insert p `lo`) +(parser/consume p `")`) +(assert (= (parser/produce p) ["hello"])) + (end-suite) diff --git a/test/suite-struct.janet b/test/suite-struct.janet index e51b22f6..32f6e9b4 100644 --- a/test/suite-struct.janet +++ b/test/suite-struct.janet @@ -78,5 +78,17 @@ (assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil)) "missing struct proto") +# struct/with-proto +(assert-error "expected odd number of arguments" (struct/with-proto {} :a)) + +# struct/to-table +(def s (struct/with-proto {:a 1 :b 2} :name "john" )) +(def t1 (struct/to-table s true)) +(def t2 (struct/to-table s false)) +(assert (deep= t1 @{:name "john"}) "struct/to-table 1") +(assert (deep= t2 @{:name "john"}) "struct/to-table 2") +(assert (deep= (getproto t1) @{:a 1 :b 2}) "struct/to-table 3") +(assert (deep= (getproto t2) nil) "struct/to-table 4") + (end-suite) From 5f56bf836c4dd22965d6ccedddc465d129f20176 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 3 Jun 2023 13:55:49 -0500 Subject: [PATCH 076/138] Update meson.build file. --- meson.build | 43 ++++++++++++++++++++++++++++--------------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/meson.build b/meson.build index e521538f..4b75e0b7 100644 --- a/meson.build +++ b/meson.build @@ -227,21 +227,34 @@ docs = custom_target('docs', # Tests test_files = [ - 'test/suite0000.janet', - 'test/suite0001.janet', - 'test/suite0002.janet', - 'test/suite0003.janet', - 'test/suite0004.janet', - 'test/suite0005.janet', - 'test/suite0006.janet', - 'test/suite0007.janet', - 'test/suite0008.janet', - 'test/suite0009.janet', - 'test/suite0010.janet', - 'test/suite0011.janet', - 'test/suite0012.janet', - 'test/suite0013.janet', - 'test/suite0014.janet' + 'test/suite-array.janet', + 'test/suite-asm.janet', + 'test/suite-boot.janet', + 'test/suite-buffer.janet', + 'test/suite-capi.janet', + 'test/suite-cfuns.janet', + 'test/suite-compile.janet', + 'test/suite-corelib.janet', + 'test/suite-debug.janet', + 'test/suite-ev.janet', + 'test/suite-ffi.janet', + 'test/suite-inttypes.janet', + 'test/suite-io.janet', + 'test/suite-marsh.janet', + 'test/suite-math.janet', + 'test/suite-os.janet', + 'test/suite-parse.janet', + 'test/suite-peg.janet', + 'test/suite-pp.janet', + 'test/suite-specials.janet', + 'test/suite-string.janet', + 'test/suite-strtod.janet', + 'test/suite-struct.janet', + 'test/suite-symcache.janet', + 'test/suite-table.janet', + 'test/suite-unknown.janet', + 'test/suite-value.janet', + 'test/suite-vm.janet' ] foreach t : test_files test(t, janet_nativeclient, args : files([t]), workdir : meson.current_source_dir()) From 7d48b75f81a1cd507a93bf5a640fb55638917824 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 3 Jun 2023 14:19:02 -0500 Subject: [PATCH 077/138] Update README.md --- README.md | 111 +++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 94 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index 6319ac77..45d06b92 100644 --- a/README.md +++ b/README.md @@ -6,10 +6,8 @@ Janet logo -**Janet** is a functional and imperative programming language and bytecode interpreter. It is a -Lisp-like language, but lists are replaced -by other data structures (arrays, tables (hash table), struct (immutable hash table), tuples). -The language also supports bridging to native code written in C, meta-programming with macros, and bytecode assembly. +**Janet** is a dynamic language and bytecode interpreter for system scripting, expressive automation, and +extending programs written in C or C++ with user scripting capabilities. There is a REPL for trying out the language, as well as the ability to run script files. This client program is separate from the core runtime, so @@ -21,14 +19,104 @@ If you'd like to financially support the ongoing development of Janet, consider
+## Examples + +See the examples directory for all provided example programs. + +### Game of Life + +```janet +# John Conway's Game of Life + +(def- window + (seq [x :range [-1 2] + y :range [-1 2] + :when (not (and (zero? x) (zero? y)))] + [x y])) + +(defn- neighbors + [[x y]] + (map (fn [[x1 y1]] [(+ x x1) (+ y y1)]) window)) + +(defn tick + "Get the next state in the Game Of Life." + [state] + (def cell-set (frequencies state)) + (def neighbor-set (frequencies (mapcat neighbors state))) + (seq [coord :keys neighbor-set + :let [count (get neighbor-set coord)] + :when (or (= count 3) (and (get cell-set coord) (= count 2)))] + coord)) + +(defn draw + "Draw cells in the game of life from (x1, y1) to (x2, y2)" + [state x1 y1 x2 y2] + (def cellset @{}) + (each cell state (put cellset cell true)) + (loop [x :range [x1 (+ 1 x2)] + :after (print) + y :range [y1 (+ 1 y2)]] + (file/write stdout (if (get cellset [x y]) "X " ". "))) + (print)) + +# Print the first 20 generations of a glider +(var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)]) +(for i 0 20 + (print "generation " i) + (draw *state* -7 -7 7 7) + (set *state* (tick *state*))) +``` + +### TCP Echo Server + +```janet +# A simple TCP echo server using the built-in socket networking and event loop. + +(defn handler + "Simple handler for connections." + [stream] + (defer (:close stream) + (def id (gensym)) + (def b @"") + (print "Connection " id "!") + (while (:read stream 1024 b) + (printf " %v -> %v" id b) + (:write stream b) + (buffer/clear b)) + (printf "Done %v!" id) + (ev/sleep 0.5))) + +(net/server "127.0.0.1" "8000" handler) +``` + +### Windows FFI Hello, World! + +```janet +# Use the FFI to popup a Windows message box - no C required + +(ffi/context "user32.dll") + +(ffi/defbind MessageBoxA :int + [w :ptr text :string cap :string typ :int]) + +(MessageBoxA nil "Hello, World!" "Test" 0) +``` + ## Use Cases Janet makes a good system scripting language, or a language to embed in other programs. It's like Lua and Guile in that regard. It has more built-in functionality and a richer core language than -Lua, but smaller than GNU Guile or Python. +Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than these languages. ## Features +* 600+ functions and macros in the core library +* Build in socket networking, threading, subprocesses, and more. +* Parsing Expression Grammars (PEG) engine as a more robust Regex alternative +* Macros +* Per-thread event loop for efficient IO (epoll/IOCP/kqueue) +* Built-in C FFI lets you load existing binaries and run them. +* Erlang-style supervision trees that integrate with the event loop * Configurable at build time - turn features on or off for a smaller or more featureful build * Minimal setup - one binary and you are good to go! * First-class closures @@ -38,19 +126,12 @@ Lua, but smaller than GNU Guile or Python. * Mutable and immutable arrays (array/tuple) * Mutable and immutable hashtables (table/struct) * Mutable and immutable strings (buffer/string) -* Macros * Multithreading -* Per-thread event loop for efficient evented IO * Bytecode interpreter with an assembly interface, as well as bytecode verification * Tail-call optimization -* Direct interop with C via abstract types and C functions +* Interface with C via abstract types and C functions * Dynamically load C libraries -* Functional and imperative standard library -* Lexical scoping -* Imperative programming as well as functional * REPL -* Parsing Expression Grammars built into the core library -* 400+ functions and macros in the core library * Embedding Janet in other programs * Interactive environment with detailed stack traces @@ -240,10 +321,6 @@ there is no need for dynamic modules, add the define See the [Embedding Section](https://janet-lang.org/capi/embedding.html) on the website for more information. -## Examples - -See the examples directory for some example Janet code. - ## Discussion Feel free to ask questions and join the discussion on the [Janet Gitter channel](https://gitter.im/janet-language/community). From e4bf27b01ceb81124e06b6b01f23e0f08bcb4470 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 3 Jun 2023 14:22:16 -0500 Subject: [PATCH 078/138] Macro hack for meson-min build. --- src/boot/boot.janet | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 7d7afcf2..6d01f7fd 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -3881,6 +3881,9 @@ (defdyn *profilepath* "Path to profile file loaded when starting up the repl.") +(compwhen (not (dyn 'os/isatty)) + (defmacro (os/isatty) [&] true)) + (defn cli-main `Entrance for the Janet CLI tool. Call this function with the command line arguments as an array or tuple of strings to invoke the CLI interface.` From 658941d26d497ef8823d6d109ed639438cc54800 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 3 Jun 2023 14:24:41 -0500 Subject: [PATCH 079/138] Fix macro declaration. --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 6d01f7fd..383dc39f 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -3882,7 +3882,7 @@ "Path to profile file loaded when starting up the repl.") (compwhen (not (dyn 'os/isatty)) - (defmacro (os/isatty) [&] true)) + (defmacro os/isatty [&] true)) (defn cli-main `Entrance for the Janet CLI tool. Call this function with the command line From c4c86f8671d5fea60e6461816b2018d9caf8d367 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 3 Jun 2023 16:47:59 -0500 Subject: [PATCH 080/138] Run boot.janet through janet-format. --- src/boot/boot.janet | 105 ++++++++++++++++++++++---------------------- 1 file changed, 53 insertions(+), 52 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 383dc39f..e283c508 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -939,37 +939,37 @@ indexed beyond the first.` [n maptype res f ind inds] ~(do - (def ,(seq [k :range [0 n]] (symbol 'ind k)) ,inds) - ,;(seq [k :range [0 n]] ~(var ,(symbol 'key k) nil)) - (each x ,ind - ,;(seq [k :range [0 n]] - ~(if (= nil (set ,(symbol 'key k) (next ,(symbol 'ind k) ,(symbol 'key k)))) (break))) - (map-aggregator ,maptype ,res (,f x ,;(seq [k :range [0 n]] ~(in ,(symbol 'ind k) ,(symbol 'key k)))))))) + (def ,(seq [k :range [0 n]] (symbol 'ind k)) ,inds) + ,;(seq [k :range [0 n]] ~(var ,(symbol 'key k) nil)) + (each x ,ind + ,;(seq [k :range [0 n]] + ~(if (= nil (set ,(symbol 'key k) (next ,(symbol 'ind k) ,(symbol 'key k)))) (break))) + (map-aggregator ,maptype ,res (,f x ,;(seq [k :range [0 n]] ~(in ,(symbol 'ind k) ,(symbol 'key k)))))))) (defmacro- map-template [maptype res f ind inds] ~(do - (def ninds (length ,inds)) - (case ninds - 0 (each x ,ind (map-aggregator ,maptype ,res (,f x))) - 1 (map-n 1 ,maptype ,res ,f ,ind ,inds) - 2 (map-n 2 ,maptype ,res ,f ,ind ,inds) - 3 (map-n 3 ,maptype ,res ,f ,ind ,inds) - 4 (map-n 4 ,maptype ,res ,f ,ind ,inds) - (do - (def iter-keys (array/new-filled ninds)) - (def call-buffer (array/new-filled ninds)) - (var done false) - (each x ,ind - (forv i 0 ninds - (let [old-key (in iter-keys i) - ii (in ,inds i) - new-key (next ii old-key)] - (if (= nil new-key) - (do (set done true) (break)) - (do (set (iter-keys i) new-key) (set (call-buffer i) (in ii new-key)))))) - (if done (break)) - (map-aggregator ,maptype ,res (,f x ;call-buffer))))))) + (def ninds (length ,inds)) + (case ninds + 0 (each x ,ind (map-aggregator ,maptype ,res (,f x))) + 1 (map-n 1 ,maptype ,res ,f ,ind ,inds) + 2 (map-n 2 ,maptype ,res ,f ,ind ,inds) + 3 (map-n 3 ,maptype ,res ,f ,ind ,inds) + 4 (map-n 4 ,maptype ,res ,f ,ind ,inds) + (do + (def iter-keys (array/new-filled ninds)) + (def call-buffer (array/new-filled ninds)) + (var done false) + (each x ,ind + (forv i 0 ninds + (let [old-key (in iter-keys i) + ii (in ,inds i) + new-key (next ii old-key)] + (if (= nil new-key) + (do (set done true) (break)) + (do (set (iter-keys i) new-key) (set (call-buffer i) (in ii new-key)))))) + (if done (break)) + (map-aggregator ,maptype ,res (,f x ;call-buffer))))))) (defn map `Map a function over every value in a data structure and @@ -2131,23 +2131,23 @@ (not= tx (type y)) (case tx :tuple (or (not= (length x) (length y)) - (do - (var ret false) - (forv i 0 (length x) - (def xx (in x i)) - (def yy (in y i)) - (if (deep-not= xx yy) - (break (set ret true)))) - ret)) + (do + (var ret false) + (forv i 0 (length x) + (def xx (in x i)) + (def yy (in y i)) + (if (deep-not= xx yy) + (break (set ret true)))) + ret)) :array (or (not= (length x) (length y)) - (do - (var ret false) - (forv i 0 (length x) - (def xx (in x i)) - (def yy (in y i)) - (if (deep-not= xx yy) - (break (set ret true)))) - ret)) + (do + (var ret false) + (forv i 0 (length x) + (def xx (in x i)) + (def yy (in y i)) + (if (deep-not= xx yy) + (break (set ret true)))) + ret)) :struct (deep-not= (kvs x) (kvs y)) :table (deep-not= (table/to-struct x) (table/to-struct y)) :buffer (not= (string x) (string y)) @@ -3213,16 +3213,17 @@ (cond (or (= b (chr "\n")) (= b (chr " "))) (endtoken) (= b (chr "`")) (delim :code) - (not (modes :code)) (cond + (not (modes :code)) + (cond (= b (chr `\`)) (do (++ token-length) (buffer/push token (get line (++ i)))) (= b (chr "_")) (delim :underline) (= b (chr "*")) - (if (= (chr "*") (get line (+ i 1))) - (do (++ i) - (delim :bold)) - (delim :italics)) + (if (= (chr "*") (get line (+ i 1))) + (do (++ i) + (delim :bold)) + (delim :italics)) (do (++ token-length) (buffer/push token b))) (do (++ token-length) (buffer/push token b)))) (endtoken) @@ -3766,10 +3767,10 @@ (defn make-ptr [] (assert (ffi/lookup (if lazy (llib) lib) raw-symbol) (string "failed to find ffi symbol " raw-symbol))) (if lazy - ~(defn ,name ,;meta [,;formal-args] - (,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args)) - ~(defn ,name ,;meta [,;formal-args] - (,ffi/call ,(make-ptr) ,(make-sig) ,;formal-args))))) + ~(defn ,name ,;meta [,;formal-args] + (,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args)) + ~(defn ,name ,;meta [,;formal-args] + (,ffi/call ,(make-ptr) ,(make-sig) ,;formal-args))))) ### ### From 53447e9d0b5620ec2fd0738063f5adce7d7a55a9 Mon Sep 17 00:00:00 2001 From: Christopher Chambers Date: Sun, 4 Jun 2023 09:59:10 -0400 Subject: [PATCH 081/138] Ensure ev/gather fibers are fully canceled on error. --- src/boot/boot.janet | 10 +++++++--- test/suite-ev.janet | 7 +++++++ 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index e283c508..44584836 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -3663,17 +3663,21 @@ (,ev/deadline ,deadline nil ,f) (,resume ,f)))) - (defn- cancel-all [fibers reason] (each f fibers (ev/cancel f reason) (put fibers f nil))) + (defn- cancel-all [chan fibers reason] + (each f fibers (ev/cancel f reason)) + (let [n (length fibers)] + (table/clear fibers) + (repeat n (ev/take chan)))) (defn- wait-for-fibers [chan fibers] - (defer (cancel-all fibers "parent canceled") + (defer (cancel-all chan fibers "parent canceled") (repeat (length fibers) (def [sig fiber] (ev/take chan)) (if (= sig :ok) (put fibers fiber nil) (do - (cancel-all fibers "sibling canceled") + (cancel-all chan fibers "sibling canceled") (propagate (fiber/last-value fiber) fiber)))))) (defmacro ev/gather diff --git a/test/suite-ev.janet b/test/suite-ev.janet index b2140f5f..d076355e 100644 --- a/test/suite-ev.janet +++ b/test/suite-ev.janet @@ -168,6 +168,13 @@ (assert (deep= @[] (ev/gather)) "ev/gather 2") (assert-error "ev/gather 3" (ev/gather 1 2 (error 3))) +(var cancel-counter 0) +(assert-error "ev/gather 4.1" (ev/gather + (defer (++ cancel-counter) (ev/take (ev/chan))) + (defer (++ cancel-counter) (ev/take (ev/chan))) + (error :oops))) +(assert (= cancel-counter 2) "ev/gather 4.2") + # Net testing # 2904c19ed (repeat 10 From 67f375bea245b2f5e32a5f24dcbbcac3859b9249 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 07:48:04 -0500 Subject: [PATCH 082/138] Small code style change to boot.janet --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 44584836..4046bf4c 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2868,7 +2868,7 @@ (if (= :dead fs) (when is-repl (put env '_ @{:value x}) - (printf (get env :pretty-format "%q") x) + (printf (get env *pretty-format* "%q") x) (flush)) (do (debug/stacktrace f x "") From 4b3c813f5abfad2836203d2ac8ae6ca839283360 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 11:21:52 -0500 Subject: [PATCH 083/138] Revert to old behavior of janet_fiber returning NULL. When there is a bad arity function passed in to the fiber constructor, return NULL so the runtime can choose what to do. This is not the prettiest API but does work, and gives better error messages for instance in the compiler. --- src/core/fiber.c | 5 ++--- src/core/vm.c | 8 ++++---- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/core/fiber.c b/src/core/fiber.c index 8851e434..44c3f13f 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -93,9 +93,7 @@ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t /* Create a new fiber with argn values on the stack. */ JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv) { - JanetFiber *result = janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv); - if (NULL == result) janet_panic("cannot create fiber"); - return result; + return janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv); } #ifdef JANET_DEBUG @@ -512,6 +510,7 @@ JANET_CORE_FN(cfun_fiber_new, janet_panicf("fiber function must accept 0 or 1 arguments"); } fiber = janet_fiber(func, 64, func->def->min_arity, NULL); + janet_assert(fiber != NULL, "bad fiber arity check"); if (argc == 2) { int32_t i; JanetByteView view = janet_getbytes(argv, 1); diff --git a/src/core/vm.c b/src/core/vm.c index 8d1a62bf..444f8d79 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -1513,14 +1513,14 @@ JanetSignal janet_pcall( JanetFiber *fiber; if (f && *f) { fiber = janet_fiber_reset(*f, fun, argc, argv); - if (NULL == fiber) { - *out = janet_cstringv("arity mismatch"); - return JANET_SIGNAL_ERROR; - } } else { fiber = janet_fiber(fun, 64, argc, argv); } if (f) *f = fiber; + if (NULL == fiber) { + *out = janet_cstringv("arity mismatch"); + return JANET_SIGNAL_ERROR; + } return janet_continue(fiber, janet_wrap_nil(), out); } From dd3b601c878d16c3686f337dbd279b1533ff6446 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 12:55:44 -0500 Subject: [PATCH 084/138] Don't do fiber double arity check. --- src/core/ev.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/ev.c b/src/core/ev.c index f9e830b6..3a23804a 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -2915,10 +2915,10 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { janet_panicf("expected function or fiber, got %v", fiberv); } JanetFunction *func = janet_unwrap_function(fiberv); - if (func->def->min_arity > 1) { + fiber = janet_fiber(func, 64, func->def->min_arity, &value); + if (fiber == NULL) { janet_panicf("thread function must accept 0 or 1 arguments"); } - fiber = janet_fiber(func, 64, func->def->min_arity, &value); fiber->flags |= JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER0 | From bb4ff05d35fdd01dbd4cd61ae9740c01830d6d86 Mon Sep 17 00:00:00 2001 From: Ico Doornekamp Date: Thu, 1 Jun 2023 14:21:15 +0200 Subject: [PATCH 085/138] Added NO_AMALG flag to Makefile to build janet from the individual source files instead of from the amalgamated janet.c; this considerably speeds up parallel builds on modern CPUs --- Makefile | 25 ++++++++++++++++++++----- src/boot/boot.janet | 9 +++++---- 2 files changed, 25 insertions(+), 9 deletions(-) diff --git a/Makefile b/Makefile index cd5cfb3f..404f76f2 100644 --- a/Makefile +++ b/Makefile @@ -39,6 +39,8 @@ JANET_PATH?=$(LIBDIR)/janet JANET_MANPATH?=$(PREFIX)/share/man/man1/ JANET_PKG_CONFIG_PATH?=$(LIBDIR)/pkgconfig JANET_DIST_DIR?=janet-dist +JANET_BOOT_FLAGS:=. JANET_PATH '$(JANET_PATH)' +JANET_TARGET_OBJECTS=build/janet.o build/shell.o JPM_TAG?=master DEBUGGER=gdb SONAME_SETTER=-Wl,-soname, @@ -54,6 +56,12 @@ COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidd BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) -g BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) +# Disable amalgamated build +ifeq ($(JANET_NO_AMALG), 1) + JANET_TARGET_OBJECTS+=$(patsubst src/%.c,build/%.bin.o,$(JANET_CORE_SOURCES)) + JANET_BOOT_FLAGS+=image-only +endif + # For installation LDCONFIG:=ldconfig "$(LIBDIR)" @@ -88,7 +96,7 @@ ifeq ($(findstring MINGW,$(UNAME)), MINGW) JANET_BOOT:=$(JANET_BOOT).exe endif -$(shell mkdir -p build/core build/c build/boot) +$(shell mkdir -p build/core build/c build/boot build/mainclient) all: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.h ###################### @@ -172,9 +180,16 @@ $(JANET_BOOT): $(JANET_BOOT_OBJECTS) # Now the reason we bootstrap in the first place build/c/janet.c: $(JANET_BOOT) src/boot/boot.janet - $(RUN) $(JANET_BOOT) . JANET_PATH '$(JANET_PATH)' > $@ + $(RUN) $(JANET_BOOT) $(JANET_BOOT_FLAGS) > $@ cksum $@ +################## +##### Quicky ##### +################## + +build/%.bin.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile + $(HOSTCC) $(BUILD_CFLAGS) -o $@ -c $< + ######################## ##### Amalgamation ##### ######################## @@ -200,13 +215,13 @@ build/janet.o: build/c/janet.c $(JANETCONF_HEADER) src/include/janet.h build/shell.o: build/c/shell.c $(JANETCONF_HEADER) src/include/janet.h $(HOSTCC) $(BUILD_CFLAGS) -c $< -o $@ -$(JANET_TARGET): build/janet.o build/shell.o +$(JANET_TARGET): $(JANET_TARGET_OBJECTS) $(HOSTCC) $(LDFLAGS) $(BUILD_CFLAGS) -o $@ $^ $(CLIBS) -$(JANET_LIBRARY): build/janet.o build/shell.o +$(JANET_LIBRARY): $(JANET_TARGET_OBJECTS) $(HOSTCC) $(LDFLAGS) $(BUILD_CFLAGS) $(SONAME_SETTER)$(SONAME) -shared -o $@ $^ $(CLIBS) -$(JANET_STATIC_LIBRARY): build/janet.o build/shell.o +$(JANET_STATIC_LIBRARY): $(JANET_TARGET_OBJECTS) $(HOSTAR) rcs $@ $^ ################### diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 0004f954..b33f182e 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -4157,10 +4157,11 @@ (defn do-one-file [fname] - (print "\n/* " fname " */") - (print "#line 0 \"" fname "\"\n") - (def source (slurp fname)) - (print (string/replace-all "\r" "" source))) + (if-not (has-value? boot/args "image-only") (do + (print "\n/* " fname " */") + (print "#line 0 \"" fname "\"\n") + (def source (slurp fname)) + (print (string/replace-all "\r" "" source))))) (do-one-file feature-header) From 88a8e2c1dfa612905a898268cdf5ff5500947e6b Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 14:05:37 -0500 Subject: [PATCH 086/138] Define *task-id* since it is part of the event-loop runtime. --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 4046bf4c..18e8ba54 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1196,7 +1196,6 @@ (def kw (keyword prefix (slice alias 1 -2))) ~(def ,alias :dyn ,;more ,kw)) - (defn has-key? "Check if a data structure `ds` contains the key `key`." [ds key] @@ -1215,6 +1214,7 @@ (defdyn *debug* "Enables a built in debugger on errors and other useful features for debugging in a repl.") (defdyn *exit* "When set, will cause the current context to complete. Can be set to exit from repl (or file), for example.") (defdyn *exit-value* "Set the return value from `run-context` upon an exit. By default, `run-context` will return nil.") +(defdyn *task-id* "When spawning a thread or fiber, the task-id can be assigned for concurrecny control.") (defdyn *macro-form* "Inside a macro, is bound to the source form that invoked the macro") From 1efb0adb35931b958d27251d5607ddb0d8c11e58 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 14:17:18 -0500 Subject: [PATCH 087/138] Add 3 argument form to fiber/new Allow passing in environment table at fiber creation since it is a fairly common thing to do. --- src/boot/boot.janet | 7 +++---- src/core/fiber.c | 13 ++++++++----- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 18e8ba54..77b20944 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -2530,8 +2530,8 @@ (set good false) (def {:error err :line line :column column :fiber errf} res) (on-compile-error err errf where (or line l) (or column c)))))) - guard)) - (fiber/setenv f env) + guard + env)) (while (fiber/can-resume? f) (def res (resume f resumeval)) (when good (set resumeval (onstatus f res))))) @@ -3868,8 +3868,7 @@ (def guard (if (get env :debug) :ydt :y)) (defn wrap-main [&] (main ;subargs)) - (def f (fiber/new wrap-main guard)) - (fiber/setenv f env) + (def f (fiber/new wrap-main guard env)) (var res nil) (while (fiber/can-resume? f) (set res (resume f res)) diff --git a/src/core/fiber.c b/src/core/fiber.c index 44c3f13f..90bdb181 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -478,10 +478,10 @@ JANET_CORE_FN(cfun_fiber_setenv, } JANET_CORE_FN(cfun_fiber_new, - "(fiber/new func &opt sigmask)", + "(fiber/new func &opt sigmask env)", "Create a new fiber with function body func. Can optionally " - "take a set of signals to block from the current parent fiber " - "when called. The mask is specified as a keyword where each character " + "take a set of signals `sigmask` to capture from child fibers, " + "and an environment table `env`. The mask is specified as a keyword where each character " "is used to indicate a signal to block. If the ev module is enabled, and " "this fiber is used as an argument to `ev/go`, these \"blocked\" signals " "will result in messages being sent to the supervisor channel. " @@ -503,7 +503,7 @@ JANET_CORE_FN(cfun_fiber_new, "exclusive flags are present, the last flag takes precedence.\n\n" "* :i - inherit the environment from the current fiber\n" "* :p - the environment table's prototype is the current environment table") { - janet_arity(argc, 1, 2); + janet_arity(argc, 1, 3); JanetFunction *func = janet_getfunction(argv, 0); JanetFiber *fiber; if (func->def->min_arity > 1) { @@ -511,7 +511,10 @@ JANET_CORE_FN(cfun_fiber_new, } fiber = janet_fiber(func, 64, func->def->min_arity, NULL); janet_assert(fiber != NULL, "bad fiber arity check"); - if (argc == 2) { + if (argc == 3 && !janet_checktype(argv[2], JANET_NIL)) { + fiber->env = janet_gettable(argv, 2); + } + if (argc >= 2) { int32_t i; JanetByteView view = janet_getbytes(argv, 1); fiber->flags = JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; From 6509e37c842b2606bd4b16ca2220ea8dfebe3e67 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 16:11:17 -0500 Subject: [PATCH 088/138] Update CHANGELOG.md and README.md --- CHANGELOG.md | 13 +++++++++++++ README.md | 31 +++++++++++++++++++++++++++---- 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d9f78e14..c5b1bbb7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,19 @@ All notable changes to this project will be documented in this file. ## ??? - Unreleased +- Add `net/setsockopt` +- Add `signal` argument to `os/proc-kill` to send signals besides `SIGKILL` on Posix. +- Add `source` argument to `os/clock` to get different time sources. +- Various combinator functions now are variadic like `map` +- Add `file/lines` to iterate over lines in a file lazily. +- Reorganize test suite to be sorted by module rather than pseudo-randomly. +- Add `*task-id*` +- Add `env` argument to `fiber/new`. +- Add `JANET_NO_AMALG` flag to Makefile to properly incremental builds +- Optimize bytecode compiler to generate fewer instructions and improve loops. +- Fix bug with `ev/gather` and hung fibers. +- Add `os/isatty` +- Add `has-key?` and `has-value?` - Make imperative arithmetic macros variadic - `ev/connect` now yields to the event loop instead of blocking while waiting for an ACK. diff --git a/README.md b/README.md index 45d06b92..def0246e 100644 --- a/README.md +++ b/README.md @@ -106,19 +106,18 @@ See the examples directory for all provided example programs. Janet makes a good system scripting language, or a language to embed in other programs. It's like Lua and Guile in that regard. It has more built-in functionality and a richer core language than -Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than these languages. +Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile. ## Features * 600+ functions and macros in the core library -* Build in socket networking, threading, subprocesses, and more. +* Built-in socket networking, threading, subprocesses, and file system functions. * Parsing Expression Grammars (PEG) engine as a more robust Regex alternative * Macros * Per-thread event loop for efficient IO (epoll/IOCP/kqueue) * Built-in C FFI lets you load existing binaries and run them. * Erlang-style supervision trees that integrate with the event loop * Configurable at build time - turn features on or off for a smaller or more featureful build -* Minimal setup - one binary and you are good to go! * First-class closures * Garbage collection * First-class green threads (continuations) @@ -328,6 +327,22 @@ Gitter provides Matrix and IRC bridges as well. ## FAQ +### How fast is it? + +Medium speed. + +In all seriousness, it is about the same speed as most interpreted languages without a JIT compiler. Tight, critical +loops should probably be written in C or C++ . Programs tend to be a bit faster than +they would be in a language like Python due to the discouragement of slow Object-Oriented abstraction +with lots of hash-table lookups, and making late-binding explicit. All values are boxed in an 8-byte +representation by default and allocated on the heap, with the exception of numbers, nils and booleans. The +PEG engine is a specialized interpreter that can efficiently process string and buffer data. + +The GC is simple and stop-the-world, but GC knobs are exposed in the core library and separate threads +have isolated heaps and garbage collectors. Data that is shared between threads is reference counted. + +YMMV. + ### Where is (favorite feature from other language)? It may exist, it may not. If you want to propose a major language feature, go ahead and open an issue, but @@ -345,7 +360,7 @@ Nope. There are no cons cells here. ### Is this a Clojure port? No. It's similar to Clojure superficially because I like Lisps and I like the aesthetics. -Internally, Janet is not at all like Clojure. +Internally, Janet is not at all like Clojure, Scheme, or Common Lisp. ### Are the immutable data structures (tuples and structs) implemented as hash tries? @@ -374,6 +389,14 @@ Usually, one of a few reasons: without feeling "bolted on", especially when compared to ALGOL-like languages. Adding features to the core also makes it a bit more difficult to keep Janet maximally portable. +### Can I bind to Rust/Zig/Go/Java/Nim/C++/D/Pascal/Fortran/Odin/Jai/(Some new "Systems" Programming Language)? + +Probably, if that language has a good interface with C. But the programmer may need to do +some extra work to map Janet's internal memory model may need some to that of the bound language. Janet +also uses `setjmp`/`longjmp` for non-local returns internally. This +approach is out of favor with many programmers now and doesn't always play well with other languages +that have exceptions or stack-unwinding. + ### Why is my terminal spitting out junk when I run the REPL? Make sure your terminal supports ANSI escape codes. Most modern terminals will From 528a51639033cc0fe3ce10973217d9483dfb6bcd Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 4 Jun 2023 18:48:34 -0500 Subject: [PATCH 089/138] Add more sandbox capabilities. Add more granularity to ffi sandbox capabilities - distinguish between using FFI functions, creating FFI functions, and creating executable memory. --- README.md | 31 +++++++++++++------------------ src/core/corelib.c | 6 ++++++ src/core/ffi.c | 20 ++++++++++---------- src/include/janet.h | 5 ++++- 4 files changed, 33 insertions(+), 29 deletions(-) diff --git a/README.md b/README.md index def0246e..8edabc7b 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Janet logo -**Janet** is a dynamic language and bytecode interpreter for system scripting, expressive automation, and +**Janet** is a programming language for system scripting, expressive automation, and extending programs written in C or C++ with user scripting capabilities. There is a REPL for trying out the language, as well as the ability @@ -105,34 +105,31 @@ See the examples directory for all provided example programs. ## Use Cases Janet makes a good system scripting language, or a language to embed in other programs. -It's like Lua and Guile in that regard. It has more built-in functionality and a richer core language than +It's like Lua and GNU Guile in that regard. It has more built-in functionality and a richer core language than Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile. -## Features +Some people use janet for sysadmin scripting, web development, or small video games. + +## Language Features * 600+ functions and macros in the core library * Built-in socket networking, threading, subprocesses, and file system functions. * Parsing Expression Grammars (PEG) engine as a more robust Regex alternative -* Macros +* Macros and compile-time computation * Per-thread event loop for efficient IO (epoll/IOCP/kqueue) -* Built-in C FFI lets you load existing binaries and run them. +* First-class green threads (continuations) as well as OS threads * Erlang-style supervision trees that integrate with the event loop -* Configurable at build time - turn features on or off for a smaller or more featureful build * First-class closures * Garbage collection -* First-class green threads (continuations) +* Distributed as janet.c and janet.h for embedding into a larger program. * Python-style generators (implemented as a plain macro) * Mutable and immutable arrays (array/tuple) * Mutable and immutable hashtables (table/struct) * Mutable and immutable strings (buffer/string) -* Multithreading -* Bytecode interpreter with an assembly interface, as well as bytecode verification -* Tail-call optimization -* Interface with C via abstract types and C functions -* Dynamically load C libraries -* REPL -* Embedding Janet in other programs -* Interactive environment with detailed stack traces +* Tail recursion +* Interface with C functions and dynamically load plugins ("natives"). +* Built-in C FFI for when the native bindings are too much work +* REPL development with debugger and inspectable runtime ## Documentation @@ -329,9 +326,7 @@ Gitter provides Matrix and IRC bridges as well. ### How fast is it? -Medium speed. - -In all seriousness, it is about the same speed as most interpreted languages without a JIT compiler. Tight, critical +It is about the same speed as most interpreted languages without a JIT compiler. Tight, critical loops should probably be written in C or C++ . Programs tend to be a bit faster than they would be in a language like Python due to the discouragement of slow Object-Oriented abstraction with lots of hash-table lookups, and making late-binding explicit. All values are boxed in an 8-byte diff --git a/src/core/corelib.c b/src/core/corelib.c index 0d72c118..741425a0 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -677,6 +677,9 @@ static const SandboxOption sandbox_options[] = { {"all", JANET_SANDBOX_ALL}, {"env", JANET_SANDBOX_ENV}, {"ffi", JANET_SANDBOX_FFI}, + {"ffi-define", JANET_SANDBOX_FFI_DEFINE}, + {"ffi-jit", JANET_SANDBOX_FFI_JIT}, + {"ffi-use", JANET_SANDBOX_FFI_USE}, {"fs", JANET_SANDBOX_FS}, {"fs-read", JANET_SANDBOX_FS_READ}, {"fs-temp", JANET_SANDBOX_FS_TEMP}, @@ -698,6 +701,9 @@ JANET_CORE_FN(janet_core_sandbox, "* :all - disallow all (except IO to stdout, stderr, and stdin)\n" "* :env - disallow reading and write env variables\n" "* :ffi - disallow FFI (recommended if disabling anything else)\n" + "* :ffi-define - disallow loading new FFI modules and binding new functions\n" + "* :ffi-jit - disallow calling `ffi/jitfn`\n" + "* :ffi-use - disallow using any previously bound FFI functions and memory-unsafe functions.\n" "* :fs - disallow access to the file system\n" "* :fs-read - disallow read access to the file system\n" "* :fs-temp - disallow creating temporary files\n" diff --git a/src/core/ffi.c b/src/core/ffi.c index ffd7301e..c61cc3da 100644 --- a/src/core/ffi.c +++ b/src/core/ffi.c @@ -1303,7 +1303,7 @@ JANET_CORE_FN(cfun_ffi_jitfn, "(ffi/jitfn bytes)", "Create an abstract type that can be used as the pointer argument to `ffi/call`. The content " "of `bytes` is architecture specific machine code that will be copied into executable memory.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_JIT); janet_fixarity(argc, 1); JanetByteView bytes = janet_getbytes(argv, 0); @@ -1356,7 +1356,7 @@ JANET_CORE_FN(cfun_ffi_call, "(ffi/call pointer signature & args)", "Call a raw pointer as a function pointer. The function signature specifies " "how Janet values in `args` are converted to native machine types.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, -1); void *function_pointer = janet_ffi_get_callable_pointer(argv, 0); JanetFFISignature *signature = janet_getabstract(argv, 1, &janet_signature_type); @@ -1381,7 +1381,7 @@ JANET_CORE_FN(cfun_ffi_buffer_write, "Append a native type to a buffer such as it would appear in memory. This can be used " "to pass pointers to structs in the ffi, or send C/C++/native structs over the network " "or to files. Returns a modifed buffer or a new buffer if one is not supplied.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 4); JanetFFIType type = decode_ffi_type(argv[0]); uint32_t el_size = (uint32_t) type_size(type); @@ -1404,7 +1404,7 @@ JANET_CORE_FN(cfun_ffi_buffer_read, "Parse a native struct out of a buffer and convert it to normal Janet data structures. " "This function is the inverse of `ffi/write`. `bytes` can also be a raw pointer, although " "this is unsafe.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 3); JanetFFIType type = decode_ffi_type(argv[0]); size_t offset = (size_t) janet_optnat(argv, argc, 2, 0); @@ -1451,7 +1451,7 @@ JANET_CORE_FN(janet_core_raw_native, " or run any code from it. This is different than `native`, which will " "run initialization code to get a module table. If `path` is nil, opens the current running binary. " "Returns a `core/native`.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_arity(argc, 0, 1); const char *path = janet_optcstring(argv, argc, 0, NULL); Clib lib = load_clib(path); @@ -1467,7 +1467,7 @@ JANET_CORE_FN(janet_core_native_lookup, "(ffi/lookup native symbol-name)", "Lookup a symbol from a native object. All symbol lookups will return a raw pointer " "if the symbol is found, else nil.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_fixarity(argc, 2); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); const char *sym = janet_getcstring(argv, 1); @@ -1481,7 +1481,7 @@ JANET_CORE_FN(janet_core_native_close, "(ffi/close native)", "Free a native object. Dereferencing pointers to symbols in the object will have undefined " "behavior after freeing.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_fixarity(argc, 1); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); if (anative->closed) janet_panic("native object already closed"); @@ -1494,7 +1494,7 @@ JANET_CORE_FN(janet_core_native_close, JANET_CORE_FN(cfun_ffi_malloc, "(ffi/malloc size)", "Allocates memory directly using the janet memory allocator. Memory allocated in this way must be freed manually! Returns a raw pointer, or nil if size = 0.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_fixarity(argc, 1); size_t size = janet_getsize(argv, 0); if (size == 0) return janet_wrap_nil(); @@ -1504,7 +1504,7 @@ JANET_CORE_FN(cfun_ffi_malloc, JANET_CORE_FN(cfun_ffi_free, "(ffi/free pointer)", "Free memory allocated with `ffi/malloc`. Returns nil.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_fixarity(argc, 1); if (janet_checktype(argv[0], JANET_NIL)) return janet_wrap_nil(); void *pointer = janet_getpointer(argv, 0); @@ -1519,7 +1519,7 @@ JANET_CORE_FN(cfun_ffi_pointer_buffer, "to be manipulated with buffer functions. Attempts to resize or extend the buffer " "beyond its initial capacity will raise an error. As with many FFI functions, this is memory " "unsafe and can potentially allow out of bounds memory access. Returns a new buffer.") { - janet_sandbox_assert(JANET_SANDBOX_FFI); + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 4); void *pointer = janet_getpointer(argv, 0); int32_t capacity = janet_getnat(argv, 1); diff --git a/src/include/janet.h b/src/include/janet.h index 1064380b..40f1a0fe 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -1809,13 +1809,16 @@ JANET_API void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *pr #define JANET_SANDBOX_SUBPROCESS 2 #define JANET_SANDBOX_NET_CONNECT 4 #define JANET_SANDBOX_NET_LISTEN 8 -#define JANET_SANDBOX_FFI 16 +#define JANET_SANDBOX_FFI_DEFINE 16 #define JANET_SANDBOX_FS_WRITE 32 #define JANET_SANDBOX_FS_READ 64 #define JANET_SANDBOX_HRTIME 128 #define JANET_SANDBOX_ENV 256 #define JANET_SANDBOX_DYNAMIC_MODULES 512 #define JANET_SANDBOX_FS_TEMP 1024 +#define JANET_SANDBOX_FFI_USE 2048 +#define JANET_SANDBOX_FFI_JIT 4096 +#define JANET_SANDBOX_FFI (JANET_SANDBOX_FFI_DEFINE | JANET_SANDBOX_FFI_USE | JANET_SANDBOX_FFI_JIT) #define JANET_SANDBOX_FS (JANET_SANDBOX_FS_WRITE | JANET_SANDBOX_FS_READ | JANET_SANDBOX_FS_TEMP) #define JANET_SANDBOX_NET (JANET_SANDBOX_NET_CONNECT | JANET_SANDBOX_NET_LISTEN) #define JANET_SANDBOX_ALL (UINT32_MAX) From 8c819b1f915afd890aeedf375fa933f539a3fbf8 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 5 Jun 2023 12:55:08 -0500 Subject: [PATCH 090/138] Update README.md --- README.md | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 8edabc7b..df3d3240 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,10 @@ **Janet** is a programming language for system scripting, expressive automation, and extending programs written in C or C++ with user scripting capabilities. +Janet makes a good system scripting language, or a language to embed in other programs. +It's like Lua and GNU Guile in that regard. It has more built-in functionality and a richer core language than +Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile. + There is a REPL for trying out the language, as well as the ability to run script files. This client program is separate from the core runtime, so Janet can be embedded in other programs. Try Janet in your browser at @@ -102,14 +106,6 @@ See the examples directory for all provided example programs. (MessageBoxA nil "Hello, World!" "Test" 0) ``` -## Use Cases - -Janet makes a good system scripting language, or a language to embed in other programs. -It's like Lua and GNU Guile in that regard. It has more built-in functionality and a richer core language than -Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile. - -Some people use janet for sysadmin scripting, web development, or small video games. - ## Language Features * 600+ functions and macros in the core library From 472ec730b5c22470535f1fcc707915172ad2a864 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Wed, 7 Jun 2023 17:41:20 +0700 Subject: [PATCH 091/138] take-drop symmetry Allow `take` from the end of bytes or indexed (as `drop` does). Allow `drop` from fibers (as `take` does). --- src/boot/boot.janet | 103 ++++++++++++++++++++++-------------------- test/suite-boot.janet | 44 +++++++++++++----- 2 files changed, 85 insertions(+), 62 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 82abb7de..86bbcad3 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1080,42 +1080,30 @@ (set k (next ind k))) ret) -(defn- take-n-fallback - [n xs] - (def res @[]) - (when (> n 0) - (var left n) - (each x xs - (array/push res x) - (-- left) - (if (= 0 left) (break)))) - res) - -(defn- take-until-fallback - [pred xs] - (def res @[]) - (each x xs - (if (pred x) (break)) - (array/push res x)) - res) - -(defn- slice-n +(defn- take-n-slice [f n ind] (def len (length ind)) - # make sure end is in [0, len] - (def m (if (> n 0) n 0)) - (def end (if (> m len) len m)) - (f ind 0 end)) + (def negn (< n 0)) + (def start (if negn (max 0 (+ len n)) 0)) + (def end (if negn len (min n len))) + (f ind start end)) (defn take - "Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string, respectively." + ``Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string, + respectively. If `n` is negative, takes the last `n` elements instead.`` [n ind] (cond - (bytes? ind) (slice-n string/slice n ind) - (indexed? ind) (slice-n tuple/slice n ind) - (take-n-fallback n ind))) + (bytes? ind) (take-n-slice string/slice n ind) + (indexed? ind) (take-n-slice tuple/slice n ind) + (do + (def res @[]) + (var key nil) + (repeat n + (if (= nil (set key (next ind key))) (break)) + (array/push res (in ind key))) + res))) -(defn- slice-until +(defn- take-until-slice [f pred ind] (def len (length ind)) (def i (find-index pred ind)) @@ -1126,9 +1114,9 @@ "Same as `(take-while (complement pred) ind)`." [pred ind] (cond - (bytes? ind) (slice-until string/slice pred ind) - (indexed? ind) (slice-until tuple/slice pred ind) - (take-until-fallback pred ind))) + (bytes? ind) (take-until-slice string/slice pred ind) + (indexed? ind) (take-until-slice tuple/slice pred ind) + (seq [x :in ind :until (pred x)] x))) (defn take-while `Given a predicate, take only elements from a fiber, indexed, or bytes type that satisfy @@ -1136,27 +1124,41 @@ [pred ind] (take-until (complement pred) ind)) +(defn- drop-n-slice + [f n ind] + (def len (length ind)) + (def negn (< n 0)) + (def start (if negn 0 (min n len))) + (def end (if negn (max 0 (+ len n)) len)) + (f ind start end)) + (defn drop - ``Drop the first `n elements in an indexed or bytes type. Returns a new tuple or string + ``Drop the first `n` elements in an indexed or bytes type. Returns a new tuple or string instance, respectively. If `n` is negative, drops the last `n` elements instead.`` [n ind] - (def use-str (bytes? ind)) - (def f (if use-str string/slice tuple/slice)) + (cond + (bytes? ind) (drop-n-slice string/slice n ind) + (indexed? ind) (drop-n-slice tuple/slice n ind) + (do + (var key nil) + (repeat n + (if (= nil (set key (next ind key))) (break))) + ind))) + +(defn- drop-until-slice + [f pred ind] (def len (length ind)) - (def negn (>= n 0)) - (def start (if negn (min n len) 0)) - (def end (if negn len (max 0 (+ len n)))) - (f ind start end)) + (def i (find-index pred ind)) + (def start (if (nil? i) len i)) + (f ind start)) (defn drop-until "Same as `(drop-while (complement pred) ind)`." [pred ind] - (def use-str (bytes? ind)) - (def f (if use-str string/slice tuple/slice)) - (def i (find-index pred ind)) - (def len (length ind)) - (def start (if (nil? i) len i)) - (f ind start)) + (cond + (bytes? ind) (drop-until-slice string/slice pred ind) + (indexed? ind) (drop-until-slice tuple/slice pred ind) + (do (find pred ind) ind))) (defn drop-while `Given a predicate, remove elements from an indexed or bytes type that satisfy @@ -4166,11 +4168,12 @@ (defn do-one-file [fname] - (if-not (has-value? boot/args "image-only") (do - (print "\n/* " fname " */") - (print "#line 0 \"" fname "\"\n") - (def source (slurp fname)) - (print (string/replace-all "\r" "" source))))) + (if-not (has-value? boot/args "image-only") + (do + (print "\n/* " fname " */") + (print "#line 0 \"" fname "\"\n") + (def source (slurp fname)) + (print (string/replace-all "\r" "" source))))) (do-one-file feature-header) diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 902cdd1c..c53c9a88 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -439,7 +439,7 @@ (assert (deep= (take 10 []) []) "take 2") (assert (deep= (take 0 [1 2 3 4 5]) []) "take 3") (assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4") -(assert (deep= (take -1 [:a :b :c]) []) "take 5") +(assert (deep= (take -1 [:a :b :c]) [:c]) "take 5") # 34019222c (assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3]) "take from fiber") @@ -482,7 +482,6 @@ (assert (deep= (drop 10 "abc") "") "drop 8") (assert (deep= (drop -1 "abc") "ab") "drop 9") (assert (deep= (drop -10 "abc") "") "drop 10") -(assert-error :invalid-type (drop 3 {}) "drop 11") # drop-until # 75dc08f @@ -493,6 +492,27 @@ (assert (deep= (drop-until pos? @[-1 1 -2]) [1 -2]) "drop-until 5") (assert (deep= (drop-until |(= $ 115) "books") "s") "drop-until 6") +# take-drop symmetry #1178 +(def items-list ['abcde :abcde "abcde" @"abcde" [1 2 3 4 5] @[1 2 3 4 5]]) + +(each items items-list + (def len (length items)) + (for i 0 (+ len 1) + (assert (deep= (take i items) (drop (- i len) items)) (string/format "take-drop symmetry %q %d" items i)) + (assert (deep= (take (- i) items) (drop (- len i) items)) (string/format "take-drop symmetry %q %d" items i)))) + +(defn squares [] + (coro + (var [a b] [0 1]) + (forever (yield a) (+= a b) (+= b 2)))) + +(def sqr1 (squares)) +(assert (deep= (take 10 sqr1) @[0 1 4 9 16 25 36 49 64 81])) +(assert (deep= (take 1 sqr1) @[100]) "take fiber next value") + +(def sqr2 (drop 10 (squares))) +(assert (deep= (take 1 sqr2) @[100]) "drop fiber next value") + # Comment macro # issue #110 - 698e89aba (comment 1) @@ -649,9 +669,9 @@ # NOTE: These is a motivation for the has-value? and has-key? functions below # returns false despite key present -(assert (= false (index-of 8 {true 7 false 8})) +(assert (= false (index-of 8 {true 7 false 8})) "index-of corner key (false) 1") -(assert (= false (index-of 8 @{false 8})) +(assert (= false (index-of 8 @{false 8})) "index-of corner key (false) 2") # still returns null (assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") @@ -670,11 +690,11 @@ (assert (= false (has-value? "abc" "1")) "has-value? 10") # weird true/false corner cases, should align with "index-of corner # key {k}" cases -(assert (= true (has-value? {true 7 false 8} 8)) +(assert (= true (has-value? {true 7 false 8} 8)) "has-value? corner key (false) 1") -(assert (= true (has-value? @{false 8} 8)) +(assert (= true (has-value? @{false 8} 8)) "has-value? corner key (false) 2") -(assert (= false (has-value? {false 8} 7)) +(assert (= false (has-value? {false 8} 7)) "has-value? corner key (false) 3") # has-key? @@ -713,16 +733,16 @@ (test-has-key "abc" 4 false) # 11 # weird true/false corner cases # - # Tries to mimic the corresponding corner cases in has-value? and + # Tries to mimic the corresponding corner cases in has-value? and # index-of, but with keys/values inverted # - # in the first two cases (truthy? (get val col)) would have given false + # in the first two cases (truthy? (get val col)) would have given false # negatives - (test-has-key {7 true 8 false} 8 true :name + (test-has-key {7 true 8 false} 8 true :name "has-key? corner value (false) 1") - (test-has-key @{8 false} 8 true :name + (test-has-key @{8 false} 8 true :name "has-key? corner value (false) 2") - (test-has-key @{8 false} 7 false :name + (test-has-key @{8 false} 7 false :name "has-key? corner value (false) 3")) # Regression From b5407ac708ff38b30655423c9ab1761b7d3a2214 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Wed, 7 Jun 2023 19:20:05 +0700 Subject: [PATCH 092/138] take-drop dictionaries Return table for `take` of dictionary types. Allow `drop` of dictionary types. --- src/boot/boot.janet | 21 +++++++++++++++++++++ test/suite-boot.janet | 8 ++++++++ 2 files changed, 29 insertions(+) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 86bbcad3..42114687 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1095,6 +1095,9 @@ (cond (bytes? ind) (take-n-slice string/slice n ind) (indexed? ind) (take-n-slice tuple/slice n ind) + (dictionary? ind) (do + (var left n) + (tabseq [[i x] :pairs ind :until (< (-- left) 0)] i x)) (do (def res @[]) (var key nil) @@ -1116,6 +1119,7 @@ (cond (bytes? ind) (take-until-slice string/slice pred ind) (indexed? ind) (take-until-slice tuple/slice pred ind) + (dictionary? ind) (tabseq [[i x] :pairs ind :until (pred x)] i x) (seq [x :in ind :until (pred x)] x))) (defn take-while @@ -1132,6 +1136,13 @@ (def end (if negn (max 0 (+ len n)) len)) (f ind start end)) +(defn- drop-n-dict + [f n ind] + (def res (f ind)) + (var left n) + (loop [[i x] :pairs ind :until (< (-- left) 0)] (set (res i) nil)) + res) + (defn drop ``Drop the first `n` elements in an indexed or bytes type. Returns a new tuple or string instance, respectively. If `n` is negative, drops the last `n` elements instead.`` @@ -1139,6 +1150,8 @@ (cond (bytes? ind) (drop-n-slice string/slice n ind) (indexed? ind) (drop-n-slice tuple/slice n ind) + (struct? ind) (drop-n-dict struct/to-table n ind) + (table? ind) (drop-n-dict table/clone n ind) (do (var key nil) (repeat n @@ -1152,12 +1165,20 @@ (def start (if (nil? i) len i)) (f ind start)) +(defn- drop-until-dict + [f pred ind] + (def res (f ind)) + (loop [[i x] :pairs ind :until (pred x)] (set (res i) nil)) + res) + (defn drop-until "Same as `(drop-while (complement pred) ind)`." [pred ind] (cond (bytes? ind) (drop-until-slice string/slice pred ind) (indexed? ind) (drop-until-slice tuple/slice pred ind) + (struct? ind) (drop-until-dict struct/to-table pred ind) + (table? ind) (drop-until-dict table/clone pred ind) (do (find pred ind) ind))) (defn drop-while diff --git a/test/suite-boot.janet b/test/suite-boot.janet index c53c9a88..49a022cb 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -513,6 +513,14 @@ (def sqr2 (drop 10 (squares))) (assert (deep= (take 1 sqr2) @[100]) "drop fiber next value") +(def dict @{:a 1 :b 2 :c 3 :d 4 :e 5}) +(def dict1 (take 2 dict)) +(def dict2 (drop 2 dict)) + +(assert (= (length dict1) 2) "take dictionary") +(assert (= (length dict2) 3) "drop dictionary") +(assert (deep= (merge dict1 dict2) dict) "take-drop symmetry for dictionary") + # Comment macro # issue #110 - 698e89aba (comment 1) From 57c954783d63a6395db2d72870dbe604407e47ab Mon Sep 17 00:00:00 2001 From: Christopher Chambers Date: Wed, 7 Jun 2023 14:56:31 -0400 Subject: [PATCH 093/138] Fix resumption values when closing a channel. When suspended in `ev/give` or `ev/take`, closing the channel should cause the result of `ev/give` or `ev/take` to be `nil`. When suspended in `ev/select`, closing the channel should cause the result of `ev/select` to be `[:close ch]`. The results were flipped before. --- src/core/ev.c | 8 ++++---- test/suite-ev.janet | 20 ++++++++++++++++++++ 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/src/core/ev.c b/src/core/ev.c index 3a23804a..ad8f5bd4 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1171,9 +1171,9 @@ JANET_CORE_FN(cfun_channel_close, janet_ev_post_event(vm, janet_thread_chan_cb, msg); } else { if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { - janet_schedule(writer.fiber, janet_wrap_nil()); - } else { janet_schedule(writer.fiber, make_close_result(channel)); + } else { + janet_schedule(writer.fiber, janet_wrap_nil()); } } } @@ -1190,9 +1190,9 @@ JANET_CORE_FN(cfun_channel_close, janet_ev_post_event(vm, janet_thread_chan_cb, msg); } else { if (reader.mode == JANET_CP_MODE_CHOICE_READ) { - janet_schedule(reader.fiber, janet_wrap_nil()); - } else { janet_schedule(reader.fiber, make_close_result(channel)); + } else { + janet_schedule(reader.fiber, janet_wrap_nil()); } } } diff --git a/test/suite-ev.janet b/test/suite-ev.janet index d076355e..184743d1 100644 --- a/test/suite-ev.janet +++ b/test/suite-ev.janet @@ -321,5 +321,25 @@ (assert (= item1 "hello")) (assert (= item2 "world")) +# ev/take, suspended, channel closed +(def ch (ev/chan)) +(ev/go |(ev/chan-close ch)) +(assert (= (ev/take ch) nil)) + +# ev/give, suspended, channel closed +(def ch (ev/chan)) +(ev/go |(ev/chan-close ch)) +(assert (= (ev/give ch 1) nil)) + +# ev/select, suspended take operation, channel closed +(def ch (ev/chan)) +(ev/go |(ev/chan-close ch)) +(assert (= (ev/select ch) [:close ch])) + +# ev/select, suspended give operation, channel closed +(def ch (ev/chan)) +(ev/go |(ev/chan-close ch)) +(assert (= (ev/select [ch 1]) [:close ch])) + (end-suite) From a238391b36d388918121040d98c042db4a22ec8e Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Thu, 8 Jun 2023 13:26:13 +0700 Subject: [PATCH 094/138] take-drop performance tweaks Increase efficiency for `take` and `drop` with slices. Check indexed types before bytes types. --- src/boot/boot.janet | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 42114687..73ad638f 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1083,9 +1083,9 @@ (defn- take-n-slice [f n ind] (def len (length ind)) - (def negn (< n 0)) - (def start (if negn (max 0 (+ len n)) 0)) - (def end (if negn len (min n len))) + (def m (+ len n)) + (def start (if (< n 0 m) m 0)) + (def end (if (<= 0 n len) n len)) (f ind start end)) (defn take @@ -1093,8 +1093,8 @@ respectively. If `n` is negative, takes the last `n` elements instead.`` [n ind] (cond - (bytes? ind) (take-n-slice string/slice n ind) (indexed? ind) (take-n-slice tuple/slice n ind) + (bytes? ind) (take-n-slice string/slice n ind) (dictionary? ind) (do (var left n) (tabseq [[i x] :pairs ind :until (< (-- left) 0)] i x)) @@ -1117,8 +1117,8 @@ "Same as `(take-while (complement pred) ind)`." [pred ind] (cond - (bytes? ind) (take-until-slice string/slice pred ind) (indexed? ind) (take-until-slice tuple/slice pred ind) + (bytes? ind) (take-until-slice string/slice pred ind) (dictionary? ind) (tabseq [[i x] :pairs ind :until (pred x)] i x) (seq [x :in ind :until (pred x)] x))) @@ -1131,10 +1131,10 @@ (defn- drop-n-slice [f n ind] (def len (length ind)) - (def negn (< n 0)) - (def start (if negn 0 (min n len))) - (def end (if negn (max 0 (+ len n)) len)) - (f ind start end)) + (cond + (<= 0 n len) (f ind n) + (< (- len) n 0) (f ind 0 (+ len n)) + (f ind 0 0))) (defn- drop-n-dict [f n ind] @@ -1148,8 +1148,8 @@ instance, respectively. If `n` is negative, drops the last `n` elements instead.`` [n ind] (cond - (bytes? ind) (drop-n-slice string/slice n ind) (indexed? ind) (drop-n-slice tuple/slice n ind) + (bytes? ind) (drop-n-slice string/slice n ind) (struct? ind) (drop-n-dict struct/to-table n ind) (table? ind) (drop-n-dict table/clone n ind) (do @@ -1175,8 +1175,8 @@ "Same as `(drop-while (complement pred) ind)`." [pred ind] (cond - (bytes? ind) (drop-until-slice string/slice pred ind) (indexed? ind) (drop-until-slice tuple/slice pred ind) + (bytes? ind) (drop-until-slice string/slice pred ind) (struct? ind) (drop-until-dict struct/to-table pred ind) (table? ind) (drop-until-dict table/clone pred ind) (do (find pred ind) ind))) From 866d83579e5181c9eb702ee81629563830b5c727 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 8 Jun 2023 09:06:34 -0500 Subject: [PATCH 095/138] Address #1165 - Allow for partial ffi support without totally removing testing. Query at runtime which calling conventions are supported, including a placeholder :none. --- src/core/ffi.c | 22 ++++++++++++++++++++++ test/suite-ffi.janet | 9 +++++++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/src/core/ffi.c b/src/core/ffi.c index c61cc3da..8fcf7d3c 100644 --- a/src/core/ffi.c +++ b/src/core/ffi.c @@ -1364,6 +1364,7 @@ JANET_CORE_FN(cfun_ffi_call, switch (signature->cc) { default: case JANET_FFI_CC_NONE: + (void) function_pointer; janet_panic("calling convention not supported"); #ifdef JANET_FFI_WIN64_ENABLED case JANET_FFI_CC_WIN_64: @@ -1529,6 +1530,26 @@ JANET_CORE_FN(cfun_ffi_pointer_buffer, return janet_wrap_buffer(janet_pointer_buffer_unsafe(offset_pointer, capacity, count)); } +JANET_CORE_FN(cfun_ffi_supported_calling_conventions, + "(ffi/calling-conventions)", + "Get an array of all supported calling conventions on the current arhcitecture. Some architectures may have some FFI " + "functionality (ffi/malloc, ffi/free, ffi/read, ffi/write, etc.) but not support " + "any calling conventions. This function can be used to get all supported calling conventions " + "that can be used on this architecture. All architectures support the :none calling " + "convention which is a placeholder that cannot be used at runtime.") { + janet_fixarity(argc, 0); + (void) argv; + JanetArray *array = janet_array(4); +#ifdef JANET_FFI_WIN64_ENABLED + janet_array_push(array, janet_ckeywordv("win64")); +#endif +#ifdef JANET_FFI_SYSV64_ENABLED + janet_array_push(array, janet_ckeywordv("sysv64")); +#endif + janet_array_push(array, janet_ckeywordv("none")); + return janet_wrap_array(array); +} + void janet_lib_ffi(JanetTable *env) { JanetRegExt ffi_cfuns[] = { JANET_CORE_REG("ffi/native", janet_core_raw_native), @@ -1546,6 +1567,7 @@ void janet_lib_ffi(JanetTable *env) { JANET_CORE_REG("ffi/malloc", cfun_ffi_malloc), JANET_CORE_REG("ffi/free", cfun_ffi_free), JANET_CORE_REG("ffi/pointer-buffer", cfun_ffi_pointer_buffer), + JANET_CORE_REG("ffi/calling-conventions", cfun_ffi_supported_calling_conventions), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, ffi_cfuns); diff --git a/test/suite-ffi.janet b/test/suite-ffi.janet index 42fb95d4..6ad4f70c 100644 --- a/test/suite-ffi.janet +++ b/test/suite-ffi.janet @@ -22,7 +22,12 @@ (start-suite) # We should get ARM support... -(def has-ffi (and (dyn 'ffi/native) (= (os/arch) :x64))) +(def has-ffi (dyn 'ffi/native)) +(def has-full-ffi + (and has-ffi + (when-let [entry (dyn 'ffi/calling-conventions)] + (def fficc (entry :value)) + (> (length (fficc)) 1)))) # all arches support :none # FFI check # d80356158 @@ -31,7 +36,7 @@ (compwhen has-ffi (ffi/defbind memcpy :ptr [dest :ptr src :ptr n :size])) -(compwhen has-ffi +(compwhen has-full-ffi (def buffer1 @"aaaa") (def buffer2 @"bbbb") (memcpy buffer1 buffer2 4) From 5317edc65d6a1bda16dc82bf23d3c45b45df99db Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Thu, 8 Jun 2023 23:00:05 +0700 Subject: [PATCH 096/138] minor readability change As suggested by @sogaiu @zevv forget to push this change in a recent PR (https://github.com/janet-lang/janet/pull/1175#issuecomment-1576128152). Incidentally, the affected lines were already reformatted in the current PR, via fmt/format-file. --- src/boot/boot.janet | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 73ad638f..bdeaf88d 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -4189,12 +4189,11 @@ (defn do-one-file [fname] - (if-not (has-value? boot/args "image-only") - (do - (print "\n/* " fname " */") - (print "#line 0 \"" fname "\"\n") - (def source (slurp fname)) - (print (string/replace-all "\r" "" source))))) + (unless (has-value? boot/args "image-only") + (print "\n/* " fname " */") + (print "#line 0 \"" fname "\"\n") + (def source (slurp fname)) + (print (string/replace-all "\r" "" source)))) (do-one-file feature-header) From 70b2e8179d4b1d4e5f7b57cd026a649cd2cc0a5b Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Thu, 8 Jun 2023 23:57:07 +0700 Subject: [PATCH 097/138] nitpick performance tweak --- src/boot/boot.janet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index bdeaf88d..0853ecbf 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1134,7 +1134,7 @@ (cond (<= 0 n len) (f ind n) (< (- len) n 0) (f ind 0 (+ len n)) - (f ind 0 0))) + (f ind len))) (defn- drop-n-dict [f n ind] From 9a2897e741d1f56d6c18e9c03b4bce7ff5b0779a Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 8 Jun 2023 13:01:49 -0500 Subject: [PATCH 098/138] Run through astyle with manual corrections --- examples/ffi/so.c | 3 --- src/boot/system_test.c | 1 - src/core/asm.c | 1 - src/core/buffer.c | 1 - src/core/ev.c | 6 ------ src/core/ffi.c | 12 ++++++------ src/core/io.c | 1 - src/core/net.c | 2 -- src/core/os.c | 2 -- src/core/specials.c | 3 --- src/include/janet.h | 2 -- src/mainclient/shell.c | 1 - 12 files changed, 6 insertions(+), 29 deletions(-) diff --git a/examples/ffi/so.c b/examples/ffi/so.c index c60a76e1..b2d097bf 100644 --- a/examples/ffi/so.c +++ b/examples/ffi/so.c @@ -78,7 +78,6 @@ double double_lots( return i + j; } - EXPORTER double double_lots_2( double a, @@ -204,5 +203,3 @@ EXPORTER int sixints_fn_3(SixInts s, int x) { return x + s.u + s.v + s.w + s.x + s.y + s.z; } - - diff --git a/src/boot/system_test.c b/src/boot/system_test.c index 8d58c5e6..0edcc1e4 100644 --- a/src/boot/system_test.c +++ b/src/boot/system_test.c @@ -70,6 +70,5 @@ int system_test() { assert(janet_equals(tuple1, tuple2)); - return 0; } diff --git a/src/core/asm.c b/src/core/asm.c index 043ad64d..b09b7e3a 100644 --- a/src/core/asm.c +++ b/src/core/asm.c @@ -949,7 +949,6 @@ static Janet janet_disasm_symbolslots(JanetFuncDef *def) { return janet_wrap_array(symbolslots); } - static Janet janet_disasm_bytecode(JanetFuncDef *def) { JanetArray *bcode = janet_array(def->bytecode_length); for (int32_t i = 0; i < def->bytecode_length; i++) { diff --git a/src/core/buffer.c b/src/core/buffer.c index 84f8fe08..5e1f76f9 100644 --- a/src/core/buffer.c +++ b/src/core/buffer.c @@ -354,7 +354,6 @@ JANET_CORE_FN(cfun_buffer_push, return argv[0]; } - JANET_CORE_FN(cfun_buffer_clear, "(buffer/clear buffer)", "Sets the size of a buffer to 0 and empties it. The buffer retains " diff --git a/src/core/ev.c b/src/core/ev.c index ad8f5bd4..28585d9f 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -20,7 +20,6 @@ * IN THE SOFTWARE. */ - #ifndef JANET_AMALG #include "features.h" #include @@ -365,7 +364,6 @@ void janet_stream_close(JanetStream *stream) { janet_stream_close_impl(stream, 0); } - /* Called to clean up a stream */ static int janet_stream_gc(void *p, size_t s) { (void) s; @@ -1453,7 +1451,6 @@ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, in return state; } - static void janet_unlisten(JanetListenerState *state, int is_gc) { janet_unlisten_impl(state, is_gc); } @@ -2173,7 +2170,6 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { janet_gcunroot(janet_wrap_fiber(return_value.fiber)); } - /* Convenience method for common case */ JANET_NO_RETURN void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp) { @@ -2523,7 +2519,6 @@ static JanetAsyncStatus handle_connect(JanetListenerState *s) { return JANET_ASYNC_STATUS_DONE; } - JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) { StateWrite *state = (StateWrite *) s; switch (event) { @@ -2703,7 +2698,6 @@ static void janet_ev_write_generic(JanetStream *stream, void *buf, void *dest_ab #endif } - void janet_ev_write_buffer(JanetStream *stream, JanetBuffer *buf) { janet_ev_write_generic(stream, buf, NULL, JANET_ASYNC_WRITEMODE_WRITE, 1, 0); } diff --git a/src/core/ffi.c b/src/core/ffi.c index 8fcf7d3c..41e3c04c 100644 --- a/src/core/ffi.c +++ b/src/core/ffi.c @@ -1531,12 +1531,12 @@ JANET_CORE_FN(cfun_ffi_pointer_buffer, } JANET_CORE_FN(cfun_ffi_supported_calling_conventions, - "(ffi/calling-conventions)", - "Get an array of all supported calling conventions on the current arhcitecture. Some architectures may have some FFI " - "functionality (ffi/malloc, ffi/free, ffi/read, ffi/write, etc.) but not support " - "any calling conventions. This function can be used to get all supported calling conventions " - "that can be used on this architecture. All architectures support the :none calling " - "convention which is a placeholder that cannot be used at runtime.") { + "(ffi/calling-conventions)", + "Get an array of all supported calling conventions on the current arhcitecture. Some architectures may have some FFI " + "functionality (ffi/malloc, ffi/free, ffi/read, ffi/write, etc.) but not support " + "any calling conventions. This function can be used to get all supported calling conventions " + "that can be used on this architecture. All architectures support the :none calling " + "convention which is a placeholder that cannot be used at runtime.") { janet_fixarity(argc, 0); (void) argv; JanetArray *array = janet_array(4); diff --git a/src/core/io.c b/src/core/io.c index a1567833..d9a8626a 100644 --- a/src/core/io.c +++ b/src/core/io.c @@ -504,7 +504,6 @@ static Janet cfun_io_print_impl_x(int32_t argc, Janet *argv, int newline, return janet_wrap_nil(); } - static Janet cfun_io_print_impl(int32_t argc, Janet *argv, int newline, const char *name, FILE *dflt_file) { Janet x = janet_dyn(name); diff --git a/src/core/net.c b/src/core/net.c index 273eee36..096b385b 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -256,7 +256,6 @@ JANET_NO_RETURN static void janet_sched_accept(JanetStream *stream, JanetFunctio janet_await(); } - #endif /* Adress info */ @@ -417,7 +416,6 @@ JANET_CORE_FN(cfun_net_connect, } } - /* Create socket */ JSock sock = JSOCKDEFAULT; void *addr = NULL; diff --git a/src/core/os.c b/src/core/os.c index d59bec98..e4ec5cd6 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -289,7 +289,6 @@ JANET_CORE_FN(os_cpu_count, #endif } - #ifndef JANET_NO_PROCESSES /* Get env for os_execute */ @@ -1076,7 +1075,6 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) { startupInfo.hStdInput = (HANDLE) _get_osfhandle(0); } - if (pipe_out != JANET_HANDLE_NONE) { startupInfo.hStdOutput = pipe_out; } else if (new_out != JANET_HANDLE_NONE) { diff --git a/src/core/specials.c b/src/core/specials.c index 5420f6c2..4f2b9740 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -182,7 +182,6 @@ static int destructure(JanetCompiler *c, return 1; } - if (!janet_checktype(values[i + 1], JANET_SYMBOL)) { janetc_error(c, janet_formatc("expected symbol following '& in destructuring pattern, found %q", values[i + 1])); return 1; @@ -651,7 +650,6 @@ static JanetSlot janetc_do(JanetFopts opts, int32_t argn, const Janet *argv) { return ret; } - /* Compile an upscope form. Upscope forms execute their body sequentially and * evaluate to the last expression in the body, but without lexical scope. */ static JanetSlot janetc_upscope(JanetFopts opts, int32_t argn, const Janet *argv) { @@ -1124,4 +1122,3 @@ const JanetSpecial *janetc_special(const uint8_t *name) { sizeof(JanetSpecial), name); } - diff --git a/src/include/janet.h b/src/include/janet.h index 40f1a0fe..509b194e 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -354,7 +354,6 @@ typedef struct JanetOSRWLock JanetOSRWLock; #include #include - /* What to do when out of memory */ #ifndef JANET_OUT_OF_MEMORY #define JANET_OUT_OF_MEMORY do { fprintf(stderr, "%s:%d - janet out of memory\n", __FILE__, __LINE__); exit(1); } while (0) @@ -1905,7 +1904,6 @@ JANET_API Janet janet_resolve_core(const char *name); #define JANET_DEF_SD(ENV, JNAME, VAL, DOC) \ janet_def_sm(ENV, JNAME, VAL, DOC, __FILE__, __LINE__) - /* Choose defaults for source mapping and docstring based on config defs */ #if defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS) #define JANET_REG JANET_REG_ diff --git a/src/mainclient/shell.c b/src/mainclient/shell.c index 3c1b13fc..a85b2246 100644 --- a/src/mainclient/shell.c +++ b/src/mainclient/shell.c @@ -548,7 +548,6 @@ static void kdeletew(void) { refresh(); } - /* See tools/symchargen.c */ static int is_symbol_char_gen(uint8_t c) { if (c & 0x80) return 1; From 0bd6e85c613d96b120ee8bd5e734416ee04d7563 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Thu, 8 Jun 2023 19:54:01 -0500 Subject: [PATCH 099/138] update changelog --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index c5b1bbb7..06f9105c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,9 @@ All notable changes to this project will be documented in this file. ## ??? - Unreleased +- Allow dictionary types for `take` and `drop` +- Fix bug with closing channels while other fibers were waiting on them - `ev/take`, `ev/give`, and `ev/select` will now return the correct (documented) value when another fiber closes the channel. +- Add `ffi/calling-conventions` to show all available calling conventions for FFI. - Add `net/setsockopt` - Add `signal` argument to `os/proc-kill` to send signals besides `SIGKILL` on Posix. - Add `source` argument to `os/clock` to get different time sources. From 52d3470cbe31d2c9ceb643efea377070db29eaae Mon Sep 17 00:00:00 2001 From: Christopher Chambers Date: Fri, 9 Jun 2023 12:32:14 -0400 Subject: [PATCH 100/138] Fix order in which *macro-lints* is set during expansion Previously, `*macro-lints*` was set after the `macroexpand1` fiber was resumed, rather than just before. And, `*macro-lints*` was never cleared. This behavior was typically fine since the main users of `compile` pass the same lint array repeatedly, and the first macro expansion (somewhere in boot.janet) never produces a lint. But, when compiling with a fresh lint array, if the first macro invocation produced a lint, the lint was always lost. --- src/core/compile.c | 8 +++++--- test/suite-boot.janet | 8 +++++++- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/core/compile.c b/src/core/compile.c index 8ab0e3a2..4f45ff1f 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -746,12 +746,14 @@ static int macroexpand1( int lock = janet_gclock(); Janet mf_kw = janet_ckeywordv("macro-form"); janet_table_put(c->env, mf_kw, x); + Janet ml_kw = janet_ckeywordv("macro-lints"); + if (c->lints) { + janet_table_put(c->env, ml_kw, janet_wrap_array(c->lints)); + } Janet tempOut; JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut); janet_table_put(c->env, mf_kw, janet_wrap_nil()); - if (c->lints) { - janet_table_put(c->env, janet_ckeywordv("macro-lints"), janet_wrap_array(c->lints)); - } + janet_table_put(c->env, ml_kw, janet_wrap_nil()); janet_gcunlock(lock); if (status != JANET_SIGNAL_OK) { const uint8_t *es = janet_formatc("(macro) %V", tempOut); diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 49a022cb..6282a212 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -877,5 +877,11 @@ (assert (= (thunk) 1) "delay 3") (assert (= counter 1) "delay 4") -(end-suite) +# maclintf +(def env (table/clone (curenv))) +((compile '(defmacro foo [] (maclintf :strict "oops")) env :anonymous)) +(def lints @[]) +(compile (tuple/setmap '(foo) 1 2) env :anonymous lints) +(assert (deep= lints @[[:strict 1 2 "oops"]]) "maclintf 1") +(end-suite) From 163f7ee85d6f07af92b6d899a605a5587dd42bd9 Mon Sep 17 00:00:00 2001 From: Christopher Chambers Date: Sat, 10 Jun 2023 16:52:20 -0400 Subject: [PATCH 101/138] Add test for maclintf in nested macro invocations --- test/suite-boot.janet | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 6282a212..af4320b3 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -884,4 +884,15 @@ (compile (tuple/setmap '(foo) 1 2) env :anonymous lints) (assert (deep= lints @[[:strict 1 2 "oops"]]) "maclintf 1") +(def env (table/clone (curenv))) +((compile '(defmacro foo [& body] (maclintf :strict "foo-oops") ~(do ,;body)) env :anonymous)) +((compile '(defmacro bar [] (maclintf :strict "bar-oops")) env :anonymous)) +(def lints @[]) +# Compile (foo (bar)), but with explicit source map values +(def bar-invoke (tuple/setmap '(bar) 3 4)) +(compile (tuple/setmap ~(foo ,bar-invoke) 1 2) env :anonymous lints) +(assert (deep= lints @[[:strict 1 2 "foo-oops"] + [:strict 3 4 "bar-oops"]]) + "maclintf 2") + (end-suite) From 94722e566c6f9bab9b0c8e630b0fd1aed4e10739 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sun, 11 Jun 2023 11:52:23 +0700 Subject: [PATCH 102/138] if-let better test coverage --- test/suite-boot.janet | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 49a022cb..17cdb0d5 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -123,10 +123,12 @@ # Some higher order functions and macros # 5e2de33 (def my-array @[1 2 3 4 5 6]) -(def x (if-let [x (get my-array 5)] x)) -(assert (= x 6) "if-let") -(def x (if-let [y (get @{} :key)] 10 nil)) -(assert (not x) "if-let 2") +(assert (= (if-let [x (get my-array 5)] x) 6) "if-let 1") +(assert (= (if-let [y (get @{} :key)] 10 nil) nil) "if-let 2") +(assert (= (if-let [a my-array k (next a)] :t :f) :t) "if-let 3") +(assert (= (if-let [a my-array k (next a 5)] :t :f) :f) "if-let 4") +(assert (= (if-let [[a b] my-array] a) 1) "if-let 5") +(assert (= (if-let [{:a a :b b} {:a 1 :b 2}] b) 2) "if-let 6") (assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") (def myfun (juxt + - * /)) From 2c3ca2984ec731f9804abee1f6b52031bbbd62a4 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sun, 11 Jun 2023 12:09:58 +0700 Subject: [PATCH 103/138] simplify if-let logic --- src/boot/boot.janet | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 0853ecbf..602c8a2e 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -674,21 +674,7 @@ (do (def bl (in bindings i)) (def br (in bindings (+ 1 i))) - (def atm (idempotent? bl)) - (def sym (if atm bl (gensym))) - (if atm - # Simple binding - (tuple 'do - (tuple 'def sym br) - (tuple 'if sym (aux (+ 2 i)) fal)) - # Destructured binding - (tuple 'do - (tuple 'def sym br) - (tuple 'if sym - (tuple 'do - (tuple 'def bl sym) - (aux (+ 2 i))) - fal)))))) + (tuple 'if (tuple 'def bl br) (aux (+ 2 i)) fal)))) (aux 0)) (defmacro when-let From f9ab91511d42fe817bd409f928e9158ec65f84b9 Mon Sep 17 00:00:00 2001 From: Chloe Kudryavtsev Date: Sun, 11 Jun 2023 10:44:39 +0200 Subject: [PATCH 104/138] peg: add support for "true" and "false" primitives to always/never match The use cases involve user-expandable grammars. For example, consider the IRC nickname specification. > They SHOULD NOT contain any dot character ('.', 0x2E). > Servers MAY have additional implementation-specific nickname restrictions. To implement this, we can do something along these lines: ```janet (def nickname @{:main '(some :allowed) :allowed (! (+ :forbidden/dot :forbidden/user)) # for lax mode, (put nickname :forbidden/dot false) :forbidden/dot "." # to add your own requirements # (put nickname :forbidden/user 'something) :forbidden/user false}) ``` Additionally, it's common in parsing theory to allow matches of the empty string (epsilon). `true` essentially allows for this. Note that this does not strictly add new functionality, you could emulate this previously using `0` and `(! 0)` respectively, but this should be faster and more intuitive. The speed improvement primarily comes from `(! 0)` which is now a single step. --- src/core/peg.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/core/peg.c b/src/core/peg.c index a814e65f..a087ddfa 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -735,6 +735,12 @@ static const uint8_t *peg_getrange(Builder *b, Janet x) { return str; } +static int32_t peg_getboolean(Builder *b, Janet x) { + if (!janet_checktype(x, JANET_BOOLEAN)) + peg_panicf(b, "expected boolean, got %v", x); + return janet_unwrap_boolean(x); +} + static int32_t peg_getinteger(Builder *b, Janet x) { if (!janet_checkint(x)) peg_panicf(b, "expected integer, got %v", x); @@ -1261,6 +1267,13 @@ static uint32_t peg_compile1(Builder *b, Janet peg) { default: peg_panic(b, "unexpected peg source"); return 0; + + case JANET_BOOLEAN: { + int n = peg_getboolean(b, peg); + Reserve r = reserve(b, 2); + emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0); + break; + } case JANET_NUMBER: { int32_t n = peg_getinteger(b, peg); Reserve r = reserve(b, 2); From 1077efd03a9699132735f6c1b543106070a18d24 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sun, 11 Jun 2023 16:38:04 +0700 Subject: [PATCH 105/138] update if-let Fixes #1189 --- src/boot/boot.janet | 6 +++++- test/suite-boot.janet | 2 ++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 602c8a2e..4c158f44 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -674,7 +674,11 @@ (do (def bl (in bindings i)) (def br (in bindings (+ 1 i))) - (tuple 'if (tuple 'def bl br) (aux (+ 2 i)) fal)))) + (if (symbol? bl) + (tuple 'if (tuple 'def bl br) (aux (+ 2 i)) fal) + (tuple 'if (tuple 'def (def sym (gensym)) br) + (tuple 'do (tuple 'def bl sym) (aux (+ 2 i))) + fal))))) (aux 0)) (defmacro when-let diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 17cdb0d5..18a3074c 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -129,6 +129,8 @@ (assert (= (if-let [a my-array k (next a 5)] :t :f) :f) "if-let 4") (assert (= (if-let [[a b] my-array] a) 1) "if-let 5") (assert (= (if-let [{:a a :b b} {:a 1 :b 2}] b) 2) "if-let 6") +(assert (= (if-let [[a b] nil] :t :f) :f) "if-let 7") +(assert (= (if-let [a true b false] b a) true) "if-let 8") (assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") (def myfun (juxt + - * /)) From e54ea7a1d8ffeb03a81d96461dd152e744d4f884 Mon Sep 17 00:00:00 2001 From: Chloe Kudryavtsev Date: Sun, 11 Jun 2023 12:38:40 +0200 Subject: [PATCH 106/138] fixup! peg: add support for "true" and "false" primitives to always/never match --- src/core/peg.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/core/peg.c b/src/core/peg.c index a087ddfa..fa7aef20 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -736,9 +736,9 @@ static const uint8_t *peg_getrange(Builder *b, Janet x) { } static int32_t peg_getboolean(Builder *b, Janet x) { - if (!janet_checktype(x, JANET_BOOLEAN)) - peg_panicf(b, "expected boolean, got %v", x); - return janet_unwrap_boolean(x); + if (!janet_checktype(x, JANET_BOOLEAN)) + peg_panicf(b, "expected boolean, got %v", x); + return janet_unwrap_boolean(x); } static int32_t peg_getinteger(Builder *b, Janet x) { @@ -1268,12 +1268,12 @@ static uint32_t peg_compile1(Builder *b, Janet peg) { peg_panic(b, "unexpected peg source"); return 0; - case JANET_BOOLEAN: { - int n = peg_getboolean(b, peg); - Reserve r = reserve(b, 2); - emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0); - break; - } + case JANET_BOOLEAN: { + int n = peg_getboolean(b, peg); + Reserve r = reserve(b, 2); + emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0); + break; + } case JANET_NUMBER: { int32_t n = peg_getinteger(b, peg); Reserve r = reserve(b, 2); From 32c5b816ae888c346a3525cc2729950d26831a02 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sun, 11 Jun 2023 18:38:20 +0700 Subject: [PATCH 107/138] use unquotes instead --- src/boot/boot.janet | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 4c158f44..43699aa6 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -675,10 +675,10 @@ (def bl (in bindings i)) (def br (in bindings (+ 1 i))) (if (symbol? bl) - (tuple 'if (tuple 'def bl br) (aux (+ 2 i)) fal) - (tuple 'if (tuple 'def (def sym (gensym)) br) - (tuple 'do (tuple 'def bl sym) (aux (+ 2 i))) - fal))))) + ~(if (def ,bl ,br) ,(aux (+ 2 i)) ,fal) + ~(if (def ,(def sym (gensym)) ,br) + (do (def ,bl ,sym) ,(aux (+ 2 i))) + ,fal))))) (aux 0)) (defmacro when-let From 2a7ea27bb73e5fb2285cab5eee53bf4b9e118140 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sun, 11 Jun 2023 19:15:48 +0700 Subject: [PATCH 108/138] do not expand false branch more than once Fixes #1191 --- src/boot/boot.janet | 12 +++++++----- test/suite-boot.janet | 7 ++++++- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 43699aa6..c6c1ff27 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -668,18 +668,20 @@ (def len (length bindings)) (if (= 0 len) (error "expected at least 1 binding")) (if (odd? len) (error "expected an even number of bindings")) + (def res (gensym)) (defn aux [i] (if (>= i len) - tru + ~(do (set ,res ,tru) true) (do (def bl (in bindings i)) (def br (in bindings (+ 1 i))) (if (symbol? bl) - ~(if (def ,bl ,br) ,(aux (+ 2 i)) ,fal) + ~(if (def ,bl ,br) ,(aux (+ 2 i))) ~(if (def ,(def sym (gensym)) ,br) - (do (def ,bl ,sym) ,(aux (+ 2 i))) - ,fal))))) - (aux 0)) + (do (def ,bl ,sym) ,(aux (+ 2 i)))))))) + ~(do + (var ,res nil) + (if ,(aux 0) ,res ,fal))) (defmacro when-let "Same as `(if-let bindings (do ;body))`." diff --git a/test/suite-boot.janet b/test/suite-boot.janet index 18a3074c..77a2bc92 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -130,7 +130,12 @@ (assert (= (if-let [[a b] my-array] a) 1) "if-let 5") (assert (= (if-let [{:a a :b b} {:a 1 :b 2}] b) 2) "if-let 6") (assert (= (if-let [[a b] nil] :t :f) :f) "if-let 7") -(assert (= (if-let [a true b false] b a) true) "if-let 8") + +# #1191 +(var cnt 0) +(defmacro upcnt [] (++ cnt)) +(assert (= (if-let [a true b true c true] nil (upcnt)) nil) "issue #1191") +(assert (= cnt 1) "issue #1191") (assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") (def myfun (juxt + - * /)) From 2fde34b51915f27e849195d111ffc55a94747e78 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 18 Jun 2023 09:41:53 -0500 Subject: [PATCH 109/138] Remove extra function call that cannot ever trigger. --- src/core/peg.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/core/peg.c b/src/core/peg.c index fa7aef20..11504cda 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -735,12 +735,6 @@ static const uint8_t *peg_getrange(Builder *b, Janet x) { return str; } -static int32_t peg_getboolean(Builder *b, Janet x) { - if (!janet_checktype(x, JANET_BOOLEAN)) - peg_panicf(b, "expected boolean, got %v", x); - return janet_unwrap_boolean(x); -} - static int32_t peg_getinteger(Builder *b, Janet x) { if (!janet_checkint(x)) peg_panicf(b, "expected integer, got %v", x); @@ -1269,7 +1263,7 @@ static uint32_t peg_compile1(Builder *b, Janet peg) { return 0; case JANET_BOOLEAN: { - int n = peg_getboolean(b, peg); + int n = janet_unwrap_boolean(peg); Reserve r = reserve(b, 2); emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0); break; From 5a39a04a79cfb3b64b79462819340a4168e357dc Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 19 Jun 2023 06:48:33 -0500 Subject: [PATCH 110/138] Prepare for 1.29.0 release. --- CHANGELOG.md | 3 ++- Makefile | 4 ++-- src/conf/janetconf.h | 6 +++--- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 06f9105c..b2c7bbce 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,8 @@ # Changelog All notable changes to this project will be documented in this file. -## ??? - Unreleased +## 1.29.0 - 2023-06-19 +- Add support for passing booleans to PEGs for "always" and "never" matching. - Allow dictionary types for `take` and `drop` - Fix bug with closing channels while other fibers were waiting on them - `ev/take`, `ev/give`, and `ev/select` will now return the correct (documented) value when another fiber closes the channel. - Add `ffi/calling-conventions` to show all available calling conventions for FFI. diff --git a/Makefile b/Makefile index 404f76f2..85b2a7ba 100644 --- a/Makefile +++ b/Makefile @@ -195,9 +195,9 @@ build/%.bin.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile ######################## ifeq ($(UNAME), Darwin) -SONAME=libjanet.1.28.dylib +SONAME=libjanet.1.29.dylib else -SONAME=libjanet.so.1.28 +SONAME=libjanet.so.1.29 endif build/c/shell.c: src/mainclient/shell.c diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 73e39d55..be917286 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -4,10 +4,10 @@ #define JANETCONF_H #define JANET_VERSION_MAJOR 1 -#define JANET_VERSION_MINOR 28 +#define JANET_VERSION_MINOR 29 #define JANET_VERSION_PATCH 0 -#define JANET_VERSION_EXTRA "-dev" -#define JANET_VERSION "1.28.0-dev" +#define JANET_VERSION_EXTRA "" +#define JANET_VERSION "1.29.0" /* #define JANET_BUILD "local" */ From 63bb93fc0788d6edc09af7549d8251ad763ec7ae Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 19 Jun 2023 07:14:56 -0500 Subject: [PATCH 111/138] Fix isatty code to not use functions only defined if ev is enabled. --- src/core/os.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index e4ec5cd6..70f0449c 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1437,11 +1437,11 @@ JANET_CORE_FN(os_isatty, FILE *f = (argc == 1) ? janet_getfile(argv, 0, NULL) : stdout; #ifdef JANET_WINDOWS int fd = _fileno(f); - if (fd == -1) janet_panicv(janet_ev_lasterr()); + if (fd == -1) janet_panic("not a valid stream"); return janet_wrap_boolean(_isatty(fd)); #else int fd = fileno(f); - if (fd == -1) janet_panicv(janet_ev_lasterr()); + if (fd == -1) janet_panic(strerror(errno)); return janet_wrap_boolean(isatty(fd)); #endif } From 3a4d56afca2eee0e4dbca9a6400757d198e6d6f3 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Mon, 19 Jun 2023 07:18:35 -0500 Subject: [PATCH 112/138] Patch release. --- CHANGELOG.md | 2 +- meson.build | 2 +- src/conf/janetconf.h | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b2c7bbce..7ccc67c8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,7 @@ # Changelog All notable changes to this project will be documented in this file. -## 1.29.0 - 2023-06-19 +## 1.29.1 - 2023-06-19 - Add support for passing booleans to PEGs for "always" and "never" matching. - Allow dictionary types for `take` and `drop` - Fix bug with closing channels while other fibers were waiting on them - `ev/take`, `ev/give`, and `ev/select` will now return the correct (documented) value when another fiber closes the channel. diff --git a/meson.build b/meson.build index 4b75e0b7..f0bcd709 100644 --- a/meson.build +++ b/meson.build @@ -20,7 +20,7 @@ project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], - version : '1.28.0') + version : '1.29.1') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index be917286..d4786eb3 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -5,9 +5,9 @@ #define JANET_VERSION_MAJOR 1 #define JANET_VERSION_MINOR 29 -#define JANET_VERSION_PATCH 0 +#define JANET_VERSION_PATCH 1 #define JANET_VERSION_EXTRA "" -#define JANET_VERSION "1.29.0" +#define JANET_VERSION "1.29.1" /* #define JANET_BUILD "local" */ From 78eed9b11c6b48f21e60b1d1ef169b69478a5cfb Mon Sep 17 00:00:00 2001 From: sogaiu <983021772@users.noreply.github.com> Date: Thu, 22 Jun 2023 17:23:07 +0900 Subject: [PATCH 113/138] Use vm_commit --- src/core/vm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/vm.c b/src/core/vm.c index 444f8d79..ab73499d 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -980,7 +980,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { if (func->gc.flags & JANET_FUNCFLAG_TRACE) { vm_do_trace(func, fiber->stacktop - fiber->stackstart, fiber->data + fiber->stackstart); } - janet_stack_frame(stack)->pc = pc; + vm_commit(); if (janet_fiber_funcframe(fiber, func)) { int32_t n = fiber->stacktop - fiber->stackstart; janet_panicf("%v called with %d argument%s, expected %d", From f977ace7f8c75f698e468cd4f5add09082dcdaf8 Mon Sep 17 00:00:00 2001 From: Michael Camilleri Date: Fri, 23 Jun 2023 15:50:19 +0900 Subject: [PATCH 114/138] Avoid prematurely closing file descriptors when redirecting IO --- src/core/os.c | 6 ++++-- test/suite-os.janet | 17 ++++++++++++++--- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/src/core/os.c b/src/core/os.c index 70f0449c..65afdce9 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1145,14 +1145,16 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) { posix_spawn_file_actions_addclose(&actions, pipe_in); } else if (new_in != JANET_HANDLE_NONE && new_in != 0) { posix_spawn_file_actions_adddup2(&actions, new_in, 0); - posix_spawn_file_actions_addclose(&actions, new_in); + if (new_in != new_out && new_in != new_err) + posix_spawn_file_actions_addclose(&actions, new_in); } if (pipe_out != JANET_HANDLE_NONE) { posix_spawn_file_actions_adddup2(&actions, pipe_out, 1); posix_spawn_file_actions_addclose(&actions, pipe_out); } else if (new_out != JANET_HANDLE_NONE && new_out != 1) { posix_spawn_file_actions_adddup2(&actions, new_out, 1); - posix_spawn_file_actions_addclose(&actions, new_out); + if (new_out != new_err) + posix_spawn_file_actions_addclose(&actions, new_out); } if (pipe_err != JANET_HANDLE_NONE) { posix_spawn_file_actions_adddup2(&actions, pipe_err, 2); diff --git a/test/suite-os.janet b/test/suite-os.janet index f88c997d..1af75674 100644 --- a/test/suite-os.janet +++ b/test/suite-os.janet @@ -94,9 +94,9 @@ (assert (= (length buf) 2) "cryptorand appends to buffer")) # 80db68210 -(assert-no-error (os/clock :realtime) "realtime clock") -(assert-no-error (os/clock :cputime) "cputime clock") -(assert-no-error (os/clock :monotonic) "monotonic clock") +(assert-no-error "realtime clock" (os/clock :realtime)) +(assert-no-error "cputime clock" (os/clock :cputime)) +(assert-no-error "monotonic clock" (os/clock :monotonic)) (def before (os/clock :monotonic)) (def after (os/clock :monotonic)) @@ -129,5 +129,16 @@ (string/format "(os/exit %d)" i)] :p)) (string "os/execute " i))) +# os/execute IO redirection +(assert-no-error "IO redirection" + (defn devnull [] + (def os (os/which)) + (def path (if (or (= os :mingw) (= os :windows)) + "NUL" + "/dev/null")) + (os/open path :w)) + (with [dn (devnull)] + (os/execute ["ls"] :px {:out dn :err dn}))) + (end-suite) From 1ccd8799166f65f3a87407d440c33bcda3f9149d Mon Sep 17 00:00:00 2001 From: Michael Camilleri Date: Sat, 24 Jun 2023 10:56:47 +0900 Subject: [PATCH 115/138] Make test cross-platform --- test/suite-os.janet | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test/suite-os.janet b/test/suite-os.janet index 1af75674..881f24cf 100644 --- a/test/suite-os.janet +++ b/test/suite-os.janet @@ -138,7 +138,11 @@ "/dev/null")) (os/open path :w)) (with [dn (devnull)] - (os/execute ["ls"] :px {:out dn :err dn}))) + (os/execute [(dyn :executable) + "-e" + "(print :foo) (eprint :bar)"] + :px + {:out dn :err dn}))) (end-suite) From ff90b81ec3c0e79ce13bf616c5362d9c14d0f09e Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 24 Jun 2023 10:38:35 -0500 Subject: [PATCH 116/138] Add some utilitites for dealing with unsigned integers in janet.h --- src/core/capi.c | 10 +++++++++- src/core/util.c | 9 ++++++++- src/core/vm.c | 8 ++++---- src/include/janet.h | 3 +++ 4 files changed, 24 insertions(+), 6 deletions(-) diff --git a/src/core/capi.c b/src/core/capi.c index 6984d3ad..c1109c5f 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -273,6 +273,14 @@ int32_t janet_getinteger(const Janet *argv, int32_t n) { return janet_unwrap_integer(x); } +uint32_t janet_getuinteger(const Janet *argv, int32_t n) { + Janet x = argv[n]; + if (!janet_checkuint(x)) { + janet_panicf("bad slot #%d, expected 32 bit signed integer, got %v", n, x); + } + return janet_unwrap_integer(x); +} + int64_t janet_getinteger64(const Janet *argv, int32_t n) { #ifdef JANET_INT_TYPES return janet_unwrap_s64(argv[n]); @@ -290,7 +298,7 @@ uint64_t janet_getuinteger64(const Janet *argv, int32_t n) { return janet_unwrap_u64(argv[n]); #else Janet x = argv[n]; - if (!janet_checkint64(x)) { + if (!janet_checkuint64(x)) { janet_panicf("bad slot #%d, expected 64 bit unsigned integer, got %v", n, x); } return (uint64_t) janet_unwrap_number(x); diff --git a/src/core/util.c b/src/core/util.c index c0e3e564..2dfd11e3 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -805,6 +805,13 @@ int janet_checkint(Janet x) { return janet_checkintrange(dval); } +int janet_checkuint(Janet x) { + if (!janet_checktype(x, JANET_NUMBER)) + return 0; + double dval = janet_unwrap_number(x); + return janet_checkuintrange(dval); +} + int janet_checkint64(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; @@ -816,7 +823,7 @@ int janet_checkuint64(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); - return dval >= 0 && dval <= JANET_INTMAX_DOUBLE && dval == (uint64_t) dval; + return janet_checkuint64range(dval); } int janet_checksize(Janet x) { diff --git a/src/core/vm.c b/src/core/vm.c index ab73499d..dd8b7e57 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -147,8 +147,8 @@ stack[A] = janet_mcall(#op, 2, _argv);\ vm_checkgc_pcnext();\ } else {\ - type1 x1 = (type1) janet_unwrap_integer(op1);\ - stack[A] = janet_wrap_integer(x1 op CS);\ + type1 x1 = (type1) janet_unwrap_number(op1);\ + stack[A] = janet_wrap_number((type1) (x1 op CS));\ vm_pcnext();\ }\ } @@ -175,9 +175,9 @@ Janet op1 = stack[B];\ Janet op2 = stack[C];\ if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\ - type1 x1 = (type1) janet_unwrap_integer(op1);\ + type1 x1 = (type1) janet_unwrap_number(op1);\ int32_t x2 = janet_unwrap_integer(op2);\ - stack[A] = janet_wrap_integer(x1 op x2);\ + stack[A] = janet_wrap_number((type1) (x1 op x2));\ vm_pcnext();\ } else {\ vm_commit();\ diff --git a/src/include/janet.h b/src/include/janet.h index 509b194e..3f6b8982 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -868,12 +868,15 @@ JANET_API Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer); #endif JANET_API int janet_checkint(Janet x); +JANET_API int janet_checkuint(Janet x); JANET_API int janet_checkint64(Janet x); JANET_API int janet_checkuint64(Janet x); JANET_API int janet_checksize(Janet x); JANET_API JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at); #define janet_checkintrange(x) ((x) >= INT32_MIN && (x) <= INT32_MAX && (x) == (int32_t)(x)) +#define janet_checkuintrange(x) ((x) >= 0 && (x) <= UINT32_MAX && (x) == (uint32_t)(x)) #define janet_checkint64range(x) ((x) >= JANET_INTMIN_DOUBLE && (x) <= JANET_INTMAX_DOUBLE && (x) == (int64_t)(x)) +#define janet_checkuint64range(x) ((x) >= 0 && (x) <= JANET_INTMAX_DOUBLE && (x) == (uint64_t)(x)) #define janet_unwrap_integer(x) ((int32_t) janet_unwrap_number(x)) #define janet_wrap_integer(x) janet_wrap_number((int32_t)(x)) From b219b146fae97fabdeac87b3c195858d3b0ffb0e Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 24 Jun 2023 12:13:51 -0500 Subject: [PATCH 117/138] Squashed commit of the following: commit fbb0711ae1bb8bf1cc3738c46682b96938c50f78 Author: Calvin Rose Date: Sat Jun 24 12:07:55 2023 -0500 Distinguish between subprocess when testing. commit 676b233566fa8fdb90af9ff801c29d7b4703c255 Author: Calvin Rose Date: Sat Jun 24 11:59:17 2023 -0500 Hack for qemu based testing (also should work with valgrind) commit d7431c7cdbf0509ebe3e42888189dfe3cf6c7910 Author: Calvin Rose Date: Sat Jun 24 11:54:04 2023 -0500 Revert "Test removing 32bit ptr marshalling." This reverts commit 566b45ea443d1d1c9b0bc6c345c4c33b3e07ed0e. commit 566b45ea443d1d1c9b0bc6c345c4c33b3e07ed0e Author: Calvin Rose Date: Sat Jun 24 11:52:22 2023 -0500 Test removing 32bit ptr marshalling. commit ff2f71d2bca868206bee1923dcc8cd3ae5ec066e Author: Calvin Rose Date: Sat Jun 24 11:42:10 2023 -0500 Conditionally compile marshal_ptr code. commit bd420aeb0e51b4905fb7976fc379943cb55dc777 Author: Calvin Rose Date: Sat Jun 24 11:38:34 2023 -0500 Add range checking to bit-shift code to prevent undefined behavior. commit b738319f8d4037dba639da1a310b52a441e4ba34 Author: Calvin Rose Date: Sat Jun 24 11:17:30 2023 -0500 Remove range check on 32 bit arch since it will always pass. commit 72486262357aef3a5eaa4652e6288328c381ea7f Author: Calvin Rose Date: Sat Jun 24 10:56:45 2023 -0500 Quiet some build warnings. commit 141c1de946ff8376de6ecff3534e875fff047928 Author: Calvin Rose Date: Sat Jun 24 10:50:13 2023 -0500 Add marshal utilities for pointers. commit c2d77d67207b1d4e71cab47a3b12ac27f801e72c Merge: 677b8a6f ff90b81e Author: Calvin Rose Date: Sat Jun 24 10:40:35 2023 -0500 Merge branch 'master' into armtest commit 677b8a6f320e9170ea047fea9af74602881c4659 Author: Ico Doornekamp Date: Mon Jun 12 21:01:26 2023 +0200 Added ARM32 test --- .github/workflows/test.yml | 15 +++++++++++++++ src/core/ev.c | 4 ++-- src/core/marsh.c | 18 ++++++++++++++++++ src/core/specials.c | 3 ++- src/core/value.c | 9 +++++++-- src/core/vm.c | 24 +++++++++++++++--------- src/include/janet.h | 2 ++ test/suite-corelib.janet | 6 ++++-- test/suite-ev.janet | 27 +++++++++++++++------------ test/suite-os.janet | 9 ++++++--- 10 files changed, 86 insertions(+), 31 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c620c513..2f5cb19c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -74,3 +74,18 @@ jobs: run: make clean && make CC=x86_64-w64-mingw32-gcc LD=x86_64-w64-mingw32-gcc UNAME=MINGW RUN=wine - name: Test the project run: make test UNAME=MINGW RUN=wine + + test-arm-linux: + name: Build and test ARM32 cross compilation + runs-on: ubuntu-latest + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Setup qemu and cross compiler + run: | + sudo apt-get update + sudo apt-get install gcc-arm-linux-gnueabi qemu-user + - name: Compile the project + run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" CC=arm-linux-gnueabi-gcc LD=arm-linux-gnueabi-gcc + - name: Test the project + run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" SUBRUN="qemu-arm -L /usr/arm-linux-gnueabi/" test diff --git a/src/core/ev.c b/src/core/ev.c index 28585d9f..17fe442e 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -401,7 +401,7 @@ static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) { } janet_marshal_abstract(ctx, p); janet_marshal_int(ctx, (int32_t) s->flags); - janet_marshal_int64(ctx, (intptr_t) s->methods); + janet_marshal_ptr(ctx, s->methods); #ifdef JANET_WINDOWS /* TODO - ref counting to avoid situation where a handle is closed or GCed * while in transit, and it's value gets reused. DuplicateHandle does not work @@ -438,7 +438,7 @@ static void *janet_stream_unmarshal(JanetMarshalContext *ctx) { p->_mask = 0; p->state = NULL; p->flags = (uint32_t) janet_unmarshal_int(ctx); - p->methods = (void *) janet_unmarshal_int64(ctx); + p->methods = janet_unmarshal_ptr(ctx); #ifdef JANET_WINDOWS p->handle = (JanetHandle) janet_unmarshal_int64(ctx); #else diff --git a/src/core/marsh.c b/src/core/marsh.c index becab902..b4dae0ba 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -362,6 +362,15 @@ void janet_marshal_int(JanetMarshalContext *ctx, int32_t value) { pushint(st, value); } +/* Only use in unsafe - don't marshal pointers otherwise */ +void janet_marshal_ptr(JanetMarshalContext *ctx, const void *ptr) { +#ifdef JANET_32 + janet_marshal_int(ctx, (intptr_t) ptr); +#else + janet_marshal_int64(ctx, (intptr_t) ptr); +#endif +} + void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value) { MarshalState *st = (MarshalState *)(ctx->m_state); pushbyte(st, value); @@ -1165,6 +1174,15 @@ int64_t janet_unmarshal_int64(JanetMarshalContext *ctx) { return read64(st, &(ctx->data)); } +void *janet_unmarshal_ptr(JanetMarshalContext *ctx) { + UnmarshalState *st = (UnmarshalState *)(ctx->u_state); +#ifdef JANET_32 + return (void *) ((intptr_t) readint(st, &(ctx->data))); +#else + return (void *) ((intptr_t) read64(st, &(ctx->data))); +#endif +} + uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); MARSH_EOS(st, ctx->data); diff --git a/src/core/specials.c b/src/core/specials.c index 4f2b9740..d4da602e 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -357,7 +357,8 @@ SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopt if (has_drop && can_destructure_lhs && rhs_is_indexed) { /* Code is of the form (def [a b] [1 2]), avoid the allocation of two tuples */ - JanetView view_lhs, view_rhs; + JanetView view_lhs = {0}; + JanetView view_rhs = {0}; janet_indexed_view(lhs, &view_lhs.items, &view_lhs.len); janet_indexed_view(rhs, &view_rhs.items, &view_rhs.len); int found_amp = 0; diff --git a/src/core/value.c b/src/core/value.c index 37ca4041..3a071cda 100644 --- a/src/core/value.c +++ b/src/core/value.c @@ -698,11 +698,16 @@ Janet janet_lengthv(Janet x) { const JanetAbstractType *type = janet_abstract_type(abst); if (type->length != NULL) { size_t len = type->length(abst, janet_abstract_size(abst)); - if ((uint64_t) len <= (uint64_t) JANET_INTMAX_INT64) { - return janet_wrap_number((double) len); + /* If len is always less then double, we can never overflow */ +#ifdef JANET_32 + return janet_wrap_number(len); +#else + if (len < (size_t) JANET_INTMAX_INT64) { + return janet_wrap_number(len); } else { janet_panicf("integer length %u too large", len); } +#endif } Janet argv[1] = { x }; return janet_mcall("length", 1, argv); diff --git a/src/core/vm.c b/src/core/vm.c index dd8b7e57..12f990c9 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -138,7 +138,7 @@ vm_pcnext();\ }\ } -#define _vm_bitop_immediate(op, type1)\ +#define _vm_bitop_immediate(op, type1, rangecheck, msg)\ {\ Janet op1 = stack[B];\ if (!janet_checktype(op1, JANET_NUMBER)) {\ @@ -147,13 +147,15 @@ stack[A] = janet_mcall(#op, 2, _argv);\ vm_checkgc_pcnext();\ } else {\ - type1 x1 = (type1) janet_unwrap_number(op1);\ + double y1 = janet_unwrap_number(op1);\ + if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\ + type1 x1 = (type1) y1;\ stack[A] = janet_wrap_number((type1) (x1 op CS));\ vm_pcnext();\ }\ } -#define vm_bitop_immediate(op) _vm_bitop_immediate(op, int32_t); -#define vm_bitopu_immediate(op) _vm_bitop_immediate(op, uint32_t); +#define vm_bitop_immediate(op) _vm_bitop_immediate(op, int32_t, janet_checkintrange, "32-bit signed integers"); +#define vm_bitopu_immediate(op) _vm_bitop_immediate(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers"); #define _vm_binop(op, wrap)\ {\ Janet op1 = stack[B];\ @@ -170,13 +172,17 @@ }\ } #define vm_binop(op) _vm_binop(op, janet_wrap_number) -#define _vm_bitop(op, type1)\ +#define _vm_bitop(op, type1, rangecheck, msg)\ {\ Janet op1 = stack[B];\ Janet op2 = stack[C];\ if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\ - type1 x1 = (type1) janet_unwrap_number(op1);\ - int32_t x2 = janet_unwrap_integer(op2);\ + double y1 = janet_unwrap_number(op1);\ + double y2 = janet_unwrap_number(op2);\ + if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\ + if (!janet_checkintrange(y2)) { vm_commit(); janet_panicf("rhs must be valid 32-bit signed integer, got %f", op2); }\ + type1 x1 = (type1) y1;\ + int32_t x2 = (int32_t) y2;\ stack[A] = janet_wrap_number((type1) (x1 op x2));\ vm_pcnext();\ } else {\ @@ -185,8 +191,8 @@ vm_checkgc_pcnext();\ }\ } -#define vm_bitop(op) _vm_bitop(op, int32_t) -#define vm_bitopu(op) _vm_bitop(op, uint32_t) +#define vm_bitop(op) _vm_bitop(op, int32_t, janet_checkintrange, "32-bit signed integers") +#define vm_bitopu(op) _vm_bitop(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers") #define vm_compop(op) \ {\ Janet op1 = stack[B];\ diff --git a/src/include/janet.h b/src/include/janet.h index 3f6b8982..34cfa06a 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -2053,6 +2053,7 @@ JANET_API int janet_cryptorand(uint8_t *out, size_t n); JANET_API void janet_marshal_size(JanetMarshalContext *ctx, size_t value); JANET_API void janet_marshal_int(JanetMarshalContext *ctx, int32_t value); JANET_API void janet_marshal_int64(JanetMarshalContext *ctx, int64_t value); +JANET_API void janet_marshal_ptr(JanetMarshalContext *ctx, const void *value); JANET_API void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value); JANET_API void janet_marshal_bytes(JanetMarshalContext *ctx, const uint8_t *bytes, size_t len); JANET_API void janet_marshal_janet(JanetMarshalContext *ctx, Janet x); @@ -2062,6 +2063,7 @@ JANET_API void janet_unmarshal_ensure(JanetMarshalContext *ctx, size_t size); JANET_API size_t janet_unmarshal_size(JanetMarshalContext *ctx); JANET_API int32_t janet_unmarshal_int(JanetMarshalContext *ctx); JANET_API int64_t janet_unmarshal_int64(JanetMarshalContext *ctx); +JANET_API void *janet_unmarshal_ptr(JanetMarshalContext *ctx); JANET_API uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx); JANET_API void janet_unmarshal_bytes(JanetMarshalContext *ctx, uint8_t *dest, size_t len); JANET_API Janet janet_unmarshal_janet(JanetMarshalContext *ctx); diff --git a/test/suite-corelib.janet b/test/suite-corelib.janet index 165207d5..8f590658 100644 --- a/test/suite-corelib.janet +++ b/test/suite-corelib.janet @@ -30,10 +30,12 @@ (assert (= 1 (brshift 4 2)) "right shift") # unsigned shift (assert (= 32768 (brushift 0x80000000 16)) "right shift unsigned 1") -(assert (= -32768 (brshift 0x80000000 16)) "right shift unsigned 2") +(assert-error "right shift unsigned 2" (= -32768 (brshift 0x80000000 16))) +(assert (= -1 (brshift -1 16)) "right shift unsigned 3") # non-immediate forms (assert (= 32768 (brushift 0x80000000 (+ 0 16))) "right shift unsigned non-immediate") -(assert (= -32768 (brshift 0x80000000 (+ 0 16))) "right shift non-immediate") +(assert-error "right shift non-immediate" (= -32768 (brshift 0x80000000 (+ 0 16)))) +(assert (= -1 (brshift -1 (+ 0 16))) "right shift non-immediate 2") (assert (= 32768 (blshift 1 (+ 0 15))) "left shift non-immediate") # 7e46ead (assert (< 1 2 3 4 5 6) "less than integers") diff --git a/test/suite-ev.janet b/test/suite-ev.janet index 184743d1..ccecdf4e 100644 --- a/test/suite-ev.janet +++ b/test/suite-ev.janet @@ -25,38 +25,41 @@ # 5e1a8c86f (def janet (dyn :executable)) +# Subprocess should inherit the "RUN" parameter for fancy testing +(def run (filter next (string/split " " (os/getenv "SUBRUN" "")))) + (repeat 10 - (let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})] + (let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})] (os/proc-wait p) (def x (:read (p :out) :all)) (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn pre close.")) - (let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})] + (let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})] (def x (:read (p :out) 1024)) (os/proc-wait p) (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn post close.")) - (let [p (os/spawn [janet "-e" `(file/read stdin :line)`] :px + (let [p (os/spawn [;run janet "-e" `(file/read stdin :line)`] :px {:in :pipe})] (:write (p :in) "hello!\n") (assert-no-error "pipe stdin to process" (os/proc-wait p)))) -(let [p (os/spawn [janet "-e" `(print (file/read stdin :line))`] :px +(let [p (os/spawn [;run janet "-e" `(print (file/read stdin :line))`] :px {:in :pipe :out :pipe})] (:write (p :in) "hello!\n") (def x (:read (p :out) 1024)) (assert-no-error "pipe stdin to process 2" (os/proc-wait p)) (assert (= "hello!" (string/trim x)) "round trip pipeline in process")) -(let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] +(let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] (os/proc-kill p) (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) -(let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] +(let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] (os/proc-kill p false :term) (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) @@ -66,7 +69,7 @@ (defn calc-1 "Run subprocess, read from stdout, then wait on subprocess." [code] - (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px + (let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] (os/proc-wait p) (def output (:read (p :out) :all)) @@ -86,7 +89,7 @@ to 10 bytes instead of :all `` [code] - (let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px + (let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] (def output (:read (p :out) 10)) (os/proc-wait p) @@ -104,18 +107,18 @@ # a1cc5ca04 (assert-no-error "file writing 1" (with [f (file/temp)] - (os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f}))) + (os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f}))) (assert-no-error "file writing 2" (with [f (file/open "unique.txt" :w)] - (os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f}) + (os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f}) (file/flush f))) # Issue #593 # a1cc5ca04 (assert-no-error "file writing 3" (def outfile (file/open "unique.txt" :w)) - (os/execute [janet "-e" "(pp (seq [i :range (1 10)] i))"] :p + (os/execute [;run janet "-e" "(pp (seq [i :range (1 10)] i))"] :p {:out outfile}) (file/flush outfile) (file/close outfile) @@ -256,7 +259,7 @@ (ev/cancel fiber "boop") # f0dbc2e -(assert (os/execute [janet "-e" `(+ 1 2 3)`] :xp) "os/execute self") +(assert (os/execute [;run janet "-e" `(+ 1 2 3)`] :xp) "os/execute self") # Test some channel # e76b8da26 diff --git a/test/suite-os.janet b/test/suite-os.janet index 881f24cf..e9bd465e 100644 --- a/test/suite-os.janet +++ b/test/suite-os.janet @@ -21,6 +21,9 @@ (import ./helper :prefix "" :exit true) (start-suite) +(def janet (dyn :executable)) +(def run (filter next (string/split " " (os/getenv "SUBRUN" "")))) + # OS Date test # 719f7ba0c (assert (deep= {:year-day 0 @@ -118,14 +121,14 @@ # os/execute with environment variables # issue #636 - 7e2c433ab -(assert (= 0 (os/execute [(dyn :executable) "-e" "(+ 1 2 3)"] :pe +(assert (= 0 (os/execute [;run janet "-e" "(+ 1 2 3)"] :pe (merge (os/environ) {"HELLO" "WORLD"}))) "os/execute with env") # os/execute regressions # 427f7c362 (for i 0 10 - (assert (= i (os/execute [(dyn :executable) "-e" + (assert (= i (os/execute [;run janet "-e" (string/format "(os/exit %d)" i)] :p)) (string "os/execute " i))) @@ -138,7 +141,7 @@ "/dev/null")) (os/open path :w)) (with [dn (devnull)] - (os/execute [(dyn :executable) + (os/execute [;run janet "-e" "(print :foo) (eprint :bar)"] :px From d63379e7777b1269ad4e8e075c971503b1732c30 Mon Sep 17 00:00:00 2001 From: Dmitry Date: Sun, 25 Jun 2023 19:29:39 +0400 Subject: [PATCH 118/138] Add parser escape sequences --- src/core/parse.c | 8 ++++++++ src/core/pp.c | 6 ++++++ 2 files changed, 14 insertions(+) diff --git a/src/core/parse.c b/src/core/parse.c index 8358a996..40ccfbf2 100644 --- a/src/core/parse.c +++ b/src/core/parse.c @@ -259,6 +259,14 @@ static int checkescape(uint8_t c) { return '\f'; case 'v': return '\v'; + case 'a': + return '\a'; + case 'b': + return '\b'; + case '\'': + return '\''; + case '?': + return '?'; case 'e': return 27; case '"': diff --git a/src/core/pp.c b/src/core/pp.c index 7f20a48a..9c897a0b 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -152,6 +152,12 @@ static void janet_escape_string_impl(JanetBuffer *buffer, const uint8_t *str, in case '\v': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\v", 2); break; + case '\a': + janet_buffer_push_bytes(buffer, (const uint8_t *)"\\a", 2); + break; + case '\b': + janet_buffer_push_bytes(buffer, (const uint8_t *)"\\b", 2); + break; case 27: janet_buffer_push_bytes(buffer, (const uint8_t *)"\\e", 2); break; From 4b7b285aa9eb57a23c9a29b377f90d95151f639b Mon Sep 17 00:00:00 2001 From: bakpakin Date: Sun, 25 Jun 2023 17:26:36 -0500 Subject: [PATCH 119/138] Remove MSVC compiler warning. --- Makefile | 2 +- src/core/value.c | 2 +- tools/format.sh | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) mode change 100755 => 100644 tools/format.sh diff --git a/Makefile b/Makefile index 85b2a7ba..a0e8e819 100644 --- a/Makefile +++ b/Makefile @@ -357,7 +357,7 @@ uninstall: ################# format: - tools/format.sh + sh tools/format.sh grammar: build/janet.tmLanguage build/janet.tmLanguage: tools/tm_lang_gen.janet $(JANET_TARGET) diff --git a/src/core/value.c b/src/core/value.c index 3a071cda..ed66ee11 100644 --- a/src/core/value.c +++ b/src/core/value.c @@ -703,7 +703,7 @@ Janet janet_lengthv(Janet x) { return janet_wrap_number(len); #else if (len < (size_t) JANET_INTMAX_INT64) { - return janet_wrap_number(len); + return janet_wrap_number((double) len); } else { janet_panicf("integer length %u too large", len); } diff --git a/tools/format.sh b/tools/format.sh old mode 100755 new mode 100644 index 37e03f26..57c568cd --- a/tools/format.sh +++ b/tools/format.sh @@ -1,4 +1,4 @@ -#!/usr/bin/env bash +#!/usr/bin/env sh # Format all code with astyle From 0cd00da35456410c4180bdac52df3b074c1450f6 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Tue, 27 Jun 2023 19:47:19 -0500 Subject: [PATCH 120/138] Add `ffi/pointer-cfunction` to FFI. This allows for more flexible C interop from DLLs. Users can skip the usual extension loading mechanism and manage function pointers manually if they need to. --- src/core/ffi.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/core/ffi.c b/src/core/ffi.c index 41e3c04c..4140c2e4 100644 --- a/src/core/ffi.c +++ b/src/core/ffi.c @@ -1530,6 +1530,22 @@ JANET_CORE_FN(cfun_ffi_pointer_buffer, return janet_wrap_buffer(janet_pointer_buffer_unsafe(offset_pointer, capacity, count)); } +JANET_CORE_FN(cfun_ffi_pointer_cfunction, + "(ffi/pointer-cfunction pointer &opt name source-file source-line)", + "Create a C Function from a raw pointer. Optionally give the cfunction a name and " + "source location for stack traces and debugging.") { + janet_sandbox_assert(JANET_SANDBOX_FFI_USE); + janet_arity(argc, 1, 4); + void *pointer = janet_getpointer(argv, 0); + const char *name = janet_optcstring(argv, argc, 1, NULL); + const char *source = janet_optcstring(argv, argc, 2, NULL); + int32_t line = janet_optinteger(argv, argc, 3, -1); + if ((name != NULL) || (source != NULL) || (line != -1)) { + janet_registry_put((JanetCFunction) pointer, name, NULL, source, line); + } + return janet_wrap_cfunction((JanetCFunction) pointer); +} + JANET_CORE_FN(cfun_ffi_supported_calling_conventions, "(ffi/calling-conventions)", "Get an array of all supported calling conventions on the current arhcitecture. Some architectures may have some FFI " @@ -1567,6 +1583,7 @@ void janet_lib_ffi(JanetTable *env) { JANET_CORE_REG("ffi/malloc", cfun_ffi_malloc), JANET_CORE_REG("ffi/free", cfun_ffi_free), JANET_CORE_REG("ffi/pointer-buffer", cfun_ffi_pointer_buffer), + JANET_CORE_REG("ffi/pointer-cfunction", cfun_ffi_pointer_cfunction), JANET_CORE_REG("ffi/calling-conventions", cfun_ffi_supported_calling_conventions), JANET_REG_END }; From c83f3ec09757eb48bf7d48f3063b39e4d8bd9345 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Wed, 28 Jun 2023 16:35:16 +0700 Subject: [PATCH 121/138] floor div, variadic mod --- src/boot/boot.janet | 2 +- src/core/asm.c | 1 + src/core/bytecode.c | 2 ++ src/core/cfuns.c | 53 +++++++++++++++++++++++++-------------------- src/core/compile.h | 1 + src/core/corelib.c | 27 ++++++++++------------- src/core/inttypes.c | 28 ++++++++++++++++++++++++ src/core/vm.c | 17 ++++++++++++++- src/include/janet.h | 1 + 9 files changed, 90 insertions(+), 42 deletions(-) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index c6c1ff27..74f6384d 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -151,7 +151,7 @@ (defmacro -= "Decrements the var x by n." [x & ns] ~(set ,x (,- ,x ,;ns))) (defmacro *= "Shorthand for (set x (\\* x n))." [x & ns] ~(set ,x (,* ,x ,;ns))) (defmacro /= "Shorthand for (set x (/ x n))." [x & ns] ~(set ,x (,/ ,x ,;ns))) -(defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n))) +(defmacro %= "Shorthand for (set x (% x n))." [x & ns] ~(set ,x (,% ,x ,;ns))) (defmacro assert "Throw an error if x is not truthy. Will not evaluate `err` if x is truthy." diff --git a/src/core/asm.c b/src/core/asm.c index b09b7e3a..e5712cc1 100644 --- a/src/core/asm.c +++ b/src/core/asm.c @@ -75,6 +75,7 @@ static const JanetInstructionDef janet_ops[] = { {"cmp", JOP_COMPARE}, {"cncl", JOP_CANCEL}, {"div", JOP_DIVIDE}, + {"divf", JOP_DIVIDE_FLOOR}, {"divim", JOP_DIVIDE_IMMEDIATE}, {"eq", JOP_EQUALS}, {"eqim", JOP_EQUALS_IMMEDIATE}, diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 34383aa7..821bf42d 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -42,6 +42,7 @@ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = { JINT_SSS, /* JOP_MULTIPLY, */ JINT_SSI, /* JOP_DIVIDE_IMMEDIATE, */ JINT_SSS, /* JOP_DIVIDE, */ + JINT_SSS, /* JOP_DIVIDE_FLOOR */ JINT_SSS, /* JOP_MODULO, */ JINT_SSS, /* JOP_REMAINDER, */ JINT_SSS, /* JOP_BAND, */ @@ -301,6 +302,7 @@ void janet_bytecode_movopt(JanetFuncDef *def) { case JOP_SUBTRACT: case JOP_MULTIPLY: case JOP_DIVIDE: + case JOP_DIVIDE_FLOOR: case JOP_MODULO: case JOP_REMAINDER: case JOP_SHIFT_LEFT: diff --git a/src/core/cfuns.c b/src/core/cfuns.c index 7656fe5e..be61da80 100644 --- a/src/core/cfuns.c +++ b/src/core/cfuns.c @@ -116,7 +116,8 @@ static JanetSlot opreduce( JanetSlot *args, int op, int opim, - Janet nullary) { + Janet nullary, + Janet unary) { JanetCompiler *c = opts.compiler; int32_t i, len; int8_t imm = 0; @@ -132,7 +133,7 @@ static JanetSlot opreduce( if (op == JOP_SUBTRACT) { janetc_emit_ssi(c, JOP_MULTIPLY_IMMEDIATE, t, args[0], -1, 1); } else { - janetc_emit_sss(c, op, t, janetc_cslot(nullary), args[0], 1); + janetc_emit_sss(c, op, t, janetc_cslot(unary), args[0], 1); } return t; } @@ -155,7 +156,7 @@ static JanetSlot opreduce( /* Function optimizers */ static JanetSlot do_propagate(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_PROPAGATE, 0, janet_wrap_nil()); + return opreduce(opts, args, JOP_PROPAGATE, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_error(JanetFopts opts, JanetSlot *args) { janetc_emit_s(opts.compiler, JOP_ERROR, args[0], 0); @@ -172,7 +173,7 @@ static JanetSlot do_debug(JanetFopts opts, JanetSlot *args) { return t; } static JanetSlot do_in(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_IN, 0, janet_wrap_nil()); + return opreduce(opts, args, JOP_IN, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_get(JanetFopts opts, JanetSlot *args) { if (janet_v_count(args) == 3) { @@ -192,20 +193,14 @@ static JanetSlot do_get(JanetFopts opts, JanetSlot *args) { c->buffer[label] |= (current - label) << 16; return t; } else { - return opreduce(opts, args, JOP_GET, 0, janet_wrap_nil()); + return opreduce(opts, args, JOP_GET, 0, janet_wrap_nil(), janet_wrap_nil()); } } static JanetSlot do_next(JanetFopts opts, JanetSlot *args) { return opfunction(opts, args, JOP_NEXT, janet_wrap_nil()); } -static JanetSlot do_modulo(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_MODULO, 0, janet_wrap_nil()); -} -static JanetSlot do_remainder(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_REMAINDER, 0, janet_wrap_nil()); -} static JanetSlot do_cmp(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_COMPARE, 0, janet_wrap_nil()); + return opreduce(opts, args, JOP_COMPARE, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_put(JanetFopts opts, JanetSlot *args) { if (opts.flags & JANET_FOPTS_DROP) { @@ -262,34 +257,43 @@ static JanetSlot do_apply(JanetFopts opts, JanetSlot *args) { /* Variadic operators specialization */ static JanetSlot do_add(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_ADD, JOP_ADD_IMMEDIATE, janet_wrap_integer(0)); + return opreduce(opts, args, JOP_ADD, JOP_ADD_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_sub(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_SUBTRACT, -JOP_ADD_IMMEDIATE, janet_wrap_integer(0)); + return opreduce(opts, args, JOP_SUBTRACT, -JOP_ADD_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_mul(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_MULTIPLY, JOP_MULTIPLY_IMMEDIATE, janet_wrap_integer(1)); + return opreduce(opts, args, JOP_MULTIPLY, JOP_MULTIPLY_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_div(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_DIVIDE, JOP_DIVIDE_IMMEDIATE, janet_wrap_integer(1)); + return opreduce(opts, args, JOP_DIVIDE, JOP_DIVIDE_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); +} +static JanetSlot do_divf(JanetFopts opts, JanetSlot *args) { + return opreduce(opts, args, JOP_DIVIDE_FLOOR, 0, janet_wrap_integer(1), janet_wrap_integer(1)); +} +static JanetSlot do_modulo(JanetFopts opts, JanetSlot *args) { + return opreduce(opts, args, JOP_MODULO, 0, janet_wrap_integer(0), janet_wrap_integer(1)); +} +static JanetSlot do_remainder(JanetFopts opts, JanetSlot *args) { + return opreduce(opts, args, JOP_REMAINDER, 0, janet_wrap_integer(0), janet_wrap_integer(1)); } static JanetSlot do_band(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_BAND, 0, janet_wrap_integer(-1)); + return opreduce(opts, args, JOP_BAND, 0, janet_wrap_integer(-1), janet_wrap_integer(-1)); } static JanetSlot do_bor(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_BOR, 0, janet_wrap_integer(0)); + return opreduce(opts, args, JOP_BOR, 0, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_bxor(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_BXOR, 0, janet_wrap_integer(0)); + return opreduce(opts, args, JOP_BXOR, 0, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_lshift(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_SHIFT_LEFT, JOP_SHIFT_LEFT_IMMEDIATE, janet_wrap_integer(1)); + return opreduce(opts, args, JOP_SHIFT_LEFT, JOP_SHIFT_LEFT_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_rshift(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_SHIFT_RIGHT, JOP_SHIFT_RIGHT_IMMEDIATE, janet_wrap_integer(1)); + return opreduce(opts, args, JOP_SHIFT_RIGHT, JOP_SHIFT_RIGHT_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_rshiftu(JanetFopts opts, JanetSlot *args) { - return opreduce(opts, args, JOP_SHIFT_RIGHT_UNSIGNED, JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, janet_wrap_integer(1)); + return opreduce(opts, args, JOP_SHIFT_RIGHT_UNSIGNED, JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_bnot(JanetFopts opts, JanetSlot *args) { return genericSS(opts, JOP_BNOT, args[0]); @@ -383,10 +387,11 @@ static const JanetFunOptimizer optimizers[] = { {fixarity2, do_propagate}, {arity2or3, do_get}, {arity1or2, do_next}, - {fixarity2, do_modulo}, - {fixarity2, do_remainder}, + {NULL, do_modulo}, + {NULL, do_remainder}, {fixarity2, do_cmp}, {fixarity2, do_cancel}, + {NULL, do_divf} }; const JanetFunOptimizer *janetc_funopt(uint32_t flags) { diff --git a/src/core/compile.h b/src/core/compile.h index 5863c0b8..05e6f39b 100644 --- a/src/core/compile.h +++ b/src/core/compile.h @@ -69,6 +69,7 @@ typedef enum { #define JANET_FUN_REMAINDER 30 #define JANET_FUN_CMP 31 #define JANET_FUN_CANCEL 32 +#define JANET_FUN_DIVIDE_FLOOR 33 /* Compiler typedefs */ typedef struct JanetCompiler JanetCompiler; diff --git a/src/core/corelib.c b/src/core/corelib.c index 741425a0..46a078e1 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -985,14 +985,6 @@ static const uint32_t next_asm[] = { JOP_NEXT | (1 << 24), JOP_RETURN }; -static const uint32_t modulo_asm[] = { - JOP_MODULO | (1 << 24), - JOP_RETURN -}; -static const uint32_t remainder_asm[] = { - JOP_REMAINDER | (1 << 24), - JOP_RETURN -}; static const uint32_t cmp_asm[] = { JOP_COMPARE | (1 << 24), JOP_RETURN @@ -1077,14 +1069,6 @@ static void janet_load_libs(JanetTable *env) { JanetTable *janet_core_env(JanetTable *replacements) { JanetTable *env = (NULL != replacements) ? replacements : janet_table(0); - janet_quick_asm(env, JANET_FUN_MODULO, - "mod", 2, 2, 2, 2, modulo_asm, sizeof(modulo_asm), - JDOC("(mod dividend divisor)\n\n" - "Returns the modulo of dividend / divisor.")); - janet_quick_asm(env, JANET_FUN_REMAINDER, - "%", 2, 2, 2, 2, remainder_asm, sizeof(remainder_asm), - JDOC("(% dividend divisor)\n\n" - "Returns the remainder of dividend / divisor.")); janet_quick_asm(env, JANET_FUN_CMP, "cmp", 2, 2, 2, 2, cmp_asm, sizeof(cmp_asm), JDOC("(cmp x y)\n\n" @@ -1183,6 +1167,17 @@ JanetTable *janet_core_env(JanetTable *replacements) { "Returns the quotient of xs. If xs is empty, returns 1. If xs has one value x, returns " "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining " "values.")); + templatize_varop(env, JANET_FUN_DIVIDE_FLOOR, "div", 1, 1, JOP_DIVIDE_FLOOR, + JDOC("(div & xs)\n\n" + "Returns the floored division of xs. If xs is empty, returns 1. If xs has one value x, returns " + "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining " + "values.")); + templatize_varop(env, JANET_FUN_MODULO, "mod", 0, 1, JOP_MODULO, + JDOC("(mod dividend divisor)\n\n" + "Returns the modulo of dividend / divisor.")); + templatize_varop(env, JANET_FUN_REMAINDER, "%", 0, 1, JOP_REMAINDER, + JDOC("(% dividend divisor)\n\n" + "Returns the remainder of dividend / divisor.")); templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND, JDOC("(band & xs)\n\n" "Returns the bit-wise and of all values in xs. Each x in xs must be an integer.")); diff --git a/src/core/inttypes.c b/src/core/inttypes.c index 7c2fef33..3910a866 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -490,11 +490,34 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ return janet_wrap_abstract(box); \ } \ +static Janet cfun_it_s64_divf(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); + int64_t op1 = janet_unwrap_s64(argv[0]); + int64_t op2 = janet_unwrap_s64(argv[1]); + if (op2 == 0) janet_panic("division by zero"); + int64_t x = op1 / op2; + *box = x - (((op1 ^ op2) < 0) && (x * op2 != op1)); + return janet_wrap_abstract(box); +} + +static Janet cfun_it_s64_divfi(int32_t argc, Janet *argv) { + janet_fixarity(argc, 2); + int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); + int64_t op2 = janet_unwrap_s64(argv[0]); + int64_t op1 = janet_unwrap_s64(argv[1]); + if (op2 == 0) janet_panic("division by zero"); + int64_t x = op1 / op2; + *box = x - (((op1 ^ op2) < 0) && (x * op2 != op1)); + return janet_wrap_abstract(box); +} + static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op1 = janet_unwrap_s64(argv[0]); int64_t op2 = janet_unwrap_s64(argv[1]); + if (op2 == 0) janet_panic("division by zero"); int64_t x = op1 % op2; *box = (op1 > 0) ? ((op2 > 0) ? x : (0 == x ? x : x + op2)) @@ -507,6 +530,7 @@ static Janet cfun_it_s64_modi(int32_t argc, Janet *argv) { int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op2 = janet_unwrap_s64(argv[0]); int64_t op1 = janet_unwrap_s64(argv[1]); + if (op2 == 0) janet_panic("division by zero"); int64_t x = op1 % op2; *box = (op1 > 0) ? ((op2 > 0) ? x : (0 == x ? x : x + op2)) @@ -555,6 +579,8 @@ static JanetMethod it_s64_methods[] = { {"r*", cfun_it_s64_mul}, {"/", cfun_it_s64_div}, {"r/", cfun_it_s64_divi}, + {"div", cfun_it_s64_divf}, + {"rdiv", cfun_it_s64_divfi}, {"mod", cfun_it_s64_mod}, {"rmod", cfun_it_s64_modi}, {"%", cfun_it_s64_rem}, @@ -580,6 +606,8 @@ static JanetMethod it_u64_methods[] = { {"r*", cfun_it_u64_mul}, {"/", cfun_it_u64_div}, {"r/", cfun_it_u64_divi}, + {"div", cfun_it_u64_div}, + {"rdiv", cfun_it_u64_divi}, {"mod", cfun_it_u64_mod}, {"rmod", cfun_it_u64_modi}, {"%", cfun_it_u64_mod}, diff --git a/src/core/vm.c b/src/core/vm.c index 12f990c9..e013fc78 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -342,6 +342,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { &&label_JOP_MULTIPLY, &&label_JOP_DIVIDE_IMMEDIATE, &&label_JOP_DIVIDE, + &&label_JOP_DIVIDE_FLOOR, &&label_JOP_MODULO, &&label_JOP_REMAINDER, &&label_JOP_BAND, @@ -583,7 +584,6 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, - &&label_unknown_op, &&label_unknown_op }; #endif @@ -688,6 +688,21 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { VM_OP(JOP_DIVIDE) vm_binop( /); + VM_OP(JOP_DIVIDE_FLOOR) { + Janet op1 = stack[B]; + Janet op2 = stack[C]; + if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) { + double x1 = janet_unwrap_number(op1); + double x2 = janet_unwrap_number(op2); + stack[A] = janet_wrap_number(floor(x1 / x2)); + vm_pcnext(); + } else { + vm_commit(); + stack[A] = janet_binop_call("div", "rdiv", op1, op2); + vm_checkgc_pcnext(); + } + } + VM_OP(JOP_MODULO) { Janet op1 = stack[B]; Janet op2 = stack[C]; diff --git a/src/include/janet.h b/src/include/janet.h index 34cfa06a..ada92277 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -1267,6 +1267,7 @@ enum JanetOpCode { JOP_MULTIPLY, JOP_DIVIDE_IMMEDIATE, JOP_DIVIDE, + JOP_DIVIDE_FLOOR, JOP_MODULO, JOP_REMAINDER, JOP_BAND, From f6248369fe4e1e5c92f0d20348256e4bab51c5f6 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 28 Jun 2023 08:18:43 -0500 Subject: [PATCH 122/138] Update janet_getcbytes to padd buffers with trailing 0. --- src/core/capi.c | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/src/core/capi.c b/src/core/capi.c index c1109c5f..be4f03e3 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -216,12 +216,31 @@ const char *janet_getcstring(const Janet *argv, int32_t n) { } const char *janet_getcbytes(const Janet *argv, int32_t n) { + /* Ensure buffer 0-padded */ + if (janet_checktype(argv[n], JANET_BUFFER)) { + JanetBuffer *b = janet_unwrap_buffer(argv[n]); + if (b->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) { + /* Make a copy with janet_smalloc in the rare case we have a buffer that cannot be realloced */ + char *new_string = janet_smalloc(b->count + 1); + memcpy(new_string, b->data, b->count); + new_string[b->count] = 0; + if (strlen(new_string) != (size_t) b->count) goto badzeros; + return new_string; + } else { + /* Ensure trailing 0 */ + janet_buffer_push_u8(b, 0); + b->count--; + if (strlen((char *)b->data) != (size_t) b->count) goto badzeros; + return (const char *) b->data; + } + } JanetByteView view = janet_getbytes(argv, n); const char *cstr = (const char *)view.bytes; - if (strlen(cstr) != (size_t) view.len) { - janet_panic("bytes contain embedded 0s"); - } + if (strlen(cstr) != (size_t) view.len) goto badzeros; return cstr; + +badzeros: + janet_panic("bytes contain embedded 0s"); } const char *janet_optcbytes(const Janet *argv, int32_t argc, int32_t n, const char *dflt) { From 3f7a2c2197e7ccabf0c76530050d2d4ace07bc83 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Wed, 28 Jun 2023 08:30:09 -0500 Subject: [PATCH 123/138] Try harder to avoid string copying with janet_getcbytes. --- src/core/capi.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/core/capi.c b/src/core/capi.c index be4f03e3..a89b4685 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -219,8 +219,9 @@ const char *janet_getcbytes(const Janet *argv, int32_t n) { /* Ensure buffer 0-padded */ if (janet_checktype(argv[n], JANET_BUFFER)) { JanetBuffer *b = janet_unwrap_buffer(argv[n]); - if (b->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) { - /* Make a copy with janet_smalloc in the rare case we have a buffer that cannot be realloced */ + if ((b->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) && b->count == b->capacity) { + /* Make a copy with janet_smalloc in the rare case we have a buffer that + * cannot be realloced and pushing a 0 byte would panic. */ char *new_string = janet_smalloc(b->count + 1); memcpy(new_string, b->data, b->count); new_string[b->count] = 0; From 8a62c742e6e22a9548f37a66433d42d2e108058e Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Fri, 30 Jun 2023 16:15:04 +0700 Subject: [PATCH 124/138] define `(mod x 0)` as `x` See: Knuth, Donald E., _The Art of Computer Programming: Volume 1: Fundamental Algorithms_, pp. 15 ([link](https://books.google.com/books?id=x9AsAwAAQBAJ&pg=PA15)) --- src/core/corelib.c | 9 ++++--- src/core/inttypes.c | 59 ++++++++++++++++++++++++++------------------- src/core/vm.c | 8 ++++-- 3 files changed, 45 insertions(+), 31 deletions(-) diff --git a/src/core/corelib.c b/src/core/corelib.c index 46a078e1..4b326496 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -1173,11 +1173,12 @@ JanetTable *janet_core_env(JanetTable *replacements) { "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining " "values.")); templatize_varop(env, JANET_FUN_MODULO, "mod", 0, 1, JOP_MODULO, - JDOC("(mod dividend divisor)\n\n" - "Returns the modulo of dividend / divisor.")); + JDOC("(mod & xs)\n\n" + "Returns the result of applying the modulo operator on the first value of xs with each remaining value. " + "`(mod x 0)` is defined to be `x`.")); templatize_varop(env, JANET_FUN_REMAINDER, "%", 0, 1, JOP_REMAINDER, - JDOC("(% dividend divisor)\n\n" - "Returns the remainder of dividend / divisor.")); + JDOC("(% & xs)\n\n" + "Returns the remainder of dividing the first value of xs by each remaining value.")); templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND, JDOC("(band & xs)\n\n" "Returns the bit-wise and of all values in xs. Each x in xs must be an integer.")); diff --git a/src/core/inttypes.c b/src/core/inttypes.c index 3910a866..c576e89d 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -431,7 +431,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ } \ #define OPMETHODINVERT(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ +static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ @@ -440,6 +440,11 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ return janet_wrap_abstract(box); \ } \ +#define DIVZERO(name) DIVZERO_##name +#define DIVZERO_div janet_panic("division by zero") +#define DIVZERO_rem janet_panic("division by zero") +#define DIVZERO_mod return janet_wrap_abstract(box) + #define DIVMETHOD(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_arity(argc, 2, -1); \ @@ -447,19 +452,19 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ *box = janet_unwrap_##type(argv[0]); \ for (int32_t i = 1; i < argc; i++) { \ T value = janet_unwrap_##type(argv[i]); \ - if (value == 0) janet_panic("division by zero"); \ + if (value == 0) DIVZERO(name); \ *box oper##= value; \ } \ return janet_wrap_abstract(box); \ } \ #define DIVMETHODINVERT(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ +static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ T value = janet_unwrap_##type(argv[0]); \ - if (value == 0) janet_panic("division by zero"); \ + if (value == 0) DIVZERO(name); \ *box oper##= value; \ return janet_wrap_abstract(box); \ } \ @@ -471,7 +476,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ *box = janet_unwrap_##type(argv[0]); \ for (int32_t i = 1; i < argc; i++) { \ T value = janet_unwrap_##type(argv[i]); \ - if (value == 0) janet_panic("division by zero"); \ + if (value == 0) DIVZERO(name); \ if ((value == -1) && (*box == INT64_MIN)) janet_panic("INT64_MIN divided by -1"); \ *box oper##= value; \ } \ @@ -479,12 +484,12 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ } \ #define DIVMETHODINVERT_SIGNED(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ +static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ T value = janet_unwrap_##type(argv[0]); \ - if (value == 0) janet_panic("division by zero"); \ + if (value == 0) DIVZERO(name); \ if ((value == -1) && (*box == INT64_MIN)) janet_panic("INT64_MIN divided by -1"); \ *box oper##= value; \ return janet_wrap_abstract(box); \ @@ -517,11 +522,12 @@ static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op1 = janet_unwrap_s64(argv[0]); int64_t op2 = janet_unwrap_s64(argv[1]); - if (op2 == 0) janet_panic("division by zero"); - int64_t x = op1 % op2; - *box = (op1 > 0) - ? ((op2 > 0) ? x : (0 == x ? x : x + op2)) - : ((op2 > 0) ? (0 == x ? x : x + op2) : x); + if (op2 == 0) { + *box = op1; + } else { + int64_t x = op1 % op2; + *box = (((op1 ^ op2) < 0) && (x != 0)) ? x + op2 : x; + } return janet_wrap_abstract(box); } @@ -530,22 +536,23 @@ static Janet cfun_it_s64_modi(int32_t argc, Janet *argv) { int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op2 = janet_unwrap_s64(argv[0]); int64_t op1 = janet_unwrap_s64(argv[1]); - if (op2 == 0) janet_panic("division by zero"); - int64_t x = op1 % op2; - *box = (op1 > 0) - ? ((op2 > 0) ? x : (0 == x ? x : x + op2)) - : ((op2 > 0) ? (0 == x ? x : x + op2) : x); + if (op2 == 0) { + *box = op1; + } else { + int64_t x = op1 % op2; + *box = (((op1 ^ op2) < 0) && (x != 0)) ? x + op2 : x; + } return janet_wrap_abstract(box); } OPMETHOD(int64_t, s64, add, +) OPMETHOD(int64_t, s64, sub, -) -OPMETHODINVERT(int64_t, s64, subi, -) +OPMETHODINVERT(int64_t, s64, sub, -) OPMETHOD(int64_t, s64, mul, *) DIVMETHOD_SIGNED(int64_t, s64, div, /) DIVMETHOD_SIGNED(int64_t, s64, rem, %) -DIVMETHODINVERT_SIGNED(int64_t, s64, divi, /) -DIVMETHODINVERT_SIGNED(int64_t, s64, remi, %) +DIVMETHODINVERT_SIGNED(int64_t, s64, div, /) +DIVMETHODINVERT_SIGNED(int64_t, s64, rem, %) OPMETHOD(int64_t, s64, and, &) OPMETHOD(int64_t, s64, or, |) OPMETHOD(int64_t, s64, xor, ^) @@ -553,12 +560,14 @@ OPMETHOD(int64_t, s64, lshift, <<) OPMETHOD(int64_t, s64, rshift, >>) OPMETHOD(uint64_t, u64, add, +) OPMETHOD(uint64_t, u64, sub, -) -OPMETHODINVERT(uint64_t, u64, subi, -) +OPMETHODINVERT(uint64_t, u64, sub, -) OPMETHOD(uint64_t, u64, mul, *) DIVMETHOD(uint64_t, u64, div, /) +DIVMETHOD(uint64_t, u64, rem, %) DIVMETHOD(uint64_t, u64, mod, %) -DIVMETHODINVERT(uint64_t, u64, divi, /) -DIVMETHODINVERT(uint64_t, u64, modi, %) +DIVMETHODINVERT(uint64_t, u64, div, /) +DIVMETHODINVERT(uint64_t, u64, rem, %) +DIVMETHODINVERT(uint64_t, u64, mod, %) OPMETHOD(uint64_t, u64, and, &) OPMETHOD(uint64_t, u64, or, |) OPMETHOD(uint64_t, u64, xor, ^) @@ -610,8 +619,8 @@ static JanetMethod it_u64_methods[] = { {"rdiv", cfun_it_u64_divi}, {"mod", cfun_it_u64_mod}, {"rmod", cfun_it_u64_modi}, - {"%", cfun_it_u64_mod}, - {"r%", cfun_it_u64_modi}, + {"%", cfun_it_u64_rem}, + {"r%", cfun_it_u64_remi}, {"&", cfun_it_u64_and}, {"r&", cfun_it_u64_and}, {"|", cfun_it_u64_or}, diff --git a/src/core/vm.c b/src/core/vm.c index e013fc78..cdc932ce 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -709,8 +709,12 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) { double x1 = janet_unwrap_number(op1); double x2 = janet_unwrap_number(op2); - double intres = x2 * floor(x1 / x2); - stack[A] = janet_wrap_number(x1 - intres); + if (x2 == 0) { + stack[A] = janet_wrap_number(x1); + } else { + double intres = x2 * floor(x1 / x2); + stack[A] = janet_wrap_number(x1 - intres); + } vm_pcnext(); } else { vm_commit(); From b3db367ae724bb9aa94a870937d266000729794c Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Fri, 30 Jun 2023 19:28:10 +0700 Subject: [PATCH 125/138] Add test cases for div and mod --- test/suite-corelib.janet | 24 +++++++++++++++++-- test/suite-inttypes.janet | 50 ++++++++++++++++++++++++++------------- test/suite-peg.janet | 12 +++++----- test/suite-strtod.janet | 5 ---- 4 files changed, 62 insertions(+), 29 deletions(-) diff --git a/test/suite-corelib.janet b/test/suite-corelib.janet index 8f590658..213a33f4 100644 --- a/test/suite-corelib.janet +++ b/test/suite-corelib.janet @@ -46,8 +46,28 @@ (assert (<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "less than or equal to reals") (assert (>= 6 5 4 4 3 2 1) "greater than or equal to integers") (assert (>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "greater than or equal to reals") -(assert (= 7 (% 20 13)) "modulo 1") -(assert (= -7 (% -20 13)) "modulo 2") + +(assert (= 7 (% 20 13)) "rem 1") +(assert (= -7 (% -20 13)) "rem 2") +(assert (= 7 (% 20 -13)) "rem 3") +(assert (= -7 (% -20 -13)) "rem 4") +(assert (nan? (% 20 0)) "rem 5") + +(assert (= 7 (mod 20 13)) "mod 1") +(assert (= 6 (mod -20 13)) "mod 2") +(assert (= -6 (mod 20 -13)) "mod 3") +(assert (= -7 (mod -20 -13)) "mod 4") +(assert (= 20 (mod 20 0)) "mod 5") + +(assert (= 1 (div 20 13)) "div 1") +(assert (= -2 (div -20 13)) "div 2") +(assert (= -2 (div 20 -13)) "div 3") +(assert (= 1 (div -20 -13)) "div 4") +(assert (= math/inf (div 20 0)) "div 5") + +(assert (all = (seq [n :range [0 10]] (mod n 5 3)) + (seq [n :range [0 10]] (% n 5 3)) + [0 1 2 0 1 0 1 2 0 1]) "variadic mod") (assert (< 1.0 nil false true (fiber/new (fn [] 1)) diff --git a/test/suite-inttypes.janet b/test/suite-inttypes.janet index 554128b4..9a7b6d0f 100644 --- a/test/suite-inttypes.janet +++ b/test/suite-inttypes.janet @@ -171,22 +171,35 @@ (assert (not (even? (int/s64 "-1001"))) "even? 6") # integer type operations -(defn modcheck [x y] - (assert (= (string (mod x y)) (string (mod (int/s64 x) y))) - (string "int/s64 (mod " x " " y ") expected " (mod x y) ", got " - (mod (int/s64 x) y))) - (assert (= (string (% x y)) (string (% (int/s64 x) y))) - (string "int/s64 (% " x " " y ") expected " (% x y) ", got " - (% (int/s64 x) y)))) +(defn opcheck [int x y] + (each op [mod % div] + (assert (compare= (op x y) (op (int x) y)) + (string int " (" op " " x " " y ") expected " (op x y) + ", got " (op (int x) y))) + (assert (compare= (op x y) (op x (int y))) + (string int " (" op " " x " " y ") expected " (op x y) + ", got " (op x (int y)))) + (assert (compare= (op x y) (op (int x) (int y))) + (string int " (" op " " x " " y ") expected " (op x y) + ", got " (op (int x) (int y)))))) -(modcheck 1 2) -(modcheck 1 3) -(modcheck 4 2) -(modcheck 4 1) -(modcheck 10 3) -(modcheck 10 -3) -(modcheck -10 3) -(modcheck -10 -3) +(loop [x :in [-5 -3 0 3 5] + y :in [-4 -3 3 4]] + (opcheck int/s64 x y) + (if (and (>= x 0) (>= y 0)) + (opcheck int/u64 x y))) + +(each int [int/s64 int/u64] + (each op [% / div] + (assert-error "division by zero" (op (int 7) 0)) + (assert-error "division by zero" (op 7 (int 0))) + (assert-error "division by zero" (op (int 7) (int 0))))) + +(each int [int/s64 int/u64] + (loop [x :in [-5 -3 0 3 5]] + (assert (= (int x) (mod (int x) 0)) (string int " mod 0")) + (assert (= (int x) (mod x (int 0))) (string int " mod 0")) + (assert (= (int x) (mod (int x) (int 0))) (string int " mod 0")))) # Check for issue #1130 # 7e65c2bda @@ -253,6 +266,11 @@ (assert (= (compare (i64 -1) (u64 1)) -1) "compare 11") (assert (= (compare (i64 -1) (u64 -1)) -1) "compare 12") +# off by 1 error in inttypes +# a3e812b86 +(assert (= (int/s64 "-0x8000_0000_0000_0000") + (+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around") +(assert (= (int/s64 "0x7FFF_FFFF_FFFF_FFFF") + (- (int/s64 "-0x8000_0000_0000_0000") 1)) "int types wrap around") (end-suite) - diff --git a/test/suite-peg.janet b/test/suite-peg.janet index 4e3603b3..44236900 100644 --- a/test/suite-peg.janet +++ b/test/suite-peg.janet @@ -307,12 +307,12 @@ (check-deep '(uint 2) "\xff\x7f" @[0x7fff]) (check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) (check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) -(check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" - @[(int/u64 0x7fff)]) -(check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" - @[(int/s64 0x7fff)]) -(check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/u64 0x7fff)]) -(check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/s64 0x7fff)]) +(when-let [u64 int/u64 + i64 int/s64] + (check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(u64 0x7fff)]) + (check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(i64 0x7fff)]) + (check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(u64 0x7fff)]) + (check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(i64 0x7fff)])) (check-deep '(* (int 2) -1) "123" nil) diff --git a/test/suite-strtod.janet b/test/suite-strtod.janet index f693b808..888123fe 100644 --- a/test/suite-strtod.janet +++ b/test/suite-strtod.janet @@ -35,10 +35,5 @@ # c876e63 0xf&1fffFFFF -# off by 1 error in inttypes -# a3e812b86 -(assert (= (int/s64 "-0x8000_0000_0000_0000") - (+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around") - (end-suite) From 20ec6f574e5027c02a06affeb986820ffe3e69d9 Mon Sep 17 00:00:00 2001 From: Michael Camilleri Date: Sat, 1 Jul 2023 19:33:38 +0900 Subject: [PATCH 126/138] Avoid removing too many symbols with strip on macOS --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index a0e8e819..c6be5487 100644 --- a/Makefile +++ b/Makefile @@ -308,7 +308,7 @@ build/janet.pc: $(JANET_TARGET) install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/janet.h mkdir -p '$(DESTDIR)$(BINDIR)' cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet' - strip '$(DESTDIR)$(BINDIR)/janet' + strip -x -S '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet' ln -sf ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' From 58d297364a5bf3e759a2dd33584c293c321c646e Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 1 Jul 2023 08:42:32 -0500 Subject: [PATCH 127/138] Change code for marshalling abstract types. --- src/core/marsh.c | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/src/core/marsh.c b/src/core/marsh.c index b4dae0ba..57370a4d 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -364,11 +364,12 @@ void janet_marshal_int(JanetMarshalContext *ctx, int32_t value) { /* Only use in unsafe - don't marshal pointers otherwise */ void janet_marshal_ptr(JanetMarshalContext *ctx, const void *ptr) { -#ifdef JANET_32 - janet_marshal_int(ctx, (intptr_t) ptr); -#else - janet_marshal_int64(ctx, (intptr_t) ptr); -#endif + union { + const void *ptr; + uint8_t bytes[sizeof(void *)]; + } u; + u.ptr = ptr; + pushbytes(ctx->m_state, u.bytes, sizeof(void *)); } void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value) { @@ -422,6 +423,7 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { marshal_one(st, janet_csymbolv(at->name), flags + 1); JanetMarshalContext context = {st, NULL, flags, NULL, at}; at->marshal(abstract, &context); + MARK_SEEN(); } else { janet_panicf("cannot marshal %p", x); } @@ -926,7 +928,7 @@ static const uint8_t *unmarshal_one_def( Janet value; data = unmarshal_one(st, data, &value, flags + 1); if (!janet_checktype(value, JANET_SYMBOL)) - janet_panic("expected symbol in symbol map"); + janet_panicf("expected symbol in unmarshal, got %v", value); def->symbolmap[i].symbol = janet_unwrap_symbol(value); } def->symbolmap_length = (uint32_t) symbolmap_length; @@ -1176,11 +1178,14 @@ int64_t janet_unmarshal_int64(JanetMarshalContext *ctx) { void *janet_unmarshal_ptr(JanetMarshalContext *ctx) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); -#ifdef JANET_32 - return (void *) ((intptr_t) readint(st, &(ctx->data))); -#else - return (void *) ((intptr_t) read64(st, &(ctx->data))); -#endif + union { + void *ptr; + uint8_t bytes[sizeof(void *)]; + } u; + MARSH_EOS(st, ctx->data + sizeof(void *) - 1); + memcpy(u.bytes, ctx->data, sizeof(void *)); + ctx->data += sizeof(void *); + return u.ptr; } uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx) { From 81423635add012bc93084f18553beb48c630308e Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sat, 1 Jul 2023 21:19:42 +0700 Subject: [PATCH 128/138] Add bnot to int types --- src/core/inttypes.c | 12 ++++++++++++ src/core/vm.c | 21 ++++++++++++++++++--- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/core/inttypes.c b/src/core/inttypes.c index c576e89d..f6f07c13 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -440,6 +440,14 @@ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ return janet_wrap_abstract(box); \ } \ +#define UNARYMETHOD(T, type, name, oper) \ +static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ + janet_fixarity(argc, 1); \ + T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ + *box = oper(janet_unwrap_##type(argv[0])); \ + return janet_wrap_abstract(box); \ +} \ + #define DIVZERO(name) DIVZERO_##name #define DIVZERO_div janet_panic("division by zero") #define DIVZERO_rem janet_panic("division by zero") @@ -556,6 +564,7 @@ DIVMETHODINVERT_SIGNED(int64_t, s64, rem, %) OPMETHOD(int64_t, s64, and, &) OPMETHOD(int64_t, s64, or, |) OPMETHOD(int64_t, s64, xor, ^) +UNARYMETHOD(int64_t, s64, not, ~) OPMETHOD(int64_t, s64, lshift, <<) OPMETHOD(int64_t, s64, rshift, >>) OPMETHOD(uint64_t, u64, add, +) @@ -571,6 +580,7 @@ DIVMETHODINVERT(uint64_t, u64, mod, %) OPMETHOD(uint64_t, u64, and, &) OPMETHOD(uint64_t, u64, or, |) OPMETHOD(uint64_t, u64, xor, ^) +UNARYMETHOD(int64_t, u64, not, ~) OPMETHOD(uint64_t, u64, lshift, <<) OPMETHOD(uint64_t, u64, rshift, >>) @@ -600,6 +610,7 @@ static JanetMethod it_s64_methods[] = { {"r|", cfun_it_s64_or}, {"^", cfun_it_s64_xor}, {"r^", cfun_it_s64_xor}, + {"~", cfun_it_s64_not}, {"<<", cfun_it_s64_lshift}, {">>", cfun_it_s64_rshift}, {"compare", cfun_it_s64_compare}, @@ -627,6 +638,7 @@ static JanetMethod it_u64_methods[] = { {"r|", cfun_it_u64_or}, {"^", cfun_it_u64_xor}, {"r^", cfun_it_u64_xor}, + {"~", cfun_it_u64_not}, {"<<", cfun_it_u64_lshift}, {">>", cfun_it_u64_rshift}, {"compare", cfun_it_u64_compare}, diff --git a/src/core/vm.c b/src/core/vm.c index cdc932ce..00b9de04 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -301,6 +301,16 @@ static Janet janet_method_lookup(Janet x, const char *name) { return method_to_fun(janet_ckeywordv(name), x); } +static Janet janet_unary_call(const char *method, Janet arg) { + Janet m = janet_method_lookup(arg, method); + if (janet_checktype(m, JANET_NIL)) { + janet_panicf("could not find method :%s for %v", method, arg); + } else { + Janet argv[1] = { arg }; + return janet_method_invoke(m, 1, argv); + } +} + /* Call a method first on the righthand side, and then on the left hand side with a prefix */ static Janet janet_binop_call(const char *lmethod, const char *rmethod, Janet lhs, Janet rhs) { Janet lm = janet_method_lookup(lhs, lmethod); @@ -749,9 +759,14 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { VM_OP(JOP_BNOT) { Janet op = stack[E]; - vm_assert_type(op, JANET_NUMBER); - stack[A] = janet_wrap_integer(~janet_unwrap_integer(op)); - vm_pcnext(); + if (janet_checktype(op, JANET_NUMBER)) { + stack[A] = janet_wrap_integer(~janet_unwrap_integer(op)); + vm_pcnext(); + } else { + vm_commit(); + stack[A] = janet_unary_call("~", op); + vm_checkgc_pcnext(); + } } VM_OP(JOP_SHIFT_RIGHT_UNSIGNED) From 2007438424339e4bcb4693b9853ec3f85c0fef86 Mon Sep 17 00:00:00 2001 From: primo-ppcg Date: Sat, 1 Jul 2023 21:47:36 +0700 Subject: [PATCH 129/138] add tests for inttypes bnot --- test/suite-inttypes.janet | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/suite-inttypes.janet b/test/suite-inttypes.janet index 9a7b6d0f..9ee7c6fe 100644 --- a/test/suite-inttypes.janet +++ b/test/suite-inttypes.janet @@ -201,6 +201,14 @@ (assert (= (int x) (mod x (int 0))) (string int " mod 0")) (assert (= (int x) (mod (int x) (int 0))) (string int " mod 0")))) +(loop [x :in [-5 -3 0 3 5]] + (assert (compare= (bnot x) (bnot (int/s64 x))) "int/s64 bnot")) + +(loop [x :range [0 10]] + (assert (= (int/u64 "0xFFFF_FFFF_FFFF_FFFF") + (bxor (int/u64 x) (bnot (int/u64 x)))) + "int/u64 bnot")) + # Check for issue #1130 # 7e65c2bda (var d (int/s64 7)) From ebb6fe5be30dd47833d34d2fd0ccc68ba510d8ed Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 1 Jul 2023 10:34:11 -0500 Subject: [PATCH 130/138] Patch fix for #1210 --- src/core/inttypes.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/inttypes.c b/src/core/inttypes.c index f6f07c13..78c39fe0 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -580,7 +580,7 @@ DIVMETHODINVERT(uint64_t, u64, mod, %) OPMETHOD(uint64_t, u64, and, &) OPMETHOD(uint64_t, u64, or, |) OPMETHOD(uint64_t, u64, xor, ^) -UNARYMETHOD(int64_t, u64, not, ~) +UNARYMETHOD(uint64_t, u64, not, ~) OPMETHOD(uint64_t, u64, lshift, <<) OPMETHOD(uint64_t, u64, rshift, >>) From 60fba585e3d8af6b8d6fb110f81a560094de6b5e Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 1 Jul 2023 17:37:12 -0500 Subject: [PATCH 131/138] Remove extra MARK_SEEN --- src/core/marsh.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core/marsh.c b/src/core/marsh.c index 57370a4d..787be7d8 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -413,7 +413,6 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { janet_abstract_incref(abstract); pushbyte(st, LB_THREADED_ABSTRACT); pushbytes(st, (uint8_t *) &abstract, sizeof(abstract)); - MARK_SEEN(); return; } #endif From edf263bcb5a456c018d2df048581eeaec832f005 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 1 Jul 2023 17:47:10 -0500 Subject: [PATCH 132/138] Make some fixes to marshalling. --- src/core/marsh.c | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/core/marsh.c b/src/core/marsh.c index 787be7d8..32aaaa1a 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -154,7 +154,7 @@ static void pushbytes(MarshalState *st, const uint8_t *bytes, int32_t len) { janet_buffer_push_bytes(st->buf, bytes, len); } -static void pushpointer(MarshalState *st, void *ptr) { +static void pushpointer(MarshalState *st, const void *ptr) { janet_buffer_push_bytes(st->buf, (const uint8_t *) &ptr, sizeof(ptr)); } @@ -364,12 +364,11 @@ void janet_marshal_int(JanetMarshalContext *ctx, int32_t value) { /* Only use in unsafe - don't marshal pointers otherwise */ void janet_marshal_ptr(JanetMarshalContext *ctx, const void *ptr) { - union { - const void *ptr; - uint8_t bytes[sizeof(void *)]; - } u; - u.ptr = ptr; - pushbytes(ctx->m_state, u.bytes, sizeof(void *)); + if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { + janet_panic("can only marshal pointers in unsafe mode"); + } + MarshalState *st = (MarshalState *)(ctx->m_state); + pushpointer(st, ptr); } void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value) { @@ -413,6 +412,7 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { janet_abstract_incref(abstract); pushbyte(st, LB_THREADED_ABSTRACT); pushbytes(st, (uint8_t *) &abstract, sizeof(abstract)); + MARK_SEEN(); return; } #endif @@ -422,7 +422,7 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { marshal_one(st, janet_csymbolv(at->name), flags + 1); JanetMarshalContext context = {st, NULL, flags, NULL, at}; at->marshal(abstract, &context); - MARK_SEEN(); + //MARK_SEEN(); } else { janet_panicf("cannot marshal %p", x); } @@ -1176,15 +1176,15 @@ int64_t janet_unmarshal_int64(JanetMarshalContext *ctx) { } void *janet_unmarshal_ptr(JanetMarshalContext *ctx) { + if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { + janet_panic("can only unmarshal pointers in unsafe mode"); + } UnmarshalState *st = (UnmarshalState *)(ctx->u_state); - union { - void *ptr; - uint8_t bytes[sizeof(void *)]; - } u; + void *ptr; MARSH_EOS(st, ctx->data + sizeof(void *) - 1); - memcpy(u.bytes, ctx->data, sizeof(void *)); + memcpy((char *) &ptr, ctx->data, sizeof(void *)); ctx->data += sizeof(void *); - return u.ptr; + return ptr; } uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx) { From db0abfde72fc3b718001208bb3784ddf292ab4c2 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sat, 1 Jul 2023 18:02:56 -0500 Subject: [PATCH 133/138] Cache references when marshalling abstract types. --- src/core/marsh.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core/marsh.c b/src/core/marsh.c index 32aaaa1a..2d58844a 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -422,7 +422,7 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { marshal_one(st, janet_csymbolv(at->name), flags + 1); JanetMarshalContext context = {st, NULL, flags, NULL, at}; at->marshal(abstract, &context); - //MARK_SEEN(); + MARK_SEEN(); } else { janet_panicf("cannot marshal %p", x); } @@ -1233,6 +1233,7 @@ static const uint8_t *unmarshal_one_abstract(UnmarshalState *st, const uint8_t * if (context.at != NULL) { janet_panic("janet_unmarshal_abstract not called"); } + janet_v_push(st->lookup, *out); return context.data; } janet_panic("invalid abstract type - no unmarshal function pointer"); From a5f4e4d32883cb328e61add61cf73abf7d365bae Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 2 Jul 2023 12:58:55 -0500 Subject: [PATCH 134/138] Test small fix for marshalling. --- src/core/ev.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/core/ev.c b/src/core/ev.c index 17fe442e..01080d02 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1224,6 +1224,7 @@ static Janet janet_chanat_next(void *p, Janet key) { static void janet_chanat_marshal(void *p, JanetMarshalContext *ctx) { JanetChannel *channel = (JanetChannel *)p; + janet_marshal_abstract(ctx, channel); janet_marshal_byte(ctx, channel->closed); janet_marshal_int(ctx, channel->limit); int32_t count = janet_q_count(&channel->items); From 9bc5bec9f18763ea1c85c636c142079f3aafe7e1 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 2 Jul 2023 13:04:42 -0500 Subject: [PATCH 135/138] More complete fix with some debugging tools. --- src/core/ev.c | 2 +- src/core/marsh.c | 79 ++++++++++++++++++++++++++++++++---------------- src/core/pp.c | 4 +++ 3 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/core/ev.c b/src/core/ev.c index 01080d02..abe3940b 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -405,7 +405,7 @@ static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) { #ifdef JANET_WINDOWS /* TODO - ref counting to avoid situation where a handle is closed or GCed * while in transit, and it's value gets reused. DuplicateHandle does not work - * for network sockets, and in general for winsock it is better to nipt duplicate + * for network sockets, and in general for winsock it is better to not duplicate * unless there is a need to. */ HANDLE duph = INVALID_HANDLE_VALUE; if (s->flags & JANET_STREAM_SOCKET) { diff --git a/src/core/marsh.c b/src/core/marsh.c index 2d58844a..f81e91c0 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -246,6 +246,7 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) { } /* Add to lookup */ janet_v_push(st->seen_defs, def); + pushint(st, def->flags); pushint(st, def->slotcount); pushint(st, def->arity); @@ -266,14 +267,14 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) { /* marshal constants */ for (int32_t i = 0; i < def->constants_length; i++) - marshal_one(st, def->constants[i], flags); + marshal_one(st, def->constants[i], flags + 1); /* Marshal symbol map, if needed */ for (int32_t i = 0; i < def->symbolmap_length; i++) { pushint(st, (int32_t) def->symbolmap[i].birth_pc); pushint(st, (int32_t) def->symbolmap[i].death_pc); pushint(st, (int32_t) def->symbolmap[i].slot_index); - marshal_one(st, janet_wrap_symbol(def->symbolmap[i].symbol), flags); + marshal_one(st, janet_wrap_symbol(def->symbolmap[i].symbol), flags + 1); } /* marshal the bytecode */ @@ -387,18 +388,27 @@ void janet_marshal_janet(JanetMarshalContext *ctx, Janet x) { marshal_one(st, x, ctx->flags + 1); } +#ifdef JANET_MARSHAL_DEBUG +#define MARK_SEEN() \ + do { if (st->maybe_cycles) { \ + Janet _check = janet_table_get(&st->seen, x); \ + if (!janet_checktype(_check, JANET_NIL)) janet_eprintf("double MARK_SEEN on %v\n", x); \ + janet_eprintf("made reference %d (%t) to %v\n", st->nextid, x, x); \ + janet_table_put(&st->seen, x, janet_wrap_integer(st->nextid++)); \ + } } while (0) +#else +#define MARK_SEEN() \ + do { if (st->maybe_cycles) { \ + janet_table_put(&st->seen, x, janet_wrap_integer(st->nextid++)); \ + } } while (0) +#endif + void janet_marshal_abstract(JanetMarshalContext *ctx, void *abstract) { MarshalState *st = (MarshalState *)(ctx->m_state); - if (st->maybe_cycles) { - janet_table_put(&st->seen, - janet_wrap_abstract(abstract), - janet_wrap_integer(st->nextid++)); - } + Janet x = janet_wrap_abstract(abstract); + MARK_SEEN(); } -#define MARK_SEEN() \ - do { if (st->maybe_cycles) janet_table_put(&st->seen, x, janet_wrap_integer(st->nextid++)); } while (0) - static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { void *abstract = janet_unwrap_abstract(x); #ifdef JANET_EV @@ -420,9 +430,8 @@ static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { if (at->marshal) { pushbyte(st, LB_ABSTRACT); marshal_one(st, janet_csymbolv(at->name), flags + 1); - JanetMarshalContext context = {st, NULL, flags, NULL, at}; + JanetMarshalContext context = {st, NULL, flags + 1, NULL, at}; at->marshal(abstract, &context); - MARK_SEEN(); } else { janet_panicf("cannot marshal %p", x); } @@ -738,9 +747,22 @@ static uint64_t read64(UnmarshalState *st, const uint8_t **atdata) { return ret; } +#ifdef JANET_MARSHAL_DEBUG +static void dump_reference_table(UnmarshalState *st) { + for (int32_t i = 0; i < janet_v_count(st->lookup); i++) { + janet_eprintf(" reference %d (%t) = %v\n", i, st->lookup[i], st->lookup[i]); + } +} +#endif + /* Assert a janet type */ -static void janet_asserttype(Janet x, JanetType t) { +static void janet_asserttype(Janet x, JanetType t, UnmarshalState *st) { if (!janet_checktype(x, t)) { +#ifdef JANET_MARSHAL_DEBUG + dump_reference_table(st); +#else + (void) st; +#endif janet_panicf("expected type %T, got %v", 1 << t, x); } } @@ -792,7 +814,7 @@ static const uint8_t *unmarshal_one_env( Janet fiberv; /* On stack variant */ data = unmarshal_one(st, data, &fiberv, flags); - janet_asserttype(fiberv, JANET_FIBER); + janet_asserttype(fiberv, JANET_FIBER, st); env->as.fiber = janet_unwrap_fiber(fiberv); /* Negative offset indicates untrusted input */ env->offset = -offset; @@ -890,13 +912,13 @@ static const uint8_t *unmarshal_one_def( if (def->flags & JANET_FUNCDEF_FLAG_HASNAME) { Janet x; data = unmarshal_one(st, data, &x, flags + 1); - janet_asserttype(x, JANET_STRING); + janet_asserttype(x, JANET_STRING, st); def->name = janet_unwrap_string(x); } if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCE) { Janet x; data = unmarshal_one(st, data, &x, flags + 1); - janet_asserttype(x, JANET_STRING); + janet_asserttype(x, JANET_STRING, st); def->source = janet_unwrap_string(x); } @@ -926,8 +948,9 @@ static const uint8_t *unmarshal_one_def( def->symbolmap[i].slot_index = (uint32_t) readint(st, &data); Janet value; data = unmarshal_one(st, data, &value, flags + 1); - if (!janet_checktype(value, JANET_SYMBOL)) - janet_panicf("expected symbol in unmarshal, got %v", value); + if (!janet_checktype(value, JANET_SYMBOL)) { + janet_panicf("corrupted symbolmap when unmarshalling debug info, got %v", value); + } def->symbolmap[i].symbol = janet_unwrap_symbol(value); } def->symbolmap_length = (uint32_t) symbolmap_length; @@ -1076,7 +1099,7 @@ static const uint8_t *unmarshal_one_fiber( /* Get function */ Janet funcv; data = unmarshal_one(st, data, &funcv, flags + 1); - janet_asserttype(funcv, JANET_FUNCTION); + janet_asserttype(funcv, JANET_FUNCTION, st); func = janet_unwrap_function(funcv); def = func->def; @@ -1122,7 +1145,7 @@ static const uint8_t *unmarshal_one_fiber( Janet envv; fiber_flags &= ~JANET_FIBER_FLAG_HASENV; data = unmarshal_one(st, data, &envv, flags + 1); - janet_asserttype(envv, JANET_TABLE); + janet_asserttype(envv, JANET_TABLE, st); fiber_env = janet_unwrap_table(envv); } @@ -1131,7 +1154,7 @@ static const uint8_t *unmarshal_one_fiber( Janet fiberv; fiber_flags &= ~JANET_FIBER_FLAG_HASCHILD; data = unmarshal_one(st, data, &fiberv, flags + 1); - janet_asserttype(fiberv, JANET_FIBER); + janet_asserttype(fiberv, JANET_FIBER, st); fiber->child = janet_unwrap_fiber(fiberv); } @@ -1229,11 +1252,12 @@ static const uint8_t *unmarshal_one_abstract(UnmarshalState *st, const uint8_t * if (at == NULL) janet_panic("unknown abstract type"); if (at->unmarshal) { JanetMarshalContext context = {NULL, st, flags, data, at}; - *out = janet_wrap_abstract(at->unmarshal(&context)); + void *abst = at->unmarshal(&context); + janet_assert(abst != NULL, "null pointer abstract"); + *out = janet_wrap_abstract(abst); if (context.at != NULL) { janet_panic("janet_unmarshal_abstract not called"); } - janet_v_push(st->lookup, *out); return context.data; } janet_panic("invalid abstract type - no unmarshal function pointer"); @@ -1331,7 +1355,7 @@ static const uint8_t *unmarshal_one( } case LB_FIBER: { JanetFiber *fiber; - data = unmarshal_one_fiber(st, data + 1, &fiber, flags); + data = unmarshal_one_fiber(st, data + 1, &fiber, flags + 1); *out = janet_wrap_fiber(fiber); return data; } @@ -1346,6 +1370,9 @@ static const uint8_t *unmarshal_one( func = janet_gcalloc(JANET_MEMORY_FUNCTION, sizeof(JanetFunction) + len * sizeof(JanetFuncEnv)); func->def = NULL; + for (int32_t i = 0; i < len; i++) { + func->envs[i] = NULL; + } *out = janet_wrap_function(func); janet_v_push(st->lookup, *out); data = unmarshal_one_def(st, data, &def, flags + 1); @@ -1399,7 +1426,7 @@ static const uint8_t *unmarshal_one( if (lead == LB_STRUCT_PROTO) { Janet proto; data = unmarshal_one(st, data, &proto, flags + 1); - janet_asserttype(proto, JANET_STRUCT); + janet_asserttype(proto, JANET_STRUCT, st); janet_struct_proto(struct_) = janet_unwrap_struct(proto); } for (int32_t i = 0; i < len; i++) { @@ -1422,7 +1449,7 @@ static const uint8_t *unmarshal_one( if (lead == LB_TABLE_PROTO) { Janet proto; data = unmarshal_one(st, data, &proto, flags + 1); - janet_asserttype(proto, JANET_TABLE); + janet_asserttype(proto, JANET_TABLE, st); t->proto = janet_unwrap_table(proto); } for (int32_t i = 0; i < len; i++) { diff --git a/src/core/pp.c b/src/core/pp.c index 9c897a0b..d8409c2c 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -250,6 +250,10 @@ void janet_to_string_b(JanetBuffer *buffer, Janet x) { case JANET_FUNCTION: { JanetFunction *fun = janet_unwrap_function(x); JanetFuncDef *def = fun->def; + if (def == NULL) { + janet_buffer_push_cstring(buffer, ""); + break; + } if (def->name) { const uint8_t *n = def->name; janet_buffer_push_cstring(buffer, " Date: Sun, 2 Jul 2023 13:13:59 -0500 Subject: [PATCH 136/138] Add test for marshalling channels. --- test/suite-marsh.janet | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/test/suite-marsh.janet b/test/suite-marsh.janet index 79196799..6e840910 100644 --- a/test/suite-marsh.janet +++ b/test/suite-marsh.janet @@ -138,5 +138,13 @@ neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 # XXX: still needed? see 72beeeea (gccollect) +# ev/chan marshalling +(compwhen (dyn 'ev/chan) + (def chan (ev/chan 10)) + (ev/give chan chan) + (def newchan (unmarshal (marshal chan))) + (def item (ev/take newchan)) + (assert (= item newchan) "ev/chan marshalling")) + (end-suite) From e38663c45761308d2b18b6486efd3b808316cd72 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 2 Jul 2023 13:43:34 -0500 Subject: [PATCH 137/138] Update CHANGELOG.md --- CHANGELOG.md | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7ccc67c8..5e55dbb3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,15 @@ # Changelog All notable changes to this project will be documented in this file. +## Unreleased - ??? +- Add new string escape sequences `\\a`, `\\b`, `\\?`, and `\\'`. +- Fix bug with marshalling channels +- Add `div` for floored division +- Make `div` and `mod` variadic +- Support `bnot` for integer types. +- Define `(mod x 0)` as `x` +- Add `ffi/pointer-cfunction` to convert pointers to cfunctions + ## 1.29.1 - 2023-06-19 - Add support for passing booleans to PEGs for "always" and "never" matching. - Allow dictionary types for `take` and `drop` From 026c64fa01090b8489dd6006aa2aa4fcc3e8eb97 Mon Sep 17 00:00:00 2001 From: Calvin Rose Date: Sun, 2 Jul 2023 15:23:22 -0500 Subject: [PATCH 138/138] Formatting. --- src/core/corelib.c | 6 +++--- src/core/vm.c | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/core/corelib.c b/src/core/corelib.c index 4b326496..56b1d41e 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -1174,11 +1174,11 @@ JanetTable *janet_core_env(JanetTable *replacements) { "values.")); templatize_varop(env, JANET_FUN_MODULO, "mod", 0, 1, JOP_MODULO, JDOC("(mod & xs)\n\n" - "Returns the result of applying the modulo operator on the first value of xs with each remaining value. " - "`(mod x 0)` is defined to be `x`.")); + "Returns the result of applying the modulo operator on the first value of xs with each remaining value. " + "`(mod x 0)` is defined to be `x`.")); templatize_varop(env, JANET_FUN_REMAINDER, "%", 0, 1, JOP_REMAINDER, JDOC("(% & xs)\n\n" - "Returns the remainder of dividing the first value of xs by each remaining value.")); + "Returns the remainder of dividing the first value of xs by each remaining value.")); templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND, JDOC("(band & xs)\n\n" "Returns the bit-wise and of all values in xs. Each x in xs must be an integer.")); diff --git a/src/core/vm.c b/src/core/vm.c index 00b9de04..132d8c09 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -720,10 +720,10 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { double x1 = janet_unwrap_number(op1); double x2 = janet_unwrap_number(op2); if (x2 == 0) { - stack[A] = janet_wrap_number(x1); + stack[A] = janet_wrap_number(x1); } else { - double intres = x2 * floor(x1 / x2); - stack[A] = janet_wrap_number(x1 - intres); + double intres = x2 * floor(x1 / x2); + stack[A] = janet_wrap_number(x1 - intres); } vm_pcnext(); } else {