| 1 | ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 Free Software Foundation, Inc. |
| 2 | ;; |
| 3 | ;; This library is free software; you can redistribute it and/or |
| 4 | ;; modify it under the terms of the GNU Lesser General Public |
| 5 | ;; License as published by the Free Software Foundation; either |
| 6 | ;; version 2.1 of the License, or (at your option) any later version. |
| 7 | ;; |
| 8 | ;; This library is distributed in the hope that it will be useful, |
| 9 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 11 | ;; Lesser General Public License for more details. |
| 12 | ;; |
| 13 | ;; You should have received a copy of the GNU Lesser General Public |
| 14 | ;; License along with this library; if not, write to the Free Software |
| 15 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
| 16 | |
| 17 | ;;;; "test.scm" Test correctness of scheme implementations. |
| 18 | ;;; Author: Aubrey Jaffer |
| 19 | ;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately |
| 20 | ;;; won't pass. Made the the tests (test-cont), (test-sc4), and |
| 21 | ;;; (test-delay) start to run automatically. |
| 22 | |
| 23 | ;;; This includes examples from |
| 24 | ;;; William Clinger and Jonathan Rees, editors. |
| 25 | ;;; Revised^4 Report on the Algorithmic Language Scheme |
| 26 | ;;; and the IEEE specification. |
| 27 | |
| 28 | ;;; The input tests read this file expecting it to be named |
| 29 | ;;; "test.scm", so you'll have to run it from the ice-9 source |
| 30 | ;;; directory, or copy this file elsewhere |
| 31 | ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running |
| 32 | ;;; these tests. You may need to delete them in order to run |
| 33 | ;;; "test.scm" more than once. |
| 34 | |
| 35 | ;;; There are three optional tests: |
| 36 | ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation |
| 37 | ;;; |
| 38 | ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE |
| 39 | ;;; |
| 40 | ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by |
| 41 | ;;; either standard. |
| 42 | |
| 43 | ;;; If you are testing a R3RS version which does not have `list?' do: |
| 44 | ;;; (define list? #f) |
| 45 | |
| 46 | ;;; send corrections or additions to jaffer@ai.mit.edu or |
| 47 | ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA |
| 48 | |
| 49 | (define cur-section '())(define errs '()) |
| 50 | (define SECTION (lambda args |
| 51 | (display "SECTION") (write args) (newline) |
| 52 | (set! cur-section args) #t)) |
| 53 | (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) |
| 54 | |
| 55 | (define test |
| 56 | (lambda (expect fun . args) |
| 57 | (write (cons fun args)) |
| 58 | (display " ==> ") |
| 59 | ((lambda (res) |
| 60 | (write res) |
| 61 | (newline) |
| 62 | (cond ((not (equal? expect res)) |
| 63 | (record-error (list res expect (cons fun args))) |
| 64 | (display " BUT EXPECTED ") |
| 65 | (write expect) |
| 66 | (newline) |
| 67 | #f) |
| 68 | (else #t))) |
| 69 | (if (procedure? fun) (apply fun args) (car args))))) |
| 70 | (define (report-errs) |
| 71 | (newline) |
| 72 | (if (null? errs) (display "Passed all tests") |
| 73 | (begin |
| 74 | (display "errors were:") |
| 75 | (newline) |
| 76 | (display "(SECTION (got expected (call)))") |
| 77 | (newline) |
| 78 | (for-each (lambda (l) (write l) (newline)) |
| 79 | errs))) |
| 80 | (newline)) |
| 81 | |
| 82 | (SECTION 2 1);; test that all symbol characters are supported. |
| 83 | '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) |
| 84 | |
| 85 | (SECTION 3 4) |
| 86 | (define disjoint-type-functions |
| 87 | (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) |
| 88 | (define type-examples |
| 89 | (list |
| 90 | #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) |
| 91 | (define i 1) |
| 92 | (for-each (lambda (x) (display (make-string i #\ )) |
| 93 | (set! i (+ 3 i)) |
| 94 | (write x) |
| 95 | (newline)) |
| 96 | disjoint-type-functions) |
| 97 | (define type-matrix |
| 98 | (map (lambda (x) |
| 99 | (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) |
| 100 | (write t) |
| 101 | (write x) |
| 102 | (newline) |
| 103 | t)) |
| 104 | type-examples)) |
| 105 | (SECTION 4 1 2) |
| 106 | (test '(quote a) 'quote (quote 'a)) |
| 107 | (test '(quote a) 'quote ''a) |
| 108 | (SECTION 4 1 3) |
| 109 | (test 12 (if #f + *) 3 4) |
| 110 | (SECTION 4 1 4) |
| 111 | (test 8 (lambda (x) (+ x x)) 4) |
| 112 | (define reverse-subtract |
| 113 | (lambda (x y) (- y x))) |
| 114 | (test 3 reverse-subtract 7 10) |
| 115 | (define add4 |
| 116 | (let ((x 4)) |
| 117 | (lambda (y) (+ x y)))) |
| 118 | (test 10 add4 6) |
| 119 | (test '(3 4 5 6) (lambda x x) 3 4 5 6) |
| 120 | (test '(5 6) (lambda (x y . z) z) 3 4 5 6) |
| 121 | (SECTION 4 1 5) |
| 122 | (test 'yes 'if (if (> 3 2) 'yes 'no)) |
| 123 | (test 'no 'if (if (> 2 3) 'yes 'no)) |
| 124 | (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) |
| 125 | (SECTION 4 1 6) |
| 126 | (define x 2) |
| 127 | (test 3 'define (+ x 1)) |
| 128 | (set! x 4) |
| 129 | (test 5 'set! (+ x 1)) |
| 130 | (SECTION 4 2 1) |
| 131 | (test 'greater 'cond (cond ((> 3 2) 'greater) |
| 132 | ((< 3 2) 'less))) |
| 133 | (test 'equal 'cond (cond ((> 3 3) 'greater) |
| 134 | ((< 3 3) 'less) |
| 135 | (else 'equal))) |
| 136 | (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) |
| 137 | (else #f))) |
| 138 | (test 'composite 'case (case (* 2 3) |
| 139 | ((2 3 5 7) 'prime) |
| 140 | ((1 4 6 8 9) 'composite))) |
| 141 | (test 'consonant 'case (case (car '(c d)) |
| 142 | ((a e i o u) 'vowel) |
| 143 | ((w y) 'semivowel) |
| 144 | (else 'consonant))) |
| 145 | (test #t 'and (and (= 2 2) (> 2 1))) |
| 146 | (test #f 'and (and (= 2 2) (< 2 1))) |
| 147 | (test '(f g) 'and (and 1 2 'c '(f g))) |
| 148 | (test #t 'and (and)) |
| 149 | (test #t 'or (or (= 2 2) (> 2 1))) |
| 150 | (test #t 'or (or (= 2 2) (< 2 1))) |
| 151 | (test #f 'or (or #f #f #f)) |
| 152 | (test #f 'or (or)) |
| 153 | (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) |
| 154 | (SECTION 4 2 2) |
| 155 | (test 6 'let (let ((x 2) (y 3)) (* x y))) |
| 156 | (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) |
| 157 | (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) |
| 158 | (test #t 'letrec (letrec ((even? |
| 159 | (lambda (n) (if (zero? n) #t (odd? (- n 1))))) |
| 160 | (odd? |
| 161 | (lambda (n) (if (zero? n) #f (even? (- n 1)))))) |
| 162 | (even? 88))) |
| 163 | (define x 34) |
| 164 | (test 5 'let (let ((x 3)) (define x 5) x)) |
| 165 | (test 34 'let x) |
| 166 | (test 6 'let (let () (define x 6) x)) |
| 167 | (test 34 'let x) |
| 168 | (test 7 'let* (let* ((x 3)) (define x 7) x)) |
| 169 | (test 34 'let* x) |
| 170 | (test 8 'let* (let* () (define x 8) x)) |
| 171 | (test 34 'let* x) |
| 172 | (test 9 'letrec (letrec () (define x 9) x)) |
| 173 | (test 34 'letrec x) |
| 174 | (test 10 'letrec (letrec ((x 3)) (define x 10) x)) |
| 175 | (test 34 'letrec x) |
| 176 | (SECTION 4 2 3) |
| 177 | (define x 0) |
| 178 | (test 6 'begin (begin (set! x 5) (+ x 1))) |
| 179 | (SECTION 4 2 4) |
| 180 | (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) |
| 181 | (i 0 (+ i 1))) |
| 182 | ((= i 5) vec) |
| 183 | (vector-set! vec i i))) |
| 184 | (test 25 'do (let ((x '(1 3 5 7 9))) |
| 185 | (do ((x x (cdr x)) |
| 186 | (sum 0 (+ sum (car x)))) |
| 187 | ((null? x) sum)))) |
| 188 | (test 1 'let (let foo () 1)) |
| 189 | (test '((6 1 3) (-5 -2)) 'let |
| 190 | (let loop ((numbers '(3 -2 1 6 -5)) |
| 191 | (nonneg '()) |
| 192 | (neg '())) |
| 193 | (cond ((null? numbers) (list nonneg neg)) |
| 194 | ((negative? (car numbers)) |
| 195 | (loop (cdr numbers) |
| 196 | nonneg |
| 197 | (cons (car numbers) neg))) |
| 198 | (else |
| 199 | (loop (cdr numbers) |
| 200 | (cons (car numbers) nonneg) |
| 201 | neg))))) |
| 202 | (SECTION 4 2 6) |
| 203 | (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) |
| 204 | (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) |
| 205 | (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) |
| 206 | (test '((foo 7) . cons) |
| 207 | 'quasiquote |
| 208 | `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) |
| 209 | |
| 210 | ;;; sqt is defined here because not all implementations are required to |
| 211 | ;;; support it. |
| 212 | (define (sqt x) |
| 213 | (do ((i 0 (+ i 1))) |
| 214 | ((> (* i i) x) (- i 1)))) |
| 215 | |
| 216 | (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) |
| 217 | (test 5 'quasiquote `,(+ 2 3)) |
| 218 | (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) |
| 219 | 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) |
| 220 | (test '(a `(b ,x ,'y d) e) 'quasiquote |
| 221 | (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) |
| 222 | (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) |
| 223 | (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) |
| 224 | (SECTION 5 2 1) |
| 225 | (define add3 (lambda (x) (+ x 3))) |
| 226 | (test 6 'define (add3 3)) |
| 227 | (define first car) |
| 228 | (test 1 'define (first '(1 2))) |
| 229 | (SECTION 5 2 2) |
| 230 | (test 45 'define |
| 231 | (let ((x 5)) |
| 232 | (define foo (lambda (y) (bar x y))) |
| 233 | (define bar (lambda (a b) (+ (* a b) a))) |
| 234 | (foo (+ x 3)))) |
| 235 | (define x 34) |
| 236 | (define (foo) (define x 5) x) |
| 237 | (test 5 foo) |
| 238 | (test 34 'define x) |
| 239 | (define foo (lambda () (define x 5) x)) |
| 240 | (test 5 foo) |
| 241 | (test 34 'define x) |
| 242 | (define (foo x) ((lambda () (define x 5) x)) x) |
| 243 | (test 88 foo 88) |
| 244 | (test 4 foo 4) |
| 245 | (test 34 'define x) |
| 246 | (SECTION 6 1) |
| 247 | (test #f not #t) |
| 248 | (test #f not 3) |
| 249 | (test #f not (list 3)) |
| 250 | (test #t not #f) |
| 251 | (test #f not '()) |
| 252 | (test #f not (list)) |
| 253 | (test #f not 'nil) |
| 254 | |
| 255 | (test #t boolean? #f) |
| 256 | (test #f boolean? 0) |
| 257 | (test #f boolean? '()) |
| 258 | (SECTION 6 2) |
| 259 | (test #t eqv? 'a 'a) |
| 260 | (test #f eqv? 'a 'b) |
| 261 | (test #t eqv? 2 2) |
| 262 | (test #t eqv? '() '()) |
| 263 | (test #t eqv? '10000 '10000) |
| 264 | (test #f eqv? (cons 1 2)(cons 1 2)) |
| 265 | (test #f eqv? (lambda () 1) (lambda () 2)) |
| 266 | (test #f eqv? #f 'nil) |
| 267 | (let ((p (lambda (x) x))) |
| 268 | (test #t eqv? p p)) |
| 269 | (define gen-counter |
| 270 | (lambda () |
| 271 | (let ((n 0)) |
| 272 | (lambda () (set! n (+ n 1)) n)))) |
| 273 | (let ((g (gen-counter))) (test #t eqv? g g)) |
| 274 | (test #f eqv? (gen-counter) (gen-counter)) |
| 275 | (letrec ((f (lambda () (if (eqv? f g) 'f 'both))) |
| 276 | (g (lambda () (if (eqv? f g) 'g 'both)))) |
| 277 | (test #f eqv? f g)) |
| 278 | |
| 279 | (test #t eq? 'a 'a) |
| 280 | (test #f eq? (list 'a) (list 'a)) |
| 281 | (test #t eq? '() '()) |
| 282 | (test #t eq? car car) |
| 283 | (let ((x '(a))) (test #t eq? x x)) |
| 284 | (let ((x '#())) (test #t eq? x x)) |
| 285 | (let ((x (lambda (x) x))) (test #t eq? x x)) |
| 286 | |
| 287 | (test #t equal? 'a 'a) |
| 288 | (test #t equal? '(a) '(a)) |
| 289 | (test #t equal? '(a (b) c) '(a (b) c)) |
| 290 | (test #t equal? "abc" "abc") |
| 291 | (test #t equal? 2 2) |
| 292 | (test #t equal? (make-vector 5 'a) (make-vector 5 'a)) |
| 293 | (SECTION 6 3) |
| 294 | (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) |
| 295 | (define x (list 'a 'b 'c)) |
| 296 | (define y x) |
| 297 | (and list? (test #t list? y)) |
| 298 | (set-cdr! x 4) |
| 299 | (test '(a . 4) 'set-cdr! x) |
| 300 | (test #t eqv? x y) |
| 301 | (test '(a b c . d) 'dot '(a . (b . (c . d)))) |
| 302 | (and list? (test #f list? y)) |
| 303 | (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) |
| 304 | |
| 305 | (test #t pair? '(a . b)) |
| 306 | (test #t pair? '(a . 1)) |
| 307 | (test #t pair? '(a b c)) |
| 308 | (test #f pair? '()) |
| 309 | (test #f pair? '#(a b)) |
| 310 | |
| 311 | (test '(a) cons 'a '()) |
| 312 | (test '((a) b c d) cons '(a) '(b c d)) |
| 313 | (test '("a" b c) cons "a" '(b c)) |
| 314 | (test '(a . 3) cons 'a 3) |
| 315 | (test '((a b) . c) cons '(a b) 'c) |
| 316 | |
| 317 | (test 'a car '(a b c)) |
| 318 | (test '(a) car '((a) b c d)) |
| 319 | (test 1 car '(1 . 2)) |
| 320 | |
| 321 | (test '(b c d) cdr '((a) b c d)) |
| 322 | (test 2 cdr '(1 . 2)) |
| 323 | |
| 324 | (test '(a 7 c) list 'a (+ 3 4) 'c) |
| 325 | (test '() list) |
| 326 | |
| 327 | (test 3 length '(a b c)) |
| 328 | (test 3 length '(a (b) (c d e))) |
| 329 | (test 0 length '()) |
| 330 | |
| 331 | (test '(x y) append '(x) '(y)) |
| 332 | (test '(a b c d) append '(a) '(b c d)) |
| 333 | (test '(a (b) (c)) append '(a (b)) '((c))) |
| 334 | (test '() append) |
| 335 | (test '(a b c . d) append '(a b) '(c . d)) |
| 336 | (test 'a append '() 'a) |
| 337 | |
| 338 | (test '(c b a) reverse '(a b c)) |
| 339 | (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) |
| 340 | |
| 341 | (test 'c list-ref '(a b c d) 2) |
| 342 | |
| 343 | (test '(a b c) memq 'a '(a b c)) |
| 344 | (test '(b c) memq 'b '(a b c)) |
| 345 | (test '#f memq 'a '(b c d)) |
| 346 | (test '#f memq (list 'a) '(b (a) c)) |
| 347 | (test '((a) c) member (list 'a) '(b (a) c)) |
| 348 | (test '(101 102) memv 101 '(100 101 102)) |
| 349 | |
| 350 | (define e '((a 1) (b 2) (c 3))) |
| 351 | (test '(a 1) assq 'a e) |
| 352 | (test '(b 2) assq 'b e) |
| 353 | (test #f assq 'd e) |
| 354 | (test #f assq (list 'a) '(((a)) ((b)) ((c)))) |
| 355 | (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) |
| 356 | (test '(5 7) assv 5 '((2 3) (5 7) (11 13))) |
| 357 | (SECTION 6 4) |
| 358 | (test #t symbol? 'foo) |
| 359 | (test #t symbol? (car '(a b))) |
| 360 | (test #f symbol? "bar") |
| 361 | (test #t symbol? 'nil) |
| 362 | (test #f symbol? '()) |
| 363 | (test #f symbol? #f) |
| 364 | ;;; But first, what case are symbols in? Determine the standard case: |
| 365 | (define char-standard-case char-upcase) |
| 366 | (if (string=? (symbol->string 'A) "a") |
| 367 | (set! char-standard-case char-downcase)) |
| 368 | ;;; Not for Guile |
| 369 | ;(test #t 'standard-case |
| 370 | ; (string=? (symbol->string 'a) (symbol->string 'A))) |
| 371 | ;(test #t 'standard-case |
| 372 | ; (or (string=? (symbol->string 'a) "A") |
| 373 | ; (string=? (symbol->string 'A) "a"))) |
| 374 | (define (str-copy s) |
| 375 | (let ((v (make-string (string-length s)))) |
| 376 | (do ((i (- (string-length v) 1) (- i 1))) |
| 377 | ((< i 0) v) |
| 378 | (string-set! v i (string-ref s i))))) |
| 379 | (define (string-standard-case s) |
| 380 | (set! s (str-copy s)) |
| 381 | (do ((i 0 (+ 1 i)) |
| 382 | (sl (string-length s))) |
| 383 | ((>= i sl) s) |
| 384 | (string-set! s i (char-standard-case (string-ref s i))))) |
| 385 | ;;; Not for Guile |
| 386 | ;(test (string-standard-case "flying-fish") symbol->string 'flying-fish) |
| 387 | ;(test (string-standard-case "martin") symbol->string 'Martin) |
| 388 | (test "Malvina" symbol->string (string->symbol "Malvina")) |
| 389 | ;;; Not for Guile |
| 390 | ;(test #t 'standard-case (eq? 'a 'A)) |
| 391 | |
| 392 | (define x (string #\a #\b)) |
| 393 | (define y (string->symbol x)) |
| 394 | (string-set! x 0 #\c) |
| 395 | (test "cb" 'string-set! x) |
| 396 | (test "ab" symbol->string y) |
| 397 | (test y string->symbol "ab") |
| 398 | |
| 399 | ;;; Not for Guile |
| 400 | ;(test #t eq? 'mISSISSIppi 'mississippi) |
| 401 | ;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) |
| 402 | (test 'JollyWog string->symbol (symbol->string 'JollyWog)) |
| 403 | |
| 404 | (SECTION 6 5 5) |
| 405 | (test #t number? 3) |
| 406 | (test #t complex? 3) |
| 407 | (test #t real? 3) |
| 408 | (test #t rational? 3) |
| 409 | (test #t integer? 3) |
| 410 | |
| 411 | (test #t exact? 3) |
| 412 | (test #f inexact? 3) |
| 413 | |
| 414 | (test #t = 22 22 22) |
| 415 | (test #t = 22 22) |
| 416 | (test #f = 34 34 35) |
| 417 | (test #f = 34 35) |
| 418 | (test #t > 3 -6246) |
| 419 | (test #f > 9 9 -2424) |
| 420 | (test #t >= 3 -4 -6246) |
| 421 | (test #t >= 9 9) |
| 422 | (test #f >= 8 9) |
| 423 | (test #t < -1 2 3 4 5 6 7 8) |
| 424 | (test #f < -1 2 3 4 4 5 6 7) |
| 425 | (test #t <= -1 2 3 4 5 6 7 8) |
| 426 | (test #t <= -1 2 3 4 4 5 6 7) |
| 427 | (test #f < 1 3 2) |
| 428 | (test #f >= 1 3 2) |
| 429 | |
| 430 | (test #t zero? 0) |
| 431 | (test #f zero? 1) |
| 432 | (test #f zero? -1) |
| 433 | (test #f zero? -100) |
| 434 | (test #t positive? 4) |
| 435 | (test #f positive? -4) |
| 436 | (test #f positive? 0) |
| 437 | (test #f negative? 4) |
| 438 | (test #t negative? -4) |
| 439 | (test #f negative? 0) |
| 440 | (test #t odd? 3) |
| 441 | (test #f odd? 2) |
| 442 | (test #f odd? -4) |
| 443 | (test #t odd? -1) |
| 444 | (test #f even? 3) |
| 445 | (test #t even? 2) |
| 446 | (test #t even? -4) |
| 447 | (test #f even? -1) |
| 448 | |
| 449 | (test 38 max 34 5 7 38 6) |
| 450 | (test -24 min 3 5 5 330 4 -24) |
| 451 | |
| 452 | (test 7 + 3 4) |
| 453 | (test '3 + 3) |
| 454 | (test 0 +) |
| 455 | (test 4 * 4) |
| 456 | (test 1 *) |
| 457 | |
| 458 | (test -1 - 3 4) |
| 459 | (test -3 - 3) |
| 460 | (test 7 abs -7) |
| 461 | (test 7 abs 7) |
| 462 | (test 0 abs 0) |
| 463 | |
| 464 | (test 5 quotient 35 7) |
| 465 | (test -5 quotient -35 7) |
| 466 | (test -5 quotient 35 -7) |
| 467 | (test 5 quotient -35 -7) |
| 468 | (test 1 modulo 13 4) |
| 469 | (test 1 remainder 13 4) |
| 470 | (test 3 modulo -13 4) |
| 471 | (test -1 remainder -13 4) |
| 472 | (test -3 modulo 13 -4) |
| 473 | (test 1 remainder 13 -4) |
| 474 | (test -1 modulo -13 -4) |
| 475 | (test -1 remainder -13 -4) |
| 476 | (define (divtest n1 n2) |
| 477 | (= n1 (+ (* n2 (quotient n1 n2)) |
| 478 | (remainder n1 n2)))) |
| 479 | (test #t divtest 238 9) |
| 480 | (test #t divtest -238 9) |
| 481 | (test #t divtest 238 -9) |
| 482 | (test #t divtest -238 -9) |
| 483 | |
| 484 | (test 4 gcd 0 4) |
| 485 | (test 4 gcd -4 0) |
| 486 | (test 4 gcd 32 -36) |
| 487 | (test 0 gcd) |
| 488 | (test 288 lcm 32 -36) |
| 489 | (test 1 lcm) |
| 490 | |
| 491 | ;;;;From: fred@sce.carleton.ca (Fred J Kaudel) |
| 492 | ;;; Modified by jaffer. |
| 493 | (define (test-inexact) |
| 494 | (define f3.9 (string->number "3.9")) |
| 495 | (define f4.0 (string->number "4.0")) |
| 496 | (define f-3.25 (string->number "-3.25")) |
| 497 | (define f.25 (string->number ".25")) |
| 498 | (define f4.5 (string->number "4.5")) |
| 499 | (define f3.5 (string->number "3.5")) |
| 500 | (define f0.0 (string->number "0.0")) |
| 501 | (define f0.8 (string->number "0.8")) |
| 502 | (define f1.0 (string->number "1.0")) |
| 503 | (define wto write-test-obj) |
| 504 | (define dto display-test-obj) |
| 505 | (define lto load-test-obj) |
| 506 | (newline) |
| 507 | (display ";testing inexact numbers; ") |
| 508 | (newline) |
| 509 | (SECTION 6 5 5) |
| 510 | (test #t inexact? f3.9) |
| 511 | (test #t 'inexact? (inexact? (max f3.9 4))) |
| 512 | (test f4.0 'max (max f3.9 4)) |
| 513 | (test f4.0 'exact->inexact (exact->inexact 4)) |
| 514 | (test (- f4.0) round (- f4.5)) |
| 515 | (test (- f4.0) round (- f3.5)) |
| 516 | (test (- f4.0) round (- f3.9)) |
| 517 | (test f0.0 round f0.0) |
| 518 | (test f0.0 round f.25) |
| 519 | (test f1.0 round f0.8) |
| 520 | (test f4.0 round f3.5) |
| 521 | (test f4.0 round f4.5) |
| 522 | (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. |
| 523 | (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) |
| 524 | (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) |
| 525 | (test #t call-with-output-file |
| 526 | "tmp3" |
| 527 | (lambda (test-file) |
| 528 | (write-char #\; test-file) |
| 529 | (display write-test-obj test-file) |
| 530 | (newline test-file) |
| 531 | (write load-test-obj test-file) |
| 532 | (output-port? test-file))) |
| 533 | (check-test-file "tmp3") |
| 534 | (set! write-test-obj wto) |
| 535 | (set! display-test-obj dto) |
| 536 | (set! load-test-obj lto) |
| 537 | (let ((x (string->number "4195835.0")) |
| 538 | (y (string->number "3145727.0"))) |
| 539 | (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) |
| 540 | (report-errs)) |
| 541 | |
| 542 | (define (test-bignum) |
| 543 | (define tb |
| 544 | (lambda (n1 n2) |
| 545 | (= n1 (+ (* n2 (quotient n1 n2)) |
| 546 | (remainder n1 n2))))) |
| 547 | (newline) |
| 548 | (display ";testing bignums; ") |
| 549 | (newline) |
| 550 | (SECTION 6 5 5) |
| 551 | (test 0 modulo -2177452800 86400) |
| 552 | (test 0 modulo 2177452800 -86400) |
| 553 | (test 0 modulo 2177452800 86400) |
| 554 | (test 0 modulo -2177452800 -86400) |
| 555 | (test #t 'remainder (tb 281474976710655 65535)) |
| 556 | (test #t 'remainder (tb 281474976710654 65535)) |
| 557 | (SECTION 6 5 6) |
| 558 | (test 281474976710655 string->number "281474976710655") |
| 559 | (test "281474976710655" number->string 281474976710655) |
| 560 | (report-errs)) |
| 561 | |
| 562 | (SECTION 6 5 6) |
| 563 | (test "0" number->string 0) |
| 564 | (test "100" number->string 100) |
| 565 | (test "100" number->string 256 16) |
| 566 | (test 100 string->number "100") |
| 567 | (test 256 string->number "100" 16) |
| 568 | (test #f string->number "") |
| 569 | (test #f string->number ".") |
| 570 | (test #f string->number "d") |
| 571 | (test #f string->number "D") |
| 572 | (test #f string->number "i") |
| 573 | (test #f string->number "I") |
| 574 | (test #f string->number "3i") |
| 575 | (test #f string->number "3I") |
| 576 | (test #f string->number "33i") |
| 577 | (test #f string->number "33I") |
| 578 | (test #f string->number "3.3i") |
| 579 | (test #f string->number "3.3I") |
| 580 | (test #f string->number "-") |
| 581 | (test #f string->number "+") |
| 582 | |
| 583 | (SECTION 6 6) |
| 584 | (test #t eqv? '#\ #\Space) |
| 585 | (test #t eqv? #\space '#\Space) |
| 586 | (test #t char? #\a) |
| 587 | (test #t char? #\() |
| 588 | (test #t char? #\ ) |
| 589 | (test #t char? '#\newline) |
| 590 | |
| 591 | (test #f char=? #\A #\B) |
| 592 | (test #f char=? #\a #\b) |
| 593 | (test #f char=? #\9 #\0) |
| 594 | (test #t char=? #\A #\A) |
| 595 | |
| 596 | (test #t char<? #\A #\B) |
| 597 | (test #t char<? #\a #\b) |
| 598 | (test #f char<? #\9 #\0) |
| 599 | (test #f char<? #\A #\A) |
| 600 | |
| 601 | (test #f char>? #\A #\B) |
| 602 | (test #f char>? #\a #\b) |
| 603 | (test #t char>? #\9 #\0) |
| 604 | (test #f char>? #\A #\A) |
| 605 | |
| 606 | (test #t char<=? #\A #\B) |
| 607 | (test #t char<=? #\a #\b) |
| 608 | (test #f char<=? #\9 #\0) |
| 609 | (test #t char<=? #\A #\A) |
| 610 | |
| 611 | (test #f char>=? #\A #\B) |
| 612 | (test #f char>=? #\a #\b) |
| 613 | (test #t char>=? #\9 #\0) |
| 614 | (test #t char>=? #\A #\A) |
| 615 | |
| 616 | (test #f char-ci=? #\A #\B) |
| 617 | (test #f char-ci=? #\a #\B) |
| 618 | (test #f char-ci=? #\A #\b) |
| 619 | (test #f char-ci=? #\a #\b) |
| 620 | (test #f char-ci=? #\9 #\0) |
| 621 | (test #t char-ci=? #\A #\A) |
| 622 | (test #t char-ci=? #\A #\a) |
| 623 | |
| 624 | (test #t char-ci<? #\A #\B) |
| 625 | (test #t char-ci<? #\a #\B) |
| 626 | (test #t char-ci<? #\A #\b) |
| 627 | (test #t char-ci<? #\a #\b) |
| 628 | (test #f char-ci<? #\9 #\0) |
| 629 | (test #f char-ci<? #\A #\A) |
| 630 | (test #f char-ci<? #\A #\a) |
| 631 | |
| 632 | (test #f char-ci>? #\A #\B) |
| 633 | (test #f char-ci>? #\a #\B) |
| 634 | (test #f char-ci>? #\A #\b) |
| 635 | (test #f char-ci>? #\a #\b) |
| 636 | (test #t char-ci>? #\9 #\0) |
| 637 | (test #f char-ci>? #\A #\A) |
| 638 | (test #f char-ci>? #\A #\a) |
| 639 | |
| 640 | (test #t char-ci<=? #\A #\B) |
| 641 | (test #t char-ci<=? #\a #\B) |
| 642 | (test #t char-ci<=? #\A #\b) |
| 643 | (test #t char-ci<=? #\a #\b) |
| 644 | (test #f char-ci<=? #\9 #\0) |
| 645 | (test #t char-ci<=? #\A #\A) |
| 646 | (test #t char-ci<=? #\A #\a) |
| 647 | |
| 648 | (test #f char-ci>=? #\A #\B) |
| 649 | (test #f char-ci>=? #\a #\B) |
| 650 | (test #f char-ci>=? #\A #\b) |
| 651 | (test #f char-ci>=? #\a #\b) |
| 652 | (test #t char-ci>=? #\9 #\0) |
| 653 | (test #t char-ci>=? #\A #\A) |
| 654 | (test #t char-ci>=? #\A #\a) |
| 655 | |
| 656 | (test #t char-alphabetic? #\a) |
| 657 | (test #t char-alphabetic? #\A) |
| 658 | (test #t char-alphabetic? #\z) |
| 659 | (test #t char-alphabetic? #\Z) |
| 660 | (test #f char-alphabetic? #\0) |
| 661 | (test #f char-alphabetic? #\9) |
| 662 | (test #f char-alphabetic? #\space) |
| 663 | (test #f char-alphabetic? #\;) |
| 664 | |
| 665 | (test #f char-numeric? #\a) |
| 666 | (test #f char-numeric? #\A) |
| 667 | (test #f char-numeric? #\z) |
| 668 | (test #f char-numeric? #\Z) |
| 669 | (test #t char-numeric? #\0) |
| 670 | (test #t char-numeric? #\9) |
| 671 | (test #f char-numeric? #\space) |
| 672 | (test #f char-numeric? #\;) |
| 673 | |
| 674 | (test #f char-whitespace? #\a) |
| 675 | (test #f char-whitespace? #\A) |
| 676 | (test #f char-whitespace? #\z) |
| 677 | (test #f char-whitespace? #\Z) |
| 678 | (test #f char-whitespace? #\0) |
| 679 | (test #f char-whitespace? #\9) |
| 680 | (test #t char-whitespace? #\space) |
| 681 | (test #f char-whitespace? #\;) |
| 682 | |
| 683 | (test #f char-upper-case? #\0) |
| 684 | (test #f char-upper-case? #\9) |
| 685 | (test #f char-upper-case? #\space) |
| 686 | (test #f char-upper-case? #\;) |
| 687 | |
| 688 | (test #f char-lower-case? #\0) |
| 689 | (test #f char-lower-case? #\9) |
| 690 | (test #f char-lower-case? #\space) |
| 691 | (test #f char-lower-case? #\;) |
| 692 | |
| 693 | (test #\. integer->char (char->integer #\.)) |
| 694 | (test #\A integer->char (char->integer #\A)) |
| 695 | (test #\a integer->char (char->integer #\a)) |
| 696 | (test #\A char-upcase #\A) |
| 697 | (test #\A char-upcase #\a) |
| 698 | (test #\a char-downcase #\A) |
| 699 | (test #\a char-downcase #\a) |
| 700 | (SECTION 6 7) |
| 701 | (test #t string? "The word \"recursion\\\" has many meanings.") |
| 702 | (test #t string? "") |
| 703 | (define f (make-string 3 #\*)) |
| 704 | (test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) |
| 705 | (test "abc" string #\a #\b #\c) |
| 706 | (test "" string) |
| 707 | (test 3 string-length "abc") |
| 708 | (test #\a string-ref "abc" 0) |
| 709 | (test #\c string-ref "abc" 2) |
| 710 | (test 0 string-length "") |
| 711 | (test "" substring "ab" 0 0) |
| 712 | (test "" substring "ab" 1 1) |
| 713 | (test "" substring "ab" 2 2) |
| 714 | (test "a" substring "ab" 0 1) |
| 715 | (test "b" substring "ab" 1 2) |
| 716 | (test "ab" substring "ab" 0 2) |
| 717 | (test "foobar" string-append "foo" "bar") |
| 718 | (test "foo" string-append "foo") |
| 719 | (test "foo" string-append "foo" "") |
| 720 | (test "foo" string-append "" "foo") |
| 721 | (test "" string-append) |
| 722 | (test "" make-string 0) |
| 723 | (test #t string=? "" "") |
| 724 | (test #f string<? "" "") |
| 725 | (test #f string>? "" "") |
| 726 | (test #t string<=? "" "") |
| 727 | (test #t string>=? "" "") |
| 728 | (test #t string-ci=? "" "") |
| 729 | (test #f string-ci<? "" "") |
| 730 | (test #f string-ci>? "" "") |
| 731 | (test #t string-ci<=? "" "") |
| 732 | (test #t string-ci>=? "" "") |
| 733 | |
| 734 | (test #f string=? "A" "B") |
| 735 | (test #f string=? "a" "b") |
| 736 | (test #f string=? "9" "0") |
| 737 | (test #t string=? "A" "A") |
| 738 | |
| 739 | (test #t string<? "A" "B") |
| 740 | (test #t string<? "a" "b") |
| 741 | (test #f string<? "9" "0") |
| 742 | (test #f string<? "A" "A") |
| 743 | |
| 744 | (test #f string>? "A" "B") |
| 745 | (test #f string>? "a" "b") |
| 746 | (test #t string>? "9" "0") |
| 747 | (test #f string>? "A" "A") |
| 748 | |
| 749 | (test #t string<=? "A" "B") |
| 750 | (test #t string<=? "a" "b") |
| 751 | (test #f string<=? "9" "0") |
| 752 | (test #t string<=? "A" "A") |
| 753 | |
| 754 | (test #f string>=? "A" "B") |
| 755 | (test #f string>=? "a" "b") |
| 756 | (test #t string>=? "9" "0") |
| 757 | (test #t string>=? "A" "A") |
| 758 | |
| 759 | (test #f string-ci=? "A" "B") |
| 760 | (test #f string-ci=? "a" "B") |
| 761 | (test #f string-ci=? "A" "b") |
| 762 | (test #f string-ci=? "a" "b") |
| 763 | (test #f string-ci=? "9" "0") |
| 764 | (test #t string-ci=? "A" "A") |
| 765 | (test #t string-ci=? "A" "a") |
| 766 | |
| 767 | (test #t string-ci<? "A" "B") |
| 768 | (test #t string-ci<? "a" "B") |
| 769 | (test #t string-ci<? "A" "b") |
| 770 | (test #t string-ci<? "a" "b") |
| 771 | (test #f string-ci<? "9" "0") |
| 772 | (test #f string-ci<? "A" "A") |
| 773 | (test #f string-ci<? "A" "a") |
| 774 | |
| 775 | (test #f string-ci>? "A" "B") |
| 776 | (test #f string-ci>? "a" "B") |
| 777 | (test #f string-ci>? "A" "b") |
| 778 | (test #f string-ci>? "a" "b") |
| 779 | (test #t string-ci>? "9" "0") |
| 780 | (test #f string-ci>? "A" "A") |
| 781 | (test #f string-ci>? "A" "a") |
| 782 | |
| 783 | (test #t string-ci<=? "A" "B") |
| 784 | (test #t string-ci<=? "a" "B") |
| 785 | (test #t string-ci<=? "A" "b") |
| 786 | (test #t string-ci<=? "a" "b") |
| 787 | (test #f string-ci<=? "9" "0") |
| 788 | (test #t string-ci<=? "A" "A") |
| 789 | (test #t string-ci<=? "A" "a") |
| 790 | |
| 791 | (test #f string-ci>=? "A" "B") |
| 792 | (test #f string-ci>=? "a" "B") |
| 793 | (test #f string-ci>=? "A" "b") |
| 794 | (test #f string-ci>=? "a" "b") |
| 795 | (test #t string-ci>=? "9" "0") |
| 796 | (test #t string-ci>=? "A" "A") |
| 797 | (test #t string-ci>=? "A" "a") |
| 798 | (SECTION 6 8) |
| 799 | (test #t vector? '#(0 (2 2 2 2) "Anna")) |
| 800 | (test #t vector? '#()) |
| 801 | (test '#(a b c) vector 'a 'b 'c) |
| 802 | (test '#() vector) |
| 803 | (test 3 vector-length '#(0 (2 2 2 2) "Anna")) |
| 804 | (test 0 vector-length '#()) |
| 805 | (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) |
| 806 | (test '#(0 ("Sue" "Sue") "Anna") 'vector-set |
| 807 | (let ((vec (vector 0 '(2 2 2 2) "Anna"))) |
| 808 | (vector-set! vec 1 '("Sue" "Sue")) |
| 809 | vec)) |
| 810 | (test '#(hi hi) make-vector 2 'hi) |
| 811 | (test '#() make-vector 0) |
| 812 | (test '#() make-vector 0 'a) |
| 813 | (SECTION 6 9) |
| 814 | (test #t procedure? car) |
| 815 | (test #f procedure? 'car) |
| 816 | (test #t procedure? (lambda (x) (* x x))) |
| 817 | (test #f procedure? '(lambda (x) (* x x))) |
| 818 | (test #t call-with-current-continuation procedure?) |
| 819 | (test 7 apply + (list 3 4)) |
| 820 | (test 7 apply (lambda (a b) (+ a b)) (list 3 4)) |
| 821 | (test 17 apply + 10 (list 3 4)) |
| 822 | (test '() apply list '()) |
| 823 | (define compose (lambda (f g) (lambda args (f (apply g args))))) |
| 824 | (test 30 (compose sqt *) 12 75) |
| 825 | |
| 826 | (test '(b e h) map cadr '((a b) (d e) (g h))) |
| 827 | (test '(5 7 9) map + '(1 2 3) '(4 5 6)) |
| 828 | (test '#(0 1 4 9 16) 'for-each |
| 829 | (let ((v (make-vector 5))) |
| 830 | (for-each (lambda (i) (vector-set! v i (* i i))) |
| 831 | '(0 1 2 3 4)) |
| 832 | v)) |
| 833 | (test -3 call-with-current-continuation |
| 834 | (lambda (exit) |
| 835 | (for-each (lambda (x) (if (negative? x) (exit x))) |
| 836 | '(54 0 37 -3 245 19)) |
| 837 | #t)) |
| 838 | (define list-length |
| 839 | (lambda (obj) |
| 840 | (call-with-current-continuation |
| 841 | (lambda (return) |
| 842 | (letrec ((r (lambda (obj) (cond ((null? obj) 0) |
| 843 | ((pair? obj) (+ (r (cdr obj)) 1)) |
| 844 | (else (return #f)))))) |
| 845 | (r obj)))))) |
| 846 | (test 4 list-length '(1 2 3 4)) |
| 847 | (test #f list-length '(a b . c)) |
| 848 | (test '() map cadr '()) |
| 849 | |
| 850 | ;;; This tests full conformance of call-with-current-continuation. It |
| 851 | ;;; is a separate test because some schemes do not support call/cc |
| 852 | ;;; other than escape procedures. I am indebted to |
| 853 | ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this |
| 854 | ;;; code. The function leaf-eq? compares the leaves of 2 arbitrary |
| 855 | ;;; trees constructed of conses. |
| 856 | (define (next-leaf-generator obj eot) |
| 857 | (letrec ((return #f) |
| 858 | (cont (lambda (x) |
| 859 | (recur obj) |
| 860 | (set! cont (lambda (x) (return eot))) |
| 861 | (cont #f))) |
| 862 | (recur (lambda (obj) |
| 863 | (if (pair? obj) |
| 864 | (for-each recur obj) |
| 865 | (call-with-current-continuation |
| 866 | (lambda (c) |
| 867 | (set! cont c) |
| 868 | (return obj))))))) |
| 869 | (lambda () (call-with-current-continuation |
| 870 | (lambda (ret) (set! return ret) (cont #f)))))) |
| 871 | (define (leaf-eq? x y) |
| 872 | (let* ((eot (list 'eot)) |
| 873 | (xf (next-leaf-generator x eot)) |
| 874 | (yf (next-leaf-generator y eot))) |
| 875 | (letrec ((loop (lambda (x y) |
| 876 | (cond ((not (eq? x y)) #f) |
| 877 | ((eq? eot x) #t) |
| 878 | (else (loop (xf) (yf))))))) |
| 879 | (loop (xf) (yf))))) |
| 880 | (define (test-cont) |
| 881 | (newline) |
| 882 | (display ";testing continuations; ") |
| 883 | (newline) |
| 884 | (SECTION 6 9) |
| 885 | (test #t leaf-eq? '(a (b (c))) '((a) b c)) |
| 886 | (test #f leaf-eq? '(a (b (c))) '((a) b c d)) |
| 887 | (report-errs)) |
| 888 | |
| 889 | ;;; Test Optional R4RS DELAY syntax and FORCE procedure |
| 890 | (define (test-delay) |
| 891 | (newline) |
| 892 | (display ";testing DELAY and FORCE; ") |
| 893 | (newline) |
| 894 | (SECTION 6 9) |
| 895 | (test 3 'delay (force (delay (+ 1 2)))) |
| 896 | (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) |
| 897 | (list (force p) (force p)))) |
| 898 | (test 2 'delay (letrec ((a-stream |
| 899 | (letrec ((next (lambda (n) |
| 900 | (cons n (delay (next (+ n 1))))))) |
| 901 | (next 0))) |
| 902 | (head car) |
| 903 | (tail (lambda (stream) (force (cdr stream))))) |
| 904 | (head (tail (tail a-stream))))) |
| 905 | (letrec ((count 0) |
| 906 | (p (delay (begin (set! count (+ count 1)) |
| 907 | (if (> count x) |
| 908 | count |
| 909 | (force p))))) |
| 910 | (x 5)) |
| 911 | (test 6 force p) |
| 912 | (set! x 10) |
| 913 | (test 6 force p)) |
| 914 | (test 3 'force |
| 915 | (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) |
| 916 | (c #f)) |
| 917 | (force p))) |
| 918 | (report-errs)) |
| 919 | |
| 920 | (SECTION 6 10 1) |
| 921 | (test #t input-port? (current-input-port)) |
| 922 | (test #t output-port? (current-output-port)) |
| 923 | (test #t call-with-input-file "test.scm" input-port?) |
| 924 | (define this-file (open-input-file "test.scm")) |
| 925 | (test #t input-port? this-file) |
| 926 | (SECTION 6 10 2) |
| 927 | (test #\; peek-char this-file) |
| 928 | (test #\; read-char this-file) |
| 929 | (test '(define cur-section '()) read this-file) |
| 930 | (test #\( peek-char this-file) |
| 931 | (test '(define errs '()) read this-file) |
| 932 | (close-input-port this-file) |
| 933 | (close-input-port this-file) |
| 934 | (define (check-test-file name) |
| 935 | (define test-file (open-input-file name)) |
| 936 | (test #t 'input-port? |
| 937 | (call-with-input-file |
| 938 | name |
| 939 | (lambda (test-file) |
| 940 | (test load-test-obj read test-file) |
| 941 | (test #t eof-object? (peek-char test-file)) |
| 942 | (test #t eof-object? (read-char test-file)) |
| 943 | (input-port? test-file)))) |
| 944 | (test #\; read-char test-file) |
| 945 | (test display-test-obj read test-file) |
| 946 | (test load-test-obj read test-file) |
| 947 | (close-input-port test-file)) |
| 948 | (SECTION 6 10 3) |
| 949 | (define write-test-obj |
| 950 | '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) |
| 951 | (define display-test-obj |
| 952 | '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) |
| 953 | (define load-test-obj |
| 954 | (list 'define 'foo (list 'quote write-test-obj))) |
| 955 | (test #t call-with-output-file |
| 956 | "tmp1" |
| 957 | (lambda (test-file) |
| 958 | (write-char #\; test-file) |
| 959 | (display write-test-obj test-file) |
| 960 | (newline test-file) |
| 961 | (write load-test-obj test-file) |
| 962 | (output-port? test-file))) |
| 963 | (check-test-file "tmp1") |
| 964 | |
| 965 | (define test-file (open-output-file "tmp2")) |
| 966 | (write-char #\; test-file) |
| 967 | (display write-test-obj test-file) |
| 968 | (newline test-file) |
| 969 | (write load-test-obj test-file) |
| 970 | (test #t output-port? test-file) |
| 971 | (close-output-port test-file) |
| 972 | (check-test-file "tmp2") |
| 973 | (define (test-sc4) |
| 974 | (newline) |
| 975 | (display ";testing scheme 4 functions; ") |
| 976 | (newline) |
| 977 | (SECTION 6 7) |
| 978 | (test '(#\P #\space #\l) string->list "P l") |
| 979 | (test '() string->list "") |
| 980 | (test "1\\\"" list->string '(#\1 #\\ #\")) |
| 981 | (test "" list->string '()) |
| 982 | (SECTION 6 8) |
| 983 | (test '(dah dah didah) vector->list '#(dah dah didah)) |
| 984 | (test '() vector->list '#()) |
| 985 | (test '#(dididit dah) list->vector '(dididit dah)) |
| 986 | (test '#() list->vector '()) |
| 987 | (SECTION 6 10 4) |
| 988 | (load "tmp1") |
| 989 | (test write-test-obj 'load foo) |
| 990 | (report-errs)) |
| 991 | |
| 992 | (report-errs) |
| 993 | (if (and (string->number "0.0") (inexact? (string->number "0.0"))) |
| 994 | (test-inexact)) |
| 995 | |
| 996 | (let ((n (string->number "281474976710655"))) |
| 997 | (if (and n (exact? n)) |
| 998 | (test-bignum))) |
| 999 | (newline) |
| 1000 | (test-cont) |
| 1001 | (newline) |
| 1002 | (test-sc4) |
| 1003 | (newline) |
| 1004 | (test-delay) |
| 1005 | (newline) |
| 1006 | "last item in file" |