newlisp/qa-specific-tests/qa-bench

2763 lines
72 KiB
Text
Executable file

#!/usr/bin/newlisp
;
; qa-bench - benchmarks most non-I/O functions
;
; USAGE
; =====
; from the newlisp-x.x.x/ directory:
;
; Run all benchmakrs and output one number comparing to the
; calibaration platform:
; ./newlisp /qa-specific-tests/qa-bench
;
; Calibrate for a specific platform:
; ./newlisp /qa-specific-tests/qa-bench calibrate
; ... this generates a file primes.lsp in the current directory
; the contents replaces the (set 'QA:primes ...) statement in qa-bench
;
; Report inividual results for each primitive tested:
; ./newlisp /qa-specific-tests/qa-bench report
; ... on the calibration platform is will output apprxomately 10 ms
; for each function.
(unless xml-parse
(println ">>>>> qa-bench needs needs XML support compiled")
(exit)
)
(set-locale "C")
(context 'Lex) ; predeclare/create context for bayes-train
(context MAIN)
; setup some stuff used later
(global 'global-myvar)
(set 'global-myvar 123)
(set '$0 "abcdefg")
(delete (sym "double")) ;; avoid error when running Emscripten intro before
(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)
(set 'failed-messages '())
(define (failed msg)
(push msg failed-messages))
(define (myappend x y)
(cond
((= '() x) y)
(true (cons (first x) (myappend (rest x) y)))))
(set 'primitives '(
!= $ % & * + - / < << <= = > >= >> NaN? ^ abs acos acosh
add address amb and append apply args array array-list array? asin asinh
assoc atan atan2 atanh atom? base64-dec base64-enc bayes-query bayes-train begin
beta betai bind binomial bits case catch ceil char chop clean collect
cond cons constant context context? copy cos cosh
count cpymem crc32 crit-chi2 crit-z curry date date-value dec
def-new default define define-macro delete det
difference div do-until do-while doargs dolist dostring dotimes
dotree dump dup empty? encrypt ends-with env erf error-event eval eval-string
exists exp expand explode factor fft filter find find-all
first flat float float? floor flt for for-all format fv gammai gammaln gcd
get-char get-float get-int get-long get-string global global? if if-not
ifft inc index int integer? intersect invert irr join lambda? last
last-error legal? length let letex letn list list? local log lookup lower-case
macro? main-args map mat match max member min mod mul multiply
new nil? normal not now nper npv nth null? number? or pack parse
pmt pop pop-assoc pow pretty-print primitive? prob-chi2
prob-z protected? push pv quote quote? rand random
randomize read-expr ref ref-all regex regex-comp replace rest
reverse rotate round seed select sequence series set
set-locale set-ref set-ref-all setf setq sgn sin sinh
slice sort source sqrt starts-with string string? sub swap sym symbol? symbols
sys-error sys-info tan tanh term throw throw-error time time-of-day title-case
transpose trim true? unify unique unless unpack
until upper-case uuid when while write-buffer
write-line xml-parse xml-type-tags zero? | ~))
; number of times to run a test-xxxx function
; on 2.3 GHz Intel Core i5 Mac Mini OX X 10.91
; and pass 1000 milliseconds
(set 'QA:primes '(
(!= 6053)
($ 25056)
(% 8760)
(& 30217)
(* 25346)
(+ 14084)
(- 30257)
(/ 18797)
(< 3022)
(<< 29441)
(<= 25578)
(= 2915)
(> 3056)
(>= 25067)
(>> 29320)
(NaN? 6689)
(^ 30002)
(abs 19338)
(acos 17728)
(acosh 25334)
(add 1100)
(address 5829)
(amb 17687)
(and 22068)
(append 811)
(apply 2373)
(args 9592)
(array 1374)
(array-list 2018)
(array? 2300)
(asin 7543)
(asinh 8852)
(assoc 1978)
(atan 13084)
(atan2 19131)
(atanh 20106)
(atom? 14913)
(base64-dec 3030)
(base64-enc 1819)
(bayes-query 14947)
(bayes-train 1449)
(begin
17015)
(beta 13924)
(betai 10034)
(bind 6360)
(binomial 14103)
(bits 2701)
(case 6907)
(catch 3158)
(ceil 31699)
(char 1809)
(chop 2193)
(clean 3283)
(collect 6354)
(cond
4163)
(cons 4743)
(constant 21374)
(context 21963)
(context? 30700)
(copy 9901)
(cos 17548)
(cosh 14825)
(count 1438)
(cpymem 8578)
(crc32 2773)
(crit-chi2 314)
(crit-z 5138)
(curry 1177)
(date 1381)
(date-value 24580)
(dec 7534)
(def-new 6353)
(default 1033)
(define 3065)
(define-macro 3104)
(delete 489)
(det 5633)
(difference 1106)
(div 13711)
(do-until 4763)
(do-while 826)
(doargs 10649)
(dolist 1378)
(dostring 5872)
(dotimes 2430)
(dotree 144)
(dump 11292)
(dup 2348)
(empty? 4194)
(encrypt 7443)
(ends-with 1106)
(env 879)
(erf 20568)
(error-event 33105)
(eval 8899)
(eval-string 3297)
(exists 1098)
(exp 12468)
(expand 1145)
(explode 936)
(factor 496)
(fft 9530)
(filter 1697)
(find 493)
(find-all 605)
(first 2454)
(flat 4612)
(float 23358)
(float? 46891)
(floor 31571)
(flt 32769)
(for 5018)
(for-all 2082)
(format 120)
(fv 18876)
(gammai 15399)
(gammaln 15592)
(gcd 8168)
(get-char 7645)
(get-float 12718)
(get-int 828)
(get-long 11219)
(get-string 12508)
(global 39818)
(global? 28470)
(if 5084)
(if-not 42924)
(ifft 9383)
(inc 4939)
(index 3909)
(int 6485)
(integer? 19445)
(intersect 2360)
(invert 617)
(irr 1621)
(join 1595)
(lambda? 46801)
(last 2378)
(last-error 15288)
(legal? 4744)
(length 1428)
(let 5611)
(letex 2014)
(letn 7377)
(list 10421)
(list? 23320)
(local 9311)
(log 12525)
(lookup 6393)
(lower-case 6685)
(macro? 31504)
(main-args 3196)
(map 3612)
(mat 332)
(match 969)
(max 15813)
(member 1416)
(min 15580)
(mod 12903)
(mul 29844)
(multiply 1147)
(new 244)
(nil? 3141)
(normal 1191)
(not 5147)
(now 9680)
(nper 19422)
(npv 14747)
(nth 749)
(null? 4556)
(number? 11851)
(or 9823)
(pack 394)
(parse 1144)
(pmt 18571)
(pop 548)
(pop-assoc 1586)
(pow 17674)
(pretty-print 11440)
(primitive? 46760)
(prob-chi2 13204)
(prob-z 21896)
(protected? 17128)
(push 435)
(pv 18318)
(quote 31454)
(quote? 41652)
(rand 89)
(random 12582)
(randomize 3009)
(read-expr 4715)
(ref 345)
(ref-all 147)
(regex 1389)
(regex-comp 3934)
(replace 150)
(rest 1057)
(reverse 5031)
(rotate 2282)
(round 1909)
(seed 2370)
(select 1721)
(sequence 19540)
(series 7188)
(set 15401)
(set-locale 17081)
(set-ref 1511)
(set-ref-all 2380)
(setf 1072)
(setq 12671)
(sgn 14249)
(sin 16651)
(sinh 12632)
(slice 507)
(sort 319)
(source 704)
(sqrt 19000)
(starts-with 4339)
(string 256)
(string? 21249)
(sub 20015)
(swap 1931)
(sym 9642)
(symbol? 10533)
(symbols 777)
(sys-error 28675)
(sys-info 13809)
(tan 15491)
(tanh 11477)
(term 17560)
(throw 4726)
(throw-error 2408)
(time 28520)
(time-of-day 13445)
(title-case 4709)
(transpose 1809)
(trim 2012)
(true? 8442)
(unify 335)
(unique 6150)
(unless 7231)
(unpack 6633)
(until 5849)
(upper-case 7117)
(uuid 7149)
(when 7225)
(while 840)
(write-buffer 2736)
(write-line 5587)
(xml-parse 4259)
(xml-type-tags 12922)
(zero? 13161)
(| 30349)
(~ 2971)))
;; run each test function once and collect errors
(define (qa)
(dolist (sm primes)
(set 'func (eval (sym (append "test-" (string (first sm))))))
(unless (apply func) (push (sm 0) errors))
)
)
;; run all test-xxx functions the number of times it would take to pass
;; 10 ms on the calibration platform
(define (bench (total-time 0))
(dolist (sm primes)
(when (and
(set 'func (eval (sym (append "test-" (string (first sm))))))
(set 'result (time (apply func) (mul (last sm) multiplier))))
(inc total-time result))
(when report-flag
(println (format "%-14s %5.1f ms" (string (first sm)) result)))
)
total-time
)
;; calibrate - find out how many times to run a test-xxxx function to pass
;; ms milliseconds time (default is one second)
(define (calibrate (ms 1000))
(set 'primes '())
(dolist (sm primitives)
(set 'func (eval (sym (append "test-" (string sm)))) )
(set 'N 0)
(set 'start-time (time-of-day))
(while (< (- (time-of-day) start-time) ms)
(dotimes (n 100) (apply func))
(inc N 1))
(push (list sm N) primes -1)
(println sm " -> " N)
)
(save "primes.lsp" 'primes)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; test-functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-$) (= ($ 0) $0))
(define (test-!= )
(and (not (!= -9223372036854775808 (& -9223372036854775808 -1))) (!= "abc" "ABC")
(!= "a" "¿")
(!= 1.000000001 1)
(!= "¿" "a")))
(define (test-% )
(and
(= (% 10 3) 1)
(= (% 5) 5))
(= (% 4.3 2) 0)
(= (% 4.3 2.2) 0)
(= (% 3.9 2) 1)
)
(define (test-& )
(= -9223372036854775808 (& -9223372036854775808 -1)))
(define (test-* )
(= (* (* 123456789 123456789)) 15241578750190521))
(define (test-+ )
(= (+ 999999999999999999 1) 1000000000000000000)
(= (+ 9223372036854775807 -9223372036854775808) -1)
(= (+ -9223372036854775808 -1) 9223372036854775807)) ; wraps around
(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)
(= '(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w))
'(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w)))
(= "¿¿¿¿¿¿¿¿¿¿¿" "¿¿¿¿¿¿¿¿¿¿¿")
(= '())
(= 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))
(= 1 (+ 1 NaN))
(= 0 (* 2 NaN))
(NaN? (add 1 (sqrt -1)))
(NaN? (abs (sqrt -1)))
(NaN? (div 0 0))
))
(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)
(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-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))
))
(define-macro (do-args p)
(= (args) '(2 "3 4" 5 (x y)))
(= (args 3 -1) 'y))
(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)
(= (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
(test-bayes-query)
(= (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-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 (check-case x)
(case x
(1 "one")
(2 "two")
(3 "three")))
(define (test-case )
(and (= (check-case 1) "one") (= (check-case 2) "two") (= (check-case
9) nil)))
(define (test-catch)
(and (not (catch (invalid-func) 'result))
(starts-with result "ERR: invalid function in function catch")
))
(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)
))
(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-collect)
(= (let (x 0) (collect (if (<= (inc x) 5) x))) '(1 2 3 4 5))
)
(define (test-crc32)
(= (crc32 "abcdefghijklmnopqrstuvwxyz") 1277644989))
(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 (check-cond x)
(cond
((= x 1) 1)
((= x 2) 2)
((= x 3) 3)))
(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-copy)
(and
(set 'aList '(a b c))
(= (replace 'b (copy aList)) '(a c))
(= aList '(a b c))
))
(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-z )
(< (abs (sub (crit-z 0.999) 3.090232)) 1e-05))
(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-value )
(= 0 (date-value 1970 1 1 0 0 0)))
(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 )
(delete (sym "xxx")))
(define (test-delete-url )
(= "ERR: bad formed URL" (delete-url "")))
(define (test-det)
(set 'A '((-1 1 1) (1 4 -5) (1 -2 0)))
(< (sub (det A) -1) 2e-10))
(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-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 (= 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-throw)
(= "Hello World"
(catch (begin (+ 1 2 3 4 5) (throw "Hello World"))))
)
(define (test-throw-error)
(and (not (catch (catch (throw-error "Hello")) 'result))
(starts-with result "ERR: user error : Hello")
))
(define (test-title-case)
(= (title-case "heLLo") "HeLLo")
(= (title-case "heLLo" true) "Hello"))
(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))
)
(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-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-factor)
(= (factor 123456789) '(3 3 3607 3803)))
(define (test-fft )
(= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
(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"))
))
(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)
)
(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))
(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-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"))
(= (test-format-r '(("foo" "bar") ("foo" "baz")))
"[ [ 'foo', 'bar' ], [ 'foo', 'baz' ] ]")
; test 64-bit formatting
(if (find ostype '("Windows")) ;; Windows
(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
(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-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)
))
(define (test-if-not )
(if-not nil
true nil))
(define (test-ifft )
(= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
(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-index )
(= '(1 3) (index (lambda (x) (> x 3)) '(1 5 2 6 2 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)
))
(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-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)
)
(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")))
(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-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? )
(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))
))
(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)))
))
(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)))
(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-term )
(= "term" (term 'term)))
(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 )
(= (length (now)) 11))
(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))
(= (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)
; 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-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-date-parse)
(and
(= (date-parse "2007.1.3" "%Y.%m.%d") 1167782400)
(= (date-parse "January 10, 07" "%B %d, %y") 1168387200)
))
(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: 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-prob-chi2 )
(< (abs (sub (prob-chi2 10 10) 0.440493)) 1e-05))
(define (test-prob-z )
(< (abs (sub (prob-z 0) 0.5)) 1e-05))
(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: 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 , clist) true
(set 'code "; a statement\n(define (double x) (+ x x))\n")
(= (read-expr code (context)) '(define (double x) (+ x x)))
)
(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))))
(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 (replace-once str)
(= (replace "a" str (upper-case $it) 0x8000) "Aaa") ;; custom option replace once
)
(define (test-replace)
(and
(set 'str "ababab")
(= (replace "a" str "b") "bbbbbb")
(set 'lst '(a a b a b a a a b a))
(= (replace 'a lst 'b) '(b b b b b b b b b b))
(set 'lst '(a))
(= (replace 'a lst) '())
(set 'str "abc")
(= (replace "" str "x" 0) "xaxbxcx")
(set 'str "abc")
(= (replace "$" str "x" 0) "abcx")
(set 'str "abc")
(= (replace "^" str "x" 0) "xabc")
(set 'str "abc")
(= (replace "\\b" str "x" 0) "xabcx")
(set 'str "1234567")
(= (replace "(?<=[0-9])(?=(?:[0-9]{3})+(?![0-9]))" str "," 0) "1,234,567")
(set 'str "ababab")
(= (replace "a" str (upper-case $it) 0) "AbAbAb")
(= $count 3)
(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))
(replace-once "aaa")
))
(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")
))
(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 3) 0)
(= (round 0.05 -1) 0.1)
(= (round 0.5) 1)
(= (round 5 1) 10)
))
(define (test-seed )
(seed 123)
(set 'a (rand 10))
(seed 123)
(set 'b (rand 10))
(= a b))
(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))
))
(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")
))
(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-sgn)
(and
(= 0 (sgn 0))
(= 1 (sgn 123))
(= -1 (sgn -3.5))))
(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-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) (fn (x y) (< x y))))
)
)
(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-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-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-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) (sys-error 1))
(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-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 " 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-unique )
(= (unique '(2 3 4 4 6 7 8 7)) '(2 3 4 6 7 8)))
(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-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-uuid)
(= 36 (length (uuid))))
(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)
(= 100 (while (< x 100) (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)
))
(define (test-write-line )
(and
(set 'Bf:Bf "")
(set 'S:S "hello world")
(write-line Bf S)
(if (find ostype '("Windows" "OS/2"))
(= Bf:Bf "hello world\r\n")
(= Bf:Bf "hello world\n"))
))
(define (test-xfer-event)
(not (xfer-event)))
(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"))
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ENTRY POINT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; this is only run to get a calibrated 'primes' table
; after running this replace the primes table in this code
(when (find "calibrate" (main-args))
(calibrate)
(exit)
)
;display-html only occurs in Emsripten compiled newLISP
(set 'Emscripten display-html)
;; for Emscripten take out throw and throw-error, they suppress output on console
(when Emscripten
(when (set 'pos (find '(throw ?) QA:primes match) )
(pop QA:primes pos) )
(when (set 'pos (find '(throw-error ?) QA:primes match) )
(pop QA:primes pos) )
)
;; test everything
(println)
(set 'report-flag nil)
(set 'errors '())
(set 'result (time (qa)))
(if errors
(dolist (f errors) (println "->" f))
(println (length primes) " non I/O functions performed SUCCESSFUL in " result " ms")
)
;; benchmark
(println)
(println ">>>>> Benchmarking all non I/O primitives ... (may take a while)")
(set 'report-flag (or Emscripten (find "report" (main-args))))
(if Emscripten
(set 'multiplier 0.2 'adjust 1.22)
(set 'multiplier 1 'adjust 1.03)
)
(set 'total-time (bench))
(println ">>>>> total time: " total-time)
(inc total-time (mul 0.5 (length primes)))
(println (format
">>>>> Performance ratio:%5.2f (1.0 on MacOSX 10.9, 2.3GHz Intel Core i5, newLISP v10.6.0-64-bit)"
(round (div (div total-time adjust) (mul 10 (length primes)) multiplier) -2)))
(context 'MAIN)
(sys-info)
; don't exit when running Emscrypten
(if (zero? (& (sys-info -1) 0x800)) (exit))
;; eof