debian/newlisp
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
newlisp/qa-comma

3661 lines
97 KiB
Text
Executable file
Raw Permalink Blame History

#!/usr/bin/env newlisp
(set 'start-of-qa (time-of-day))
;;
;; General test suite testing functioning of all built in primitives.
;;
;; use from inside the newlisp-x.x.x/ directory
;;
;; ./newlisp qa-dot
;;
;; or for countries and configurations with decimal
;;
;; ./newlisp qa-comma (for countries and configurations with decimal , )
;;
(set (sym "test-:" 'QA) (lambda () true))
(context 'Lex) ; predeclare/create context for bayes-train
(context MAIN)
;; changed for a locale where the comma ',' is the decimal separator
;; instead of the decimal point, i.e. Germany
;;
;; set a locale which uses the decimal comma
(setq LOCALE (if (find ostype '("Windows")) "German_Germany.1252" "de_DE.UTF-8"))
(unless (set-locale LOCALE)
(println "Cannot set locale to '" LOCALE "' - must exit")
(exit))
(unless (= (last (set-locale)) ",")
(println "Cannot set comma locale - must exit")
(exit))
(when utf8
(set 'unicodelist '(913 914 915 916 937 945 946 947 948 969 32
1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10))
(set 'utf8str (join (map char unicodelist)))
(unless (catch (regex-comp (join (map char '(12411 12370 12411 12370)))) 'result)
(println "Problem compiling utf-8 regular expressions."))
)
(define (utf8qa)
(if (not (= (length (char 937)) 2)) (QA:failed "UTF-8 char: failed"))
(if (not (and
(= (map char (explode (chop utf8str))) (chop unicodelist))
(= (map char (explode (chop utf8str 3))) (chop unicodelist 3))
(= (map char (explode (chop utf8str 5))) (chop unicodelist 5)))) (QA:failed "UTF-8 chop: failed"))
(if (not (= (map char (explode utf8str)) unicodelist)) (QA:failed "UTF-8 explode: failed"))
(if (not (= (map char (explode (upper-case utf8str)))
'(913 914 915 916 937 913 914 915 916 937 32 1040 1041 1042 1043 1044 1040 1041 1042 1043 1044 13 10)))
(println "upper-case of UTF8 characters not available - not critical -"))
(if (not (= (map char (explode (lower-case utf8str)))
'(945 946 947 948 969 945 946 947 948 969 32 1072 1073 1074 1075 1076 1072 1073 1074 1075 1076 13 10)))
(println "lower-case of UTF8 characters not available - not critical -"))
(if (not (= (map char (explode (first utf8str))) '(913))) (QA:failed "UTF-8 first: failed"))
(if (not (= (map char (explode (last utf8str))) '(10))) (QA:failed "UTF-8 last: failed"))
(if (not (= (map char (explode (rest utf8str)))
'(914 915 916 937 945 946 947 948 969 32 1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10)))
(QA:failed "UTF-8 rest: failed"))
(if (not (= (map char (explode (first (rest utf8str)))) '(914))) (QA:failed "UTF-8 first, rest: failed"))
(if (not
(and (= (map char (explode (select utf8str 1 2 3))) '(914 915 916))
(= (map char (explode (select utf8str -1 -2 -3))) '(10 13 1076))
(= (map char (explode (select utf8str 2 4 6))) '(915 937 946))))
(QA:failed "UTF-8 select: failed"))
(if (not (= (map char (explode (select utf8str '(1 2 3)))) '(914 915 916))) (QA:failed "UTF-8 select: failed"))
(if (not (and
(= (map char (explode (nth 1 utf8str))) '(914))
(= (map char (explode (nth -5 utf8str))) '(1074))))
(QA:failed "UTF-8 nth: failed"))
(setf (nth 2 utf8str) (char 937))
(if (not (= (map char (explode utf8str) )
'(913 914 937 916 937 945 946 947 948 969 32 1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10)))
(QA:failed "UTF-8 set-nth: failed"))
true
)
(global 'global-myvar)
(set 'global-myvar 123)
; testing the default functor
(define (double:double x) (+ x x))
(define (test-default-functor)
(and
(= (map double '(1 2 3 4 5)) '(2 4 6 8 10))
(= (map 'double '(1 2 3 4 5)) '(2 4 6 8 10))
(set 'dflt:dflt '(a b c d e f g))
(= (map dflt '(1 2 6)) '(b c g))
(set 'i 0 'j -1 'k 6)
(= (dflt i) 'a)
(= (dflt k) 'g)
(= (dflt j) 'g)
(set 'ctx dflt)
(= (default ctx) dflt:dflt)
(= (default dflt) dflt:dflt)
(sort (default ctx) >)
(= (default dflt) '(g f e d c b a))
))
(context 'QA)
(define (cleanup)
(delete-file "junk")
(delete-file "junk2"))
(set 'failed-messages '())
(define (check-case x)
(case x
(1 "one")
(2 "two")
(3 "three")))
(define (check-cond x)
(cond
((= x 1) 1)
((= x 2) 2)
((= x 3) 3)))
(define (checkqa )
(dolist (p (symbols 'MAIN))
(if (primitive? (eval p))
(begin
(set 'sm (sym (append "test-" (string p))))
(if (not (lambda? (eval sm)))
(print sm "\n"))))))
(define-macro (do-args p)
(= (args) '(2 "3 4" 5 (x y)))
(= (args 3 -1) 'y))
(define (failed msg)
; (println msg)
(push msg failed-messages))
(define (file-copy from-file to-file)
(set 'in-file (open from-file "read"))
(set 'out-file (open to-file "write"))
(while (set 'chr (read-char in-file))
(if (not (= chr 95))
(write-char out-file chr)))
(close in-file)
(close out-file))
(define (line-count file)
(device (open file "read"))
(set 'cnt 0)
(while (read-line)
(inc cnt))
(close (device))cnt)
(define (myappend x y)
(cond
((= '() x) y)
(true (cons (first x) (myappend (rest x) y)))))
(define (qa )
(set 'sm-cnt 0)
(dolist (sm (symbols 'MAIN))
(if (not
(if (and (primitive? (eval sm)) (< sm 'zzzz))
(begin
(inc sm-cnt (+ (length (term sm)) 1))
(if (> sm-cnt 79)
(begin
(set 'sm-cnt 0)
(println)))
(print (term sm) " ")
(set 'func (eval (sym (append "test-" (string sm)))) )
(and (catch (apply func) 'result) result))
true))
(failed (string " >>>> " sm " failed " result) )))
(println))
(define (test-$) (find "a|b" "xtzabc" 0) (= ($ 0) $0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; test-functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-!)
(integer? (! "")))
(define (test-!= )
(and (not (!= -9223372036854775808 (& -9223372036854775808 -1))) (!= "abc" "ABC")
(!= "a" "?")
(!= 1,000000001 1)
(!= "?" "a")))
(define (test-$)
(set '$0 123)
(= ($ 0) 123))
(define (test-% )
(and
(= (% 10 3) 1)
(not (catch (%) 'result))))
(define (test-& )
(= -9223372036854775808 (& -9223372036854775808 -1)))
(define (test-* )
(and
(= (* (* 123456789 123456789)) 15241578750190521)
(= (*) 1)
))
(define (test-+ )
(and
(= (+ 999999999999999999 1) 1000000000000000000)
(= (+ 9223372036854775807 -9223372036854775808) -1)
(= (+ -9223372036854775808 -1) 9223372036854775807) ; wraps around
(= (+) 0)
))
(define (test-- )
(= (- 100000000 1) 99999999))
(define (test-/ )
(= (/ 15241578750190521 123456789) 123456789)
(= (/ -10 5) -2))
(define (test-< )
(and
(< -9223372036854775808 9223372036854775807)
(< "abcdefg" "abcdefgh")
(< 1 1,000000001)
(< 1 "a")
(< "a" 'a)
(< '(a b) '(b c) '(c d))
(not (< '(a b) '(b d) '(b c)))
(< '(((a b))) '(((b c))))
(< '(a (b c)) '(a (b d)) '(a (b (d))))
(< -1)
(< -1,23)
(not (< "1"))
(not (< '()))
))
(define (test-<< )
(= (<< 1 63) -9223372036854775808))
(define (test-<= )
(and (<= -2147483648 2147483647) (<= 1 1,00000001)))
(define (test-= )
(and (= 1,23456789 1,23456789)
(= 123456789 123456789)
(= 0xFFFFFFFFFFFFFFFF -1)
(= 0b1111111111111111111111111111111111111111111111111111111111111111 -1)
(= '(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w))
'(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w)))
(= "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>" "<22><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
(= '())
(= 0)
(= "")
(not (= 1))
(not (= "abc"))
(not (= '(1 2 3)))
))
(define (test-> )
(and (> 2147483647 -2147483648) (> "abcdefgh" "abcdefg") (> 1,000000001
1)
(> "a" 1)
(> "z" "aaaaa")
(> "aaa" "a")
(> 'a "a")
(> '(a) 'a)
(> 1)
(> 1,23)
(> "abc")
(> '(1 2 3))
(not (> ""))
(not (> '()))
))
(define (test->= )
(and (>= 1 0) (>= 1,00000001 1)))
(define (test->> )
(= (>> 1073741824 30) 1))
(define (test-NaN? )
(and (NaN? (sqrt -1))
(set 'NaN (sqrt -1))
(not (= NaN NaN))
(= 1 (+ 1 NaN))
(= 0 (* 2 NaN))
(NaN? (add 1 (sqrt -1)))
(NaN? (abs (sqrt -1)))))
(define (test-^ )
(= (^ 1431655765 -1431655766) -1))
(define (test-abs )
(and (= (abs -1) 1) (= (abs -9,9) 9,9)))
(define (test-acos )
(= 0 (acos (cos (acos (cos 0))))))
(define (test-acosh)
(= (cosh (acosh 1)) 1))
(define (test-add , l)
(and
(= (add) 0)
(dotimes (x 100)
(push x l))
(= 4950 (apply add l))
))
(define (test-address s)
(and
(set 's "foo")
(= (address s) (last (dump s)))
(set 'D:D "foo")
(= (address D) (last (dump D:D)))
))
(define (test-amb)
(set 'x (amb 1 2))
(or (= x 1) (= x 2)))
(define (test-and )
(and (and true true true) (not (and true true nil))))
(define (test-append )
(and
(= '(1 2 3 4) (append '(1 2) '(3 4)))
(= '(1 2 3 4 5) (append '(1 2) '(3) '(4 5)))
(= '(1 2 3 4) (append '(1 2) '(3 4) '()))
(= '(1 2 3 4 5) (append '(1 2) '(3 4) '() '(5)))
(= '(1 2 3 4 5) (append '() '(1 2) '(3 4) '() '(5)))
(= '() (append '()) (append '() '()) (append))
(= "abcdefg" (append "" "a" "bcd" "" "ef" "g" ""))
(= "" (append ""))
(set 'A (array 3 2 (sequence 1 6)))
(set 'B (array 2 2 (sequence 7 10)))
(= (array 5 2 (sequence 1 10)) (append A B))
(lambda? (append '(lambda)))
; default functor
(set 'D:D '(a b c))
(= '(a b c a b c a b c) (append D D D))
))
(define (test-append-file)
(append-file "junk" "ABC")
(append-file "file://junk" "DEF")
(= (read-file "junk") "ABCDEF")
)
(define (test-apply )
(and (= (apply + '(1 2)) 3)
(= (apply append '("a" "b" "c")) "abc")
(= (apply (fn (x y) (+ x y)) '(3 4)) 7)
(= (apply list '(a b c d e f) 2) '(((((a b) c) d) e) f))
(= (inc (apply set '(x 123))) 124 x)
(= (apply + (array 100 (sequence 1 100)))
(apply + (sequence 1 100))
(apply + (0 100 (array 100 (sequence 1 100)))))
))
(define (test-args )
(do-args 1 2 "3 4" 5 (x y)))
(define (test-array)
(and
(= (array-list (array 3 2 (sequence 1 6))) '((1 2) (3 4) (5 6)))
(set 'A (array 3 2 (sequence 1 6)))
(= (array-list (nth 0 A)) '(1 2))
(= (nth '(0 0) A) 1)
(= (nth '(2 1) A) 6)
(= (nth '(-1 -1) A) 6)
(not (catch (nth '(10 10) A) 'result))
(not (catch (nth '(-10 -10) A) 'result))
(= (nth 0 A) (array 2 '(1 2)))
(= (array-list (nth 0 A)) '(1 2))
(< (nth 0 A) (nth 1 A))
(> (nth 2 A) (nth 1 A))
(setf (A 1 0) 1)
(= (nth '(1 0) A) 1)
(setf (A 1 1) 1)
(= (array-list A) '((1 2) (1 1) (5 6)))
(< (nth 1 A) (nth 0 A))
))
(define (test-array-list)
(and
(set 'a (array 3 4 (sequence 1 12)))
(array? a)
(list? (array-list a))
; default functor
(set 'D:D (array 3 4 (sequence 1 12)))
(array? D:D)
(list? (array-list D))
(= (array-list D) '((1 2 3 4) (5 6 7 8) (9 10 11 12)))
))
(define (test-array?) (test-array-list))
(define (test-asin )
(= (round (asin (sin (asin (sin 1)))) -9) 1))
(define (test-asinh)
(= (round (sinh (asinh 1)) -12) 1))
(define (test-assoc)
(and
(set 'L '((a 1) (b (c (d 2) (e 3) (e 4))) ("a" 5) ((a) 6)))
(= (assoc 'a L) '(a 1))
(= (assoc 'b L) '(b (c (d 2) (e 3) (e 4))))
(= (assoc "a" L) '("a" 5))
(= (assoc '((a)) L) '((a) 6))
(= (assoc '(b c) L) '(c (d 2) (e 3) (e 4)))
(= (assoc '(b c d) L) '(d 2))
(= (assoc '(b c e) L) '(e 3))
; default functor
(set 'D:D '((a 1) (b (c (d 2) (e 3) (e 4))) ("a" 5) ((a) 6)))
(= (assoc 'a D) '(a 1))
))
(define (test-atan )
(< (sub 1 (atan (tan (atan (tan 1))))) 1e-15))
; old test broke after Mac OS X update to 10.5.2
; (= 1 (atan (tan (atan (tan 1)))))
(define (test-atanh)
(< (sub (tanh (atanh 0,5)) 0,5) 0,0000000001))
(define (test-atan2 )
(= (div (acos 0) (atan 1 1)) 2))
(define (test-atom? )
(and (atom? 1) (atom? 1,23) (atom? "hello") (atom? 'x) (atom? nil) (atom? true)))
(define (test-base64-enc)
(and
(= "" (base64-dec (base64-enc "")))
(= "1" (base64-dec (base64-enc "1")))
(= "12" (base64-dec (base64-enc "12")))
(= "123" (base64-dec (base64-enc "123")))
(= "1234" (base64-dec (base64-enc "1234")))
))
(define (test-base64-dec)
(test-base64-enc))
;; context Lex was previously created
(define (test-bayes-train)
(and
(= (bayes-train '(F F F B B) '(F B B B B) 'Lex) '(5 5))
(> 0,001 (apply add (map sub (bayes-query '(F) Lex) '(0,75 0,25))))
(> 0,001 (apply add (map sub (bayes-query '(F) Lex true) '(0,75 0,25))))
(> 0,001 (apply add (map sub (bayes-query '(F F) Lex) '(0,8251777681 0,1748222319))))
(> 0,001 (apply add (map sub (bayes-query '(F F) Lex true) '(0,9 0,1))))
)
)
(define (test-bayes-query)
(set 'Lex:F '(0 0))
(set 'Lex:B '(0 0))
(set 'Lex:total '(0 0))
true)
(define (test-begin )
(begin
(set 'x 0)
(inc x)
(inc x)
(= x 2)))
(define (test-beta )
(< (abs (sub (beta 1 2) 0,5)) 1e-05))
(define (test-betai )
(< (abs (sub (betai 0,5 5 10) 0,910217)) 1e-05))
(define (test-bigint?)
(and
(bigint? 123456789012345678901234567890)
(bigint? 123456789012345678901234567890L)
(bigint? 0L)
(bigint? 123L)
(bigint? (bigint 12345))
(bigint? (bigint 12345.678))
(bigint? (bigint "12345"))
(bigint? (bigint "12345"))
(bigint? (bigint "123hello"))
(nil? (bigint "hello"))
))
(define (test-bigint)
(and
(= 12345L (bigint 12345))
(= 12345 (bigint 12345.678))
(= 12345 (bigint "12345"))
))
(define (test-bind)
(bind '((a 1) (b "hello") (c (3 4))))
(and
(= a 1)
(= b "hello")
(= c '(3 4))
(= 7 (bind '((a (+ 3 4))) true))
)
)
(define (test-binomial )
(< (sub (binomial 2 1 0,5) 0,5) 1e-09))
(define (test-bits)
(and
(= (int (bits 0x7fffffffffffffff) 0 2) 0x7fffffffffffffff)
(= (int (bits 0x8000000000000000) 0 2) 0x8000000000000000)
(= 64 (length (bits 0x8000000000000000)))
(= (bits 0) "0")
(= (bits 1234) "10011010010")
(= (bits 1234 true) '(nil true nil nil true nil true true nil nil true))
))
(define (test-break )
(break true)
(= true (break))
(not (break nil)))
(define (test-case )
(and (= (check-case 1) "one") (= (check-case 2) "two") (= (check-case
9) nil)))
(define (test-callback) true)
(define (test-catch )
(and
(catch (+ 3 4) 'result)
(= result 7)
(= (catch (+ 3 4)) 7)
(= (catch (dotimes (x 100) (if (= x 7) (throw x)))) 7)
))
(define (test-ceil )
(= 2 (ceil 1,5)))
(define (test-change-dir )
(make-dir "adir")
(change-dir "adir")
(change-dir "..")
(remove-dir "adir"))
(define (test-char )
(and
(= (format "%c" (char "a" 0)) "a")
(= (char "A") 65) (= (char 65) "A")
(= (map char (sequence 65 67)) '("A" "B" "C"))
(= (char 0) "\000")
(set 'D:D "ABCDEFG")
(= (char D 0) 65)
(= (char D -1) 71)
(if utf8
(let (s (char 937))
(and
(= (char s 0 true) 206)
(= (char s 1 true) 169)
(= (char s -1 true) 169)
(= (char s -2 true) 206)
)
)
true
)
))
(define (test-chop )
(and
(= (chop "newlisp") "newlis")
(= (chop "newlisp" 4) "new")
(= (chop "abc" 5) "")
(= (chop "abc" -5) "")
(= (chop '(a b (c d) e)) '(a b (c d)))
(= (chop '(a b (c d) e) 2) '(a b))
(set 'D:D "newlisp")
(= (chop D) "newlis")
(= (chop D 4) "new")
))
(define (test-clean )
(and
(= (clean integer? '(1 1,1 2 2,2 3 3,3)) '(1,1 2,2 3,3))
(= (clean true? '(a nil b nil c nil)) '(nil nil nil))))
(define (test-close , fno)
(and
(set 'fno (open "qa-comma" "read"))
(close fno)))
(define (test-collect)
(= (let (x 0) (collect (if (<= (inc x) 5) x))) '(1 2 3 4 5))
)
(define (test-corr)
(< (apply add (map sub (corr '(1 3 5 8 9 9) '(2 2 3 4 6 8))
'(0,868724789 0,5571847507 0,6187683284 3,507907832 4 0,0247186268))) 0,000000001)
)
(define (test-crc32)
(and
(= (crc32 "abcdefghijklmnopqrstuvwxyz") 1277644989)
(= (crc32 "HELLO") 3242484790))
)
(define (test-select-collect )
(and
(set 'l '(0 1 2 3 4 5 6 7 8 9))
(= (select l '()) '())
(= (select l 0 9 9 0 1 8 8 1) '(0 9 9 0 1 8 8 1))
(= (select "2001-09-20" 5 6 8 9 0 1 2 3) "09202001")
(set 'a 0 'b 1 'c 2)
(= (select '(w x y z) a b c) '(w x y))
(= (select '(w x y z) (inc a) (inc b) (inc c)) '(x y z))
))
(define (test-command-event) true) /* test interactively */
(define (test-cond )
(and
(= (check-cond 1) 1)
(= (check-cond 2) 2)
(not (check-cond 99))
(= (cond ((+ 3 4))) 7)
(= (cond (nil 1) ('())) '())
(= (cond (nil 1) (nil)) nil)
(= (cond (nil 1) (true nil)) nil)
(= (cond ('())) '())
(= (cond (nil 1) ('() 2)) '())
))
(define (test-cons )
(= (myappend '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6))
)
(define (test-constant )
(constant 'cs 123)
(= cs 123)
(protected? 'cs))
(define (test-context )
(and (context 'TEST) (context 'QA)))
(define (test-context? )
(and (context? MAIN) (context? QA)))
(define (test-continue)
(let (cnt 0)
(= 1000 (catch (begin (if (< (inc cnt) 1000) (continue) cnt)))))
)
(define (test-copy)
(and
(set 'aList '(a b c))
(= (replace 'b (copy aList)) '(a c))
(= aList '(a b c))
(find-all "12" "12345" (replace "1" (copy $0) "N"))
(= (rotate (copy "abcdefg")) "gabcdef")
))
(define (test-copy-file )
(and (copy-file "qa-comma" "junk") (delete-file "junk")))
(define (test-cos )
(= 1 (cos (acos (cos (acos 1))))))
(define (test-cosh)
(= (cosh 1) (div (add (exp 1) (exp -1)) 2)))
(define (test-count )
(and (= (count '(1 2) '(2 1 2 1)) '(2 2))
(= (count '(a b) '(a a b c a b b)) '(3 3))
(= (count '(a b c) '()) '(0 0 0))
)
)
(define (test-cpymem)
(set 'from "12345")
(set 'to " ")
(cpymem (address from) (address to) 5)
(= from to))
(define (test-crit-chi2)
(and
(< (abs (sub (crit-chi2 (prob-chi2 4,605 2) 2) 4,605)) 0,001)
(< (abs (sub (crit-chi2 (prob-chi2 51,805 40) 40) 51,805)) 0,001)
(< (abs (sub (crit-chi2 (prob-chi2 9,210 2) 2) 9,210)) 0,001)
(< (abs (sub (crit-chi2 (prob-chi2 63,691 40) 40) 63,691)) 0,001)
))
(define (test-crit-f)
(and
(< (abs (sub (crit-f (prob-f 6,59 3 4) 3 4) 6,59)) 0,001)
(< (abs (sub (crit-f (prob-f 2,79 12 11) 12 11) 2,79)) 0,001)
(< (abs (sub (crit-f (prob-f 16,59 3 4) 3 4) 16,59)) 0,001)
(< (abs (sub (crit-f (prob-f 4,40 12 11) 12 11) 4,40)) 0,001)
))
(define (test-crit-t)
(and
(< (abs (sub (crit-t (prob-t 1,886 2) 2) 1,886)) 0,001)
(< (abs (sub (crit-t (prob-t 1,303 40) 40) 1,303)) 0,001)
(< (abs (sub (crit-t (prob-t 6,965 2) 2) 6,965)) 0,001)
(< (abs (sub (crit-t (prob-t 2,423 40) 40) 2,423)) 0,001)
))
(define (test-crit-z)
(for (z -6 6 0,3)
(let (flag true)
(if (> (abs (sub (crit-z (prob-z z)) z)) 0,0001)
(set 'flag nil))
flag)
))
(define (test-current-line , handle)
(and
(set 'handle (open "qa-comma" "r"))
(= (read-line handle) "#!/usr/bin/env newlisp")
(= (current-line) "#!/usr/bin/env newlisp")
(close handle)))
(define (test-curry)
(and
(= (set 'f (curry + 10)) (lambda ($x) (+ 10 $x)))
(= (filter (curry match '(a *)) '((a 10) (b 5) (a 3) (c 8) (a 9)))
'((a 10) (a 3) (a 9)))
(= (clean (curry match '(a *)) '((a 10) (b 5) (a 3) (c 8) (a 9)))
'((b 5) (c 8)))
(= (map (curry list 'x) (sequence 1 5))
'((x 1) (x 2) (x 3) (x 4) (x 5)))
))
(define (test-date )
(= (date) (date (date-value)) (date (apply date-value (now)))))
(define (test-date-parse)
(and
(= (date-parse "2007.1.3" "%Y.%m.%d") 1167782400)
(= (date-parse "20091014" "%Y%m%d") 1255478400)
; note that the month name here is in German
(= (date-parse "Januar 10, 07" "%B %d, %y") 1168387200)
))
(define (test-parse-date) (test-date-parse))
(define (test-date-list)
(let (value (date-value) vlist (now))
(= (apply date-value (date-list value)) value)
(= (vlist -4) ((date-list (apply date-value vlist)) -2))
(= (date-list 0) '(1970 1 1 0 0 0 1 4))
)
)
(define (test-date-value )
(= 0
(date-value 1970 1 1 0 0 0)
(date-value (+ 1970) (+ 1) (+ 1) (+ 0) (+ 0) (+ 0))
(date-value '(1970 1 1 0 0 0))) )
(define (test-debug )
(= (debug (+ 3 4)) 7))
(define (test-dec , x)
(test-inc))
(define (test-define , foo)
(and
(lambda? (define (foo (x 1) (y 2)) (list x y)))
(= (foo) '(1 2))
(= (foo 3) '(3 2))
(= (foo 3 4) '(3 4))
(define (foo (x 10) (y (div x 2))) (list x y))
(= (foo) '(10 5))
(= (foo 20) '(20 10))
(= (foo 3 4) '(3 4))
))
(define (test-def-new)
(and
(set 'fooctx:x 123)
(new fooctx)
(= fooctx:x 123)
(set 'barctx:bar 999)
(def-new 'barctx:bar)
(= bar 999)
(def-new 'barctx:bar 'foobar)
(= foobar 999)
(def-new 'barctx:bar 'foofoo:foo)
(= foofoo:foo 999)
))
(define (test-define-macro , foo)
(and
(macro? (define-macro (foo (x 1) (y 2)) (list x y)))
(= (foo) '(1 2))
(= (foo 3) '(3 2))
(= (foo 3 4) '(3 4))
(define-macro (foo (x 10) (y (div x 2))) (list x y))
(= (foo) '(10 5))
(= (foo 20) '(20 10))
(= (foo 3 4) '(3 4))
))
(define (test-default)
(MAIN:test-default-functor))
(define (test-delete )
(and
(set 'l (list (sym "xxx")))
(not (delete (sym "xxx") true))
(delete (sym "xxx")))
)
(define (test-delete-file )
(and (copy-file "qa-comma" "junk") (delete-file "junk")))
(define (test-delete-url )
(= "ERR: HTTP bad formed URL" (delete-url "")))
(define (test-destroy)
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "AIX" "Tru64Unix" "Cygwin"))
(set 'pid (fork (dotimes (t 100) (sleep 100))))
(set 'pid (process "newlisp")) )
(if (= ostype "Cygwin") (sleep 1000))
(destroy pid))
(define (test-det)
(and
(set 'A '((-1 1 1) (1 4 -5) (1 -2 0)))
(< (sub (det A) -1) 2e-10)
(set 'A '((1 2 3) (4 5 6)))
(not (catch (det A) 'result))
(starts-with result "ERR: wrong dimensions")
))
(define (test-device , fno)
(set 'fno (open "junk" "write"))
(device fno)
(if (= (device) fno)
(close (device))))
(define (test-difference )
(and
(= (difference '(2 5 6 0 3 0 2 5) '(1 2 3 3 2 1)) '(5 6 0))
(= (difference '(1 5 2 3 2 2 4 5 3 4 5 1) '(3 4) true) '(1 5 2 2 2 5 5 1))
(= (difference '(nil nil nil) '()) '(nil))
(= (difference '(nil nil nil) '() true) '(nil nil nil))
)
)
(define (test-directory )
(or (find "qa-comma" (directory)) (find "QA" (directory))))
(define (test-directory? )
(and
(directory? ".")
(directory? "modules/")
(directory? "modules")
))
(define (test-div )
(and (= 0,1 (div 100000000 1000000000))
(= (div 1 3) 0,3333333333333333)
(= (div 3) 0,3333333333333333)
))
(define (testdoargs)
(local (lst)
(doargs (i) (push i lst))
lst))
(define (test-doargs)
(= (testdoargs 3 2 1) '(1 2 3)))
(define (test-dolist , rList)
(and
(dolist (x '(1 2 3 4 5 6 7 8 9))
(push x rList))
(= rList '(9 8 7 6 5 4 3 2 1))
(dolist (x rList)
(pop rList))
(dolist (x '(1 2 3 4 5 6 7 8 9) (> x 5))
(push x rList))
(= rList '(5 4 3 2 1))
(= (local (l) (dolist (e '(1 2 3)) (push $idx l)) l) '(2 1 0))
(= (dolist (x '(a b c d e f g)) x) 'g)
))
(define (test-dostring)
(local (r)
(dostring (i "newlisp" (= i 108)) (push i r))
(= r '(119 101 110))
(= (dostring (c "newlisp") c) 112)
)
)
(define (test-dotimes , aList)
(dotimes (x 2)
(dotimes (y 2)
(dotimes (z 2)
(push z aList))))
(and
(= '(1 0 1 0 1 0 1 0) aList)
(not (dotimes (x 0) x))
(= (dotimes (x 1) x) 0)
; dotimes returns nil when ever executed since 8.9.7
(not (= (dotimes (x -1) x) 0))
(not (= (dotimes (x -1,8) x) 0))
(= (dotimes (x 1,8) x) 0)
(set 'cnt 0)
(dotimes (x 10 (> x 5)) (inc cnt))
(= cnt 6)
))
(define (test-dotree )
(set 'aList '())
(and
(= (last (symbols MAIN)) (dotree (p MAIN) p))
(dotree (x 'MAIN)
(push x aList))
(= (length (symbols 'MAIN)) (length aList))
))
(define (test-dump )
( = "hello" (get-string (last (dump "hello")))))
(define (test-dump-symbol )
(= (length (dump nil) 4)))
(define (test-dup)
(and
(= (dup "" 0) "")
(= (dup "" 10) "")
(= (dup "A" 10) "AAAAAAAAAA")
(= (dup "AB" 5) "ABABABABAB")
(= (dup 'x 5) '(x x x x x))
(= (dup "l" -1) "")
(= (dup '(1) -1) '())
(= (dup 1 0) '())
(= (dup 1 5) '(1 1 1 1 1))))
(define (test-empty? , aList)
(set 'aList '(1 2 3 4 5 6 7 8 9 0))
(while aList
(pop aList))
(and (empty? aList) (empty? "")))
(define (test-encrypt )
(= (encrypt (encrypt "newlisp" "123") "123") "newlisp"))
(define (test-ends-with )
(and
(ends-with "newlisp" "lisp")
(ends-with "newlisp" "LISP" 1)
(ends-with "abc.def.ghi" "def|ghi" 1)
(ends-with "12345" "4|5" 1)
(ends-with (explode "newlisp") "p")
(set 'D:D "newlisp")
(ends-with D "lisp")
(ends-with D "LISP" 1)
))
(define (test-env)
(and
(list? (env))
(env "key" "value")
(= (env "key") "value")
(env "key" "") ; remove key
(if (or (= ostype "SunOS") (= ostype "Solaris"))
(= (env "key" ""))
(not (env "key")))
))
(define (test-erf)
(< (abs (sub 0,5204998778 (erf 0,5))) 0,000001))
;(define (test-estack) (list? (estack)))
(define (test-even?)
(and (even? 2) (not (even? 3)) (even? 0,9) (not (even? 3,9))))
(define (alarm) (println "ring..."))
(define (test-timer)
(timer 'alarm 2))
(define (test-t-test)
(and
(< (apply add (map sub (t-test '(1 3 5 8 9 9) '(2 2 3 4 6 8))
'(5,833333333 4,166666667 3,371448749 2,401388487 0,9862873039 10 0,3472542517)))
0,00000001)
; related samples (before and after treatment)
(< (apply add (map sub (t-test '(3 0 6 7 4 3 2 1 4) '(5 1 5 7 10 9 7 11 8) true)
'(3,333333333 7 2,236067977 3,041381265 -3,142857143 8 0,01374582439)))
0,00000001)
; force Welch's Student's t for unequal variances
(< (apply add (map sub (t-test '(1 3 5 8 9 9) '(2 2 3 4 6 8) 1,0)
'(5,833333333 4,166666667 3,371448749 2,401388487 0,9862873039 9 0,3497635197)))
0,00000001)
; force Welch's Student's t for unequal variances and sample sizes
(< (apply add (map sub (t-test '(10 4 7 1 1 6 1 8 2 4) '(4 6 9 4 6 8 9 3) 1.0)
'(4,4 6,125 3,238655414 2,356601669 -1,30656126 15 0,2110406063)))
0,00000001)
; one sample t-test
(< (apply add (map sub (t-test '(3 5 4 2 5 7 4 3) 2,5)
'(4,125 2,5 1,552647509 0,548943791 2,960230221 7 0,02109816335)))
0,00000001)
))
(define (test-title-case)
(= (title-case "heLLo") "HeLLo")
(= (title-case "heLLo" true) "Hello"))
(define (test-throw-error)
(and
(not (catch (throw-error "ERR: message text") 'result))
(starts-with result "ERR: user error :")) )
(define (test-error-event )
(= 'nil (error-event)))
(define (test-estack) (list? (estack)))
(define (test-eval , x y)
(set 'x 123)
(set 'y 'x)
(set 'z 'y)
(and (= 123 (eval y)) (= 123 (eval 'x)) (= 123 (eval (eval z)))))
(define (test-eval-string )
(eval-string "(set 'x 123)")
(eval-string "(set 'y x)")
(= 123 (eval-string "y"))
(set 'Foo:xyz 99999)
(= 99999 (eval-string "xyz" 'Foo))
(delete (sym "xyz" Foo))
)
(define (test-exec )
(and (sub-read-exec) (sub-write-exec)))
(define (sub-read-exec )
(write-file "exectest" {(println "hello") (exit)})
(and
(set 'result (if (find ostype '("Windows" "OS/2"))
(exec "newlisp exectest")
(exec "./newlisp exectest")))
(= "hello" (last result))
(delete-file "exectest")))
(define (sub-write-exec )
(and
(write-file "testexec" {(write-file "exectest" (read-line))})
(if (find ostype '("Windows" "OS/2"))
(exec "newlisp testexec" "HELLO") (exec "./newlisp testexec" "HELLO"))
(= "HELLO" (read-file "exectest"))
(delete-file "testexec")
(delete-file "exectest")))
(define (test-exit )
(or (primitive? exit) (lambda? exit)))
(define (test-exists)
(and
(= (exists string? '(2 3 4 6 "hello" 7)) "hello")
(not (exists string? '(3 4 2 -7 3 0)) )
(= (exists zero? '(3 4 2 -7 3 0)) 0)
(= (exists < '(3 4 2 -7 3 0)) -7)
(= (exists (fn (x) (> x 3)) '(3 4 2 -7 3 0)) 4)
(not (exists (fn (x) (= x 10)) '(3 4 2 -7 3 0)))
))
(define (test-exp )
(= 1 (exp (log (exp (log (exp (log 1))))))))
(define (test-expand)
(and
(set 'x 2)
(= (expand 'x 'x) 2)
(= (expand '(a x b) 'x) '(a 2 b))
(= (expand '(x b) 'x) '(2 b))
(= (expand '(a x) 'x) '(a 2))
(= (expand '(a (x) b) 'x) '(a (2) b))
(= (expand '(a ((x)) b) 'x) '(a ((2)) b))
(set 'a 1 'b 2 'c 3)
(= (expand '(a b c) 'b 'a 'c ) '(1 2 3))
;; prolog mode with uppercase vars
(set 'X 2)
(= (expand '(a ((X)) b)) '(a ((2)) b))
;; env list as parameter
(set 'a "a" 'B "B" 'c "c" 'd "d")
(= (expand '(a (B (c) (d a B))) '((a 1) (B 2) (c 3) (d 4)))
'(1 (2 (3) (4 1 2))))
(= a "a") (= B "B") (= c "c") (= d "d")
))
(define (test-explode )
(and
(= (explode "kakak" -1) '())
(= (explode "ABC" 4) '("ABC"))
(= (explode '(a b c d e f) -1) '())
(= (explode "new") '("n" "e" "w"))
(= (explode "newlisp" 3) '("new" "lis" "p"))
(= (explode "newlisp" 3 true) '("new" "lis"))
(= (explode "newlisp" 7 true) '("newlisp"))
(= (explode "newlisp" 8 true) '())
(= (explode '(a b c d e)) '((a) (b) (c) (d) (e)))
(= (explode '(a b c d e) 2) '((a b) (c d) (e)))
(= (explode '(a b c d e)) '((a) (b) (c) (d) (e)))
(= (explode '(a b c d e) 2) '((a b) (c d) (e)))
(= (explode '(n e w l i s p)) '((n) (e) (w) (l) (i) (s) (p)))
(= (explode '(n e w l i s p) 3) '((n e w) (l i s) (p)))
(= (explode '(n e w l i s p) 7 true) '((n e w l i s p)))
(= (explode '(n e w l i s p) 8 true) '())
(set 'D:D '(a b c d e f g))
(= (explode D 2) '((a b) (c d) (e f) (g)))
))
(define (test-extend)
(and
(= (extend '() '(a) '(b c)) '(a b c))
(= (extend '(a) '() '(b)) '(a b))
(= (extend '(a) '(b) '(c d)) '(a b c d))
(not (set 'l '()))
(= (extend l '(a) '(b c)) '(a b c))
(= (extend l '(d e)) '(a b c d e))
(not (set 'l nil))
(= (extend l "abc" "def") "abcdef")
(not (set 'l nil))
(= (extend l '(a) '(b c)) '(a b c))
)
)
(define (test-factor)
(= (apply * (factor 0x7FFFFFFFFFFFFFFF)) 0x7FFFFFFFFFFFFFFF))
(define (test-fcall) true)
(define (test-fft )
(= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
(define (test-file-info )
(list? (file-info "qa-comma")))
(define (test-file? )
(and
(file? "qa-dot")
(= (file? "qa-dot" true) "qa-dot")
(file? "modules/")
(file? "modules")
(not (file? "modules" true))
))
(define (test-filter )
(and
(= (filter integer? '(1 1,1 2 2,2 3 3,3)) '(1 2 3))
(= (filter true? '(a nil b nil c nil)) '(a b c))
; default functor
(set 'D:D '(2 4 2 7 5 3 8))
(= (filter (curry < 5) D) '(7 8))
))
(define (test-find )
(and
(= 3 (find '(3 4) '(0 1 2 (3 4) 5 6 7 8)))
(= nil (find 9 '(1 2 3)))
(= 2 (find "W" "newlisp" 1))
(= $0 "w")
(= (find "newlisp" '("Perl" "Python" "newLISP") 1) 2)
; use a comparison functor
(= (find '(1 2) '((1 4) 5 6 (1 2) (8 9))) 3)
(= (find 3 '(8 4 3 7 2 6) >) 4)
(= (find 5 '((l 3) (k 5) (a 10) (z 22)) (fn (x y) (= x (last y)))) 1)
(= (find '(a ?) '((l 3) (k 5) (a 10) (z 22)) match) 2)
(= (find '(X X) '((a b) (c d) (e e) (f g)) unify) 2)
(define (has-it-as-last x y) (= x (last y)))
(= (find 22 '((l 3) (k 5) (a 10) (z 22)) has-it-as-last) 3)
(= (find "newlisp" '("Perl" "Python" "newLISP") (fn (x y) (regex x y 1))) 2)
; default functor
(set 'D:D '(0 1 2 (3 4) 5 6 7 8))
(= 3 (find '(3 4) D))
(set 'D:D "newlisp")
(= 2 (find "W" D 1))
))
(define (test-find-all)
(and
(= (find-all {\d+} "asdf2kjh44hgfhgf890") '("2" "44" "890"))
(= (find-all {(new)(lisp)} "newLISPisNEWLISP" (append $2 $1) 1) '("LISPnew" "LISPNEW"))
(set 'D:D "asdf2kjh44hgfhgf890")
(= (find-all {\d+} D) '("2" "44" "890"))
(set 'D:D "newLISPisNEWLISP")
(= (find-all {(new)(lisp)} D (append $2 $1) 1) '("LISPnew" "LISPNEW"))
(= (find-all {(^|(?<=,))("(([^"]|"")*)"|([^",]*))}
{Ten Thousand,10000, 2710 ,,"10,000","It's ""10 Grand"", baby",10K})
'("Ten Thousand" "10000" " 2710 " "" "\"10,000\"" "\"It's \"\"10 Grand\"\", baby\"" "10K"))
))
(define (test-first )
(= 1 (first '(1 2 3 4)))
(= "n" (first "ewLISP"))
(= (array 2 '(1 2)) (first (array 3 2 (sequence 1 6))))
(not (catch (first '()) 'result))
)
(define (test-flat )
(set 'lst '(a (b (c d))))
(= (map (fn (x) (ref x lst)) (flat lst)) '((0) (1 0) (1 1 0) (1 1 1))))
(define (test-float )
(float? (float "1,234")))
(define (test-flt)
(= (flt 1,23) 1067282596)
(= (flt 0,8) 1061997773)
(= (flt -0,8) 3209481421))
(define (test-float? )
(float? 1,234))
(define (test-floor )
(= 1 (floor 1,5)))
(define (test-for , x lst1 lst2)
(set 'lst1 '())
(set 'lst2 '())
(for (x 10 0 3)
(push x lst1))
(for (x 10 0 3 (< x 7))
(push x lst2))
(and
(= lst1 '(1 4 7 10))
(= lst2 '(7 10)) )
)
(define (test-for-all)
(and
(for-all number? '(2 3 4 6 7))
(not (for-all number? '(2 3 4 6 "hello" 7)) )
(for-all (fn (x) (= x 10)) '(10 10 10 10 10))
))
(define (test-fork) (integer? (fork (exit))))
(define (test-format )
(and
(= (format "%d" 1,23) "1")
(= (format "%5.2f" 10) "10,00")
(= (format "%c %s %d %g" 65 "hello" 123 1,23) "A hello 123 1,23")
(= (format "%5.2s" "hello") " he")
; args passed in a list
(= (format "%d" '(1,23)) "1")
(= (format "%5.2f" '(10)) "10,00")
(= (format "%c %s %d %g" '(65 "hello" 123 1,23)) "A hello 123 1,23")
(= (format "%5.2s" '("hello")) " he")
(set 'data '((1 "a001" "g") (2 "a101" "c") (3 "c220" "g")))
(set 'result (map (fn (x) (format "%3.2f %5s %2s" (nth 0 x) (nth 1 x) (nth 2 x))) data))
(set 'result (map (fn (x) (format "%3.2f %5s %2s" (x 0) (x 1) (x 2))) data))
(= result '("1,00 a001 g" "2,00 a101 c" "3,00 c220 g"))
(not (catch (format "%%" 1) 'result))
(not (catch (format "%10.2lf" 123) 'result))
(= (test-format-r '(("foo" "bar") ("foo" "baz")))
"[ [ 'foo', 'bar' ], [ 'foo', 'baz' ] ]")
; test 64-bit formatting
(if (find ostype '("Windows") ) ;; Win32 Win64
(begin
(and
(= (format "%I64d" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%I64x" 0x7fffffffffffffff) "7fffffffffffffff")
(= (format "%I64u" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%I64d" 0x8000000000000000) "-9223372036854775808")
(= (format "%I64x" 0x8000000000000000) "8000000000000000")
(= (format "%I64u" 0x8000000000000000) "9223372036854775808")
(= (format "%I64d" 0xFFFFFFFFFFFFFFFF) "-1")
(= (format "%I64x" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
(= (format "%I64u" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
)
(begin ;; UNIX like OS
(if (= ostype "Tru64Unix") ;TRU64
(begin
(and
(= (format "%d" 0x7fffffff) "2147483647")
(= (format "%d" 0xffffffff) "-1")
(= (format "%u" 0xffffffff) "4294967295")
(= (format "%i" 0x7fffffff) "2147483647")
; truncate
(= (format "%d" 0x7fffffffffffffff) "-1")
(= (format "%u" 0x7fffffffffffffff) "4294967295")
(= (format "%x" 0x7fffffffffffffff) "ffffffff")
(= (format "%X" 0x7fffffffffffffff) "FFFFFFFF")
(= (format "%ld" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%lu" 0xffffffffffffffff) "18446744073709551615")
(= (format "%li" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%lx" 0x7fffffffffffffff) "7fffffffffffffff")
(= (format "%ld" 0x8000000000000000) "-9223372036854775808")
(= (format "%lx" 0x8000000000000000) "8000000000000000")
(= (format "%lu" 0x8000000000000000) "9223372036854775808")
(= (format "%ld" 0xFFFFFFFFFFFFFFFF) "-1")
(= (format "%lx" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
(= (format "%lu" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
)
(begin ; all other UNIX, Linux, OS X
(and
(= (format "%d" 0x7fffffff) "2147483647")
(= (format "%d" 0xffffffff) "-1")
(= (format "%u" 0xffffffff) "4294967295")
; truncate
(= (format "%d" 0x7fffffffffffffff) "-1")
(= (format "%u" 0x7fffffffffffffff) "4294967295")
(= (format "%x" 0x7fffffffffffffff) "ffffffff")
(= (format "%X" 0x7fffffffffffffff) "FFFFFFFF")
(= (format "%lld" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%llx" 0x7fffffffffffffff) "7fffffffffffffff")
(= (format "%llu" 0x7fffffffffffffff) "9223372036854775807")
(= (format "%lld" 0x8000000000000000) "-9223372036854775808")
(= (format "%llx" 0x8000000000000000) "8000000000000000")
(= (format "%llu" 0x8000000000000000) "9223372036854775808")
(= (format "%lld" 0xFFFFFFFFFFFFFFFF) "-1")
(= (format "%llx" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
(= (format "%llu" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
)
)
))))
(define (test-format-r obj , s)
(cond
((string? obj) (format "'%s'" obj))
((list? obj) (format "[ %s ]" (join (map test-format-r obj) ", ")))
))
(define (test-fv )
(< (sub (fv 0,1 10 1000 0 0) -15937,4246) 1e-05))
(define (test-gammai )
(< (abs (sub (gammai 4 5) 0,734974)) 1e-05))
(define (test-gammaln )
(< (abs (sub 120 (exp (gammaln 6)))) 1e-05))
(define (test-gcd)
(and
(= (gcd 0) 0)
(= (gcd 1) 1)
(= (gcd 12 36) 12)
(= (gcd 12 36 6) 6)
(= (gcd 12 36 6 3) 3)
))
(define (test-get-char )
(and
(= 65 (get-char (address "A")) (get-char "ABC"))
(set 'D:D "ABC")
(= 65 (get-char D))
))
(define (test-get-float )
(= 1,234 (get-float (pack "lf" 1,234))))
(define (test-get-int )
(and
(= 123456789 (get-int (pack "ld" 123456789)))
(set 'adr (pack "ldld" 0xaabbccdd 0xccddeeff))
(= (format "%x" (get-int adr)) "aabbccdd")
(= (format "%x" (get-int (address adr))) "aabbccdd")
(= (format "%x" (get-int (+ (address adr) 0))) "aabbccdd")
(= (format "%x" (get-int (+ (address adr) 4))) "ccddeeff")
(set 'adr (pack "> ldld" 0xaabbccdd 0xccddeeff))
(= adr "\170\187\204\221\204\221\238\255")
(set 'adr (pack "< ldld" 0xaabbccdd 0xccddeeff))
(= adr "\221\204\187\170\255\238\221\204")
(set 'buff (pack "lulululululululu" 1 2 3 4))
(apply and (map (fn (i) (= (+ i 1) (get-int (+ (* i 4) (address buff))))) '(0 1 2 3)))
))
(define (test-get-long)
(set 'adr (pack "Ld" -1))
(= -1 (get-long adr)))
(define (test-get-string )
(= "hello" (get-string (address "hello"))))
(define (test-get-url )
(= "ERR: HTTP bad formed URL" (get-url "")))
(define (test-global)
(= global-myvar 123))
(define (test-global?)
(and
(global? 'global-myvar)
(global? 'println)
))
(define (test-if )
(and
(if true true)
(if nil nil true)
(if 'nil nil true)
(if '() nil true)
(= (if '()) '())
(= (if nil 1 '() 2) '())
(= (if nil '() '()) '())
(= (if true '() '()) '())
(= (if nil 1 nil 2 nil 3 true 4 3) 4)
(= (if nil 1 nil 2 nil 3 nil 4 3) 3)
; anaphoric $it
(if 123 (= $it 123))
))
(define (test-if-not )
(if-not nil
true nil))
(define (test-ifft )
(= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
(define (test-import )
(primitive? import))
(define (test-inc , x)
(and
(= (inc x) 1)
(= (inc x) 2)
(set 'l '(1 2 3 4))
(= (inc (l 1)) 3)
(= (dec (nth 0 l) 2) -1)
(= (dec (last l) 0,1) 3,9)
(= (inc (+ 3 4)) 8)
(= l '(-1 3 3 3,9))
))
(define (test---) (test-++))
(define (test-++ , x)
(and
(= (++ x) 1)
(= (++ x) 2)
(= (++ x 3) 5)
(set 'l '(0 nil 2,5))
(= (-- (l 0)) -1)
(= (++ (l 1)) 1)
(= (++ (l 2) 2) 4)
(= l '(-1 1 4))
)
)
(define (test-index )
(= '(1 3) (index (lambda (x) (> x 3)) '(1 5 2 6 2 0))))
(define (test-inf?)
(inf? (div 1 0)))
(define (test-int)
(and
(integer? (int "12345"))
(= (int " 12345") 12345)
(= (int "9223372036854775807") 9223372036854775807)
(= (int "-9223372036854775808") -9223372036854775808)
(= (int 0.0) 0)
(= (int 1e30) 9223372036854775807)
(= (int -1e30) -9223372036854775808)
(= (int 0x8000000000000000) (int "0x8000000000000000"))
(set 'D:D 12345)
(= (int D) 12345)
(= (int "gg" 99) 99)
(= (int "ff" 99 16) 255)
(= (int "-ff" 99 16) -255)
(= (int "0b101010") 42)
(= (int "101010" 0 2) 42)
))
(define (test-integer) (test-int))
(define (test-integer? )
(and
(integer? 12345)
(integer? 9223372036854775807)
(integer? -9223372036854775808)
(integer? 0x7FFFFFFFFFFFFFFF)
(integer? 0xFFFFFFFFFFFFFFFF)
))
(define (test-intersect )
(= (intersect '(3 0 2 4 1) '(1 4 2 5)) '(2 4 1)))
(define (test-invert )
(set 'A '((-1 1 1) (1 4 -5) (1 -2 0)))
(set 'I (multiply A (invert A)))
(set 'J (multiply (array 3 3 (flat A)) (invert (array 3 3 (flat A)))))
(and (< (sub 1 (nth 0 (nth 0 I))) 1e-06)
(< (sub 1 (nth 1 (nth 1 I))) 1e-06)
(< (sub 1 (nth 2 (nth 2 I))) 1e-06)
(= I (array-list J))
(not (invert '((0 1 0) (1 0 1) (0 0 0))) )
))
(define (test-irr )
(< (abs (sub (irr '(-1000 500 400 300 200 100)) 0,20272)) 0,0001))
(define (test-join )
(and
(= "this is a sentence" (join '("this" "is" "a" "sentence") " "))
(= "this_is_a_sentence" (join '("this_" "is_" "a_" "sentence")))
(= "" (join '()))
(= (join '("A" "B" "C") "-") "A-B-C")
(= (join '("A" "B" "C") "-" true) "A-B-C-")
))
(define (test-json-error)
(and
(not (json-parse {{"key" : "value" , "hello" "world"}}))
(= (json-error) '("missing : colon" 28))
))
; see also qa-specific-tests/qa-json
(define (test-json-parse)
(and
(= (json-parse { {"key" : "value" , "hello" : "world", "array" : [1, 2, 3, 4, 5]} })
'(("key" "value") ("hello" "world") ("array" (1 2 3 4 5))))
(= (json-parse { [1,2,3,4,5,6,{ "nested" : 777}, 8, 9] } )
'(1 2 3 4 5 6 (("nested" 777)) 8 9) )
))
(define (test-kmeans-query) true)
(define (test-kmeans-train)
(let (data '(
(1,85 1,89 0,11)
(2,11 2,14 0,85)
(2,48 2,26 0,19)
(2,43 2,14 1,59)
(2,29 4,18 1,06)
(1,17 4,46 1,02)
(3,12 3,1 1,4)
(9,44 2,65 7,37)
(8,16 3,83 8,93)
(8,49 5,31 7,47)
(7,01 4,2 11,9)
(6,57 4,96 11,91)
(8,63 2,51 8,11)
(7,18 3,46 8,7)
(8,17 6,59 7,49)
(6,79 8,72 8,62)
(5,44 5,9 5,57)
(7,56 7,93 5,06)
(3,61 7,95 5,11)
(6,77 6,04 3,76) ))
(< (abs (apply add (map sub (kmeans-train data 3 'MAIN:KMT)
'(403,8613998 122,6051922 91,49019772 85,06633163 82,74597619)))) 0,000001)
(= KMT:labels '(2 2 2 2 2 2 2 3 3 3 3 3 3 3 1 1 1 1 1 1))
(= KMT:clusters '((14 15 16 17 18 19) (0 1 2 3 4 5 6) (7 8 9 10 11 12 13)))
(< (abs (apply add (map sub KMT:deviations '(2,457052209 1,240236975 2,260089397)))) 0,000001)
(< (abs (apply add (map sub (flat KMT:centroids) (flat '((6,39 7,188333333 5,935)
(2,207142857 2,881428571 0,8885714286)
(7,925714286 3,845714286 9,198571429)))))) 0,000001)
(< (abs (apply add (map sub (kmeans-query '(1 2 3) KMT:centroids)
'(8,036487279 2,58693657 9,475994267)))) 0,000001)
)
true
)
(define (test-lambda? )
(lambda? qa))
(define (test-last )
(= 'f (last '(a b c d e f)))
(= "p" (last "newlisp"))
(= (array 2 '(5 6)) (last (array 3 2 (sequence 1 6))))
(not (catch (last '()) 'result))
)
(define (test-last-error)
(= (last-error 1) '(1 "not enough memory"))
)
(define (test-legal?)
(and
(legal? "abc")
(not (legal? "a b c"))
(set 'greek (pack "cccccccccccccccccc" 206 160 206 181 206 187 206 181 206 185 206
172 206 180 206 181 207 137))
(legal? greek)
))
(define (test-length )
(> (length (symbols)) 100)
(- 7 (length "newlisp"))
(= 3 (length 123))
(= 3 (length 123,456))
(= 1 (length 0))
(= 1 (length 0,789))
(= 7 (length 10e5))
)
(define (test-let )
(set 'a 123)
(set 'b 456)
(set 'p 111)
(set 'q 222)
(and
(let ((a 1) (b 2))
(= (+ a b) 3))
(= a 123)
(= b 456)
(let (p 3 q 4)
(= (+ q p) 7))
(= p 111)
(= q 222)
))
(define (test-letex)
(and
(= (letex (x '* y 3 z 4) (x y z)) 12)
(= (letex (x 1 y 2 z 3) (quote (x y z))) '(1 2 3))
(= (letex (x 1 y 2 z 3) '(x y z)) '(1 2 3))
(= (letex (x 1 y 2 z 3) '('x (quote y) z)) '('1 (quote 2) 3))
(= (letex (x 1) 'x) 1)
(set 'x 123 'y 456)
(= (letex (x 'y) 'x) 'y)
(= (letex (x 'y) x) 456)
(= (letex (x '(+ 3 4)) 'x) '(+ 3 4))
(= (letex (x '(+ 3 4)) x) 7)
))
(define (test-letn)
(set 'x 0 'y 0 'z 0)
(and
(= (letn ((x 1) (y (+ x 1)) (z (+ y 1))) (list x y z)) '(1 2 3))
(= 0 x y z))
)
(define (test-list )
(and (list? (list 1 2 3 4 5)) (= '(1) (list 1)) (= '(1 nil) (list
1 'nil))))
(define (test-list? )
(and (list? '(1 2 3 4 5)) (list? '())))
(define (test-load )
(write-file "junk" "(+ 3 4)")
(load "junk"))
(define (test-local)
(set 'a 10 'b 20)
(and
(= (local (a b) (set 'a 1 'b 2) (+ a b)) 3)
(= a 10)
(= b 20)))
(define (test-set-locale)
(list? (set-locale)))
(define (test-log )
(and
(= 1 (log (exp 1)))
(= 1 (log (exp 1) (exp 1)))
)
)
(define (test-lookup )
(and
(= 3 (lookup 1 '((2 3 4) (1 2 3))))
(= 2 (lookup 1 '((2 3 4) (1 2 3)) 1))
; default functor
(set 'D:D '((a 1 2 3) (b 4 5 6) (c 7 8 9)))
(= 6 (lookup 'b D -1))
))
(define (test-lower-case )
(= "abcdefghijklmnopqrstuvwxyz" (lower-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
(define (test-macro)
(= (unless testmacro (macro (testmacro x) (+ x x)))
(lambda-macro (x) (expand '(+ x x))))
)
(define (test-macro? )
(macro?
(define-macro (foo-macro))))
(define (test-main-args )
(and
(list? (main-args))
(list? $main-args)
(= $main-args (main-args))
(= ($main-args 0) ((main-args) 0) (main-args 0))
(= ($main-args -1) ((main-args) -1))
(= ($main-args -1) (main-args -1))
))
(define (test-make-dir )
(and (make-dir "foodir") (remove-dir "foodir")))
(define (test-map )
(and (= '(11 22 33) (map + '(10 20 30) '(1 2 3)))
(= '(2 4 6) (map (lambda (x) (+ x x)) '(1 2 3)))
(set 'D:D '(1 2 3 4 5))
(= (map pow D) '(1 4 9 16 25))
(= (map pow (array 5 D)) '(1 4 9 16 25))
))
(define (test-mat)
(set 'A '((1 2 3) (4 5 6)))
(set 'B A)
(and
(= (mat + A B) '((2 4 6) (8 10 12)))
(= (mat - A B) '((0 0 0) (0 0 0)))
(= (mat * A B) '((1 4 9) (16 25 36)))
(= (mat / A B) '((1 1 1) (1 1 1)))
(= (mat + A 2) '((3 4 5) (6 7 8)))
(= (mat - A 2) '((-1 0 1) (2 3 4)))
(= (mat * A 2) '((2 4 6) (8 10 12)))
(= (mat / A 2) '((0,5 1 1,5) (2 2,5 3)))
(= (mat + A 5) '((6 7 8) (9 10 11)))
(= (mat - A 2) '((-1 0 1) (2 3 4)))
(= (mat * A 3) '((3 6 9) (12 15 18)))
(= (mat / A 10) '((,1 ,2 ,3) (,4 ,5 ,6)))
(set 'op +)
(= (mat op A B) '((2 4 6) (8 10 12)))
(set 'op '+)
(= (mat op A B) '((2 4 6) (8 10 12)))
; default functor
(set 'DA:DA A)
(set 'DB:DB B)
(= (mat + DA DB) '((2 4 6) (8 10 12)))
(set 'B '((-1 1 1) (1 4 -5) (1 -2 0)))
(set 'A '((1 2 3) (4 5 6)))
(not (catch (mat + A B) 'result))
(starts-with result "ERR: wrong dimensions")
))
(define (test-match)
(and
(= (match '(a (b ?) d e *) '(a (b c) d e f g) true) '(a (b c) d e (f g)) )
(= (match '(a (b ?) d e *) '(a (b c) d e f g) ) '(c (f g)) )
(= (match '(a * b x) '(a b c d b x e f b x) true) '(a (b c d b x e f) b x) )
(= (match '(a * b x) '(a b c d b x e f b x) ) '((b c d b x e f)) )
(= (match '(? (?) x * ? (? e)) '(a (b) x y c (d e)) true) '(a (b) x (y) c (d e)) )
(= (match '(? (?) x * ? (? e)) '(a (b) x y c (d e))) '(a b (y) c d) )
(= (match '(a * b) '(a x b) true) '(a (x) b) )
(= (match '(a * b) '(a x b)) '((x)) )
(= (match '(a * b) '(a b) true) '(a () b) )
(= (match '(a * b) '(a b)) '(()) )
(= (match '( (? ?) * ) '( (x y) ) true) '((x y) ()) )
(= (match '( (? ?) * ) '( (x y) )) '(x y ()) )
(match '(+) '(a))
(match '(+) '(a b))
(not (match '(+) '()))
; default functors
(set 'P:P '(a (b ?) d e *) )
(set 'M:M '(a (b c) d e f g))
(true? (match P M))
))
(define (test-max )
(and (= 10 (max 3 6 10 8)) (= 1,2 (max 0,7 0,6 1,2))))
(define (test-member )
(and
(= '(3 4) (member 3 '(1 2 3 4)))
(= (member "LISP" "newLISP") "LISP")
(= (member "LI" "newLISP") "LISP")
(= (member "" "newLISP") "newLISP")
(not (member "xyz" "newLISP"))
(not (member "new" "this is NEWLISP" 0))
(= (member "new" "this is NEWLISP" 1) "NEWLISP")
; default functor
(set 'D:D '(1 2 3 4))
(= '(3 4) (member 3 D))
(set 'D:D "newLISP")
(= "LISP" (member "LI" D))
)
)
(define (test-message) true)
(define (test-min )
(and (= 3 (min 3 6 10 8)) (= 0,6 (min 0,7 0,6 1,2))))
(define (test-mod )
(and (< (sub (mod 10,5 3,3) 0,6) 0,0001)
(< (sub (mod 10 3) 1) 0,0001)
(< (sub (mod 10,5) 0,5) 0,0001)
))
(define (test-mul )
(= 1e-09 (mul 0,0001 1e-05)))
(define (test-multiply )
(let ((A '((1 2 3) (4 5 6))) (B '((1 2) (1 2) (1 2))))
(and
(= '((6 12) (15 30)) (multiply A B))
(= (array 2 2 (flat '((6 12) (15 30))))
(multiply (array 2 3 (flat A)) (array 3 2 (flat B))))
)
))
(define (test-net-accept )
(and
(set 'net-listen-test (set 'listen (net-listen 12345)))
(if (zero? (& (sys-info -1) 512)) ; IPv4
(set 'net-connect-test (set 'connect (net-connect "localhost" 12345)))
(set 'net-connect-test (set 'connect (net-connect "::1" 12345)))
)
(set 'server (net-accept listen))
(set 'net-send-test (= (net-send server "hello") 5))
(set 'net-select-test (net-select connect "r" 100000))
(set 'net-peek-test (= (net-peek connect) 5))
(set 'net-receive-test (net-receive connect buff 20))
(= buff "hello")
(set 'net-sessions-test (and
(find listen (net-sessions))
(find connect (net-sessions))
(find server (net-sessions))))
(set 'net-local-test (= (net-local server) (net-peer connect)))
(set 'net-peer-test (= (net-local connect) (net-peer server)))
(set 'net-close-test (net-close connect))
(set 'net-close-test (net-close server))
(set 'net-close-test (net-close listen))
(not (net-error))
))
(define (test-net-close ) net-close-test)
(define (test-net-connect ) net-connect-test)
(define (test-net-error )
(and
(not (net-close 12345))
(list? (net-error))))
(define (test-net-eval) true) ;; see special test prog
(define (test-net-interface) true) ;; test manually on multihoned machines
(define (test-net-keypad)
(net-keypad "1234567890"))
(define (test-net-listen ) net-listen-test)
(define (test-net-local ) net-local-test)
(define (test-net-ipv)
(and (= (net-ipv) 4) (= (net-ipv 6) 6) (= (net-ipv 4) 4)))
(define (test-net-lookup )
(if (zero? (& (sys-info -1) 512)) ; IPv4
(and (= "127.0.0.1" (net-lookup "localhost")) (string? (net-lookup "127.0.0.1")))
(and (= "localhost" (net-lookup "::1")) (= "::1" (net-lookup "localhost")))
)
)
(define (test-net-packet) true);
(define (test-net-peek ) net-peek-test)
(define (test-net-peer ) net-peer-test)
(define (test-net-ping) true) ; test manually on UNIX as root
(define (test-net-receive ) net-receive-test)
(define (test-net-receive-from)
(and
(set 'sock (net-listen 1234 "localhost" "udp"))
(set 'net-send-to-test (net-send-to "localhost" 1234 "hello" sock))
(set 'net-select-test (net-select sock "r" 1000000) )
(= "hello" (first (net-receive-from sock 10)))
(net-close sock)))
(define (test-net-receive-udp)
(write-file "udptest.lsp"
[text]
(map set '(in out sid) (map int (slice (main-args) 2)))
(semaphore sid 1) ; signal parent to start
(set 'msg (net-receive-udp in 20 2000000))
(sleep 100)
(if (not msg) (exit))
(net-send-udp "localhost" out (upper-case (first msg)))
(exit)
[/text]
)
(and
(set 'sid (semaphore))
(if (find ostype '("Windows" "OS/2"))
(process (string "newlisp udptest.lsp " 10001 " " 10002 " " sid))
(process (string "./newlisp udptest.lsp " 10001 " " 10002 " " sid)))
;(println "---------- testing UDP Win32/64 and OS/2 -------------")
;(println "waiting ...")
(semaphore sid -1) ; wait for child process
(sleep 100)
;(println "sending ...")
(net-send-udp "localhost" 10001 "hello")
;(println "receiving ...")
(set 'msg (net-receive-udp 10002 20 3000000))
;(println "msg:" msg)
(or (delete-file "udptest.lsp") true)
;(println "deleting semaphore:" (semaphore sid 0)) ; delete semaphore
;(println "------------------------------------------")
(if msg (set 'net-send-udp-test (= "HELLO" (first msg)) ) )))
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "AIX" "True64Unix" "Cygwin"))
(define (test-net-receive-udp)
(fork (begin (sleep 500) (net-send-udp "localhost" 10001 "hello")))
(set 'net-send-udp-test (= "hello" (first (net-receive-udp 10001 10)))))
)
(define (test-net-select ) net-select-test)
(define (test-net-send ) net-send-test)
(define (test-net-send-to ) net-send-to-test)
(define (test-net-send-udp ) net-send-udp-test)
(define (test-net-service ) (= 21 (net-service "ftp" "tcp")))
(define (test-net-sessions ) net-sessions-test)
(define (test-new)
(new QA 'MAIN:QA2))
(define (test-nil?)
(and
;test symbol-nil = logic-nil in order compare of count
(= (count '(nil true) (map (curry < 3) '(1 2 4 5))) '(2 2))
(= nil (not (nil? nil)))
(= '(nil true) (map nil? '(a nil)))))
(define (test-null?)
(= (map null? '(1 0 2 0,0 "hello" "" (a b c) () nil true))
'(nil true nil true nil true nil true true nil)))
(define (test-normal )
(and (float? (normal)) (float? (normal 10 3)) (list? (normal 10
3 100))))
(define (test-not )
(and (not (not (not '()))) (not (not (not (not (not nil))))) (not
(not (not (not true))))
(= '(true true true) (map not '(nil nil nil)))
(= '(nil nil nil) (map not '(true true true)))))
(define (test-now )
(and
(= (length (now)) 11)
(= 3600 (round (- (apply date-value (now 60)) (date-value)) 2))
)
)
(define (test-nper )
(< (sub (nper 0,1 1000 100000 0 0) -25,15885793) 1e-08))
(define (test-npv )
(< (sub (npv 0,1 '(-10000 3000 4200 6800)) 1188,443412) 1e-06))
(define (test-nth , l)
(and
(set 'l '(0 1 2))
(= 0 (nth 0 l))
(= 1 (nth 1 l))
(= 2 (nth 2 l))
(= 2 (nth -1 l))
(= (nth 0 "lisp") "l")
(= (nth 1 "lisp") "i")
(= (nth 3 "lisp") "p")
(= (nth -4 "lisp") "l")
(= (nth 0 "") "")
(set 'l '(a b (c d) (e f)))
(= 'a (l 0))
(= '(c d) (l 2))
(= 'c (l 2 0))
(= 'f (l -1 -1))
(= 'c (l '(2 0)))
(= 'f (l '(-1 -1)))
(set 'myarray (array 3 2 (sequence 1 6)))
(= (array 2 '(3 4)) (myarray 1))
(= 6 (myarray -1 -1))
(= (myarray '()) myarray)
(= (array 2 '(3 4)) (myarray '(1)))
(= 6 (myarray '(-1 -1)))
(= "L" ("newLISP" 3))
(constant 'constL '((1 2 3) (a b c)))
(set 'aref '(1 2))
(= (constL 1 2) 'c)
(= (nth '(1 2) constL) 'c)
(= (nth (list (- 2 1) (+ 1 1)) constL) 'c)
(= (nth aref constL) 'c)
(= (nth '() constL) constL)
; default functor
(set 'D:D '(a b (c d) (e f)))
(= 'a (D 0))
(= '(c d) (D 2))
(= 'c (D 2 0))
(= 'f (D -1 -1))
(= 'c (D '(2 0)))
(= 'f (D '(-1 -1)))
(= 'a (nth 0 D))
(= '(c d) (nth 2 D))
))
(define (test-number?)
(and
(number? 1)
(number? 1,23)
(not (number? 'x))
(not (number? "abc"))
(not (number? '(a b c)))
)
)
(define (test-open )
(and
(set 'fle (open "qa-comma" "read"))
(close fle)))
(define (test-or )
(and (or (or (= 1 2) nil nil) (or nil nil nil true)) (not (or nil
(= "a" "b") nil))))
(define (test-odd?)
(and (odd? 3) (not (odd? 2)) (odd? 3,34) (not (odd? 2,999))))
(define (test-pack )
(and
(= (pack "c c c" 65 66 67) "ABC")
(= (unpack "c c c" "ABC") '(65 66 67))
(set 's (pack "c d u" 10 12345 56789))
(= (unpack "c d u" s) '(10 12345 56789))
(set 's (pack "s10 f" "result" 1,23))
(= (first (unpack "s10 f" s)) "result\000\000\000\000")
(< (- (last (unpack "s10 f" s)) 1,23) 0,00001)
(set 's (pack "s3 lf" "result" 1,23))
(= (first (unpack "s3 f" s)) "res")
(= (pack "ccc" 65 66 67) "ABC")
(= (unpack "ccc" "ABC") '(65 66 67))
(set 's (pack "cdu" 10 12345 56789))
(= (unpack "cdu" s) '(10 12345 56789))
(set 's (pack "s10f" "result" 1,23))
(= (first (unpack "s10f" s)) "result\000\000\000\000")
(< (- (last (unpack "s10f" s)) 1,23) 0,00001)
(set 's (pack "s3lf" "result" 1,23))
(= (first (unpack "s3f" s)) "res")
(= "\001\000" (pack "<d" 1))
(= "\000\001" (pack ">d" 1))
(= "\001\000\000\000" (pack "<ld" 1))
(= "\000\000\000\001" (pack ">ld" 1))
(= '(12345678) (unpack "ld" (pack "ld" 12345678)))
(= '(12345678) (unpack "<ld" (pack "<ld" 12345678)))
(= '(12345678) (unpack ">ld" (pack ">ld" 12345678)))
(= (unpack "bbbbbbbb" (pack "<lf" 1,234)) '(88 57 180 200 118 190 243 63))
(= (unpack "bbbbbbbb" (pack ">lf" 1,234)) '(63 243 190 118 200 180 57 88))
(= (format "%20.2f" (first (unpack "lf" (pack "lf" 1234567890123456)))) " 1234567890123456,00")
))
(define (test-parse )
(and
(= 3 (length (parse "hello hi there")))
(= (parse "abcbdbe" "b") '("a" "c" "d" "e"))
(= (parse "," ",") '("" ""))
(= (parse "hello regular expression 1, 2, 3" {,\s*|\s+} 0)
'("hello" "regular" "expression" "1" "2" "3"))))
(define (test-prefix)
(set 's 'Foo:bar)
(= s (sym (term s) (prefix s))))
(define (test-peek)
(set 'fle (open "qa-comma" "r"))
(= (peek fle) (first (file-info "qa-comma")))
(close fle))
(define (test-pipe)
(write-file "pipe-child.lsp"
[text]
(set 'msg (read-line (int (nth 2 (main-args)))))
(write-line (int (nth 3 (main-args))) (upper-case msg))
(exit)
[/text]
)
(and
(set 'channel (pipe))
(set 'in (first channel))
(set 'out (last channel))
(if (find ostype '("Windows" "OS/2"))
(process (string "newlisp pipe-child.lsp " in " " out))
(process (string "./newlisp pipe-child.lsp " in " " out)))
(sleep 500)
(write-line out "hello there")
(sleep 500)
(= (read-line in) "HELLO THERE")
(delete-file "pipe-child.lsp")
)
)
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "Aix" "True64Unix" "Cygwin"))
(define (test-pipe)
(set 'channel (pipe))
(set 'in (first channel))
(set 'out (last channel))
(fork (write-line out (upper-case (read-line in))))
(write-line out "hello there")
(sleep 1000)
(= (read-line in) "HELLO THERE")
)
)
(define (test-pmt )
(< (sub (pmt 0,1 10 100000 0 0) -16274,53949) 1e-05))
(define (test-pop , r l)
(set 'r '())
(set 'l '(1 2 3 4 5 6 7 8 9 0))
(dotimes (x 10)
(push (pop l) r))
(and (= r '(0 9 8 7 6 5 4 3 2 1))
(set 'l '(a b (c d (x) e)))
(= 'x (pop l '(2 2 0)))
(set 'lst '(1 2 3 (4 5)()))
(push 'x lst -1 -1)
(= lst '(1 2 3 (4 5) (x)))
(push 'y lst -1 0)
(= lst '(1 2 3 (4 5) (y x)))
(push 'z lst -1 1)
(= lst '(1 2 3 (4 5) (y z x)))
(push 'p lst 4)
(= lst '(1 2 3 (4 5) p (y z x)))
(push 'q lst -2)
(= lst '(1 2 3 (4 5) p q (y z x)))
(push 'a lst 3 -3)
(= lst '(1 2 3 (a 4 5) p q (y z x)))
(= (pop lst 3 -3) 'a)
(= (pop lst -2) 'q)
(= (pop lst 4) 'p)
(= (pop lst -1 1) 'z)
(= (pop lst -1 0) 'y)
(= (pop lst -1 -1) 'x)
(= lst '(1 2 3 (4 5)()))
; test pop string
(set 's "newLISP")
(= (pop s) "n")
(= s "ewLISP")
(= (pop s 2) "L")
(= s "ewISP")
(= (pop s -1) "P")
(= s "ewIS")
(= (pop s -2 2) "IS")
(= s "ew")
(= (pop s -2 10) "ew")
(= s "")
(set 's "123456789")
(= (pop s 5) "6")
(= (pop s 5 -1) "")
(= s "12345789")
(set 's "123456789")
(= (pop s 5 5) "6789")
(set 's "x")
(= (pop s) "x")
(= s "")
(= (pop s) "")
(= (pop s) "")
(= s "")
; default functor
(set 'D:D '(a b (c d (x) e)))
(= 'x (pop D '(2 2 0)))
))
(define (test-pop-assoc)
(and
(set 'L '((a (b 1) (c (d 2)))))
(= (pop-assoc 'a L) '(a (b 1) (c (d 2))))
(= L '())
(set 'L '((a (b 1) (c (d 2)))))
( = (pop-assoc '(a b) L) '(b 1))
(= L '((a (c (d 2)))))
(set 'L '((a (b 1) (c (d 2)))))
(= (pop-assoc '(a c) L) '(c (d 2)))
(= L '((a (b 1))))
(set 'L '((a (b 1) (c (d 2)))))
(= (pop-assoc (list 'a 'c 'd) L) '(d 2))
(= L '((a (b 1) (c))))
(= (pop-assoc '(a c) L) '(c))
(= L '((a (b 1))))
(= (pop-assoc '(a b) L) '(b 1))
(= L '((a)))
(= (pop-assoc 'a L) '(a))
(= L '())
; default functor
(set 'D:D '((a (b 1) (c (d 2)))))
(= (pop-assoc 'a D) '(a (b 1) (c (d 2))))
(= D:D '())
)
)
(define (test-post-url )
(= "ERR: HTTP bad formed URL" (post-url "" "abc" "def")))
(define (test-pow )
(and
(= 1024 (pow 2 10))
(= 100 (pow 10))
))
(define (test-pretty-print)
(= (pretty-print) '(80 " " "%1.16g")))
(define (test-primitive? )
(primitive? primitive?))
(define (test-print )
(device (open "testprint" "w"))
(print "hello")
(close (device))
(and (= "hello" (read-file "testprint"))
(delete-file "testprint")))
(define (test-println )
(device (open "testprintln" "w"))
(print "hello")
(close (device))
(and
(= "hello" (slice (read-file "testprintln") 0 5))
(delete-file "testprintln")))
(define (test-prob-f)
(and
(< (abs (sub (prob-f 6,59 3 4) 0,05)) 0,001)
(< (abs (sub (prob-f 2,79 12 11) 0,05)) 0,001)
(< (abs (sub (prob-f 16,69 3 4) 0,01)) 0,0001)
(< (abs (sub (prob-f 4,40 12 11) 0,01)) 0,0001)
))
(define (test-prob-chi2)
(and
(< (abs (sub (prob-chi2 4,605 2) 0,1)) 0,001)
(< (abs (sub (prob-chi2 51,805 40) 0,1)) 0,001)
(< (abs (sub (prob-chi2 9,210 2) 0,01)) 0,0001)
(< (abs (sub (prob-chi2 63,691 40) 0,01)) 0,0001)
))
(define (test-prob-t)
(and
(< (abs (sub (prob-t 1,886 2) 0,1)) 0,001)
(< (abs (sub (prob-t 1,303 40) 0,1)) 0,001)
(< (abs (sub (prob-t 6,965 2) 0,01)) 0,0001)
(< (abs (sub (prob-t 2,423 40) 0,01)) 0,0001)
))
(define (test-prob-z)
(and
(< (sub (prob-z -0,1) 0,4601721627) 0,00001)
(< (sub (prob-z 0,1) 0,5398278373) 0,00001)
(< (sub (prob-z -1) 0,1586552539) 0,00001)
(< (sub (prob-z 1) 0,8413447461) 0,00001)
(< (sub (prob-z -2) 0,02275013195) 0,00001)
(< (sub (prob-z 2) 0,9772498681) 0,00001)
(< (sub (prob-z -3) 0,001349898032) 0,00001)
(< (sub (prob-z 3) 0,998650102) 0,00001)
))
(define (test-process )
(write-file "processtest" {(write-file "testprocess" "hello") (exit)})
(if (find ostype '("Windows" "OS/2"))
(process "newlisp processtest")
(process "./newlisp processtest"))
(until (file? "testprocess") (sleep 500))
(and
(= "hello" (read-file "testprocess"))
(delete-file "processtest")
(delete-file "testprocess")))
(define (test-prompt-event) true) /* test interactively */
(define (test-protected?)
(and
(protected? 'println)
(constant 'cval 123)
(protected? 'cval)
(protected? 'QA))
)
(define (test-push , l)
(dotimes (x 10)
(push x l x))
(and
(= l '(0 1 2 3 4 5 6 7 8 9))
(set 'l '(a b (c d () e)))
(push 'x l '(2 2 0))
(= (ref 'x l) '(2 2 0))
(set 'lst '(1 2 3 (4 5)()))
(push 'x lst -1 -1)
(= lst '(1 2 3 (4 5) (x)))
(push 'y lst -1 0)
(= lst '(1 2 3 (4 5) (y x)))
(push 'z lst -1 1)
(= lst '(1 2 3 (4 5) (y z x)))
(push 'p lst 4)
(= lst '(1 2 3 (4 5) p (y z x)))
(push 'q lst -2)
(= lst '(1 2 3 (4 5) p q (y z x)))
(push 'a lst 3 -3)
(= lst '(1 2 3 (a 4 5) p q (y z x)))
(= (pop lst 3 -3) 'a)
(= (pop lst -2) 'q)
(= (pop lst 4) 'p)
(= (pop lst -1 1) 'z)
(= (pop lst -1 0) 'y)
(= (pop lst -1 -1) 'x)
(= lst '(1 2 3 (4 5)()))
(set 'lst '((1)))
(push 2 lst -1 -1)
(= lst '((1 2)))
(test-push-pop)
(test-push-optimization-bug)
; test string push
(set 's "newLISP")
(= (push "#" s) "#newLISP")
(= (push "#" s 1) "##newLISP")
(= (push "#" s 3) "##n#ewLISP")
(= (push "#" s -1) "##n#ewLISP#")
(= (push "#" s -3) "##n#ewLIS#P#")
(= (push "xy" s) "xy##n#ewLIS#P#")
(= (push "xy" s -1) "xy##n#ewLIS#P#xy")
(= s "xy##n#ewLIS#P#xy")
(set 's "")
(= (push "" s) "")
(set 's "newLISP")
(= (push "" s -1) "newLISP")
(= (push "" s) "newLISP")
(= s "newLISP")
(push "-" s 7)
(= s "newLISP-")
(push "-" s -9)
(= s "-newLISP-")
(set 's "newLISP")
(= (push "-" s 8) "newLISP-")
(= (push "-" s -10) "-newLISP-")
; default functor
(set 'D:D '(a b (c d () e)))
(push 'x D '(2 2 0))
(= (ref 'x D) '(2 2 0))
(set 'D:D "newLISP")
(= (push "#" D:D) "#newLISP")
(= D:D "#newLISP")
))
(define (test-push-pop)
; string
(set 's "abcdefg")
(= (pop (push "h" s -1)) "a")
(= s "bcdefgh")
)
(define (test-push-optimization-bug) ; fixed in 8.7.1
(set 'l nil)
(and (push 'x l -1)
(set 'lst l)
(push 'y lst -1)
(= lst '(x y))))
(define (test-put-url )
(= "ERR: HTTP bad formed URL" (put-url "" "abc")))
(define (test-pv )
(< (sub (pv 0,1 10 1000 100000 0 0) -44696,89605) 1e-05))
(define (test-quote )
(= (quote x) 'x))
(define (test-quote? )
(quote? ''quote?))
(define (test-rand , sum)
(set 'sum 0)
(dotimes (x 1000)
(inc sum (rand 2)))
(and (< sum 600) (> sum 400) (list? (rand 10 100))))
(define (test-random )
(and (float? (random)) (= (length (random 0 1 10)) 10)))
(define (test-randomize)
(and
(!= '(a b c d e f g) (randomize '(a b c d e f g)))
(= (difference '(a b c d e f g) (randomize '(a b c d e f g))) '())
)
)
(define (test-read-expr , code)
(and
(set 'code "; a statement\n(define (double x) (+ x x))\n")
(= (read-expr code (context)) '(define (double x) (+ x x)))
(= $count 41))
)
(define (test-read-buffer )
(and
(set 'file (open "qa-comma" "read"))
(read-buffer file buff (nth 0 (file-info "qa-comma")))
(close file)
(set 'file (open "junk" "write"))
(write-buffer file buff (nth 0 (file-info "qa-comma")))
(close file)))
(define test-read test-read-buffer)
(define (test-read-char )
(and
(file-copy "qa-comma" "junk")
(delete-file "junk")))
(define (test-read-file )
(read-file "qa-dot")
(starts-with (read-file "file://qa-dot") "#!/usr/bin/env newlisp")
)
(define (test-read-key) true)
(define (test-read-line )
(line-count "qa-comma"))
(define (test-read-utf8)
(and
(write-file "utf8text.txt" MAIN:utf8str)
(setq fle (open "utf8text.txt" "read"))
(= (read-utf8 fle) (char (MAIN:utf8str 0)))
(close fle)
(delete-file "utf8text.txt")
))
(define (test-reader-event) true)
(define (test-real-path)
(and
(string? (real-path))
(string? (real-path "."))
(not (real-path "foofoo"))
(not (real-path "foofoo" true))
(if (!= ostype "Windows")
(let ( old-path (env "PATH"))
(and
(env "PATH" (append (real-path) ":" (env "PATH")))
; on Unix newLISP's which() is used to find executable path
(= (real-path "newlisp" true) (append (real-path) "/newlisp"))
(env "PATH" old-path))
)
true
)
))
(define (test-receive) true) ; tested with qa-message
(define (test-ref)
(and
(set 'pList '(a b (c d () e)))
(push 'x pList 2 2 0)
(= (ref 'x pList) '(2 2 0))
(= (ref '(x) pList) '(2 2))
(set 'v (ref '(x) pList))
(= (pList v) '(x))
;(= (ref 'foo pList) '()) changel in 10.2.18
(= (ref 'foo pList) nil)
; comparison functor
(= (ref 'e '(a b (c d (e) f)) =) '(2 2 0))
(= (ref 'e '(a b (c d (e) f)) >) '(0))
(= (ref 'e '(a b (c d (e) f)) <) '(2))
(= (ref 'e '(a b (c d (e) f)) (fn (x y) (or (= x y) (= y 'd)))) '(2 1))
(define (is-it-or-d x y) (or (= x y) (= y 'd)))
(= (ref 'e '(a b (c d (e) f)) is-it-or-d) '(2 1))
; comparison with match and unify
(= (ref '(a ?) '((l 3) (a 12) (k 5) (a 10) (z 22)) match) '(1))
(= (ref '(X X) '( ((a b) (c d)) ((e e) (f g)) ) unify) '(1 0))
(= (ref '(X g) '( ((a b) (c d)) ((e e) (f g)) ) unify) '(1 1))
; default functor
(set 'D:D '((l 3) (a 12) (k 5) (a 10) (z 22)) )
(= (ref '(a ?) D match) '(1))
))
(define (test-ref-all)
(and
(set 'L '(a b c (d a f (a h a)) (k a (m n a) (x))))
(= (ref-all 'a L) '((0) (3 1) (3 3 0) (3 3 2) (4 1) (4 2 2)))
(= (L '(3 1)) 'a)
(= (map 'L (ref-all 'a L)) '(a a a a a a))
(= (ref-all 'a '(1 2 3 4 5 6)) '())
; with comparison functor
(set 'L '(a b c (d f (h l a)) (k a (m n) (x))))
(= (ref-all 'c L =) '((2)))
(= (ref-all 'c L >) '((0) (1) (3 2 2) (4 1)))
(= (ref-all 'a L (fn (x y) (or (= x y) (= y 'k)))) ' ((0) (3 2 2) (4 0) (4 1)))
(define (is-long? x y) (> (length y) 2))
(= (ref-all nil L is-long?) '((3) (3 2) (4)))
(define (is-it-or-d x y) (or (= x y) (= y 'd)))
(= (ref-all 'e '(a b (c d (e) f)) is-it-or-d) '((2 1) (2 2 0)))
(= (ref-all 'b '(a b (c d (e) f)) is-it-or-d) '((1) (2 1)))
(= (ref-all nil '(((()))) (fn (x y) (> (length y) 0))) '((0) (0 0)))
; test comparison with match and unify
(= (ref-all '(a ?) '((l 3) (a 12) (k 5) (a 10) (z 22)) match) '((1) (3)))
(= (ref-all '(X X) '( ((a b) (c d)) ((e e) (f g)) ((z) (z))) unify) '((1 0) (2)))
(= (ref-all '(X g) '( ((x y z) g) ((a b) (c d)) ((e e) (f g))) unify) '((0) (2 1)))
))
(define (test-regex )
(and
(= (regex "http://(.*):(.*)" "http://nuevatec.com:80")
'("http://nuevatec.com:80" 0 22 "nuevatec.com" 7 12 "80" 20 2))
(= $0 "http://nuevatec.com:80")
(= $1 "nuevatec.com")
(= $2 "80")
(= (regex "b+" "AAAABBBAAAA" 1) '("BBB" 4 3))
(= (regex "b+" "AABBBAAABBA" 1 4) '("B" 4 1))
(= (regex "b+" "AABBBAAABBA" 1 5) '("BB" 8 2))
))
(define (test-regex-comp)
(and
(set 'pattern (regex-comp "http://(.*):(.*)"))
(find pattern "http://nuevatec.com:80" 0x10000)
(= $0 "http://nuevatec.com:80")
(= $1 "nuevatec.com")
(= $2 "80")
))
(define (test-remove-dir )
(and (make-dir "junk") (remove-dir "junk")))
(define (test-rename-file )
(copy-file "qa-comma" "junk")
(rename-file "junk" "junk2"))
;; this can run only once than must be reloaded
;; because some replace's are in place with a constant
(define (test-replace )
(and
(not (catch (replace "a" "akakak") 'result))
(not (catch (replace "a") 'result))
(not (catch (replace) 'result))
(catch (replace "a" '("x" "a" "y")) 'result)
(= (replace "a" "ababab" "b") "bbbbbb")
(= $count 3)
(= (replace 'a '(a a b a b a a a b a) 'b) '(b b b b b b b b b b))
(= (replace 'a '(a a b a b a a a b a)) '(b b b))
(= (replace 'a '(a)) '())
;; with regular expressions option
(= (replace "" "abc" "x" 0) "xaxbxcx")
(= (replace "$" "abc" "x" 0) "abcx")
(= (replace "^" "abc" "x" 0) "xabc")
(= (replace "\\b" "abc" "x" 0) "xabcx")
(= (replace "(?<=[0-9])(?=(?:[0-9]{3})+(?![0-9]))" "1234567" "," 0) "1,234,567")
(= (replace "a" "ababab" (upper-case $0) 0) "AbAbAb")
(= $count 3)
(set 'str2 "abaBab")
(= (replace "b|B" str2 "z" 0) "azazaz")
(= $count 3)
(replace-once "aaa")
(= (replace "%([0-9A-F][0-9A-F])" "%41123%42456%43" (char (int (append "0x" $1))) 1) "A123B456C")
; replace with comparison functor
(set 'L '(1 4 22 5 6 89 2 3 24))
(= (replace 10 L 10 <) '(1 4 10 5 6 10 2 3 10))
(set 'L '(1 4 22 5 6 89 2 3 24))
(= (replace 10 L 10 (fn (x y) (< x y))) '(1 4 10 5 6 10 2 3 10))
;
(set 'AL '((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
(= (replace '(mary *) AL (list 'mary (apply + (rest $it))) match)
'((john 5 6 4) (mary 14) (bob 4 2 7 9) (jane 3)))
(set 'AL '((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
(= (replace '(*) AL (list ($it 0) (apply + (rest $it))) match)
'((john 15) (mary 14) (bob 22) (jane 3)))
(set 'AL '((john 5 6 4) ("mary" 3 4 7) (bob 4 2 7 9) ("jane" 3)))
(= (replace nil AL (cons (sym ($it 0)) (rest $it)) (fn (x y) (string? (y 0))))
'((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
; default functor
(set 'D:D '(a a b a b a a a b a) )
(= (replace 'a D 'b) '(b b b b b b b b b b))
(set 'D:D "abc")
(= (replace "" D "x" 0) "xaxbxcx")
; regression for key cell part of list
(setq a '(b c d))
(= (replace (a 0) a (term (a 0))) '("b" c d))
))
(define (replace-once str)
(= (replace "a" str (upper-case $0) 0x8000) "Aaa") ;; custom option replace once
)
(define (test-reset )
true)
(define (test-rest , l)
(set 'l '(a b c d e f g))
(and (= (cons (first l) (rest l)) l)
(= (rest "newlisp") "ewlisp")
;; implicit nrest
(= (1 l) '(b c d e f g))
(= (10 l) '())
(= (0 l) l)
(= (-3 '(a b c d e f g)) '(e f g))
(= (-3 "abcdefg") "efg")
(= (1 '(A)) '())
(= (1 "A") "")
(= (array 2 2 (sequence 3 6)) (rest (array 3 2 (sequence 1 6))))
))
(define (test-reverse )
(and
(= (reverse '(1 2 3)) '(3 2 1))
(= (reverse "newLISP") "PSILwen")
(set 'D:D '(1 2 3))
(= (reverse D) '(3 2 1))
(set 'D:D "newLISP")
(= (reverse D) "PSILwen")
(set 'a (array 2 3 '(1 2 3 4 5 6)))
(reverse a)
(= a (array 2 3 '(4 5 6 1 2 3)))
))
(define (test-rotate )
(and
(= '(8 9 0 1 2 3 4 5 6 7) (rotate '(0 1 2 3 4 5 6 7 8 9) 2))
(= '() (rotate '()))
(= (rotate '(1) -1) '(1))
(= (rotate "") "")
(= (rotate "x" -1) "x")
(set 'str "abcdefg")
(= (rotate str) "gabcdef")
(= (rotate str 3) "defgabc")
(= (rotate str -4) "abcdefg")
(set 'D:D '(0 1 2 3 4 5 6 7 8 9))
(= '(8 9 0 1 2 3 4 5 6 7) (rotate D 2))
))
(define (test-round)
(and
(= (round 1,25) (round 1,25 0) 1)
(= (round 3,89) (round 3,89 0) 4)
(= (round 123,49 2) 100)
(= (round 123,49 1) 120)
(= (round 123,49 0) 123)
(= (round 123,49 -1) 123,5)
(= (round 123,49 -2) 123,49)
(= (round 123,49 -3) 123,49)
(!= (round 123,49 -2) 123,49000000000001)
(= (round 123,49 3) 0)
(= (round 0,05 -1) 0,1)
(= (round 0,5) 1)
(= (round 5 1) 10)
))
(define (test-save )
(and (save "all") (save "save.lsp" 'test-save) (delete-file "all")
(delete-file "save.lsp")))
(define (test-search , file)
(and
(set 'file (open "qa-comma" "read"))
(search file "define")
(close file)))
(define (test-seed )
(seed 123)
(set 'a (rand 10))
(seed 123)
(set 'b (rand 10))
(= a b)
; built-in PRNG with state recall
(seed 123 true)
(rand 100 100)
(set 'state (seed)) ; save state
(set 'r1 (rand 100 100))
(rand 100 100)
(normal 10 3 100)
(seed state true 0) ; recall state
(= r1 (rand 100 100))
)
(define (test-seek , file chr)
(set 'file (open "junk" "write"))
(dotimes (x 100)
(write-char file x))
(close file)
(set 'file (open "junk" "read"))
(seek file 65)
(set 'chr (read-char file))
(close file)
(delete-file "junk")
(= chr 65))
(define (test-select )
(set 'l '(0 1 2 3 4 5 6 7 8 9))
(and
(test-select-collect)
(= (select l '(0 9 9 0 1 8 8 1)) '(0 9 9 0 1 8 8 1))
(= (select "2001-09-20" '(5 6 8 9 0 1 2 3)) "09202001")
; default functor
(set 'D:D '(0 1 2 3 4 5 6 7 8 9))
(= (select D '(0 9 9 0 1 8 8 1)) '(0 9 9 0 1 8 8 1))
))
(new Class 'MAIN:Circle)
(define (test-self)
(define (Circle:move dx dy) (inc (self 1) dx) (inc (self 2) dy))
(set 'myc (list (Circle 1 2 3) (Circle 4 5 6)))
(:move (myc 0) 10 20)
(:move (myc 1) 10 20)
(= myc '((Circle 11 22 3) (Circle 14 25 6)))
)
;; for testing semaphores accross processes/threads see test-share
(define (test-semaphore)
(and
(set 'sid (semaphore))
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "AIX" "Tru64Unix" "Cygwin"))
(= (semaphore sid) 0) true) ;; no semaphore status on Win32/64
(semaphore sid 1)
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "AIX" "Tru64Unix" "Cygwin"))
(= (semaphore sid) 1) true) ;; no semaphore status on Win32/64
(semaphore sid 0)))
(define (test-send) true) ; tested with qa-message
(define (test-sequence )
(= (sequence 1 10 3) '(1 4 7 10)))
(define (test-series )
(and
(= (series 2 2 5) '(2 4 8 16 32))
(= (series 2 2 0) '())
(= (series 1 2 -10) '())
(= (series 1 1 5) '(1 1 1 1 1))
))
(define (test-set , x y z)
(set 'x (set 'y (set 'z 123)))
(= x 123))
(define (test-setf)
(and
(setf l '(a b c d e f g))
(setf (nth 3 l) 999)
(= l '(a b c 999 e f g))
(set 's "abcdefg")
(setf (s 3) (upper-case $it))
(= s "abcDefg")
(set 's "a-b-c-d-e-f-g")
(setf (first (replace "-" s "")) (upper-case $it))
(= s "Abcdefg")
(setf (s 2) "CCC")
(= s "AbCCCdefg")
(= (setf ((copy '(a b c)) 1) 'B) 'B)
))
(define (test-setq , x y z)
(setq x 1 y 2 z 3)
(and (= x 1) (= y 2) (= z 3)))
(define (test-set-ref)
(and
(set 'L '(z a b (z) (d (c c (c)) e f c)))
(= (set-ref 'c L 'z) '(z a b (z) (d (z c (c)) e f c)))
(set 'L '((a 1) (b 2) (a 3) (b 4)))
(= (set-ref '(a *) L '(z 99) match) '((z 99) (b 2) (a 3) (b 4)))
(= (set-ref '(a *) L '(z 99) match) '((z 99) (b 2) (z 99) (b 4)))
(set 'Ct:Ct '(a b c d e f g))
(= (set-ref 'c Ct 'z) '(a b z d e f g))
; default functor
(set 'D:D '(z a b (z) (d (c c (c)) e f c)))
(= (set-ref 'c D 'z) '(z a b (z) (d (z c (c)) e f c)))
)
)
(define (test-set-ref-all)
(and
(set 'L '(z a b (c) (d (c c (c)) e f c)))
(= (set-ref-all 'c L 'z) '(z a b (z) (d (z z (z)) e f z)))
(set 'L '((a 1) (b 2) (a 3) (b 4)))
(= (set-ref-all '(a *) L '(z 99) match) '((z 99) (b 2) (z 99) (b 4)))
)
)
(define (test-share)
(and
(if (find ostype '("Windows" "OS/2"))
(win32-test-share)
(unix-test-share))
(set 'mvar (share))
(not (share mvar nil))
(= (share mvar) nil)
(share mvar true)
(= (share mvar) true)
(share mvar 123)
(= (share mvar) 123)
(share mvar 123,456)
(= (share mvar) 123,456)
(share mvar "hello")
(= (share mvar) "hello")
; check sizes > pagesize
(share mvar (dup "X" 10000))
(= 10000 (length (share mvar)))
; force deletion of temporary file
(not (share mvar nil))
))
(define (win32-test-share)
(write-file "sharetest.lsp"
[text]
(map set '(sid mm) (map int (slice (main-args) 2)))
(if (= (share mm) "hello") (share mm "HELLO"))
(semaphore sid 1) ; signale parent to read
(exit)
[/text]
)
(and
(set 'sid (semaphore))
(set 'mm (share))
(share mm "hello")
(if (find ostype '("Windows" "OS/2"))
(process (string "newlisp sharetest.lsp " sid " " mm))
(process (string "./newlisp sharetest.lsp " sid " " mm)))
(semaphore sid -1) ; wait for child process
(semaphore sid 0) ;; delete semaphore
(= (share mm) "HELLO")
(or (delete-file "sharetest.lsp") true)))
(define (unix-test-share)
(and
(set 'mm (share))
(share mm "hello")
(wait-pid (fork (begin
(if (= (share mm) "hello")
(share mm "HELLO"))
(exit ))))
(= (share mm) "HELLO")
(share nil mm) ; unmap share
))
(define (test-sgn)
(and
(= 0 (sgn 0))
(= 1 (sgn 123))
(= -1 (sgn -3,5))))
(define (test-signal)
(primitive? signal))
(define (test-silent )
(primitive? silent))
(define (test-sin )
(= 1 (sin (asin (sin (asin 1))))))
(define (test-sinh)
(< (abs (sub (tanh 1) (div (sinh 1) (cosh 1)))) 0,0000000001)
)
(define (test-sleep )
(set 'start (time-of-day))
(sleep 10)
(set 'start (time-of-day))
(sleep 1000)
(set 'duration (- (time-of-day) start))
(and (> duration 500) (< duration 1500)))
(define (test-slice )
(and
(set 'str "0123456789")
(= (slice str 0 1) "0")
(= (slice str 0 3) "012")
(= (slice str 8 2) "89")
(= (slice str 8 10) "89")
(= (slice str 20 10) "")
(= (slice str 2 -2) "234567")
(= (slice str 2 -5) "234")
(= (slice str 2 -7) "2")
(= (slice str 2 -8) "")
(= (slice str 2 -9) "")
(= (slice '(a b c d e f g) 3 1) '(d))
(= (slice '(a b c d e f g) 3 0) '())
(= (slice '(a b c d e f g) 0 0) '())
(= (slice '(a b c d e f g) 10 10) '())
(= (slice '(a b c d e f g) 3 2) '(d e))
(= (slice '(a b c d e f g) 5) '(f g))
(= (slice '(a b c d e f g) -5 2) '(c d))
(= (slice '(a b c d e f g) -1 -2) '())
(= (slice '(a b c d e f g) 1 -2) '(b c d e))
(= (slice '(a b c d e f g) 4 -2) '(e))
(= (slice '(a b c d e f g) 4 -3) '())
(= (slice '(a b c d e f g) 4 -4) '())
(= (slice '(a b c d e f g) -6 -3) '(b c d))
;; implicit slice
(= (1 3 '(a b c d e f g)) '(b c d))
(= (-4 2 '(a b c d e f g)) '(d e))
(= (1 3 "abcdefg") "bcd")
(= (-4 2 "abcdefg") "de")
(= (1 -3 "abcdefg") "bcd")
(= (1 -5 "abcdefg") "b")
(= (1 -7 "abcdefg") "")
(setq x 1 y 2)
(= (x y '(a b c d e f g)) '(b c))
(= (x y "abcdefg") "bc")
(= (1 -2 '(a b c d e f g)) '(b c d e))
(= (4 -2 '(a b c d e f g)) '(e))
(= (4 -3 '(a b c d e f g)) '())
(= (4 -4 '(a b c d e f g)) '())
(= (-6 -3 '(a b c d e f g)) '(b c d))
; default functor
(set 'D:D "0123456789")
(= (slice D 0 1) "0")
(= (slice D 0 3) "012")
(set 'D:D '(a b c d e f g))
(= (slice D 3 1) '(d))
(= (1 3 D) '(b c d))
))
(define (test-sort )
(and
(= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5)))
(= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5)))
(= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5) <))
(= '(9 8 7 6 5 4 3 2 1) (sort '(9 1 8 2 7 3 6 4 5) >))
(= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5) (fn (x y) (< x y))))
(= '(9 8 7 6 5 4 3 2 1) (sort '(9 1 8 2 7 3 6 4 5) (fn (x y) (> x y))))
(= '() (sort '()))
(= (sort '(1 nil)) '(nil 1))
(= (sort '(a nil true 1 1,2)) (sort (list 'a nil true 1 1,2)) '(nil true 1 1,2 a))
;; at runtime generated sort function v10.4.6
(define (f<g= f g)
(expand (fn (a b) (f (g a) (g b))) 'f 'g))
(set 'lst '((c 4) (b 5) (a 2)))
(= (sort lst (f<g= < last)) '((a 2) (c 4) (b 5)))
)
)
(define (test-source)
(= (replace "\r|\n" (source 'test-sin) "" 0)
"(define (test-sin ) (= 1 (sin (asin (sin (asin 1))))))"))
(define (test-sqrt )
(and (= 10 (sqrt 100)) (= 1,2 (sqrt 1,44))))
(define (test-ssq)
(= 385 (ssq (sequence 1 10)) (ssq (array 10 (sequence 1 10))))
)
(define (test-starts-with )
(and
(starts-with "newlisp" "new")
(starts-with "newlisp" "NEW" 1)
(set 'D:D "newlisp")
(starts-with D "new")
(starts-with D "NEW" 1)
))
(define (test-stats)
(< (apply add (map sub (stats '(1 2 3 4 5)) '(5 3 1,2 1,58113883 2,5 0 -1,912))) 0,000000001)
)
(define (test-string )
(and (string? (string 12345)) (= (string 12345) "12345") (string?
(string 1.234))
(= (string 'test-string) "test-string")
(string? (string test-string))
(= (string "a" "b" "c") (append "a" "b" "c") "abc")
(= (string "a" 123 "b") "a123b")))
(define (test-string? )
(and (string? "1234") (not (string? 1234))))
(define (test-struct) ; more tests in qa-libffi
(struct 'complex "double" "double")
(= (unpack complex (pack complex 1,23 4,56)) '(1,23 4,56)))
(define (test-sub )
(= 0 (sub 0,99999999 0,99999999))
(= -123 (sub 123)))
(define (test-swap )
(and
; new (swap <place1> <place2>) in 10.0.3
(set 'lst '(1 2 3 4))
(= (swap (first lst) (last lst)) 1)
(= lst '(4 2 3 1))
(= (swap (lst 0) (lst -1)) 4)
(= lst '(1 2 3 4))
(set 'A (array 2 3 (sequence 1 6)))
(= (swap (A 0 0) (A -1 -1)) 1)
(= A (array 2 3 (flat '((6 2 3) (4 5 1)))))
(set 'lst '(a b c d))
(set 'x 'z)
(= (swap (lst 0) x) 'a)
(= lst '(z b c d))
(= x 'a)
)
)
(define (test-sym)
(and (= (sym "test-sym") 'test-sym)
(= (sym "test-sym" 'QA) 'test-sym)))
(define (test-symbol? )
(and
(symbol? (sym "test-sym"))
(symbol? (sym "a b"))
))
(define (test-symbols )
(and (list? (symbols)) (> (length (symbols)) 0)))
(define (test-sys-error) true)
; (integer? (sys-error 0) ))
(define (test-sys-info )
(and (list? (sys-info)) (= (length (sys-info)) 10)))
(define (test-tan )
(> 1 (tan (atan (tan (atan 1))))))
(define (test-tanh)
(< (abs (sub (sinh 1) (div (sub (exp 1) (exp -1)) 2))) 0,0000000001)
)
(define (test-term )
(= "term" (term 'term)))
(define test-name test-term)
(define (test-throw )
(and (catch (throw (+ 3 4)) 'msg) (= msg 7)))
(define (test-time )
(float? (time))
)
(define (test-time-of-day )
(float? (time-of-day)))
(define (test-trace )
(trace nil)
(= nil (trace)))
(define (test-trace-highlight )
(trace-highlight "#" "#"))
(define (test-transpose )
(= '((1) (2) (3)) (transpose '((1 2 3))))
(= '((a b) (c d) (e f)) (transpose '((a c e) (b d f))))
(= '((a d f) (b e g) (c nil nil)) (transpose '((a b c) (d e) (f g))))
(= '((a c f) (b d g)) (transpose '((a b) (c d e) (f g)))))
(define (test-trim )
(and
(= (trim " \n \t h e l l o \r ") "h e l l o")
(= (trim " hello ") "hello")
(= (trim "----hello----" "-") "hello")
(= (trim "----hello====" "-" "=") "hello")
(= (trim "000012345" "0" "") "12345")))
(define (test-true?)
(= (map true? '(x nil 1 nil "hi" ())) '(true nil true nil true nil)))
(define (test-unify)
(and
(= (unify 'A 'A) '())
(= (unify 'X 123) '((X 123)))
(= (unify '(Int Flt Str Sym Lst) '(123 4,56 "Hello" s '(a b c)))
'((Int 123) (Flt 4,56) (Str "Hello") (Sym s) (Lst '(a b c))))
(= (unify '(A B "hello") '("hi" A Z)) '((A "hi") (B "hi") (Z "hello")))
(= (unify '(A B) '(B abc)) '((A abc) (B abc)))
(= (unify '(B A) '(abc B)) '((B abc) (A abc)))
(= (unify '(A A C D) '(B C 1 C)) '((B 1) (A 1) (C 1) (D 1)))
(= (unify '(D C A A) '(C 1 C B)) '((D 1) (C 1) (B 1) (A 1)))
(= (unify '(f A) '(f (a b c))) '((A (a b c))))
(= (unify '(A f) '((a b c) f)) '((A (a b c))))
(= (unify '(f (g A)) '(f B)) '((B (g A))))
(= (unify '(p X Y a) '(p Y X X)) '((Y a) (X a)))
(= (unify '(p X Y) '(p Y X)) '((Y X)))
(= (unify '(q (p X Y) (p Y X)) '(q Z Z)) '((Y X) (Z (p X X))))
(= (unify '(f (g A) A) '(f B xyz)) '((B (g xyz)) (A xyz)))
(= (unify '(A (g abc)) '(B A)) '((B (g abc)) (A (g abc))))
;; with additional environment list
(= (unify '(A (B) X) '(A (A) Z) '((A 1) (Z 4)))
' ((A 1) (Z 4) (B 1) (X 4)))
))
(define (test-unicode)
(= (utf8 (unicode "newLISP")) "newLISP"))
(define (test-union)
(= (union '(1 3 1 4 4 3) '(2 1 5 6 4)) '(1 3 4 2 5 6)))
(define (test-unique )
(= (unique '(2 3 4 4 6 7 8 7)) '(2 3 4 6 7 8)))
(define (test-utf8len)
(= 23 (utf8len MAIN:utf8str)))
(define (test-unless )
(and
(= (unless nil (set 'x 1) (set 'y 2) (set 'z 3)) 3)
(= x 1) (= y 2) (= z 3)
(= (unless 123) 123)
(= (unless true) true)
(= (unless nil) nil)
))
(define (test-unpack )
(= (pack "c c c" 65 66 67) "ABC")
(= (unpack "c c c" "ABC") '(65 66 67)))
(define (test-until , x)
(set 'x 0)
(= 10 (until (= x 10) (inc x)) x))
(define (test-do-until , x)
(set 'x 0)
(and
(= 10 (do-until (= x 10) (inc x)) x)
(= 11 (do-until (> x 0) (inc x)) x)
))
(define (test-upper-case )
(= (upper-case "abcdefghijklmnopqrstuvwxyz") "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define (test-utf8)
(and
(= (utf8 (unicode "newLISP")) "newLISP")
(MAIN:utf8qa)))
(define (test-uuid)
(= 36 (length (uuid))))
(define (test-wait-pid)
(set 'pid (fork (begin (sleep 200)(exit))))
(wait-pid pid))
(define (test-when)
(and
(= (when true (set 'x 1) (set 'y 2) (set 'z 3)) 3)
(= x 1) (= y 2) (= z 3)
(= (when 123) 123)
(= (when nil) nil))
)
(define (test-while , x)
(and
(set 'x 0)
(= 1000 (while (< x 1000) (inc x)) x)
))
(define (test-do-while, x)
(and
(set 'x 0)
(= 100 (do-while (< x 100) (inc x)) x)
(= 101 (do-while (< x 100) (inc x)) x)
))
(define (test-write-buffer )
(set 'str "")
(dotimes (x 5) (write-buffer str "hello"))
(set 'Bf:Bf "")
(set 'S:S "hello")
(dotimes (x 5) (write-buffer Bf S))
(and
(= str "hellohellohellohellohello")
(= Bf:Bf str)
(test-read-buffer)
(set 'str "")
(write-buffer str S 3)
(= str "hel")
))
(define test-write test-write-buffer)
(define (test-write-char )
(file-copy "qa-comma" "junk")
(delete-file "junk"))
(define (test-write-file )
(and
(write-file "junk" "newlisp")
(write-file "file://junk2" "hello")
(= (read-file "junk") "newlisp")
(= (read-file "file://junk2") "hello")
(delete-file "file://junk2")
))
(define (test-write-line )
(and
(set 'fle (open "testwrite" "w"))
(write-line fle "hello")
(close fle)
(set 'fle (open "testwrite" "r"))
(= (read-line fle) "hello")
(close fle)
(delete-file "testwrite")
(set 'Bf:Bf "")
(set 'S:S "hello world")
(write-line Bf S)
(if (find ostype '("Windows") )
(= Bf:Bf "hello world\r\n")
(= Bf:Bf "hello world\n"))
))
(define (test-xfer-event)
(not (xfer-event)))
(define (test-xml-error )
(= (xml-error) nil))
(define (test-xml-parse )
(= (xml-parse "<hello att='value'></hello>") '(("ELEMENT" "hello"
(("att" "value"))
()))))
(define (test-xml-type-tags )
(length (xml-type-tags) 4))
(define (test-zero?)
(= (map zero? '(1 0 1,2 0,0)) '(nil true nil true)))
(define (test-| )
(= (| -1431655766 1431655765) -1))
(define (test-~ )
(and
(= (~ 0) -1)
(if
(find ostype '("Windows" "OS/2"))
(= (format "%I64x" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f")
(= ostype "True64Unix")
(= (format "%lx" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f")
(= (format "%llx" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f"))
))
;;;;;;;;;;;;;;;; test Cilk interface, run qa-cilk for more tests ;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-abort)
(and
(spawn 'x (+ 1 2))
(abort)))
(define (test-spawn)
(and
(set 'px (spawn 'x (+ 1 2 3 4)))
(set 'py (spawn 'y (+ 5 6 7 8)))
(if (!= ostype "Windows")
(begin
(find px (sync))
(find py (sync)))
true)
(true? (sync 1000))
(empty? (sync))
(= x 10)
(= y 26)
))
(define (test-sync) true)
(define (test-schedule) true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ENTRY POINT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (or (not (or (file? "newlisp") (file? "newlisp.exe"))) (not (file? "qa-comma")))
(begin
(println "both newlisp(.exe) and qa-comma should be in the current directory.")
(exit)))
(cleanup)
(println)
(println "Testing built-in functions ...")
(println)
(qa)
(cleanup)
(context 'MAIN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(println)
(println "Testing contexts as objects and scoping rules ...")
(println)
;; check creating local symbols
;; in case they already exist in MAIN
(set 'var 123)
(set 'CTX:var 456)
(if (or (!= CTX:var 456) (!= var 123))
(println " >>>> problem creating local symbols"))
(set 'ctx CTX)
(global 'myprint)
(set 'myprint print)
;; following would fail without dynamic symbols for non-existing
;; contexts because 'accnt' is not a context at this moment
(define (report accnt)
(list accnt:name accnt:balance))
;; late in ACCOUNT the definition of 'deposit' should
;; should not fail, locals should always be created for
;; the current context
(constant 'amount 999)
(constant 'stat 999)
;; the symbol defined should always be forced into the current
;; context, even if alread exists in MAIN, if not following
;; definition of 'deposit' would fail
(set 'deposit 999)
(set 'clear 999)
(constant 'withdraw 999)
(define balance 1000.00)
(constant 'phone "123-456-789")
(context 'ACCOUNT)
(set 'ACCOUNT:term "") ; force creation of local symbol with
(define balance 0,0) ; same name as built in primitive
(set 'phone "")
(constant 'const "foo") ; a protected variable
(define (deposit amount)
(inc balance amount))
(define (withdraw amount)
(dec balance amount))
; make sure contexts are inherited
; but not variables containing contexts
(if (not (context? CTX))
(QA:failed " >>>> problem inheriting context symbols"))
; make sure context variables get not inherited
(if (= ctx CTX) (QA:failed " >>>> should not inherit context var"))
(set 'ctx 123)
; make sure redefined primitives get inherited
(if (not (primitive? myprint))
(QA:failed " >>>> problem inheriting redefined primitives"))
(set 'myprint nil)
(context 'MAIN)
;; make sure again that context defs did not overwrite MAIN symbols
(if (or (!= deposit 999) (!= clear 999) (!= withdraw 999) (!= stat 999) (!= ctx CTX)
(not (primitive? term)) (!= balance 1000.0) (!= phone "123-456-789"))
(QA:failed " >>>> context definitions are overwriting MAIN"))
(new ACCOUNT 'John true) ; this creates a new context copy of
; ACCOUNT called 'John' if exists overwrite symbols
(set 'John:name "John Doe")
(set 'John:phone "555-123-456")
(unless (protected? 'John:const)
(QA:failed ">>>> symbol protection has not been copied"))
(John:deposit 100,00)
(John:withdraw 60)
(new ACCOUNT 'Anne true)
(set 'Anne:name "Anne Somebody")
(set 'Anne:phone "555-456-123")
(Anne:deposit 120,00)
(Anne:withdraw 50)
(if (or (!= John:balance 40) (!= Anne:balance 70))
(QA:failed " >>>> problem with methods in contexts"))
(if (or (!= (report John) (list John:name John:balance))
(!= (report Anne) (list Anne:name Anne:balance)))
(QA:failed " >>>> problem using context variables"))
(if (!= (map report (map eval '(John Anne)))
'(("John Doe" 40) ("Anne Somebody" 70)) )
(QA:failed " >>>> problem mapping functions using context vars"))
;; dynamic context var as symbol to be defined
;;
(define (defit)
(define (ctx:foo x) (+ x x)))
(set 'ctx ACCOUNT)
(defit)
(if (!= (ctx:foo 10) 20)
(QA:failed " >>>> problem with dyna symbols in defined symbol"))
;; check setq, define (as set) and inc, dec on dynamic context vars
;;
(define (foo-set ct value) (set 'ct:var value))
(define (foo-setq ct value) (setq ct:var value))
(define (foo-define ct value) (define ct:var value))
(define (foo-inc ct value) (inc ct:var))
(define (foo-dec ct value) (dec ct:var))
(set 'CTX:var 0) ;; make sure var is existent
(foo-set CTX 1)
(if (!= 1 CTX:var)
(QA:failed " >>>> problem with set on context vars"))
(foo-setq CTX 3)
(if (!= 3 CTX:var)
(QA:failed " >>>> problem with setq on context vars"))
(foo-define CTX 4)
(if (!= 4 CTX:var)
(QA:failed " >>>> problem with define on context vars"))
(foo-inc CTX)
(if (!= 5 CTX:var)
(QA:failed " >>>> problem with inc on context vars"))
(foo-dec CTX)
(if (!= 4 CTX:var)
(QA:failed " >>>> problem with dec on context vars"))
;; dynamic context vars inside a context (since version 7.5.1)
(context 'TST)
(define (init ctx value)
(set 'ctx:foo value))
;; since version 8.7.8 when calling a function in a context the current runtime
;; context changes
(define (test-context-change)
(= (context) TST))
(context MAIN)
;; foo does not exist in CTX
(TST:init CTX 999)
(if (!= 999 CTX:foo)
(QA:failed " >>>> problem with dyna vars in contexts"))
;; now foo does exist
(TST:init CTX 222)
(if (!= 222 CTX:foo)
(QA:failed " >>>> problem with dyna vars in contexts"))
(define (cdf:cdf a b) (+ a b))
(if (!= (cdf 3 4) 7)
(QA:failed " >>>> problem with context default vars"))
;; check for existence of dynamic context symbol
(define (check-sym-existence ctx)
(if (symbol? 'ctx:foovar) ;; will not create is only check
(QA:failed " >>>> problem with symbol? for dyna vars")))
(check-sym-existence CTX)
;; do not overwrite existing symbols
(set 'Actx:x 123)
(set 'Actx:y 456)
(set 'Bctx:x 999)
(new Actx Bctx)
(if (not (= Bctx:x 999))
(QA:failed " >>>> problem with new in overwriting symbols"))
;; delete contexts
(if (not (and
(delete 'ACCOUNT)
(delete 'Anne)
(delete 'John)
; (map delete '(Actx Bctx cdf))
) )
(QA:failed " >>>> problem deleting contexts"))
;; define static default functions
(define foobar:foobar)
(define (def-static s contents)
(def-new 'contents (sym (term s) s)))
(if (not
(and
(def-static 'foobar (fn (x) (+ x x)))
(= foobar:foobar (lambda (foobar:x) (+ foobar:x foobar:x)))
(= (foobar 10) 20)))
(QA:failed " >>>> problem with static default function definition"))
;; calling into context changes context
(if (not TST:test-context-change)
(QA:failed " >>>> problem changing runtime context with symbol"))
;; but calling with raw lambda doesn't
(if ((eval TST:test-context-change))
(QA:failed " >>>> problem maintaining runtime context with lambda"))
;; apply evaluates functor
(if (not (apply 'TST:test-context-change))
(QA:failed " >>>> problem changing runtime context with apply symbol"))
;; apply evaluates functor
(if (apply TST:test-context-change)
(QA:failed " >>>> problem maintaining runtime context with apply lambda"))
;; map evaluates functor
(if (!= (map 'TST:test-context-change '(a b c)) '(true true true))
(QA:failed " >>>> problem changing runtime context with map symbol"))
;; map evaluates functor
(if (!= (map TST:test-context-change '(a b c)) '(nil nil nil))
(QA:failed " >>>> problem maintaining runtime context with map lambda"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;; testing the default functor ;;;;;;;;;;;;;;;
(define (double:double x) (+ x x))
(define (test-default-functor)
(and
(= (map double '(1 2 3 4 5)) '(2 4 6 8 10))
(= (map 'double '(1 2 3 4 5)) '(2 4 6 8 10))
(set 'dflt:dflt '(a b c d e f g))
(= (map dflt '(1 2 6)) '(b c g))
(set 'i 0 'j -1 'k 6)
(= (dflt i) 'a)
(= (dflt k) 'g)
(= (dflt j) 'g)
))
(if (not (test-default-functor))
(QA:failed " >>>> problem testing default functor"))
;; hash-like access functions for namespaces
(if (not (and
(nil? (define Foo:Foo)) ; create namespace and default functor
(= (Foo "bar" 123) 123)
(= (Foo "bar") 123)
(= (Foo "bar" (+ 100 23)) 123)
(= (Foo (append "b" "ar")) 123)
(= (Foo '(("var" 123) ("bar" 456) ("baz" 789))) 'Foo)
(= (Foo) '(("bar" 456) ("baz" 789) ("var" 123)))
(= (Foo "var" (* 2 (Foo "var"))) 246)
(= (Foo 123 "hello") "hello" (Foo 123))
(nil? (Foo 123 nil))
)) (QA:failed " >>>> problem with hash functions for namespaces") true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(println)
(if QA:failed-messages
(begin
(println "TESTING FINISHED WITH ERRORS:")
(println)
(dolist (func (reverse QA:failed-messages))
(println func)))
(println "ALL FUNCTIONS FINISHED SUCCESSFULL"))
(println)
(delete-file "sharetest.lsp")
(delete-file "udptest.lsp")
(println "total time: " (- (time-of-day) start-of-qa))
(unless do-not-exit (exit))
;; eof
Reference in a new issue View git blame Copy permalink