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

3713 lines
98 KiB
Text
Executable file
Raw 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 comma
;;
;; ./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)
(set-locale "C")
(when utf8
(set-locale "en_US")
(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"))
; rewrite woth 'pop' and 'push', which currently do not work correctly with utf8
;(if (not (= (map char (explode (set-nth 2 utf8str (char 937))))
; '(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 'KMT)
(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)
(dolist (sm (symbols 'MAIN))
(if (not
(if (and (primitive? (eval sm)) (< sm 'zzz))
(begin
(unless MAIN:testing-cell-leaks (print " -> " (term sm) " \r"))
(set 'func (eval (sym (append "test-" (string sm)))) )
(and (catch (apply func) 'result) result))
true))
(failed (string " >>>> " sm " failed " result) )))
(unless MAIN:testing-cell-leaks (print " \n")))
(define (test-$) (find "a|b" "xtzabc" 0) (= ($ 0) $0))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; test-functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-!)
(integer? (! "")))
(define (test-!= )
(and (not (!= -9223372036854775808 (& -9223372036854775808 -1))) (!= "abc" "ABC")
(!= "a" "<22>")
(!= 1.000000001 1)
(!= "<22>" "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 (<= -9223372036854775808 -9223372036854775808) (<= 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 (> 9223372036854775807 -9223372036854775808) (> "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 "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-dot" "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-dot" "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))
(set 'L '(a b c d e f))
(= (count L L) '(1 1 1 1 1 1))
)
)
(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-dot" "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)
(= (date-parse "January 10, 07" "%B %d, %y") 1168387200)
))
(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-dot" "junk") (delete-file "junk")))
(define (test-delete-url )
(= "ERR: HTTP bad formed URL" (delete-url "")))
(define (test-destroy)
(if (find ostype '("Linux" "BSD" "OSX" "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))
(set 'L '(a b c d e f))
(= (difference L L) '())
)
)
(define (test-directory )
(or (find "qa-dot" (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)
;; default functor
(set 'D:D (sequence 1 10))
(set 'cnt 0)
(dolist (i D) (inc cnt i))
(= cnt (apply add D))
))
(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? "")
(set 'D:D (sequence 1 10))
(while D:D (pop D))
(empty? D)
))
(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-t-test)
(and
; dependent samples
(< (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-timer)
(timer 'alarm 4))
(define (test-title-case)
(= (title-case "heLLo") "HeLLo")
(= (title-case "heLLo" true) "Hello"))
(define (test-throw-error)
(and
(not (catch (throw-error "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 ) true
(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")
;; default functor
(set 'Le:Le '(a (B (c) (d a B))) )
(set 'p '((a 1) (B 2) (c 3) (d 4)))
(= (expand Le p) '(1 (2 (3) (4 1 2))))
))
(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 '(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-dot")))
(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))))
;; default functor
(set 'D:D '(a b c d e f g))
(= (first D) 'a)
(set 'D:D (array 7 '(a b c d e f g)))
(= (first D) 'a)
(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))
))
; use qa-pipe, qa-pipefork, qa-setsig in qa-specific-test/ to test fork
(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 and 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 )
(and
(= 1.234 (get-float (pack "lf" 1.234)))
(= (get-float (address (get-long (address 17.4)))) 17.4)
(= (get-long (address (get-float (address 4625590882276894310)))) 4625590882276894310)
) )
(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 )
(and
(starts-with (get-url "file://qa-dot") "#!/usr/bin/env newlisp")
(= "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-integer )
(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-int) (test-integer))
(define (test-integer? )
(and
(integer? 12345)
(integer? 9223372036854775807)
(integer? -9223372036854775808)
(integer? 0x7FFFFFFFFFFFFFFF)
(integer? 0xFFFFFFFFFFFFFFFF)
))
(define (test-intersect )
(and
(= (intersect '(3 0 2 4 1) '(1 4 2 5)) '(2 4 1))
(set 'L '(a b c d e f))
(= (intersect L L) L)
)
)
(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)
)
)
(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))))
;; default functor
(set 'D:D '(a b c d e f g))
(= (last D) 'g)
(set 'D:D (array 7 '(a b c d e f g)))
(= (last D) 'g)
(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-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 )
(and
(= (mul) 1)
(= 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 machine
(define (test-net-ipv)
(and (= (net-ipv) 4) (= (net-ipv 6) 6) (= (net-ipv 4) 4)))
(define (test-net-listen ) net-listen-test)
(define (test-net-local ) net-local-test)
(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 manualyy as superuser
(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" "SunOS" "AIX" "Tru64Unix" "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 (lambda) (fn) (lambda ())))
'(nil true nil true nil true nil true 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)))
(= (l '()) l)
(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-dot" "read"))
(close fle)))
(define (test-odd?)
(and (odd? 3) (not (odd? 2)) (odd? 3.34) (not (odd? 2.999))))
(define (test-or )
(and (or (or (= 1 2) nil nil) (or nil nil nil true)) (not (or nil
(= "a" "b") nil))))
(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-parse-date) (test-date-parse))
(define (test-prefix)
(set 's 'Foo:bar)
(= s (sym (term s) (prefix s))))
(define (test-peek)
(set 'fle (open "qa-dot" "r"))
(= (peek fle) (first (file-info "qa-dot")))
(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"))
(if (find ostype '("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 '())
; pop-assoc last, should disable nested last-element optimizations (10.5.4)
(= (set 'data '()) '())
(push '(1 (k_1 "v_1")) data)
(set 'result (push '(k_2 "v_2") (assoc 1 data) -1))
(pop-assoc '(1 k_2) data)
(= result (push '(k_2 "v_2") (assoc 1 data) -1))
)
)
(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 "process test" {(write-file "test process" "hello") (exit)})
(if (find ostype '("Windows" "OS/2"))
(process {newlisp '"process test"'}) ; Win32 and Win64
(process "./newlisp 'process test'")) ; Unix
(until (file? "test process") (sleep 500))
(sleep 200)
(and
(= "hello" (read-file "test process"))
(delete-file "process test")
(delete-file "test process")))
(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-dot" "read"))
(read-buffer file buff (nth 0 (file-info "qa-dot")))
(close file)
(set 'file (open "junk" "write"))
(write-buffer file buff (nth 0 (file-info "qa-dot")))
(close file)))
(define test-read test-read-buffer)
(define (test-read-char )
(and
(file-copy "qa-dot" "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-dot"))
(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
)
))
; tested with qa-specific-tests/qa-message
(define (test-receive) true)
(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) '()) changed 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))
; with comparison functor
(= (ref-all 'a '(1 2 3 4 5 6)) '())
(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-dot" "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 $it) 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 $it) 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))))
;; default functor
(set 'D:D '(a b c d e f g))
(= (rest D) '(b c d e f g))
(set 'D:D (array 7 '(a b c d e f g)))
(= (rest D) (array 6 '(b c d e f g)))
))
(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-dot" "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
(semaphore sid 1)
(if (find ostype '("Linux" "BSD" "OSX" "Solaris" "SunOS" "AIX" "Tru64Unix" "Cygwin"))
(= (semaphore sid) 1) true) ;; no semaphore status on Win32
(semaphore sid 0)))
; tested with qa-specific-tests/qa-message
(define (test-send) true)
(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))
(= (series "a" (fn (c) (char (inc (char c)))) 5) '("a" "b" "c" "d" "e"))
(= (series 1 (fn (x) (* 2 x)) 5) '(1 2 4 8 16))
))
(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"))
(windows-test-share)
(unix-test-share))
(set 'mvar (share))
(not (share mvar nil))
(= (share mvar) nil) ; nil
(share mvar true)
(= (share mvar) true) ; true
(share mvar 123)
(= (share mvar) 123) ; integer
(share mvar 123.456)
(= (share mvar) 123.456) ; float
(share mvar "hello")
(= (share mvar) "hello") ; string
(share mvar '(a b c d e f))
(= (share mvar) '(a b c d e f)) ; list
; check sizes > pagesize
(share mvar (dup "X" 10000))
(= 10000 (length (share mvar)))
; force deletion of temporary file
(not (share mvar nil))
(unless (= ostype "Windows") (share nil mvar))
))
(define (windows-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
(sleep 1000)
(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))))
; test manually
(define (test-signal) true)
(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-symbol"))
(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 )
(and
(= '((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))))
;; transpose arrays
(set 'A (array 2 3 (sequence 1 6)))
(= (array-list (transpose A)) '((1 4) (2 5) (3 6)))
))
(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 "000012345" "0" "") "12345")))
(define (test-true?)
(= (map true? '(x nil 1 nil "hi" ())) '(true nil true nil true nil)))
(define (test-unicode)
(= (utf8 (unicode "newLISP")) "newLISP"))
(define (test-unify)
(and
(= (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 'A) '())
(= (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-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-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-utf8len)
(= 23 (utf8len MAIN:utf8str)))
(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)
(= (when true) true)
))
(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-dot" "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)
))
; more testing can be found in qa-specific-test/qa-cilk
(define (test-spawn)
(and
(set 'pw (spawn 'w (list 'a 'b 'c 'd 'e 'f))) ; list
(set 'px (spawn 'x (+ 1 2 3 4))) ; integer
(set 'py (spawn 'y (add 1.23 4.56))) ; float
(set 'pz (spawn 'z (upper-case "hello world"))) ;string
(if (!= ostype "Windows")
(begin
(find pw (sync))
(find px (sync))
(find py (sync))
(find pz (sync)))
true)
(true? (sync 1000))
(empty? (sync))
(= w '(a b c d e f))
(= x 10)
(< (abs (sub y 5.79)) 0.0000000001)
(= z "HELLO WORLD")
))
(define (test-sync) true)
(define (test-schedule) true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ENTRY POINT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (or (not (or (file? "newlisp") (file? "newlisp.exe"))) (not (file? "qa-dot")))
(begin
(println "both newlisp(.exe) and qa-dot should be in the current directory.")
(exit)))
(cleanup)
(unless MAIN:testing-cell-leaks
(println)
(println "Testing built-in functions ..."))
(qa)
(cleanup)
(context 'MAIN)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless MAIN:testing-cell-leaks
(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 'term 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) ;; check only, will not create
(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)
) )
(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"))
;; 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)
; accept integers as keys since 10.5.6 (get converted to strings)
(= (Foo 123 "hello") "hello" (Foo 123))
(nil? (Foo 123 nil))
)) (QA:failed " >>>> problem with hash functions for namespaces") true)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(unless testing-cell-leaks (println "total time: " (- (time-of-day) start-of-qa) "\n"))
(if QA:failed-messages
(begin
(println ">>>>> TESTING: " (main-args 0) " FINISHED WITH ERRORS:")
(println)
(dolist (func (reverse QA:failed-messages))
(println func)))
(unless testing-cell-leaks
(println ">>>>> ALL FUNCTIONS FINISHED SUCCESSFUL: " (main-args 0))
(println))
)
(delete-file "sharetest.lsp")
(delete-file "udptest.lsp")
(sys-info)
(unless do-not-exit (exit))
;; eof
Reference in a new issue View git blame Copy permalink