summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/guardians.test65
-rw-r--r--test-suite/tests/interp.test16
-rw-r--r--test-suite/tests/mambo.test0
-rw-r--r--test-suite/tests/ports.test324
-rw-r--r--test-suite/tests/r4rs.test1014
-rw-r--r--test-suite/tests/time.test28
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")))