summaryrefslogtreecommitdiff
path: root/test-suite/tests/r4rs.test
diff options
context:
space:
mode:
authorcvs2svn <admin@example.com>1999-08-26 04:24:43 +0000
committercvs2svn <admin@example.com>1999-08-26 04:24:43 +0000
commit0047f9758418f216ddfa0cefef5ed9e781e99086 (patch)
treee864e8e86e738c8cb53e3113720376fed7631093 /test-suite/tests/r4rs.test
parent9de33deb2ea07bf6c93651bbd693e7484dd29b33 (diff)
downloadguile-mdj_post_subr_table.tar.gz
This commit was manufactured by cvs2svn to create tagmdj_post_subr_table
'mdj_post_subr_table'.
Diffstat (limited to 'test-suite/tests/r4rs.test')
-rw-r--r--test-suite/tests/r4rs.test1014
1 files changed, 0 insertions, 1014 deletions
diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test
deleted file mode 100644
index c915b515c..000000000
--- a/test-suite/tests/r4rs.test
+++ /dev/null
@@ -1,1014 +0,0 @@
-;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*-
-;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
-
-
-;;;; ============= NOTE =============
-
-;;;; This file is a quick-and-dirty adaptation of Aubrey's test suite
-;;;; to Guile's testing framework. As such, it's not as clean as one
-;;;; might hope. (In particular, it uses with-test-prefix oddly.)
-;;;;
-;;;; If you're looking for an example of a test suite to imitate, you
-;;;; might do better by looking at ports.test, which uses the
-;;;; (test-suite lib) functions much more idiomatically.
-
-
-;;;; "test.scm" Test correctness of scheme implementations.
-;;;; Author: Aubrey Jaffer
-;;;; Modified: Mikael Djurfeldt
-;;;; Removed tests which Guile deliberately
-;;;; won't pass. Made the the tests (test-cont), (test-sc4), and
-;;;; (test-delay) start to run automatically.
-;;;; Modified: Jim Blandy
-;;;; adapted to new Guile test suite framework
-
-;;; This includes examples from
-;;; William Clinger and Jonathan Rees, editors.
-;;; Revised^4 Report on the Algorithmic Language Scheme
-;;; and the IEEE specification.
-
-;;; The input tests read this file expecting it to be named
-;;; "test.scm", so you'll have to run it from the ice-9 source
-;;; directory, or copy this file elsewhere
-;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
-;;; these tests. You may need to delete them in order to run
-;;; "test.scm" more than once.
-
-;;; There are three optional tests:
-;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
-;;;
-;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
-;;;
-;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
-;;; either standard.
-
-;;; If you are testing a R3RS version which does not have `list?' do:
-;;; (define list? #f)
-
-;;; send corrections or additions to jaffer@ai.mit.edu or
-;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
-
-(define cur-section '())(define errs '())
-(define SECTION (lambda args
- (set! cur-section args) #t))
-(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
-(define (report-errs) #f)
-
-(define test
- (lambda (expect fun . args)
- (let ((res (if (procedure? fun) (apply fun args) (car args))))
- (with-test-prefix cur-section
- (pass-if (call-with-output-string (lambda (port)
- (write (cons fun args) port)))
- (equal? expect res))))))
-
-;; test that all symbol characters are supported.
-(SECTION 2 1)
-'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
-
-(SECTION 3 4)
-(define disjoint-type-functions
- (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
-(define type-examples
- (list
- #t #f #\a '() 9739 '(test) (lambda () #f) car "test" "" 'test
- '#() '#(a b c)))
-(define type-matrix
- (map (lambda (x)
- (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
- t))
- type-examples))
-(for-each (lambda (object row)
- (let ((count (apply + (map (lambda (elt) (if elt 1 0))
- row))))
- (pass-if (call-with-output-string
- (lambda (port)
- (display "object recognized by only one predicate: "
- port)
- (display object port)))
- (= count 1))))
- type-examples
- type-matrix)
-
-(SECTION 4 1 2)
-(test '(quote a) 'quote (quote 'a))
-(test '(quote a) 'quote ''a)
-(SECTION 4 1 3)
-(test 12 (if #f + *) 3 4)
-(SECTION 4 1 4)
-(test 8 (lambda (x) (+ x x)) 4)
-(define reverse-subtract
- (lambda (x y) (- y x)))
-(test 3 reverse-subtract 7 10)
-(define add4
- (let ((x 4))
- (lambda (y) (+ x y))))
-(test 10 add4 6)
-(test '(3 4 5 6) (lambda x x) 3 4 5 6)
-(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
-(SECTION 4 1 5)
-(test 'yes 'if (if (> 3 2) 'yes 'no))
-(test 'no 'if (if (> 2 3) 'yes 'no))
-(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
-(SECTION 4 1 6)
-(define x 2)
-(test 3 'define (+ x 1))
-(set! x 4)
-(test 5 'set! (+ x 1))
-(SECTION 4 2 1)
-(test 'greater 'cond (cond ((> 3 2) 'greater)
- ((< 3 2) 'less)))
-(test 'equal 'cond (cond ((> 3 3) 'greater)
- ((< 3 3) 'less)
- (else 'equal)))
-(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
- (else #f)))
-(test 'composite 'case (case (* 2 3)
- ((2 3 5 7) 'prime)
- ((1 4 6 8 9) 'composite)))
-(test 'consonant 'case (case (car '(c d))
- ((a e i o u) 'vowel)
- ((w y) 'semivowel)
- (else 'consonant)))
-(test #t 'and (and (= 2 2) (> 2 1)))
-(test #f 'and (and (= 2 2) (< 2 1)))
-(test '(f g) 'and (and 1 2 'c '(f g)))
-(test #t 'and (and))
-(test #t 'or (or (= 2 2) (> 2 1)))
-(test #t 'or (or (= 2 2) (< 2 1)))
-(test #f 'or (or #f #f #f))
-(test #f 'or (or))
-(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
-(SECTION 4 2 2)
-(test 6 'let (let ((x 2) (y 3)) (* x y)))
-(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
-(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
-(test #t 'letrec (letrec ((even?
- (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
- (odd?
- (lambda (n) (if (zero? n) #f (even? (- n 1))))))
- (even? 88)))
-(define x 34)
-(test 5 'let (let ((x 3)) (define x 5) x))
-(test 34 'let x)
-(test 6 'let (let () (define x 6) x))
-(test 34 'let x)
-(test 7 'let* (let* ((x 3)) (define x 7) x))
-(test 34 'let* x)
-(test 8 'let* (let* () (define x 8) x))
-(test 34 'let* x)
-(test 9 'letrec (letrec () (define x 9) x))
-(test 34 'letrec x)
-(test 10 'letrec (letrec ((x 3)) (define x 10) x))
-(test 34 'letrec x)
-(SECTION 4 2 3)
-(define x 0)
-(test 6 'begin (begin (set! x 5) (+ x 1)))
-(SECTION 4 2 4)
-(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
- (i 0 (+ i 1)))
- ((= i 5) vec)
- (vector-set! vec i i)))
-(test 25 'do (let ((x '(1 3 5 7 9)))
- (do ((x x (cdr x))
- (sum 0 (+ sum (car x))))
- ((null? x) sum))))
-(test 1 'let (let foo () 1))
-(test '((6 1 3) (-5 -2)) 'let
- (let loop ((numbers '(3 -2 1 6 -5))
- (nonneg '())
- (neg '()))
- (cond ((null? numbers) (list nonneg neg))
- ((negative? (car numbers))
- (loop (cdr numbers)
- nonneg
- (cons (car numbers) neg)))
- (else
- (loop (cdr numbers)
- (cons (car numbers) nonneg)
- neg)))))
-(SECTION 4 2 6)
-(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
-(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
-(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
-(test '((foo 7) . cons)
- 'quasiquote
- `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
-
-;;; sqt is defined here because not all implementations are required to
-;;; support it.
-(define (sqt x)
- (do ((i 0 (+ i 1)))
- ((> (* i i) x) (- i 1))))
-
-(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
-(test 5 'quasiquote `,(+ 2 3))
-(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
- 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
-(test '(a `(b ,x ,'y d) e) 'quasiquote
- (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
-(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
-(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
-(SECTION 5 2 1)
-(define add3 (lambda (x) (+ x 3)))
-(test 6 'define (add3 3))
-(define first car)
-(test 1 'define (first '(1 2)))
-(SECTION 5 2 2)
-(test 45 'define
- (let ((x 5))
- (define foo (lambda (y) (bar x y)))
- (define bar (lambda (a b) (+ (* a b) a)))
- (foo (+ x 3))))
-(define x 34)
-(define (foo) (define x 5) x)
-(test 5 foo)
-(test 34 'define x)
-(define foo (lambda () (define x 5) x))
-(test 5 foo)
-(test 34 'define x)
-(define (foo x) ((lambda () (define x 5) x)) x)
-(test 88 foo 88)
-(test 4 foo 4)
-(test 34 'define x)
-(SECTION 6 1)
-(test #f not #t)
-(test #f not 3)
-(test #f not (list 3))
-(test #t not #f)
-(test #f not '())
-(test #f not (list))
-(test #f not 'nil)
-
-(test #t boolean? #f)
-(test #f boolean? 0)
-(test #f boolean? '())
-(SECTION 6 2)
-(test #t eqv? 'a 'a)
-(test #f eqv? 'a 'b)
-(test #t eqv? 2 2)
-(test #t eqv? '() '())
-(test #t eqv? '10000 '10000)
-(test #f eqv? (cons 1 2)(cons 1 2))
-(test #f eqv? (lambda () 1) (lambda () 2))
-(test #f eqv? #f 'nil)
-(let ((p (lambda (x) x)))
- (test #t eqv? p p))
-(define gen-counter
- (lambda ()
- (let ((n 0))
- (lambda () (set! n (+ n 1)) n))))
-(let ((g (gen-counter))) (test #t eqv? g g))
-(test #f eqv? (gen-counter) (gen-counter))
-(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
- (g (lambda () (if (eqv? f g) 'g 'both))))
- (test #f eqv? f g))
-
-(test #t eq? 'a 'a)
-(test #f eq? (list 'a) (list 'a))
-(test #t eq? '() '())
-(test #t eq? car car)
-(let ((x '(a))) (test #t eq? x x))
-(let ((x '#())) (test #t eq? x x))
-(let ((x (lambda (x) x))) (test #t eq? x x))
-
-(test #t equal? 'a 'a)
-(test #t equal? '(a) '(a))
-(test #t equal? '(a (b) c) '(a (b) c))
-(test #t equal? "abc" "abc")
-(test #t equal? 2 2)
-(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
-(SECTION 6 3)
-(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
-(define x (list 'a 'b 'c))
-(define y x)
-(and list? (test #t list? y))
-(set-cdr! x 4)
-(test '(a . 4) 'set-cdr! x)
-(test #t eqv? x y)
-(test '(a b c . d) 'dot '(a . (b . (c . d))))
-(and list? (test #f list? y))
-(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
-
-(test #t pair? '(a . b))
-(test #t pair? '(a . 1))
-(test #t pair? '(a b c))
-(test #f pair? '())
-(test #f pair? '#(a b))
-
-(test '(a) cons 'a '())
-(test '((a) b c d) cons '(a) '(b c d))
-(test '("a" b c) cons "a" '(b c))
-(test '(a . 3) cons 'a 3)
-(test '((a b) . c) cons '(a b) 'c)
-
-(test 'a car '(a b c))
-(test '(a) car '((a) b c d))
-(test 1 car '(1 . 2))
-
-(test '(b c d) cdr '((a) b c d))
-(test 2 cdr '(1 . 2))
-
-(test '(a 7 c) list 'a (+ 3 4) 'c)
-(test '() list)
-
-(test 3 length '(a b c))
-(test 3 length '(a (b) (c d e)))
-(test 0 length '())
-
-(test '(x y) append '(x) '(y))
-(test '(a b c d) append '(a) '(b c d))
-(test '(a (b) (c)) append '(a (b)) '((c)))
-(test '() append)
-(test '(a b c . d) append '(a b) '(c . d))
-(test 'a append '() 'a)
-
-(test '(c b a) reverse '(a b c))
-(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
-
-(test 'c list-ref '(a b c d) 2)
-
-(test '(a b c) memq 'a '(a b c))
-(test '(b c) memq 'b '(a b c))
-(test '#f memq 'a '(b c d))
-(test '#f memq (list 'a) '(b (a) c))
-(test '((a) c) member (list 'a) '(b (a) c))
-(test '(101 102) memv 101 '(100 101 102))
-
-(define e '((a 1) (b 2) (c 3)))
-(test '(a 1) assq 'a e)
-(test '(b 2) assq 'b e)
-(test #f assq 'd e)
-(test #f assq (list 'a) '(((a)) ((b)) ((c))))
-(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
-(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
-(SECTION 6 4)
-(test #t symbol? 'foo)
-(test #t symbol? (car '(a b)))
-(test #f symbol? "bar")
-(test #t symbol? 'nil)
-(test #f symbol? '())
-(test #f symbol? #f)
-;;; But first, what case are symbols in? Determine the standard case:
-(define char-standard-case char-upcase)
-(if (string=? (symbol->string 'A) "a")
- (set! char-standard-case char-downcase))
-;;; Not for Guile
-;(test #t 'standard-case
-; (string=? (symbol->string 'a) (symbol->string 'A)))
-;(test #t 'standard-case
-; (or (string=? (symbol->string 'a) "A")
-; (string=? (symbol->string 'A) "a")))
-(define (str-copy s)
- (let ((v (make-string (string-length s))))
- (do ((i (- (string-length v) 1) (- i 1)))
- ((< i 0) v)
- (string-set! v i (string-ref s i)))))
-(define (string-standard-case s)
- (set! s (str-copy s))
- (do ((i 0 (+ 1 i))
- (sl (string-length s)))
- ((>= i sl) s)
- (string-set! s i (char-standard-case (string-ref s i)))))
-;;; Not for Guile
-;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
-;(test (string-standard-case "martin") symbol->string 'Martin)
-(test "Malvina" symbol->string (string->symbol "Malvina"))
-;;; Not for Guile
-;(test #t 'standard-case (eq? 'a 'A))
-
-(define x (string #\a #\b))
-(define y (string->symbol x))
-(string-set! x 0 #\c)
-(test "cb" 'string-set! x)
-(test "ab" symbol->string y)
-(test y string->symbol "ab")
-
-;;; Not for Guile
-;(test #t eq? 'mISSISSIppi 'mississippi)
-;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
-(test 'JollyWog string->symbol (symbol->string 'JollyWog))
-
-(SECTION 6 5 5)
-(test #t number? 3)
-(test #t complex? 3)
-(test #t real? 3)
-(test #t rational? 3)
-(test #t integer? 3)
-
-(test #t exact? 3)
-(test #f inexact? 3)
-
-(test #t = 22 22 22)
-(test #t = 22 22)
-(test #f = 34 34 35)
-(test #f = 34 35)
-(test #t > 3 -6246)
-(test #f > 9 9 -2424)
-(test #t >= 3 -4 -6246)
-(test #t >= 9 9)
-(test #f >= 8 9)
-(test #t < -1 2 3 4 5 6 7 8)
-(test #f < -1 2 3 4 4 5 6 7)
-(test #t <= -1 2 3 4 5 6 7 8)
-(test #t <= -1 2 3 4 4 5 6 7)
-(test #f < 1 3 2)
-(test #f >= 1 3 2)
-
-(test #t zero? 0)
-(test #f zero? 1)
-(test #f zero? -1)
-(test #f zero? -100)
-(test #t positive? 4)
-(test #f positive? -4)
-(test #f positive? 0)
-(test #f negative? 4)
-(test #t negative? -4)
-(test #f negative? 0)
-(test #t odd? 3)
-(test #f odd? 2)
-(test #f odd? -4)
-(test #t odd? -1)
-(test #f even? 3)
-(test #t even? 2)
-(test #t even? -4)
-(test #f even? -1)
-
-(test 38 max 34 5 7 38 6)
-(test -24 min 3 5 5 330 4 -24)
-
-(test 7 + 3 4)
-(test '3 + 3)
-(test 0 +)
-(test 4 * 4)
-(test 1 *)
-
-(test -1 - 3 4)
-(test -3 - 3)
-(test 7 abs -7)
-(test 7 abs 7)
-(test 0 abs 0)
-
-(test 5 quotient 35 7)
-(test -5 quotient -35 7)
-(test -5 quotient 35 -7)
-(test 5 quotient -35 -7)
-(test 1 modulo 13 4)
-(test 1 remainder 13 4)
-(test 3 modulo -13 4)
-(test -1 remainder -13 4)
-(test -3 modulo 13 -4)
-(test 1 remainder 13 -4)
-(test -1 modulo -13 -4)
-(test -1 remainder -13 -4)
-(define (divtest n1 n2)
- (= n1 (+ (* n2 (quotient n1 n2))
- (remainder n1 n2))))
-(test #t divtest 238 9)
-(test #t divtest -238 9)
-(test #t divtest 238 -9)
-(test #t divtest -238 -9)
-
-(test 4 gcd 0 4)
-(test 4 gcd -4 0)
-(test 4 gcd 32 -36)
-(test 0 gcd)
-(test 288 lcm 32 -36)
-(test 1 lcm)
-
-;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
-;;; Modified by jaffer.
-(define (test-inexact)
- (define f3.9 (string->number "3.9"))
- (define f4.0 (string->number "4.0"))
- (define f-3.25 (string->number "-3.25"))
- (define f.25 (string->number ".25"))
- (define f4.5 (string->number "4.5"))
- (define f3.5 (string->number "3.5"))
- (define f0.0 (string->number "0.0"))
- (define f0.8 (string->number "0.8"))
- (define f1.0 (string->number "1.0"))
- (define wto write-test-obj)
- (define dto display-test-obj)
- (define lto load-test-obj)
- (SECTION 6 5 5)
- (test #t inexact? f3.9)
- (test #t 'inexact? (inexact? (max f3.9 4)))
- (test f4.0 'max (max f3.9 4))
- (test f4.0 'exact->inexact (exact->inexact 4))
- (test (- f4.0) round (- f4.5))
- (test (- f4.0) round (- f3.5))
- (test (- f4.0) round (- f3.9))
- (test f0.0 round f0.0)
- (test f0.0 round f.25)
- (test f1.0 round f0.8)
- (test f4.0 round f3.5)
- (test f4.0 round f4.5)
- (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
- (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
- (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
- (test #t call-with-output-file
- "tmp3"
- (lambda (test-file)
- (write-char #\; test-file)
- (display write-test-obj test-file)
- (newline test-file)
- (write load-test-obj test-file)
- (output-port? test-file)))
- (check-test-file "tmp3")
- (set! write-test-obj wto)
- (set! display-test-obj dto)
- (set! load-test-obj lto)
- (let ((x (string->number "4195835.0"))
- (y (string->number "3145727.0")))
- (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
- (report-errs))
-
-(define (test-bignum)
- (define tb
- (lambda (n1 n2)
- (= n1 (+ (* n2 (quotient n1 n2))
- (remainder n1 n2)))))
- (SECTION 6 5 5)
- (test 0 modulo -2177452800 86400)
- (test 0 modulo 2177452800 -86400)
- (test 0 modulo 2177452800 86400)
- (test 0 modulo -2177452800 -86400)
- (test #t 'remainder (tb 281474976710655 65535))
- (test #t 'remainder (tb 281474976710654 65535))
- (SECTION 6 5 6)
- (test 281474976710655 string->number "281474976710655")
- (test "281474976710655" number->string 281474976710655)
- (report-errs))
-
-(SECTION 6 5 6)
-(test "0" number->string 0)
-(test "100" number->string 100)
-(test "100" number->string 256 16)
-(test 100 string->number "100")
-(test 256 string->number "100" 16)
-(test #f string->number "")
-(test #f string->number ".")
-(test #f string->number "d")
-(test #f string->number "D")
-(test #f string->number "i")
-(test #f string->number "I")
-(test #f string->number "3i")
-(test #f string->number "3I")
-(test #f string->number "33i")
-(test #f string->number "33I")
-(test #f string->number "3.3i")
-(test #f string->number "3.3I")
-(test #f string->number "-")
-(test #f string->number "+")
-
-(SECTION 6 6)
-(test #t eqv? '#\ #\Space)
-(test #t eqv? #\space '#\Space)
-(test #t char? #\a)
-(test #t char? #\()
-(test #t char? #\ )
-(test #t char? '#\newline)
-
-(test #f char=? #\A #\B)
-(test #f char=? #\a #\b)
-(test #f char=? #\9 #\0)
-(test #t char=? #\A #\A)
-
-(test #t char<? #\A #\B)
-(test #t char<? #\a #\b)
-(test #f char<? #\9 #\0)
-(test #f char<? #\A #\A)
-
-(test #f char>? #\A #\B)
-(test #f char>? #\a #\b)
-(test #t char>? #\9 #\0)
-(test #f char>? #\A #\A)
-
-(test #t char<=? #\A #\B)
-(test #t char<=? #\a #\b)
-(test #f char<=? #\9 #\0)
-(test #t char<=? #\A #\A)
-
-(test #f char>=? #\A #\B)
-(test #f char>=? #\a #\b)
-(test #t char>=? #\9 #\0)
-(test #t char>=? #\A #\A)
-
-(test #f char-ci=? #\A #\B)
-(test #f char-ci=? #\a #\B)
-(test #f char-ci=? #\A #\b)
-(test #f char-ci=? #\a #\b)
-(test #f char-ci=? #\9 #\0)
-(test #t char-ci=? #\A #\A)
-(test #t char-ci=? #\A #\a)
-
-(test #t char-ci<? #\A #\B)
-(test #t char-ci<? #\a #\B)
-(test #t char-ci<? #\A #\b)
-(test #t char-ci<? #\a #\b)
-(test #f char-ci<? #\9 #\0)
-(test #f char-ci<? #\A #\A)
-(test #f char-ci<? #\A #\a)
-
-(test #f char-ci>? #\A #\B)
-(test #f char-ci>? #\a #\B)
-(test #f char-ci>? #\A #\b)
-(test #f char-ci>? #\a #\b)
-(test #t char-ci>? #\9 #\0)
-(test #f char-ci>? #\A #\A)
-(test #f char-ci>? #\A #\a)
-
-(test #t char-ci<=? #\A #\B)
-(test #t char-ci<=? #\a #\B)
-(test #t char-ci<=? #\A #\b)
-(test #t char-ci<=? #\a #\b)
-(test #f char-ci<=? #\9 #\0)
-(test #t char-ci<=? #\A #\A)
-(test #t char-ci<=? #\A #\a)
-
-(test #f char-ci>=? #\A #\B)
-(test #f char-ci>=? #\a #\B)
-(test #f char-ci>=? #\A #\b)
-(test #f char-ci>=? #\a #\b)
-(test #t char-ci>=? #\9 #\0)
-(test #t char-ci>=? #\A #\A)
-(test #t char-ci>=? #\A #\a)
-
-(test #t char-alphabetic? #\a)
-(test #t char-alphabetic? #\A)
-(test #t char-alphabetic? #\z)
-(test #t char-alphabetic? #\Z)
-(test #f char-alphabetic? #\0)
-(test #f char-alphabetic? #\9)
-(test #f char-alphabetic? #\space)
-(test #f char-alphabetic? #\;)
-
-(test #f char-numeric? #\a)
-(test #f char-numeric? #\A)
-(test #f char-numeric? #\z)
-(test #f char-numeric? #\Z)
-(test #t char-numeric? #\0)
-(test #t char-numeric? #\9)
-(test #f char-numeric? #\space)
-(test #f char-numeric? #\;)
-
-(test #f char-whitespace? #\a)
-(test #f char-whitespace? #\A)
-(test #f char-whitespace? #\z)
-(test #f char-whitespace? #\Z)
-(test #f char-whitespace? #\0)
-(test #f char-whitespace? #\9)
-(test #t char-whitespace? #\space)
-(test #f char-whitespace? #\;)
-
-(test #f char-upper-case? #\0)
-(test #f char-upper-case? #\9)
-(test #f char-upper-case? #\space)
-(test #f char-upper-case? #\;)
-
-(test #f char-lower-case? #\0)
-(test #f char-lower-case? #\9)
-(test #f char-lower-case? #\space)
-(test #f char-lower-case? #\;)
-
-(test #\. integer->char (char->integer #\.))
-(test #\A integer->char (char->integer #\A))
-(test #\a integer->char (char->integer #\a))
-(test #\A char-upcase #\A)
-(test #\A char-upcase #\a)
-(test #\a char-downcase #\A)
-(test #\a char-downcase #\a)
-(SECTION 6 7)
-(test #t string? "The word \"recursion\\\" has many meanings.")
-(test #t string? "")
-(define f (make-string 3 #\*))
-(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
-(test "abc" string #\a #\b #\c)
-(test "" string)
-(test 3 string-length "abc")
-(test #\a string-ref "abc" 0)
-(test #\c string-ref "abc" 2)
-(test 0 string-length "")
-(test "" substring "ab" 0 0)
-(test "" substring "ab" 1 1)
-(test "" substring "ab" 2 2)
-(test "a" substring "ab" 0 1)
-(test "b" substring "ab" 1 2)
-(test "ab" substring "ab" 0 2)
-(test "foobar" string-append "foo" "bar")
-(test "foo" string-append "foo")
-(test "foo" string-append "foo" "")
-(test "foo" string-append "" "foo")
-(test "" string-append)
-(test "" make-string 0)
-(test #t string=? "" "")
-(test #f string<? "" "")
-(test #f string>? "" "")
-(test #t string<=? "" "")
-(test #t string>=? "" "")
-(test #t string-ci=? "" "")
-(test #f string-ci<? "" "")
-(test #f string-ci>? "" "")
-(test #t string-ci<=? "" "")
-(test #t string-ci>=? "" "")
-
-(test #f string=? "A" "B")
-(test #f string=? "a" "b")
-(test #f string=? "9" "0")
-(test #t string=? "A" "A")
-
-(test #t string<? "A" "B")
-(test #t string<? "a" "b")
-(test #f string<? "9" "0")
-(test #f string<? "A" "A")
-
-(test #f string>? "A" "B")
-(test #f string>? "a" "b")
-(test #t string>? "9" "0")
-(test #f string>? "A" "A")
-
-(test #t string<=? "A" "B")
-(test #t string<=? "a" "b")
-(test #f string<=? "9" "0")
-(test #t string<=? "A" "A")
-
-(test #f string>=? "A" "B")
-(test #f string>=? "a" "b")
-(test #t string>=? "9" "0")
-(test #t string>=? "A" "A")
-
-(test #f string-ci=? "A" "B")
-(test #f string-ci=? "a" "B")
-(test #f string-ci=? "A" "b")
-(test #f string-ci=? "a" "b")
-(test #f string-ci=? "9" "0")
-(test #t string-ci=? "A" "A")
-(test #t string-ci=? "A" "a")
-
-(test #t string-ci<? "A" "B")
-(test #t string-ci<? "a" "B")
-(test #t string-ci<? "A" "b")
-(test #t string-ci<? "a" "b")
-(test #f string-ci<? "9" "0")
-(test #f string-ci<? "A" "A")
-(test #f string-ci<? "A" "a")
-
-(test #f string-ci>? "A" "B")
-(test #f string-ci>? "a" "B")
-(test #f string-ci>? "A" "b")
-(test #f string-ci>? "a" "b")
-(test #t string-ci>? "9" "0")
-(test #f string-ci>? "A" "A")
-(test #f string-ci>? "A" "a")
-
-(test #t string-ci<=? "A" "B")
-(test #t string-ci<=? "a" "B")
-(test #t string-ci<=? "A" "b")
-(test #t string-ci<=? "a" "b")
-(test #f string-ci<=? "9" "0")
-(test #t string-ci<=? "A" "A")
-(test #t string-ci<=? "A" "a")
-
-(test #f string-ci>=? "A" "B")
-(test #f string-ci>=? "a" "B")
-(test #f string-ci>=? "A" "b")
-(test #f string-ci>=? "a" "b")
-(test #t string-ci>=? "9" "0")
-(test #t string-ci>=? "A" "A")
-(test #t string-ci>=? "A" "a")
-(SECTION 6 8)
-(test #t vector? '#(0 (2 2 2 2) "Anna"))
-(test #t vector? '#())
-(test '#(a b c) vector 'a 'b 'c)
-(test '#() vector)
-(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
-(test 0 vector-length '#())
-(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
-(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
- (let ((vec (vector 0 '(2 2 2 2) "Anna")))
- (vector-set! vec 1 '("Sue" "Sue"))
- vec))
-(test '#(hi hi) make-vector 2 'hi)
-(test '#() make-vector 0)
-(test '#() make-vector 0 'a)
-(SECTION 6 9)
-(test #t procedure? car)
-(test #f procedure? 'car)
-(test #t procedure? (lambda (x) (* x x)))
-(test #f procedure? '(lambda (x) (* x x)))
-(test #t call-with-current-continuation procedure?)
-(test 7 apply + (list 3 4))
-(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
-(test 17 apply + 10 (list 3 4))
-(test '() apply list '())
-(define compose (lambda (f g) (lambda args (f (apply g args)))))
-(test 30 (compose sqt *) 12 75)
-
-(test '(b e h) map cadr '((a b) (d e) (g h)))
-(test '(5 7 9) map + '(1 2 3) '(4 5 6))
-(test '#(0 1 4 9 16) 'for-each
- (let ((v (make-vector 5)))
- (for-each (lambda (i) (vector-set! v i (* i i)))
- '(0 1 2 3 4))
- v))
-(test -3 call-with-current-continuation
- (lambda (exit)
- (for-each (lambda (x) (if (negative? x) (exit x)))
- '(54 0 37 -3 245 19))
- #t))
-(define list-length
- (lambda (obj)
- (call-with-current-continuation
- (lambda (return)
- (letrec ((r (lambda (obj) (cond ((null? obj) 0)
- ((pair? obj) (+ (r (cdr obj)) 1))
- (else (return #f))))))
- (r obj))))))
-(test 4 list-length '(1 2 3 4))
-(test #f list-length '(a b . c))
-(test '() map cadr '())
-
-;;; This tests full conformance of call-with-current-continuation. It
-;;; is a separate test because some schemes do not support call/cc
-;;; other than escape procedures. I am indebted to
-;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
-;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
-;;; trees constructed of conses.
-(define (next-leaf-generator obj eot)
- (letrec ((return #f)
- (cont (lambda (x)
- (recur obj)
- (set! cont (lambda (x) (return eot)))
- (cont #f)))
- (recur (lambda (obj)
- (if (pair? obj)
- (for-each recur obj)
- (call-with-current-continuation
- (lambda (c)
- (set! cont c)
- (return obj)))))))
- (lambda () (call-with-current-continuation
- (lambda (ret) (set! return ret) (cont #f))))))
-(define (leaf-eq? x y)
- (let* ((eot (list 'eot))
- (xf (next-leaf-generator x eot))
- (yf (next-leaf-generator y eot)))
- (letrec ((loop (lambda (x y)
- (cond ((not (eq? x y)) #f)
- ((eq? eot x) #t)
- (else (loop (xf) (yf)))))))
- (loop (xf) (yf)))))
-(define (test-cont)
- (SECTION 6 9)
- (test #t leaf-eq? '(a (b (c))) '((a) b c))
- (test #f leaf-eq? '(a (b (c))) '((a) b c d))
- (report-errs))
-
-;;; Test Optional R4RS DELAY syntax and FORCE procedure
-(define (test-delay)
- (SECTION 6 9)
- (test 3 'delay (force (delay (+ 1 2))))
- (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
- (list (force p) (force p))))
- (test 2 'delay (letrec ((a-stream
- (letrec ((next (lambda (n)
- (cons n (delay (next (+ n 1)))))))
- (next 0)))
- (head car)
- (tail (lambda (stream) (force (cdr stream)))))
- (head (tail (tail a-stream)))))
- (letrec ((count 0)
- (p (delay (begin (set! count (+ count 1))
- (if (> count x)
- count
- (force p)))))
- (x 5))
- (test 6 force p)
- (set! x 10)
- (test 6 force p))
- (test 3 'force
- (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
- (c #f))
- (force p)))
- (report-errs))
-
-(SECTION 6 10 1)
-(test #t input-port? (current-input-port))
-(test #t output-port? (current-output-port))
-(test #t call-with-input-file (data-file "tests/r4rs.test") input-port?)
-(define this-file (open-input-file (data-file "tests/r4rs.test")))
-(test #t input-port? this-file)
-(SECTION 6 10 2)
-(test #\; peek-char this-file)
-(test #\; read-char this-file)
-(test '(define cur-section '()) read this-file)
-(test #\( peek-char this-file)
-(test '(define errs '()) read this-file)
-(close-input-port this-file)
-(close-input-port this-file)
-(define (check-test-file name)
- (define test-file (open-input-file name))
- (test #t 'input-port?
- (call-with-input-file
- name
- (lambda (test-file)
- (test load-test-obj read test-file)
- (test #t eof-object? (peek-char test-file))
- (test #t eof-object? (read-char test-file))
- (input-port? test-file))))
- (test #\; read-char test-file)
- (test display-test-obj read test-file)
- (test load-test-obj read test-file)
- (close-input-port test-file))
-(SECTION 6 10 3)
-(define write-test-obj
- '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
-(define display-test-obj
- '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
-(define load-test-obj
- (list 'define 'foo (list 'quote write-test-obj)))
-(test #t call-with-output-file
- "tmp1"
- (lambda (test-file)
- (write-char #\; test-file)
- (display write-test-obj test-file)
- (newline test-file)
- (write load-test-obj test-file)
- (output-port? test-file)))
-(check-test-file "tmp1")
-
-(define test-file (open-output-file "tmp2"))
-(write-char #\; test-file)
-(display write-test-obj test-file)
-(newline test-file)
-(write load-test-obj test-file)
-(test #t output-port? test-file)
-(close-output-port test-file)
-(check-test-file "tmp2")
-(define (test-sc4)
- (SECTION 6 7)
- (test '(#\P #\space #\l) string->list "P l")
- (test '() string->list "")
- (test "1\\\"" list->string '(#\1 #\\ #\"))
- (test "" list->string '())
- (SECTION 6 8)
- (test '(dah dah didah) vector->list '#(dah dah didah))
- (test '() vector->list '#())
- (test '#(dididit dah) list->vector '(dididit dah))
- (test '#() list->vector '())
- (SECTION 6 10 4)
- (load (data-file "tmp1"))
- (test write-test-obj 'load foo)
- (report-errs))
-
-(report-errs)
-(if (and (string->number "0.0") (inexact? (string->number "0.0")))
- (test-inexact))
-
-(let ((n (string->number "281474976710655")))
- (if (and n (exact? n))
- (test-bignum)))
-(test-cont)
-(test-sc4)
-(test-delay)
-"last item in file"