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