2763 lines
72 KiB
Text
Executable file
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
|
|
|
|
|
|
|