/[guile]/guile/guile-core/test-suite/tests/r4rs.test
ViewVC logotype

Diff of /guile/guile-core/test-suite/tests/r4rs.test

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by jimb, Sun Aug 1 08:06:15 1999 UTC revision 1.3.6.1 by ttn, Sat Feb 9 23:12:46 2002 UTC
# Line 1  Line 1 
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,
# Line 38  Line 38 
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 =============
# Line 75  Line 75 
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    
# Line 235  Line 235 
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))))
# Line 873  Line 873 
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)
# Line 935  Line 935 
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)
# Line 997  Line 997 
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    

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.3.6.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26