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