-;; 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.
+;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*-
+;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-r4rs)
+ :use-module (test-suite lib)
+ :use-module (test-suite guile-test))
+
+
+;;;; ============= 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.
+;;;; 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.
;;; send corrections or additions to jaffer@ai.mit.edu or
;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+;; Note: The following two expressions are being read as part of the tests in
+;; section (6 10 2). Those tests expect that above the following two
+;; expressions there should be only one arbitrary s-expression (which is the
+;; define-module expression). Further, the two expressions should be written
+;; on one single line without a blank between them. If you change this, you
+;; will also have to change the corresponding tests in section (6 10 2).
+
(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))))
(list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
(list
- #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
-(define i 1)
+ #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))
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ t))
type-examples))
-(for-each (lambda (predicate row)
- (let ((count (apply + (map (lambda (elt) (if elt 1 0))
- row))))
- (pass-if (call-with-output-string
- (lambda (port)
- (display "predicate is disjoint: " port)
- (display predicate port)))
- (= count 1))))
- disjoint-type-functions
- type-matrix)
+(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))
(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"
+ (data-file-name "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")
+ (check-test-file (data-file-name "tmp3"))
(set! write-test-obj wto)
(set! display-test-obj dto)
(set! load-test-obj lto)
(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 call-with-input-file (test-file-name "r4rs.test") input-port?)
+(define this-file (open-input-file (test-file-name "r4rs.test")))
(test #t input-port? this-file)
(SECTION 6 10 2)
(test #\; peek-char this-file)
(test #\; read-char this-file)
+(read this-file) ;; skip define-module expression
(test '(define cur-section '()) read this-file)
(test #\( peek-char this-file)
(test '(define errs '()) read this-file)
(define load-test-obj
(list 'define 'foo (list 'quote write-test-obj)))
(test #t call-with-output-file
- "tmp1"
+ (data-file-name "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")
+(check-test-file (data-file-name "tmp1"))
-(define test-file (open-output-file "tmp2"))
+(define test-file (open-output-file (data-file-name "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")
+(check-test-file (data-file-name "tmp2"))
(define (test-sc4)
(SECTION 6 7)
(test '(#\P #\space #\l) string->list "P l")
(test '#(dididit dah) list->vector '(dididit dah))
(test '#() list->vector '())
(SECTION 6 10 4)
- (load (data-file "tmp1"))
+ (load (data-file-name "tmp1"))
(test write-test-obj 'load foo)
(report-errs))
(test-sc4)
(test-delay)
"last item in file"
+
+(delete-file (data-file-name "tmp1"))
+(delete-file (data-file-name "tmp2"))
+(delete-file (data-file-name "tmp3"))
HCoop / bpt / guile.git / blobdiff