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)