diff options
Diffstat (limited to 'tests/012')
53 files changed, 2386 insertions, 29 deletions
diff --git a/tests/012/aseq.expected b/tests/012/aseq.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/aseq.expected +++ /dev/null diff --git a/tests/012/aseq.tl b/tests/012/aseq.tl index dfb20118..e1a55fb8 100644 --- a/tests/012/aseq.tl +++ b/tests/012/aseq.tl @@ -8,7 +8,11 @@ (:method lambda (me i) (if (rangep i) (mapcar (op + me.n) [me.list i]) - (+ me.n (ref me.list i))))) + (+ me.n (ref me.list i)))) + (:method lambda-set (me i nv) + (if (rangep i) + (set [me.list i] (mapcar (lop - me.n) nv)) + (set [me.list i] (- nv me.n))))) (defvarl o (new (add 3 (range 10 100 10)))) @@ -16,3 +20,8 @@ (test (cadr o) 23) (test [o 4] 53) (test (cadr (last o)) nil) + +(test (set [o 0..3] '(1003 1103 1203)) (1003 1103 1203)) +(test o.list (1000 1100 1200 40 50 60 70 80 90 100)) +(test (del [o 1..4]) (1103 1203 43)) +(test o.list (1000 50 60 70 80 90 100)) diff --git a/tests/012/ashwin.expected b/tests/012/ashwin.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/ashwin.expected +++ /dev/null diff --git a/tests/012/binding.tl b/tests/012/binding.tl new file mode 100644 index 00000000..59c1ff04 --- /dev/null +++ b/tests/012/binding.tl @@ -0,0 +1,5 @@ +(load "../common") + +(test + (mac-env-param-bind '(foo) 42 (:env e :form f x y) '(1 2) (list x y e f)) + (1 2 42 (foo))) diff --git a/tests/012/buf.tl b/tests/012/buf.tl new file mode 100644 index 00000000..01a510ab --- /dev/null +++ b/tests/012/buf.tl @@ -0,0 +1,28 @@ +(load "../common") + +(vtest (uint-buf (make-buf 8 255 16)) (pred (expt 2 64))) +(test (int-buf (make-buf 8 255 16)) -1) + +(mtest + (str-buf #b'E6BC') "\xDCE6\xDCBC" + (buf-str "\xDCE6\xDCBC") #b'E6BC' + (str-buf #b'E6') "\xDCE6" + (buf-str "\xDCE6") #b'E6') + +(when (fboundp 'usr:buf-compress) + (mtest + (< (len (buf-compress (make-buf 1024))) 100) t + (buf-compress (make-buf 1024) -2) :error + (buf-compress (make-buf 1024) 10) :error) + + (each ((i 0..65535)) + (let* ((buf (ffi-put i (ffi uint16))) + (zbuf (buf-compress buf))) + (vtest (buf-decompress zbuf) buf))) + + (let ((buf (random-buf 65536))) + (vtest (buf-decompress (buf-compress buf)) buf)) + + (mtest + (buf-decompress (make-buf 1024)) :error + (buf-decompress (make-buf 1024 255)) :error)) diff --git a/tests/012/cadr.tl b/tests/012/cadr.tl new file mode 100644 index 00000000..509590f7 --- /dev/null +++ b/tests/012/cadr.tl @@ -0,0 +1,14 @@ +(load "../common") + +(mtest + (cxr 1 42) 42 + (cxr #b11 '(a . b)) a + (cxr #b10 '(a . b)) b + (cxr #b11000 '(1 2 3 4 5)) 4 + (cyr #b100001 '(1 2 3 4 5)) 5 + (cyr #b1111 '(((a)))) a + (cyr #b111 '(a)) :error) + +(let ((r (range* 0 100))) + (vtest (mapcar (op cyr (succ (expt 2 (succ @1))) r) 0..100) r) + (vtest (mapcar (op cxr (* 3 (expt 2 @1)) r) 0..100) r)) diff --git a/tests/012/callable.tl b/tests/012/callable.tl new file mode 100644 index 00000000..9e88b955 --- /dev/null +++ b/tests/012/callable.tl @@ -0,0 +1,31 @@ +(load "../common") + +(mtest + [0 '(1 2 3)] 1 + [1 '(1 2 3)] 2 + [2 '(1 2 3)] 3) + +(mtest + [0 "abc"] #\a + [1 "abc"] #\b + [2 "abc"] #\c) + +(mtest + [0..1 '(1 2 3)] (1) + [1..3 '(1 2 3)] (2 3)) + +(mtest + [0..0 "abc"] "" + [0..2 "abc"] "ab" + [-1..: "abc"] "c") + +(test (mapcar [callf list* 2 0 1 3..:] '((A B C X) (D E F Y) (G H I Z))) + ((C A B X) (F D E Y) (I G H Z))) + +(mtest + (set [1 1] 2) :error + (set [1 1..2] 2) :error + (set [1..2 1] 2) :error + (set [1..2 1..2] 2) :error + (let ((abc "abc")) (set [1..2 abc] "42") abc) "a42c" + (let ((abc "abc")) (set [1 abc] #\d) abc) "adc") diff --git a/tests/012/case.tl b/tests/012/case.tl new file mode 100644 index 00000000..856ac56c --- /dev/null +++ b/tests/012/case.tl @@ -0,0 +1,32 @@ +(load "../common") + +(mtest + (caseq 0 (1 :match)) nil + (caseq 0 ((1) :match)) nil + (caseq 1 (1 :match)) :match + (caseq 1 ((1) :match)) :match + (caseq 1 ((0 1) :match)) :match + (caseq 1 ((0 2) :match)) nil + (caseq 1 (t :match)) :match + (caseq 1 ((t) :match)) nil + (caseq t ((t) :match)) :match) + +(defvar o 1) +(defvar y t) + +(mtest + (caseq* 0 (o :match)) nil + (caseq* 0 ((o) :match)) nil + (caseq* 1 (o :match)) :match + (caseq* 1 ((o) :match)) :match + (caseq* 1 ((0 o) :match)) :match + (caseq* 1 ((0 2) :match)) nil + (caseq* 1 (t :match)) :match + (caseq* 1 (y :match)) nil + (caseq* 1 ((t) :match)) nil + (caseq* t ((t) :match)) :match + (caseq* t ((y) :match)) :match) + +(test (casequal '(a b c d) + (((a b c d)) :match)) + :match) diff --git a/tests/012/circ.tl b/tests/012/circ.tl index 4b6e9990..82abe745 100644 --- a/tests/012/circ.tl +++ b/tests/012/circ.tl @@ -5,9 +5,9 @@ (print me.a stream pretty-p) (put-string "]]" stream))) -(defvar x (let* ((l (list "a")) - (c (new circ-print a l))) - (list l c))) +(defvarl x (let* ((l (list "a")) + (c (new circ-print a l))) + (list l c))) (let ((*print-circle* t)) (prinl (new circ-print a "a")) diff --git a/tests/012/compile.tl b/tests/012/compile.tl new file mode 100644 index 00000000..b79d92f4 --- /dev/null +++ b/tests/012/compile.tl @@ -0,0 +1,15 @@ +(defparml %this-dir% (dir-name *load-path*)) +(defparml %expected-file% `@(m^ #/.*[.]/ *load-path*)expected`) + +(file-put-string %expected-file% "") + +(each ((f '#"aseq ashwin circ cont defset except \ + fini ifa man-or-boy oop-mi oop-seq oop \ + parse syms quasi quine seq stslot const type")) + (let ((exf `@{%this-dir%}/@f.expected`)) + (when (path-exists-p exf) + (file-append-string %expected-file% + (file-get-string exf)))) + (with-compile-opts (nil unused) + (compile-file `@f.tl` "temp.tlo")) + (remove-path "temp.tlo")) diff --git a/tests/012/cons.tl b/tests/012/cons.tl new file mode 100644 index 00000000..98267290 --- /dev/null +++ b/tests/012/cons.tl @@ -0,0 +1,35 @@ +(load "../common") + +(mtest + (tree-find "abc" "abc") t + (tree-find "abc" "abc" (fun eq)) nil + (tree-find "b" '("a" "b" "c")) t + (tree-find "b" '("a" "b" "c") (fun eq)) nil + (tree-find "b" '(("b") "a" "c")) t + (tree-find "b" '("a" ("b") "c")) t + (tree-find "b" '("a" (("b")) "c")) t + (tree-find "d" '("a" (("b")) "c")) nil + (tree-find nil '("a" (("b")) "c")) nil) + +(mtest + (cons-find "abc" "abc") t + (cons-find "abc" "ABC" (fun eq)) nil + (cons-find "b" '("a" "b" "c")) t + (cons-find "b" '("a" "b" "c") (fun eq)) nil + (cons-find "b" '(("b") "a" "c")) t + (cons-find "b" '("a" ("b") "c")) t + (cons-find "b" '("a" (("b")) "c")) t + (cons-find "d" '("a" (("b")) "c")) nil + (cons-find "d" '("a" (("b")) "c" . "d")) t + (cons-find "d" '("a" (("b") . "d") "c")) t + (cons-find "d" '("a" . "d")) t + (cons-find nil '("a" (("b")) "c")) t) + +(mtest + (cons-count "abc" "abc") 1 + (cons-count "abc" "abc" (fun eq)) 0 + (cons-count "b" '("b" . "b")) 2 + (cons-count "b" '(3 . "b")) 1 + (cons-count "b" '("b" . 3)) 1 + (cons-count "b" '(("b" . "b") ("b" . "b"))) 4 + (cons-count nil '(1 (2 3 (4)))) 3) diff --git a/tests/012/const.tl b/tests/012/const.tl new file mode 100644 index 00000000..e0235e30 --- /dev/null +++ b/tests/012/const.tl @@ -0,0 +1,23 @@ +(load "../common") + +(mtest + (constantp nil) t + (constantp t) t + (constantp :key) t + (constantp 'a) nil) + +(mtest + (constantp ''a) t + (constantp '(+)) t + (constantp '(+ 2)) t + (constantp '(+ 2 2)) t) + +(mtest + (constantp '(+ a)) nil + (constantp '(+ (* 2 2) (* 3 3))) t + (constantp '(+ (* 2 2) (* 3 a))) nil) + +(mtest + (constantp '(list 1 2 3)) nil + (constantp '(symacrolet ((a 1)) (+ a))) t + (constantp '(let ((a 1)) (+ a))) nil) diff --git a/tests/012/cont.expected b/tests/012/cont.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/cont.expected +++ /dev/null diff --git a/tests/012/cont.tl b/tests/012/cont.tl index 0a728ff9..f6724439 100644 --- a/tests/012/cont.tl +++ b/tests/012/cont.tl @@ -24,8 +24,8 @@ (defun amb (. args) (suspend amb-scope cont (each ((a args)) - (when (and a (call cont a)) - (return-from amb a))))) + (whenlet ((res (and a (call cont a)))) + (return-from amb-scope res))))) (test (amb-scope (let ((w1 (amb "the" "that" "a")) @@ -37,3 +37,16 @@ (eql [w3 -1] [w4 0]))) (list w1 w2 w3 w4))) ("that" "thing" "grows" "slowly")) + +(unless (>= (sizeof wchar) 4) + (exit 0)) + +(test (amb-scope + (let ((🍌 [apply amb (range 95795 95805)]) + (🍏 [apply amb (range 217510 217520)]) + (🍉 [apply amb (range 414555 414570)]) + (🍒 [apply amb (range 422470 422485)])) + (amb (= (+ (expt 🍌 4) (expt 🍏 4) (expt 🍉 4)) + (expt 🍒 4))) + (list 🍌 🍏 🍉 🍒))) + (95800 217519 414560 422481)) diff --git a/tests/012/defset.expected b/tests/012/defset.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/defset.expected +++ /dev/null diff --git a/tests/012/defset.tl b/tests/012/defset.tl index 110f3c64..917c0a9c 100644 --- a/tests/012/defset.tl +++ b/tests/012/defset.tl @@ -19,3 +19,15 @@ (expand '(inc (foo 1 2 :a 3 :b 4) 5)) ^(let ((,%new-val-sym% (+ (foo 1 2 :a 3 :b 4) 5))) (bar 1 2 3 4 () 4 ,%new-val-sym%))) + +(defvarl %data% (vec 0 0 0 0 0 0 0 0 0 1)) +(defun getd (a b c) [%data% (+ a b c)]) +(defun setd (a b c v) (set [%data% (+ a b c)] v)) +(define-accessor getd setd) + +(mtest + (getd 2 3 4) 1 + (set (getd 2 3 4) 2) 2 + [%data% 9] 2 + (inc (getd 2 3 4) 3) 5 + [%data% 9] 5) diff --git a/tests/012/fini.expected b/tests/012/fini.expected index 5e967eb2..72fdc948 100644 --- a/tests/012/fini.expected +++ b/tests/012/fini.expected @@ -2,44 +2,64 @@ inside with-objects base:21 finalized derived:1 derived fini derived:1 finalized +derived:1 derived postfini derived:2 derived fini derived:2 finalized +derived:2 derived postfini derived:3 derived fini derived:3 finalized +derived:3 derived postfini derived:4 derived fini derived:4 finalized +derived:4 derived postfini derived:5 derived fini derived:5 finalized +derived:5 derived postfini derived:6 derived fini derived:6 finalized +derived:6 derived postfini derived:7 derived fini derived:7 finalized +derived:7 derived postfini derived:8 derived fini derived:8 finalized +derived:8 derived postfini derived:9 derived fini derived:9 finalized +derived:9 derived postfini derived:10 derived fini derived:10 finalized +derived:10 derived postfini derived:11 derived fini derived:11 finalized +derived:11 derived postfini derived:12 derived fini derived:12 finalized +derived:12 derived postfini derived:13 derived fini derived:13 finalized +derived:13 derived postfini derived:14 derived fini derived:14 finalized +derived:14 derived postfini derived:15 derived fini derived:15 finalized +derived:15 derived postfini derived:16 derived fini derived:16 finalized +derived:16 derived postfini derived:17 derived fini derived:17 finalized +derived:17 derived postfini derived:18 derived fini derived:18 finalized +derived:18 derived postfini derived:19 derived fini derived:19 finalized +derived:19 derived postfini derived:20 derived fini derived:20 finalized +derived:20 derived postfini after with-objects derived:41 derived fini derived:41 finalized @@ -81,3 +101,31 @@ derived:23 derived fini derived:23 finalized derived:22 derived fini derived:22 finalized +derived:22 derived postfini +derived:23 derived postfini +derived:24 derived postfini +derived:25 derived postfini +derived:26 derived postfini +derived:27 derived postfini +derived:28 derived postfini +derived:29 derived postfini +derived:30 derived postfini +derived:31 derived postfini +derived:32 derived postfini +derived:33 derived postfini +derived:34 derived postfini +derived:35 derived postfini +derived:36 derived postfini +derived:37 derived postfini +derived:38 derived postfini +derived:39 derived postfini +derived:40 derived postfini +derived:41 derived postfini +multi :init: 1 +multi :init: 2 +multi :postinit: 1 +multi :postinit: 2 +multi :fini: 2 +multi :fini: 1 +multi :postfini: 1 +multi :postfini: 2 diff --git a/tests/012/fini.tl b/tests/012/fini.tl index 3aa581f9..506b4c9e 100644 --- a/tests/012/fini.tl +++ b/tests/012/fini.tl @@ -11,7 +11,9 @@ (defstruct derived base (:fini (me) - (put-line `@(typeof me):@{me.id} derived fini`))) + (put-line `@(typeof me):@{me.id} derived fini`)) + (:postfini (me) + (put-line `@(typeof me):@{me.id} derived postfini`))) (unwind-protect (with-objects ((b (new base others (mapcar (ret (new derived)) (range 1 20))))) @@ -19,4 +21,24 @@ (put-line "after with-objects")) (mapcar (ret (new derived)) (range 1 20)) -(sys:gc) +(sys:gc t) + +(defstruct multi () + (:init (me) + (put-line `@{%fun%}: 1`)) + (:init (me) + (put-line `@{%fun%}: 2`)) + (:postinit (me) + (put-line `@{%fun%}: 1`)) + (:postinit (me) + (put-line `@{%fun%}: 2`)) + (:fini (me) + (put-line `@{%fun%}: 1`)) + (:fini (me) + (put-line `@{%fun%}: 2`)) + (:postfini (me) + (put-line `@{%fun%}: 1`)) + (:postfini (me) + (put-line `@{%fun%}: 2`))) + +(with-objects ((m (new multi)))) diff --git a/tests/012/ifa.expected b/tests/012/ifa.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/ifa.expected +++ /dev/null diff --git a/tests/012/ifa.tl b/tests/012/ifa.tl index d669244d..45a2939b 100644 --- a/tests/012/ifa.tl +++ b/tests/012/ifa.tl @@ -10,8 +10,11 @@ (isqrt it))) 7) -;; ambiguous: is "it" x or is "it" y? -(test (let (x y) (ifa (> x y) (print it))) :error) +;; no it-candidates: "it" is leftmost arg x. +(test (let ((x 1) (y 0)) (ifa (> x y) it)) 1) + +;; multiple it-candidates: error +(test (let (x y) (ifa (> (* x x) (* y y)) it)) :error) ;; "it" is (+ 3 (* 2 x)) (test (let ((x 5)) diff --git a/tests/012/iter.tl b/tests/012/iter.tl new file mode 100644 index 00000000..1b1bfd1e --- /dev/null +++ b/tests/012/iter.tl @@ -0,0 +1,92 @@ +(load "../common") + +(mtest + [mapcar identity "A".."D"] ("A" "B" "C" "D") + [mapcar identity "A1".."C2"] ("A1" "A2" "B1" "B2" "C1" "C2") + [mapcar identity "D".."A"] ("D" "C" "B" "A") + [mapcar identity "C2".."A1"] ("C2" "C1" "B2" "B1" "A2" "A1")) + +(test + [maprod append "AA".."DD" "01".."19"] + ("AA01" "AA02" "AA03" "AA04" "AA05" "AA06" "AA07" "AA08" "AA09" + "AA11" "AA12" "AA13" "AA14" "AA15" "AA16" "AA17" "AA18" "AA19" + "AB01" "AB02" "AB03" "AB04" "AB05" "AB06" "AB07" "AB08" "AB09" + "AB11" "AB12" "AB13" "AB14" "AB15" "AB16" "AB17" "AB18" "AB19" + "AC01" "AC02" "AC03" "AC04" "AC05" "AC06" "AC07" "AC08" "AC09" + "AC11" "AC12" "AC13" "AC14" "AC15" "AC16" "AC17" "AC18" "AC19" + "AD01" "AD02" "AD03" "AD04" "AD05" "AD06" "AD07" "AD08" "AD09" + "AD11" "AD12" "AD13" "AD14" "AD15" "AD16" "AD17" "AD18" "AD19" + "BA01" "BA02" "BA03" "BA04" "BA05" "BA06" "BA07" "BA08" "BA09" + "BA11" "BA12" "BA13" "BA14" "BA15" "BA16" "BA17" "BA18" "BA19" + "BB01" "BB02" "BB03" "BB04" "BB05" "BB06" "BB07" "BB08" "BB09" + "BB11" "BB12" "BB13" "BB14" "BB15" "BB16" "BB17" "BB18" "BB19" + "BC01" "BC02" "BC03" "BC04" "BC05" "BC06" "BC07" "BC08" "BC09" + "BC11" "BC12" "BC13" "BC14" "BC15" "BC16" "BC17" "BC18" "BC19" + "BD01" "BD02" "BD03" "BD04" "BD05" "BD06" "BD07" "BD08" "BD09" + "BD11" "BD12" "BD13" "BD14" "BD15" "BD16" "BD17" "BD18" "BD19" + "CA01" "CA02" "CA03" "CA04" "CA05" "CA06" "CA07" "CA08" "CA09" + "CA11" "CA12" "CA13" "CA14" "CA15" "CA16" "CA17" "CA18" "CA19" + "CB01" "CB02" "CB03" "CB04" "CB05" "CB06" "CB07" "CB08" "CB09" + "CB11" "CB12" "CB13" "CB14" "CB15" "CB16" "CB17" "CB18" "CB19" + "CC01" "CC02" "CC03" "CC04" "CC05" "CC06" "CC07" "CC08" "CC09" + "CC11" "CC12" "CC13" "CC14" "CC15" "CC16" "CC17" "CC18" "CC19" + "CD01" "CD02" "CD03" "CD04" "CD05" "CD06" "CD07" "CD08" "CD09" + "CD11" "CD12" "CD13" "CD14" "CD15" "CD16" "CD17" "CD18" "CD19" + "DA01" "DA02" "DA03" "DA04" "DA05" "DA06" "DA07" "DA08" "DA09" + "DA11" "DA12" "DA13" "DA14" "DA15" "DA16" "DA17" "DA18" "DA19" + "DB01" "DB02" "DB03" "DB04" "DB05" "DB06" "DB07" "DB08" "DB09" + "DB11" "DB12" "DB13" "DB14" "DB15" "DB16" "DB17" "DB18" "DB19" + "DC01" "DC02" "DC03" "DC04" "DC05" "DC06" "DC07" "DC08" "DC09" + "DC11" "DC12" "DC13" "DC14" "DC15" "DC16" "DC17" "DC18" "DC19" + "DD01" "DD02" "DD03" "DD04" "DD05" "DD06" "DD07" "DD08" "DD09" + "DD11" "DD12" "DD13" "DD14" "DD15" "DD16" "DD17" "DD18" "DD19")) + +(mtest + [maprod append "A".."F" (drop 1 "00".."15")] + ("A01" "A02" "A03" "A04" "A05" "A10" "A11" "A12" "A13" "A14" "A15" + "B01" "B02" "B03" "B04" "B05" "B10" "B11" "B12" "B13" "B14" "B15" + "C01" "C02" "C03" "C04" "C05" "C10" "C11" "C12" "C13" "C14" "C15" + "D01" "D02" "D03" "D04" "D05" "D10" "D11" "D12" "D13" "D14" "D15" + "E01" "E02" "E03" "E04" "E05" "E10" "E11" "E12" "E13" "E14" "E15" + "F01" "F02" "F03" "F04" "F05" "F10" "F11" "F12" "F13" "F14" "F15") + [maprod append "A".."F" [1..11 "00".."99"]] + ("A01" "A02" "A03" "A04" "A05" "A06" "A07" "A08" "A09" "A10" "B01" + "B02" "B03" "B04" "B05" "B06" "B07" "B08" "B09" "B10" "C01" "C02" + "C03" "C04" "C05" "C06" "C07" "C08" "C09" "C10" "D01" "D02" "D03" + "D04" "D05" "D06" "D07" "D08" "D09" "D10" "E01" "E02" "E03" "E04" + "E05" "E06" "E07" "E08" "E09" "E10" "F01" "F02" "F03" "F04" "F05" + "F06" "F07" "F08" "F09" "F10")) + +(test + [mapcar identity [3..6 0..10]] (3 4 5)) + +;; iterating from fixnum to bignum was rejected in up to txr-269. +(test (each ((x fixnum-max..(* 5 fixnum-max))) (return 42)) 42) + +(test (progn (each ((x "A".."Z")) (sys:gc)) 42) 42) + +(let ((big (* fixnum-max 8))) + (test (progn (each ((x big..(+ 10 big))) (sys:gc)) 42) 42)) + +(mtest + (list-seq 0..5) (0 1 2 3 4) + (list-seq 5..0) (4 3 2 1 0) + (list-seq 0..5.0) (0 1 2 3 4) + (list-seq 5..0.0) (4 3 2 1 0) + (list-seq 0.0..5.0) (0.0 1.0 2.0 3.0 4.0) + (list-seq 5.0..0.0) (4.0 3.0 2.0 1.0 0.0) + (list-seq 0.0..5) (0.0 1.0 2.0 3.0 4.0) + (list-seq 5.0..0) (4.0 3.0 2.0 1.0 0.0) + (list-seq 0.0..5.1) (0.0 1.0 2.0 3.0 4.0 5.0) + (list-seq 0.5..5) (0.5 1.5 2.5 3.5 4.5) + (list-seq (expt 2 256)..(ssucc (expt 2 256))) + (115792089237316195423570985008687907853269984665640564039457584007913129639936 + 115792089237316195423570985008687907853269984665640564039457584007913129639937) + (list-seq (expt 2 256)..(ppred (expt 2 256))) + (115792089237316195423570985008687907853269984665640564039457584007913129639935 + 115792089237316195423570985008687907853269984665640564039457584007913129639934) + (take 3 (list-seq (expt 2 256)..0)) + (115792089237316195423570985008687907853269984665640564039457584007913129639935 + 115792089237316195423570985008687907853269984665640564039457584007913129639934 + 115792089237316195423570985008687907853269984665640564039457584007913129639933)) + diff --git a/tests/012/lambda.tl b/tests/012/lambda.tl new file mode 100644 index 00000000..811dbcfc --- /dev/null +++ b/tests/012/lambda.tl @@ -0,0 +1,162 @@ +(load "../common") + +(defun call-lambda (fn . args) + [fn . args]) + +(defun call-lambda-fixed (fn . args) + (tree-case args + (() [fn]) + ((a1) [fn a1]) + ((a1 a2) [fn a1 a2]) + ((a1 a2 a3) [fn a1 a2 a3]) + ((a1 a2 a3 a4) [fn a1 a2 a3 a4]) + ((a1 a2 a3 a4 a5) [fn a1 a2 a3 a4 a5]) + ((a1 . r) [fn a1 . r]) + ((a1 a2 . r) [fn a1 a2 . r]) + ((a1 a2 a3 . r) [fn a1 a2 a3 . r]) + ((a1 a2 a3 a4 . r) [fn a1 a2 a3 a4 . r]) + ((a1 a2 a3 a4 a5 . r) [fn a1 a2 a3 a4 a5 . r]) + (r [fn . r]))) + +(defmacro ltest (:match :form f) + (([(lambda . @rest) . @args] @expected) + (if *compile-test* + ^(progn + (test [(lambda ,*rest) ,*args] ,expected) + (test (call-lambda (lambda ,*rest) ,*args) ,expected) + (test (call-lambda-fixed (lambda ,*rest) ,*args) ,expected)) + ^(test [(lambda ,*rest) ,*args] ,expected))) + ((@else . rest) (compile-error f "bad syntax"))) + +(defmacro mltest (. pairs) + ^(progn ,*(mapcar (op cons 'ltest) (tuples 2 pairs)))) + +(mltest + [(lambda ())] nil + [(lambda ()) 1] :error + [(lambda (a) a)] :error + [(lambda (a) a) 1] 1 + [(lambda (a) a) 1 2] :error + [(lambda (a b) (list a b)) 1] :error + [(lambda (a b) (list a b)) 1 2] (1 2) + [(lambda (a b) (list a b)) 1 2 3] :error + [(lambda (a b c) (list a b c)) 1 2] :error + [(lambda (a b c) (list a b c)) 1 2 3] (1 2 3) + [(lambda (a b c) (list a b c)) 1 2 3 4] :error) + +(mltest + [(lambda (: a) a)] nil + [(lambda (: (a 1)) a)] 1 + [(lambda (: (a 1)) a) 2] 2 + [(lambda (: (a 1)) a) 2 3] :error + [(lambda (: (a 1 a-p)) (list a a-p))] (1 nil) + [(lambda (: (a 1 a-p)) (list a a-p)) 2] (2 t)) + +(mltest + [(lambda (x : a) (list x a))] :error + [(lambda (x : (a 1)) (list x a))] :error + [(lambda (x : (a 1)) (list x a)) 2] (2 1) + [(lambda (x : (a 1)) (list x a)) 2 3] (2 3) + [(lambda (x : (a 1)) (list x a)) 2 3 4] :error + [(lambda (x : (a 1 a-p)) (list x a a-p))] :error + [(lambda (x : (a 1 a-p)) (list x a a-p)) 2] (2 1 nil)) + +(mltest + [(lambda (x : a) (list x a)) 0] (0 nil) + [(lambda (x : (a 1)) (list x a)) 0] (0 1) + [(lambda (x : (a 1)) (list x a)) 0 2] (0 2) + [(lambda (x : (a 1 a-p)) (list x a a-p)) 0] (0 1 nil) + [(lambda (x : (a 1 a-p)) (list x a a-p)) 0 2] (0 2 t)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r))] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2] (1 2 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8] (1 2 8 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9] (1 2 8 9 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9 0] (1 2 8 9 (0))) + +(defvarl vs '(a)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vs] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vs] (1 a 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vs] (1 2 a 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vs] (1 2 3 a nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vs] (1 2 3 4 (a))) + +(mltest + [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vs] :error + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vs] (1 a 3 4) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 . vs] (1 2 a 4) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 . vs] (1 2 3 a) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 4 . vs] :error) + +(test + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) . vs] :error) + +(mltest + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 . vs] + (1 a 3 nil 4 nil nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 . vs] + (1 2 a t 4 nil nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 . vs] + (1 2 3 t a t nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 . vs] + (1 2 3 t 4 t (a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 5 . vs] + (1 2 3 t 4 t (5 a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 : 4 . vs] + (1 2 3 nil 4 t (a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 : . vs] + (1 2 3 t 4 nil (a))) + +(defvarl vl '(a b c d)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vl] (a b c d nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vl] (1 a b c (d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vl] (1 2 a b (c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vl] (1 2 3 a (b c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vl] (1 2 3 4 (a b c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 5 . vl] (1 2 3 4 (5 a b c d))) + +(mltest + [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vl] (a b c d) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vl] :error) + +(mltest + [(lambda (x : y) (list x y)) 1 :] (1 nil) + [(lambda (x : y z) (list x y z)) 1 :] (1 nil nil) + [(lambda (x : y z) (list x y z)) 1 2 :] (1 2 nil) + [(lambda (x : y z) (list x y z)) 1 nil :] (1 nil nil) + [(lambda (x : y z) (list x y z)) 1 nil nil] (1 nil nil)) + +(mltest + [(lambda (x : (y nil)) (list x y)) 1 :] (1 nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 :] (1 nil nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 2 :] (1 2 nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 nil :] (1 nil nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 nil nil] (1 nil nil)) + +(defvarl vc '(: : : :)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vc] (: : 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vc] (1 : 3 4 (:)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vc] (1 2 3 4 (: :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 . vc] (1 2 0 4 (: : :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 . vc] (1 2 0 0 (: : : :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 5 . vc] (1 2 0 0 (5 : : : :))) + +(test (functionp (lambda (: (n n)) n)) t) + +(defvarl n) + +(ltest + [(lambda (: (n n)) n)] nil) + +(cond + (*compile-test* (exit t)) + (t (set *compile-test* t) + (load (base-name *load-path*)))) diff --git a/tests/012/lazy.tl b/tests/012/lazy.tl new file mode 100644 index 00000000..be04412a --- /dev/null +++ b/tests/012/lazy.tl @@ -0,0 +1,6 @@ +(load "../common") + +(test [mapcar* list nil] nil) +(test [mapcar* list '(1)] ((1))) +(test [mapcar* list '(1 2 3)] ((1) (2) (3))) +(test [mapcar* list '(1 2 3) '(a b c)] ((1 a) (2 b) (3 c))) diff --git a/tests/012/less.tl b/tests/012/less.tl new file mode 100644 index 00000000..11748c7f --- /dev/null +++ b/tests/012/less.tl @@ -0,0 +1,21 @@ +(load "../common") + +(mtest + (less #() #(a)) t + (greater #() #(a)) nil + (less #(0) #(1)) t + (greater #(0) #(1)) nil + (less #(1) #(0)) nil + (greater #(1) #(0)) t + (less #(0) #(0 0)) t + (less #(1) #(0 0)) nil + (less #(0 0) #(0 1)) t + (less #(0 0) #(0 0)) nil + (less #(0 0) #(0 0 0)) t) + +(mtest + (less '() #()) t + (less '(0) #(0)) t + (less "a" #(#\a)) t + (less #() #b'') t + (less #(0) #b'00') t) diff --git a/tests/012/oop-dsc.tl b/tests/012/oop-dsc.tl new file mode 100644 index 00000000..7885f386 --- /dev/null +++ b/tests/012/oop-dsc.tl @@ -0,0 +1,80 @@ +(load "../common") + +(define-struct-clause :nothing (. ignored-args)) + +(defstruct s0 () + (:nothing 1 "foo" :junk) + x) + +(test (new s0) #S(s0 x nil)) + +(define-struct-clause :multi (init-val . names) + (mapcar (lop list init-val) names)) + +(defstruct s1 () + (:multi 0 a b c)) + +(test (new s1) #S(s1 a 0 b 0 c 0)) + +(define-struct-clause :getset (slot getter setter : init-val) + ^((,slot ,init-val) + (:method ,getter (obj) obj.,slot) + (:method ,setter (obj new) (set obj.,slot new)))) + +(defstruct s2 () + (:getset a get-a set-a 0) + (:getset b get-b set-b 0)) + +(let ((s2 (new s2))) + (mtest + s2.a 0 + s2.b 0 + s2.(get-a) 0 + s2.(get-b) 0 + s2.(set-a 42) 42 + s2.(set-b 73) 73 + s2.a 42 + s2.b 73 + s2.(get-a) 42 + s2.(get-b) 73)) + +(define-struct-clause :hash (hash-name by-slot) + ^((:static ,hash-name (hash)) + (:postinit (me) + (set [me.,hash-name me.,by-slot] me)) + (:postfini (me) + (del [me.,hash-name me.,by-slot])))) + +(defstruct s3 () + a b + (:hash a-hash a) + (:hash b-hash b)) + +(let* ((s3-list (list (new s3 a "one" b 1) + (new s3 a "two" b 2) + (new s3 a "three" b 3))) + (s3 (first s3-list))) + (mtest + [s3.a-hash "one"].a "one" + [s3.a-hash "two"].b 2 + [s3.a-hash "three"].b 3 + [s3.b-hash 1].a "one" + [s3.b-hash 2].b 2 + [s3.b-hash 3].a "three") + (call-finalizers s3) + (test [s3.a-hash "one"] nil)) + +(define-struct-clause :s3 () + '((:inherit s3) + (:inherit passwd group))) + +(defstruct s4 (time) + (:s3)) + +(let ((s4 (new s4 a "x" b 999))) + (mtest + [s4.a-hash "two"].a "two" + [s4.a-hash "x"].a "x" + [s4.b-hash 999].a "x" + s4.uid nil + s4.gid nil)) diff --git a/tests/012/oop-mac.tl b/tests/012/oop-mac.tl new file mode 100644 index 00000000..d3c3e480 --- /dev/null +++ b/tests/012/oop-mac.tl @@ -0,0 +1,18 @@ +(load "../common") + +(test (with-resources ((a nil (list a)) + (b nil) + (c nil (list c))) + (list a b c)) + (nil nil nil)) + +(test (build + (catch + (with-resources ((a 1 (add a)) + (x nil) + (b 2 (add b)) + (y (throw 'out)) + (z nil t) + (c 3 (add c)))) + (out () (add 4)))) + (2 1 4)) diff --git a/tests/012/oop-mi.expected b/tests/012/oop-mi.expected index 6d112c2e..ebc807f3 100644 --- a/tests/012/oop-mi.expected +++ b/tests/012/oop-mi.expected @@ -1,7 +1,7 @@ -#S(der0 gx gx gy dgy x dx y dy z dz) +#S(der0 li (b1 b2 g) gx gx gy dgy x dx y dy z dz) dgs0 gs1-b1 -#S(der1 x b3x gx b3gx gy gy y b2y) +#S(der1 x b3x gx b3gx li (b1 b2 g) gy gy y b2y) gs0 gs1-b1 (meth base3 b3m0) @@ -15,3 +15,11 @@ gm base1 base2 grand +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b2 b1 g) +(gf b1f b2f b2 b1 g) diff --git a/tests/012/oop-mi.tl b/tests/012/oop-mi.tl index 4431f23d..0e54086a 100644 --- a/tests/012/oop-mi.tl +++ b/tests/012/oop-mi.tl @@ -1,8 +1,11 @@ (load "../common") (defstruct grand nil + (li 'nil) (gx 'gx) (gy 'gy) + (:init (me) (push 'g me.li)) + (:fini (me) (push 'gf me.li)) (:static gs0 'gs0) (:static gs1 'gs1) (:method gm (me) 'gm)) @@ -12,11 +15,15 @@ (defstruct base1 grand (x 'b1x) + (:init (me) (push 'b1 me.li)) + (:fini (me) (push 'b1f me.li)) (:static gs1 'gs1-b1) (:method m (me) 'm1)) (defstruct base2 grand (y 'b2y) + (:init (me) (push 'b2 me.li)) + (:fini (me) (push 'b2f me.li)) (:static gs1 'gs1-b2) (:method m (me) 'm2)) @@ -63,3 +70,9 @@ (prinl (static-slot-home 'der2 'm)) (prinl (static-slot-home 'der3 'm)) (prinl (static-slot-home 'der3 'gm)) + +(each ((ty '(der0 der1 der2 der3))) + (let ((ob (new* ty))) + (prinl ob.li) + (call-finalizers ob) + (prinl ob.li))) diff --git a/tests/012/oop-prelude.expected b/tests/012/oop-prelude.expected new file mode 100644 index 00000000..daf379e0 --- /dev/null +++ b/tests/012/oop-prelude.expected @@ -0,0 +1,5 @@ +#S(fox) created +#S(bear) created +inside with-object +#S(bear) finalized +#S(fox) finalized diff --git a/tests/012/oop-prelude.tl b/tests/012/oop-prelude.tl new file mode 100644 index 00000000..bb0b3d44 --- /dev/null +++ b/tests/012/oop-prelude.tl @@ -0,0 +1,13 @@ +(load "../common") + +(define-struct-prelude init-fini-log (fox bear) + (:init (me) (put-line `@me created`)) + (:fini (me) (put-line `@me finalized`))) + +(defstruct fox ()) + +(defstruct bear ()) + +(with-objects ((f (new fox)) + (b (new bear))) + (put-line "inside with-object")) diff --git a/tests/012/oop-seq.tl b/tests/012/oop-seq.tl new file mode 100644 index 00000000..17463e96 --- /dev/null +++ b/tests/012/oop-seq.tl @@ -0,0 +1,87 @@ +(load "../common") + +(defstruct counter-iter-fast () + cur-val + step + limit + (:method iter-item (me) + me.cur-val) + (:method iter-step (me) + (inc me.cur-val me.step) + (if (< me.cur-val me.limit) me))) + +(defstruct counter-fast () + init + step + limit + (:method iter-begin (me) + (if (< me.init me.limit) + (new counter-iter-fast + cur-val me.init + step me.step + limit me.limit)))) + +(defstruct counter-iter-canon () + cur-val + step + limit + (:method iter-item (me) + me.cur-val) + (:method iter-more (me) + (< me.cur-val me.limit)) + (:method iter-step (me) + (inc me.cur-val me.step) + me)) + +(defstruct counter-canon () + init + step + limit + (:method iter-begin (me) + (new counter-iter-canon + cur-val me.init + step me.step + limit me.limit))) + +(test (list-seq (new counter-canon init 0 step 2 limit 10)) + (0 2 4 6 8)) + +(test (list-seq (new counter-fast init 0 step 2 limit 10)) + (0 2 4 6 8)) + +(test (list-seq (new counter-canon init 0 step 1 limit 0)) + nil) + +(test (list-seq (new counter-fast init 0 step 1 limit 0)) + nil) + +(defstruct integers () + item to next + (:method length-< (me len) + (cond + ((<= len 1) nil) + (me.next me.next.(length-< (pred len))) + (t))) + (:postinit (me) + (if (< me.item me.to) + (set me.next (lnew integers to me.to item (succ me.item)))))) + +(let ((ints (new integers item 1 to 10))) + (mtest + (length-< ints 11) t) + (length-< ints 10) nil + (length-< ints 9) nil) + +;; The following reproduced a segfault when the change was made to allow del to +;; work with structs that have lambda and lambda-set. + +(defstruct blah () + (:method lambda-set (me . args))) + +(defparm o (new blah)) + +(set [o 1..20] 42) + +(defmeth blah lambda (me . args)) + +(set [o 1..20] 42) diff --git a/tests/012/oop.tl b/tests/012/oop.tl index 51dadbf3..5cdd3ec3 100644 --- a/tests/012/oop.tl +++ b/tests/012/oop.tl @@ -2,7 +2,7 @@ (defstruct animal nil (:function whoami () "n/a") - (:method print (self stream : pretty-p) (put-string self.[whoami] stream))) + (:method print (self stream : pretty-p) (put-string [self.whoami] stream))) (defstruct dog animal (:function whoami () "dog")) @@ -77,3 +77,75 @@ (prinl d) (prinl (list b.sa b.sb b.sc b.x b.y)) (prinl (list d.sa d.sb d.sc d.x d.y))) + +(defstruct (ab a : b) () a b) + +(defvar foo) + +(mtest + (new* (foo 'ab) a 1) :error + (new* ((find-struct-type 'ab)) a 1) #S(ab a 1 b nil) + (new* [find-struct-type 'ab] a 1) #S(ab a 1 b nil) + (new* ([find-struct-type 'ab] 1 2)) #S(ab a 1 b 2) + (new* ((find-struct-type 'ab) 1 2)) #S(ab a 1 b 2) + (new* ([find-struct-type 'ab] 1) b 2) #S(ab a 1 b 2) + (let ((type (find-struct-type 'ab))) + (new* type a 3 b 4)) #S(ab a 3 b 4) + (let ((type (find-struct-type 'ab))) + (new* (type 3 4))) #S(ab a 3 b 4)) + +(defstruct worker () + name + (:method work (me) `worker @{me.name} works`) + (:method relax (me : (min 15)) `worker @{me.name} relaxes for @min min`)) + +(defstruct contractor () + sub + (:delegate work (me) me.sub.sub) + (:delegate break (me : min) me.sub.sub relax) + (:delegate break20 (me : (min 20)) me.sub.sub relax)) + +(let ((co (new contractor sub (new contractor sub (new worker name "foo"))))) + (mtest co.(work) "worker foo works" + co.(break) "worker foo relaxes for 15 min" + co.(break 5) "worker foo relaxes for 5 min" + co.(break20 5) "worker foo relaxes for 5 min" + co.(break20) "worker foo relaxes for 20 min")) + +(test + (defstruct bad-delegate () + (:delegate del (x : (y z w)))) + :error) + +(defstruct api-x () + (:method get (x a b : c . d) ^(api-x get ,x ,a ,b ,c ,d)) + (:method put (x s) ^(api-x put ,x ,s))) + +(defstruct api-y () + (:method frob (y r : s) ^(api-y frob ,y ,r ,s)) + (:method tweak (y) ^(api-y tweak ,y))) + +(defstruct api-z () + (:method decrement (z n) ^(api-z decrement ,z ,n)) + (:method increment (z n) ^(api-z increment ,z ,n))) + +(defstruct component () + (ax (new api-x)) + (ay (new api-y)) + (az (new api-z)) + (:mass-delegate o o.ax api-x *) + (:mass-delegate o o.ay api-y frob) + (:mass-delegate o o.az api-z * decrement)) + +(let ((c (new component))) + (mtest + c.(get 1 2 3 . 4) (api-x get #S(api-x) 1 2 3 4) + c.(put 5) (api-x put #S(api-x) 5) + c.(get) :error + c.(put 5 6) :error + c.(frob 7 8) (api-y frob #S(api-y) 7 8) + c.(frob 9) (api-y frob #S(api-y) 9 nil) + c.(frob 7 8 9) :error + c.(tweak) :error + c.(increment 1) (api-z increment #S(api-z) 1) + c.(decrement) :error)) diff --git a/tests/012/op.tl b/tests/012/op.tl new file mode 100644 index 00000000..47f1f80d --- /dev/null +++ b/tests/012/op.tl @@ -0,0 +1,127 @@ +(load "../common") + +(defun fi (fun) + (assert (zerop (fun-optparam-count fun))) + (list (fun-fixparam-count fun) + (fun-variadic fun))) + +(mtest + (fi (op)) :error + (fi (op list)) (0 t) + (fi (op list @1)) (1 t) + (fi (op list @2)) (2 t) + (fi (op list @42)) (42 t) + (fi (op list @rest)) (0 t) + (fi (op list @1 @rest)) (1 t) + (fi (op list @2 @rest)) (2 t) + (fi (op list @42 @rest)) (42 t) + (fi (op list @1 @3 @rest @2)) (3 t)) + +(mtest + (fi (do)) :error + (fi (do progn)) (1 t) + (fi (do progn @1)) (1 t) + (fi (do progn @2)) (2 t) + (fi (do progn @42)) (42 t) + (fi (do progn @rest)) (0 t) + (fi (do progn @1 @rest)) (1 t) + (fi (do progn @2 @rest)) (2 t) + (fi (do progn @42 @rest)) (42 t) + (fi (do progn @1 @3 @rest @2)) (3 t)) + +(mtest + (fi (do if)) (1 t) + (fi (do if @1)) (1 t) + (fi (do if @2)) (2 t) + (fi (do if @42)) (42 t) + (fi (do if @rest)) (0 t) + (fi (do if @1 @rest)) (1 t) + (fi (do if @2 @rest)) (2 t) + (fi (do if @42 @rest)) (42 t) + (fi (do if @1 @3 @rest @2)) (3 t)) + +(mtest + [(do quote x) 3] :error + [(do quote @1) 3] :error + (do pop a) :error) + +(defun y (f) + [(op @1 @1) + (op f (op [@@1 @@1]))]) + +(defun fac (f) + (do if (zerop @1) + 1 + (* @1 [f (- @1 1)]))) + +(defun fac-y (n) + [(y (do do if (zerop @1) + 1 + (* @1 [@@1 (- @1 1)]))) n]) + +(defun fac-r (n) + [(do if (zerop @1) 1 (* @1 [@rec (pred @1)])) n]) + +(defun fac-r2 (n) + [(do if (zerop @1) 1 (* @1 @(rec (pred @1)))) n]) + +(mtest + [[y fac] 4] 24 + (fac-y 4) 24 + (fac-r 4) 24 + (fac-r2 4) 24) + +(mtest + (flow 1 (+ 2) [dup *] (let ((x @1)) x)) 9 + (flow #S(time year 2021) .year succ) 2022) + +(mtest + [[(do op list)] 2] :error + [[(do op list) 2]] (2) + [[(do op list @@1) 1] 2] (1 2) + [[(do op list @1)] 2] :error + [[(do op list @1) 1] 2] (2 1) + [[(do op list @@1 @1) 1] 2] (1 2)) + +(mtest + [[[[(do do do op list @1) 1] 2] 3] 4] (4 1 2 3) + [[[[(do do do op list @@1) 1] 2] 3] 4] (3 1 2 4) + [[[[(do do do op list @@@1) 1] 2] 3] 4] (2 1 3 4) + [[[[(do do do op list @@@@1) 1] 2] 3] 4] (1 2 3 4)) + +(mtest + [[[[(do do do op list) 1] 2] 3] 4] (1 2 3 4) + [[[[(do do do op list @1 @@1 @@@1 @@@@1) 1] 2] 3] 4] (4 3 2 1) + [[[[(do do do op list @@@@1 @@@1 @@1 @1) 1] 2] 3] 4] (1 2 3 4)) + +(test (flow (range 1000 9999) + (keep-if (opip digits (ap > (+ @2 @3) (+ @1 @4)))) + (partition-if (op neq 1 (- @2 @1))) + (find-max-key @1 : len)) + 80) + +(mtest + (flow 1 (+ 1) (let x) (+ 2) (let y) (+ 3) (list x y @1)) (2 4 7) + (flow 10 (+ 1) (let (x @1) (y (* x 2))) (+ x y)) 44 + (flow 10 (+ 1) (let ((x @1) (y (* @1 2))) (+ x y))) 33 + (flow 10 (+ 1) (let ((x @1) (y (* @1 2))))) nil) + +(mtest + (lflow 10 (- 1) (- 1)) 8 + (lflow 10 (op - 100) (+ 1)) 91) + +(mtest + (remove-if (opf orf (< 10) (> 5)) (range 0 20)) (5 6 7 8 9 10) + (remove-if (lopf orf (> 10) (< 5)) (range 0 20)) (5 6 7 8 9 10)) + +(test + (let ((x 0) (y 0)) + (list (flow x + (+ 2) + (tap inc y @1) + (* 4) + (tap inc y @1) + (+ 5) + (tap inc y @1)) + y)) + (13 23)) diff --git a/tests/012/parse.tl b/tests/012/parse.tl new file mode 100644 index 00000000..6d091b00 --- /dev/null +++ b/tests/012/parse.tl @@ -0,0 +1,66 @@ +(load "../common") + +(unless (< (sizeof wchar) 4) + (test (read `"@(str-buf #b'EDB081')"`) + "\xDCED\xDCB0\xDC81") + + (test (read `"@(str-buf #b'F3FF')"`) + "\xDCF3\xDCFF") + + (test (regex-parse (str-buf #b'EDB081')) + (compound "\xDCED\xDCB0\xDC81")) + + (test (regex-parse (str-buf #b'F3FF')) + (compound #\xDCF3 #\xDCFF))) + +(mtest + (read "0") 0 + (read "0x") 0x + (read "a") a + (read "abc") abc + (read "abc.def") abc.def + (read "(1 2 3)") (1 2 3) + (read "#;(1 2 3) 4") 4 + (read "#;(1 2 3) #; a.b 4") 4 + (read "0 ") 0 + (read "0x ") 0x + (read "a ") a + (read "abc ") abc + (read "abc.def ") abc.def + (read "(1 2 3) ") (1 2 3) + (read "#;(1 2 3) 4 ") 4 + (read "#;(1 2 3) #; a.b 4 ") 4 + (read "0,") :error + (read "0x,") :error + (read "a,") :error + (read "abc,") :error + (read "abc.def,") :error + (read "(1 2 3),") :error + (read "#;(1 2 3) 4,") :error + (read "#;(1 2 3) #; a.b 4,") :error) + +(mtest + (iread "0") 0 + (iread "0x") 0x + (iread "a") a + (iread "abc") abc + (iread "abc.def") abc + (iread "(1 2 3)") (1 2 3) + (iread "#;(1 2 3) 4") 4 + (iread "#;(1 2 3) #; a.b 4") .b + (iread "0 ") 0 + (iread "0x ") 0x + (iread "a ") a + (iread "abc ") abc + (iread "abc.def ") abc + (iread "(1 2 3) ") (1 2 3) + (iread "#;(1 2 3) 4 ") 4 + (iread "#;(1 2 3) #; a.b 4 ") .b + (iread "0,") 0 + (iread "0x,") 0x + (iread "a,") a + (iread "abc,") abc + (iread "abc.def,") abc + (iread "(1 2 3),") (1 2 3) + (iread "#;(1 2 3) 4,") 4 + (iread "#;(1 2 3) #; a.b 4,") .b) diff --git a/tests/012/quasi.expected b/tests/012/quasi.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/quasi.expected +++ /dev/null diff --git a/tests/012/quasi.tl b/tests/012/quasi.tl index 276d5395..1cb24578 100644 --- a/tests/012/quasi.tl +++ b/tests/012/quasi.tl @@ -36,3 +36,18 @@ (let ((s)) (mapcar (ret `<@{(push (inc @1) s) d}>`) (range 0 2)))) ("<1>" "<2-1>" "<3-2-1>")) + +(test + (symacrolet ((two 2)) + `@{two}abc`) + "2abc") + +(test + (macrolet ((two () 2)) + `@(two)abc`) + "2abc") + +(compile-only + (eval-only + (compile-file (base-name *load-path*) "temp.tlo") + (remove-path "temp.tlo"))) diff --git a/tests/012/quine.expected b/tests/012/quine.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/quine.expected +++ /dev/null diff --git a/tests/012/readprint.tl b/tests/012/readprint.tl new file mode 100644 index 00000000..4298a85b --- /dev/null +++ b/tests/012/readprint.tl @@ -0,0 +1,13 @@ +(load "../common") + +(mstest + '[ . a] "[. a]" + '[. a] "[. a]" + '[ . @a] "[. @a]" + '[. @a] "[. @a]" + '[] "[]" + '[. 3] "[. 3]" + '[3 . 4] "[3 . 4]" + '(dwim) "[]" + '(dwim . 3) "[. 3]" + '(dwim 3 . 4) "[3 . 4]") diff --git a/tests/012/seq.expected b/tests/012/seq.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/seq.expected +++ /dev/null diff --git a/tests/012/seq.tl b/tests/012/seq.tl index 9c3821d1..262c7739 100644 --- a/tests/012/seq.tl +++ b/tests/012/seq.tl @@ -13,7 +13,873 @@ (test (build (add 1) (add 2) (pend (get) (get))) (1 2 1 2 1 2)) (test (build (add 1) (add 2) (pend* (get) (get))) (1 2 1 2 1 2)) +(mtest + (build (add 1 2) (oust)) nil + (build (add 1 2) (oust '(3 4)) (add 5)) (3 4 5) + (build (add 1 2) (oust '(3 4) '(5)) (add 6)) (3 4 5 6)) + (set *print-circle* t) (stest (build (add 1) (add 2) (ncon (get))) "#1=(1 2 . #1#)") (stest (build (add 1) (add 2) (ncon* (get))) "#1=(1 2 . #1#)") + +(test (mapcar (lambda (. args) (list . args)) '#(1 2 3) '#(4 5 6)) + #((1 4) (2 5) (3 6))) + +(test [window-map 2 '(x x) list '(a b c d e f g)] + ((x x a b c) (x a b c d) (a b c d e) + (b c d e f) (c d e f g) (d e f g nil) + (e f g nil nil))) + +(test [window-map 2 '(x x y y) list '(a b c d e f g)] + ((x x a b c) (x a b c d) (a b c d e) + (b c d e f) (c d e f g) (d e f g y) + (e f g y y))) + +(test [window-map 2 nil list '(a b c d e f g)] + ((nil nil a b c) (nil a b c d) (a b c d e) + (b c d e f) (c d e f g) + (d e f g nil) (e f g nil nil))) + +(test [window-map 2 :wrap list '(a b c d e f g)] + ((f g a b c) (g a b c d) (a b c d e) (b c d e f) + (c d e f g) (d e f g a) (e f g a b))) + +(test [window-map 2 :reflect list '(a b c d e f g)] + ((b a a b c) (a a b c d) (a b c d e) (b c d e f) + (c d e f g) (d e f g g) (e f g g f))) + +(test [window-map 7 :wrap list '(a b c)] + ((c a b c a b c a b c a b c a b) + (a b c a b c a b c a b c a b c) + (b c a b c a b c a b c a b c a))) + +(test [window-map 7 :reflect list '(a b c)] + ((a c b a c b a a b c c b a c b) + (c b a c b a a b c c b a c b a) + (b a c b a a b c c b a c b a c))) + +(test [window-map 1 nil (lambda (x y z) + (if (and (eq x #\<) + (eq z #\>)) + (chr-toupper y) + y)) + "ab<c>de<f>g"] + "ab<C>de<F>g") + +(test [window-mappend 1 :reflect (lambda (x y z) + (if (< x y z) + (list y))) + '(1 2 1 3 4 2 1 9 7 5 7 8 5)] + (3 7)) + +(test [window-map 2 #(0 0 0 0) + (lambda (. args) (/ (sum args) 5)) + #(4 7 9 13 5 1 6 11 10 3 8)] + #(4.0 6.6 7.6 7.0 6.8 7.2 6.6 6.2 7.6 6.4 4.2)) + +(mtest + [reduce-left + () 0] 0 + [reduce-left + ()] 0 + [reduce-left cons ()] :error + [reduce-left cons '(1)] 1 + [reduce-left cons #(1)] 1 + [reduce-left cons #(1) : (op * 10)] 10 + [reduce-left cons #(1) 2 (op * 10)] (2 . 10) + [reduce-left cons #(2 3) 10 (op * 10)] ((10 . 20) . 30)) + +(mtest + (starts-with "" "") t + (starts-with "" "a") t + (starts-with "a" "") nil + (starts-with "a" "a") t + (starts-with "" "abc") t + (starts-with "abc" "") nil + (starts-with "abc" "abc") t + (starts-with "ab" "abc") t + (starts-with "bc" "abc") nil + ) + +(mtest + (ends-with "" "") t + (ends-with "" "a") t + (ends-with "a" "") nil + (ends-with "a" "a") t + (ends-with "" "abc") t + (ends-with "abc" "") nil + (ends-with "abc" "abc") t + (ends-with "ab" "abc") nil + (ends-with "bc" "abc") t) + +(mtest + (rmismatch #() #()) nil + (rmismatch #(1) #()) -1 + (rmismatch #() #(1)) -1 + (rmismatch #(1) #(1)) nil + (rmismatch #(1 2) #(1 2)) nil + (rmismatch #(2 2) #(1 2)) -2 + (rmismatch #(1 2) #(2 2)) -2 + (rmismatch #(3 2 1) #(1 1)) -2 + (rmismatch #(1 1) #(3 2 1)) -2 + (rmismatch #(3 2 1) #(2 1)) -3 + (rmismatch #(2 1) #(3 2 1)) -3) + +(mtest + (rmismatch '() '()) nil + (rmismatch '(1) '()) -1 + (rmismatch '() '(1)) -1 + (rmismatch '(1) '(1)) nil + (rmismatch '(1 2) '(1 2)) nil + (rmismatch '(2 2) '(1 2)) -2 + (rmismatch '(1 2) '(2 2)) -2 + (rmismatch '(3 2 1) '(1 1)) -2 + (rmismatch '(1 1) '(3 2 1)) -2 + (rmismatch '(3 2 1) '(2 1)) -3 + (rmismatch '(2 1) '(3 2 1)) -3) + +(mtest + (rmismatch '() #()) nil + (rmismatch '(1) #()) -1 + (rmismatch '() #(1)) -1 + (rmismatch '(1) #(1)) nil + (rmismatch '(1 2) #(1 2)) nil + (rmismatch '(2 2) #(1 2)) -2 + (rmismatch '(1 2) #(2 2)) -2 + (rmismatch '(3 2 1) #(1 1)) -2 + (rmismatch '(1 1) #(3 2 1)) -2 + (rmismatch '(3 2 1) #(2 1)) -3 + (rmismatch '(2 1) #(3 2 1)) -3) + +(mtest + (rmismatch #() '()) nil + (rmismatch #(1) '()) -1 + (rmismatch #() '(1)) -1 + (rmismatch #(1) '(1)) nil + (rmismatch #(1 2) '(1 2)) nil + (rmismatch #(2 2) '(1 2)) -2 + (rmismatch #(1 2) '(2 2)) -2 + (rmismatch #(3 2 1) '(1 1)) -2 + (rmismatch #(1 1) '(3 2 1)) -2 + (rmismatch #(3 2 1) '(2 1)) -3 + (rmismatch #(2 1) '(3 2 1)) -3) + +(mtest + (rmismatch "" "") nil + (rmismatch "1" "") -1 + (rmismatch "" "1") -1 + (rmismatch "1" "1") nil + (rmismatch "12" "12") nil + (rmismatch "22" "12") -2 + (rmismatch "12" "22") -2 + (rmismatch "321" "11") -2 + (rmismatch "11" "321") -2 + (rmismatch "321" "21") -3 + (rmismatch "21" "321") -3) + +(mtest + [keep-if oddp (range 1 10)] (1 3 5 7 9) + [keep-if oddp nil] nil + [keep-if oddp #()] #() + [keep-if oddp #(1)] #(1) + [keep-if oddp #(2)] #() + [keep-if chr-isalpha "a1b2c3d"] "abcd" + [keep-if chr-isalpha ""] "" + [keep-if chr-isalpha "abc"] "abc" + [keep-if chr-isalpha "1234"] "") + +(mtest + [remove-if oddp (range 1 10)] (2 4 6 8 10) + [remove-if oddp nil] nil + [remove-if oddp #()] #() + [remove-if oddp #(1)] #() + [remove-if oddp #(2)] #(2) + [remove-if chr-isalpha "a1b2c3d"] "123" + [remove-if chr-isalpha ""] "" + [remove-if chr-isalpha "1234"] "1234" + [remove-if chr-isalpha "abcd"] "") + +(mtest + [keep-if* chr-isalpha ""] nil + [keep-if* chr-isalpha "abcd"] (#\a #\b #\c #\d) + (take 3 [keep-if* oddp (range 1)]) (1 3 5)) + +(mtest + [remove-if* chr-isalpha ""] nil + [remove-if* chr-isalpha "abcd"] nil + [remove-if* chr-isdigit "a1b2c3d4"] (#\a #\b #\c #\d) + (take 3 [remove-if* oddp (range 1)]) (2 4 6)) + +(mtest + [separate oddp (range 1 10)] ((1 3 5 7 9) (2 4 6 8 10)) + [separate integerp (range 1 10)] ((1 2 3 4 5 6 7 8 9 10) ()) + [separate chrp (range 1 10)] (() (1 2 3 4 5 6 7 8 9 10)) + [separate oddp (vec-list (range 1 10))] (#(1 3 5 7 9) #(2 4 6 8 10)) + [separate chr-isalpha "a1b2c3d4"] ("abcd" "1234") + [separate chrp "a1b2c3d4"] ("a1b2c3d4" "") + [separate integerp "a1b2c3d4"] ("" "a1b2c3d4")) + +(mtest + (tuples 0 nil) :error + (tuples 3.5 '(1 2 3)) :error + (tuples -1 "abc") :error) + +(mtest + (tuples 1 nil) nil + (tuples 1 "") nil + (tuples 1 #()) nil) + +(mtest + (tuples 1 '(a)) ((a)) + (tuples 1 "a") ("a") + (tuples 1 #(1)) (#(1))) + +(mtest + (tuples 1 '(a b c)) ((a) (b) (c)) + (tuples 1 "abc") ("a" "b" "c") + (tuples 1 #(1 2 3)) (#(1) #(2) #(3))) + +(mtest + (tuples 1 '(a b c) 'd) ((a) (b) (c)) + (tuples 1 "abc" #\d) ("a" "b" "c") + (tuples 1 #(1 2 3) 4) (#(1) #(2) #(3))) + +(mtest + (tuples 2 '(a b c)) ((a b) (c)) + (tuples 2 "abc") ("ab" "c") + (tuples 2 #(1 2 3)) (#(1 2) #(3))) + +(mtest + (tuples 3 '(a b c)) ((a b c)) + (tuples 3 "abc") ("abc") + (tuples 3 #(1 2 3)) (#(1 2 3))) + +(mtest + (tuples 2 '(a b c) 'd) ((a b) (c d)) + (tuples 2 "abc" #\d) ("ab" "cd") + (tuples 2 #(1 2 3) 4) (#(1 2) #(3 4))) + +(defun lforce (list) + [mapdo identity list] + list) + +(test + (lforce (tuples 2 "abc" 3)) ("ab" (#\c 3))) + +(test + (take 3 (tuples 3 (range 0))) ((0 1 2) (3 4 5) (6 7 8))) + +(mtest + (tuples* 0 nil) :error + (tuples* 3.5 '(1 2 3)) :error + (tuples* -1 "abc") :error) + +(mtest + (tuples* 1 nil) nil + (tuples* 1 "") nil + (tuples* 1 #()) nil) + +(mtest + (tuples* 1 '(a)) ((a)) + (tuples* 1 "a") ("a") + (tuples* 1 #(1)) (#(1))) + +(mtest + (tuples* 1 '(a b c)) ((a) (b) (c)) + (tuples* 1 "abc") ("a" "b" "c") + (tuples* 1 #(1 2 3)) (#(1) #(2) #(3))) + +(mtest + (tuples* 1 '(a b c) 'd) ((a) (b) (c)) + (tuples* 1 "abc" #\d) ("a" "b" "c") + (tuples* 1 #(1 2 3) 4) (#(1) #(2) #(3))) + +(mtest + (tuples* 2 '(a b c)) ((a b) (b c)) + (tuples* 2 "abc") ("ab" "bc") + (tuples* 2 #(1 2 3)) (#(1 2) #(2 3))) + +(mtest + (tuples* 3 '(a b c)) ((a b c)) + (tuples* 3 "abc") ("abc") + (tuples* 3 #(1 2 3)) (#(1 2 3))) + +(mtest + (tuples* 3 '(a b) 'c) ((a b c)) + (tuples* 3 "a" #\c) ("acc") + (tuples* 3 #() 1) (#(1 1 1))) + +(test + (lforce (tuples* 3 "a" 1)) :error) + +(mtest + (take 3 (tuples* 3 (range 0))) ((0 1 2) (1 2 3) (2 3 4)) + (take 3 (tuples* 3 0)) ((0 1 2) (1 2 3) (2 3 4))) + +(mtest + (nrot nil) nil + (nrot (vec)) #() + (nrot "") "" + (nrot nil 2) nil + (nrot (vec) 2) #() + (nrot "" 2) "" + (nrot nil -1) nil + (nrot (vec) -1) #() + (nrot "" -1) "") + +(mtest + (let ((s '(a))) (nrot s)) (a) + (let ((s (vec 1))) (nrot s) s) #(1) + (let ((s "x")) (nrot s) s) "x" + (let ((s '(a))) (nrot s -1)) (a) + (let ((s (vec 1))) (nrot s -1) s) #(1) + (let ((s "x")) (nrot s -1) s) "x") + +(mtest + (let ((s '(a b))) (nrot s)) (b a) + (let ((s (vec 1 2))) (nrot s) s) #(2 1) + (let ((s (copy "xy"))) (nrot s) s) "yx" + (let ((s '(a b))) (nrot s -1)) (b a) + (let ((s (vec 1 2))) (nrot s -1) s) #(2 1) + (let ((s (copy "xy"))) (nrot s -1) s) "yx") + +(mtest + (let ((s '(a b c))) (nrot s)) (b c a) + (let ((s (vec 1 2 3))) (nrot s) s) #(2 3 1) + (let ((s (copy "xyz"))) (nrot s) s) "yzx" + (let ((s '(a b c))) (nrot s -1)) (c a b) + (let ((s (vec 1 2 3))) (nrot s -1) s) #(3 1 2) + (let ((s (copy "xyz"))) (nrot s -1) s) "zxy") + +(mtest + (let ((s (list 'a 'b 'c))) (nrot s 33)) (a b c) + (let ((s (list 'a 'b 'c))) (nrot s 34)) (b c a)) + +(mtest + (rot nil) nil + (rot #()) #() + (rot "") "" + (rot nil 2) nil + (rot #() 2) #() + (rot "" 2) "" + (rot nil -1) nil + (rot #() -1) #() + (rot "" -1) "") + +(mtest + (let ((s '(a))) (list (rot s) s)) ((a) (a)) + (let ((s #(1))) (list (rot s) s)) (#(1) #(1)) + (let ((s "x")) (list (rot s) s)) ("x" "x") + (let ((s '(a))) (list (rot s -1) s)) ((a) (a)) + (let ((s #(1))) (list (rot s -1) s)) (#(1) #(1)) + (let ((s "x")) (list (rot s -1) s)) ("x" "x")) + +(mtest + (let ((s '(a b))) (list (rot s) s)) ((b a) (a b)) + (let ((s #(1 2))) (list (rot s) s)) (#(2 1) #(1 2)) + (let ((s "xy")) (list (rot s) s)) ("yx" "xy") + (let ((s '(a b))) (list (rot s -1) s)) ((b a) (a b)) + (let ((s #(1 2))) (list (rot s -1) s)) (#(2 1) #(1 2)) + (let ((s "xy")) (list (rot s -1) s)) ("yx" "xy")) + +(mtest + (let ((s '(a b c))) (list (rot s) s)) ((b c a) (a b c)) + (let ((s #(1 2 3))) (list (rot s) s)) (#(2 3 1) #(1 2 3)) + (let ((s "xyz")) (list (rot s) s)) ("yzx" "xyz") + (let ((s '(a b c))) (list (rot s -1) s)) ((c a b) (a b c)) + (let ((s #(1 2 3))) (list (rot s -1) s)) (#(3 1 2) #(1 2 3)) + (let ((s "xyz")) (list (rot s -1) s)) ("zxy" "xyz")) + +(mtest + (let ((s '(a b c))) (list (rot s 33) s)) ((a b c) (a b c)) + (let ((s '(a b c))) (list (rot s 34) s)) ((b c a) (a b c))) + +(mtest + (subq #\a #\b "") "" + (subq #\a #\b "a") "b" + (subq #\a #\b "aaa") "bbb" + (subq #\a #\b "abc") "bbc") + +(mtest + (subql #\a #\b "") "" + (subql #\a #\b "a") "b" + (subql #\a #\b "aaa") "bbb" + (subql #\a #\b "abc") "bbc") + +(mtest + (subqual #\a #\b "") "" + (subqual #\a #\b "a") "b" + (subqual #\a #\b "aaa") "bbb" + (subqual #\a #\b "abc") "bbc") + +(mtest + (subq 0 1 nil) nil + (subq 0 1 '(0)) (1) + (subq 0 1 '(0 0 0)) (1 1 1) + (subq 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subql 0 1 nil) nil + (subql 0 1 '(0)) (1) + (subql 0 1 '(0 0 0)) (1 1 1) + (subql 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subqual 0 1 nil) nil + (subqual 0 1 '(0)) (1) + (subqual 0 1 '(0 0 0)) (1 1 1) + (subqual 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subqual "foo" "bar" nil) nil + (subqual "foo" "bar" '#"foo") #"bar" + (subqual "foo" "bar" '#"foo foo foo") #"bar bar bar" + (subqual "foo" "bar" '#"xyzzy foo quuz") #"xyzzy bar quuz") + +(mtest + (subqual "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow") + (subst "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow")) + +(mtest + [subst "brown" "black" #("how" "now" "BROWN" "cow") : downcase-str] #("how" "now" "black" "cow") + [subst 5 0 '(1 2 3 4 5 6 7 8 9 10) <] (1 2 3 4 5 0 0 0 0 0)) + +(mtest + (pairlis nil nil) nil + (pairlis "abc" #(1 2 3 4)) ((#\a . 1) (#\b . 2) (#\c . 3)) + (pairlis "abcd" #(1 2 3)) ((#\a . 1) (#\b . 2) (#\c . 3)) + (pairlis "" #(1 2 3)) nil + (pairlis "abcd" #()) nil + (pairlis '(1 2 3) '(a b c) '(4 5 6)) ((1 . a) (2 . b) (3 . c) 4 5 6)) + +(mtest + (find-max nil) nil + [find-max '("alpha" "charlie" "aardvark" "bravo") less] "aardvark" + [find-max '("alpha" "charlie" "aardvark" "bravo") less reverse] "alpha" + [find-max '("alpha" "charlie" "aardvark" "bravo") : reverse] "bravo" + (find-max 1..10) 9 + [find-max #H(() (a 1) (b 2) (c 3)) : cdr] (c . 3)) + +(mtest + (find-max-key nil) nil + [find-max-key '("alpha" "charlie" "aardvark" "bravo") less upcase-str] "AARDVARK" + [find-max-key #H(() (a 1) (b 2) (c 3)) : cdr] 3) + +(defvarl fn (do and + (chr-isdigit @1) + (not (chr-isdigit @2)))) + +(mtest + [partition-if tf nil] nil + [partition-if tf "abc"] ("a" "b" "c") + [partition-if nilf "abc"] ("abc") + [partition-if neql "aaaabbcdee"] ("aaaa" "bb" "c" "d" "ee") + (partition-if fn "a13cd9foo42z") ("a13" "cd9" "foo42" "z")) + +(mtest + (partition-if (op /= (- @2 @1) 1) + '(1 3 4 5 7 8 9 10 9 8 6 5 3 2)) + ((1) (3 4 5) (7 8 9 10) (9) (8) (6) (5) (3) (2)) + (partition-if (op > (abs (- @2 @1)) 1) + '(1 3 4 5 7 8 9 10 9 8 6 5 3 2)) + ((1) (3 4 5) (7 8 9 10 9 8) (6 5) (3 2))) + +(mtest + [partition-if neql "aaaabbcdee" 2] ("aaaa" "bb" "cdee") + [partition-if neql "aaaabbcdee" 1] ("aaaa" "bbcdee") + [partition-if fn "a13cd9foo42z" 2] ("a13" "cd9" "foo42z") + [partition-if fn "a13cd9foo42z" 1] ("a13" "cd9foo42z") + [partition-if fn "a13cd9foo42z" 0] ("a13cd9foo42z")) + +(mtest + [count 1 nil] 0 + [count 1 '(1 2 3 4 1 5)] 2 + [count "abc" '("foo" "bar" "ABC" "abc" "def" "abc")] 2 + [count "ABC" '("foo" "bar" "ABC" "abc" "def" "abc") : upcase-str] 3) + +(compile-only + (test + [count #1="abc" '("abc" "abc" "abc" #1# "abc" #1#" abc") eq] 2)) + +(mtest + (search "" "") 0 + (search "abcde" "ab") 0 + (search "abcde" "bc") 1 + (search "abcde" "cd") 2 + (search "abcde" "de") 3 + (search "abcde" "e") 4 + (search "abcde" "") 0 + (search "abcde" "x") nil) + +(mtest + (search nil nil) 0 + (search '#"a b c d e" '#"a b") 0 + (search '#"a b c d e" '#"b c") 1 + (search '#"a b c d e" '#"c d") 2 + (search '#"a b c d e" '#"d e") 3 + (search '#"a b c d e" '#"e") 4 + (search '#"a b c d e" nil) 0 + (search '#"a b c d e" '#"x") nil) + +(mtest + (rsearch nil nil) 0 + (rsearch "abcde" "ab") 0 + (rsearch "abcde" "bc") 1 + (rsearch "abcde" "cd") 2 + (rsearch "abcde" "de") 3 + (rsearch "abcde" "e") 4 + (rsearch "abcde" "") 5 + (rsearch "abcde" "x") nil) + +(mtest + (rsearch '#"a b c d e" '#"a b") 0 + (rsearch '#"a b c d e" '#"b c") 1 + (rsearch '#"a b c d e" '#"c d") 2 + (rsearch '#"a b c d e" '#"d e") 3 + (rsearch '#"a b c d e" '#"e") 4 + (rsearch '#"a b c d e" nil) 5 + (rsearch '#"a b c d e" '#"x") nil) + +(mtest + (search-all "" "") (0) + (search-all "xxxxx" "y") nil + (search-all "xxxxx" "x") (0 1 2 3 4) + (search-all "xxx" "") (0 1 2 3)) + +(mtest + (search-all nil nil) (0) + (search-all '#"x x x x x" '#"y") nil + (search-all '#"x x x x x" '#"x") (0 1 2 3 4) + (search-all '#"x x x" "") (0 1 2 3)) + +(mtest + [keep-keys-if evenp (range 1 20) square] (4 16 36 64 100 144 196 256 324 400) + [keep-keys-if chr-isupper "foo bar" chr-toupper] "FOOBAR" + [keep-keys-if evenp (vec-list (range 1 20)) square] #(4 16 36 64 100 144 196 256 324 400)) + + +(mtest + [separate-keys evenp (range 1 20) square] ((4 16 36 64 100 144 196 256 324 400) + (1 9 25 49 81 121 169 225 289 361)) + [separate-keys chr-isupper "foo bar" chr-toupper] ("FOOBAR" " ") + [separate-keys evenp (vec-list (range 1 20)) square] (#(4 16 36 64 100 144 196 256 324 400) + #(1 9 25 49 81 121 169 225 289 361))) + +(mtest + (flatten '()) () + (flatten '(nil)) () + (flatten '(a)) (a) + (flatten '(a b)) (a b) + (flatten '(nil b)) (b) + (flatten '(a nil)) (a) + + (flatten '((nil))) () + (flatten '((a))) (a) + (flatten '((a) (b))) (a b) + (flatten '((nil) (b))) (b) + (flatten '((a) (nil))) (a) + + (flatten '((a b))) (a b) + (flatten '((nil b))) (b) + (flatten '((a nil))) (a) + + (flatten '(((())))) nil + (flatten '(((())) a)) (a) + (flatten '(((()) a))) (a) + (flatten '(((() a)))) (a) + (flatten '((((a))))) (a) + + (flatten 3) (3) + (flatten '(1 . 2)) :error + (flatten '(1 2 . 3)) :error + (flatten '(1 (2 . 3))) :error) + +(mtest + (flatten* '()) () + (flatten* '(nil)) () + (flatten* '(a)) (a) + (flatten* '(a b)) (a b) + (flatten* '(nil b)) (b) + (flatten* '(a nil)) (a) + + (flatten* '((nil))) () + (flatten* '((a))) (a) + (flatten* '((a) (b))) (a b) + (flatten* '((nil) (b))) (b) + (flatten* '((a) (nil))) (a) + + (flatten* '((a b))) (a b) + (flatten* '((nil b))) (b) + (flatten* '((a nil))) (a) + + (flatten* '(((())))) nil + (flatten* '(((())) a)) (a) + (flatten* '(((()) a))) (a) + (flatten* '(((() a)))) (a) + (flatten* '((((a))))) (a) + + (flatten* 3) (3) + (lforce (flatten* '(1 . 2))) :error + (lforce (flatten* '(1 2 . 3))) :error + (lforce (flatten* '(1 (2 . 3)))) :error) + +(mtest + (flatcar ()) (nil) + (flatcar 'a) (a) + (flatcar '(a . b)) (a b) + (flatcar '(nil . nil)) (nil) + (flatcar '(nil . b)) (nil b) + (flatcar '(b . nil)) (b) + (flatcar '(a b . c)) (a b c) + (flatcar '(() b . c)) (nil b c) + (flatcar '((()) b . c)) (nil b c) + (flatcar '(((a)) b . c)) (a b c)) + +(mtest + (flatcar* ()) (nil) + (flatcar* 'a) (a) + (flatcar* '(a . b)) (a b) + (flatcar* '(nil . nil)) (nil) + (flatcar* '(nil . b)) (nil b) + (flatcar* '(b . nil)) (b) + (flatcar* '(a b . c)) (a b c) + (flatcar* '(() b . c)) (nil b c) + (flatcar* '((()) b . c)) (nil b c) + (flatcar* '(((a)) b . c)) (a b c)) + +(mtest + (length-< nil 0) nil + (length-< nil 1) t + (length-< '(a) 1) nil + (length-< '(a) 2) t + (length-< '(a . b) 1) nil + (length-< '(a . b) 2) t) + +(mtest + (length-< "" 0) nil + (length-< "" 1) t + (length-< "a" 1) nil + (length-< "a" 2) t) + +(mtest + (length-< #() 0) nil + (length-< #() 1) t + (length-< #(a) 1) nil + (length-< #(a) 2) t) + +(let ((l (list 1 2 3 4))) + (del (ref l 1)) + (test l (1 3 4)) + (del (second l)) + (test l (1 4))) + +(let ((nl (list (list (list 1 2) + (list 3 4) + (list 5 6)) + (list (list 7 8) + (list 9 10) + (list 11 12))))) + (mtest + (mref nl 0 0 0) 1 + (mref nl 0 0 1) 2 + (mref nl 0 1 0) 3 + (mref nl 0 1 1) 4 + (mref nl 0 2 0) 5 + (mref nl 0 2 1) 6 + (mref nl 1 0 0) 7 + (mref nl 1 0 1) 8 + (mref nl 1 1 0) 9 + (mref nl 1 1 1) 10 + (mref nl 1 2 0) 11 + (mref nl 0 2 1) 6) + + (mtest + (set (mref nl 0 0 0) 101) 101 + (mref nl 0 0 0) 101 + + (del (mref nl 0 0 0..:)) (101 2) + nl ((nil (3 4) (5 6)) ((7 8) (9 10) (11 12))) + + (set (mref nl 1 0..2) '(4)) (4) + nl ((nil (3 4) (5 6)) (4 (11 12))) + + (del (mref nl 1)) (4 (11 12)) + nl ((nil (3 4) (5 6))) + + (set (mref nl 1..:) '(a b c)) (a b c) + nl ((nil (3 4) (5 6)) a b c) + + (set (mref nl 1..3) '(e f)) (e f) + nl ((nil (3 4) (5 6)) e f c))) + +(flet ((get-vec () (vec 1 2 3)) + (get-list () (list 1 2 3))) + (mtest + (inc (mref (get-vec) 0)) 2 + (set (mref (get-vec) 0) 10) 10 + (inc (mref (get-list) 0)) 2 + (set (mref (get-list) 0) 10) 10 + (push 3 (mref (get-vec) 1..2)) (3 . #(2)) + (set (mref (get-vec) 1..2) '(30)) (30) + (push 3 (mref (get-list) 1..2)) :error + (set (mref (get-list) 1..2) '(30)) :error)) + + +(let ((nv (nested-vec 4 4 4))) + (let ((x 0)) + (each-prod ((i 0..4) + (j 0..4) + (k 0..4)) + (vtest (set (mref nv i j k) (inc x)) (succ x)))) + (mtest + nv #(#(#( 1 2 3 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 0 0 1..3) #(20 30)) #(20 30) + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 1 1..3) "AB") "AB" + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #\A #\B #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 1..3) '(B C)) (B C) + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + B + C + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))))) + +(let ((cf (lambda (x) + (lambda (y) + (lambda (z) + (+ x y z)))))) + (test [mref cf 1 2 3] 6)) + +(test + (zip) nil) + +(mtest + (zip '()) nil + (zip #()) #() + (zip "") "" + (zip #b'') #b'') + +(mtest + (zip '(a)) ((a)) + (zip '(a b)) ((a) (b)) + (zip '(a b c)) ((a) (b) (c))) + +(mtest + (zip #(a)) #(#(a)) + (zip #(a b)) #(#(a) #(b)) + (zip #(a b c)) #(#(a) #(b) #(c))) + +(mtest + (zip "a") ("a") + (zip "ab") ("a" "b") + (zip "abc") ("a" "b" "c")) + +(mtest + (zip #b'aa') (#b'aa') + (zip #b'aabb') (#b'aa' #b'bb') + (zip #b'aabbcc') (#b'aa' #b'bb' #b'cc')) + +(mtest + (zip '(a) '(b)) ((a b)) + (zip '(a c) '(b d)) ((a b) (c d)) + (zip '(a c e) '(b d f)) ((a b) (c d) (e f)) + (zip '(a d) '(b e) '(c f)) ((a b c) (d e f))) + +(mtest + (zip #(a) #(b)) #(#(a b)) + (zip #(a c) #(b d)) #(#(a b) #(c d)) + (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f)) + (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f))) + +(mtest + (zip #(a) #(b)) #(#(a b)) + (zip #(a c) #(b d)) #(#(a b) #(c d)) + (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f)) + (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f))) + +(mtest + (zip "a" "b") ("ab") + (zip "ac" "bd") ("ab" "cd") + (zip "ace" "bdf") ("ab" "cd" "ef") + (zip "ad" "bef" "cf") ("abc" "def")) + +(mtest + (zip #b'aa' #b'bb') (#b'aabb') + (zip #b'aacc' #b'bbdd') (#b'aabb' #b'ccdd') + (zip #b'aaccee' #b'bbddff') (#b'aabb' #b'ccdd' #b'eeff') + (zip #b'aaddee' #b'bbeeff' #b'ccff') (#b'aabbcc' #b'ddeeff')) + +(test + (zip "ab" "ijklm" "xy") ("aix" "bjy")) + +(test + (zip "ab" '(#\i #\j) #("x" "y")) ("aix" "bjy")) + +(vtest + [apply mapcar join (list-seq "aaa".."zzz")] + (transpose (list-seq "aaa".."zzz"))) + +(eval-only (set *compile-opts*.constant-throws nil)) + +(mtest + (ref "a".."z" 0) :error + (ref (rcons 'foo 'bar) 0) :error) + +(mtest + (ref 1..6 0) 1 + (ref 1..6 1) 2 + (ref 1..6 4) 5 + (ref 1..6 5) :error + (ref 1..6 -1) 5 + (ref 1..6 -2) 4 + (ref 1..6 -5) 1 + (ref 1..6 -6) :error) + +(mtest + (ref 1..: 0) 1 + (ref 1..: 1) 2 + (ref 1..: 4) 5 + (ref 1..: -1) :error + (ref 1..: -2) :error) + +(mtest + (ref 1..t 0) 1 + (ref 1..t 1) 2 + (ref 1..t 4) 5 + (ref 1..t -1) :error + (ref 1..: -2) :error) + +(mtest + (ref #\a..#\f 0) #\a + (ref #\a..#\f 1) #\b + (ref #\a..#\f 4) #\e + (ref #\a..#\f 5) :error + (ref #\a..#\f -1) #\e + (ref #\a..#\f -2) #\d + (ref #\a..#\f -5) #\a + (ref #\a..#\f -6) :error) + +(mtest + (ref #\a..: 0) #\a + (ref #\a..: 1) #\b + (ref #\a..: 4) #\e + (ref #\a..: -1) :error + (ref #\a..: -2) :error) + +(mtest + (ref #\a..t 0) #\a + (ref #\a..t 1) #\b + (ref #\a..t 4) #\e + (ref #\a..t -1) :error + (ref #\a..: -2) :error) + + +(mtest + (ref 1..6 0.0) (1.0 2.0 3.0 4.0 5.0)) diff --git a/tests/012/sort.tl b/tests/012/sort.tl new file mode 100644 index 00000000..bca4a3d8 --- /dev/null +++ b/tests/012/sort.tl @@ -0,0 +1,98 @@ +(load "../common") + +(test (sort ()) nil) + +(let* ((list (conses '(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar sort (perm list (len list))]))) + (mvtest (len sp) 1 + (car sp) list)) + +(test (sort #()) #()) + +(let* ((vec (conses #(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar sort (perm vec (len vec))]))) + (mvtest (len sp) 1 + (car sp) vec)) + +(let* ((list (range* 0 1000)) + (slist (shuffle list)) + (vec (vec-list list)) + (svec (vec-list slist))) + (mvtest + (sort list) list + (sort slist) list + (sort list (fun greater)) (reverse list) + (sort slist (fun greater)) (reverse list)) + (mvtest + (sort vec) vec + (sort svec) vec + (sort vec (fun greater)) (reverse vec) + (sort svec (fun greater)) (reverse vec)) + (mvtest + (csort list) list + (csort slist) list + (csort list (fun greater)) (reverse list) + (csort slist (fun greater)) (reverse list)) + (mvtest + (csort vec) vec + (csort svec) vec + (csort vec (fun greater)) (reverse vec) + (csort svec (fun greater)) (reverse vec))) + + +(test (ssort ()) nil) + +(let* ((list (conses '(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar ssort (perm list (len list))]))) + (mvtest (len sp) 1 + (car sp) list)) + +(test (ssort #()) #()) + +(let* ((vec (conses #(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar ssort (perm vec (len vec))]))) + (mvtest (len sp) 1 + (car sp) vec)) + +(let* ((list (range* 0 1000)) + (slist (shuffle list)) + (vec (vec-list list)) + (svec (vec-list slist))) + (mvtest + (ssort list) list + (ssort slist) list + (ssort list (fun greater)) (reverse list) + (ssort slist (fun greater)) (reverse list)) + (mvtest + (ssort vec) vec + (ssort svec) vec + (ssort vec (fun greater)) (reverse vec) + (ssort svec (fun greater)) (reverse vec)) + (mvtest + (cssort list) list + (cssort slist) list + (cssort list (fun greater)) (reverse list) + (cssort slist (fun greater)) (reverse list)) + (mvtest + (cssort vec) vec + (cssort svec) vec + (cssort vec (fun greater)) (reverse vec) + (cssort svec (fun greater)) (reverse vec))) + +(mtest + [sort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car] + (((a 1) (a 2) (a 3) (a 4)) + ((b 1) (b 2)) + ((c 2) (c 1))) + [csort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car] + (((a 1) (a 2) (a 3) (a 4)) + ((b 1) (b 2)) + ((c 2) (c 1)))) + +(mtest + (hist-sort nil) nil + (hist-sort '(3 4 5)) ((3 . 1) (4 . 1) (5 . 1)) + (hist-sort '("a" "b" "c" "a" "b" "a" "b" "a")) (("a" . 4) ("b" . 3) ("c" . 1))) + +(test + [hist-sort-by upcase-str '("a" "b" "c" "a" "b" "a" "b" "a")] (("A" . 4) ("B" . 3) ("C" . 1))) diff --git a/tests/012/stack.tl b/tests/012/stack.tl new file mode 100644 index 00000000..b3cea078 --- /dev/null +++ b/tests/012/stack.tl @@ -0,0 +1,50 @@ +(load "../common") + +(defvarl stack-limited (set-stack-limit 32768)) + +(defun recur () (recur)) + +(defmacro so (expr) + ^(catch ,expr + (stack-overflow (exc) :so))) + +(test (so (recur)) :so) + +(if (fboundp 'setrlimit) + (test (let ((pid (fork))) + (cond + ((zerop pid) + (set-stack-limit 0) + (let ((rlim (getrlimit rlimit-stack))) + (set rlim.cur 32768) + (setrlimit rlimit-stack rlim)) + (recur)) + (t (let ((status (wait pid))) + (w-ifsignaled status))))) + t)) + +(defmacro infexp () + ^(foo (infexp))) + +(test (so (expand '(infexp))) :so) + +(defvarl orig (get-stack-limit)) + +(mvtest + (set-stack-limit nil) orig + (set-stack-limit orig) nil + (set-stack-limit 0) orig + (set-stack-limit orig) nil + (set-stack-limit 65536) orig + (set-stack-limit orig) 65536) + +(set-sig-handler sig-segv + (lambda (signal async-p) + (assert (null (get-stack-limit))) + (throw 'out))) + +(test + (catch + (raise sig-segv) + (out () :sig)) + :sig) diff --git a/tests/012/stack2.expected b/tests/012/stack2.expected new file mode 100644 index 00000000..cad99e12 --- /dev/null +++ b/tests/012/stack2.expected @@ -0,0 +1 @@ +caught diff --git a/tests/012/stack2.txr b/tests/012/stack2.txr new file mode 100644 index 00000000..3652a764 --- /dev/null +++ b/tests/012/stack2.txr @@ -0,0 +1,9 @@ +@(define recur ()) +@(recur) +@(end) +@(do (set-stack-limit 32768)) +@(try) +@(recur) +@(catch stack-overflow (arg)) +@(do (put-line "caught")) +@(end) diff --git a/tests/012/struct.expected b/tests/012/struct.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/struct.expected +++ /dev/null diff --git a/tests/012/struct.tl b/tests/012/struct.tl index 9de3f832..33431780 100644 --- a/tests/012/struct.tl +++ b/tests/012/struct.tl @@ -16,7 +16,7 @@ (test (expand '^#S(bar b ,(+ 2 2))) (sys:make-struct-lit 'bar (list 'b (+ 2 2)))) -(defvar s (eval ^#S(bar b ,(+ 2 2)))) +(defvarl s (eval ^#S(bar b ,(+ 2 2)))) (test (set (slot s 'a) 100) 100) @@ -28,32 +28,36 @@ (slot (slot (slot a 'b) 'c) 'd)) -(test (expand 's.a) +(defmacro get-current-menv (:env e) e) +(defvarl menv (let (s a b c d) (macro-time (get-current-menv)))) + +(test (expand 's.a menv) (slot s 'a)) -(test (expand 's.[a]) - [(slot s 'a)]) -(test (expand 's.[a b c]) - [(slot s 'a) b c]) +(test (expand 's.[a] menv) + [(slot s 'a) s]) +(test (expand 's.[a b c] menv) + [(slot s 'a) s b c]) (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a))) + +(stest (ignwarn (expand 's.(a) menv)) "(call (slot s 'a)\n \ \ s)") (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a b c))) +(stest (ignwarn (expand 's.(a b c) menv)) "(call (slot s 'a)\n \ \ s b c)") -(test (expand 's.[a].d) - (slot [(slot s 'a)] 'd)) -(test (expand 's.[a b c].d) - (slot [(slot s 'a) b c] 'd)) +(test (expand 's.[a].b menv) + (slot [(slot s 'a) s] 'b)) +(test (expand 's.[a b c].b menv) + (slot [(slot s 'a) s b c] 'b)) (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a).d)) +(stest (ignwarn (expand 's.(a).d menv)) "(slot (call (slot s 'a)\n \ \ s)\n \ \ 'd)") (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a b c).d)) +(stest (ignwarn (expand 's.(a b c).d menv)) "(slot (call (slot s 'a)\n \ \ s b c)\n \ \ 'd)") @@ -62,7 +66,7 @@ (test (new foo) #S(foo a 42)) -(set *gensym-counter* 0) +(set *gensym-counter* 4) (stest (expand '(defstruct (boa x y) nil (x 0) (y 0))) "(sys:make-struct-type 'boa '() '()\n \ @@ -104,7 +108,7 @@ (stest bz "#S(baz array #(1 2 3) increment #<interpreted fun: lambda (self which delta)>)") -(test bz.[array 2] 3) +(test [bz.array 2] 3) (test bz.(increment 0 42) 43) (test bz.array #(43 2 3)) (test [(meth bz increment) 1 5] 7) @@ -133,3 +137,11 @@ (test (equal #S(foo) #S(foo)) t) (test (equal #S(foo a 0) #S(foo a 1)) nil) (test (equal #S(bar a 3 b 3) #S(bar a 3 b 3)) t) + +(defstruct eqsub () + key + (:method equal (me) me.key)) + +(test (equal (new eqsub key '(1 2)) + (new eqsub key '(1 2))) + t) diff --git a/tests/012/stslot.expected b/tests/012/stslot.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/stslot.expected +++ /dev/null diff --git a/tests/012/syms.expected b/tests/012/syms.expected new file mode 100644 index 00000000..bfe9f694 --- /dev/null +++ b/tests/012/syms.expected @@ -0,0 +1,6 @@ +(loc-0 loc-1 loc-2 cons) +(loc-0 loc-1 loc-2 cons) +(fb-2:loc-0 fb-2:loc-1 loc-2 cons) +(loc-0 loc-1 loc-2 cons) +(fb-2:loc-0 fb-2:loc-1 loc-2 cons) +(fb-1:loc-0 loc-1 loc-2 cons) diff --git a/tests/012/syms.tl b/tests/012/syms.tl new file mode 100644 index 00000000..007125e2 --- /dev/null +++ b/tests/012/syms.tl @@ -0,0 +1,28 @@ +(load "../common") + +(defpackage fb-2 + (:local loc-0 loc-1 loc-2) + (:fallback usr)) + +(defpackage fb-1 + (:local loc-0 loc-1) + (:fallback fb-2 usr)) + +(defpackage main + (:local loc-0) + (:fallback fb-1 fb-2 usr)) + +(in-package fb-2) + +(prinl '(loc-0 loc-1 loc-2 cons)) + +(in-package fb-1) + +(prinl '(loc-0 loc-1 loc-2 cons)) +(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons)) + +(in-package main) + +(prinl '(loc-0 loc-1 loc-2 cons)) +(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons)) +(prinl '(fb-1:loc-0 fb-1:loc-1 fb-1:loc-2 fb-1:cons)) diff --git a/tests/012/syntax.tl b/tests/012/syntax.tl new file mode 100644 index 00000000..bc7d9668 --- /dev/null +++ b/tests/012/syntax.tl @@ -0,0 +1,74 @@ +(load "../common") + +"top level literal" + +".." + +"." + +#;(commented out list) +#;3.14 +#;abc +#;.foo +#; .foo +#;a.b + +'(#;.foo) +'(#; .foo) + +(test + #;(commented out list) + #;3.14 + #;abc + #;.foo + #; .foo + #;a.b + 42 42) + +(mtest + '(#;abc) nil + '(#; abc 1) (1) + '(0 #; abc 1) (0 1) + '(0 #; abc) (0)) + +(mtest + '(#; .abc) nil + '(#; .abc 1) (1) + '(0 #; .abc 1) (0 1) + '(0 #; .abc) (0)) + +(mtest + '(-,1) (- (sys:unquote 1)) + 1,2 12 + 1,,2 12 + 1,,,2 12 + 1,2,3 1,2,3 + -0,1 -1 + '(1,a) (1 (sys:unquote a))) + +(mtest + (read "#x,ff") :error + (read "#o,1") :error + (read "#b,1") :error + '(#xff,ff,z) (65535 (sys:unquote z)) + '(#xff,ff,a) (1048570)) + +(mtest + #xff,ff 65535 + #o7,7,7 511 + #b1101,1110 #xDE) + +(mtest + 1,234,567.890,123E13 1234567.890123E13 + '(1.234,e+12) (1.234 (sys:unquote e+12)) + '(1.,234) (1.0 (sys:unquote 234))) + +(mtest + (read "0..1") (rcons 0 1) + (read "0..1..2") (rcons 0 (rcons 1 2))) + +(mtest + (tostring '(rcons 0 1)) "0..1" + (tostring '(rcons 0 (rcons 1 2))) "0..1..2" + (tostring '(rcons (rcons 0 1) 2)) "(rcons 0..1 2)" + (tostring '(rcons (rcons 0 1) (rcons 2 3))) "(rcons 0..1 2..3)") diff --git a/tests/012/type.tl b/tests/012/type.tl new file mode 100644 index 00000000..97007b3c --- /dev/null +++ b/tests/012/type.tl @@ -0,0 +1,68 @@ +(load "../common") + +(mtest + (subtypep 'a 'a) t + (subtypep t t) t + (subtypep nil t) t + (subtypep t nil) nil + (subtypep nil nil) t + (subtypep 'null nil) nil + (subtypep nil 'null) t + (subtypep 'null t) t + (subtypep 'null 'a) nil + (subtypep 'a 'null) nil + (subtypep nil 'a) t + (subtypep 'a nil) nil + (subtypep 'a t) t) + +(mtest + (subtypep 'stream 'stdio-stream) nil + (subtypep 'stdio-stream 'stream) t) + +(defstruct xtime time) +(defstruct nottime nil) + +(mtest + (typep #S(time) 'time) t + (typep #S(time) (find-struct-type 'time)) t + (typep #S(xtime) 'time) t + (typep #S(xtime) (find-struct-type 'time)) t + (typep #S(nottime) 'time) nil + (typep #S(nottime) (find-struct-type 'time)) nil) + +(mtest + (subtypep (find-struct-type 'time) (find-struct-type 'time)) t + (subtypep (find-struct-type 'time) 'time) t + (subtypep 'time (find-struct-type 'time)) t) + +(mtest + (subtypep (find-struct-type 'xtime) (find-struct-type 'time)) t + (subtypep (find-struct-type 'xtime) 'time) t + (subtypep 'xtime (find-struct-type 'time)) t) + +(mtest + (subtypep (find-struct-type 'time) (find-struct-type 'xtime)) nil + (subtypep (find-struct-type 'time) 'xtime) nil + (subtypep 'time (find-struct-type 'xtime)) nil) + +(mtest + (subtypep 'time 'struct) t + (subtypep (find-struct-type 'time) 'struct) t + (subtypep 'hash 'struct) nil) + +(defstruct listlike nil + (:method car (me))) + +(defstruct veclike nil + (:method length (me))) + +(mtest + (subtypep 'listlike 'sequence) t + (subtypep (find-struct-type 'listlike) 'sequence) t + (subtypep 'veclike 'sequence) t + (subtypep (find-struct-type 'veclike) 'sequence) t + (subtypep 'time 'sequence) nil + (subtypep 'hash 'sequence) nil + (subtypep 'str 'sequence) t + (subtypep 'string 'sequence) t + (subtypep 'vec 'sequence) t) diff --git a/tests/012/typecase.tl b/tests/012/typecase.tl new file mode 100644 index 00000000..97b3da48 --- /dev/null +++ b/tests/012/typecase.tl @@ -0,0 +1,18 @@ +(load "../common") + +(mtest + (typecase) :error + (typecase nil) nil + (typecase nil a) :error + (typecase 0 (symbol 1)) nil + (typecase 0 (integer 1)) 1 + (typecase 0 (integer 1) (integer 2)) 1 + (typecase 0 (t 3) (integer 1)) 3) + +(mtest + (etypecase) :error + (etypecase nil) :error + (etypecase nil a) :error + (etypecase 0 (string 1)) :error + (etypecase 0 (string 1) (integer 2)) 2 + (etypecase 0 (string 1) (t 2)) 2) diff --git a/tests/012/use-as.tl b/tests/012/use-as.tl new file mode 100644 index 00000000..eb736d9d --- /dev/null +++ b/tests/012/use-as.tl @@ -0,0 +1,39 @@ +(load "../common") + +(defpackage lottery + (:local draw) + (:fallback usr)) + +(defpackage graphics + (:local draw) + (:fallback usr)) + +(defpackage gui-lottery + (:fallback lottery graphics usr pub) + (:use-syms-as lottery:draw ldraw + graphics:draw gdraw)) + +(in-package gui-lottery) + +(mtest + (package-name (symbol-package 'ldraw)) "lottery" + (package-name (symbol-package 'gdraw)) "graphics" + (symbol-name 'ldraw) "draw" + (symbol-name 'gdraw) "draw") + +(mtest + (tostring 'ldraw) "draw" + (tostring 'gdraw) "graphics:draw") + +(mtest + (use-sym-as 3 '#:foo) :error + (use-sym-as 'ldraw 3) :error + (use-sym-as 'x 'x) x) + +(mtest + (find-symbol "ldraw") lottery:draw + (find-symbol "gdraw") graphics:draw + (unuse-sym 'ldraw) lottery:draw + (unuse-sym 'gdraw) graphics:draw + (find-symbol "ldraw") nil + (find-symbol "gdraw") nil) |