home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / packs / skeem / test.scm < prev    next >
Text File  |  2000-07-29  |  28KB  |  980 lines
  1. ;;;; `test.scm' Test correctness of scheme implementations.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
  3.  
  4. ;;; This includes examples from
  5. ;;; William Clinger and Jonathan Rees, editors.
  6. ;;; Revised^4 Report on the Algorithmic Language Scheme
  7. ;;; and the IEEE specification.
  8.  
  9. ;;; The input tests read this file expecting it to be named "test.scm".
  10. ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
  11. ;;; these tests.  You may need to delete them in order to run
  12. ;;; "test.scm" more than once.
  13.  
  14. ;;;   There are three optional tests:
  15. ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
  16. ;;; 
  17. ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
  18. ;;; 
  19. ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
  20. ;;;   either standard.
  21.  
  22. ;;; If you are testing a R3RS version which does not have `list?' do:
  23. ;;; (define list? #f)
  24.  
  25. ;;; send corrections or additions to jaffer@ai.mit.edu or
  26. ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
  27.  
  28. (define cur-section '())(define errs '())
  29. (define SECTION (lambda args
  30.           (display "SECTION") (write args) (newline)
  31.           (set! cur-section args) #t))
  32. (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
  33.  
  34. (define test
  35.   (lambda (expect fun . args)
  36.     (write (cons fun args))
  37.     (display "  ==> ")
  38.     ((lambda (res)
  39.       (write res)
  40.       (newline)
  41.       (cond ((not (equal? expect res))
  42.          (record-error (list res expect (cons fun args)))
  43.          (display " BUT EXPECTED ")
  44.          (write expect)
  45.          (newline)
  46.          #f)
  47.         (else #t)))
  48.      (if (procedure? fun) (apply fun args) (car args)))))
  49. (define (report-errs)
  50.   (newline)
  51.   (if (null? errs) (display "Passed all tests")
  52.       (begin
  53.     (display "errors were:")
  54.     (newline)
  55.     (display "(SECTION (got expected (call)))")
  56.     (newline)
  57.     (for-each (lambda (l) (write l) (newline))
  58.           errs)))
  59.   (newline))
  60.  
  61. (SECTION 2 1);; test that all symbol characters are supported.
  62. '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
  63.  
  64. (SECTION 3 4)
  65. (define disjoint-type-functions
  66.   (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
  67. (define type-examples
  68.   (list
  69.    #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
  70. (define i 1)
  71. (for-each (lambda (x) (display (make-string i #\ ))
  72.           (set! i (+ 3 i))
  73.           (write x)
  74.           (newline))
  75.       disjoint-type-functions)
  76. (define type-matrix
  77.   (map (lambda (x)
  78.      (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
  79.        (write t)
  80.        (write x)
  81.        (newline)
  82.        t))
  83.        type-examples))
  84. (SECTION 4 1 2)
  85. (test '(quote a) 'quote (quote 'a))
  86. (test '(quote a) 'quote ''a)
  87. (SECTION 4 1 3)
  88. (test 12 (if #f + *) 3 4)
  89. (SECTION 4 1 4)
  90. (test 8 (lambda (x) (+ x x)) 4)
  91. (define reverse-subtract
  92.   (lambda (x y) (- y x)))
  93. (test 3 reverse-subtract 7 10)
  94. (define add4
  95.   (let ((x 4))
  96.     (lambda (y) (+ x y))))
  97. (test 10 add4 6)
  98. (test '(3 4 5 6) (lambda x x) 3 4 5 6)
  99. (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
  100. (SECTION 4 1 5)
  101. (test 'yes 'if (if (> 3 2) 'yes 'no))
  102. (test 'no 'if (if (> 2 3) 'yes 'no))
  103. (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
  104. (SECTION 4 1 6)
  105. (define x 2)
  106. (test 3 'define (+ x 1))
  107. (set! x 4)
  108. (test 5 'set! (+ x 1))
  109. (SECTION 4 2 1)
  110. (test 'greater 'cond (cond ((> 3 2) 'greater)
  111.                ((< 3 2) 'less)))
  112. (test 'equal 'cond (cond ((> 3 3) 'greater)
  113.              ((< 3 3) 'less)
  114.              (else 'equal)))
  115. (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
  116.              (else #f)))
  117. (test 'composite 'case (case (* 2 3)
  118.              ((2 3 5 7) 'prime)
  119.              ((1 4 6 8 9) 'composite)))
  120. (test 'consonant 'case (case (car '(c d))
  121.              ((a e i o u) 'vowel)
  122.              ((w y) 'semivowel)
  123.              (else 'consonant)))
  124. (test #t 'and (and (= 2 2) (> 2 1)))
  125. (test #f 'and (and (= 2 2) (< 2 1)))
  126. (test '(f g) 'and (and 1 2 'c '(f g)))
  127. (test #t 'and (and))
  128. (test #t 'or (or (= 2 2) (> 2 1)))
  129. (test #t 'or (or (= 2 2) (< 2 1)))
  130. (test #f 'or (or #f #f #f))
  131. (test #f 'or (or))
  132. (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
  133. (SECTION 4 2 2)
  134. (test 6 'let (let ((x 2) (y 3)) (* x y)))
  135. (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
  136. (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
  137. (test #t 'letrec (letrec ((even?
  138.                (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
  139.               (odd?
  140.                (lambda (n) (if (zero? n) #f (even? (- n 1))))))
  141.            (even? 88)))
  142. (define x 34)
  143. (test 5 'let (let ((x 3)) (define x 5) x))
  144. (test 34 'let x)
  145. (test 6 'let (let () (define x 6) x))
  146. (test 34 'let x)
  147. (test 7 'let* (let* ((x 3)) (define x 7) x))
  148. (test 34 'let* x)
  149. (test 8 'let* (let* () (define x 8) x))
  150. (test 34 'let* x)
  151. (test 9 'letrec (letrec () (define x 9) x))
  152. (test 34 'letrec x)
  153. (test 10 'letrec (letrec ((x 3)) (define x 10) x))
  154. (test 34 'letrec x)
  155. (SECTION 4 2 3)
  156. (define x 0)
  157. (test 6 'begin (begin (set! x 5) (+ x 1)))
  158. (SECTION 4 2 4)
  159. (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
  160.                 (i 0 (+ i 1)))
  161.                ((= i 5) vec)
  162.              (vector-set! vec i i)))
  163. (test 25 'do (let ((x '(1 3 5 7 9)))
  164.            (do ((x x (cdr x))
  165.             (sum 0 (+ sum (car x))))
  166.            ((null? x) sum))))
  167. (test 1 'let (let foo () 1))
  168. (test '((6 1 3) (-5 -2)) 'let
  169.       (let loop ((numbers '(3 -2 1 6 -5))
  170.          (nonneg '())
  171.          (neg '()))
  172.     (cond ((null? numbers) (list nonneg neg))
  173.           ((negative? (car numbers))
  174.            (loop (cdr numbers)
  175.              nonneg
  176.              (cons (car numbers) neg)))
  177.           (else
  178.            (loop (cdr numbers)
  179.              (cons (car numbers) nonneg)
  180.              neg)))))
  181. (SECTION 4 2 6)
  182. (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
  183. (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
  184. (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
  185. (test '((foo 7) . cons)
  186.     'quasiquote
  187.     `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
  188.  
  189. ;;; sqt is defined here because not all implementations are required to
  190. ;;; support it. 
  191. (define (sqt x)
  192.     (do ((i 0 (+ i 1)))
  193.         ((> (* i i) x) (- i 1))))
  194.  
  195. (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
  196. (test 5 'quasiquote `,(+ 2 3))
  197. (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
  198.       'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
  199. (test '(a `(b ,x ,'y d) e) 'quasiquote
  200.     (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
  201. (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
  202. (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
  203. (SECTION 5 2 1)
  204. (define add3 (lambda (x) (+ x 3)))
  205. (test 6 'define (add3 3))
  206. (define first car)
  207. (test 1 'define (first '(1 2)))
  208. (SECTION 5 2 2)
  209. (test 45 'define
  210.     (let ((x 5))
  211.         (define foo (lambda (y) (bar x y)))
  212.         (define bar (lambda (a b) (+ (* a b) a)))
  213.         (foo (+ x 3))))
  214. (define x 34)
  215. (define (foo) (define x 5) x)
  216. (test 5 foo)
  217. (test 34 'define x)
  218. (define foo (lambda () (define x 5) x))
  219. (test 5 foo)
  220. (test 34 'define x)
  221. (define (foo x) ((lambda () (define x 5) x)) x)
  222. (test 88 foo 88)
  223. (test 4 foo 4)
  224. (test 34 'define x)
  225. (SECTION 6 1)
  226. (test #f not #t)
  227. (test #f not 3)
  228. (test #f not (list 3))
  229. (test #t not #f)
  230. (test #f not '())
  231. (test #f not (list))
  232. (test #f not 'nil)
  233.  
  234. (test #t boolean? #f)
  235. (test #f boolean? 0)
  236. (test #f boolean? '())
  237. (SECTION 6 2)
  238. (test #t eqv? 'a 'a)
  239. (test #f eqv? 'a 'b)
  240. (test #t eqv? 2 2)
  241. (test #t eqv? '() '())
  242. (test #t eqv? '10000 '10000)
  243. (test #f eqv? (cons 1 2)(cons 1 2))
  244. (test #f eqv? (lambda () 1) (lambda () 2))
  245. (test #f eqv? #f 'nil)
  246. (let ((p (lambda (x) x)))
  247.   (test #t eqv? p p))
  248. (define gen-counter
  249.  (lambda ()
  250.    (let ((n 0))
  251.       (lambda () (set! n (+ n 1)) n))))
  252. (let ((g (gen-counter))) (test #t eqv? g g))
  253. (test #f eqv? (gen-counter) (gen-counter))
  254. (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
  255.      (g (lambda () (if (eqv? f g) 'g 'both))))
  256.   (test #f eqv? f g))
  257.  
  258. (test #t eq? 'a 'a)
  259. (test #f eq? (list 'a) (list 'a))
  260. (test #t eq? '() '())
  261. (test #t eq? car car)
  262. (let ((x '(a))) (test #t eq? x x))
  263. (let ((x '#())) (test #t eq? x x))
  264. (let ((x (lambda (x) x))) (test #t eq? x x))
  265.  
  266. (test #t equal? 'a 'a)
  267. (test #t equal? '(a) '(a))
  268. (test #t equal? '(a (b) c) '(a (b) c))
  269. (test #t equal? "abc" "abc")
  270. (test #t equal? 2 2)
  271. (test #t equal? (make-vector 5 'a) (make-vector 5 'a))
  272. (SECTION 6 3)
  273. (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
  274. (define x (list 'a 'b 'c))
  275. (define y x)
  276. (and list? (test #t list? y))
  277. (set-cdr! x 4)
  278. (test '(a . 4) 'set-cdr! x)
  279. (test #t eqv? x y)
  280. (test '(a b c . d) 'dot '(a . (b . (c . d))))
  281. (and list? (test #f list? y))
  282. (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
  283.  
  284. (test #t pair? '(a . b))
  285. (test #t pair? '(a . 1))
  286. (test #t pair? '(a b c))
  287. (test #f pair? '())
  288. (test #f pair? '#(a b))
  289.  
  290. (test '(a) cons 'a '())
  291. (test '((a) b c d) cons '(a) '(b c d))
  292. (test '("a" b c) cons "a" '(b c))
  293. (test '(a . 3) cons 'a 3)
  294. (test '((a b) . c) cons '(a b) 'c)
  295.  
  296. (test 'a car '(a b c))
  297. (test '(a) car '((a) b c d))
  298. (test 1 car '(1 . 2))
  299.  
  300. (test '(b c d) cdr '((a) b c d))
  301. (test 2 cdr '(1 . 2))
  302.  
  303. (test '(a 7 c) list 'a (+ 3 4) 'c)
  304. (test '() list)
  305.  
  306. (test 3 length '(a b c))
  307. (test 3 length '(a (b) (c d e)))
  308. (test 0 length '())
  309.  
  310. (test '(x y) append '(x) '(y))
  311. (test '(a b c d) append '(a) '(b c d))
  312. (test '(a (b) (c)) append '(a (b)) '((c)))
  313. (test '() append)
  314. (test '(a b c . d) append '(a b) '(c . d))
  315. (test 'a append '() 'a)
  316.  
  317. (test '(c b a) reverse '(a b c))
  318. (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
  319.  
  320. (test 'c list-ref '(a b c d) 2)
  321.  
  322. (test '(a b c) memq 'a '(a b c))
  323. (test '(b c) memq 'b '(a b c))
  324. (test '#f memq 'a '(b c d))
  325. (test '#f memq (list 'a) '(b (a) c))
  326. (test '((a) c) member (list 'a) '(b (a) c))
  327. (test '(101 102) memv 101 '(100 101 102))
  328.  
  329. (define e '((a 1) (b 2) (c 3)))
  330. (test '(a 1) assq 'a e)
  331. (test '(b 2) assq 'b e)
  332. (test #f assq 'd e)
  333. (test #f assq (list 'a) '(((a)) ((b)) ((c))))
  334. (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
  335. (test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
  336. (SECTION 6 4)
  337. (test #t symbol? 'foo)
  338. (test #t symbol? (car '(a b)))
  339. (test #f symbol? "bar")
  340. (test #t symbol? 'nil)
  341. (test #f symbol? '())
  342. (test #f symbol? #f)
  343. ;;; But first, what case are symbols in?  Determine the standard case:
  344. (define char-standard-case char-upcase)
  345. (if (string=? (symbol->string 'A) "a")
  346.     (set! char-standard-case char-downcase))
  347. (test #t 'standard-case
  348.       (string=? (symbol->string 'a) (symbol->string 'A)))
  349. (test #t 'standard-case
  350.       (or (string=? (symbol->string 'a) "A")
  351.       (string=? (symbol->string 'A) "a")))
  352. (define (str-copy s)
  353.   (let ((v (make-string (string-length s))))
  354.     (do ((i (- (string-length v) 1) (- i 1)))
  355.     ((< i 0) v)
  356.       (string-set! v i (string-ref s i)))))
  357. (define (string-standard-case s)
  358.   (set! s (str-copy s))
  359.   (do ((i 0 (+ 1 i))
  360.        (sl (string-length s)))
  361.       ((>= i sl) s)
  362.       (string-set! s i (char-standard-case (string-ref s i)))))
  363. (test (string-standard-case "flying-fish") symbol->string 'flying-fish)
  364. (test (string-standard-case "martin") symbol->string 'Martin)
  365. (test "Malvina" symbol->string (string->symbol "Malvina"))
  366. (test #t 'standard-case (eq? 'a 'A))
  367.  
  368. (define x (string #\a #\b))
  369. (define y (string->symbol x))
  370. (string-set! x 0 #\c)
  371. (test "cb" 'string-set! x)
  372. (test "ab" symbol->string y)
  373. (test y string->symbol "ab")
  374.  
  375. (test #t eq? 'mISSISSIppi 'mississippi)
  376. (test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
  377. (test 'JollyWog string->symbol (symbol->string 'JollyWog))
  378.  
  379. (SECTION 6 5 5)
  380. (test #t number? 3)
  381. (test #t complex? 3)
  382. (test #t real? 3)
  383. (test #t rational? 3)
  384. (test #t integer? 3)
  385.  
  386. (test #t exact? 3)
  387. (test #f inexact? 3)
  388.  
  389. (test #t = 22 22 22)
  390. (test #t = 22 22)
  391. (test #f = 34 34 35)
  392. (test #f = 34 35)
  393. (test #t > 3 -6246)
  394. (test #f > 9 9 -2424)
  395. (test #t >= 3 -4 -6246)
  396. (test #t >= 9 9)
  397. (test #f >= 8 9)
  398. (test #t < -1 2 3 4 5 6 7 8)
  399. (test #f < -1 2 3 4 4 5 6 7)
  400. (test #t <= -1 2 3 4 5 6 7 8)
  401. (test #t <= -1 2 3 4 4 5 6 7)
  402. (test #f < 1 3 2)
  403. (test #f >= 1 3 2)
  404.  
  405. (test #t zero? 0)
  406. (test #f zero? 1)
  407. (test #f zero? -1)
  408. (test #f zero? -100)
  409. (test #t positive? 4)
  410. (test #f positive? -4)
  411. (test #f positive? 0)
  412. (test #f negative? 4)
  413. (test #t negative? -4)
  414. (test #f negative? 0)
  415. (test #t odd? 3)
  416. (test #f odd? 2)
  417. (test #f odd? -4)
  418. (test #t odd? -1)
  419. (test #f even? 3)
  420. (test #t even? 2)
  421. (test #t even? -4)
  422. (test #f even? -1)
  423.  
  424. (test 38 max 34 5 7 38 6)
  425. (test -24 min 3  5 5 330 4 -24)
  426.  
  427. (test 7 + 3 4)
  428. (test '3 + 3)
  429. (test 0 +)
  430. (test 4 * 4)
  431. (test 1 *)
  432.  
  433. (test -1 - 3 4)
  434. (test -3 - 3)
  435. (test 7 abs -7)
  436. (test 7 abs 7)
  437. (test 0 abs 0)
  438.  
  439. (test 5 quotient 35 7)
  440. (test -5 quotient -35 7)
  441. (test -5 quotient 35 -7)
  442. (test 5 quotient -35 -7)
  443. (test 1 modulo 13 4)
  444. (test 1 remainder 13 4)
  445. (test 3 modulo -13 4)
  446. (test -1 remainder -13 4)
  447. (test -3 modulo 13 -4)
  448. (test 1 remainder 13 -4)
  449. (test -1 modulo -13 -4)
  450. (test -1 remainder -13 -4)
  451. (define (divtest n1 n2)
  452.     (= n1 (+ (* n2 (quotient n1 n2))
  453.          (remainder n1 n2))))
  454. (test #t divtest 238 9)
  455. (test #t divtest -238 9)
  456. (test #t divtest 238 -9)
  457. (test #t divtest -238 -9)
  458.  
  459. (test 4 gcd 0 4)
  460. (test 4 gcd -4 0)
  461. (test 4 gcd 32 -36)
  462. (test 0 gcd)
  463. (test 288 lcm 32 -36)
  464. (test 1 lcm)
  465.  
  466. ;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
  467. ;;; Modified by jaffer.
  468. (define (test-inexact)
  469.   (define f3.9 (string->number "3.9"))
  470.   (define f4.0 (string->number "4.0"))
  471.   (define f-3.25 (string->number "-3.25"))
  472.   (define f.25 (string->number ".25"))
  473.   (define f4.5 (string->number "4.5"))
  474.   (define f3.5 (string->number "3.5"))
  475.   (define f0.0 (string->number "0.0"))
  476.   (define f0.8 (string->number "0.8"))
  477.   (define f1.0 (string->number "1.0"))
  478.   (define wto write-test-obj)
  479.   (define dto display-test-obj)
  480.   (define lto load-test-obj)
  481.   (newline)
  482.   (display ";testing inexact numbers; ")
  483.   (newline)
  484.   (SECTION 6 5 5)
  485.   (test #t inexact? f3.9)
  486.   (test #t 'inexact? (inexact? (max f3.9 4)))
  487.   (test f4.0 'max (max f3.9 4))
  488.   (test f4.0 'exact->inexact (exact->inexact 4))
  489.   (test (- f4.0) round (- f4.5))
  490.   (test (- f4.0) round (- f3.5))
  491.   (test (- f4.0) round (- f3.9))
  492.   (test f0.0 round f0.0)
  493.   (test f0.0 round f.25)
  494.   (test f1.0 round f0.8)
  495.   (test f4.0 round f3.5)
  496.   (test f4.0 round f4.5)
  497.   (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
  498.   (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
  499.   (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
  500.   (test #t call-with-output-file
  501.       "tmp3"
  502.       (lambda (test-file)
  503.     (write-char #\; test-file)
  504.     (display write-test-obj test-file)
  505.     (newline test-file)
  506.     (write load-test-obj test-file)
  507.     (output-port? test-file)))
  508.   (check-test-file "tmp3")
  509.   (set! write-test-obj wto)
  510.   (set! display-test-obj dto)
  511.   (set! load-test-obj lto)
  512.   (let ((x (string->number "4195835.0"))
  513.     (y (string->number "3145727.0")))
  514.     (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
  515.   (report-errs))
  516.  
  517. (define (test-bignum)
  518.   (define tb
  519.     (lambda (n1 n2)
  520.       (= n1 (+ (* n2 (quotient n1 n2))
  521.            (remainder n1 n2)))))
  522.   (newline)
  523.   (display ";testing bignums; ")
  524.   (newline)
  525.   (section 6 5 5)
  526.   (test 0 modulo -2177452800 86400)
  527.   (test 0 modulo 2177452800 -86400)
  528.   (test 0 modulo 2177452800 86400)
  529.   (test 0 modulo -2177452800 -86400)
  530.   (test #t 'remainder (tb 281474976710655 65535))
  531.   (test #t 'remainder (tb 281474976710654 65535))
  532.   (SECTION 6 5 6)
  533.   (test 281474976710655 string->number "281474976710655")
  534.   (test "281474976710655" number->string 281474976710655)
  535.   (report-errs))
  536.  
  537. (SECTION 6 5 6)
  538. (test "0" number->string 0)
  539. (test "100" number->string 100)
  540. (test "100" number->string 256 16)
  541. (test 100 string->number "100")
  542. (test 256 string->number "100" 16)
  543. (test #f string->number "")
  544. (test #f string->number ".")
  545. (test #f string->number "d")
  546. (test #f string->number "D")
  547. (test #f string->number "i")
  548. (test #f string->number "I")
  549. (test #f string->number "3i")
  550. (test #f string->number "3I")
  551. (test #f string->number "33i")
  552. (test #f string->number "33I")
  553. (test #f string->number "3.3i")
  554. (test #f string->number "3.3I")
  555. (test #f string->number "-")
  556. (test #f string->number "+")
  557.  
  558. (SECTION 6 6)
  559. (test #t eqv? '#\  #\Space)
  560. (test #t eqv? #\space '#\Space)
  561. (test #t char? #\a)
  562. (test #t char? #\()
  563. (test #t char? #\ )
  564. (test #t char? '#\newline)
  565.  
  566. (test #f char=? #\A #\B)
  567. (test #f char=? #\a #\b)
  568. (test #f char=? #\9 #\0)
  569. (test #t char=? #\A #\A)
  570.  
  571. (test #t char<? #\A #\B)
  572. (test #t char<? #\a #\b)
  573. (test #f char<? #\9 #\0)
  574. (test #f char<? #\A #\A)
  575.  
  576. (test #f char>? #\A #\B)
  577. (test #f char>? #\a #\b)
  578. (test #t char>? #\9 #\0)
  579. (test #f char>? #\A #\A)
  580.  
  581. (test #t char<=? #\A #\B)
  582. (test #t char<=? #\a #\b)
  583. (test #f char<=? #\9 #\0)
  584. (test #t char<=? #\A #\A)
  585.  
  586. (test #f char>=? #\A #\B)
  587. (test #f char>=? #\a #\b)
  588. (test #t char>=? #\9 #\0)
  589. (test #t char>=? #\A #\A)
  590.  
  591. (test #f char-ci=? #\A #\B)
  592. (test #f char-ci=? #\a #\B)
  593. (test #f char-ci=? #\A #\b)
  594. (test #f char-ci=? #\a #\b)
  595. (test #f char-ci=? #\9 #\0)
  596. (test #t char-ci=? #\A #\A)
  597. (test #t char-ci=? #\A #\a)
  598.  
  599. (test #t char-ci<? #\A #\B)
  600. (test #t char-ci<? #\a #\B)
  601. (test #t char-ci<? #\A #\b)
  602. (test #t char-ci<? #\a #\b)
  603. (test #f char-ci<? #\9 #\0)
  604. (test #f char-ci<? #\A #\A)
  605. (test #f char-ci<? #\A #\a)
  606.  
  607. (test #f char-ci>? #\A #\B)
  608. (test #f char-ci>? #\a #\B)
  609. (test #f char-ci>? #\A #\b)
  610. (test #f char-ci>? #\a #\b)
  611. (test #t char-ci>? #\9 #\0)
  612. (test #f char-ci>? #\A #\A)
  613. (test #f char-ci>? #\A #\a)
  614.  
  615. (test #t char-ci<=? #\A #\B)
  616. (test #t char-ci<=? #\a #\B)
  617. (test #t char-ci<=? #\A #\b)
  618. (test #t char-ci<=? #\a #\b)
  619. (test #f char-ci<=? #\9 #\0)
  620. (test #t char-ci<=? #\A #\A)
  621. (test #t char-ci<=? #\A #\a)
  622.  
  623. (test #f char-ci>=? #\A #\B)
  624. (test #f char-ci>=? #\a #\B)
  625. (test #f char-ci>=? #\A #\b)
  626. (test #f char-ci>=? #\a #\b)
  627. (test #t char-ci>=? #\9 #\0)
  628. (test #t char-ci>=? #\A #\A)
  629. (test #t char-ci>=? #\A #\a)
  630.  
  631. (test #t char-alphabetic? #\a)
  632. (test #t char-alphabetic? #\A)
  633. (test #t char-alphabetic? #\z)
  634. (test #t char-alphabetic? #\Z)
  635. (test #f char-alphabetic? #\0)
  636. (test #f char-alphabetic? #\9)
  637. (test #f char-alphabetic? #\space)
  638. (test #f char-alphabetic? #\;)
  639.  
  640. (test #f char-numeric? #\a)
  641. (test #f char-numeric? #\A)
  642. (test #f char-numeric? #\z)
  643. (test #f char-numeric? #\Z)
  644. (test #t char-numeric? #\0)
  645. (test #t char-numeric? #\9)
  646. (test #f char-numeric? #\space)
  647. (test #f char-numeric? #\;)
  648.  
  649. (test #f char-whitespace? #\a)
  650. (test #f char-whitespace? #\A)
  651. (test #f char-whitespace? #\z)
  652. (test #f char-whitespace? #\Z)
  653. (test #f char-whitespace? #\0)
  654. (test #f char-whitespace? #\9)
  655. (test #t char-whitespace? #\space)
  656. (test #f char-whitespace? #\;)
  657.  
  658. (test #f char-upper-case? #\0)
  659. (test #f char-upper-case? #\9)
  660. (test #f char-upper-case? #\space)
  661. (test #f char-upper-case? #\;)
  662.  
  663. (test #f char-lower-case? #\0)
  664. (test #f char-lower-case? #\9)
  665. (test #f char-lower-case? #\space)
  666. (test #f char-lower-case? #\;)
  667.  
  668. (test #\. integer->char (char->integer #\.))
  669. (test #\A integer->char (char->integer #\A))
  670. (test #\a integer->char (char->integer #\a))
  671. (test #\A char-upcase #\A)
  672. (test #\A char-upcase #\a)
  673. (test #\a char-downcase #\A)
  674. (test #\a char-downcase #\a)
  675. (SECTION 6 7)
  676. (test #t string? "The word \"recursion\\\" has many meanings.")
  677. (test #t string? "")
  678. (define f (make-string 3 #\*))
  679. (test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
  680. (test "abc" string #\a #\b #\c)
  681. (test "" string)
  682. (test 3 string-length "abc")
  683. (test #\a string-ref "abc" 0)
  684. (test #\c string-ref "abc" 2)
  685. (test 0 string-length "")
  686. (test "" substring "ab" 0 0)
  687. (test "" substring "ab" 1 1)
  688. (test "" substring "ab" 2 2)
  689. (test "a" substring "ab" 0 1)
  690. (test "b" substring "ab" 1 2)
  691. (test "ab" substring "ab" 0 2)
  692. (test "foobar" string-append "foo" "bar")
  693. (test "foo" string-append "foo")
  694. (test "foo" string-append "foo" "")
  695. (test "foo" string-append "" "foo")
  696. (test "" string-append)
  697. (test "" make-string 0)
  698. (test #t string=? "" "")
  699. (test #f string<? "" "")
  700. (test #f string>? "" "")
  701. (test #t string<=? "" "")
  702. (test #t string>=? "" "")
  703. (test #t string-ci=? "" "")
  704. (test #f string-ci<? "" "")
  705. (test #f string-ci>? "" "")
  706. (test #t string-ci<=? "" "")
  707. (test #t string-ci>=? "" "")
  708.  
  709. (test #f string=? "A" "B")
  710. (test #f string=? "a" "b")
  711. (test #f string=? "9" "0")
  712. (test #t string=? "A" "A")
  713.  
  714. (test #t string<? "A" "B")
  715. (test #t string<? "a" "b")
  716. (test #f string<? "9" "0")
  717. (test #f string<? "A" "A")
  718.  
  719. (test #f string>? "A" "B")
  720. (test #f string>? "a" "b")
  721. (test #t string>? "9" "0")
  722. (test #f string>? "A" "A")
  723.  
  724. (test #t string<=? "A" "B")
  725. (test #t string<=? "a" "b")
  726. (test #f string<=? "9" "0")
  727. (test #t string<=? "A" "A")
  728.  
  729. (test #f string>=? "A" "B")
  730. (test #f string>=? "a" "b")
  731. (test #t string>=? "9" "0")
  732. (test #t string>=? "A" "A")
  733.  
  734. (test #f string-ci=? "A" "B")
  735. (test #f string-ci=? "a" "B")
  736. (test #f string-ci=? "A" "b")
  737. (test #f string-ci=? "a" "b")
  738. (test #f string-ci=? "9" "0")
  739. (test #t string-ci=? "A" "A")
  740. (test #t string-ci=? "A" "a")
  741.  
  742. (test #t string-ci<? "A" "B")
  743. (test #t string-ci<? "a" "B")
  744. (test #t string-ci<? "A" "b")
  745. (test #t string-ci<? "a" "b")
  746. (test #f string-ci<? "9" "0")
  747. (test #f string-ci<? "A" "A")
  748. (test #f string-ci<? "A" "a")
  749.  
  750. (test #f string-ci>? "A" "B")
  751. (test #f string-ci>? "a" "B")
  752. (test #f string-ci>? "A" "b")
  753. (test #f string-ci>? "a" "b")
  754. (test #t string-ci>? "9" "0")
  755. (test #f string-ci>? "A" "A")
  756. (test #f string-ci>? "A" "a")
  757.  
  758. (test #t string-ci<=? "A" "B")
  759. (test #t string-ci<=? "a" "B")
  760. (test #t string-ci<=? "A" "b")
  761. (test #t string-ci<=? "a" "b")
  762. (test #f string-ci<=? "9" "0")
  763. (test #t string-ci<=? "A" "A")
  764. (test #t string-ci<=? "A" "a")
  765.  
  766. (test #f string-ci>=? "A" "B")
  767. (test #f string-ci>=? "a" "B")
  768. (test #f string-ci>=? "A" "b")
  769. (test #f string-ci>=? "a" "b")
  770. (test #t string-ci>=? "9" "0")
  771. (test #t string-ci>=? "A" "A")
  772. (test #t string-ci>=? "A" "a")
  773. (SECTION 6 8)
  774. (test #t vector? '#(0 (2 2 2 2) "Anna"))
  775. (test #t vector? '#())
  776. (test '#(a b c) vector 'a 'b 'c)
  777. (test '#() vector)
  778. (test 3 vector-length '#(0 (2 2 2 2) "Anna"))
  779. (test 0 vector-length '#())
  780. (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
  781. (test '#(0 ("Sue" "Sue") "Anna") 'vector-set
  782.     (let ((vec (vector 0 '(2 2 2 2) "Anna")))
  783.       (vector-set! vec 1 '("Sue" "Sue"))
  784.       vec))
  785. (test '#(hi hi) make-vector 2 'hi)
  786. (test '#() make-vector 0)
  787. (test '#() make-vector 0 'a)
  788. (SECTION 6 9)
  789. (test #t procedure? car)
  790. (test #f procedure? 'car)
  791. (test #t procedure? (lambda (x) (* x x)))
  792. (test #f procedure? '(lambda (x) (* x x)))
  793. (test #t call-with-current-continuation procedure?)
  794. (test 7 apply + (list 3 4))
  795. (test 7 apply (lambda (a b) (+ a b)) (list 3 4))
  796. (test 17 apply + 10 (list 3 4))
  797. (test '() apply list '())
  798. (define compose (lambda (f g) (lambda args (f (apply g args)))))
  799. (test 30 (compose sqt *) 12 75)
  800.  
  801. (test '(b e h) map cadr '((a b) (d e) (g h)))
  802. (test '(5 7 9) map + '(1 2 3) '(4 5 6))
  803. (test '#(0 1 4 9 16) 'for-each
  804.     (let ((v (make-vector 5)))
  805.         (for-each (lambda (i) (vector-set! v i (* i i)))
  806.             '(0 1 2 3 4))
  807.         v))
  808. (test -3 call-with-current-continuation
  809.         (lambda (exit)
  810.          (for-each (lambda (x) (if (negative? x) (exit x)))
  811.              '(54 0 37 -3 245 19))
  812.         #t))
  813. (define list-length
  814.  (lambda (obj)
  815.   (call-with-current-continuation
  816.    (lambda (return)
  817.     (letrec ((r (lambda (obj) (cond ((null? obj) 0)
  818.                 ((pair? obj) (+ (r (cdr obj)) 1))
  819.                 (else (return #f))))))
  820.     (r obj))))))
  821. (test 4 list-length '(1 2 3 4))
  822. (test #f list-length '(a b . c))
  823. (test '() map cadr '())
  824.  
  825. ;;; This tests full conformance of call-with-current-continuation.  It
  826. ;;; is a separate test because some schemes do not support call/cc
  827. ;;; other than escape procedures.  I am indebted to
  828. ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
  829. ;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
  830. ;;; trees constructed of conses.  
  831. (define (next-leaf-generator obj eot)
  832.   (letrec ((return #f)
  833.        (cont (lambda (x)
  834.            (recur obj)
  835.            (set! cont (lambda (x) (return eot)))
  836.            (cont #f)))
  837.        (recur (lambda (obj)
  838.               (if (pair? obj)
  839.               (for-each recur obj)
  840.               (call-with-current-continuation
  841.                (lambda (c)
  842.                  (set! cont c)
  843.                  (return obj)))))))
  844.     (lambda () (call-with-current-continuation
  845.         (lambda (ret) (set! return ret) (cont #f))))))
  846. (define (leaf-eq? x y)
  847.   (let* ((eot (list 'eot))
  848.      (xf (next-leaf-generator x eot))
  849.      (yf (next-leaf-generator y eot)))
  850.     (letrec ((loop (lambda (x y)
  851.              (cond ((not (eq? x y)) #f)
  852.                ((eq? eot x) #t)
  853.                (else (loop (xf) (yf)))))))
  854.       (loop (xf) (yf)))))
  855. (define (test-cont)
  856.   (newline)
  857.   (display ";testing continuations; ")
  858.   (newline)
  859.   (SECTION 6 9)
  860.   (test #t leaf-eq? '(a (b (c))) '((a) b c))
  861.   (test #f leaf-eq? '(a (b (c))) '((a) b c d))
  862.   (report-errs))
  863.  
  864. ;;; Test Optional R4RS DELAY syntax and FORCE procedure
  865. (define (test-delay)
  866.   (newline)
  867.   (display ";testing DELAY and FORCE; ")
  868.   (newline)
  869.   (SECTION 6 9)
  870.   (test 3 'delay (force (delay (+ 1 2))))
  871.   (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
  872.             (list (force p) (force p))))
  873.   (test 2 'delay (letrec ((a-stream
  874.                (letrec ((next (lambda (n)
  875.                         (cons n (delay (next (+ n 1)))))))
  876.                  (next 0)))
  877.               (head car)
  878.               (tail (lambda (stream) (force (cdr stream)))))
  879.            (head (tail (tail a-stream)))))
  880.   (letrec ((count 0)
  881.        (p (delay (begin (set! count (+ count 1))
  882.                 (if (> count x)
  883.                 count
  884.                 (force p)))))
  885.        (x 5))
  886.     (test 6 force p)
  887.     (set! x 10)
  888.     (test 6 force p))
  889.   (test 3 'force
  890.     (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
  891.          (c #f))
  892.       (force p)))
  893.   (report-errs))
  894.  
  895. (SECTION 6 10 1)
  896. (test #t input-port? (current-input-port))
  897. (test #t output-port? (current-output-port))
  898. (test #t call-with-input-file "test.scm" input-port?)
  899. (define this-file (open-input-file "test.scm"))
  900. (test #t input-port? this-file)
  901. (SECTION 6 10 2)
  902. (test #\; peek-char this-file)
  903. (test #\; read-char this-file)
  904. (test '(define cur-section '()) read this-file)
  905. (test #\( peek-char this-file)
  906. (test '(define errs '()) read this-file)
  907. (close-input-port this-file)
  908. (close-input-port this-file)
  909. (define (check-test-file name)
  910.   (define test-file (open-input-file name))
  911.   (test #t 'input-port?
  912.     (call-with-input-file
  913.         name
  914.       (lambda (test-file)
  915.         (test load-test-obj read test-file)
  916.         (test #t eof-object? (peek-char test-file))
  917.         (test #t eof-object? (read-char test-file))
  918.         (input-port? test-file))))
  919.   (test #\; read-char test-file)
  920.   (test display-test-obj read test-file)
  921.   (test load-test-obj read test-file)
  922.   (close-input-port test-file))
  923. (SECTION 6 10 3)
  924. (define write-test-obj
  925.   '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
  926. (define display-test-obj
  927.   '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
  928. (define load-test-obj
  929.   (list 'define 'foo (list 'quote write-test-obj)))
  930. (test #t call-with-output-file
  931.       "tmp1"
  932.       (lambda (test-file)
  933.     (write-char #\; test-file)
  934.     (display write-test-obj test-file)
  935.     (newline test-file)
  936.     (write load-test-obj test-file)
  937.     (output-port? test-file)))
  938. (check-test-file "tmp1")
  939.  
  940. (define test-file (open-output-file "tmp2"))
  941. (write-char #\; test-file)
  942. (display write-test-obj test-file)
  943. (newline test-file)
  944. (write load-test-obj test-file)
  945. (test #t output-port? test-file)
  946. (close-output-port test-file)
  947. (check-test-file "tmp2")
  948. (define (test-sc4)
  949.   (newline)
  950.   (display ";testing scheme 4 functions; ")
  951.   (newline)
  952.   (SECTION 6 7)
  953.   (test '(#\P #\space #\l) string->list "P l")
  954.   (test '() string->list "")
  955.   (test "1\\\"" list->string '(#\1 #\\ #\"))
  956.   (test "" list->string '())
  957.   (SECTION 6 8)
  958.   (test '(dah dah didah) vector->list '#(dah dah didah))
  959.   (test '() vector->list '#())
  960.   (test '#(dididit dah) list->vector '(dididit dah))
  961.   (test '#() list->vector '())
  962.   (SECTION 6 10 4)
  963.   (load "tmp1")
  964.   (test write-test-obj 'load foo)
  965.   (report-errs))
  966.  
  967. (report-errs)
  968. (if (and (string->number "0.0") (inexact? (string->number "0.0")))
  969.     (test-inexact))
  970.  
  971. (let ((n (string->number "281474976710655")))
  972.   (if (and n (exact? n))
  973.       (test-bignum)))
  974. (newline)
  975. (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
  976. (newline)
  977. (display "(test-cont) (test-sc4) (test-delay)")
  978. (newline)
  979. "last item in file"
  980.