~ chicken-core (master) /tests/r7rs-tests.scm

  1;; R7RS Tests
  2
  3(import (only (chicken port) with-input-from-string with-output-to-string)
  4	(chicken condition) (scheme lazy))
  5
  6;; Copied from R4RS tests
  7(define cur-section '())
  8
  9(define errs '())
 10
 11(define (SECTION . args)
 12  (newline)
 13  (write (cons 'SECTION args))
 14  (newline)
 15  (newline)
 16  (set! cur-section args) #t)
 17
 18(define (record-error e)
 19  (set! errs (cons (list cur-section e) errs)))
 20
 21(define (test expect fun . args)
 22  (write (cons fun args))
 23  (display "  ==> ")
 24  (let ((res (if (procedure? fun) (apply fun args) (car args))))
 25    (write res)
 26    (newline)
 27    (if (equal? expect res)
 28        #t
 29        (begin
 30          (record-error (list res expect (cons fun args)))
 31          (display " BUT EXPECTED ")
 32          (write expect)
 33          (newline)
 34          #f))))
 35
 36(define (test-error expected? fun . args)
 37  (write (cons fun args))
 38  (newline)
 39  (handle-exceptions exn
 40    (or (expected? exn)
 41        (begin
 42          (record-error (list exn expected? (cons fun args)))
 43          (display " EXPECTED A DIFFERENT ERROR")
 44          (newline)
 45          #f))
 46    (apply fun args)
 47    (display " EXPECTED AN ERROR BUT DIDN'T GET ONE")
 48    #f))
 49
 50(define (report-errs)
 51  (newline)
 52  (if (null? errs) (display "Passed all tests")
 53      (begin
 54	(display "errors were:")
 55	(newline)
 56	(display "(SECTION (got expected (call)))")
 57	(newline)
 58	(for-each (lambda (l) (write l) (newline))
 59		  errs)
 60        (exit 1)))
 61  (newline))
 62
 63(SECTION 4 2 1)
 64
 65;; cond clause with only <test>
 66(test 1 (lambda () (cond (1))))
 67(test 'foo (lambda () (cond ('foo))))
 68
 69;; case with => clause
 70(test "a" (lambda () (case 'a ((a) => symbol->string))))
 71(test "a" (lambda () (case 'a (else => symbol->string))))
 72(test-error condition? (lambda () (case 'a ((a) =>))))
 73(test-error condition? (lambda () (case 'a (else =>))))
 74
 75(SECTION 4 2 5)
 76
 77
 78;; make-promise test
 79(test #t promise? (make-promise 1))
 80(test #t promise? (make-promise (lambda _ 'foo)))
 81(test #t promise? (make-promise (make-promise 1)))
 82
 83(test 1 force (make-promise 1))
 84(test #t procedure? (force (make-promise (lambda _ 1))))
 85(test 1 force (make-promise (make-promise 1)))
 86
 87;; delay/force/delay-force
 88(test #t promise? (delay 1))
 89(test #t promise? (delay (delay 1)))
 90(test 1 force 1)
 91(test force force (force (delay force)))
 92
 93(test 3 force (delay (+ 1 2))) ; pp. 18
 94(let ((p (delay (+ 1 2))))
 95  (test '(3 3) list (force p) (force p)))
 96
 97(let () ; pp. 19
 98  (define integers
 99    (letrec ((next
100	      (lambda (n)
101		(delay (cons n (next (+ n 1)))))))
102      (next 0)))
103  (define head
104    (lambda (stream) (car (force stream))))
105  (define tail
106    (lambda (stream) (cdr (force stream))))
107  (test 0 head integers)
108  (test 0 head integers)
109  (test 1 head (tail integers))
110  (test 2 head (tail (tail integers))))
111
112(let () ; later on pp. 19
113  (define count 0)
114  (define p
115    (delay (begin (set! count (+ count 1))
116	     (if (> count x)
117		 count
118		 (force p)))))
119  (define x 5)
120  (test #t promise? p)
121  (test 6 force p)
122  (test #t promise? p)
123  (set! x 10)
124  (test 6 force p))
125
126(test #t promise? (delay-force 1))
127(test 1 force (delay-force 1))
128(test 6 force (delay-force (+ 1 2 3)))
129(test #t promise? (delay-force (delay 1)))
130
131;; delayed MVs
132(call-with-values
133 (lambda () (force (delay (values 1 2 3))))
134 (lambda mv (test '(1 2 3) #f mv)))
135(call-with-values
136 (lambda () (force (delay-force (values 4 5 6))))
137 (lambda mv (test '(4 5 6) #f mv)))
138(call-with-values
139 (lambda () (force (delay (values))))
140 (lambda mv (test '() #f mv)))
141
142
143(SECTION 5 3)
144
145(test '(1 2)
146      (lambda ()
147        (define-values (a b) (values 1 2))
148        (list a b)))
149
150(test '(1 (2))
151      (lambda ()
152        (define-values (a . b) (values 1 2))
153        (list a b)))
154
155(test '((1 2))
156      (lambda ()
157        (define-values a (values 1 2))
158        (list a)))
159
160(test 'ok ; Just tests that no error is thrown.
161      (lambda ()
162        (define-values () (values))
163        'ok))
164
165
166(SECTION 6 6)
167
168
169(define (integer->named-char x)
170  (with-output-to-string (lambda () (write (integer->char x)))))
171
172(test "#\\alarm" integer->named-char #x07)
173(test "#\\backspace" integer->named-char #x08)
174(test "#\\delete" integer->named-char #x7f)
175(test "#\\escape" integer->named-char #x1b)
176(test "#\\newline" integer->named-char #x0a)
177(test "#\\null" integer->named-char #x00)
178(test "#\\return" integer->named-char #x0d)
179(test "#\\space" integer->named-char #x20)
180(test "#\\tab" integer->named-char #x09)
181
182
183
184(SECTION 6 7)
185
186
187;; We try to avoid using the very constructs that we are testing here,
188;; hence the slightly cumbersome string construction of <x> -> "\"\\<x>\""
189(define (read-escaped-string x)
190  (with-input-from-string (string-append (string #\" #\\) x (string #\"))
191    read))
192(define (escaped-char x)
193  (string-ref (read-escaped-string x) 0))
194
195(test #\alarm escaped-char "a")
196(test #\backspace escaped-char "b")
197(test #\tab escaped-char "t")
198(test #\newline escaped-char "n")
199(test #\return escaped-char "r")
200(test #\" escaped-char "\"")
201(test #\\ escaped-char "\\")
202(test #\| escaped-char "|")
203;; *ONE* line ending following a backslash escape, along with any
204;; preceding or trailing intraline whitespace is collapsed and ignored.
205(test #\E escaped-char (string-append (string #\newline) "       END"))
206;; This also works with CR instead of LF...
207(test #\E escaped-char (string-append (string #\return) "       END"))
208;; And CRLF, too
209(test #\E escaped-char (string-append (string #\return) (string #\newline) "       END"))
210(test #\E escaped-char (string-append "    " (string #\newline) "END"))
211(test #\E escaped-char (string-append "    " (string #\newline) "END"))
212(test #\E escaped-char (string-append "     " (string #\newline) "   END"))
213;; But not more than one!
214(test #\newline escaped-char (string-append "     " (string #\newline) "    " (string #\newline) " END"))
215;; CR and LF both counted
216(test #\newline escaped-char (string-append "     " (string #\return) "    " (string #\newline) " END"))
217;; Tabs count as intraline whitespace too
218(test #\E escaped-char (string-append (string #\tab) (string #\newline) (string #\tab) "   END"))
219;; Edge case
220(test "" read-escaped-string (string-append "    " (string #\newline) "    "))
221
222(test #\tab escaped-char "x9;")
223(test #\tab escaped-char "x09;")
224
225
226
227(SECTION 6 8)
228
229;; Symbols are implicitly quoted inside self-evaluating vectors.
230;; This is not as clear from draft 9 as it could be.
231(test '#(0 (2 2 2 2) "Anna") #f #(0 (2 2 2 2) "Anna"))
232(test #t vector? '#(0 (a b) c))
233(test #t vector? #(0 (a b) c))
234(test '#(0 (a b) c d #(1 2 (e) f) g) #f #(0 (a b) c d #(1 2 (e) f) g))
235
236(report-errs)