summaryrefslogtreecommitdiffstats
path: root/r4rstest.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commitc7d035ae1a729232579a0fe41ed5affa131d3623 (patch)
treefb387f7c2a8e01cf603d4c75fbbaa68f711df986 /r4rstest.scm
parentdeda2c0fd8689349fea2a900199a76ff7ecb319e (diff)
downloadscm-c7d035ae1a729232579a0fe41ed5affa131d3623.tar.gz
scm-c7d035ae1a729232579a0fe41ed5affa131d3623.zip
Import Upstream version 5d9upstream/5d9
Diffstat (limited to 'r4rstest.scm')
-rw-r--r--r4rstest.scm67
1 files changed, 44 insertions, 23 deletions
diff --git a/r4rstest.scm b/r4rstest.scm
index 3683f0d..f6f3ae0 100644
--- a/r4rstest.scm
+++ b/r4rstest.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 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
@@ -30,16 +30,16 @@
;;; 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
+;;; send corrections or additions to agj @ alum.mit.edu
(define cur-section '())(define errs '())
(define SECTION (lambda args
@@ -224,7 +224,7 @@
`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
;;; sqt is defined here because not all implementations are required to
-;;; support it.
+;;; support it.
(define (sqt x)
(do ((i 0 (+ i 1)))
((> (* i i) x) (- i 1))))
@@ -557,6 +557,21 @@
(test 288 lcm 32 -36)
(test 1 lcm)
+(SECTION 6 5 5)
+;;; Implementations which don't allow division by 0 can have fragile
+;;; string->number.
+(define (test-string->number str)
+ (define ans (string->number str))
+ (cond ((not ans) #t) ((number? ans) #t) (else ans)))
+(for-each (lambda (str) (test #t test-string->number str))
+ '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
+ "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
+ "#i" "#e" "#" "#i0/0"))
+(cond ((number? (string->number "1+1i")) ;More kawa bait
+ (test #t number? (string->number "#i-i"))
+ (test #t number? (string->number "#i+i"))
+ (test #t number? (string->number "#i2+i"))))
+
;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
;;; Modified by jaffer.
(define (test-inexact)
@@ -574,11 +589,17 @@
(newline)
(display ";testing inexact numbers; ")
(newline)
+ (SECTION 6 2)
+ (test #f eqv? 1 f1.0)
+ (test #f eqv? 0 f0.0)
(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 #t 'max (inexact? (max f3.9 4)))
+ (test f4.0 max f3.9 4)
+ (test f4.0 exact->inexact 4)
+ (test f4.0 exact->inexact 4.0)
+ (test 4 inexact->exact 4)
+ (test 4 inexact->exact 4.0)
(test (- f4.0) round (- f4.5))
(test (- f4.0) round (- f3.5))
(test (- f4.0) round (- f3.9))
@@ -618,14 +639,14 @@
(define log2
(let ((l2 (log 2)))
(lambda (x) (/ (log x) l2))))
-
+
(define (slow-frexp x)
(if (zero? x)
(list f0.0 0)
(let* ((l2 (log2 x))
(e (floor (log2 x)))
(e (if (= l2 e)
- (inexact->exact e)
+ (inexact->exact e)
(+ (inexact->exact e) 1)))
(f (/ x (expt 2 e))))
(list f e))))
@@ -649,7 +670,7 @@
minval
eps)))
(slow-frexp x)))))
-
+
(define (float-print-test x)
(define (testit number)
(eqv? number (string->number (number->string number))))
@@ -671,7 +692,7 @@
(define (mult-float-print-test x)
(let ((res #t))
- (for-each
+ (for-each
(lambda (mult)
(or (float-print-test (* mult x)) (set! res #f)))
(map string->number
@@ -682,7 +703,7 @@
(SECTION 6 5 6)
(test #t 'float-print-test (float-print-test f0.0))
(test #t 'mult-float-print-test (mult-float-print-test f1.0))
- (test #t 'mult-float-print-test (mult-float-print-test
+ (test #t 'mult-float-print-test (mult-float-print-test
(string->number "3.0")))
(test #t 'mult-float-print-test (mult-float-print-test
(string->number "7.0")))
@@ -1023,15 +1044,15 @@
(test '(1 2 3) map * '(1 2 3))
(test '(-1 -2 -3) map - '(1 2 3))
(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))
+ (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))
+ (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
@@ -1049,7 +1070,7 @@
;;; 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.
+;;; trees constructed of conses.
(define (next-leaf-generator obj eot)
(letrec ((return #f)
(cont (lambda (x)
@@ -1191,7 +1212,7 @@
(report-errs))
(report-errs)
-(let ((have-inexacts?
+(let ((have-inexacts?
(and (string->number "0.0") (inexact? (string->number "0.0"))))
(have-bignums?
(let ((n (string->number "281474976710655325431")))