diff options
Diffstat (limited to 'test-suite/tests')
-rw-r--r-- | test-suite/tests/guardians.test | 65 | ||||
-rw-r--r-- | test-suite/tests/interp.test | 16 | ||||
-rw-r--r-- | test-suite/tests/mambo.test | 0 | ||||
-rw-r--r-- | test-suite/tests/ports.test | 324 | ||||
-rw-r--r-- | test-suite/tests/r4rs.test | 1014 | ||||
-rw-r--r-- | test-suite/tests/time.test | 28 |
6 files changed, 0 insertions, 1447 deletions
diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test deleted file mode 100644 index 4d8eac678..000000000 --- a/test-suite/tests/guardians.test +++ /dev/null @@ -1,65 +0,0 @@ -;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- July 1999 -;;;; -;;;; Copyright (C) 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 - -;;; These tests make some questionable assumptions. -;;; - They assume that a GC will find all dead objects, so they -;;; will become flaky if we have a generational GC. -;;; - They assume that objects won't be saved by the guardian until -;;; they explicitly invoke GC --- in other words, they assume that GC -;;; won't happen too often. - -(gc) - -(define g1 (make-guardian)) -(define not-g1-garbage (list 'not-g1-garbage)) -(g1 not-g1-garbage) -(g1 (list 'g1-garbage)) -(pass-if "g1-garbage not collected yet" (equal? (g1) #f)) -(gc) -(pass-if "g1-garbage saved" (equal? (g1) '(g1-garbage))) - -;;; Who guards the guardian? -(gc) -(define g2 (make-guardian)) -(g2 (list 'g2-garbage)) -(define g3 (make-guardian)) -(g3 (list 'g3-garbage)) -(g3 g2) -(pass-if "g2-garbage not collected yet" (equal? (g2) #f)) -(pass-if "g3-garbage not collected yet" (equal? (g3) #f)) -(set! g2 #f) -(gc) -(let ((seen-g3-garbage #f) - (seen-g2 #f) - (seen-something-else #f)) - (let loop () - (let ((saved (g3))) - (if saved - (begin - (cond - ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t)) - ((procedure? saved) (set! seen-g2 saved)) - (else (set! seen-something-else #t))) - (loop))))) - (pass-if "g3-garbage saved" seen-g3-garbage) - (pass-if "g2-saved" seen-g2) - (pass-if "nothing else saved" (not seen-something-else)) - (pass-if "g2-garbage saved" (and (procedure? seen-g2) - (equal? (seen-g2) '(g2-garbage))))) diff --git a/test-suite/tests/interp.test b/test-suite/tests/interp.test deleted file mode 100644 index 18218d6d3..000000000 --- a/test-suite/tests/interp.test +++ /dev/null @@ -1,16 +0,0 @@ -;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*- -;;;; We'll put a copyright on this as soon as it's big enough to copyright. - -(pass-if "Internal defines 1" - (letrec ((foo (lambda (arg) - (or arg (and (procedure? foo) - (foo 99)))))) - (define bar (foo #f)) - (foo #f))) - -(pass-if "Internal defines 2" - (letrec ((foo 77) - (bar #f) - (retfoo (lambda () foo))) - (define baz (retfoo)) - (retfoo))) diff --git a/test-suite/tests/mambo.test b/test-suite/tests/mambo.test deleted file mode 100644 index e69de29bb..000000000 --- a/test-suite/tests/mambo.test +++ /dev/null diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test deleted file mode 100644 index ce796d11e..000000000 --- a/test-suite/tests/ports.test +++ /dev/null @@ -1,324 +0,0 @@ -;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- October 1998 -;;;; -;;;; Copyright (C) 1998, 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 - -(use-modules (test-suite lib) - (ice-9 popen)) - -(define (display-line . args) - (for-each display args) - (newline)) - -(define (test-file) - (tmpnam)) - - -;;;; Some general utilities for testing ports. - -;;; Read from PORT until EOF, and return the result as a string. -(define (read-all port) - (let loop ((chars '())) - (let ((char (read-char port))) - (if (eof-object? char) - (list->string (reverse! chars)) - (loop (cons char chars)))))) - -(define (read-file filename) - (let* ((port (open-input-file filename)) - (string (read-all port))) - (close-port port) - string)) - - -;;;; Normal file ports. - -;;; Write out an s-expression, and read it back. -(catch-test-errors - (let ((string '("From fairest creatures we desire increase," - "That thereby beauty's rose might never die,")) - (filename (test-file))) - (let ((port (open-output-file filename))) - (write string port) - (close-port port)) - (let ((port (open-input-file filename))) - (let ((in-string (read port))) - (pass-if "file: write and read back list of strings" - (equal? string in-string))) - (close-port port)) - (delete-file filename))) - -;;; Write out a string, and read it back a character at a time. -(catch-test-errors - (let ((string "This is a test string\nwith no newline at the end") - (filename (test-file))) - (let ((port (open-output-file filename))) - (display string port) - (close-port port)) - (let ((in-string (read-file filename))) - (pass-if "file: write and read back characters" - (equal? string in-string))) - (delete-file filename))) - -;;; Buffered input/output port with seeking. -(catch-test-errors - (let* ((filename (test-file)) - (port (open-file filename "w+"))) - (display "J'Accuse" port) - (seek port -1 SEEK_CUR) - (pass-if "file: r/w 1" - (char=? (read-char port) #\e)) - (pass-if "file: r/w 2" - (eof-object? (read-char port))) - (seek port -1 SEEK_CUR) - (write-char #\x port) - (seek port 7 SEEK_SET) - (pass-if "file: r/w 3" - (char=? (read-char port) #\x)) - (seek port -2 SEEK_END) - (pass-if "file: r/w 4" - (char=? (read-char port) #\s)) - (delete-file filename))) - -;;; Unbuffered input/output port with seeking. -(catch-test-errors - (let* ((filename (test-file)) - (port (open-file filename "w+0"))) - (display "J'Accuse" port) - (seek port -1 SEEK_CUR) - (pass-if "file: ub r/w 1" - (char=? (read-char port) #\e)) - (pass-if "file: ub r/w 2" - (eof-object? (read-char port))) - (seek port -1 SEEK_CUR) - (write-char #\x port) - (seek port 7 SEEK_SET) - (pass-if "file: ub r/w 3" - (char=? (read-char port) #\x)) - (seek port -2 SEEK_END) - (pass-if "file: ub r/w 4" - (char=? (read-char port) #\s)) - (delete-file filename))) - -;;; unusual characters. -(catch-test-errors - (let* ((filename (test-file)) - (port (open-output-file filename))) - (display (string #\nul (integer->char 255) (integer->char 128) - #\nul) port) - (close-port port) - (let* ((port (open-input-file filename)) - (line (read-line port))) - (pass-if "file: read back NUL 1" - (char=? (string-ref line 0) #\nul)) - (pass-if "file: read back 255" - (char=? (string-ref line 1) (integer->char 255))) - (pass-if "file: read back 128" - (char=? (string-ref line 2) (integer->char 128))) - (pass-if "file: read back NUL 2" - (char=? (string-ref line 3) #\nul)) - (pass-if "file: EOF" - (eof-object? (read-char port)))) - (delete-file filename))) - -;;; line buffering mode. -(catch-test-errors - (let* ((filename (test-file)) - (port (open-file filename "wl")) - (test-string "one line more or less")) - (write-line test-string port) - (let* ((in-port (open-input-file filename)) - (line (read-line in-port))) - (close-port in-port) - (close-port port) - (pass-if "file: line buffering" - (string=? line test-string))) - (delete-file filename))) - - -;;;; Pipe ports. - -;;; Run a command, and read its output. -(catch-test-errors - (let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r")) - (in-string (read-all pipe))) - (close-pipe pipe) - (pass-if "pipe: read" - (equal? in-string "Howdy there, partner!\n")))) - -;;; Run a command, send some output to it, and see if it worked. -(catch-test-errors - (let* ((filename (test-file)) - (pipe (open-pipe (string-append "grep Mommy > " filename) "w"))) - (display "Now Jimmy lives on a mushroom cloud\n" pipe) - (display "Mommy, why does everybody have a bomb?\n" pipe) - (close-pipe pipe) - (let ((in-string (read-file filename))) - (pass-if "pipe: write" - (equal? in-string "Mommy, why does everybody have a bomb?\n"))) - (delete-file filename))) - - -;;;; Void ports. These are so trivial we don't test them. - - -;;;; String ports. - -(with-test-prefix "string ports" - - ;; Write text to a string port. - (catch-test-errors - (let* ((string "Howdy there, partner!") - (in-string (call-with-output-string - (lambda (port) - (display string port) - (newline port))))) - (pass-if "display text" - (equal? in-string (string-append string "\n"))))) - - ;; Write an s-expression to a string port. - (catch-test-errors - (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926)) - (in-sexpr - (call-with-input-string (call-with-output-string - (lambda (port) - (write sexpr port))) - read))) - (pass-if "write/read sexpr" - (equal? in-sexpr sexpr))))) - - -;;;; Soft ports. No tests implemented yet. - - -;;;; Generic operations across all port types. - -(let ((port-loop-temp (test-file))) - - ;; Return a list of input ports that all return the same text. - ;; We map tests over this list. - (define (input-port-list text) - - ;; Create a text file some of the ports will use. - (let ((out-port (open-output-file port-loop-temp))) - (display text out-port) - (close-port out-port)) - - (list (open-input-file port-loop-temp) - (open-input-pipe (string-append "cat " port-loop-temp)) - (call-with-input-string text (lambda (x) x)) - ;; We don't test soft ports at the moment. - )) - - (define port-list-names '("file" "pipe" "string")) - - ;; Test the line counter. - (define (test-line-counter text second-line final-column) - (with-test-prefix "line counter" - (let ((ports (input-port-list text))) - (for-each - (lambda (port port-name) - (with-test-prefix port-name - (pass-if "at beginning of input" - (= (port-line port) 0)) - (pass-if "read first character" - (eqv? (read-char port) #\x)) - (pass-if "after reading one character" - (= (port-line port) 0)) - (pass-if "read first newline" - (eqv? (read-char port) #\newline)) - (pass-if "after reading first newline char" - (= (port-line port) 1)) - (pass-if "second line read correctly" - (equal? (read-line port) second-line)) - (pass-if "read-line increments line number" - (= (port-line port) 2)) - (pass-if "read-line returns EOF" - (let loop ((i 0)) - (cond - ((eof-object? (read-line port)) #t) - ((> i 20) #f) - (else (loop (+ i 1)))))) - (pass-if "line count is 5 at EOF" - (= (port-line port) 5)) - (pass-if "column is correct at EOF" - (= (port-column port) final-column)))) - ports port-list-names) - (for-each close-port ports) - (delete-file port-loop-temp)))) - - (catch-test-errors - (with-test-prefix "newline" - (test-line-counter - (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n") - "He who receives an idea from me, receives instruction" - 0))) - - (catch-test-errors - (with-test-prefix "no newline" - (test-line-counter - (string-append "x\n" - "He who receives an idea from me, receives instruction\n" - "himself without lessening mine; as he who lights his\n" - "taper at mine, receives light without darkening me.\n" - " --- Thomas Jefferson\n" - "no newline here") - "He who receives an idea from me, receives instruction" - 15)))) - - -;;;; testing read-delimited and friends - -(with-test-prefix "read-delimited!" - (let ((c (make-string 20 #\!))) - (call-with-input-string - "defdef\nghighi\n" - (lambda (port) - - (read-delimited! "\n" c port 'concat) - (pass-if "read-delimited! reads a first line" - (string=? c "defdef\n!!!!!!!!!!!!!")) - - (read-delimited! "\n" c port 'concat 3) - (pass-if "read-delimited! reads a first line" - (string=? c "defghighi\n!!!!!!!!!!")))))) - - -;;;; char-ready? - -(call-with-input-string - "howdy" - (lambda (port) - (pass-if "char-ready? returns true on string port" - (char-ready? port)))) - -;;; This segfaults on some versions of Guile. We really should run -;;; the tests in a subprocess... - -(call-with-input-string - "howdy" - (lambda (port) - (with-input-from-port - port - (lambda () - (pass-if "char-ready? returns true on string port as default port" - (char-ready?)))))) diff --git a/test-suite/tests/r4rs.test b/test-suite/tests/r4rs.test deleted file mode 100644 index c915b515c..000000000 --- a/test-suite/tests/r4rs.test +++ /dev/null @@ -1,1014 +0,0 @@ -;;;; 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. - - -;;;; ============= 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. -;;;; Modified: Jim Blandy -;;;; adapted to new Guile test suite framework - -;;; 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 -;;; "test.scm", so you'll have to run it from the ice-9 source -;;; directory, or copy this file elsewhere -;;; 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 -;;; "test.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 jaffer@ai.mit.edu or -;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA - -(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)))) -(define (report-errs) #f) - -(define test - (lambda (expect fun . args) - (let ((res (if (procedure? fun) (apply fun args) (car args)))) - (with-test-prefix cur-section - (pass-if (call-with-output-string (lambda (port) - (write (cons fun args) port))) - (equal? expect res)))))) - -;; test that all symbol characters are supported. -(SECTION 2 1) -'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) - -(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) (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)) - type-examples)) -(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)) -(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) -(SECTION 4 2 3) -(define x 0) -(test 6 'begin (begin (set! x 5) (+ x 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))))) -(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))) -(SECTION 5 2 2) -(test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (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) -(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)) - -(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)) -;;; Not for Guile -;(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))))) -;;; Not for Guile -;(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")) -;;; Not for Guile -;(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") - -;;; Not for Guile -;(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) -(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) - -;;;;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 dto display-test-obj) - (define lto load-test-obj) - (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 (- 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) - (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. - (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" - (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") - (set! write-test-obj wto) - (set! display-test-obj dto) - (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-bignum) - (define tb - (lambda (n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2))))) - (SECTION 6 5 5) - (test 0 modulo -2177452800 86400) - (test 0 modulo 2177452800 -86400) - (test 0 modulo 2177452800 86400) - (test 0 modulo -2177452800 -86400) - (test #t 'remainder (tb 281474976710655 65535)) - (test #t 'remainder (tb 281474976710654 65535)) - (SECTION 6 5 6) - (test 281474976710655 string->number "281474976710655") - (test "281474976710655" number->string 281474976710655) - (report-errs)) - -(SECTION 6 5 6) -(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 "+") - -(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 '#(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) - (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) - (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 (data-file "tests/r4rs.test") input-port?) -(define this-file (open-input-file (data-file "tests/r4rs.test"))) -(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 display-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 display-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 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 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) - (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 (data-file "tmp1")) - (test write-test-obj 'load foo) - (report-errs)) - -(report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) - -(let ((n (string->number "281474976710655"))) - (if (and n (exact? n)) - (test-bignum))) -(test-cont) -(test-sc4) -(test-delay) -"last item in file" diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test deleted file mode 100644 index 59b9125db..000000000 --- a/test-suite/tests/time.test +++ /dev/null @@ -1,28 +0,0 @@ -;;;; time.test --- test suite for Guile's time functions -*- scheme -*- -;;;; Jim Blandy <jimb@red-bean.com> --- June 1999 -;;;; -;;;; Copyright (C) 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 - -(use-modules (test-suite lib) - (ice-9 regex)) - -(pass-if "strftime %Z doesn't return garbage" - (let ((t (localtime (current-time)))) - (vector-set! t 10 "ZOW") - (string=? (strftime "%Z" t) - "ZOW"))) |