1 |
;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- |
;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*- |
2 |
;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999 Free Software Foundation, Inc. |
;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999 Free Software Foundation, Inc. |
3 |
;;;; |
;;;; |
4 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; This program is free software; you can redistribute it and/or modify |
5 |
;;;; it under the terms of the GNU General Public License as published by |
;;;; it under the terms of the GNU General Public License as published by |
6 |
;;;; the Free Software Foundation; either version 2, or (at your option) |
;;;; the Free Software Foundation; either version 2, or (at your option) |
7 |
;;;; any later version. |
;;;; any later version. |
8 |
;;;; |
;;;; |
9 |
;;;; This program is distributed in the hope that it will be useful, |
;;;; This program is distributed in the hope that it will be useful, |
10 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
12 |
;;;; GNU General Public License for more details. |
;;;; GNU General Public License for more details. |
13 |
;;;; |
;;;; |
14 |
;;;; You should have received a copy of the GNU General Public License |
;;;; You should have received a copy of the GNU General Public License |
15 |
;;;; along with this software; see the file COPYING. If not, write to |
;;;; along with this software; see the file COPYING. If not, write to |
16 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
38 |
;;;; |
;;;; |
39 |
;;;; If you write modifications of your own for GUILE, it is your choice |
;;;; If you write modifications of your own for GUILE, it is your choice |
40 |
;;;; whether to permit this exception to apply to your modifications. |
;;;; whether to permit this exception to apply to your modifications. |
41 |
;;;; If you do not wish that, delete this exception notice. |
;;;; If you do not wish that, delete this exception notice. |
42 |
|
|
43 |
|
|
44 |
;;;; ============= NOTE ============= |
;;;; ============= NOTE ============= |
75 |
|
|
76 |
;;; There are three optional tests: |
;;; There are three optional tests: |
77 |
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation |
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation |
78 |
;;; |
;;; |
79 |
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE |
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE |
80 |
;;; |
;;; |
81 |
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by |
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by |
82 |
;;; either standard. |
;;; either standard. |
83 |
|
|
235 |
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) |
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) |
236 |
|
|
237 |
;;; sqt is defined here because not all implementations are required to |
;;; sqt is defined here because not all implementations are required to |
238 |
;;; support it. |
;;; support it. |
239 |
(define (sqt x) |
(define (sqt x) |
240 |
(do ((i 0 (+ i 1))) |
(do ((i 0 (+ i 1))) |
241 |
((> (* i i) x) (- i 1)))) |
((> (* i i) x) (- i 1)))) |
873 |
;;; other than escape procedures. I am indebted to |
;;; other than escape procedures. I am indebted to |
874 |
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this |
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this |
875 |
;;; code. The function leaf-eq? compares the leaves of 2 arbitrary |
;;; code. The function leaf-eq? compares the leaves of 2 arbitrary |
876 |
;;; trees constructed of conses. |
;;; trees constructed of conses. |
877 |
(define (next-leaf-generator obj eot) |
(define (next-leaf-generator obj eot) |
878 |
(letrec ((return #f) |
(letrec ((return #f) |
879 |
(cont (lambda (x) |
(cont (lambda (x) |
935 |
(SECTION 6 10 1) |
(SECTION 6 10 1) |
936 |
(test #t input-port? (current-input-port)) |
(test #t input-port? (current-input-port)) |
937 |
(test #t output-port? (current-output-port)) |
(test #t output-port? (current-output-port)) |
938 |
(test #t call-with-input-file (data-file "tests/r4rs.test") input-port?) |
(test #t call-with-input-file (test-file-name "r4rs.test") input-port?) |
939 |
(define this-file (open-input-file (data-file "tests/r4rs.test"))) |
(define this-file (open-input-file (test-file-name "r4rs.test"))) |
940 |
(test #t input-port? this-file) |
(test #t input-port? this-file) |
941 |
(SECTION 6 10 2) |
(SECTION 6 10 2) |
942 |
(test #\; peek-char this-file) |
(test #\; peek-char this-file) |
997 |
(test '#(dididit dah) list->vector '(dididit dah)) |
(test '#(dididit dah) list->vector '(dididit dah)) |
998 |
(test '#() list->vector '()) |
(test '#() list->vector '()) |
999 |
(SECTION 6 10 4) |
(SECTION 6 10 4) |
1000 |
(load (data-file "tmp1")) |
(load (data-file-name "tmp1")) |
1001 |
(test write-test-obj 'load foo) |
(test write-test-obj 'load foo) |
1002 |
(report-errs)) |
(report-errs)) |
1003 |
|
|