1
;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*-
2
;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
4
;;;; This library is free software; you can redistribute it and/or
5
;;;; modify it under the terms of the GNU Lesser General Public
6
;;;; License as published by the Free Software Foundation; either
7
;;;; version 2.1 of the License, or (at your option) any later version.
9
;;;; This library is distributed in the hope that it will be useful,
10
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12
;;;; Lesser General Public License for more details.
14
;;;; You should have received a copy of the GNU Lesser General Public
15
;;;; License along with this library; if not, write to the Free Software
16
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
(define-module (test-suite test-r4rs)
19
:use-module (test-suite lib)
20
:use-module (test-suite guile-test))
23
;;;; ============= NOTE =============
25
;;;; This file is a quick-and-dirty adaptation of Aubrey's test suite
26
;;;; to Guile's testing framework. As such, it's not as clean as one
27
;;;; might hope. (In particular, it uses with-test-prefix oddly.)
29
;;;; If you're looking for an example of a test suite to imitate, you
30
;;;; might do better by looking at ports.test, which uses the
31
;;;; (test-suite lib) functions much more idiomatically.
34
;;;; "test.scm" Test correctness of scheme implementations.
35
;;;; Author: Aubrey Jaffer
36
;;;; Modified: Mikael Djurfeldt
37
;;;; Removed tests which Guile deliberately
38
;;;; won't pass. Made the the tests (test-cont), (test-sc4), and
39
;;;; (test-delay) start to run automatically.
40
;;;; Modified: Jim Blandy
41
;;;; adapted to new Guile test suite framework
43
;;; This includes examples from
44
;;; William Clinger and Jonathan Rees, editors.
45
;;; Revised^4 Report on the Algorithmic Language Scheme
46
;;; and the IEEE specification.
48
;;; The input tests read this file expecting it to be named
49
;;; "test.scm", so you'll have to run it from the ice-9 source
50
;;; directory, or copy this file elsewhere
51
;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
52
;;; these tests. You may need to delete them in order to run
53
;;; "test.scm" more than once.
55
;;; There are three optional tests:
56
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
58
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
60
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
63
;;; If you are testing a R3RS version which does not have `list?' do:
66
;;; send corrections or additions to jaffer@ai.mit.edu or
67
;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
69
;; Note: The following two expressions are being read as part of the tests in
70
;; section (6 10 2). Those tests expect that above the following two
71
;; expressions there should be only one arbitrary s-expression (which is the
72
;; define-module expression). Further, the two expressions should be written
73
;; on one single line without a blank between them. If you change this, you
74
;; will also have to change the corresponding tests in section (6 10 2).
76
(define cur-section '())(define errs '())
78
(define SECTION (lambda args
79
(set! cur-section args) #t))
80
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
81
(define (report-errs) #f)
84
(lambda (expect fun . args)
85
(let ((res (if (procedure? fun) (apply fun args) (car args))))
86
(with-test-prefix cur-section
87
(pass-if (call-with-output-string (lambda (port)
88
(write (cons fun args) port)))
89
(equal? expect res))))))
91
;; test that all symbol characters are supported.
93
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
96
(define disjoint-type-functions
97
(list boolean? char? null? number? pair? procedure? string? symbol? vector?))
100
#t #f #\a '() 9739 '(test) (lambda () #f) car "test" "" 'test
104
(let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
107
(for-each (lambda (object row)
108
(let ((count (apply + (map (lambda (elt) (if elt 1 0))
110
(pass-if (call-with-output-string
112
(display "object recognized by only one predicate: "
114
(display object port)))
120
(test '(quote a) 'quote (quote 'a))
121
(test '(quote a) 'quote ''a)
123
(test 12 (if #f + *) 3 4)
125
(test 8 (lambda (x) (+ x x)) 4)
126
(define reverse-subtract
127
(lambda (x y) (- y x)))
128
(test 3 reverse-subtract 7 10)
131
(lambda (y) (+ x y))))
133
(test '(3 4 5 6) (lambda x x) 3 4 5 6)
134
(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
136
(test 'yes 'if (if (> 3 2) 'yes 'no))
137
(test 'no 'if (if (> 2 3) 'yes 'no))
138
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
141
(test 3 'define (+ x 1))
143
(test 5 'set! (+ x 1))
145
(test 'greater 'cond (cond ((> 3 2) 'greater)
147
(test 'equal 'cond (cond ((> 3 3) 'greater)
150
(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
152
(test 'composite 'case (case (* 2 3)
154
((1 4 6 8 9) 'composite)))
155
(test 'consonant 'case (case (car '(c d))
159
(test #t 'and (and (= 2 2) (> 2 1)))
160
(test #f 'and (and (= 2 2) (< 2 1)))
161
(test '(f g) 'and (and 1 2 'c '(f g)))
163
(test #t 'or (or (= 2 2) (> 2 1)))
164
(test #t 'or (or (= 2 2) (< 2 1)))
165
(test #f 'or (or #f #f #f))
167
(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
169
(test 6 'let (let ((x 2) (y 3)) (* x y)))
170
(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
171
(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
172
(test #t 'letrec (letrec ((even?
173
(lambda (n) (if (zero? n) #t (odd? (- n 1)))))
175
(lambda (n) (if (zero? n) #f (even? (- n 1))))))
178
(test 5 'let (let ((x 3)) (define x 5) x))
180
(test 6 'let (let () (define x 6) x))
182
(test 7 'let* (let* ((x 3)) (define x 7) x))
184
(test 8 'let* (let* () (define x 8) x))
186
(test 9 'letrec (letrec () (define x 9) x))
188
(test 10 'letrec (letrec ((x 3)) (define x 10) x))
192
(test 6 'begin (begin (set! x 5) (+ x 1)))
194
(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
197
(vector-set! vec i i)))
198
(test 25 'do (let ((x '(1 3 5 7 9)))
200
(sum 0 (+ sum (car x))))
202
(test 1 'let (let foo () 1))
203
(test '((6 1 3) (-5 -2)) 'let
204
(let loop ((numbers '(3 -2 1 6 -5))
207
(cond ((null? numbers) (list nonneg neg))
208
((negative? (car numbers))
211
(cons (car numbers) neg)))
214
(cons (car numbers) nonneg)
217
(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
218
(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
219
(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
220
(test '((foo 7) . cons)
222
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
224
;;; sqt is defined here because not all implementations are required to
228
((> (* i i) x) (- i 1))))
230
(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
231
(test 5 'quasiquote `,(+ 2 3))
232
(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
233
'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
234
(test '(a `(b ,x ,'y d) e) 'quasiquote
235
(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
236
(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
237
(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
239
(define add3 (lambda (x) (+ x 3)))
240
(test 6 'define (add3 3))
242
(test 1 'define (first '(1 2)))
246
(define foo (lambda (y) (bar x y)))
247
(define bar (lambda (a b) (+ (* a b) a)))
250
(define (foo) (define x 5) x)
253
(define foo (lambda () (define x 5) x))
256
(define (foo x) ((lambda () (define x 5) x)) x)
263
(test #f not (list 3))
269
(test #t boolean? #f)
271
(test #f boolean? '())
276
(test #t eqv? '() '())
277
(test #t eqv? '10000 '10000)
278
(test #f eqv? (cons 1 2)(cons 1 2))
279
(test #f eqv? (lambda () 1) (lambda () 2))
280
(test #f eqv? #f 'nil)
281
(let ((p (lambda (x) x)))
286
(lambda () (set! n (+ n 1)) n))))
287
(let ((g (gen-counter))) (test #t eqv? g g))
288
(test #f eqv? (gen-counter) (gen-counter))
289
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
290
(g (lambda () (if (eqv? f g) 'g 'both))))
294
(test #f eq? (list 'a) (list 'a))
295
(test #t eq? '() '())
296
(test #t eq? car car)
297
(let ((x '(a))) (test #t eq? x x))
298
(let ((x '#())) (test #t eq? x x))
299
(let ((x (lambda (x) x))) (test #t eq? x x))
301
(test #t equal? 'a 'a)
302
(test #t equal? '(a) '(a))
303
(test #t equal? '(a (b) c) '(a (b) c))
304
(test #t equal? "abc" "abc")
306
(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
308
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
309
(define x (list 'a 'b 'c))
311
(and list? (test #t list? y))
313
(test '(a . 4) 'set-cdr! x)
315
(test '(a b c . d) 'dot '(a . (b . (c . d))))
316
(and list? (test #f list? y))
317
(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
319
(test #t pair? '(a . b))
320
(test #t pair? '(a . 1))
321
(test #t pair? '(a b c))
323
(test #f pair? '#(a b))
325
(test '(a) cons 'a '())
326
(test '((a) b c d) cons '(a) '(b c d))
327
(test '("a" b c) cons "a" '(b c))
328
(test '(a . 3) cons 'a 3)
329
(test '((a b) . c) cons '(a b) 'c)
331
(test 'a car '(a b c))
332
(test '(a) car '((a) b c d))
333
(test 1 car '(1 . 2))
335
(test '(b c d) cdr '((a) b c d))
336
(test 2 cdr '(1 . 2))
338
(test '(a 7 c) list 'a (+ 3 4) 'c)
341
(test 3 length '(a b c))
342
(test 3 length '(a (b) (c d e)))
345
(test '(x y) append '(x) '(y))
346
(test '(a b c d) append '(a) '(b c d))
347
(test '(a (b) (c)) append '(a (b)) '((c)))
349
(test '(a b c . d) append '(a b) '(c . d))
350
(test 'a append '() 'a)
352
(test '(c b a) reverse '(a b c))
353
(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
355
(test 'c list-ref '(a b c d) 2)
357
(test '(a b c) memq 'a '(a b c))
358
(test '(b c) memq 'b '(a b c))
359
(test '#f memq 'a '(b c d))
360
(test '#f memq (list 'a) '(b (a) c))
361
(test '((a) c) member (list 'a) '(b (a) c))
362
(test '(101 102) memv 101 '(100 101 102))
364
(define e '((a 1) (b 2) (c 3)))
365
(test '(a 1) assq 'a e)
366
(test '(b 2) assq 'b e)
368
(test #f assq (list 'a) '(((a)) ((b)) ((c))))
369
(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
370
(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
372
(test #t symbol? 'foo)
373
(test #t symbol? (car '(a b)))
374
(test #f symbol? "bar")
375
(test #t symbol? 'nil)
376
(test #f symbol? '())
378
;;; But first, what case are symbols in? Determine the standard case:
379
(define char-standard-case char-upcase)
380
(if (string=? (symbol->string 'A) "a")
381
(set! char-standard-case char-downcase))
383
;(test #t 'standard-case
384
; (string=? (symbol->string 'a) (symbol->string 'A)))
385
;(test #t 'standard-case
386
; (or (string=? (symbol->string 'a) "A")
387
; (string=? (symbol->string 'A) "a")))
389
(let ((v (make-string (string-length s))))
390
(do ((i (- (string-length v) 1) (- i 1)))
392
(string-set! v i (string-ref s i)))))
393
(define (string-standard-case s)
394
(set! s (str-copy s))
396
(sl (string-length s)))
398
(string-set! s i (char-standard-case (string-ref s i)))))
400
;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
401
;(test (string-standard-case "martin") symbol->string 'Martin)
402
(test "Malvina" symbol->string (string->symbol "Malvina"))
404
;(test #t 'standard-case (eq? 'a 'A))
406
(define x (string #\a #\b))
407
(define y (string->symbol x))
408
(string-set! x 0 #\c)
409
(test "cb" 'string-set! x)
410
(test "ab" symbol->string y)
411
(test y string->symbol "ab")
414
;(test #t eq? 'mISSISSIppi 'mississippi)
415
;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
416
(test 'JollyWog string->symbol (symbol->string 'JollyWog))
422
(test #t rational? 3)
433
(test #f > 9 9 -2424)
434
(test #t >= 3 -4 -6246)
437
(test #t < -1 2 3 4 5 6 7 8)
438
(test #f < -1 2 3 4 4 5 6 7)
439
(test #t <= -1 2 3 4 5 6 7 8)
440
(test #t <= -1 2 3 4 4 5 6 7)
448
(test #t positive? 4)
449
(test #f positive? -4)
450
(test #f positive? 0)
451
(test #f negative? 4)
452
(test #t negative? -4)
453
(test #f negative? 0)
463
(test 38 max 34 5 7 38 6)
464
(test -24 min 3 5 5 330 4 -24)
478
(test 5 quotient 35 7)
479
(test -5 quotient -35 7)
480
(test -5 quotient 35 -7)
481
(test 5 quotient -35 -7)
483
(test 1 remainder 13 4)
484
(test 3 modulo -13 4)
485
(test -1 remainder -13 4)
486
(test -3 modulo 13 -4)
487
(test 1 remainder 13 -4)
488
(test -1 modulo -13 -4)
489
(test -1 remainder -13 -4)
490
(define (divtest n1 n2)
491
(= n1 (+ (* n2 (quotient n1 n2))
493
(test #t divtest 238 9)
494
(test #t divtest -238 9)
495
(test #t divtest 238 -9)
496
(test #t divtest -238 -9)
502
(test 288 lcm 32 -36)
505
;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
506
;;; Modified by jaffer.
507
(define (test-inexact)
508
(define f3.9 (string->number "3.9"))
509
(define f4.0 (string->number "4.0"))
510
(define f-3.25 (string->number "-3.25"))
511
(define f.25 (string->number ".25"))
512
(define f4.5 (string->number "4.5"))
513
(define f3.5 (string->number "3.5"))
514
(define f0.0 (string->number "0.0"))
515
(define f0.8 (string->number "0.8"))
516
(define f1.0 (string->number "1.0"))
517
(define wto write-test-obj)
518
(define dto display-test-obj)
519
(define lto load-test-obj)
521
(test #t inexact? f3.9)
522
(test #t 'inexact? (inexact? (max f3.9 4)))
523
(test f4.0 'max (max f3.9 4))
524
(test f4.0 'exact->inexact (exact->inexact 4))
525
(test (- f4.0) round (- f4.5))
526
(test (- f4.0) round (- f3.5))
527
(test (- f4.0) round (- f3.9))
528
(test f0.0 round f0.0)
529
(test f0.0 round f.25)
530
(test f1.0 round f0.8)
531
(test f4.0 round f3.5)
532
(test f4.0 round f4.5)
533
(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
534
(set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
535
(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
536
(test #t call-with-output-file
537
(data-file-name "tmp3")
539
(write-char #\; test-file)
540
(display write-test-obj test-file)
542
(write load-test-obj test-file)
543
(output-port? test-file)))
544
(check-test-file (data-file-name "tmp3"))
545
(set! write-test-obj wto)
546
(set! display-test-obj dto)
547
(set! load-test-obj lto)
548
(let ((x (string->number "4195835.0"))
549
(y (string->number "3145727.0")))
550
(test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
553
(define (test-bignum)
556
(= n1 (+ (* n2 (quotient n1 n2))
557
(remainder n1 n2)))))
559
(test 0 modulo -2177452800 86400)
560
(test 0 modulo 2177452800 -86400)
561
(test 0 modulo 2177452800 86400)
562
(test 0 modulo -2177452800 -86400)
563
(test #t 'remainder (tb 281474976710655 65535))
564
(test #t 'remainder (tb 281474976710654 65535))
566
(test 281474976710655 string->number "281474976710655")
567
(test "281474976710655" number->string 281474976710655)
571
(test "0" number->string 0)
572
(test "100" number->string 100)
573
(test "100" number->string 256 16)
574
(test 100 string->number "100")
575
(test 256 string->number "100" 16)
576
(test #f string->number "")
577
(test #f string->number ".")
578
(test #f string->number "d")
579
(test #f string->number "D")
580
(test #f string->number "i")
581
(test #f string->number "I")
582
(test #f string->number "3i")
583
(test #f string->number "3I")
584
(test #f string->number "33i")
585
(test #f string->number "33I")
586
(test #f string->number "3.3i")
587
(test #f string->number "3.3I")
588
(test #f string->number "-")
589
(test #f string->number "+")
592
(test #t eqv? '#\ #\Space)
593
(test #t eqv? #\space '#\Space)
597
(test #t char? '#\newline)
599
(test #f char=? #\A #\B)
600
(test #f char=? #\a #\b)
601
(test #f char=? #\9 #\0)
602
(test #t char=? #\A #\A)
604
(test #t char<? #\A #\B)
605
(test #t char<? #\a #\b)
606
(test #f char<? #\9 #\0)
607
(test #f char<? #\A #\A)
609
(test #f char>? #\A #\B)
610
(test #f char>? #\a #\b)
611
(test #t char>? #\9 #\0)
612
(test #f char>? #\A #\A)
614
(test #t char<=? #\A #\B)
615
(test #t char<=? #\a #\b)
616
(test #f char<=? #\9 #\0)
617
(test #t char<=? #\A #\A)
619
(test #f char>=? #\A #\B)
620
(test #f char>=? #\a #\b)
621
(test #t char>=? #\9 #\0)
622
(test #t char>=? #\A #\A)
624
(test #f char-ci=? #\A #\B)
625
(test #f char-ci=? #\a #\B)
626
(test #f char-ci=? #\A #\b)
627
(test #f char-ci=? #\a #\b)
628
(test #f char-ci=? #\9 #\0)
629
(test #t char-ci=? #\A #\A)
630
(test #t char-ci=? #\A #\a)
632
(test #t char-ci<? #\A #\B)
633
(test #t char-ci<? #\a #\B)
634
(test #t char-ci<? #\A #\b)
635
(test #t char-ci<? #\a #\b)
636
(test #f char-ci<? #\9 #\0)
637
(test #f char-ci<? #\A #\A)
638
(test #f char-ci<? #\A #\a)
640
(test #f char-ci>? #\A #\B)
641
(test #f char-ci>? #\a #\B)
642
(test #f char-ci>? #\A #\b)
643
(test #f char-ci>? #\a #\b)
644
(test #t char-ci>? #\9 #\0)
645
(test #f char-ci>? #\A #\A)
646
(test #f char-ci>? #\A #\a)
648
(test #t char-ci<=? #\A #\B)
649
(test #t char-ci<=? #\a #\B)
650
(test #t char-ci<=? #\A #\b)
651
(test #t char-ci<=? #\a #\b)
652
(test #f char-ci<=? #\9 #\0)
653
(test #t char-ci<=? #\A #\A)
654
(test #t char-ci<=? #\A #\a)
656
(test #f char-ci>=? #\A #\B)
657
(test #f char-ci>=? #\a #\B)
658
(test #f char-ci>=? #\A #\b)
659
(test #f char-ci>=? #\a #\b)
660
(test #t char-ci>=? #\9 #\0)
661
(test #t char-ci>=? #\A #\A)
662
(test #t char-ci>=? #\A #\a)
664
(test #t char-alphabetic? #\a)
665
(test #t char-alphabetic? #\A)
666
(test #t char-alphabetic? #\z)
667
(test #t char-alphabetic? #\Z)
668
(test #f char-alphabetic? #\0)
669
(test #f char-alphabetic? #\9)
670
(test #f char-alphabetic? #\space)
671
(test #f char-alphabetic? #\;)
673
(test #f char-numeric? #\a)
674
(test #f char-numeric? #\A)
675
(test #f char-numeric? #\z)
676
(test #f char-numeric? #\Z)
677
(test #t char-numeric? #\0)
678
(test #t char-numeric? #\9)
679
(test #f char-numeric? #\space)
680
(test #f char-numeric? #\;)
682
(test #f char-whitespace? #\a)
683
(test #f char-whitespace? #\A)
684
(test #f char-whitespace? #\z)
685
(test #f char-whitespace? #\Z)
686
(test #f char-whitespace? #\0)
687
(test #f char-whitespace? #\9)
688
(test #t char-whitespace? #\space)
689
(test #f char-whitespace? #\;)
691
(test #f char-upper-case? #\0)
692
(test #f char-upper-case? #\9)
693
(test #f char-upper-case? #\space)
694
(test #f char-upper-case? #\;)
696
(test #f char-lower-case? #\0)
697
(test #f char-lower-case? #\9)
698
(test #f char-lower-case? #\space)
699
(test #f char-lower-case? #\;)
701
(test #\. integer->char (char->integer #\.))
702
(test #\A integer->char (char->integer #\A))
703
(test #\a integer->char (char->integer #\a))
704
(test #\A char-upcase #\A)
705
(test #\A char-upcase #\a)
706
(test #\a char-downcase #\A)
707
(test #\a char-downcase #\a)
709
(test #t string? "The word \"recursion\\\" has many meanings.")
711
(define f (make-string 3 #\*))
712
(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
713
(test "abc" string #\a #\b #\c)
715
(test 3 string-length "abc")
716
(test #\a string-ref "abc" 0)
717
(test #\c string-ref "abc" 2)
718
(test 0 string-length "")
719
(test "" substring "ab" 0 0)
720
(test "" substring "ab" 1 1)
721
(test "" substring "ab" 2 2)
722
(test "a" substring "ab" 0 1)
723
(test "b" substring "ab" 1 2)
724
(test "ab" substring "ab" 0 2)
725
(test "foobar" string-append "foo" "bar")
726
(test "foo" string-append "foo")
727
(test "foo" string-append "foo" "")
728
(test "foo" string-append "" "foo")
729
(test "" string-append)
730
(test "" make-string 0)
731
(test #t string=? "" "")
732
(test #f string<? "" "")
733
(test #f string>? "" "")
734
(test #t string<=? "" "")
735
(test #t string>=? "" "")
736
(test #t string-ci=? "" "")
737
(test #f string-ci<? "" "")
738
(test #f string-ci>? "" "")
739
(test #t string-ci<=? "" "")
740
(test #t string-ci>=? "" "")
742
(test #f string=? "A" "B")
743
(test #f string=? "a" "b")
744
(test #f string=? "9" "0")
745
(test #t string=? "A" "A")
747
(test #t string<? "A" "B")
748
(test #t string<? "a" "b")
749
(test #f string<? "9" "0")
750
(test #f string<? "A" "A")
752
(test #f string>? "A" "B")
753
(test #f string>? "a" "b")
754
(test #t string>? "9" "0")
755
(test #f string>? "A" "A")
757
(test #t string<=? "A" "B")
758
(test #t string<=? "a" "b")
759
(test #f string<=? "9" "0")
760
(test #t string<=? "A" "A")
762
(test #f string>=? "A" "B")
763
(test #f string>=? "a" "b")
764
(test #t string>=? "9" "0")
765
(test #t string>=? "A" "A")
767
(test #f string-ci=? "A" "B")
768
(test #f string-ci=? "a" "B")
769
(test #f string-ci=? "A" "b")
770
(test #f string-ci=? "a" "b")
771
(test #f string-ci=? "9" "0")
772
(test #t string-ci=? "A" "A")
773
(test #t string-ci=? "A" "a")
775
(test #t string-ci<? "A" "B")
776
(test #t string-ci<? "a" "B")
777
(test #t string-ci<? "A" "b")
778
(test #t string-ci<? "a" "b")
779
(test #f string-ci<? "9" "0")
780
(test #f string-ci<? "A" "A")
781
(test #f string-ci<? "A" "a")
783
(test #f string-ci>? "A" "B")
784
(test #f string-ci>? "a" "B")
785
(test #f string-ci>? "A" "b")
786
(test #f string-ci>? "a" "b")
787
(test #t string-ci>? "9" "0")
788
(test #f string-ci>? "A" "A")
789
(test #f string-ci>? "A" "a")
791
(test #t string-ci<=? "A" "B")
792
(test #t string-ci<=? "a" "B")
793
(test #t string-ci<=? "A" "b")
794
(test #t string-ci<=? "a" "b")
795
(test #f string-ci<=? "9" "0")
796
(test #t string-ci<=? "A" "A")
797
(test #t string-ci<=? "A" "a")
799
(test #f string-ci>=? "A" "B")
800
(test #f string-ci>=? "a" "B")
801
(test #f string-ci>=? "A" "b")
802
(test #f string-ci>=? "a" "b")
803
(test #t string-ci>=? "9" "0")
804
(test #t string-ci>=? "A" "A")
805
(test #t string-ci>=? "A" "a")
807
(test #t vector? '#(0 (2 2 2 2) "Anna"))
808
(test #t vector? '#())
809
(test '#(a b c) vector 'a 'b 'c)
811
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
812
(test 0 vector-length '#())
813
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
814
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
815
(let ((vec (vector 0 '(2 2 2 2) "Anna")))
816
(vector-set! vec 1 '("Sue" "Sue"))
818
(test '#(hi hi) make-vector 2 'hi)
819
(test '#() make-vector 0)
820
(test '#() make-vector 0 'a)
822
(test #t procedure? car)
823
(test #f procedure? 'car)
824
(test #t procedure? (lambda (x) (* x x)))
825
(test #f procedure? '(lambda (x) (* x x)))
826
(test #t call-with-current-continuation procedure?)
827
(test 7 apply + (list 3 4))
828
(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
829
(test 17 apply + 10 (list 3 4))
830
(test '() apply list '())
831
(define compose (lambda (f g) (lambda args (f (apply g args)))))
832
(test 30 (compose sqt *) 12 75)
834
(test '(b e h) map cadr '((a b) (d e) (g h)))
835
(test '(5 7 9) map + '(1 2 3) '(4 5 6))
836
(test '#(0 1 4 9 16) 'for-each
837
(let ((v (make-vector 5)))
838
(for-each (lambda (i) (vector-set! v i (* i i)))
841
(test -3 call-with-current-continuation
843
(for-each (lambda (x) (if (negative? x) (exit x)))
844
'(54 0 37 -3 245 19))
848
(call-with-current-continuation
850
(letrec ((r (lambda (obj) (cond ((null? obj) 0)
851
((pair? obj) (+ (r (cdr obj)) 1))
852
(else (return #f))))))
854
(test 4 list-length '(1 2 3 4))
855
(test #f list-length '(a b . c))
856
(test '() map cadr '())
858
;;; This tests full conformance of call-with-current-continuation. It
859
;;; is a separate test because some schemes do not support call/cc
860
;;; other than escape procedures. I am indebted to
861
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
862
;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
863
;;; trees constructed of conses.
864
(define (next-leaf-generator obj eot)
868
(set! cont (lambda (x) (return eot)))
873
(call-with-current-continuation
877
(lambda () (call-with-current-continuation
878
(lambda (ret) (set! return ret) (cont #f))))))
879
(define (leaf-eq? x y)
880
(let* ((eot (list 'eot))
881
(xf (next-leaf-generator x eot))
882
(yf (next-leaf-generator y eot)))
883
(letrec ((loop (lambda (x y)
884
(cond ((not (eq? x y)) #f)
886
(else (loop (xf) (yf)))))))
890
(test #t leaf-eq? '(a (b (c))) '((a) b c))
891
(test #f leaf-eq? '(a (b (c))) '((a) b c d))
894
;;; Test Optional R4RS DELAY syntax and FORCE procedure
897
(test 3 'delay (force (delay (+ 1 2))))
898
(test '(3 3) 'delay (let ((p (delay (+ 1 2))))
899
(list (force p) (force p))))
900
(test 2 'delay (letrec ((a-stream
901
(letrec ((next (lambda (n)
902
(cons n (delay (next (+ n 1)))))))
905
(tail (lambda (stream) (force (cdr stream)))))
906
(head (tail (tail a-stream)))))
908
(p (delay (begin (set! count (+ count 1))
917
(letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
923
(test #t input-port? (current-input-port))
924
(test #t output-port? (current-output-port))
925
(test #t call-with-input-file (test-file-name "r4rs.test") input-port?)
926
(define this-file (open-input-file (test-file-name "r4rs.test")))
927
(test #t input-port? this-file)
929
(test #\; peek-char this-file)
930
(test #\; read-char this-file)
931
(read this-file) ;; skip define-module expression
932
(test '(define cur-section '()) read this-file)
933
(test #\( peek-char this-file)
934
(test '(define errs '()) read this-file)
935
(close-input-port this-file)
936
(close-input-port this-file)
937
(define (check-test-file name)
938
(define test-file (open-input-file name))
939
(test #t 'input-port?
940
(call-with-input-file
943
(test load-test-obj read test-file)
944
(test #t eof-object? (peek-char test-file))
945
(test #t eof-object? (read-char test-file))
946
(input-port? test-file))))
947
(test #\; read-char test-file)
948
(test display-test-obj read test-file)
949
(test load-test-obj read test-file)
950
(close-input-port test-file))
952
(define write-test-obj
953
'(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
954
(define display-test-obj
955
'(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
956
(define load-test-obj
957
(list 'define 'foo (list 'quote write-test-obj)))
958
(test #t call-with-output-file
959
(data-file-name "tmp1")
961
(write-char #\; test-file)
962
(display write-test-obj test-file)
964
(write load-test-obj test-file)
965
(output-port? test-file)))
966
(check-test-file (data-file-name "tmp1"))
968
(define test-file (open-output-file (data-file-name "tmp2")))
969
(write-char #\; test-file)
970
(display write-test-obj test-file)
972
(write load-test-obj test-file)
973
(test #t output-port? test-file)
974
(close-output-port test-file)
975
(check-test-file (data-file-name "tmp2"))
978
(test '(#\P #\space #\l) string->list "P l")
979
(test '() string->list "")
980
(test "1\\\"" list->string '(#\1 #\\ #\"))
981
(test "" list->string '())
983
(test '(dah dah didah) vector->list '#(dah dah didah))
984
(test '() vector->list '#())
985
(test '#(dididit dah) list->vector '(dididit dah))
986
(test '#() list->vector '())
988
(load (data-file-name "tmp1"))
989
(test write-test-obj 'load foo)
993
(if (and (string->number "0.0") (inexact? (string->number "0.0")))
996
(let ((n (string->number "281474976710655")))
997
(if (and n (exact? n))
1004
(delete-file (data-file-name "tmp1"))
1005
(delete-file (data-file-name "tmp2"))
1006
(delete-file (data-file-name "tmp3"))
added
removed
test-suite/tests/r4rs.test
