1233 lines
35 KiB
Scheme
1233 lines
35 KiB
Scheme
;; 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
|
|
;; 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.
|
|
;;
|
|
;; To receive a copy of the GNU General Public License, write to the
|
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA; or view
|
|
;; http://swissnet.ai.mit.edu/~jaffer/GPL.html
|
|
|
|
;;;; "r4rstest.scm" Test correctness of scheme implementations.
|
|
;;; Author: Aubrey Jaffer
|
|
|
|
;;; 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 "r4rstest.scm".
|
|
;;; 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
|
|
;;; "r4rstest.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 agj @ alum.mit.edu
|
|
|
|
(define cur-section '())(define errs '())
|
|
(define SECTION (lambda args
|
|
(display "SECTION") (write args) (newline)
|
|
(set! cur-section args) #t))
|
|
(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
|
|
|
|
(define test
|
|
(lambda (expect fun . args)
|
|
(write (cons fun args))
|
|
(display " ==> ")
|
|
((lambda (res)
|
|
(write res)
|
|
(newline)
|
|
(cond ((not (equal? expect res))
|
|
(record-error (list res expect (cons fun args)))
|
|
(display " BUT EXPECTED ")
|
|
(write expect)
|
|
(newline)
|
|
#f)
|
|
(else #t)))
|
|
(if (procedure? fun) (apply fun args) (car args)))))
|
|
(define (report-errs)
|
|
(newline)
|
|
(if (null? errs) (display "Passed all tests")
|
|
(begin
|
|
(display "errors were:")
|
|
(newline)
|
|
(display "(SECTION (got expected (call)))")
|
|
(newline)
|
|
(for-each (lambda (l) (write l) (newline))
|
|
errs)))
|
|
(newline))
|
|
|
|
(SECTION 2 1);; test that all symbol characters are supported.
|
|
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
|
|
|
|
(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) record-error "test" "" 'test '#() '#(a b c) ))
|
|
(define i 1)
|
|
(for-each (lambda (x) (display (make-string i #\ ))
|
|
(set! i (+ 3 i))
|
|
(write x)
|
|
(newline))
|
|
disjoint-type-functions)
|
|
(define type-matrix
|
|
(map (lambda (x)
|
|
(let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
|
|
(write t)
|
|
(write x)
|
|
(newline)
|
|
t))
|
|
type-examples))
|
|
(set! i 0)
|
|
(define j 0)
|
|
(for-each (lambda (x y)
|
|
(set! j (+ 1 j))
|
|
(set! i 0)
|
|
(for-each (lambda (f)
|
|
(set! i (+ 1 i))
|
|
(cond ((and (= i j))
|
|
(cond ((not (f x)) (test #t f x))))
|
|
((f x) (test #f f x)))
|
|
(cond ((and (= i j))
|
|
(cond ((not (f y)) (test #t f y))))
|
|
((f y) (test #f f y))))
|
|
disjoint-type-functions))
|
|
(list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
|
|
(list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
|
|
(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)
|
|
(define (s x) (if x (let () (set! s x) (set! x s))))
|
|
(SECTION 4 2 3)
|
|
(define x 0)
|
|
(test 6 'begin (begin (set! x (begin (begin 5)))
|
|
(begin ((begin +) (begin x) (begin (begin 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)))))
|
|
;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US>
|
|
(test -1 'let (let ((f -)) (let f ((n (f 1))) n)))
|
|
|
|
(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)))
|
|
(define old-+ +)
|
|
(begin (begin (begin)
|
|
(begin (begin (begin) (define + (lambda (x y) (list y x)))
|
|
(begin)))
|
|
(begin))
|
|
(begin)
|
|
(begin (begin (begin) (test '(3 6) add3 6)
|
|
(begin))))
|
|
(set! + old-+)
|
|
(test 9 add3 6)
|
|
(begin)
|
|
(begin (begin))
|
|
(begin (begin (begin (begin))))
|
|
(SECTION 5 2 2)
|
|
(test 45 'define
|
|
(let ((x 5))
|
|
(begin (begin (begin)
|
|
(begin (begin (begin) (define foo (lambda (y) (bar x y)))
|
|
(begin)))
|
|
(begin))
|
|
(begin)
|
|
(begin)
|
|
(begin (define bar (lambda (a b) (+ (* a b) a))))
|
|
(begin))
|
|
(begin)
|
|
(begin (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)
|
|
(test 99 'internal-define (letrec ((foo (lambda (arg)
|
|
(or arg (and (procedure? foo)
|
|
(foo 99))))))
|
|
(define bar (foo #f))
|
|
(foo #f)))
|
|
(test 77 'internal-define (letrec ((foo 77)
|
|
(bar #f)
|
|
(retfoo (lambda () foo)))
|
|
(define baz (retfoo))
|
|
(retfoo)))
|
|
(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))
|
|
|
|
(define test-eq?-eqv?-agreement
|
|
(lambda (obj1 obj2)
|
|
(cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
|
|
(else
|
|
(record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2)))
|
|
(display "eqv? and eq? disagree about ")
|
|
(write obj1)
|
|
(display #\ )
|
|
(write obj2)
|
|
(newline)))))
|
|
|
|
(test-eq?-eqv?-agreement '#f '#f)
|
|
(test-eq?-eqv?-agreement '#t '#t)
|
|
(test-eq?-eqv?-agreement '#t '#f)
|
|
(test-eq?-eqv?-agreement '(a) '(a))
|
|
(test-eq?-eqv?-agreement '(a) '(b))
|
|
(test-eq?-eqv?-agreement car car)
|
|
(test-eq?-eqv?-agreement car cdr)
|
|
(test-eq?-eqv?-agreement (list 'a) (list 'a))
|
|
(test-eq?-eqv?-agreement (list 'a) (list 'b))
|
|
(test-eq?-eqv?-agreement '#(a) '#(a))
|
|
(test-eq?-eqv?-agreement '#(a) '#(b))
|
|
(test-eq?-eqv?-agreement "abc" "abc")
|
|
(test-eq?-eqv?-agreement "abc" "abz")
|
|
|
|
(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))
|
|
(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)))))
|
|
(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"))
|
|
(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")
|
|
|
|
(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)
|
|
(test 0 modulo 0 86400)
|
|
(test 0 modulo 0 -86400)
|
|
(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)
|
|
|
|
(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)
|
|
(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 lto load-test-obj)
|
|
(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 '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))
|
|
(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)
|
|
(test 1 expt 0 0)
|
|
(test 0 expt 0 1)
|
|
(test (atan 1) atan 1 1)
|
|
(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
|
|
(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 #\; test-file)
|
|
(display ";" test-file)
|
|
(write 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! 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-inexact-printing)
|
|
(let ((f0.0 (string->number "0.0"))
|
|
(f0.5 (string->number "0.5"))
|
|
(f1.0 (string->number "1.0"))
|
|
(f2.0 (string->number "2.0")))
|
|
(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) 1)))
|
|
(f (/ x (expt 2 e))))
|
|
(list f e))))
|
|
|
|
(define float-precision
|
|
(let ((mantissa-bits
|
|
(do ((i 0 (+ i 1))
|
|
(eps f1.0 (* f0.5 eps)))
|
|
((= f1.0 (+ f1.0 eps))
|
|
i)))
|
|
(minval
|
|
(do ((x f1.0 (* f0.5 x)))
|
|
((zero? (* f0.5 x)) x))))
|
|
(lambda (x)
|
|
(apply (lambda (f e)
|
|
(let ((eps
|
|
(cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
|
|
((zero? f) minval)
|
|
(else (expt f2.0 (- e mantissa-bits))))))
|
|
(if (zero? eps) ;Happens if gradual underflow.
|
|
minval
|
|
eps)))
|
|
(slow-frexp x)))))
|
|
|
|
(define (float-print-test x)
|
|
(define (testit number)
|
|
(eqv? number (string->number (number->string number))))
|
|
(let ((eps (float-precision x))
|
|
(all-ok? #t))
|
|
(do ((j -100 (+ j 1)))
|
|
((or (not all-ok?) (> j 100)) all-ok?)
|
|
(let* ((xx (+ x (* j eps)))
|
|
(ok? (testit xx)))
|
|
(cond ((not ok?)
|
|
(display "Number readback failure for ")
|
|
(display `(+ ,x (* ,j ,eps)))
|
|
(newline)
|
|
(display xx)
|
|
(newline)
|
|
(set! all-ok? #f))
|
|
;; (else (display xx) (newline))
|
|
)))))
|
|
|
|
(define (mult-float-print-test x)
|
|
(let ((res #t))
|
|
(for-each
|
|
(lambda (mult)
|
|
(or (float-print-test (* mult x)) (set! res #f)))
|
|
(map string->number
|
|
'("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
|
|
"0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
|
|
res))
|
|
|
|
(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
|
|
(string->number "3.0")))
|
|
(test #t 'mult-float-print-test (mult-float-print-test
|
|
(string->number "7.0")))
|
|
(test #t 'mult-float-print-test (mult-float-print-test
|
|
(string->number "3.1415926535897931")))
|
|
(test #t 'mult-float-print-test (mult-float-print-test
|
|
(string->number "2.7182818284590451")))))
|
|
|
|
(define (test-bignum)
|
|
(define tb
|
|
(lambda (n1 n2)
|
|
(= n1 (+ (* n2 (quotient n1 n2))
|
|
(remainder n1 n2)))))
|
|
(newline)
|
|
(display ";testing bignums; ")
|
|
(newline)
|
|
(SECTION 6 5 7)
|
|
(test 0 modulo 33333333333333333333 3)
|
|
(test 0 modulo 33333333333333333333 -3)
|
|
(test 0 remainder 33333333333333333333 3)
|
|
(test 0 remainder 33333333333333333333 -3)
|
|
(test 2 modulo 33333333333333333332 3)
|
|
(test -1 modulo 33333333333333333332 -3)
|
|
(test 2 remainder 33333333333333333332 3)
|
|
(test 2 remainder 33333333333333333332 -3)
|
|
(test 1 modulo -33333333333333333332 3)
|
|
(test -2 modulo -33333333333333333332 -3)
|
|
(test -2 remainder -33333333333333333332 3)
|
|
(test -2 remainder -33333333333333333332 -3)
|
|
|
|
(test 3 modulo 3 33333333333333333333)
|
|
(test 33333333333333333330 modulo -3 33333333333333333333)
|
|
(test 3 remainder 3 33333333333333333333)
|
|
(test -3 remainder -3 33333333333333333333)
|
|
(test -33333333333333333330 modulo 3 -33333333333333333333)
|
|
(test -3 modulo -3 -33333333333333333333)
|
|
(test 3 remainder 3 -33333333333333333333)
|
|
(test -3 remainder -3 -33333333333333333333)
|
|
|
|
(test 0 modulo -2177452800 86400)
|
|
(test 0 modulo 2177452800 -86400)
|
|
(test 0 modulo 2177452800 86400)
|
|
(test 0 modulo -2177452800 -86400)
|
|
(test 0 modulo 0 -2177452800)
|
|
(test #t 'remainder (tb 281474976710655325431 65535))
|
|
(test #t 'remainder (tb 281474976710655325430 65535))
|
|
|
|
(SECTION 6 5 8)
|
|
(test 281474976710655325431 string->number "281474976710655325431")
|
|
(test "281474976710655325431" number->string 281474976710655325431)
|
|
(report-errs))
|
|
|
|
(define (test-numeric-predicates)
|
|
(let* ((big-ex (expt 2 90))
|
|
(big-inex (exact->inexact big-ex)))
|
|
(newline)
|
|
(display ";testing bignum-inexact comparisons;")
|
|
(newline)
|
|
(SECTION 6 5 5)
|
|
(test #f = (+ big-ex 1) big-inex (- big-ex 1))
|
|
(test #f = big-inex (+ big-ex 1) (- big-ex 1))
|
|
(test #t < (- (inexact->exact big-inex) 1)
|
|
big-inex
|
|
(+ (inexact->exact big-inex) 1))))
|
|
|
|
|
|
(SECTION 6 5 9)
|
|
(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 "+")
|
|
(test #t 'string->number (or (not (string->number "80000000" 16))
|
|
(positive? (string->number "80000000" 16))))
|
|
(test #t 'string->number (or (not (string->number "-80000000" 16))
|
|
(negative? (string->number "-80000000" 16))))
|
|
|
|
(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 '(1 2 3) map + '(1 2 3))
|
|
(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))
|
|
(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)
|
|
(newline)
|
|
(display ";testing continuations; ")
|
|
(newline)
|
|
(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)
|
|
(newline)
|
|
(display ";testing DELAY and FORCE; ")
|
|
(newline)
|
|
(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 "r4rstest.scm" input-port?)
|
|
(define this-file (open-input-file "r4rstest.scm"))
|
|
(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 #\; read-char test-file)
|
|
(test #\; read-char test-file)
|
|
(test write-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 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 #\; test-file)
|
|
(display ";" test-file)
|
|
(write 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 #\; test-file)
|
|
(display ";" test-file)
|
|
(write 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)
|
|
(newline)
|
|
(display ";testing scheme 4 functions; ")
|
|
(newline)
|
|
(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 "tmp1")
|
|
(test write-test-obj 'load foo)
|
|
(report-errs))
|
|
|
|
(report-errs)
|
|
(let ((have-inexacts?
|
|
(and (string->number "0.0") (inexact? (string->number "0.0"))))
|
|
(have-bignums?
|
|
(let ((n (string->number "281474976710655325431")))
|
|
(and n (exact? n)))))
|
|
(cond (have-inexacts?
|
|
(test-inexact)
|
|
(test-inexact-printing)))
|
|
(if have-bignums? (test-bignum))
|
|
(if (and have-inexacts? have-bignums?)
|
|
(test-numeric-predicates)))
|
|
|
|
(newline)
|
|
(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
|
|
(newline)
|
|
(display "(test-cont) (test-sc4) (test-delay)")
|
|
(newline)
|
|
"last item in file"
|