qa-dot

   1 #!/usr/bin/newlisp
   2 (set 'start-of-qa (time-of-day))
   3 ;;
   4 ;; General test suite testing functioning of all built in primitives.
   5 ;;
   6 ;; use from inside the newlisp-x.x.x/ directory
   7 ;;
   8 ;;   ./newlisp qa-dot
   9 ;;
  10 ;;   or for countries and configurations with decimal
  11 ;;
  12 ;;   ./newlisp qa-comma (for countries and configurations with decimal , )
  13 ;;
  14
  15 (set (sym "test-:" 'QA) (lambda () true))
  16 (context 'Lex)  ; predeclare/create context for bayes-train
  17 (context MAIN)
  18 (define (utf8qa)
  19 (set-locale "en_US")
  20
  21 (set 'unicodelist '(913 914 915 916 937 945 946 947 948 969 32
  22                  1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10))
  23
  24 (set 'utf8str (join (map char unicodelist)))
  25
  26
  27 (if (not (= (length (char 937)) 2)) (QA:failed "UTF-8 char: failed"))
  28
  29 (if (not (and
  30     (= (map char (explode (chop utf8str))) (chop unicodelist))
  31     (= (map char (explode (chop utf8str 3))) (chop unicodelist 3))
  32     (= (map char (explode (chop utf8str 5))) (chop unicodelist 5)))) (QA:failed "UTF-8 chop: failed"))
  33
  34 (if (not (= (map char (explode utf8str)) unicodelist)) (QA:failed "UTF-8 explode: failed"))
  35
  36 (if (not (= (map char (explode (upper-case utf8str)))
  37     '(913 914 915 916 937 913 914 915 916 937 32 1040 1041 1042 1043 1044 1040 1041 1042 1043 1044 13 10)))
  38     (QA:failed "UTF-8 upper-case: failed"))
  39
  40 (if (not (= (map char (explode (lower-case utf8str)))
  41     '(945 946 947 948 969 945 946 947 948 969 32 1072 1073 1074 1075 1076 1072 1073 1074 1075 1076 13 10)))
  42     (QA:failed "UTF-8 lower-case: failed"))
  43
  44 (if (not (= (map char (explode (first utf8str))) '(913))) (QA:failed "UTF-8 first: failed"))
  45
  46 (if (not (= (map char (explode (last utf8str))) '(10))) (QA:failed "UTF-8 last: failed"))
  47
  48 (if (not (= (map char (explode (rest utf8str)))
  49     '(914 915 916 937 945 946 947 948 969 32 1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10)))
  50     (QA:failed "UTF-8 rest: failed"))
  51
  52 (if (not (= (map char (explode (first (rest utf8str)))) '(914))) (QA:failed "UTF-8 first, rest: failed"))
  53
  54 (if (not
  55   (and (= (map char (explode (select utf8str 1 2 3))) '(914 915 916))
  56        (= (map char (explode (select utf8str -1 -2 -3))) '(10 13 1076))
  57        (= (map char (explode (select utf8str 2 4 6))) '(915 937 946))))
  58   (QA:failed "UTF-8 select: failed"))
  59
  60
  61 (if (not (= (map char (explode (select utf8str '(1 2 3)))) '(914 915 916))) (QA:failed "UTF-8 select: failed"))
  62
  63 (if (not (and
  64     (= (map char (explode (nth 1 utf8str))) '(914))
  65     (= (map char (explode (nth -5 utf8str))) '(1074))))
  66  (QA:failed "UTF-8 nth: failed"))
  67
  68 (if (not (= (map char (explode (nth-set 2 utf8str (char 937)))) '(915))) (QA:failed "UTF-8 nth-set: failed"))
  69
  70 (if (not (= (map char (explode (set-nth 2 utf8str (char 937))))
  71     '(913 914 937 916 937 945 946 947 948 969 32 1040 1041 1042 1043 1044 1072 1073 1074 1075 1076 13 10)))
  72     (QA:failed "UTF-8 set-nth: failed"))
  73
  74 true
  75 )
  76
  77 (global 'global-myvar)
  78 (set 'global-myvar 123)
  79
  80 ; testing the default functor
  81
  82 (define (double:double x) (+ x x))
  83
  84 (define (test-default-functor)
  85         (and
  86                 (= (map double '(1 2 3 4 5)) '(2 4 6 8 10))
  87                 (= (map 'double '(1 2 3 4 5)) '(2 4 6 8 10))
  88                 (set 'dflt:dflt '(a b c d e f g))
  89                 (= (map dflt '(1 2 6)) '(b c g))
  90                 (set 'i 0 'j -1 'k 6)
  91                 (= (dflt i) 'a)
  92                 (= (dflt k) 'g)
  93                 (= (dflt j) 'g)
  94                 (set 'ctx dflt)
  95                 (= (default ctx) 'dflt:dflt)
  96                 (= (default dflt) 'dflt:dflt)
  97                 (sort (eval (default ctx)) >)
  98                 (= dflt:dflt '(g f e d c b a))
  99 ))
 100
 101
 102 (context 'QA)
 103
 104 ;; get operating system
 105 (set 'opsys (& (last (sys-info)) 0xf))
 106
 107 (define (cleanup)
 108   (delete-file "junk")
 109   (delete-file "junk2"))
 110
 111 (set 'failed-messages '())
 112
 113 (define (check-case x)
 114   (case x
 115    (1 "one")
 116    (2 "two")
 117    (3 "three")))
 118
 119 (define (check-cond x)
 120   (cond
 121    ((= x 1) 1)
 122    ((= x 2) 2)
 123    ((= x 3) 3)))
 124
 125 (define (checkqa )
 126   (dolist (p (symbols 'MAIN))
 127    (if (primitive? (eval p))
 128     (begin
 129      (set 'sm (sym (append "test-" (string p))))
 130      (if (not (lambda? (eval sm)))
 131       (print sm "\n"))))))
 132
 133 (define-macro (do-args p)
 134   (= (args) '(2 "3 4" 5 (x y)))
 135   (= (args 3 -1) 'y))
 136
 137 (define (failed msg)
 138 ;  (println msg)
 139   (push msg failed-messages))
 140
 141 (define (file-copy from-file to-file)
 142   (set 'in-file (open from-file "read"))
 143   (set 'out-file (open to-file "write"))
 144   (while (set 'chr (read-char in-file))
 145    (if (not (= chr 95))
 146     (write-char out-file chr)))
 147   (close in-file)
 148   (close out-file))
 149
 150 (define (line-count file)
 151   (device (open file "read"))
 152   (set 'cnt 0)
 153   (while (read-line)
 154    (inc 'cnt))
 155   (close (device))cnt)
 156
 157 (define (myappend x y)
 158   (cond
 159    ((= '() x) y)
 160    (true (cons (first x) (myappend (rest x) y)))))
 161
 162 (define (qa )
 163   (dolist (sm (symbols 'MAIN))
 164    (if (not
 165      (if (and (primitive? (eval sm)) (< sm 'zzzz))
 166        (begin
 167           (print (name sm) " ")
 168           (set 'func (eval (sym (append "test-" (string sm)))) )
 169           (and (catch (apply func) 'result)  result))
 170        true))
 171      (failed (string ">>>> " sm " failed " result) )))
 172   (println))
 173
 174 (define (test-$) (find "a|b" "xtzabc" 0) (= ($ 0) $0))
 175
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; test-functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177
 178 (define (test-!)
 179   (integer? (! "")))
 180
 181 (define (test-!= )
 182   (and (not (!= -9223372036854775808 (& -9223372036854775808 -1))) (!= "abc" "ABC")
 183    (!= "a" "ä")
 184    (!= 1.000000001 1)
 185    (!= "á" "a")))
 186
 187 (define (test-$)
 188         (set '$0 123)
 189         (= ($ 0) 123))
 190
 191 (define (test-% )
 192   (and
 193     (= (% 10 3) 1)
 194     (not (catch (%) 'result))))
 195
 196 (define (test-& )
 197   (= -9223372036854775808 (& -9223372036854775808 -1)))
 198
 199 (define (test-* )
 200   (= (* (* 123456789 123456789)) 15241578750190521))
 201
 202 (define (test-+ )
 203   (= (+ 999999999999999999 1) 1000000000000000000)
 204   (= (+ 9223372036854775807 -9223372036854775808) -1)
 205   (= (+ -9223372036854775808 -1) 9223372036854775807)) ; wraps around
 206
 207 (define (test-- )
 208   (= (- 100000000 1) 99999999))
 209
 210 (define (test-/ )
 211   (= (/ 15241578750190521 123456789) 123456789)
 212   (= (/ -10 5) -2))
 213
 214 (define (test-< )
 215   (and
 216    (< -9223372036854775808 9223372036854775807)
 217    (< "abcdefg" "abcdefgh")
 218    (< 1 1.000000001)
 219    (< 1 "a")
 220    (< "a" 'a)
 221    (< '(a b) '(b c) '(c d))
 222    (not (< '(a b) '(b d) '(b c)))
 223    (< '(((a b))) '(((b c))))
 224    (< '(a (b c)) '(a (b d)) '(a (b (d))))
 225    (< -1)
 226    (< -1.23)
 227    (not (< "1"))
 228    (not (< '()))
 229 ))
 230
 231 (define (test-<< )
 232   (= (<< 1 63) -9223372036854775808))
 233
 234 (define (test-<= )
 235   (and (<= -9223372036854775808 -9223372036854775808) (<= 1 1.00000001)))
 236
 237 (define (test-= )
 238   (and
 239     (= 1.23456789 1.23456789)
 240     (= 123456789 123456789)
 241     (= '(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w))
 242     '(1 2 3 (4 5) (a b ("CDEFG" "HIJK") 'u 'v 'w)))
 243     (= "éâäáíóúñÑöò" "éâäáíóúñÑöò")
 244     (= '())
 245     (= 0)
 246     (= "")
 247     (not (= 1))
 248     (not (= "abc"))
 249     (not (= '(1 2 3)))
 250 ))
 251
 252 (define (test-> )
 253   (and (> 9223372036854775807 -9223372036854775808) (> "abcdefgh" "abcdefg") (> 1.000000001
 254     1)
 255    (> "a" 1)
 256    (> "z" "aaaaa")
 257    (> "aaa" "a")
 258    (> 'a "a")
 259    (> '(a) 'a)
 260    (> 1)
 261    (> 1.23)
 262    (> "abc")
 263    (> '(1 2 3))
 264    (not (> ""))
 265    (not (> '()))
 266 ))
 267
 268 (define (test->= )
 269   (and (>= 1 0) (>= 1.00000001 1)))
 270
 271 (define (test->> )
 272   (= (>> 1073741824 30) 1))
 273
 274 (define (test-NaN? )
 275   (and (NaN? (sqrt -1))
 276        (set 'NaN (sqrt -1))
 277        (= 1 (+ 1 NaN))
 278        (= 0 (* 2 NaN))
 279        (NaN? (add 1 (sqrt -1)))
 280        (NaN? (abs (sqrt -1)))))
 281
 282 (define (test-^ )
 283   (= (^ 1431655765 -1431655766) -1))
 284
 285 (define (test-abs )
 286   (and (= (abs -1) 1) (= (abs -9.9) 9.9)))
 287
 288 (define (test-acos )
 289   (= 0 (acos (cos (acos (cos 0))))))
 290
 291 (define (test-acosh)
 292         (= (cosh (acosh 1)) 1))
 293
 294 (define (test-add , l)
 295   (dotimes (x 100)
 296    (push x l))
 297   (= 4950 (apply add l)))
 298
 299 (define (test-address, s)
 300         (set 's "foo")
 301         (= (address s) (last (dump s))))
 302
 303 (define (test-amb)
 304         (set 'x (amb 1 2))
 305         (or (= x 1) (= x 2)))
 306
 307 (define (test-and )
 308   (and (and true true true) (not (and true true nil))))
 309
 310 (define (test-append )
 311   (and
 312     (= '(1 2 3 4) (append '(1 2) '(3 4)))
 313     (= '(1 2 3 4 5) (append '(1 2) '(3) '(4 5)))
 314     (= '(1 2 3 4) (append '(1 2) '(3 4) '()))
 315     (= '(1 2 3 4 5) (append '(1 2) '(3 4) '() '(5)))
 316     (= '(1 2 3 4 5) (append '() '(1 2) '(3 4) '() '(5)))
 317     (= '() (append '()) (append '() '()) (append))
 318     (= "abcdefg" (append "" "a" "bcd" "" "ef" "g" ""))
 319     (= "" (append ""))
 320     (set 'A (array 3 2 (sequence 1 6)))
 321     (set 'B (array 2 2 (sequence 7 10)))
 322     (= (array 5 2 (sequence 1 10)) (append A B))
 323     (lambda? (append '(lambda)))
 324 ))
 325
 326 (define (test-append-file)
 327   (append-file "junk" "ABC")
 328   (append-file "junk" "DEF")
 329   (= (read-file "junk") "ABCDEF")
 330 )
 331
 332 (define (test-apply )
 333   (and (= (apply + '(1 2)) 3)
 334        (= (apply append '("a" "b" "c")) "abc")
 335        (= (apply (fn (x y) (+ x y)) '(3 4)) 7)
 336 ))
 337
 338 (define (test-args )
 339   (do-args 1 2 "3 4" 5 (x y)))
 340
 341 (define (test-array)
 342   (and
 343     (= (array-list (array 3 2 (sequence 1 6))) '((1 2) (3 4) (5 6)))
 344     (set 'A (array 3 2 (sequence 1 6)))
 345     (= (array-list (nth 0 A)) '(1 2))
 346     (= (nth 0 0 A) 1)
 347     (= (nth 2 1 A) 6)
 348     (= (nth -1 -1 A) 6)
 349     (not (catch (nth 10 10 A)  'result))
 350     (not (catch (nth -10 -10 A) 'result))
 351     (= (nth 0 A) (array 2 '(1 2)))
 352     (= (array-list (nth 0 A)) '(1 2))
 353     (< (nth 0 A) (nth 1 A))
 354     (> (nth 2 A) (nth 1 A))
 355     (set-nth 1 0 A 1)
 356     (= (nth 1 0 A) 1)
 357     (= (nth-set 1 1 A 1) 4)
 358     (< (nth 1 A) (nth 0 A))
 359 ))
 360
 361 (define (test-array-list)
 362         (set 'a (array 3 4 (sequence 1 12)))
 363         (and (array? a) (list? (array-list a))))
 364
 365 (define (test-array?) (test-array-list))
 366
 367 (define (test-asin )
 368   (= (round (asin (sin (asin (sin 1)))) -9) 1))
 369
 370 (define (test-asinh)
 371   (= (sinh (asinh 1)) 1))
 372
 373 (define (test-assoc )
 374   (= (assoc 'b '((a 1) (b 2))) '(b 2)))
 375
 376 (define (test-assoc-set)
 377         (and
 378                 (set 'A '((a 1) (b 2) (c 3)))
 379                 (= (assoc-set (A 'b) '(b 3)) '(b 2))
 380                 (= A '((a 1) (b 3) (c 3)))
 381 ))
 382
 383
 384 (define (test-atan )
 385         (< (sub 1 (atan (tan (atan (tan 1))))) 1e-15))
 386
 387 ; old test broke after Mac OS X update to 10.5.2
 388 ;  (= 1 (atan (tan (atan (tan 1)))))
 389
 390 (define (test-atanh)
 391         (< (sub (tanh (atanh 0.5)) 0.5) 0.0000000001))
 392
 393 (define (test-atan2 )
 394   (= (div (acos 0) (atan 1 1)) 2))
 395
 396 (define (test-atom? )
 397   (and (atom? 1) (atom? 1.23) (atom? "hello") (atom? 'x) (atom? nil) (atom? true)))
 398
 399 (define (test-base64-enc)
 400   (and
 401     (= "" (base64-dec (base64-enc "")))
 402     (= "1" (base64-dec (base64-enc "1")))
 403     (= "12" (base64-dec (base64-enc "12")))
 404     (= "123" (base64-dec (base64-enc "123")))
 405     (= "1234" (base64-dec (base64-enc "1234")))
 406 ))
 407
 408 (define (test-base64-dec)
 409   (test-base64-enc))
 410
 411 ;; context Lex was previously created
 412
 413 (define (test-bayes-train)
 414   (and
 415     (= (bayes-train '(F F F B B) '(F B B B B) 'Lex) '(5 5))
 416     (> 0.001 (apply add (map sub (bayes-query '(F) Lex) '(0.75 0.25))))
 417     (> 0.001 (apply add (map sub (bayes-query '(F) Lex true) '(0.75 0.25))))
 418     (> 0.001 (apply add (map sub (bayes-query '(F F) Lex) '(0.8251777681 0.1748222319))))
 419     (> 0.001 (apply add (map sub (bayes-query '(F F) Lex true) '(0.9 0.1))))
 420   )
 421 )
 422
 423 (define (test-bayes-query)
 424         (set 'Lex:F '(0 0))
 425         (set 'Lex:B '(0 0))
 426         (set 'Lex:total '(0 0))
 427         true)
 428
 429 (define (test-begin )
 430   (begin
 431    (set 'x 0)
 432    (inc 'x)
 433    (inc 'x)
 434    (= x 2)))
 435
 436 (define (test-beta )
 437   (< (abs (sub (beta 1 2) 0.5)) 1e-05))
 438
 439 (define (test-betai )
 440   (< (abs (sub (betai 0.5 5 10) 0.910217)) 1e-05))
 441
 442 (define (test-bind)
 443         (bind '((a 1) (b "hello") (c (3 4))))
 444         (and
 445                 (= a 1)
 446                 (= b "hello")
 447                 (= c '(3 4)))
 448 )
 449
 450 (define (test-binomial )
 451   (< (sub (binomial 2 1 0.5) 0.5) 1e-09))
 452
 453 (define (test-break )
 454   (break true)
 455   (= true (break))
 456   (not (break nil)))
 457
 458 (define (test-case )
 459   (and (= (check-case 1) "one") (= (check-case 2) "two") (= (check-case
 460      9) nil)))
 461
 462 (define (test-callback) true)
 463
 464 (define (test-catch )
 465   (and
 466         (catch (+ 3 4) 'result)
 467         (= result 7)
 468         (= (catch (+ 3 4)) 7)
 469         (= (catch (dotimes (x 100) (if (= x 7) (throw x)))) 7)
 470 ))
 471
 472 (define (test-ceil )
 473   (= 2 (ceil 1.5)))
 474
 475 (define (test-change-dir )
 476   (make-dir "adir")
 477   (change-dir "adir")
 478   (change-dir "..")
 479   (remove-dir "adir"))
 480
 481 (define (test-char )
 482   (and
 483     (= (format "%c" (char "a" 0)) "a")
 484     (= (char "A") 65) (= (char 65) "A")
 485     (= (map char (sequence 65 67)) '("A" "B" "C"))
 486     (= (char 0) "\000")))
 487
 488 (define (test-chop )
 489   (and
 490     (= (chop "newlisp") "newlis")
 491     (= (chop "newlisp" 4) "new"))
 492         (= (chop "abc" 5) "")
 493         (= (chop "abc" -5) "")
 494     (= (chop '(a b (c d) e)) '(a b (c d)))
 495     (= (chop '(a b (c d) e) 2) '(a b)))
 496
 497 (define (test-clean )
 498   (and
 499     (= (clean integer? '(1 1.1 2 2.2 3 3.3)) '(1.1 2.2 3.3))
 500     (= (clean true? '(a nil b nil c nil)) '(nil nil nil))))
 501
 502 (define (test-close , fno)
 503   (and
 504     (set 'fno (open "qa-dot" "read"))
 505     (close fno)))
 506
 507 (define (test-crc32)
 508     (= (crc32 "abcdefghijklmnopqrstuvwxyz") 1277644989))
 509
 510 (define (test-select-collect )
 511   (and
 512     (set 'l '(0 1 2 3 4 5 6 7 8 9))
 513     (= (select l '()) '())
 514     (= (select l 0 9 9 0 1 8 8 1) '(0 9 9 0 1 8 8 1))
 515     (= (select "2001-09-20" 5 6 8 9 0 1 2 3) "09202001")
 516     (set 'a 0 'b 1 'c 2)
 517     (= (select '(w x y z) a b c) '(w x y))
 518     (= (select '(w x y z) (inc 'a) (inc 'b) (inc 'c)) '(x y z))
 519 ))
 520
 521 (define (test-command-line )
 522   (and (not (command-line nil)) (command-line true)))
 523
 524 (define (test-cond )
 525   (and
 526       (= (check-cond 1) 1)
 527       (= (check-cond 2) 2)
 528       (not (check-cond 99))
 529       (= (cond ((+ 3 4))) 7)
 530       (= (cond (nil 1) ('())) '())
 531       (= (cond (nil 1) (nil)) nil)
 532       (= (cond (nil 1) (true nil)) nil)
 533       (= (cond ('())) '())
 534       (= (cond (nil 1) ('() 2)) '())
 535 ))
 536
 537 (define (test-cons )
 538   (= (myappend '(1 2 3) '(4 5 6)) '(1 2 3 4 5 6))
 539   (= (cons 'c '(a b) -1) '(a b c))
 540 )
 541
 542 (define (test-constant )
 543   (constant 'cs 123)
 544   (= cs 123)
 545   (define (trick z) (constant 'z 999))
 546   (= (trick) 999)
 547   (= (set 'z 123) 123)
 548   (= (trick) 999)
 549   (= z 123))
 550
 551
 552 (define (test-context )
 553   (and (context 'TEST) (context 'QA)))
 554
 555 (define (test-context? )
 556   (and (context? MAIN) (context? QA)))
 557
 558 (define (test-copy-file )
 559   (and (copy-file "qa-dot" "junk") (delete-file "junk")))
 560
 561 (define (test-cos )
 562   (= 1 (cos (acos (cos (acos 1))))))
 563
 564 (define (test-cosh)
 565         (= (cosh 1) (div (add (exp 1) (exp -1)) 2)))
 566
 567 (define (test-count )
 568   (and (= (count '(1 2) '(2 1 2 1)) '(2 2))
 569        (= (count '(a b) '(a a b c a b b)) '(3 3))
 570        (= (count '(a b c) '()) '(0 0 0))
 571        (set 'L '(a b c d e f))
 572        (= (count L L) '(1 1 1 1 1 1))
 573   )
 574 )
 575
 576 (define (test-cpymem)
 577   (set 'from "12345")
 578   (set 'to "     ")
 579   (cpymem (address from) (address to) 5)
 580   (= from to))
 581
 582 (define (test-crit-chi2 )
 583   (< (abs (sub (crit-chi2 0.559506 10) 9.999991)) 1e-05))
 584
 585 (define (test-crit-z )
 586   (< (abs (sub (crit-z 0.999) 3.090232)) 1e-05))
 587
 588 (define (test-current-line , handle)
 589   (and
 590     (set 'handle (open "qa-dot" "r"))
 591     (= (read-line handle) "#!/usr/bin/newlisp")
 592     (= (current-line) "#!/usr/bin/newlisp")
 593     (close handle)))
 594
 595 (define (test-curry)
 596   (and
 597     (= (set 'f (curry + 10)) (lambda (_x) (+ 10 _x)))
 598     (= (filter (curry match '(a *)) '((a 10) (b 5) (a 3) (c 8) (a 9)))
 599        '((a 10) (a 3) (a 9)))
 600     (= (clean (curry match '(a *)) '((a 10) (b 5) (a 3) (c 8) (a 9)))
 601        '((b 5) (c 8)))
 602     (= (map (curry list 'x) (sequence 1 5))
 603        '((x 1) (x 2) (x 3) (x 4) (x 5)))
 604 ))
 605
 606 (define (test-date )
 607   (= (date) (date (date-value)) (date (apply date-value (now)))))
 608
 609 (define (test-date-value )
 610   (= 0 (date-value 1970 1 1 0 0 0)))
 611
 612 (define (test-debug )
 613   (= (debug (+ 3 4)) 7))
 614
 615 (define (test-dec , x)
 616   (set 'x 20)
 617   (and (= 19 (dec 'x)) (= 17 (dec 'x 2)) (= 16.5 (dec 'x 0.5))))
 618
 619 (define (test-define , foo)
 620   (and
 621         (lambda? (define (foo (x 1) (y 2)) (list x y)))
 622     (= (foo) '(1 2))
 623         (= (foo 3) '(3 2))
 624         (= (foo 3 4) '(3 4))
 625         (define (foo (x 10) (y (div x 2))) (list x y))
 626         (= (foo) '(10 5))
 627         (= (foo 20) '(20 10))
 628         (= (foo 3 4) '(3 4))
 629 ))
 630
 631 (define (test-def-new)
 632   (and
 633     (set 'fooctx:x 123)
 634     (new fooctx)
 635     (= fooctx:x 123)
 636     (set 'barctx:bar 999)
 637     (def-new 'barctx:bar)
 638     (= bar 999)
 639     (def-new 'barctx:bar 'foobar)
 640     (= foobar 999)
 641     (def-new 'barctx:bar 'foofoo:foo)
 642     (= foofoo:foo 999)
 643 ))
 644
 645
 646 (define (test-define-macro , foo)
 647   (and
 648         (macro? (define-macro (foo (x 1) (y 2)) (list x y)))
 649     (= (foo) '(1 2))
 650         (= (foo 3) '(3 2))
 651         (= (foo 3 4) '(3 4))
 652         (define-macro (foo (x 10) (y (div x 2))) (list x y))
 653         (= (foo) '(10 5))
 654         (= (foo 20) '(20 10))
 655         (= (foo 3 4) '(3 4))
 656 ))
 657
 658 (define (test-default)
 659         (MAIN:test-default-functor))
 660
 661 (define (test-delete )
 662   (delete 'xxx))
 663
 664 (define (test-delete-file )
 665   (and (copy-file "qa-dot" "junk") (delete-file "junk")))
 666
 667 (define (test-delete-url )
 668   (= "ERR: bad formed URL" (delete-url "")))
 669
 670 (define (test-destroy)
 671         (if (or (< opsys 5)(= opsys 9))
 672                 (set 'pid (fork (dotimes (t 100) (sleep 100))))
 673                 (set 'pid (process "newlisp"))  )
 674         (destroy pid))
 675
 676 (define (test-det)
 677   (set 'A '((-1 1 1) (1 4 -5) (1 -2 0)))
 678   (<  (sub (det A) -1) 2e-10))
 679
 680 (define (test-device , fno)
 681   (set 'fno (open "junk" "write"))
 682   (device fno)
 683   (if (= (device) fno)
 684    (close (device))))
 685
 686 (define (test-difference )
 687   (and
 688     (= (difference '(2 5 6 0 3 0 2 5) '(1 2 3 3 2 1)) '(5 6 0))
 689     (= (difference '(1 5 2 3 2 2 4 5 3 4 5 1) '(3 4) true) '(1 5 2 2 2 5 5 1))
 690     (= (difference '(nil nil nil) '()) '(nil))
 691     (= (difference '(nil nil nil) '() true) '(nil nil nil))
 692     (set 'L '(a b c d e f))
 693     (= (difference L L) '())
 694   )
 695 )
 696
 697 (define (test-directory )
 698   (or (find "qa-dot" (directory)) (find "QA" (directory))))
 699
 700 (define (test-directory? )
 701   (directory? "."))
 702
 703 (define (test-div )
 704   (and (= 0.1 (div 100000000 1000000000))
 705        (= (div 1 3) 0.3333333333333333)
 706        (= (div 3) 0.3333333333333333)
 707 ))
 708
 709 (define (testdoargs)
 710         (local (lst)
 711                 (doargs (i) (push i lst))
 712                 lst))
 713
 714 (define (test-doargs)
 715         (= (testdoargs 3 2 1) '(1 2 3)))
 716
 717 (define (test-dolist , rList)
 718   (and
 719    (dolist (x '(1 2 3 4 5 6 7 8 9))
 720     (push x rList))
 721    (= rList '(9 8 7 6 5 4 3 2 1))
 722    (dolist (x rList)
 723     (pop rList))
 724     (dolist (x '(1 2 3 4 5 6 7 8 9) (> x 5))
 725           (push x rList))
 726    (= rList '(5 4 3 2 1))
 727    (= (local (l) (dolist (e '(1 2 3)) (push $idx l)) l) '(2 1 0))
 728    (= (dolist (x '(a b c d e f g)) x) 'g)
 729 ))
 730
 731 (define (test-dostring)
 732         (local (r)
 733                 (dostring (i "newlisp" (= i 108)) (push  i r))
 734                 (= r '(119 101 110))
 735                 (= (dostring (c "newlisp") c) 112)
 736         )
 737 )
 738
 739 (define (test-dotimes , aList)
 740   (dotimes (x 2)
 741    (dotimes (y 2)
 742     (dotimes (z 2)
 743      (push z aList))))
 744   (and
 745      (= '(1 0 1 0 1 0 1 0) aList)
 746      (not (dotimes (x 0) x))
 747      (= (dotimes (x 1) x) 0)
 748
 749      ; dotimes returns nil when ever executed since 8.9.7
 750      (not (= (dotimes (x -1) x) 0))
 751      (not (= (dotimes (x -1.8) x) 0))
 752
 753      (= (dotimes (x 1.8) x) 0)
 754          (set 'cnt 0)
 755          (dotimes (x 10 (> x 5)) (inc 'cnt))
 756          (= cnt 6)
 757
 758 ))
 759
 760 (define (test-dotree )
 761   (set 'aList '())
 762   (and
 763     (= (last (symbols MAIN)) (dotree (p MAIN) p))
 764         (dotree (x 'MAIN)
 765                 (push x aList))
 766         (= (length (symbols 'MAIN)) (length aList))
 767 ))
 768
 769 (define (test-dump )
 770   ( = "hello" (get-string (last (dump "hello")))))
 771
 772 (define (test-dump-symbol )
 773   (= (length (dump nil) 4)))
 774
 775 (define (test-dup)
 776   (and
 777     (= (dup "" 0) "")
 778     (= (dup "" 10) "")
 779     (= (dup "A" 10) "AAAAAAAAAA")
 780     (= (dup "AB" 5) "ABABABABAB")
 781     (= (dup 'x 5) '(x x x x x))
 782         (= (dup "l" -1) "")
 783         (= (dup '(1) -1) '())
 784     (= (dup 1 0) '())
 785     (= (dup 1 5) '(1 1 1 1 1))))
 786
 787 (define (test-empty? , aList)
 788   (set 'aList '(1 2 3 4 5 6 7 8 9 0))
 789   (while aList
 790    (pop aList))
 791   (and (empty? aList) (empty? "")))
 792
 793 (define (test-encrypt )
 794   (= (encrypt (encrypt "newlisp" "123") "123") "newlisp"))
 795
 796 (define (test-ends-with )
 797   (and
 798         (ends-with "newlisp" "lisp")
 799         (ends-with "newlisp" "LISP" nil)
 800         (ends-with "abc.def.ghi" "def|ghi" 1)
 801         (ends-with "12345" "4|5" 1)
 802     (ends-with (explode "newlisp") "p")))
 803
 804 (define (test-env)
 805   (and
 806     (list? (env))
 807     (env "key" "value")
 808     (= (env "key") "value")
 809         (env "key" "") ; remove key
 810         (if (= ostype "Solaris")
 811                 (= (env "key" ""))
 812                 (not (env "key")))
 813 ))
 814
 815 (define (test-erf)
 816    (<  (abs (sub 0.5204998778 (erf 0.5))) 0.000001))
 817
 818 (define (alarm) (println "ring..."))
 819
 820 (define (test-timer)
 821         (timer 'alarm 4))
 822
 823 (define (test-title-case)
 824         (= (title-case "heLLo") "HeLLo")
 825         (= (title-case "heLLo" true) "Hello"))
 826
 827 (define (test-throw-error)
 828     (and
 829         (not (catch (throw-error "message text") 'result))
 830         (starts-with result "user error :")) )
 831
 832
 833 (define (test-error-event )
 834   (= 'nil (error-event)))
 835
 836 (define (test-error-number )
 837   (integer? (error-number)))
 838
 839 (define (test-error-text )
 840   (= (error-text 24) "invalid function"))
 841
 842 (define (test-eval , x y)
 843   (set 'x 123)
 844   (set 'y 'x)
 845   (set 'z 'y)
 846   (and (= 123 (eval y)) (= 123 (eval 'x)) (= 123 (eval (eval z)))))
 847
 848 (define (test-eval-string )
 849   (eval-string "(set 'x 123)")
 850   (eval-string "(set 'y x)")
 851   (and (= 123 (eval-string "y")))
 852   (= 123 (eval-string "(blah-blah)" 123))
 853   (set 'Foo:xyz 99999)
 854   (= 99999 (eval-string "xyz" nil 'Foo))
 855 )
 856
 857 (define (test-exec )
 858   (and (sub-read-exec) (sub-write-exec)))
 859
 860 (define (sub-read-exec )
 861    (write-file "exectest" {(println "hello") (exit)})
 862    (and
 863      (set 'result  (if (and (> opsys 5) (< opsys 9))
 864      (exec "newlisp exectest") (exec "./newlisp exectest")))
 865      (or (= '("hello") result) (= '("" "hello") result))
 866      (delete-file "exectest")))
 867
 868 (define (sub-write-exec )
 869   (and
 870     (write-file "testexec" {(write-file "exectest" (read-line))})
 871     (if (and (> opsys 5) (< opsys 9))
 872          (exec "newlisp testexec" "HELLO") (exec "./newlisp testexec" "HELLO"))
 873     (= "HELLO" (read-file "exectest"))
 874     (delete-file "testexec")
 875     (delete-file "exectest")))
 876
 877
 878 (define (test-exit )
 879   (or (primitive? exit) (lambda? exit)))
 880
 881 (define (test-exists)
 882   (and
 883     (= (exists string? '(2 3 4 6 "hello" 7)) "hello")
 884     (not (exists string? '(3 4 2 -7 3 0)) )
 885     (= (exists zero? '(3 4 2 -7 3 0)) 0)
 886     (= (exists < '(3 4 2 -7 3 0)) -7)
 887     (= (exists (fn (x) (> x 3)) '(3 4 2 -7 3 0)) 4)
 888     (not (exists (fn (x) (= x 10)) '(3 4 2 -7 3 0)))
 889 ))
 890
 891 (define (test-exp )
 892   (= 1 (exp (log (exp (log (exp (log 1))))))))
 893
 894 (define (test-expand)
 895   (and
 896     (set 'x 2)
 897     (= (expand '(a x b) 'x) '(a 2 b))
 898     (= (expand '(x b) 'x) '(2 b))
 899     (= (expand '(a x) 'x) '(a 2))
 900     (= (expand '(a (x) b) 'x) '(a (2) b))
 901     (= (expand '(a ((x)) b) 'x) '(a ((2)) b))
 902     (set 'a 1 'b 2 'c 3)
 903     (= (expand '(a b c) 'b 'a 'c ) '(1 2 3))
 904         ;; prolog mode with uppercase vars
 905         (set 'X 2)
 906         (= (expand '(a ((X)) b)) '(a ((2)) b))
 907         ;; env list as parameter
 908         (set 'a "a" 'B "B" 'c "c" 'd "d")
 909         (= (expand '(a (B (c) (d a B))) '((a 1) (B 2) (c 3) (d 4)))
 910            '(1 (2 (3) (4 1 2))))
 911         (= a "a") (= B "B") (= c "c") (= d "d")
 912 ))
 913
 914 (define (test-explode )
 915         (and
 916                 (= (explode "kakak" -1) '())
 917                 (= (explode "ABC" 4) '("ABC"))
 918                 (= (explode '(a b c d e f) -1) '())
 919                 (= (explode "new") '("n" "e" "w"))
 920                 (= (explode "newlisp" 3) '("new" "lis" "p"))
 921                 (= (explode "newlisp" 3 true) '("new" "lis"))
 922                 (= (explode "newlisp" 7 true) '("newlisp"))
 923                 (= (explode "newlisp" 8 true) '())
 924                 (= (explode '(a b c d e)) '((a) (b) (c) (d) (e)))
 925                 (= (explode '(a b c d e) 2) '((a b) (c d) (e)))
 926                 (= (explode '(n e w l i s p)) '((n) (e) (w) (l) (i) (s) (p)))
 927                 (= (explode '(n e w l i s p) 3) '((n e w) (l i s) (p)))
 928                 (= (explode '(n e w l i s p) 7 true) '((n e w l i s p)))
 929         (= (explode '(n e w l i s p) 8 true) '())
 930 ))
 931
 932 (define (test-factor)
 933         (= (apply * (factor 0x7FFFFFFFFFFFFFFF)) 0x7FFFFFFFFFFFFFFF))
 934
 935 (define (test-fft )
 936   (= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
 937
 938 (define (test-file-info )
 939   (list? (file-info "qa-dot")))
 940
 941 (define (test-file? )
 942   (file? "qa-dot"))
 943
 944 (define (test-filter )
 945   (and
 946     (= (filter integer? '(1 1.1 2 2.2 3 3.3)) '(1 2 3))
 947     (= (filter true? '(a nil b nil c nil)) '(a b c))))
 948
 949 (define (test-find )
 950   (and
 951     (= 3 (find '(3 4) '(0 1 2 (3 4) 5 6 7 8)))
 952     (= nil (find 9 '(1 2 3)))
 953     (= 2 (find "W" "newlisp" 1))
 954     (= $0 "w")
 955     (= (find "newlisp" '("Perl" "Python" "newLISP") 1) 2)
 956     ; use a comparison functor
 957     (= (find '(1 2) '((1 4) 5 6 (1 2) (8 9))) 3)
 958     (= (find 3 '(8 4 3  7 2 6) >)  4)
 959     (= (find 5 '((l 3) (k 5) (a 10) (z 22)) (fn (x y) (= x (last y)))) 1)
 960     (= (find '(a ?) '((l 3) (k 5) (a 10) (z 22)) match) 2)
 961     (= (find '(X X) '((a b) (c d) (e e) (f g)) unify) 2)
 962     (define (has-it-as-last x y) (= x (last y)))
 963     (= (find 22 '((l 3) (k 5) (a 10) (z 22)) has-it-as-last) 3)
 964     (= (find "newlisp" '("Perl" "Python" "newLISP") (fn (x y) (regex x y 1))) 2)
 965 ))
 966
 967 (define (test-find-all)
 968   (and
 969         (= (find-all {\d+} "asdf2kjh44hgfhgf890") '("2" "44" "890"))
 970         (= (find-all {(new)(lisp)} "newLISPisNEWLISP" (append $2 $1) 1) '("LISPnew" "LISPNEW"))
 971 ))
 972
 973 (define (test-first )
 974   (= 1 (first '(1 2 3 4)))
 975   (= "n" (first "ewLISP"))
 976   (= (array 2 '(1 2)) (first (array 3 2 (sequence 1 6))))
 977 )
 978
 979 (define (test-flat )
 980   (set 'lst '(a (b (c d))))
 981   (= (map (fn (x) (ref x lst)) (flat lst)) '((0) (1 0) (1 1 0) (1 1 1))))
 982
 983 (define (test-float )
 984   (float? (float "1.234")))
 985
 986 (define (test-flt)
 987         (= (flt 1.23) 1067282596))
 988
 989 (define (test-float? )
 990   (float? 1.234))
 991
 992 (define (test-floor )
 993   (= 1 (floor 1.5)))
 994
 995 (define (test-for , x lst1 lst2)
 996   (set 'lst1 '())
 997   (set 'lst2 '())
 998   (for (x 10 0 3)
 999    (push x lst1))
1000   (for (x 10 0 3 (< x 7))
1001    (push x lst2))
1002   (and
1003    (= lst1 '(1 4 7 10))
1004    (= lst2 '(7 10)) )
1005 )
1006
1007 (define (test-for-all)
1008   (and
1009     (for-all number? '(2 3 4 6 7))
1010     (not (for-all number? '(2 3 4 6 "hello" 7)) )
1011     (for-all (fn (x) (= x 10)) '(10 10 10 10 10))
1012 ))
1013
1014
1015 (define (test-fork) (integer? (fork (exit))))
1016
1017 (define (test-format )
1018   (and
1019    (= (format "%d" 1.23) "1")
1020    (= (format "%5.2f" 10) "10.00")
1021    (= (format "%c %s %d %g" 65 "hello" 123 1.23) "A hello 123 1.23")
1022    (= (format "%5.2s" "hello") "   he")
1023    ; args passed in a list
1024    (= (format "%d" '(1.23)) "1")
1025    (= (format "%5.2f" '(10)) "10.00")
1026    (= (format "%c %s %d %g" '(65 "hello" 123 1.23)) "A hello 123 1.23")
1027    (= (format "%5.2s" '("hello")) "   he")
1028    (set 'data '((1 "a001" "g") (2 "a101" "c") (3 "c220" "g")))
1029    (set 'result (map (fn (x) (format "%3.2f %5s %2s" (nth 0 x) (nth 1 x) (nth 2 x))) data))
1030    (set 'result (map (fn (x) (format "%3.2f %5s %2s" (x 0) (x 1) (x 2))) data))
1031    (= result '("1.00  a001  g" "2.00  a101  c" "3.00  c220  g"))
1032    (not (catch (format "%%" 1) 'result))
1033    (not (catch (format "%10.2lf" 123) 'result))
1034    (if (and (> opsys 5) (< opsys 9) (!= opsys 7)) ;; Win32
1035       (begin
1036         (and
1037          (= (format "%I64d" 0x7fffffffffffffff) "9223372036854775807")
1038          (= (format "%I64x" 0x7fffffffffffffff) "7fffffffffffffff")
1039          (= (format "%I64u" 0x7fffffffffffffff) "9223372036854775807")
1040          (= (format "%I64d" 0x8000000000000000) "-9223372036854775808")
1041          (= (format "%I64x" 0x8000000000000000) "8000000000000000")
1042          (= (format "%I64u" 0x8000000000000000) "9223372036854775808")
1043          (= (format "%I64d" 0xFFFFFFFFFFFFFFFF) "-1")
1044          (= (format "%I64x" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
1045          (= (format "%I64u" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
1046       )
1047       (begin ;; UNIX like OS
1048         (if (= opsys 9) ;TRU64
1049           (begin
1050             (and
1051               (= (format "%d" 0x7fffffff) "2147483647")
1052               (= (format "%d" 0xffffffff) "-1")
1053               (= (format "%u" 0xffffffff) "4294967295")
1054               (= (format "%i" 0x7fffffff) "2147483647")
1055
1056               ; truncate
1057               (= (format "%d" 0x7fffffffffffffff) "-1")
1058               (= (format "%u" 0x7fffffffffffffff) "4294967295")
1059               (= (format "%x" 0x7fffffffffffffff) "ffffffff")
1060               (= (format "%X" 0x7fffffffffffffff) "FFFFFFFF")
1061
1062               (= (format "%ld" 0x7fffffffffffffff) "9223372036854775807")
1063               (= (format "%lu" 0xffffffffffffffff) "18446744073709551615")
1064               (= (format "%li" 0x7fffffffffffffff) "9223372036854775807")
1065               (= (format "%lx" 0x7fffffffffffffff) "7fffffffffffffff")
1066               (= (format "%ld" 0x8000000000000000) "-9223372036854775808")
1067               (= (format "%lx" 0x8000000000000000) "8000000000000000")
1068               (= (format "%lu" 0x8000000000000000) "9223372036854775808")
1069               (= (format "%ld" 0xFFFFFFFFFFFFFFFF) "-1")
1070               (= (format "%lx" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
1071               (= (format "%lu" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
1072           )
1073           (begin
1074             (and
1075               (= (format "%d" 0x7fffffff) "2147483647")
1076               (= (format "%d" 0xffffffff) "-1")
1077               (= (format "%u" 0xffffffff) "4294967295")
1078
1079               ; truncate
1080               (= (format "%d" 0x7fffffffffffffff) "-1")
1081               (= (format "%u" 0x7fffffffffffffff) "4294967295")
1082               (= (format "%x" 0x7fffffffffffffff) "ffffffff")
1083               (= (format "%X" 0x7fffffffffffffff) "FFFFFFFF")
1084
1085               (= (format "%lld" 0x7fffffffffffffff) "9223372036854775807")
1086               (= (format "%llx" 0x7fffffffffffffff) "7fffffffffffffff")
1087               (= (format "%llu" 0x7fffffffffffffff) "9223372036854775807")
1088               (= (format "%lld" 0x8000000000000000) "-9223372036854775808")
1089               (= (format "%llx" 0x8000000000000000) "8000000000000000")
1090               (= (format "%llu" 0x8000000000000000) "9223372036854775808")
1091               (= (format "%lld" 0xFFFFFFFFFFFFFFFF) "-1")
1092               (= (format "%llx" 0xFFFFFFFFFFFFFFFF) "ffffffffffffffff")
1093               (= (format "%llu" 0xFFFFFFFFFFFFFFFF) "18446744073709551615"))
1094           )
1095       )
1096 ))))
1097
1098 (define (test-fv )
1099   (< (sub (fv 0.1 10 1000 0 0) -15937.4246) 1e-05))
1100
1101 (define (test-gammai )
1102   (< (abs (sub (gammai 4 5) 0.734974)) 1e-05))
1103
1104 (define (test-gammaln )
1105   (< (abs (sub 120 (exp (gammaln 6)))) 1e-05))
1106
1107 (define (test-gcd)
1108  (and
1109   (= (gcd 0) 0)
1110   (= (gcd 1) 1)
1111   (= (gcd 12 36) 12)
1112   (= (gcd 12 36 6) 6)
1113   (= (gcd 12 36 6 3) 3)
1114 ))
1115
1116 (define (test-get-char )
1117   (= 65 (get-char (address "A"))))
1118
1119 (define (test-get-float )
1120   (= 1.234 (get-float (pack "lf" 1.234))))
1121
1122 (define (test-get-int )
1123   (and
1124     (= 123456789 (get-int (pack "ld" 123456789)))
1125     (set 'adr (pack "ldld" 0xaabbccdd 0xccddeeff))
1126     (= (format "%x" (get-int adr)) "aabbccdd")
1127     (= (format "%x" (get-int (address adr))) "aabbccdd")
1128     (= (format "%x" (get-int (+ (address adr) 0))) "aabbccdd")
1129     (= (format "%x" (get-int (+ (address adr) 4))) "ccddeeff")
1130     (set 'adr (pack "> ldld" 0xaabbccdd 0xccddeeff))
1131     (= adr "\170\187\204\221\204\221\238\255")
1132     (set 'adr (pack "< ldld" 0xaabbccdd 0xccddeeff))
1133     (= adr "\221\204\187\170\255\238\221\204")
1134     (set 'buff (pack "lulululululululu" 1 2 3 4))
1135     (apply and (map (fn (i) (= (+ i 1) (get-int (+ (* i 4) (address buff))))) '(0 1 2 3)))
1136 ))
1137
1138 (define (test-get-long)
1139         (set 'adr (pack "Ld" -1))
1140         (= -1 (get-long adr)))
1141
1142 (define (test-get-string )
1143   (= "hello" (get-string (address "hello"))))
1144
1145 (define (test-get-url )
1146   (= "ERR: bad formed URL" (get-url "")))
1147
1148
1149 (define (test-global)
1150         (= global-myvar 123))
1151
1152 (define (test-global?)
1153         (and
1154                 (global? 'global-myvar)
1155                 (global? 'println)
1156 ))
1157
1158 (define (test-if )
1159   (and
1160    (if true true)
1161    (if nil nil true)
1162    (if 'nil nil true)
1163    (if '() nil true)
1164    (= (if '()) '())
1165    (= (if nil 1 '() 2) '())
1166    (= (if nil '() '()) '())
1167    (= (if true '() '()) '())
1168    (= (if nil 1 nil 2 nil 3 true 4 3) 4)
1169    (= (if nil 1 nil 2 nil 3 nil 4 3) 3)
1170    ))
1171
1172 (define (test-ifft )
1173   (= '((1 2) (3 4)) (ifft (fft '((1 2) (3 4))))))
1174
1175 (define (test-import )
1176   (primitive? import))
1177
1178 (define (test-inc , x)
1179   (set 'x 1)
1180   (and (= 2 (inc 'x)) (= 2.1 (inc 'x 0.1))))
1181
1182 (define (test-index )
1183   (= '(1 3) (index (lambda (x) (> x 3)) '(1 5 2 6 2 0))))
1184
1185 (define (test-integer )
1186   (and
1187     (integer? (int "12345"))
1188     (= (int " 12345") 12345)
1189     (= (int "9223372036854775807")  9223372036854775807)
1190     (= (int "-9223372036854775808") -9223372036854775808)
1191     (= (int 0.0) 0)
1192     (= (int 1e30)  9223372036854775807)
1193     (= (int -1e30) -9223372036854775808)
1194     (= (int 0x8000000000000000) (int "0x8000000000000000"))
1195 ))
1196
1197 (define (test-int) (test-integer))
1198
1199 (define (test-integer? )
1200   (and
1201     (integer? 12345)
1202     (integer? 9223372036854775807)
1203     (integer? -9223372036854775808)
1204     (integer? 0x7FFFFFFFFFFFFFFF)
1205     (integer? 0xFFFFFFFFFFFFFFFF)
1206 ))
1207
1208 (define (test-intersect )
1209   (and
1210     (= (intersect '(3 0 2 4 1) '(1 4 2 5)) '(2 4 1))
1211     (set 'L '(a b c d e f))
1212     (= (intersect L L) L)
1213   )
1214 )
1215
1216 (define (test-invert )
1217   (set 'A '((-1 1 1) (1 4 -5) (1 -2 0)))
1218   (set 'I (multiply A (invert A)))
1219   (set 'J (multiply (array 3 3 (flat A)) (invert (array 3 3 (flat A)))))
1220   (and (< (sub 1 (nth 0 (nth 0 I))) 1e-06)
1221        (< (sub 1 (nth 1 (nth 1 I))) 1e-06)
1222        (< (sub 1 (nth 2 (nth 2 I))) 1e-06)
1223        (= I (array-list J))
1224        (not (invert '((0 1 0) (1 0 1) (0 0 0))) )
1225 ))
1226
1227 (define (test-irr )
1228   (< (abs (sub (irr '(-1000 500 400 300 200 100)) 0.20272)) 0.0001))
1229
1230 (define (test-join )
1231   (and
1232     (= "this is a sentence" (join '("this" "is" "a" "sentence") " "))
1233     (= "this_is_a_sentence" (join '("this_" "is_" "a_" "sentence")))
1234     (= "" (join '()))
1235         (= (join '("A" "B" "C") "-") "A-B-C")
1236         (= (join '("A" "B" "C") "-" true) "A-B-C-")
1237 ))
1238
1239 (define (test-lambda? )
1240   (lambda? qa))
1241
1242 (define (test-last )
1243   (= 'f (last '(a b c d e f)))
1244   (= "p" (last "newlisp"))
1245   (= (array 2 '(5 6)) (last (array 3 2 (sequence 1 6))))
1246 )
1247
1248 (define (test-legal?)
1249   (and
1250     (legal? "abc")
1251     (not (legal? "a b c"))
1252     (set 'greek (pack "cccccccccccccccccc" 206 160 206 181 206 187 206 181 206 185 206
1253                                 172 206 180 206 181 207 137))
1254     (legal? greek)
1255 ))
1256
1257
1258 (define (test-length )
1259   (> (length (symbols)) 100)
1260   (- 7 (length "newlisp")))
1261
1262 (define (test-let )
1263   (set 'a 123)
1264   (set 'b 456)
1265   (set 'p 111)
1266   (set 'q 222)
1267   (and
1268      (let ((a 1) (b 2))
1269        (= (+ a b) 3))
1270      (= a 123)
1271      (= b 456)
1272      (let (p 3 q 4)
1273        (= (+ q p) 7))
1274      (= p 111)
1275      (= q 222)
1276 ))
1277
1278 (define (test-letex)
1279   (and
1280         (= (letex (x '* y 3 z 4) (x y z)) 12)
1281         (= (letex (x 1 y 2 z 3) (quote (x y z))) '(1 2 3))
1282         (= (letex (x 1 y 2 z 3) '(x y z)) '(1 2 3))
1283         (= (letex (x 1 y 2 z 3) '('x (quote y) z)) '('1 (quote 2) 3))
1284         (= (letex (x 1) 'x) 1)
1285         ))
1286
1287 (define (test-letn)
1288   (set 'x 0 'y 0 'z 0)
1289   (and
1290       (= (letn ((x 1) (y (+ x 1)) (z (+ y 1))) (list x y z)) '(1 2 3))
1291       (= 0 x y z))
1292 )
1293
1294 (define (test-list )
1295   (and (list? (list 1 2 3 4 5)) (= '(1) (list 1)) (= '(1 nil) (list
1296      1 'nil))))
1297
1298 (define (test-list? )
1299   (and (list? '(1 2 3 4 5)) (list? '())))
1300
1301 (define (test-load )
1302   (write-file "junk" "(+ 3 4)")
1303   (load "junk"))
1304
1305 (define (test-local)
1306         (set 'a 10 'b 20)
1307         (and
1308                 (= (local (a b) (set 'a 1 'b 2) (+ a b)) 3)
1309                 (= a 10)
1310                 (= b 20)))
1311
1312 (define (test-set-locale)
1313   (string? (set-locale)))
1314
1315 (define (test-log )
1316   (and
1317         (= 1 (log (exp 1)))
1318         (= 1 (log (exp 1) (exp 1)))
1319   )
1320 )
1321
1322 (define (test-lookup )
1323   (and (= 3 (lookup 1 '((2 3 4) (1 2 3)))) (= 2 (lookup 1 '((2 3
1324        4)
1325       (1 2 3)) 1))))
1326
1327 (define (test-lower-case )
1328   (if (> opsys 4)
1329    (= "abcdefgq" (lower-case "ABCDEFGQ"))
1330    (= "abcdefgh" (lower-case "ABCDEFGH"))))
1331
1332 (define (test-macro? )
1333   (macro?
1334    (define-macro (foo-macro))))
1335
1336 (define (test-main-args )
1337   (and
1338      (list? (main-args))
1339      (list? $main-args)
1340      (= $main-args (main-args))
1341      (= ($main-args 0) ((main-args) 0) (main-args 0))
1342      (= ($main-args -1) ((main-args) -1))
1343      (= ($main-args -1) (main-args -1))
1344 ))
1345
1346 (define (test-make-dir )
1347   (and (make-dir "foodir") (remove-dir "foodir")))
1348
1349 (define (test-map )
1350   (and (= '(11 22 33) (map + '(10 20 30) '(1 2 3)))
1351        (= '(2 4 6) (map (lambda (x) (+ x x)) '(1 2 3)))
1352 ))
1353
1354 (define (test-mat)
1355         (set 'A '((1 2 3) (4 5 6)))
1356         (set 'B A)
1357         (and
1358                 (= (mat + A B) '((2 4 6) (8 10 12)))
1359                 (= (mat - A B) '((0 0 0) (0 0 0)))
1360                 (= (mat * A B) '((1 4 9) (16 25 36)))
1361                 (= (mat / A B) '((1 1 1) (1 1 1)))
1362                 (= (mat + A 2) '((3 4 5) (6 7 8)))
1363                 (= (mat - A 2) '((-1 0 1) (2 3 4)))
1364                 (= (mat * A 2) '((2 4 6) (8 10 12)))
1365                 (= (mat / A 2) '((0.5 1 1.5) (2 2.5 3)))
1366
1367                 (= (mat + A 5) '((6 7 8) (9 10 11)))
1368                 (= (mat - A 2) '((-1 0 1) (2 3 4)))
1369                 (= (mat * A 3) '((3 6 9) (12 15 18)))
1370                 (= (mat / A 10) '((.1 .2 .3) (.4 .5 .6)))
1371
1372         (set 'op +)
1373                 (= (mat op A B) '((2 4 6) (8 10 12)))
1374         (set 'op '+)
1375                 (= (mat op A B) '((2 4 6) (8 10 12)))
1376         ))
1377
1378 (define (test-match)
1379   (and
1380     (= (match '(a (b ?) d e *) '(a (b c) d e f g) true)   '(a (b c) d e (f g)) )
1381     (= (match '(a (b ?) d e *) '(a (b c) d e f g) )  '(c (f g)) )
1382
1383     (= (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) )
1384     (= (match '(a * b x) '(a b c d b x e f b x) ) '((b c d b x e f)) )
1385
1386
1387     (= (match '(? (?) x * ? (? e)) '(a (b) x y c (d e)) true) '(a (b) x (y) c (d e)) )
1388     (= (match '(? (?) x * ? (? e)) '(a (b) x y c (d e))) '(a b (y) c d) )
1389
1390     (= (match '(a * b) '(a x b) true) '(a (x) b) )
1391     (= (match '(a * b) '(a x b)) '((x)) )
1392
1393
1394     (= (match '(a * b) '(a b) true) '(a () b) )
1395     (= (match '(a * b) '(a b)) '(()) )
1396
1397     (= (match '( (? ?) * ) '( (x y) ) true) '((x y) ()) )
1398     (= (match '( (? ?) * ) '( (x y) )) '(x y ()) )
1399     (match '(+) '(a))
1400     (match '(+) '(a b))
1401     (not (match '(+) '()))
1402   ))
1403
1404
1405 (define (test-max )
1406   (and (= 10 (max 3 6 10 8)) (= 1.2 (max 0.7 0.6 1.2))))
1407
1408 (define (test-member )
1409   (= '(3 4) (member 3 '(1 2 3 4)))
1410   (= (member "LISP" "newLISP") "LISP")
1411   (= (member "LI" "newLISP") "LISP")
1412   (= (member "" "newLISP") "newLISP")
1413   (not (member "xyz" "newLISP"))
1414   (not (member "new" "this is NEWLISP" 0))
1415   (= (member "new" "this is NEWLISP" 1) "NEWLISP")
1416 )
1417
1418 (define (test-min )
1419   (and (= 3 (min 3 6 10 8)) (= 0.6 (min 0.7 0.6 1.2))))
1420
1421 (define (test-mod )
1422   (and (< (sub (mod 10.5 3.3) 0.6) 0.0001) (< (sub (mod 10 3) 1) 0.0001)))
1423
1424 (define (test-mul )
1425   (= 1e-09 (mul 0.0001 1e-05)))
1426
1427 (define (test-multiply )
1428   (let ((A '((1 2 3) (4 5 6))) (B '((1 2) (1 2) (1 2))))
1429     (and
1430        (= '((6 12) (15 30)) (multiply A B))
1431        (= (array 2 2 (flat '((6 12) (15 30))))
1432           (multiply (array 2 3 (flat A)) (array 3 2 (flat  B))))
1433     )
1434 ))
1435
1436 (define (test-name )
1437   (= "name" (name 'name)))
1438
1439 (define (test-net-accept )
1440   (and
1441         (set 'net-listen-test (set 'listen (net-listen 12345)))
1442         (set 'net-connect-test (set 'connect (net-connect "localhost" 12345)))
1443         (set 'server (net-accept listen))
1444         (set 'net-send-test (= (net-send server "hello") 5))
1445         (set 'net-select-test (net-select connect "r" 100000))
1446         (set 'net-peek-test (= (net-peek connect) 5))
1447         (set 'net-receive-test (net-receive connect 'buff 20))
1448         (= buff "hello")
1449         (set 'net-sessions-test (and
1450           (find listen (net-sessions))
1451           (find connect (net-sessions))
1452           (find server (net-sessions))))
1453         (set 'net-local-test (= (net-local server) (net-peer connect)))
1454         (set 'net-peer-test (= (net-local connect) (net-peer server)))
1455         (set 'net-close-test (net-close connect))
1456         (set 'net-close-test (net-close server))
1457         (set 'net-close-test (net-close listen))
1458         (not (net-error))
1459 ))
1460
1461 (define (test-net-close ) net-close-test)
1462
1463 (define (test-net-connect )  net-connect-test)
1464
1465 (define (test-net-error )
1466         (and
1467                 (not (net-close 12345))
1468                 (list? (net-error))))
1469
1470 (define (test-net-eval) true) ;; see special test prog
1471
1472 (define (test-net-listen ) net-listen-test)
1473
1474 (define (test-net-local ) net-local-test)
1475
1476 (define (test-net-lookup )
1477         (and
1478                 (or (= "127.0.0.1" (net-lookup "localhost")) (= "::1" (net-lookup "localhost")))
1479                 (or (= "localhost" (net-lookup "127.0.0.1")) (= "localhost" (net-lookup "::1")))
1480         )
1481 )
1482
1483 (define (test-net-peek ) net-peek-test)
1484
1485 (define (test-net-peer ) net-peer-test)
1486
1487 (define (test-net-ping) true) ; test manualyy as superuser
1488
1489 (define (test-net-receive ) net-receive-test)
1490
1491 (define (test-net-receive-from)
1492   (and
1493     (set 'sock (net-listen 1234 "localhost" "udp"))
1494     (set 'net-send-to-test (net-send-to "localhost" 1234 "hello" sock))
1495     (set 'net-select-test (net-select sock "r" 1000000) )
1496     (= "hello" (first (net-receive-from sock 10)))
1497     (net-close sock)))
1498
1499
1500 (define (test-net-receive-udp)
1501     (write-file "udptest.lsp"
1502 [text]
1503 (map set '(in out sid) (map int (slice (main-args) 2)))
1504 (semaphore sid 1) ; signal parent to start
1505 (set 'msg (net-receive-udp in 20 2000000))
1506 (sleep 100)
1507 (if (not msg) (exit))
1508 (net-send-udp "localhost" out (upper-case (first msg)))
1509 (exit)
1510 [/text]
1511     )
1512   (and
1513     (set 'sid (semaphore))
1514     (if (and (> opsys 5)(< opsys 9))
1515       (process (string "newlisp udptest.lsp " 10001 " " 10002 " " sid))
1516       (process (string "./newlisp udptest.lsp " 10001 " " 10002 " " sid)))
1517     (println "---------- testing UDP Win32 and OS/2 -------------")
1518     (println "waiting ...");
1519     (semaphore sid -1) ; wait for child process
1520     (sleep 100)
1521     (println "sending ...")
1522     (net-send-udp "localhost" 10001 "hello")
1523     (println "receiving ...")
1524     (set 'msg (net-receive-udp 10002 20 3000000))
1525     (println "msg:" msg)
1526     (or (delete-file "udptest.lsp") true)
1527     (println "deleting semaphore:" (semaphore sid 0)) ; delete semaphore
1528     (println "------------------------------------------")
1529     (if msg (set 'net-send-udp-test (= "HELLO" (first msg)) ) )))
1530
1531
1532 (if (or (< opsys 6)(= opsys 9))
1533   (define (test-net-receive-udp)
1534     (fork (begin (sleep 500) (net-send-udp "localhost" 10001 "hello")))
1535     (set 'net-send-udp-test (= "hello" (first (net-receive-udp 10001 10)))))
1536 )
1537
1538
1539 (define (test-net-select )  net-select-test)
1540
1541 (define (test-net-send ) net-send-test)
1542
1543 (define (test-net-send-to ) net-send-to-test)
1544
1545 (define (test-net-send-udp ) net-send-udp-test)
1546
1547 (define (test-net-service ) (= 21 (net-service "ftp" "tcp")))
1548
1549 (define (test-net-sessions ) net-sessions-test)
1550
1551 (define (test-new)
1552   (new QA 'MAIN:QA2))
1553
1554 (define (test-nil?)
1555   (and
1556     ;test symbol-nil = logic-nil in order compare of count
1557         (= (count '(nil true) (map (curry < 3) '(1 2 4 5))) '(2 2))
1558     (= nil (not (nil? nil)))
1559     (= '(nil true) (map nil? '(a nil)))))
1560
1561 (define (test-null?)
1562         (= (map null? '(1 0 2 0.0 "hello" "" (a b c) () nil true (lambda) (fn) (lambda ())))
1563         '(nil true nil true nil true nil true true nil true true nil)))
1564
1565 (define (test-normal )
1566   (and (float? (normal)) (float? (normal 10 3)) (list? (normal 10
1567      3 100))))
1568
1569 (define (test-not )
1570   (and (not (not (not '()))) (not (not (not (not (not nil))))) (not
1571     (not (not (not true))))
1572    (= '(true true true) (map not '(nil nil nil)))
1573    (= '(nil nil nil) (map not '(true true true)))))
1574
1575 (define (test-now )
1576   (= (length (now)) 11))
1577
1578 (define (test-nper )
1579   (< (sub (nper 0.1 1000 100000 0 0) -25.15885793) 1e-08))
1580
1581 (define (test-npv )
1582   (< (sub (npv 0.1 '(-10000 3000 4200 6800)) 1188.443412) 1e-06))
1583
1584 (define (test-nth , l) ;; see set-nth for more comprehensive testing
1585         (set 'l '(0 1 2))
1586         (and (= 0 (nth 0 l))
1587                 (= 1 (nth 1 l))
1588                 (= 2 (nth 2 l))
1589                 (= 2 (nth -1 l))
1590                 (= (nth 0 "lisp") "l")
1591                 (= (nth 1 "lisp") "i")
1592                 (= (nth 3 "lisp") "p")
1593                 (= (nth -4 "lisp") "l")
1594                 (= (nth 0 "") "")
1595                 (= (nth 1 "") "")
1596                 (= (nth -1 "") "")
1597
1598                 (set 'l '(a b (c d) (e f)))
1599                 (= 'a (l 0))
1600                 (= '(c d) (l 2))
1601                 (= 'c (l 2 0))
1602                 (= 'f (l -1 -1))
1603                 (= 'c (l '(2 0)))
1604                 (= 'f (l '(-1 -1)))
1605
1606                 (set 'myarray (array 3 2 (sequence 1 6)))
1607                 (= (array 2 '(3 4)) (myarray 1))
1608                 (= 6 (myarray -1 -1))
1609
1610                 (= (array 2 '(3 4)) (myarray '(1)))
1611                 (= 6 (myarray '(-1 -1)))
1612
1613                 (= "L" ("newLISP" 3))
1614
1615                 (constant 'constL '((1 2 3) (a b c)))
1616                 (set 'aref '(1 2))
1617                 (= (constL 1 2) 'c)
1618                 (= (nth 1 2 constL) 'c)
1619                 (= (nth (constL 1 2)) 'c)
1620                 (= (nth (constL (- 2 1) (+ 1 1))) 'c)
1621                 (= (nth (constL '(1 2))) 'c)
1622                 (= (nth (constL aref)) 'c)
1623                 (= (nth 0 (+ 1 1) constL) 3)
1624
1625   ))
1626
1627 (define (test-number?)
1628     (and
1629         (number? 1)
1630         (number? 1.23)
1631         (not (number? 'x))
1632         (not (number? "abc"))
1633         (not (number? '(a b c)))
1634     )
1635 )
1636
1637 (define (test-open )
1638   (and
1639     (set 'fle (open "qa-dot" "read"))
1640     (close fle)))
1641
1642 (define (test-or )
1643   (and (or (or (= 1 2) nil nil) (or nil nil nil true)) (not (or nil
1644      (= "a" "b") nil))))
1645
1646 (define (test-pack )
1647  (and
1648   (= (pack "c c c" 65 66 67) "ABC")
1649   (= (unpack "c c c" "ABC") '(65 66 67))
1650   (set 's (pack "c d u" 10 12345 56789))
1651   (= (unpack "c d u" s) '(10 12345 56789))
1652   (set 's (pack "s10 f" "result" 1.23))
1653   (= (first (unpack "s10 f" s)) "result\000\000\000\000")
1654   (< (- (last (unpack "s10 f" s)) 1.23) 0.00001)
1655   (set 's (pack "s3 lf" "result" 1.23))
1656   (= (first (unpack "s3 f" s)) "res")
1657
1658   (= (pack "ccc" 65 66 67) "ABC")
1659   (= (unpack "ccc" "ABC") '(65 66 67))
1660   (set 's (pack "cdu" 10 12345 56789))
1661   (= (unpack "cdu" s) '(10 12345 56789))
1662   (set 's (pack "s10f" "result" 1.23))
1663   (= (first (unpack "s10f" s)) "result\000\000\000\000")
1664   (< (- (last (unpack "s10f" s)) 1.23) 0.00001)
1665   (set 's (pack "s3lf" "result" 1.23))
1666   (= (first (unpack "s3f" s)) "res")
1667
1668   (= "\001\000" (pack "<d" 1))
1669   (= "\000\001" (pack ">d" 1))
1670   (= "\001\000\000\000" (pack "<ld" 1))
1671   (= "\000\000\000\001" (pack ">ld" 1))
1672   (= '(12345678) (unpack "ld" (pack "ld" 12345678)))
1673   (= '(12345678) (unpack "<ld" (pack "<ld" 12345678)))
1674   (= '(12345678) (unpack ">ld" (pack ">ld" 12345678)))
1675   (= (unpack "bbbbbbbb" (pack "<lf" 1.234)) '(88 57 180 200 118 190 243 63))
1676   (= (unpack "bbbbbbbb" (pack ">lf" 1.234)) '(63 243 190 118 200 180 57 88))
1677   (= (format "%20.2f" (first (unpack "lf" (pack "lf" 1234567890123456)))) " 1234567890123456.00")
1678 ))
1679
1680 (define (test-parse )
1681   (and
1682     (= 3 (length (parse "hello hi there")))
1683     (= (parse "abcbdbe" "b") '("a" "c" "d" "e"))
1684     (= (parse "," ",") '("" ""))
1685     (= (parse "hello regular   expression 1, 2, 3" {,\s*|\s+} 0)
1686        '("hello" "regular" "expression" "1" "2" "3"))))
1687
1688
1689 (define (test-parse-date)
1690         (and
1691                 (= (parse-date "2007.1.3" "%Y.%m.%d") 1167782400)
1692                 (= (parse-date "January 10, 07" "%B %d, %y") 1168387200)
1693 ))
1694
1695
1696 (define (test-peek)
1697         (set 'fle (open "qa-dot" "r"))
1698         (= (peek fle) (first (file-info "qa-dot")))
1699         (close fle))
1700
1701 (define (test-pipe)
1702         (write-file "pipe-child.lsp"
1703 [text]
1704 (set 'msg (read-line (int (nth 2 (main-args)))))
1705 (write-line (upper-case msg) (int (nth 3 (main-args))))
1706 (exit)
1707 [/text]
1708         )
1709         (set 'channel (pipe))
1710         (set 'in (first channel))
1711         (set 'out (last channel))
1712         (if (and (> opsys 5) (< opsys 9))
1713                 (process (string "newlisp pipe-child.lsp " in " " out))
1714                 (process (string "./newlisp pipe-child.lsp " in " " out)))
1715         (sleep 500)
1716         (write-line "hello there" out)
1717         (sleep 500)
1718         (= (read-line in) "HELLO THERE")
1719         (delete-file "pipe-child.lsp"))
1720
1721 (if (< opsys 6)
1722   (define (test-pipe)
1723         (set 'channel (pipe))
1724         (set 'in (first channel))
1725         (set 'out (last channel))
1726         (fork (write-line (upper-case (read-line in)) out))
1727         (write-line "hello there" out)
1728         (sleep 1000)
1729         (= (read-line in) "HELLO THERE")
1730         )
1731 )
1732
1733
1734 (define (test-pmt )
1735   (< (sub (pmt 0.1 10 100000 0 0) -16274.53949) 1e-05))
1736
1737 (define (test-pop , r l)
1738   (set 'r '())
1739   (set 'l '(1 2 3 4 5 6 7 8 9 0))
1740   (dotimes (x 10)
1741    (push (pop l) r))
1742   (and (= r '(0 9 8 7 6 5 4 3 2 1))
1743        (set 'l '(a b (c d (x) e)))
1744        (= 'x (pop l '(2 2 0)))
1745        (set 'lst '(1 2 3 (4 5)()))
1746        (push 'x lst -1 -1)
1747        (= lst '(1 2 3 (4 5) (x)))
1748        (push 'y lst -1 0)
1749        (= lst '(1 2 3 (4 5) (y x)))
1750        (push 'z lst -1 1)
1751        (= lst '(1 2 3 (4 5) (y z x)))
1752        (push 'p lst 4)
1753        (= lst '(1 2 3 (4 5) p (y z x)))
1754        (push 'q lst -2)
1755        (= lst '(1 2 3 (4 5) p q (y z x)))
1756        (push 'a lst 3 -3)
1757        (= lst '(1 2 3 (a 4 5) p q (y z x)))
1758        (= (pop lst 3 -3) 'a)
1759        (= (pop lst -2) 'q)
1760        (= (pop lst 4) 'p)
1761        (= (pop lst -1 1) 'z)
1762        (= (pop lst -1 0) 'y)
1763        (= (pop lst -1 -1) 'x)
1764        (= lst '(1 2 3 (4 5)()))
1765        ; test pop string
1766        (set 's "newLISP")
1767        (= (pop s) "n")
1768        (= s "ewLISP")
1769        (= (pop s 2) "L")
1770        (= s "ewISP")
1771        (= (pop s -1) "P")
1772        (= s "ewIS")
1773        (= (pop s -2 2) "IS")
1774        (= s "ew")
1775        (= (pop s -2 10) "ew")
1776        (= s "")
1777        (set 's "123456789")
1778        (= (pop s 5) "6")
1779        (= (pop s 5 -1) "")
1780        (= s "12345789")
1781        (set 's "123456789")
1782        (= (pop s 5 5) "6789")
1783        (set 's "x")
1784        (= (pop s) "x")
1785        (= s "")
1786        (= (pop s) "")
1787        (= (pop s) "")
1788        (= s "")
1789 ))
1790
1791 (define (test-pop-assoc)
1792         (and
1793                 (set 'L '((a (b 1) (c (d 2)))))
1794                 (= (pop-assoc (L 'a)) '(a (b 1) (c (d 2))))
1795                 (= L '())
1796                 (set 'L '((a (b 1) (c (d 2)))))
1797                 ( = (pop-assoc (L 'a 'b)) '(b 1))
1798                 (= L '((a (c (d 2)))))
1799                 (set 'L '((a (b 1) (c (d 2)))))
1800                 (= (pop-assoc (L 'a 'c)) '(c (d 2)))
1801                 (= L '((a (b 1))))
1802                 (set 'L '((a (b 1) (c (d 2)))))
1803                 (= (pop-assoc (L 'a 'c 'd)) '(d 2))
1804                 (= L '((a (b 1) (c))))
1805                 (= (pop-assoc (L 'a 'c)) '(c))
1806                 (= L '((a (b 1))))
1807                 (= (pop-assoc (L 'a 'b)) '(b 1))
1808                 (= L '((a)))
1809                 (= (pop-assoc (L 'a)) '(a))
1810                 (= L '())
1811         )
1812 )
1813
1814 (define (test-post-url )
1815   (= "ERR: bad formed URL" (post-url "" "abc" "def")))
1816
1817 (define (test-pow )
1818   (and
1819     (= 1024 (pow 2 10))
1820     (= 100 (pow 10))
1821 ))
1822
1823 (define (test-pretty-print)
1824   (= (pretty-print) '(80 " ")))
1825
1826 (define (test-primitive? )
1827   (primitive? primitive?))
1828
1829 (define (test-print )
1830   (device (open "testprint" "w"))
1831   (print "hello")
1832   (close (device))
1833   (and (= "hello" (read-file "testprint"))
1834      (delete-file "testprint")))
1835
1836 (define (test-println )
1837   (device (open "testprintln" "w"))
1838   (print "hello")
1839   (close (device))
1840   (and
1841      (= "hello" (slice (read-file "testprintln") 0 5))
1842      (delete-file "testprintln")))
1843
1844 (define (test-prob-chi2 )
1845   (< (abs (sub (prob-chi2 10 10) 0.440493)) 1e-05))
1846
1847 (define (test-prob-z )
1848   (< (abs (sub (prob-z 0) 0.5)) 1e-05))
1849
1850 (define (test-process )
1851    (write-file "process test" {(write-file "test process" "hello") (exit)})
1852    (if (and (> opsys 5) (< opsys 9))
1853         (process {newlisp '"process test"'}) ; Win32
1854     (process "./newlisp 'process test'")) ; Unix
1855    (until (file? "test process") (sleep 500))
1856    (sleep 200)
1857    (and
1858      (= "hello" (read-file "test process"))
1859      (delete-file "process test")
1860      (delete-file "test process")))
1861
1862 (define (test-protected?)
1863         (and
1864                 (protected? 'println)
1865                 (constant 'cval 123)
1866                 (protected? 'cval)
1867                 (protected? 'QA))
1868 )
1869
1870 (define (test-push , l)
1871   (dotimes (x 10)
1872    (push x l x))
1873   (and
1874        (= l '(0 1 2 3 4 5 6 7 8 9))
1875        (set 'l '(a b (c d () e)))
1876        (push 'x l '(2 2 0))
1877        (= (ref 'x l) '(2 2 0))
1878        (set 'lst '(1 2 3 (4 5)()))
1879        (push 'x lst -1 -1)
1880        (= lst '(1 2 3 (4 5) (x)))
1881        (push 'y lst -1 0)
1882        (= lst '(1 2 3 (4 5) (y x)))
1883        (push 'z lst -1 1)
1884        (= lst '(1 2 3 (4 5) (y z x)))
1885        (push 'p lst 4)
1886        (= lst '(1 2 3 (4 5) p (y z x)))
1887        (push 'q lst -2)
1888        (= lst '(1 2 3 (4 5) p q (y z x)))
1889        (push 'a lst 3 -3)
1890        (= lst '(1 2 3 (a 4 5) p q (y z x)))
1891        (= (pop lst 3 -3) 'a)
1892        (= (pop lst -2) 'q)
1893        (= (pop lst 4) 'p)
1894        (= (pop lst -1 1) 'z)
1895        (= (pop lst -1 0) 'y)
1896        (= (pop lst -1 -1) 'x)
1897        (= lst '(1 2 3 (4 5)()))
1898        (test-push-pop)
1899        (test-push-optimization-bug)
1900        ; test string push
1901        (set 's "newLISP")
1902        (= (push "#" s) "#")
1903        (= s "#newLISP")
1904        (= (push "#" s 1) "#")
1905        (= s "##newLISP")
1906        (= (push "#" s 3) "#")
1907        (= s "##n#ewLISP")
1908        (= (push "#" s -1) "#")
1909        (= s "##n#ewLISP#")
1910        (= (push "#" s -3) "#")
1911        (= s "##n#ewLIS#P#")
1912        (= (push "xy" s) "xy")
1913        (= s "xy##n#ewLIS#P#")
1914        (= (push "xy" s -1) "xy")
1915        (= s "xy##n#ewLIS#P#xy")
1916        (set 's "")
1917        (= (push "" s) "")
1918        (= s "")
1919        (set 's "newLISP")
1920        (= (push "" s -1) "")
1921        (= (push "" s) "")
1922        (= s "newLISP")
1923        (push "-" s 7)
1924            (= s "newLISP-")
1925            (push "-" s -9)
1926            (= s "-newLISP-")
1927        (set 's "newLISP")
1928        (push "-" s 8)
1929            (= s "newLISP-")
1930            (push "-" s -10)
1931            (= s "-newLISP-")
1932 ))
1933
1934 (define (test-push-pop)
1935         (set 'lst (sequence 1 1000))
1936         (dotimes (x 1000) (push (pop lst) lst -1))
1937         (= lst (sequence 1 1000)))
1938
1939 (define (test-push-optimization-bug) ; fixed in 8.7.1
1940     (set 'l nil)
1941     (and (push 'x l -1)
1942          (set 'lst l)
1943          (push 'y lst -1)
1944          (= lst '(x y))))
1945
1946 (define (test-put-url )
1947   (= "ERR: bad formed URL" (put-url "" "abc")))
1948
1949 (define (test-pv )
1950   (< (sub (pv 0.1 10 1000 100000 0 0) -44696.89605) 1e-05))
1951
1952 (define (test-quote )
1953   (= (quote x) 'x))
1954
1955 (define (test-quote? )
1956   (quote? ''quote?))
1957
1958 (define (test-rand , sum)
1959   (set 'sum 0)
1960   (dotimes (x 1000)
1961    (inc 'sum (rand 2)))
1962   (and (< sum 600) (> sum 400) (list? (rand 10 100))))
1963
1964 (define (test-random )
1965   (and (float? (random)) (= (length (random 0 1 10)) 10)))
1966
1967 (define (test-randomize)
1968   (and
1969     (!= '(a b c d e f g) (randomize '(a b c d e f g)))
1970     (= (difference '(a b c d e f g) (randomize '(a b c d e f g))) '())
1971   )
1972 )
1973
1974 (define (test-read-expr)
1975     (set 'code "; a statement\n(+ 3 4)\n(define (double x) (+ x x))")
1976     (read-expr code (fn (x) (push x clist)) (context))
1977     (= clist '((define (double x) (+ x x)) (+ 3 4)))
1978 )
1979
1980 (define (test-read-buffer )
1981   (and
1982     (set 'file (open "qa-dot" "read"))
1983     (read-buffer file 'buff (nth 0 (file-info "qa-dot")))
1984     (close file)
1985     (set 'file (open "junk" "write"))
1986     (write-buffer file 'buff (nth 0 (file-info "qa-dot")))
1987     (close file)))
1988
1989 (define (test-read-char )
1990   (and
1991     (file-copy "qa-dot" "junk")
1992     (delete-file "junk")))
1993
1994 (define (test-read-file )
1995   (read-file "qa-dot"))
1996
1997 (define (test-read-key) true)
1998
1999 (define (test-read-line )
2000   (line-count "qa-dot"))
2001
2002
2003 (define (test-real-path)
2004   (and
2005         (string? (real-path))
2006     (string? (real-path "."))
2007  ))
2008
2009 (define (test-ref)
2010   (and
2011     (set 'pList '(a b (c d () e)))
2012     (push 'x pList 2 2 0)
2013     (= (ref 'x pList) '(2 2 0))
2014     (= (ref '(x) pList) '(2 2))
2015     (set 'v (ref '(x) pList))
2016     (= (pList v) '(x))
2017     (= (ref 'foo pList) '())
2018     ; comparison functor
2019     (= (ref 'e '(a b (c d (e) f)) =) '(2 2 0))
2020     (= (ref 'e '(a b (c d (e) f)) >) '(0))
2021     (= (ref 'e '(a b (c d (e) f)) <) '(2))
2022     (= (ref 'e '(a b (c d (e) f)) (fn (x y) (or (= x y) (= y 'd)))) '(2 1))
2023     (define (is-it-or-d x y) (or (= x y) (= y 'd)))
2024     (= (ref 'e '(a b (c d (e) f)) is-it-or-d) '(2 1))
2025     ; comparison with match and unify
2026     (= (ref '(a ?) '((l 3) (a 12) (k 5) (a 10) (z 22)) match) '(1))
2027     (= (ref '(X X) '( ((a b) (c d)) ((e e) (f g)) ) unify) '(1 0))
2028     (= (ref '(X g) '( ((a b) (c d)) ((e e) (f g)) ) unify) '(1 1))
2029 ))
2030
2031 (define (test-ref-all)
2032   (and
2033     (set 'L '(a b c (d a f (a h a)) (k a (m n a) (x))))
2034     (= (ref-all 'a L) '((0) (3 1) (3 3 0) (3 3 2) (4 1) (4 2 2)))
2035     (= (L '(3 1)) 'a)
2036     (= (map 'L (ref-all 'a L)) '(a a a a a a))
2037     ; with comparison functor
2038     (= (ref-all 'a '(1 2 3 4 5 6)) '())
2039     (set 'L '(a b c (d f (h l a)) (k a (m n) (x))))
2040     (= (ref-all 'c L =) '((2)))
2041     (= (ref-all 'c L >) '((0) (1) (3 2 2) (4 1)))
2042     (= (ref-all 'a L (fn (x y) (or (= x y) (= y 'k)))) ' ((0) (3 2 2) (4 0) (4 1)))
2043     (define (is-long? x y) (> (length y) 2))
2044     (= (ref-all nil L is-long?) '((3) (3 2) (4)))
2045     (define (is-it-or-d x y) (or (= x y) (= y 'd)))
2046     (= (ref-all 'e '(a b (c d (e) f)) is-it-or-d) '((2 1) (2 2 0)))
2047     (= (ref-all 'b '(a b (c d (e) f)) is-it-or-d) '((1) (2 1)))
2048     (= (ref-all nil '(((()))) (fn (x y) (> (length y) 0))) '((0) (0 0)))
2049     ; test comparison with match and unify
2050     (= (ref-all '(a ?) '((l 3) (a 12) (k 5) (a 10) (z 22)) match) '((1) (3)))
2051     (= (ref-all '(X X) '( ((a b) (c d)) ((e e) (f g)) ((z) (z))) unify) '((1 0) (2)))
2052     (= (ref-all '(X g) '( ((x y z) g) ((a b) (c d)) ((e e) (f g))) unify) '((0) (2 1)))
2053 ))
2054
2055
2056 (define (test-regex )
2057   (and
2058    (= (regex "http://(.*):(.*)" "http://nuevatec.com:80")
2059       '("http://nuevatec.com:80" 0 22 "nuevatec.com" 7 12 "80" 20 2))
2060    (= $0 "http://nuevatec.com:80")
2061    (= $1 "nuevatec.com")
2062    (= $2 "80")
2063    (= (regex "b+" "AAAABBBAAAA" 1) '("BBB" 4 3))))
2064
2065 (define (test-remove-dir )
2066   (and (make-dir "junk") (remove-dir "junk")))
2067
2068 (define (test-rename-file )
2069   (copy-file "qa-dot" "junk")
2070   (rename-file "junk" "junk2"))
2071
2072 ;; this can run only once than must be reloaded
2073 ;; because some replace's are in place with a constant
2074 (define (test-replace )
2075  (and
2076   (not (catch (replace "a" "akakak") 'result))
2077   (not (catch (replace "a") 'result))
2078   (not (catch (replace) 'result))
2079   (catch (replace "a" '("x" "a" "y")) 'result)
2080   (= (replace "a" "ababab" "b") "bbbbbb")
2081   (= $0 3)
2082   (= (replace 'a '(a a b a b a a a b a) 'b) '(b b b b b b b b b b))
2083   (= (replace 'a '(a a b a b a a a b a)) '(b b b))
2084   (= (replace 'a '(a)) '())
2085 ;; with regular expressions option
2086   (= (replace "" "abc" "x" 0) "xaxbxcx")
2087   (= (replace "$" "abc" "x" 0) "abcx")
2088   (= (replace "^" "abc" "x" 0) "xabc")
2089   (= (replace "\\b" "abc" "x" 0) "xabcx")
2090   (= (replace "(?<=[0-9])(?=(?:[0-9]{3})+(?![0-9]))" "1234567" "," 0) "1,234,567")
2091   (= (replace "a" "ababab" (upper-case $0) 0) "AbAbAb")
2092   (= $0 3)
2093   (set 'str2 "abaBab")
2094   (= (replace "b|B" str2 "z" 0) "azazaz")
2095   (= $0 3)
2096   (replace-once "aaa")
2097   (= (replace "%([0-9A-F][0-9A-F])" "%41123%42456%43" (char (int (append "0x" $1))) 1) "A123B456C")
2098   ; replace with comparison functor
2099   (set 'L '(1 4 22 5 6 89 2 3 24))
2100   (= (replace 10 L 10 <) '(1 4 10 5 6 10 2 3 10))
2101   (set 'L '(1 4 22 5 6 89 2 3 24))
2102   (= (replace 10 L 10 (fn (x y) (< x y))) '(1 4 10 5 6 10 2 3 10))
2103   ;
2104   (set 'AL '((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
2105   (= (replace '(mary *)  AL (list 'mary (apply + (rest $0))) match)
2106     '((john 5 6 4) (mary 14) (bob 4 2 7 9) (jane 3)))
2107   (set 'AL '((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
2108   (= (replace '(*) AL (list ($0 0) (apply + (rest $0))) match)
2109     '((john 15) (mary 14) (bob 22) (jane 3)))
2110   (set 'AL '((john 5 6 4) ("mary" 3 4 7) (bob 4 2 7 9) ("jane" 3)))
2111   (= (replace nil AL (cons (sym ($0 0)) (rest $0)) (fn (x y) (string? (y 0))))
2112     '((john 5 6 4) (mary 3 4 7) (bob 4 2 7 9) (jane 3)))
2113 ))
2114
2115 (define (replace-once str)
2116   (= (replace "a" str (upper-case $0) 0x8000) "Aaa") ;; custom option replace once
2117 )
2118
2119 (define (test-replace-assoc )
2120   (set 'aList '((a 1 2 3) (b 4 5 6) (c 7 8 9)))
2121   (set 'bList '((a 1) (b 2) (c 3)))
2122   (replace-assoc 'b aList '(b 4 5 99))
2123   (replace-assoc 'c aList '(x "this works too"))
2124   (and
2125     (= aList '((a 1 2 3) (b 4 5 99) (x "this works too")))
2126     (set 'lst '((a 1)(b 2)(c 3)))
2127     (= (replace-assoc 'b lst (list 'b (+ 1 (last $0))))
2128        '((a 1)(b 3)(c 3)))
2129     (= (replace-assoc 'b bList) '((a 1) (c 3)))
2130     (= (replace-assoc 'a bList) '((c 3)))
2131     (= (replace-assoc 'c bList) '())
2132   )
2133 )
2134
2135 (define (test-reset )
2136   true)
2137
2138 (define (test-rest , l)
2139   (set 'l '(a b c d e f g))
2140   (and  (= (cons (first l) (rest l)) l)
2141     (= (rest "newlisp") "ewlisp")
2142 ;; implicit nrest
2143         (= (1 l) '(b c d e f g))
2144     (= (10 l) '())
2145     (= (0 l) l)
2146     (= (-3 '(a b c d e f g)) '(e f g))
2147         (= (-3 "abcdefg") "efg")
2148     (= (1 '(A)) '())
2149     (= (1 "A") "")
2150     (= (array 2 2 (sequence 3 6)) (rest (array 3 2 (sequence 1 6))))
2151 ))
2152
2153 (define (test-reverse )
2154   (and
2155     (= (reverse '(1 2 3)) '(3 2 1))
2156     (= (reverse "newLISP") "PSILwen")))
2157
2158 (define (test-rotate )
2159   (and
2160     (= '(8 9 0 1 2 3 4 5 6 7) (rotate '(0 1 2 3 4 5 6 7 8 9) 2))
2161     (= '() (rotate '()))
2162         (= (rotate '(1) -1) '(1))
2163         (= (rotate "") "")
2164         (= (rotate "x" -1) "x")
2165         (set 'str "abcdefg")
2166         (= (rotate str) "gabcdef")
2167         (= (rotate str 3) "defgabc")
2168         (= (rotate str -4) "abcdefg")
2169 ))
2170
2171 (define (test-round)
2172         (and
2173                 (= (round 1.25)  (round 1.25 0) 1)
2174                 (= (round 3.89) (round 3.89 0) 4)
2175                 (= (round 123.49 2) 100)
2176                 (= (round 123.49 1) 120)
2177                 (= (round 123.49 0) 123)
2178                 (= (round 123.49 -1) 123.5)
2179                 (= (round 123.49 -2) 123.49)
2180                 (= (round 123.49 -3) 123.49)
2181                 (!= (round 123.49 -2) 123.49000000000001)
2182                 (= (round 123.49 3)  0)))
2183
2184 (define (test-save )
2185   (and (save "all") (save "save.lsp" 'test-save) (delete-file "all")
2186    (delete-file "save.lsp")))
2187
2188 (define (test-search , file)
2189   (and
2190     (set 'file (open "qa-dot" "read"))
2191     (search file "define")
2192     (close file)))
2193
2194 (define (test-seed )
2195   (seed 123)
2196   (set 'a (rand 10))
2197   (seed 123)
2198   (set 'b (rand 10))
2199   (= a b))
2200
2201 (define (test-seek , file chr)
2202   (set 'file (open "junk" "write"))
2203   (dotimes (x 100)
2204    (write-char file x))
2205   (close file)
2206   (set 'file (open "junk" "read"))
2207   (seek file 65)
2208   (set 'chr (read-char file))
2209   (close file)
2210   (delete-file "junk")
2211   (= chr 65))
2212
2213 (define (test-select )
2214   (set 'l '(0 1 2 3 4 5 6 7 8 9))
2215   (and
2216     (test-select-collect)
2217     (= (select l '(0 9 9 0 1 8 8 1)) '(0 9 9 0 1 8 8 1))
2218     (= (select "2001-09-20" '(5 6 8 9 0 1 2 3)) "09202001")))
2219
2220 ;; for testing semaphores accross processes/threads see test-share
2221 (define (test-semaphore)
2222   (and
2223     (set 'sid (semaphore))
2224     (if (or (< opsys 5)(= opsys 9)) (= (semaphore sid) 0) true) ;; no semaphore status on Win32
2225     (semaphore sid 1)
2226     (if (or (< opsys 5)(= opsys 9)) (= (semaphore sid) 1) true) ;; no semaphore status on Win32
2227     (semaphore sid 0)))
2228
2229 (define (test-sequence )
2230   (= (sequence 1 10 3) '(1 4 7 10)))
2231
2232 (define (test-series )
2233   (and
2234     (= (series 2 2 5) '(2 4 8 16 32))
2235     (= (series 2 2 0) '())
2236     (= (series 1 2 -10) '())
2237     (= (series 1 1 5) '(1 1 1 1 1))
2238 ))
2239
2240 (define (test-set , x y z)
2241   (set 'x (set 'y (set 'z 123)))
2242   (= x 123))
2243
2244 (define (test-setq , x y z)
2245   (setq x 1 y 2 z 3)
2246   (and (= x 1) (= y 2) (= z 3)))
2247
2248 (define (test-set-assoc)
2249  (and
2250         (set 'L '((a 1) (b (c (d 2) (e 3) (e 4))) ("a" 5) ((a) 6)))
2251         (= (assoc 'a L) '(a 1))
2252         (= (assoc 'b L) '(b (c (d 2) (e 3) (e 4))))
2253         (= (assoc "a" L) '("a" 5))
2254         (= (assoc '(a) L) '((a) 6))
2255
2256         (= (assoc (L 'a)) '(a 1))
2257         (= (assoc (L 'b)) '(b (c (d 2) (e 3) (e 4))))
2258         (= (assoc (L "a")) '("a" 5))
2259         (= (assoc (L '(a))) '((a) 6))
2260
2261         (= (assoc (L 'b 'c)) '(c (d 2) (e 3) (e 4)))
2262         (= (assoc (L 'b 'c 'd)) '(d 2))
2263         (= (assoc (L 'b 'c 'e)) '(e 3))
2264
2265         (= (set-assoc (L 'a) '(a 11))
2266         '((a 11) (b (c (d 2) (e 3) (e 4))) ("a" 5) ((a) 6)))
2267
2268         (= (set-assoc (L 'b) '(B (C (d 2) (e 3) (e 4))))
2269                 '((a 11) (B (C (d 2) (e 3) (e 4))) ("a" 5) ((a) 6)))
2270
2271         (= (set-assoc (L "a") '("A" 5))
2272                 '((a 11) (B (C (d 2) (e 3) (e 4))) ("A" 5) ((a) 6)))
2273
2274         (= (set-assoc (L '(a)) '((A) 6))
2275                 '((a 11) (B (C (d 2) (e 3) (e 4))) ("A" 5) ((A) 6)))
2276
2277         (= (set-assoc (L 'B 'C) '(c (d 2) (e 3) (e 4)))
2278                 '((a 11) (B (c (d 2) (e 3) (e 4))) ("A" 5) ((A) 6)))
2279
2280         (= (set-assoc (L 'B 'c 'd) '(d 22))
2281                 '((a 11) (B (c (d 22) (e 3) (e 4))) ("A" 5) ((A) 6)))
2282
2283         (= (set-assoc (L 'B 'c 'e) '(e 33))
2284                 '((a 11) (B (c (d 22) (e 33) (e 4))) ("A" 5) ((A) 6)))
2285
2286         (= (length (set 'L (dup '(a 1) 1000))) 1000)
2287         (= (push '(x 9) L -1) '(x 9))
2288         (= (ref '(x *) L match) '(1000))
2289         (= (assoc 'x L) '(x 9))
2290         (= (assoc-set (L 'x) $0) '(x 9))
2291 ))
2292
2293 (define (test-set-nth-implicit)
2294   (and
2295     (= (set-nth ("abcd" 0) "z") "zbcd")
2296     (= (set-nth ("abcd" -1) "z") "abcz")
2297     (= (set-nth ("abcd" 3) "z") "abcz")
2298     (= (set-nth ("abcd" -4) "z") "zbcd")
2299     (= (set-nth ("abcd" 0) "xyz") "xyzbcd")
2300     (= (set-nth ("abcd" -1) "xyz") "abcxyz")
2301     (= (set-nth ("abcd" 3) "xyz") "abcxyz")
2302     (= (set-nth ("abcd" -4) "xyz") "xyzbcd")
2303     (= (set-nth ("abcd" 1) (append $0 $0)) "abbcd")
2304     (set 'l '(1 (2 3) 4))
2305     (= (set-nth (l 0) 'new) '(new (2 3) 4))
2306     (= (nth 0 l) 'new)
2307     (set 'l '(1 (2 3) 4))
2308     (= (set-nth (l 1) 'new) '(1 new 4))
2309     (= (nth 1 l) 'new)
2310     (set 'l '(1 (2 3) 4))
2311     (= (set-nth (l 2) 'new) '(1 (2 3) new))
2312     (= (nth 2 l) 'new)
2313     (set 'l '(1 (2 3) 4))
2314     (= (set-nth (l 0 0) 'new) '(new (2 3) 4))
2315     (= (nth 0 0 l) 'new)
2316     (set 'l '(1 (2 3) 4))
2317     (= (set-nth (l 1 0) 'new) '(1 (new 3) 4))
2318     (= (nth 1 0 l) 'new)
2319     (set 'l '(1 (2 3) 4))
2320     (= (set-nth (l 1 1) 'new) '(1 (2 new) 4))
2321     (= (nth 1 1 l) 'new)
2322     (set 'l '((2 3) 4))
2323     (= (set-nth (l 0 0) 'new) '((new 3) 4))
2324     (= (nth 0 0 l) 'new)
2325     (set 'l '((2 (3 4))(5 6)))
2326     (= (set-nth (l 0 0 0) 'new) '((new (3 4)) (5 6)))
2327     (= (nth 0 0 0 l) 'new)
2328     (set 'l '((2 (3 4))(5 6)))
2329     (= (set-nth (l 0 0 1) 'new) '((new (3 4)) (5 6)))
2330     (= (nth 0 0 1 l) 'new)
2331     (set 'l '((2 (3 4))(5 6)))
2332     (= (set-nth (l 0 1 1) 'new) '((2 (3 new)) (5 6)))
2333     (= (nth 0 1 1 l) 'new)
2334     (set 'l '((2 (3 4))(5 6)))
2335     (= (set-nth (l 0 1) 'new) '((2 new) (5 6)))
2336     (= (nth 0 1 l) 'new)
2337         (set 'L '(1 2 3 4 5))
2338         (= (set-nth (L 3) (+ $0 1)) '(1 2 3 5 5))
2339         (set 'L '(a b c (d e f)))
2340         (= (set-nth (L 3) (set-nth (L 3) 99)) '(a b c (a b c 99)))
2341         (set 'L '(()))
2342         (= (set-nth (L -1) 99) '(99))
2343         (set 'L '((1 2 3) (a b c)))
2344         (= (set 'aref (ref 'c L)) '(1 2))
2345         (= (set-nth (L aref) 99) '((1 2 3) (a b 99)))
2346         (set 'L '((1 2 3) (a b c)))
2347         (= (set-nth 1 (+ 1 1) L 99) '((1 2 3) (a b 99)))
2348         (= (set-nth (L 1 (+ 1 1)) 999) '((1 2 3) (a b 999)))
2349         (= (set-nth (L (sequence 1 10000)) '@) '((1 2 3) (a b @)))
2350 ))
2351
2352 (define (test-set-nth)
2353   (and
2354     (= (set-nth 0 "abcd" "z") "zbcd")
2355     (= (set-nth -1 "abcd" "z") "abcz")
2356     (= (set-nth 3 "abcd" "z") "abcz")
2357     (= (set-nth -4 "abcd" "z") "zbcd")
2358     (= (set-nth 0 "abcd" "xyz") "xyzbcd")
2359     (= (set-nth -1 "abcd" "xyz") "abcxyz")
2360     (= (set-nth (+ 1 2) "abcd" "xyz") "abcxyz")
2361     (= (set-nth -4 "abcd" "xyz") "xyzbcd")
2362     (= (set-nth 1 "abcd" (append $0 $0)) "abbcd")
2363     (set 'l '(1 (2 3) 4))
2364     (= (set-nth 0 l 'new) '(new (2 3) 4))
2365     (= (nth 0 l) 'new)
2366     (set 'l '(1 (2 3) 4))
2367     (= (set-nth 1 l 'new) '(1 new 4))
2368     (= (nth 1 l) 'new)
2369     (set 'l '(1 (2 3) 4))
2370     (= (set-nth 2 l 'new) '(1 (2 3) new))
2371     (= (nth 2 l) 'new)
2372     (set 'l '(1 (2 3) 4))
2373     (= (set-nth 0 0 l 'new) '(new (2 3) 4))
2374     (= (nth 0 0 l) 'new)
2375     (set 'l '(1 (2 3) 4)) ;;;;
2376     (= (set-nth 1 0 l 'new) '(1 (new 3) 4))
2377     (= (nth 1 0 l) 'new)
2378     (set 'l '(1 (2 3) 4))
2379     (= (set-nth 1 1 l 'new) '(1 (2 new) 4))
2380     (= (nth 1 1 l) 'new)
2381     (set 'l '((2 3) 4))
2382     (= (set-nth 0 0 l 'new) '((new 3) 4))
2383     (= (nth 0 0 l) 'new)
2384     (set 'l '((2 (3 4))(5 6)))
2385     (= (set-nth 0 0 0 l 'new) '((new (3 4)) (5 6)))
2386     (= (nth 0 0 0 l) 'new)
2387     (set 'l '((2 (3 4))(5 6)))
2388     (= (set-nth 0 0 1 l 'new) '((new (3 4)) (5 6)))
2389     (= (nth 0 0 1 l) 'new)
2390     (set 'l '((2 (3 4))(5 6)))
2391     (= (set-nth 0 1 1 l 'new) '((2 (3 new)) (5 6)))
2392     (= (nth 0 1 1 l) 'new)
2393     (set 'l '((2 (3 4))(5 6)))
2394     (= (set-nth 0 1 l 'new) '((2 new) (5 6)))
2395     (= (nth 0 1 l) 'new)
2396         (set 'L '(1 2 3 4 5))
2397         (= (set-nth 3 L (+ $0 1)) '(1 2 3 5 5))
2398         (set 'L '(a b c (d e f)))
2399         (= (set-nth 3 L (set-nth 3 L 99)) '(a b c (a b c 99)))
2400         (test-set-nth-implicit)
2401 ))
2402
2403 (define (test-nth-set-implicit)
2404   (and
2405     (= (nth-set ("abcd" 0) "z") "a")
2406     (= (nth-set ("abcd" -1) "z") "d")
2407     (= (nth-set ("abcd" 3) "z") "d")
2408     (= (nth-set ("abcd" -4)"z") "a")
2409     (= (nth-set ("abcd" 0) "xyz") "a")
2410     (= (nth-set ("abcd" -1)"xyz") "d")
2411     (= (nth-set ("abcd" 3) "xyz") "d")
2412     (= (nth-set ("abcd" -4) "xyz") "a")
2413     (= (nth-set ("abcd" 1) (append $0 $0)) "b")
2414     (set 'l '(1 (2 3) 4))
2415     (= (nth-set (l 0) 'new) 1)
2416     (= (nth 0 l) 'new)
2417     (set 'l '(1 (2 3) 4))
2418     (= (nth-set  (l 1) 'new) '(2 3))
2419     (= (nth 1 l) 'new)
2420     (set 'l '(1 (2 3) 4))
2421     (= (nth-set (l 2) 'new) 4)
2422     (= (nth 2 l) 'new)
2423     (set 'l '(1 (2 3) 4))
2424     (= (nth-set (l 3) 'new) 4)
2425     (= (nth 3 l) 'new)
2426     (set 'l '(1 (2 3) 4))
2427     (= (nth-set (l 0 0) 'new) 1)
2428     (= (nth 0 0 l) 'new)
2429     (set 'l '(1 (2 3) 4))
2430     (= (nth-set (l 1 0) 'new) 2)
2431     (= (nth 1 0 l) 'new)
2432     (set 'l '(1 (2 3) 4))
2433     (= (nth-set (l 1 1) 'new) 3)
2434     (= (nth 1 1 l) 'new)
2435     (set 'l '((2 3) 4))
2436     (= (nth-set (l 0 0) 'new) 2)
2437     (= (nth 0 0 l) 'new)
2438     (set 'l '((2 3)))
2439     (= (nth-set (l 1 1) 'new) 3)
2440     (= (nth 1 1 l) 'new)
2441     (set 'l '((2 3)))
2442     (= (nth-set (l 2 3) 'new) 3)
2443     (= (nth 2 3 l) 'new)
2444     (set 'l '((2 (3 4))(5 6)))
2445     (= (nth-set (l 0 0 0) 'new) 2)
2446     (= (nth 0 0 0 l) 'new)
2447     (set 'l '((2 (3 4))(5 6)))
2448     (= (nth-set (l 0 0 1) 'new) 2)
2449     (= (nth 0 0 1 l) 'new) ;;;
2450     (set 'l '((2 (3 4))(5 6)))
2451     (= (nth-set (l 0 1 1) 'new) 4)
2452     (= (nth 0 1 1 l) 'new)
2453     (set 'l '((2 (3 4))(5 6)))
2454     (= (nth-set (l 0 1) 'new) '(3 4))
2455     (= (nth 0 1 l) 'new)
2456         (set 'L '(a b c (d e f)))
2457         (nth-set (L 3) (nth-set (L 3) 99))
2458         (= L '(a b c (d e f)))
2459         (set 'L '((1 2 3) (a b c)))
2460         (= (set 'aref (ref 'c L)) '(1 2))
2461         (= (nth-set (L aref) 99) 'c)
2462 ))
2463
2464
2465 (define (test-nth-set)
2466   (and
2467     (= (nth-set 0 "abcd" "z") "a")
2468     (= (nth-set -1 "abcd" "z") "d")
2469     (= (nth-set (+ 1 2) "abcd" "z") "d")
2470     (= (nth-set -4 "abcd" "z") "a")
2471     (= (nth-set 0 "abcd" "xyz") "a")
2472     (= (nth-set -1 "abcd" "xyz") "d")
2473     (= (nth-set 3 "abcd" "xyz") "d")
2474     (= (nth-set -4 "abcd" "xyz") "a")
2475     (= (nth-set 1 "abcd" (append $0 $0)) "b")
2476     (set 'l '(1 (2 3) 4))
2477     (= (nth-set 0 l 'new) 1)
2478     (= (nth 0 l) 'new)
2479     (set 'l '(1 (2 3) 4))
2480     (= (nth-set 1 l 'new) '(2 3))
2481     (= (nth 1 l) 'new)
2482     (set 'l '(1 (2 3) 4))
2483     (= (nth-set 2 l 'new) 4)
2484     (= (nth 2 l) 'new)
2485     (set 'l '(1 (2 3) 4))
2486     (= (nth-set 2 l 'new) 4)
2487     (= (nth 2 l) 'new)
2488     (set 'l '(1 (2 3) 4))
2489     (= (nth-set 0 0 l 'new) 1)
2490     (= (nth 0 0 l) 'new)
2491     (set 'l '(1 (2 3) 4))
2492     (= (nth-set 1 0 l 'new) 2)
2493     (= (nth 1 0 l) 'new)
2494     (set 'l '(1 (2 3) 4))
2495     (= (nth-set 1 1 l 'new) 3)
2496     (= (nth 1 1 l) 'new)
2497     (set 'l '((2 3) 4))
2498     (= (nth-set 0 0 l 'new) 2)
2499     (= (nth 0 0 l) 'new)
2500     (set 'l '((2 3)))
2501     (= (nth-set 0 1 l 'new) 3)
2502     (= (nth 0 1 l) 'new)
2503     (set 'l '((2 3)))
2504     (set 'l '((2 (3 4))(5 6)))
2505     (= (nth-set 0 0 0 l 'new) 2)
2506     (= (nth 0 0 0 l) 'new)
2507     (set 'l '((2 (3 4))(5 6)))
2508     (= (nth-set 0 0 1 l 'new) 2)
2509     (= (nth 0 0 1 l) 'new)
2510     (set 'l '((2 (3 4))(5 6)))
2511     (= (nth-set 0 1 1 l 'new) 4)
2512     (= (nth 0 1 1 l) 'new)
2513     (set 'l '((2 (3 4))(5 6)))
2514     (= (nth-set 0 1 l 'new) '(3 4))
2515     (= (nth 0 1 l) 'new)
2516         (set 'L '(a b c (d e f)))
2517         (nth-set 3 L (nth-set 3 L 99))
2518         (= L '(a b c (d e f)))
2519 ))
2520
2521
2522 (define (test-set-ref)
2523         (and
2524                 (set 'L '(z a b (z) (d (c c (c)) e f c)))
2525                 (= (set-ref (L 'c) 'z) '(z a b (z) (d (z c (c)) e f c)))
2526                 (set 'L '((a 1) (b 2) (a 3) (b 4)))
2527                 (= (set-ref (L '(a *)) '(z 99) match) '((z 99) (b 2) (a 3) (b 4)))
2528                 (= (set-ref (L '(a *)) '(z 99) match) '((z 99) (b 2) (z 99) (b 4)))
2529                 (set 'Ct:Ct '(a b c d e f g))
2530                 (= (set-ref  (Ct 'c) 'z) '(a b z d e f g))
2531         )
2532 )
2533
2534
2535 (define (test-set-ref-all)
2536     (and
2537                 (set 'L '(z a b (c) (d (c c (c)) e f c)))
2538                 (= (set-ref-all (L 'c) 'z) '(z a b (z) (d (z z (z)) e f z)))
2539                 (set 'L '((a 1) (b 2) (a 3) (b 4)))
2540                 (= (set-ref-all (L '(a *)) '(z 99) match) '((z 99) (b 2) (z 99) (b 4)))
2541     )
2542 )
2543
2544 (define (test-ref-set)
2545         (and
2546                 (set 'L '(a b (c) d e f g))
2547                 (= (ref-set (L 'c) 'z) 'c)
2548                 (set 'L '(a b (c) d e f g))
2549                 (= (ref-set (L 'c) 'z) 'c)
2550         )
2551 )
2552
2553 (define (test-share)
2554     (and
2555       (if (or (< opsys 5)(= opsys 9))
2556           (unix-test-share)
2557           (win32-test-share))
2558       (set 'mvar (share))
2559       (share mvar 123)
2560       (= (share mvar) 123)
2561       (share mvar 123.456)
2562       (= (share mvar) 123.456)
2563       (share mvar "hello")
2564       (= (share mvar) "hello")))
2565
2566
2567 (define (win32-test-share)
2568     (write-file "sharetest.lsp"
2569 [text]
2570 (map set '(sid mm) (map int (slice (main-args) 2)))
2571 (if (= (share mm) "hello") (share mm "HELLO"))
2572 (semaphore sid 1) ; signale parent to read
2573 (exit)
2574 [/text]
2575     )
2576   (and
2577     (set 'sid (semaphore))
2578     (set 'mm (share))
2579     (share mm "hello")
2580     (if (and (> opsys 5)(< opsys 9))
2581       (process (string "newlisp sharetest.lsp " sid " " mm))
2582       (process (string "./newlisp sharetest.lsp " sid " " mm)))
2583     (semaphore sid -1) ; wait for child process
2584     (sleep 1000)
2585     (semaphore sid 0) ;; delete semaphore
2586     (= (share mm) "HELLO")
2587     (or (delete-file "sharetest.lsp") true)))
2588
2589
2590 (define (unix-test-share)
2591   (and
2592     (set 'mm (share))
2593     (share mm "hello")
2594
2595     (wait-pid (fork (begin
2596             (if (= (share mm) "hello")
2597                 (share mm "HELLO"))
2598                 (exit ))))
2599
2600     (= (share mm) "HELLO")
2601     (share nil mm) ; unmap share
2602 ))
2603
2604 (define (test-sgn)
2605  (and
2606    (= 0 (sgn 0))
2607    (= 1 (sgn 123))
2608    (= -1 (sgn -3.5))))
2609
2610
2611 ; test manually
2612 (define (test-signal) true)
2613
2614 (define (test-silent )
2615   (primitive? silent))
2616
2617 (define (test-sin )
2618   (= 1 (sin (asin (sin (asin 1))))))
2619
2620 (define (test-sinh)
2621         (< (abs (sub (tanh 1) (div (sinh 1) (cosh 1))))  0.0000000001)
2622 )
2623
2624 (define (test-sleep )
2625   (set 'start (time-of-day))
2626   (sleep 10)
2627   (set 'start (time-of-day))
2628   (sleep 1000)
2629   (set 'duration (- (time-of-day) start))
2630   (and (> duration 500) (< duration 1500)))
2631
2632 (define (test-slice )
2633 (and
2634    (set 'str "0123456789")
2635    (= (slice str 0 1) "0")
2636    (= (slice str 0 3) "012")
2637    (= (slice str 8 2) "89")
2638    (= (slice str 8 10) "89")
2639    (= (slice str 20 10) "")
2640    (= (slice str 2 -2) "234567")
2641    (= (slice str 2 -5) "234")
2642    (= (slice str 2 -7) "2")
2643    (= (slice str 2 -8) "")
2644    (= (slice str 2 -9) "")
2645    (= (slice '(a b c d e f g) 3 1) '(d))
2646    (= (slice '(a b c d e f g) 3 0) '())
2647    (= (slice '(a b c d e f g) 0 0) '())
2648    (= (slice '(a b c d e f g) 10 10) '())
2649    (= (slice '(a b c d e f g) 3 2) '(d e))
2650    (= (slice '(a b c d e f g) 5) '(f g))
2651    (= (slice '(a b c d e f g) -5 2) '(c d))
2652    (= (slice '(a b c d e f g) -1 -2) '())
2653    (= (slice '(a b c d e f g) 1 -2) '(b c d e))
2654    (= (slice '(a b c d e f g) 4 -2) '(e))
2655    (= (slice '(a b c d e f g) 4 -3) '())
2656    (= (slice '(a b c d e f g) 4 -4) '())
2657    (= (slice '(a b c d e f g) -6 -3) '(b c d))
2658 ;; implicit slice
2659    (= (1 3 '(a b c d e f g)) '(b c d))
2660    (= (-4 2 '(a b c d e f g)) '(d e))
2661    (= (1 3 "abcdefg") "bcd")
2662    (= (-4 2 "abcdefg") "de")
2663    (= (1 -3 "abcdefg") "bcd")
2664    (= (1 -5 "abcdefg") "b")
2665    (=  (1 -7 "abcdefg") "")
2666    (setq x 1 y 2)
2667    (= (x y '(a b c d e f g)) '(b c))
2668    (= (x y "abcdefg") "bc")
2669    (= (1 -2 '(a b c d e f g)) '(b c d e))
2670    (= (4 -2 '(a b c d e f g)) '(e))
2671    (= (4 -3 '(a b c d e f g)) '())
2672    (= (4 -4 '(a b c d e f g)) '())
2673    (= (-6 -3 '(a b c d e f g)) '(b c d))
2674 ))
2675
2676 (define (test-sort )
2677   (and
2678     (= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5)))
2679     (= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5)))
2680     (= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5) <))
2681     (= '(9 8 7 6 5 4 3 2 1) (sort '(9 1 8 2 7 3 6 4 5) >))
2682     (= '(1 2 3 4 5 6 7 8 9) (sort '(9 1 8 2 7 3 6 4 5) (fn (x y) (< x y))))
2683     (= '(9 8 7 6 5 4 3 2 1) (sort '(9 1 8 2 7 3 6 4 5) (fn (x y) (> x y))))
2684     (= '() (sort '()))
2685   )
2686 )
2687
2688 (define (test-source)
2689   (= (replace "\r|\n" (source 'test-sin) "" 0)
2690      "(define (test-sin )  (= 1 (sin (asin (sin (asin 1))))))"))
2691
2692 (define (test-sqrt )
2693   (and (= 10 (sqrt 100)) (= 1.2 (sqrt 1.44))))
2694
2695 (define (test-starts-with )
2696   (and (starts-with "newlisp" "new") (starts-with "newlisp" "NEW"
2697     nil)))
2698
2699 (define (test-string )
2700   (and (string? (string 12345)) (= (string 12345) "12345") (string?
2701     (string 1.234))
2702    (= (string 'test-string) "test-string")
2703    (string? (string test-string))
2704    (= (string "a" "b" "c") (append "a" "b" "c") "abc")
2705    (= (string "a" 123 "b") "a123b")))
2706
2707 (define (test-string? )
2708   (and (string? "1234") (not (string? 1234))))
2709
2710 (define (test-sub )
2711   (= 0 (sub 0.99999999 0.99999999))
2712   (= -123 (sub 123)))
2713
2714 (define (test-swap )
2715   (set 'lst '(1 2 3 4))
2716   (and
2717         (= (swap 1 2 lst) '(1 3 2 4))
2718         (= lst '(1 3 2 4))
2719     (let (a 1 b 2) (and (= (swap a b) 1) (= a 2) (= b 1)))
2720   )
2721 )
2722
2723 (define (test-sym)
2724   (and (= (sym "test-sym") 'test-sym)
2725        (= (sym "test-sym" 'QA) 'test-sym)))
2726
2727 (define (test-symbol? )
2728         (and
2729                 (symbol? (sym "test-symbol"))
2730                 (symbol? (sym "a b"))
2731 ))
2732
2733 (define (test-symbols )
2734   (and (list? (symbols)) (> (length (symbols)) 0)))
2735
2736 (define (test-sys-error)
2737         (integer? (sys-error 0) ))
2738
2739 (define (test-sys-info )
2740    (and (list? (sys-info)) (= (length (sys-info)) 8)))
2741
2742 (define (test-tan )
2743   (> 1 (tan (atan (tan (atan 1))))))
2744
2745 (define (test-tanh)
2746         (< (abs (sub (sinh 1) (div (sub (exp 1) (exp -1)) 2))) 0.0000000001)
2747 )
2748
2749 (define (test-throw )
2750   (and (catch (throw (+ 3 4)) 'msg) (= msg 7)))
2751
2752 (define (test-time )
2753   (integer? (time)))
2754
2755 (define (test-time-of-day )
2756   (integer? (time-of-day)))
2757
2758 (define (test-trace )
2759   (trace nil)
2760   (= nil (trace)))
2761
2762 (define (test-trace-highlight )
2763   (trace-highlight "#" "#"))
2764
2765 (define (test-transpose )
2766  (and
2767   (= '((1) (2) (3)) (transpose '((1 2 3))))
2768   (= '((a b) (c d) (e f)) (transpose '((a c e) (b d f))))
2769   (= '((a d f) (b e g) (c nil nil)) (transpose '((a b c) (d e) (f g))))
2770   (= '((a c f) (b d g)) (transpose '((a b) (c d e) (f g))))
2771 ;; transpose arrays
2772   (set 'A (array 2 3 (sequence 1 6)))
2773   (= (array-list (transpose A)) '((1 4) (2 5) (3 6)))
2774 ))
2775
2776 (define (test-trim )
2777   (and
2778     (= (trim "    hello    ") "hello")
2779     (= (trim "----hello----" "-") "hello")
2780     (= (trim "----hello====" "-" "=") "hello")
2781     (= (trim "000012345" "0" "") "12345")))
2782
2783 (define (test-true?)
2784  (= (map true? '(x nil  1 nil "hi" ())) '(true nil true nil true nil)))
2785
2786 (define (test-unique )
2787   (= (unique '(2 3 4 4 6 7 8 7)) '(2 3 4 6 7 8)))
2788
2789 (define (test-unicode)
2790   (= (utf8 (unicode "newLISP")) "newLISP"))
2791
2792 (define (test-unify)
2793         (and
2794                 (= (unify 'X 123) '((X 123)))
2795         (= (unify '(Int Flt Str Sym Lst) '(123 4.56 "Hello" s '(a b c)))
2796                   '((Int 123) (Flt 4.56) (Str "Hello") (Sym s) (Lst '(a b c))))
2797                 (= (unify 'A 'A) '())
2798                 (= (unify '(A B "hello") '("hi" A Z)) '((A "hi") (B "hi") (Z "hello")))
2799                 (= (unify '(A B) '(B abc)) '((A abc) (B abc)))
2800                 (= (unify '(B A) '(abc B)) '((B abc) (A abc)))
2801                 (= (unify '(A A C D) '(B C 1 C)) '((B 1) (A 1) (C 1) (D 1)))
2802                 (= (unify '(D C A A) '(C 1 C B)) '((D 1) (C 1) (B 1) (A 1)))
2803                 (= (unify '(f A) '(f (a b c))) '((A (a b c))))
2804                 (= (unify '(A f) '((a b c) f)) '((A (a b c))))
2805                 (= (unify '(f (g A)) '(f B)) '((B (g A))))
2806                 (= (unify '(p X Y a) '(p Y X X)) '((Y a) (X a)))
2807                 (= (unify '(p X Y) '(p Y X)) '((Y X)))
2808                 (= (unify '(q (p X Y) (p Y X)) '(q Z Z)) '((Y X) (Z (p X X))))
2809                 (= (unify '(f (g A) A) '(f B xyz)) '((B (g xyz)) (A xyz)))
2810                 (= (unify '(A (g abc)) '(B A)) '((B (g abc)) (A (g abc))))
2811                 ;; with additional environment list
2812                 (= (unify '(A (B) X) '(A (A) Z) '((A 1) (Z 4)))
2813                    '((A 1) (Z 4) (B 1) (X 4)))
2814 ))
2815
2816 (define (test-unless )
2817   (unless nil
2818    true nil))
2819
2820 (define (test-unpack )
2821   (= (pack "c c c" 65 66 67) "ABC")
2822   (= (unpack "c c c" "ABC") '(65 66 67)))
2823
2824 (define (test-until , x)
2825   (set 'x 0)
2826   (= 10 (until (= x 10) (inc 'x)) x))
2827
2828 (define (test-do-until , x)
2829   (set 'x 0)
2830   (and
2831    (= 10 (do-until (= x 10) (inc 'x)) x)
2832    (= 11 (do-until (> x 0) (inc 'x)) x)
2833 ))
2834
2835 (define (test-upper-case )
2836   (if (> opsys 4)
2837    (= "ABCDEFGQ" (upper-case "abcdefgq"))
2838    (= "ABCDEFGH" (upper-case "abcdefgh"))))
2839
2840 (define (test-utf8)
2841   (and
2842     (= (utf8 (unicode "newLISP")) "newLISP")
2843     (MAIN:utf8qa)))
2844
2845 (define (test-utf8len)
2846         (= 23 (utf8len MAIN:utf8str)))
2847
2848 (define (test-uuid)
2849     (= 36 (length (uuid))))
2850
2851 (define (test-wait-pid)
2852   (set 'pid (fork (begin (sleep 200)(exit))))
2853   (wait-pid pid))
2854
2855 (define (test-when)
2856         (and
2857                 (= (when true (set 'x 1) (set 'y 2) (set 'z 3)) 3)
2858                 (= x 1) (= y 2) (= z 3)
2859                 (= (when 123) 123)
2860                 (= (when nil) nil))
2861 )
2862
2863 (define (test-while , x)
2864   (and
2865     (set 'x 0)
2866     (= 1000 (while (< x 1000) (inc 'x)) x)
2867 ))
2868
2869 (define (test-do-while, x)
2870   (and
2871     (set 'x 0)
2872     (= 100 (do-while (< x 100) (inc 'x)) x)
2873     (= 101 (do-while (< x 100) (inc 'x)) x)
2874 ))
2875
2876 (define (test-write-buffer )
2877   (set 'str "")
2878   (dotimes (x 5) (write-buffer str "hello"))
2879   (and (= str "hellohellohellohellohello")
2880        (test-read-buffer)))
2881
2882 (define (test-write-char )
2883   (file-copy "qa-dot" "junk")
2884   (delete-file "junk"))
2885
2886 (define (test-write-file )
2887   (write-file "junk" "newlisp")
2888   (= (read-file "junk") "newlisp"))
2889
2890 (define (test-write-line )
2891   (and
2892     (set 'fle (open "testwrite" "w"))
2893     (write-line "hello" fle)
2894     (close fle)
2895     (set 'fle (open "testwrite" "r"))
2896     (= (read-line fle) "hello")
2897     (close fle)
2898     (delete-file "testwrite")  ))
2899
2900
2901 (define (test-xml-error )
2902   (= (xml-error) nil))
2903
2904 (define (test-xml-parse )
2905   (= (xml-parse "<hello att='value'></hello>") '(("ELEMENT" "hello"
2906      (("att" "value"))
2907      ()))))
2908
2909 (define (test-xml-type-tags )
2910   (length (xml-type-tags) 4))
2911
2912 (define (test-zero?)
2913   (= (map zero? '(1 0 1.2 0.0)) '(nil true nil true)))
2914
2915 (define (test-| )
2916   (= (| -1431655766 1431655765) -1))
2917
2918 (define (test-~ )
2919   (and
2920     (= (~ 0) -1)
2921     (if
2922         (and (> opsys 5) (< opsys 9)) ;; Win32
2923         (= (format "%I64x" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f")
2924
2925         (= opsys 9)
2926         (= (format "%lx" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f")
2927
2928         (= (format "%llx" (~ 0xa0a0a0a0a0a0a0a0)) "5f5f5f5f5f5f5f5f"))
2929 ))
2930
2931 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ENTRY POINT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2932
2933 (if (or (not (or (file? "newlisp") (file? "newlisp.exe"))) (not (file? "qa-dot")))
2934         (begin
2935                 (println "both newlisp(.exe) and qa-dot should be in the current directory.")
2936                 (exit)))
2937
2938 (cleanup)
2939 (println)
2940 (println "Testing built-in functions ...")
2941 (println)
2942 (qa)
2943 (cleanup)
2944
2945 (context 'MAIN)
2946
2947 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2948 (println)
2949 (println "Testing contexts as objects and scoping rules ...")
2950 (println)
2951
2952 ;; check creating local symbols
2953 ;; in case they already exist in MAIN
2954 (set 'var 123)
2955 (set 'CTX:var 456)
2956 (if (or (!= CTX:var 456) (!= var 123))
2957         (println ">>>>> problem creating local symbols"))
2958
2959 (set 'ctx CTX)
2960
2961 (global 'myprint)
2962 (set 'myprint print)
2963
2964 ;; following would fail without dynamic symbols for non-existing
2965 ;; contexts because 'accnt' is not a context at this moment
2966 (define (report accnt)
2967     (list accnt:name accnt:balance))
2968
2969 ;; late in ACCOUNT the definition of 'deposit' should
2970 ;; should not fail, locals should always be created for
2971 ;; the current context
2972 (constant 'amount 999)
2973 (constant 'stat 999)
2974
2975 ;; the symbol defined should always be forced into the current
2976 ;; context, even if alread exists in MAIN, if not following
2977 ;; definition of 'deposit' would fail
2978 (set 'deposit 999)
2979 (set 'clear 999)
2980 (constant 'withdraw 999)
2981
2982 (define balance 1000.00)
2983 (constant 'phone "123-456-789")
2984
2985
2986 (context 'ACCOUNT)
2987     (set 'ACCOUNT:name "")      ; force creation of local symbol with
2988     (define balance 0.0)        ; same name as built in primitive
2989     (constant 'phone "")
2990
2991     (define (deposit amount)
2992         (inc 'balance amount))
2993
2994     (define (withdraw amount)
2995         (dec 'balance amount))
2996
2997     ; make sure contexts are inherited
2998     ; but not variables containing contexts
2999     (if (not (context? CTX))
3000         (QA:failed ">>>> problem inheriting context symbols"))
3001
3002     ; make sure context variables get not inherited
3003     (if (= ctx CTX) (QA:failed ">>>>> should not inherit context var"))
3004
3005     (set 'ctx 123)
3006
3007     ; make sure redefined primitives get inherited
3008     (if (not (primitive? myprint))
3009         (QA:failed ">>>> problem inheriting redefined primitives"))
3010
3011 (set 'myprint nil)
3012
3013 (context 'MAIN)
3014
3015 ;; make sure again that context defs did not overwrite MAIN symbols
3016 (if (or (!= deposit 999) (!= clear 999) (!= withdraw 999) (!= stat 999) (!= ctx CTX)
3017         (not (primitive? name)) (!= balance 1000.0) (!= phone "123-456-789"))
3018         (QA:failed ">>>> context definitions are overwriting MAIN"))
3019
3020 (new ACCOUNT 'John true)     ; this creates a new context copy of
3021                              ; ACCOUNT called 'John' if exists overwrite symbols
3022
3023 (set 'John:name "John Doe")
3024 (set 'John:phone "555-123-456")
3025
3026 (John:deposit 100.00)
3027 (John:withdraw 60)
3028
3029 (new ACCOUNT 'Anne true)
3030
3031 (set 'Anne:name "Anne Somebody")
3032 (set 'Anne:phone "555-456-123")
3033
3034 (Anne:deposit 120.00)
3035 (Anne:withdraw 50)
3036 (if (or (!= John:balance 40) (!= Anne:balance 70))
3037         (QA:failed ">>>> problem with methods in contexts"))
3038
3039 (if (or (!= (report John) (list John:name John:balance))
3040         (!= (report Anne) (list Anne:name Anne:balance)))
3041     (QA:failed ">>>> problem using context variables"))
3042
3043 (if (!= (map report (map eval '(John Anne)))
3044        '(("John Doe" 40) ("Anne Somebody" 70)) )
3045     (QA:failed ">>>> problem mapping functions using context vars"))
3046
3047
3048 ;; dynamic context var as symbol to be defined
3049 ;;
3050 (define (defit)
3051         (define (ctx:foo x) (+ x x)))
3052
3053 (set 'ctx ACCOUNT)
3054 (defit)
3055 (if (!= (ctx:foo 10) 20)
3056   (QA:failed ">>>> problem with dyna symbols in defined symbol"))
3057
3058
3059 ;; check setq, define (as set) and inc, dec on dynamic context vars
3060 ;;
3061 (define (foo-set ct value) (set 'ct:var value))
3062 (define (foo-setq ct value) (setq ct:var value))
3063 (define (foo-define ct value) (define ct:var value))
3064 (define (foo-inc ct value) (inc 'ct:var))
3065 (define (foo-dec ct value) (dec 'ct:var))
3066
3067 (set 'CTX:var 0) ;; make sure var is existent
3068 (foo-set CTX 1)
3069 (if (!= 1 CTX:var)
3070   (QA:failed ">>>> problem with set on context vars"))
3071
3072 (foo-setq CTX 3)
3073 (if (!= 3 CTX:var)
3074   (QA:failed ">>>> problem with setq on context vars"))
3075
3076 (foo-define CTX 4)
3077 (if (!= 4 CTX:var)
3078   (QA:failed ">>>> problem with define on context vars"))
3079
3080 (foo-inc CTX)
3081 (if (!= 5 CTX:var)
3082   (QA:failed ">>>> problem with inc on context vars"))
3083
3084 (foo-dec CTX)
3085 (if (!= 4 CTX:var)
3086   (QA:failed ">>>> problem with dec on context vars"))
3087
3088 ;; dynamic context vars inside a context (since version 7.5.1)
3089
3090 (context 'TST)
3091
3092 (define (init ctx value)
3093         (set 'ctx:foo value))
3094
3095 ;; since version 8.7.8 when calling a function in a context the current runtime
3096 ;; context changes
3097 (define (test-context-change)
3098         (= (context) TST))
3099
3100 (context MAIN)
3101
3102 ;; foo does not exist in CTX
3103
3104 (TST:init CTX 999)
3105
3106 (if (!= 999 CTX:foo)
3107   (QA:failed ">>>> problem with dyna vars in contexts"))
3108
3109 ;; now foo does exist
3110 (TST:init CTX 222)
3111
3112 (if (!= 222 CTX:foo)
3113   (QA:failed ">>>> problem with dyna vars in contexts"))
3114
3115
3116 (define (cdf:cdf a b) (+ a b))
3117
3118 (if (!= (cdf 3 4) 7)
3119   (QA:failed ">>>> problem with context default vars"))
3120
3121 ;; check for existence of dynamic context symbol
3122
3123 (define (check-sym-existence ctx)
3124   (if (symbol? 'ctx:foovar) ;; chack only, will not create
3125     (QA:failed ">>>> problem with symbol? for dyna vars")))
3126
3127 (check-sym-existence CTX)
3128
3129 ;; do not overwrite existing symbols
3130
3131 (set 'Actx:x 123)
3132 (set 'Actx:y 456)
3133 (set 'Bctx:x 999)
3134
3135 (new Actx Bctx)
3136
3137 (if (not (= Bctx:x 999))
3138   (QA:failed ">>>>> problem with new in overwriting symbols"))
3139
3140
3141 ;; delete contexts
3142  (if (not (and
3143         (delete ACCOUNT)
3144         (delete Anne)
3145         (delete John)
3146 ;               (map delete '(Actx Bctx cdf))
3147       ) )
3148     (QA:failed ">>>>> problem deleting contexts"))
3149
3150
3151 ;; define static default functions
3152
3153 (define foobar:foobar)
3154
3155 (define (def-static s contents)
3156    (def-new 'contents (sym (name s) s)))
3157
3158 (if (not
3159   (and
3160     (def-static 'foobar (fn (x) (+ x x)))
3161     (= foobar:foobar (lambda (foobar:x) (+ foobar:x foobar:x)))
3162     (= (foobar 10) 20)))
3163   (QA:failed ">>>>> problem with static default function definition"))
3164
3165 ;; calling into context changes context
3166 (if (not TST:test-context-change)
3167   (QA:failed ">>>>> problem changing runtime context with symbol"))
3168
3169 ;; but calling with raw lambda doesn't
3170 (if ((eval TST:test-context-change))
3171   (QA:failed ">>>>> problem maintaining runtime context with lambda"))
3172
3173 ;; apply evaluates functor
3174 (if (not (apply 'TST:test-context-change))
3175   (QA:failed ">>>>> problem changing runtime context with apply symbol"))
3176
3177 ;; apply evaluates functor
3178 (if (apply TST:test-context-change)
3179   (QA:failed ">>>>> problem maintaining runtime context with apply lambda"))
3180
3181 ;; map evaluates functor
3182 (if (!= (map 'TST:test-context-change '(a b c)) '(true true true))
3183   (QA:failed ">>>>> problem changing runtime context with map symbol"))
3184
3185 ;; map evaluates functor
3186 (if (!= (map TST:test-context-change '(a b c)) '(nil nil nil))
3187   (QA:failed ">>>>> problem maintaining runtime context with map lambda"))
3188
3189
3190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3191
3192 (println)>
3193 (if QA:failed-messages
3194   (begin
3195     (println "TESTING: " (main-args 0) " FINISHED WITH ERRORS:")
3196     (println)
3197     (dolist (func (reverse QA:failed-messages))
3198         (println func)))
3199   (println "ALL FUNCTIONS FINISHED SUCCESSFULL: " (main-args 0)))
3200
3201 (println)
3202 (delete-file "sharetest.lsp")
3203 (delete-file "udptest.lsp")
3204 (println "total time: " (- (time-of-day) start-of-qa))
3205 (exit)
3206 ;; eof
3207
3208