code:
;;;; popen.test --- exercise ice-9/popen.scm      -*- scheme -*-
;;;;
;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-ice-9-popen)
  #:use-module (test-suite lib)
  #:use-module (ice-9 popen))

;; read from PORT until eof is reached, return what's read as a string
(define (read-string-to-eof port)
  (do ((lst '() (cons c lst))
       (c (read-char port) (read-char port)))
      ((eof-object? c)
       (list->string (reverse! lst)))))

;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is
;; generated rather than a SIGPIPE signal
(define (with-epipe thunk)
  (dynamic-wind
      (lambda ()
	(sigaction SIGPIPE SIG_IGN))
      thunk
      restore-signals))

;;
;; open-input-pipe
;;

(with-test-prefix "open-input-pipe"

  (pass-if-exception "no args" exception:wrong-num-args
    (open-input-pipe))

  (pass-if "port?"
    (port? (open-input-pipe "echo hello")))

  (pass-if "echo hello"
    (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))

  ;; exercise file descriptor setups when stdin is the same as stderr
  (pass-if "stdin==stderr"
    (let ((port (open-file "/dev/null" "r+")))
      (with-input-from-port port
	(lambda ()
	  (with-error-to-port port
	    (lambda ()
	      (open-input-pipe "echo hello"))))))
    #t)

  ;; exercise file descriptor setups when stdout is the same as stderr
  (pass-if "stdout==stderr"
    (let ((port (open-file "/dev/null" "r+")))
      (with-output-to-port port
	(lambda ()
	  (with-error-to-port port
	    (lambda ()
	      (open-input-pipe "echo hello"))))))
    #t)

  (pass-if "open-input-pipe process gets (current-input-port) as stdin"
    (let* ((p2c (pipe))
           (port (with-input-from-port (car p2c)
                   (lambda ()
                     (open-input-pipe "read line && echo $line")))))
      (display "hello\n" (cdr p2c))
      (force-output (cdr p2c))
      (let ((result (eq? (read port) 'hello)))
	(close-port (cdr p2c))
	(close-pipe port)
	result)))

  ;; After the child closes stdout (which it indicates here by writing
  ;; "closed" to stderr), the parent should see eof.  In Guile 1.6.4
  ;; and earlier a duplicate of stdout existed in the child, meaning
  ;; eof was not seen.
  ;;
  ;; Note that the objective here is to test that the parent sees EOF
  ;; while the child is still alive.  (It is obvious that the parent
  ;; must see EOF once the child has died.)  The use of the `p2c'
  ;; pipe, and `echo closed' and `read' in the child, allows us to be
  ;; sure that we are testing what the parent sees at a point where
  ;; the child has closed stdout but is still alive.
  (pass-if "no duplicate"
    (let* ((c2p (pipe))
	   (p2c (pipe))
	   (port (with-error-to-port (cdr c2p)
		   (lambda ()
		     (with-input-from-port (car p2c)
		       (lambda ()
			 (open-input-pipe
			  "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read")))))))
      (close-port (cdr c2p))   ;; write side
      (let ((result (eof-object? (read-char port))))
	(display "hello!\n" (cdr p2c))
	(force-output (cdr p2c))
	(close-pipe port)
	result)))

  )

;;
;; open-output-pipe
;;

(with-test-prefix "open-output-pipe"

  (pass-if-exception "no args" exception:wrong-num-args
    (open-output-pipe))

  (pass-if "port?"
    (port? (open-output-pipe "exit 0")))

  ;; exercise file descriptor setups when stdin is the same as stderr
  (pass-if "stdin==stderr"
    (let ((port (open-file "/dev/null" "r+")))
      (with-input-from-port port
	(lambda ()
	  (with-error-to-port port
	    (lambda ()
	      (open-output-pipe "exit 0"))))))
    #t)

  ;; exercise file descriptor setups when stdout is the same as stderr
  (pass-if "stdout==stderr"
    (let ((port (open-file "/dev/null" "r+")))
      (with-output-to-port port
	(lambda ()
	  (with-error-to-port port
	    (lambda ()
	      (open-output-pipe "exit 0"))))))
    #t)

  ;; After the child closes stdin (which it indicates here by writing
  ;; "closed" to stderr), the parent should see a broken pipe.  We
  ;; setup to see this as EPIPE (rather than SIGPIPE).  In Guile 1.6.4
  ;; and earlier a duplicate of stdin existed in the child, preventing
  ;; the broken pipe occurring.
  ;;
  ;; Note that the objective here is to test that the parent sees a
  ;; broken pipe while the child is still alive.  (It is obvious that
  ;; the parent will see a broken pipe once the child has died.)  The
  ;; use of the `c2p' pipe, and the repeated `echo closed' in the
  ;; child, allows us to be sure that we are testing what the parent
  ;; sees at a point where the child has closed stdin but is still
  ;; alive.
  ;;
  ;; Note that `with-epipe' must apply only to the parent and not to
  ;; the child process; we rely on the child getting SIGPIPE, to
  ;; terminate it (and avoid leaving a zombie).
  (pass-if "no duplicate"
    (let* ((c2p (pipe))
	   (port (with-error-to-port (cdr c2p)
		   (lambda ()
		     (open-output-pipe (format #f
                                               "guile -s ~a/tests/popen-child.scm"
                                               (getenv "TEST_SUITE_DIR")))))))
      (close-port (cdr c2p))   ;; write side
      (with-epipe
       (lambda ()
	 (let ((result
		(and (char? (read-char (car c2p))) ;; wait for child to do its thing
		     (catch 'system-error
			    (lambda ()
			      (write-char #\x port)
			      (force-output port)
			      #f)
			    (lambda (key name fmt args errno-list)
			      (= (car errno-list) EPIPE))))))
	   ;; Now close our reading end of the pipe.  This should give
	   ;; the child a broken pipe and so allow it to exit.
	   (close-port (car c2p))
	   (close-pipe port)
	   result)))))

  )

;;
;; close-pipe
;;

(with-test-prefix "close-pipe"

  (pass-if-exception "no args" exception:wrong-num-args
    (close-pipe))

  (pass-if "exit 0"
    (let ((st (close-pipe (open-output-pipe "exit 0"))))
      (and (status:exit-val st)
	   (= 0 (status:exit-val st)))))

  (pass-if "exit 1"
    (let ((st (close-pipe (open-output-pipe "exit 1"))))
      (and (status:exit-val st)
	   (= 1 (status:exit-val st))))))


code:
;;;; ports.test --- Guile I/O ports.    -*- coding: utf-8; mode: scheme; -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; 	Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-ports)
  :use-module (test-suite lib)
  :use-module (test-suite guile-test)
  :use-module (ice-9 popen)
  :use-module (ice-9 rdelim)
  :use-module (rnrs bytevectors))

(define (display-line . args)
  (for-each display args)
  (newline))

(define (test-file)
  (data-file-name "ports-test.tmp"))

;;;; Some general utilities for testing ports.

;; Make sure we are set up for 8-bit Latin-1 data.
(fluid-set! %default-port-encoding "ISO-8859-1")
(for-each (lambda (p)
            (set-port-encoding! p (fluid-ref %default-port-encoding)))
          (list (current-input-port) (current-output-port)
                (current-error-port)))

;;; 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.
(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.
(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.
(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))
  (close-port port)
  (delete-file filename))

;;; Unbuffered input/output port with seeking.
(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))
  (close-port port)
  (delete-file filename))

;;; Buffered output-only and input-only ports with seeking.
(let* ((filename (test-file))
       (port (open-output-file filename)))
  (display "J'Accuse" port)
  (pass-if "file: out tell"
	   (= (seek port 0 SEEK_CUR) 8))
  (seek port -1 SEEK_CUR)
  (write-char #\x port)
  (close-port port)
  (let ((iport (open-input-file filename)))
    (pass-if "file: in tell 0"
	     (= (seek iport 0 SEEK_CUR) 0))
    (read-char iport)
    (pass-if "file: in tell 1"
	     (= (seek iport 0 SEEK_CUR) 1))
    (unread-char #\z iport)
    (pass-if "file: in tell 0 after unread"
	     (= (seek iport 0 SEEK_CUR) 0))
    (pass-if "file: unread char still there"
	     (char=? (read-char iport) #\z))
    (seek iport 7 SEEK_SET)
    (pass-if "file: in last char"
	     (char=? (read-char iport) #\x))
    (close-port iport))
  (delete-file filename))

;;; unusual characters.
(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)))
    (close-port port))
  (delete-file filename))

;;; line buffering mode.
(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))

;;; read-line should use the port encoding (not the locale encoding).
(let ((str "ĉu bone?"))
  (with-locale "C"
               (let* ((filename (test-file))
                      (port (open-file filename "wl")))
                 (set-port-encoding! port "UTF-8")
                 (write-line str port)
                 (let ((in-port (open-input-file filename)))
                   (set-port-encoding! in-port "UTF-8")
                   (let ((line (read-line in-port)))
                     (close-port in-port)
                     (close-port port)
                     (pass-if "file: read-line honors port encoding"
                              (string=? line str))))
                 (delete-file filename))))

;;; binary mode ignores port encoding
(pass-if "file: binary mode ignores port encoding"
  (with-fluids ((%default-port-encoding "UTF-8"))
               (let* ((filename (test-file))
                      (port (open-file filename "w"))
                      (test-string "一二三")
                      (binary-test-string
                       (apply string
                              (map integer->char
                                   (uniform-vector->list
                                    (string->utf8 test-string))))))
                 (write-line test-string port)
                 (close-port port)
                 (let* ((in-port (open-file filename "rb"))
                        (line (read-line in-port)))
                   (close-port in-port)
                   (delete-file filename)
                   (string=? line binary-test-string)))))

;;; binary mode ignores file coding declaration
(pass-if "file: binary mode ignores file coding declaration"
  (with-fluids ((%default-port-encoding "UTF-8"))
               (let* ((filename (test-file))
                      (port (open-file filename "w"))
                      (test-string "一二三")
                      (binary-test-string
                       (apply string
                              (map integer->char
                                   (uniform-vector->list
                                    (string->utf8 test-string))))))
                 (write-line ";; coding: utf-8" port)
                 (write-line test-string port)
                 (close-port port)
                 (let* ((in-port (open-file filename "rb"))
                        (line1 (read-line in-port))
                        (line2 (read-line in-port)))
                   (close-port in-port)
                   (delete-file filename)
                   (string=? line2 binary-test-string)))))

;; open-file honors file coding declarations
(pass-if "file: open-file honors coding declarations"
  (with-fluids ((%default-port-encoding "UTF-8"))
               (let* ((filename (test-file))
                      (port (open-output-file filename))
                      (test-string "€100"))
                 (set-port-encoding! port "ISO-8859-15")
                 (write-line ";; coding: iso-8859-15" port)
                 (write-line test-string port)
                 (close-port port)
                 (let* ((in-port (open-input-file filename))
                        (line1 (read-line in-port))
                        (line2 (read-line in-port)))
                   (close-port in-port)
                   (delete-file filename)
                   (string=? line2 test-string)))))

;;; ungetting characters and strings.
(with-input-from-string "walk on the moon\nmoon"
			(lambda ()
			  (read-char)
			  (unread-char #\a (current-input-port))
			  (pass-if "unread-char"
				   (char=? (read-char) #\a))
			  (read-line)
			  (let ((replacenoid "chicken enchilada"))
			    (unread-char #\newline (current-input-port))
			    (unread-string replacenoid (current-input-port))
			    (pass-if "unread-string"
				     (string=? (read-line) replacenoid)))
			  (pass-if "unread residue"
				   (string=? (read-line) "moon"))))

;;; non-blocking mode on a port.  create a pipe and set O_NONBLOCK on
;;; the reading end.  try to read a byte: should get EAGAIN or
;;; EWOULDBLOCK error.
(let* ((p (pipe))
       (r (car p)))
  (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
  (pass-if "non-blocking-I/O"
	   (catch 'system-error
		  (lambda () (read-char r) #f)
		  (lambda (key . args)
		    (and (eq? key 'system-error)
			 (let ((errno (car (list-ref args 3))))
			   (or (= errno EAGAIN)
			       (= errno EWOULDBLOCK))))))))

;;;; Pipe (popen) ports.

;;; Run a command, and read its output.
(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.
(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.
  (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.
  (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)))

  ;; seeking and unreading from an input string.
  (let ((text "that text didn't look random to me"))
    (call-with-input-string text
			    (lambda (p)
			      (pass-if "input tell 0"
				       (= (seek p 0 SEEK_CUR) 0))
			      (read-char p)
			      (pass-if "input tell 1"
				       (= (seek p 0 SEEK_CUR) 1))
			      (unread-char #\x p)
			      (pass-if "input tell back to 0"
				       (= (seek p 0 SEEK_CUR) 0))
			      (pass-if "input ungetted char"
				       (char=? (read-char p) #\x))
			      (seek p 0 SEEK_END)
			      (pass-if "input seek to end"
				       (= (seek p 0 SEEK_CUR)
					  (string-length text)))
			      (unread-char #\x p)
			      (pass-if "input seek to beginning"
				       (= (seek p 0 SEEK_SET) 0))
			      (pass-if "input reread first char"
				       (char=? (read-char p)
					       (string-ref text 0))))))

  ;; seeking an output string.
  (let* ((text (string-copy "123456789"))
	 (len (string-length text))
	 (result (call-with-output-string
		  (lambda (p)
		    (pass-if "output tell 0"
			     (= (seek p 0 SEEK_CUR) 0))
		    (display text p)
		    (pass-if "output tell end"
			     (= (seek p 0 SEEK_CUR) len))
		    (pass-if "output seek to beginning"
			     (= (seek p 0 SEEK_SET) 0))
		    (write-char #\a p)
		    (seek p -1 SEEK_END)
		    (pass-if "output seek to last char"
			     (= (seek p 0 SEEK_CUR)
				(- len 1)))
		    (write-char #\b p)))))
    (string-set! text 0 #\a)
    (string-set! text (- len 1) #\b)
    (pass-if "output check"
	     (string=? text result)))

  (pass-if "%default-port-encoding is honored"
    (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
      (equal? (map (lambda (e)
                     (with-fluids ((%default-port-encoding e))
                       (call-with-output-string
                         (lambda (p)
                           (display (port-encoding p) p)))))
                   encodings)
              encodings)))

  (pass-if "suitable encoding [latin-1]"
    (let ((str "hello, world"))
      (with-fluids ((%default-port-encoding "ISO-8859-1"))
        (equal? str
                (with-output-to-string
                  (lambda ()
                    (display str)))))))

  (pass-if "suitable encoding [latin-3]"
    (let ((str "ĉu bone?"))
      (with-fluids ((%default-port-encoding "ISO-8859-3"))
        (equal? str
                (with-output-to-string
                  (lambda ()
                    (display str)))))))

  (pass-if "wrong encoding"
    (let ((str "ĉu bone?"))
      (catch 'encoding-error
        (lambda ()
          ;; Latin-1 cannot represent ‘ĉ’.
          (with-fluids ((%default-port-encoding "ISO-8859-1"))
            (with-output-to-string
              (lambda ()
                (display str)))))
        (lambda (key subr message errno from to faulty-str)
          (and (eq? faulty-str str)
               (string=? from "UTF-32")
               (string=? to "ISO-8859-1")
               (string? (strerror errno))))))))

(with-test-prefix "call-with-output-string"

  ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
  ;; occur.
  (pass-if-exception "proc closes port" exception:wrong-type-arg
    (call-with-output-string close-port)))

;;;; 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))))

  (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))

  (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)))

;; Test port-line and port-column for output ports

(define (test-output-line-counter text final-column)
  (with-test-prefix "port-line and port-column for output ports"
    (let ((port (open-output-string)))
      (pass-if "at beginning of input"
	       (and (= (port-line port) 0)
		    (= (port-column port) 0)))
      (write-char #\x port)
      (pass-if "after writing one character"
	       (and (= (port-line port) 0)
		    (= (port-column port) 1)))
      (write-char #\newline port)
      (pass-if "after writing first newline char"
	       (and (= (port-line port) 1)
		    (= (port-column port) 0)))
      (display text port)
      (pass-if "line count is 5 at end"
	       (= (port-line port) 5))
      (pass-if "column is correct at end"
	       (= (port-column port) final-column)))))

(test-output-line-counter
 (string-append "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")
 15)

(with-test-prefix "port-column"

  (with-test-prefix "output"

    (pass-if "x"
      (let ((port (open-output-string)))
	(display "x" port)
	(= 1 (port-column port))))

    (pass-if "\\a"
      (let ((port (open-output-string)))
	(display "\a" port)
	(= 0 (port-column port))))

    (pass-if "x\\a"
      (let ((port (open-output-string)))
	(display "x\a" port)
	(= 1 (port-column port))))

    (pass-if "\\x08 backspace"
      (let ((port (open-output-string)))
	(display "\x08" port)
	(= 0 (port-column port))))

    (pass-if "x\\x08 backspace"
      (let ((port (open-output-string)))
	(display "x\x08" port)
	(= 0 (port-column port))))

    (pass-if "\\n"
      (let ((port (open-output-string)))
	(display "\n" port)
	(= 0 (port-column port))))

    (pass-if "x\\n"
      (let ((port (open-output-string)))
	(display "x\n" port)
	(= 0 (port-column port))))

    (pass-if "\\r"
      (let ((port (open-output-string)))
	(display "\r" port)
	(= 0 (port-column port))))

    (pass-if "x\\r"
      (let ((port (open-output-string)))
	(display "x\r" port)
	(= 0 (port-column port))))

    (pass-if "\\t"
      (let ((port (open-output-string)))
	(display "\t" port)
	(= 8 (port-column port))))

    (pass-if "x\\t"
      (let ((port (open-output-string)))
	(display "x\t" port)
	(= 8 (port-column port)))))

  (with-test-prefix "input"

    (pass-if "x"
      (let ((port (open-input-string "x")))
	(while (not (eof-object? (read-char port))))
	(= 1 (port-column port))))

    (pass-if "\\a"
      (let ((port (open-input-string "\a")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\a"
      (let ((port (open-input-string "x\a")))
	(while (not (eof-object? (read-char port))))
	(= 1 (port-column port))))

    (pass-if "\\x08 backspace"
      (let ((port (open-input-string "\x08")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\x08 backspace"
      (let ((port (open-input-string "x\x08")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\n"
      (let ((port (open-input-string "\n")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\n"
      (let ((port (open-input-string "x\n")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\r"
      (let ((port (open-input-string "\r")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "x\\r"
      (let ((port (open-input-string "x\r")))
	(while (not (eof-object? (read-char port))))
	(= 0 (port-column port))))

    (pass-if "\\t"
      (let ((port (open-input-string "\t")))
	(while (not (eof-object? (read-char port))))
	(= 8 (port-column port))))

    (pass-if "x\\t"
      (let ((port (open-input-string "x\t")))
	(while (not (eof-object? (read-char port))))
	(= 8 (port-column port))))))

(with-test-prefix "port-line"

  ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
  ;; scm_t_port actually holds a long; this restricted the range on 64-bit
  ;; systems
  (pass-if "set most-positive-fixnum/2"
    (let ((n    (quotient most-positive-fixnum 2))
	  (port (open-output-string)))
      (set-port-line! port n)
      (eqv? n (port-line port)))))

;;;
;;; port-for-each
;;;

(with-test-prefix "port-for-each"

  ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
  ;; its iterator func if a port was inaccessible in the last gc mark but
  ;; the lazy sweeping has not yet reached it to remove it from the port
  ;; table (scm_i_port_table).  Provoking those gc conditions is a little
  ;; tricky, but the following code made it happen in 1.8.2.
  (pass-if "passing freed cell"
    (let ((lst '()))
      ;; clear out the heap
      (gc) (gc) (gc)
      ;; allocate cells so the opened ports aren't at the start of the heap
      (make-list 1000)
      (open-input-file "/dev/null")
      (make-list 1000)
      (open-input-file "/dev/null")
      ;; this gc leaves the above ports unmarked, ie. inaccessible
      (gc)
      ;; but they're still in the port table, so this sees them
      (port-for-each (lambda (port)
		       (set! lst (cons port lst))))
      ;; this forces completion of the sweeping
      (gc) (gc) (gc)
      ;; and (if the bug is present) the cells accumulated in LST are now
      ;; freed cells, which give #f from `port?'
      (not (memq #f (map port? lst))))))

(with-test-prefix
 "fdes->port"
 (pass-if "fdes->ports finds port"
	  (let ((port (open-file (test-file) "w")))

	    (not (not (memq port (fdes->ports (port->fdes port))))))))

;;;
;;; seek
;;;

(with-test-prefix "seek"

  (with-test-prefix "file port"

    (pass-if "SEEK_CUR"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "abcde" port)))
      (let ((port (open-file (test-file) "r")))
	(read-char port)
	(seek port 2 SEEK_CUR)
	(eqv? #\d (read-char port))))

    (pass-if "SEEK_SET"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "abcde" port)))
      (let ((port (open-file (test-file) "r")))
	(read-char port)
	(seek port 3 SEEK_SET)
	(eqv? #\d (read-char port))))

    (pass-if "SEEK_END"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "abcde" port)))
      (let ((port (open-file (test-file) "r")))
	(read-char port)
	(seek port -2 SEEK_END)
	(eqv? #\d (read-char port))))))

;;;
;;; truncate-file
;;;

(with-test-prefix "truncate-file"

  (pass-if-exception "flonum file" exception:wrong-type-arg
    (truncate-file 1.0 123))

  (pass-if-exception "frac file" exception:wrong-type-arg
    (truncate-file 7/3 123))

  (with-test-prefix "filename"

    (pass-if-exception "flonum length" exception:wrong-type-arg
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (truncate-file (test-file) 1.0))

    (pass-if "shorten"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (truncate-file (test-file) 1)
      (eqv? 1 (stat:size (stat (test-file)))))

    (pass-if-exception "shorten to current pos" exception:miscellaneous-error
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (truncate-file (test-file))))

  (with-test-prefix "file descriptor"

    (pass-if "shorten"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let ((fd (open-fdes (test-file) O_RDWR)))
	(truncate-file fd 1)
	(close-fdes fd))
      (eqv? 1 (stat:size (stat (test-file)))))

    (pass-if "shorten to current pos"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let ((fd (open-fdes (test-file) O_RDWR)))
	(seek fd 1 SEEK_SET)
	(truncate-file fd)
	(close-fdes fd))
      (eqv? 1 (stat:size (stat (test-file))))))

  (with-test-prefix "file port"

    (pass-if "shorten"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let ((port (open-file (test-file) "r+")))
	(truncate-file port 1))
      (eqv? 1 (stat:size (stat (test-file)))))

    (pass-if "shorten to current pos"
      (call-with-output-file (test-file)
	(lambda (port)
	  (display "hello" port)))
      (let ((port (open-file (test-file) "r+")))
	(read-char port)
	(truncate-file port))
      (eqv? 1 (stat:size (stat (test-file)))))))

;;;; 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?))))))

;;;; Close current-input-port, and make sure everyone can handle it.

(with-test-prefix "closing current-input-port"
  (for-each (lambda (procedure name)
	      (with-input-from-port
		  (call-with-input-string "foo" (lambda (p) p))
		(lambda ()
		  (close-port (current-input-port))
		  (pass-if-exception name
		    exception:wrong-type-arg
		    (procedure)))))
	    (list read read-char read-line)
	    '("read" "read-char" "read-line")))

(delete-file (test-file))

license: mit


code:
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2004, 2006, 2007, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-posix)
  :use-module (test-suite lib))

;; FIXME: The following exec tests are disabled since on an i386 debian with
;; glibc 2.3.2 they seem to interact badly with threads.test, the latter
;; dies with signal 32 (one of the SIGRTs).  Don't know how or why, or who's
;; at fault (though it seems to happen with or without the recent memory
;; leak fix in these error cases).

;;
;; execl
;;

;; (with-test-prefix "execl"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execl "./nosuchprog" "./nosuchprog" "some arg")))

;;
;; execlp
;;

;; (with-test-prefix "execlp"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execlp "./nosuchprog" "./nosuchprog" "some arg")))

;;
;; execle
;;

;; (with-test-prefix "execle"
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execle "./nosuchprog" '() "./nosuchprog" "some arg"))
;;   (pass-if-exception "./nosuchprog" '(system-error . ".*")
;;     (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg")))

;;
;; mkstemp!
;;

(with-test-prefix "mkstemp!"

  ;; the temporary names used in the tests here are kept to 8 characters so
  ;; they'll work on a DOS 8.3 file system

  (define (string-copy str)
    (list->string (string->list str)))

  (pass-if-exception "number arg" exception:wrong-type-arg
    (mkstemp! 123))

  (pass-if "filename string modified"
    (let* ((template "T-XXXXXX")
	   (str      (string-copy template))
	   (port     (mkstemp! str))
	   (result   (not (string=? str template))))
      (delete-file str)
      result)))

;;
;; putenv
;;

(with-test-prefix "putenv"

  (pass-if "something"
    (putenv "FOO=something")
    (equal? "something" (getenv "FOO")))

  (pass-if "replacing"
    (putenv "FOO=one")
    (putenv "FOO=two")
    (equal? "two" (getenv "FOO")))

  (pass-if "empty"
    (putenv "FOO=")
    (equal? "" (getenv "FOO")))

  (pass-if "removing"
    (putenv "FOO=bar")
    (putenv "FOO")
    (not (getenv "FOO")))

  (pass-if "modifying string doesn't change env"
    (let ((s (string-copy "FOO=bar")))
      (putenv s)
      (string-set! s 5 #\x)
      (equal? "bar" (getenv "FOO")))))

;;
;; setenv
;;

(with-test-prefix "setenv"

  (pass-if "something"
    (setenv "FOO" "something")
    (equal? "something" (getenv "FOO")))

  (pass-if "replacing"
    (setenv "FOO" "one")
    (setenv "FOO" "two")
    (equal? "two" (getenv "FOO")))

  (pass-if "empty"
    (setenv "FOO" "")
    (equal? "" (getenv "FOO")))

  (pass-if "removing"
    (setenv "FOO" "something")
    (setenv "FOO" #f)
    (not (getenv "FOO"))))

;;
;; unsetenv
;;

(with-test-prefix "unsetenv"

  (pass-if "something"
    (putenv "FOO=something")
    (unsetenv "FOO")
    (not (getenv "FOO")))

  (pass-if "empty"
    (putenv "FOO=")
    (unsetenv "FOO")
    (not (getenv "FOO"))))

;;
;; ttyname
;;

(with-test-prefix "ttyname"

  (pass-if-exception "non-tty argument" exception:system-error
    ;; This used to crash in 1.8.1 and earlier.
    (let ((file (false-if-exception
                 (open-output-file "/dev/null"))))
      (if (not file)
          (throw 'unsupported)
          (ttyname file)))))

;;
;; utimes
;;

(with-test-prefix "utime"

  (pass-if "valid argument (second resolution)"
    (let ((file "posix.test-utime"))
      (dynamic-wind
        (lambda ()
          (close-port (open-output-file file)))
        (lambda ()
          (let* ((accessed (+ (current-time) 3600))
                 (modified (- accessed 1000)))
            (utime file accessed modified)
            (let ((info (stat file)))
              (and (= (stat:atime info) accessed)
                   (= (stat:mtime info) modified)))))
        (lambda ()
          (delete-file file))))))


code:
;;;; -*- coding: utf-8; mode: scheme; -*-
;;;;
;;;; Copyright (C) 2010  Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-print)
  #:use-module (ice-9 pretty-print)
  #:use-module (test-suite lib))

(with-test-prefix "truncated-print"
  (define exp '(a b #(c d e) f . g))

  (define (tprint x width encoding)
    (with-fluids ((%default-port-encoding encoding))
      (with-output-to-string
	(lambda ()
	  (truncated-print x #:width width)))))

  (pass-if (equal? (tprint exp 10 "ISO-8859-1")
		   "(a b . #)"))

  (pass-if (equal? (tprint exp 15 "ISO-8859-1")
		   "(a b # f . g)"))

  (pass-if (equal? (tprint exp 18 "ISO-8859-1")
		   "(a b #(c ...) . #)"))

  (pass-if (equal? (tprint exp 20 "ISO-8859-1")
		   "(a b #(c d e) f . g)"))

  (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
		   "\"The quick brown...\""))

  (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
		   "\"The quick brown f…\""))

  (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
		   "#<directory (tes...>"))

  (pass-if (equal? (tprint (current-module) 20 "UTF-8")
		   "#<directory (test-…>")))


code:
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; 	Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-procpop)
  :use-module (test-suite lib))

(with-test-prefix "procedure-name"
  (pass-if "simple subr"
    (eq? 'display (procedure-name display)))

  (pass-if "gsubr"
    (eq? 'hashq-ref (procedure-name hashq-ref))))

(with-test-prefix "procedure-arity"
  (pass-if "simple subr"
    (equal? (procedure-minimum-arity display)
            '(1 1 #f)))

  (pass-if "gsubr"
    (equal? (procedure-minimum-arity hashq-ref)
            '(2 1 #f)))

  (pass-if "port-closed?"
    (equal? (procedure-minimum-arity port-closed?)
            '(1 0 #f)))

  (pass-if "apply"
    (equal? (procedure-minimum-arity apply)
            '(1 0 #t)))

  (pass-if "cons*"
    (equal? (procedure-minimum-arity cons*)
            '(1 0 #t)))

  (pass-if "list"
    (equal? (procedure-minimum-arity list)
            '(0 0 #t))))


code:
;;;; q.test --- test (ice-9 q) module -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-ice-9-q)
  #:use-module (test-suite lib)
  #:use-module (ice-9 q))

;; Call (THUNK) and return #t if it throws 'q-empty, or #f it not.
(define (true-if-catch-q-empty thunk)
  (catch 'q-empty
    (lambda ()
      (thunk)
      #f)
    (lambda args
      #t)))

;;;
;;; q-pop!
;;;

(with-test-prefix "q-pop!"

  (with-test-prefix "no elems"
    (let ((q (make-q)))
      (pass-if "empty" (true-if-catch-q-empty
			(lambda ()
			  (q-pop! q))))
      (pass-if "valid at end" (q? q))))

  (with-test-prefix "one elem"
    (let ((x (cons 1 2))
	  (q (make-q)))
      (q-push! q x)

      (pass-if "x" (eq? x (q-pop! q)))
      (pass-if "valid after x" (q? q))
      (pass-if "empty" (true-if-catch-q-empty
			(lambda ()
			  (q-pop! q))))
      (pass-if "valid at end" (q? q))))

  (with-test-prefix "two elems"
    (let ((x (cons 1 2))
	  (y (cons 3 4))
	  (q (make-q)))
      (q-push! q x)
      (q-push! q y)

      (pass-if "y" (eq? y (q-pop! q)))
      (pass-if "valid after y" (q? q))
      (pass-if "x" (eq? x (q-pop! q)))
      (pass-if "valid after x" (q? q))
      (pass-if "empty" (true-if-catch-q-empty
			(lambda ()
			  (q-pop! q))))
      (pass-if "valid at end" (q? q))))

  (with-test-prefix "three elems"
    (let ((x (cons 1 2))
	  (y (cons 3 4))
	  (z (cons 5 6))
	  (q (make-q)))
      (q-push! q x)
      (q-push! q y)
      (q-push! q z)

      (pass-if "z" (eq? z (q-pop! q)))
      (pass-if "valid after z" (q? q))
      (pass-if "y" (eq? y (q-pop! q)))
      (pass-if "valid after y" (q? q))
      (pass-if "x" (eq? x (q-pop! q)))
      (pass-if "valid after x" (q? q))
      (pass-if "empty" (true-if-catch-q-empty
			(lambda ()
			  (q-pop! q))))
      (pass-if "valid at end" (q? q)))))


code:
;;;; r4rs.test --- tests for R4RS compliance      -*- scheme -*-
;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-r4rs)
  :use-module (test-suite lib)
  :use-module (test-suite guile-test))

;;;; ============= 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

;; Note: The following two expressions are being read as part of the tests in
;; section (6 10 2).  Those tests expect that above the following two
;; expressions there should be only one arbitrary s-expression (which is the
;; define-module expression).  Further, the two expressions should be written
;; on one single line without a blank between them.  If you change this, you
;; will also have to change the corresponding tests in section (6 10 2).

(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
      (data-file-name "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 (data-file-name "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 (test-file-name "r4rs.test") input-port?)
(define this-file (open-input-file (test-file-name "r4rs.test")))
(test #t input-port? this-file)
(SECTION 6 10 2)
(test #\; peek-char this-file)
(test #\; read-char this-file)
(read this-file) ;; skip define-module expression
(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
      (data-file-name "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 (data-file-name "tmp1"))

(define test-file (open-output-file (data-file-name "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 (data-file-name "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-name "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"

(delete-file (data-file-name "tmp1"))
(delete-file (data-file-name "tmp2"))
(delete-file (data-file-name "tmp3"))


code:
;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS     -*- scheme -*-
;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;; These tests have been copied from
;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
;; macro has been modified to fit into our test suite machinery.

(define-module (test-suite test-r5rs-pitfall)
  :use-module (test-suite lib))

(define-syntax should-be
  (syntax-rules ()
    ((_ test-id value expression)
     (run-test test-id #t (lambda ()
                            (false-if-exception
                             (equal? expression value)))))))

(define-syntax should-be-but-isnt
  (syntax-rules ()
    ((_ test-id value expression)
     (run-test test-id #f (lambda ()
                            (false-if-exception
                             (equal? expression value)))))))

(define call/cc call-with-current-continuation)

;; Section 1: Proper letrec implementation

;;Credits to Al Petrofsky
;; In thread:
;; defines in letrec body
;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com

(should-be 1.1 0
 (let ((cont #f))
   (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
            (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
     (if cont
         (let ((c cont))
           (set! cont #f)
           (set! x 1)
           (set! y 1)
           (c 0))
         (+ x y)))))

;;Credits to Al Petrofsky
;; In thread:
;; Widespread bug (arguably) in letrec when an initializer returns twice
;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
(should-be 1.2 #t
  (letrec ((x (call/cc list)) (y (call/cc list)))
    (cond ((procedure? x) (x (pair? y)))
          ((procedure? y) (y (pair? x))))
    (let ((x (car x)) (y (car y)))
      (and (call/cc x) (call/cc y) (call/cc x)))))

;;Credits to Alan Bawden
;; In thread:
;; LETREC + CALL/CC = SET! even in a limited setting
;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
(should-be 1.3 #t
  (letrec ((x (call-with-current-continuation
                  (lambda (c)
                    (list #T c)))))
      (if (car x)
          ((cadr x) (list #F (lambda () x)))
          (eq? x ((cadr x))))))

;; Section 2: Proper call/cc and procedure application

;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
;; In thread:
;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1
;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org
(should-be 2.1 1
 (call/cc (lambda (c) (0 (c 1)))))

;; Section 3: Hygienic macros

;; Eli Barzilay
;; In thread:
;; R5RS macros...
;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
(should-be 3.1 4
  (let-syntax ((foo
                (syntax-rules ()
                  ((_ expr) (+ expr 1)))))
    (let ((+ *))
      (foo 3))))

;; Al Petrofsky again
;; In thread:
;; Buggy use of begin in r5rs cond and case macros.
;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
(should-be 3.2 2
 (let-syntax ((foo (syntax-rules ()
                       ((_ var) (define var 1)))))
     (let ((x 2))
       (begin (define foo +))
       (cond (else (foo x)))
       x)))

;;Al Petrofsky
;; In thread:
;; An Advanced syntax-rules Primer for the Mildly Insane
;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org

(should-be 3.3 1
  (let ((x 1))
    (let-syntax
        ((foo (syntax-rules ()
                ((_ y) (let-syntax
                             ((bar (syntax-rules ()
                                   ((_) (let ((x 2)) y)))))
                         (bar))))))
      (foo x))))

;; Al Petrofsky
;; Contributed directly
(should-be 3.4 1
  (let-syntax ((x (syntax-rules ()))) 1))

;; Setion 4: No identifiers are reserved

;;(Brian M. Moore)
;; In thread:
;; shadowing syntatic keywords, bug in MIT Scheme?
;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
(should-be 4.1 '(x)
 ((lambda lambda lambda) 'x))

(should-be 4.2 '(1 2 3)
 ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))

(should-be 4.3 #f
 (let ((quote -)) (eqv? '1 1)))
;; Section 5: #f/() distinctness

;; Scott Miller
(should-be 5.1 #f
  (eq? #f '()))
(should-be 5.2 #f
  (eqv? #f '()))
(should-be 5.3 #f
  (equal? #f '()))

;; Section 6: string->symbol case sensitivity

;; Jens Axel S?gaard
;; In thread:
;; Symbols in DrScheme - bug?
;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
(should-be 6.1 #f
  (eq? (string->symbol "f") (string->symbol "F")))

;; Section 7: First class continuations

;; Scott Miller
;; No newsgroup posting associated.  The jist of this test and 7.2
;; is that once captured, a continuation should be unmodified by the
;; invocation of other continuations.  This test determines that this is
;; the case by capturing a continuation and setting it aside in a temporary
;; variable while it invokes that and another continuation, trying to
;; side effect the first continuation.  This test case was developed when
;; testing SISC 1.7's lazy CallFrame unzipping code.
(define r #f)
(define a #f)
(define b #f)
(define c #f)
(define i 0)
(should-be 7.1 28
  (let ()
    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
    (if (not c)
        (set! c a))
    (set! i (+ i 1))
    (case i
      ((1) (a 5))
      ((2) (b 8))
      ((3) (a 6))
      ((4) (c 4)))
    r))

;; Same test, but in reverse order
(define r #f)
(define a #f)
(define b #f)
(define c #f)
(define i 0)
(should-be 7.2 28
  (let ()
    (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
               (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
    (if (not c)
        (set! c a))
    (set! i (+ i 1))
    (case i
      ((1) (b 8))
      ((2) (a 5))
      ((3) (b 7))
      ((4) (c 4)))
    r))

;; Credits to Matthias Radestock
;; Another test case used to test SISC's lazy CallFrame routines.
(should-be 7.3 '((-1 4 5 3)
                 (4 -1 5 3)
                 (-1 5 4 3)
                 (5 -1 4 3)
                 (4 5 -1 3)
                 (5 4 -1 3))
  (let ((k1 #f)
        (k2 #f)
        (k3 #f)
        (state 0))
    (define (identity x) x)
    (define (fn)
      ((identity (if (= state 0)
                     (call/cc (lambda (k) (set! k1 k) +))
                     +))
       (identity (if (= state 0)
                     (call/cc (lambda (k) (set! k2 k) 1))
                     1))
       (identity (if (= state 0)
                     (call/cc (lambda (k) (set! k3 k) 2))
                     2))))
    (define (check states)
      (set! state 0)
      (let* ((res '())
             (r (fn)))
        (set! res (cons r res))
        (if (null? states)
            res
            (begin (set! state (car states))
                   (set! states (cdr states))
                   (case state
                     ((1) (k3 4))
                     ((2) (k2 2))
                     ((3) (k1 -)))))))
    (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))

;; Modification of the yin-yang puzzle so that it terminates and produces
;; a value as a result. (Scott G. Miller)
(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)
  (let ((x '())
        (y 0))
    (call/cc
     (lambda (escape)
       (let* ((yin ((lambda (foo)
                      (set! x (cons y x))
                      (if (= y 10)
                          (escape x)
                          (begin
                            (set! y 0)
                            foo)))
                    (call/cc (lambda (bar) bar))))
              (yang ((lambda (foo)
                       (set! y (+ y 1))
                       foo)
                     (call/cc (lambda (baz) baz)))))
         (yin yang))))))

;; Miscellaneous

;;Al Petrofsky
;; In thread:
;; R5RS Implementors Pitfalls
;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
(should-be 8.1 -1
  (let - ((n (- 1))) n))

(should-be 8.2 '(1 2 3 4 1 2 3 4 5)
  (let ((ls (list 1 2 3 4)))
    (append ls ls '(5))))

;;Not really an error to fail this (Matthias Radestock)
;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
;;tail-recursive.  If its (0 0 0), the opposite is true.
(should-be 8.3 '(0 1 0)
  (let ()
    (define executed-k #f)
    (define cont #f)
    (define res1 #f)
    (define res2 #f)
    (set! res1 (map (lambda (x)
                      (if (= x 0)
                          (call/cc (lambda (k) (set! cont k) 0))
                          0))
                    '(1 0 2)))
    (if (not executed-k)
        (begin (set! executed-k #t)
               (set! res2 res1)
               (cont 1)))
    res2))


code:
;;; arithmetic-bitwise.test --- Test suite for R6RS (rnrs arithmetic bitwise)

;;      Copyright (C) 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-r6rs-arithmetic-bitwise)
  :use-module ((rnrs arithmetic bitwise) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "bitwise-not"
  (pass-if "bitwise-not simple"
    (eqv? (bitwise-not 3) -4)))

(with-test-prefix "bitwise-and"
  (pass-if "bitwise-and simple"
    (eqv? (bitwise-and #b101 #b110) #b100)))

(with-test-prefix "bitwise-ior"
  (pass-if "bitwise-ior simple"
    (eqv? (bitwise-ior #b010 #b100) #b110)))

(with-test-prefix "bitwise-xor"
  (pass-if "bitwise-xor simple"
    (eqv? (bitwise-xor #b101 #b100) #b001)))

(with-test-prefix "bitwise-if"
  (pass-if "bitwise-if simple"
    (eqv? (bitwise-if #b101 #b011 #b100) #b001)))

(with-test-prefix "bitwise-bit-count"
  (pass-if "bitwise-bit-count simple"
    (eqv? (bitwise-bit-count #b101) 2)))

(with-test-prefix "bitwise-length"
  (pass-if "bitwise-length simple"
    (eqv? (bitwise-length #b101) 3))
  (pass-if "bitwise-length leading zeros"
    (eqv? (bitwise-length #b001) 1)))

(with-test-prefix "bitwise-first-bit-set"
  (pass-if "bitwise-first-bit-set simple"
    (and (eqv? (bitwise-first-bit-set 1) 0)
         (eqv? (bitwise-first-bit-set -4) 2)))
  (pass-if "bitwise-first-bit-set zero"
    (and (eqv? (bitwise-first-bit-set 0) -1))))

(with-test-prefix "bitwise-copy-bit"
  (pass-if "bitwise-copy-bit simple"
    (eqv? (bitwise-copy-bit #b010 2 #b111) #b110)))

(with-test-prefix "bitwise-bit-field"
  (pass-if "bitwise-bit-field simple"
    (eqv? (bitwise-bit-field #b110010 1 4) #b001)))

(with-test-prefix "bitwise-copy-bit-field"
  (pass-if "bitwise-copy-bit-field simple"
    (eqv? (bitwise-copy-bit-field #b11111111 2 6 #b1010) #b11101011)))

(with-test-prefix "bitwise-arithmetic-shift"
  (pass-if "bitwise-arithmetic-shift simple"
    (and (eqv? (bitwise-arithmetic-shift -6 -1) -3)
         (eqv? (bitwise-arithmetic-shift -5 -1) -3)
	 (eqv? (bitwise-arithmetic-shift -4 -1) -2)
	 (eqv? (bitwise-arithmetic-shift -3 -1) -2)
	 (eqv? (bitwise-arithmetic-shift -2 -1) -1)
	 (eqv? (bitwise-arithmetic-shift -1 -1) -1))))

(with-test-prefix "bitwise-arithmetic-shift-left"
  (pass-if "bitwise-arithmetic-shift-left simple"
    (eqv? (bitwise-arithmetic-shift-left -6 -1) -3)))

(with-test-prefix "bitwise-arithmetic-shift-right"
  (pass-if "bitwise-arithmetic-shift-right simple"
    (eqv? (bitwise-arithmetic-shift-right -6 1) -3)))

(with-test-prefix "bitwise-rotate-bit-field"
  (pass-if "bitwise-rotate-bit-field simple"
    (eqv? (bitwise-rotate-bit-field #b11100011 2 6 2) #b11001011)))

(with-test-prefix "bitwise-reverse-bit-field"
  (pass-if "bitwise-reverse-bit-field simple"
    (eqv? (bitwise-reverse-bit-field #b1010010 1 4) #b1011000)))


code:
;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise)

;;      Copyright (C) 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-r6rs-arithmetic-fixnums)
  :use-module ((rnrs arithmetic fixnums) :version (6))
  :use-module ((rnrs conditions) :version (6))
  :use-module ((rnrs exceptions) :version (6))
  :use-module (test-suite lib))

(with-test-prefix "fixnum?"
  (pass-if "fixnum? is #t for fixnums" (fixnum? 0))

  (pass-if "fixnum? is #f for non-fixnums" (not (fixnum? 'foo)))

  (pass-if "fixnum? is #f for non-fixnum numbers"
    (and (not (fixnum? 1.0)) (not (fixnum? (+ (greatest-fixnum) 1))))))

(with-test-prefix "fx=?"
  (pass-if "fx=? is #t for eqv inputs" (fx=? 3 3 3))

  (pass-if "fx=? is #f for non-eqv inputs" (not (fx=? 1 2 3))))

(with-test-prefix "fx>?"
  (pass-if "fx>? is #t for monotonically > inputs" (fx>? 3 2 1))

  (pass-if "fx>? is #f for non-monotonically > inputs" (not (fx>? 1 2 3))))

(with-test-prefix "fx<?"
  (pass-if "fx<? is #t for monotonically < inputs" (fx<? 1 2 3))

  (pass-if "fx<? is #t for non-monotonically < inputs" (not (fx<? 3 2 1))))

(with-test-prefix "fx>=?"
  (pass-if "fx>=? is #t for monotonically > or = inputs" (fx>=? 3 2 2 1))

  (pass-if "fx>=? is #f for non-monotonically > or = inputs"
    (not (fx>=? 1 2 3))))

(with-test-prefix "fx<=?"
  (pass-if "fx<=? is #t for monotonically < or = inputs" (fx<=? 1 2 2 3))

  (pass-if "fx<=? is #f for non-monotonically < or = inputs"
    (not (fx<=? 3 2 1))))

(with-test-prefix "fxzero?"
  (pass-if "fxzero? is #t for zero" (fxzero? 0))

  (pass-if "fxzero? is #f for non-zero fixnums"
    (and (not (fxzero? 1)) (not (fxzero? -1)))))

(with-test-prefix "fxpositive?"
  (pass-if "fxpositive? is #t for positive fixnums" (fxpositive? 1))

  (pass-if "fxpositive? is #f for non-positive fixnums"
    (and (not (fxpositive? -1))
	 (not (fxpositive? 0)))))

(with-test-prefix "fxnegative?"
  (pass-if "fxnegative? is #t for negative fixnums" (fxnegative? -1))

  (pass-if "fxnegative? is #f for non-negative fixnums"
    (and (not (fxnegative? 1))
	 (not (fxnegative? 0)))))

(with-test-prefix "fxodd?"
  (pass-if "fxodd? is #t for odd fixnums" (fxodd? 1))

  (pass-if "fxodd? is #f for even fixnums" (not (fxodd? 2))))

(with-test-prefix "fxeven?"
  (pass-if "fxeven? is #t for even fixnums" (fxeven? 2))

  (pass-if "fxeven? is #f for odd fixnums" (not (fxeven? 1))))

(with-test-prefix "fxmax" (pass-if "simple" (fx=? (fxmax 1 3 2) 3)))

(with-test-prefix "fxmin" (pass-if "simple" (fx=? (fxmin -1 0 2) -1)))

(with-test-prefix "fx+"
  (pass-if "simple" (fx=? (fx+ 1 2) 3))

  (pass-if "&implementation-restriction on non-fixnum result"
    (guard (condition ((implementation-restriction-violation? condition) #t)
		      (else #f))
	   (begin (fx+ (greatest-fixnum) 1) #f))))

(with-test-prefix "fx*"
  (pass-if "simple" (fx=? (fx* 2 3) 6))

  (pass-if "&implementation-restriction on non-fixnum result"
    (guard (condition ((implementation-restriction-violation? condition) #t)
		      (else #f))
	   (begin (fx* (greatest-fixnum) 2) #f))))

(with-test-prefix "fx-"
  (pass-if "unary fx- negates argument" (fx=? (fx- 1) -1))

  (pass-if "simple" (fx=? (fx- 3 2) 1))

  (pass-if "&assertion on non-fixnum result"
    (guard (condition ((assertion-violation? condition) #t) (else #f))
	   (fx- (least-fixnum) 1))))

(with-test-prefix "fxdiv-and-mod"
  (pass-if "simple"
    (call-with-values (lambda () (fxdiv-and-mod 123 10))
      (lambda (d m)
	(or (and (fx=? d 12) (fx=? m 3))
	    (throw 'unresolved))))))

(with-test-prefix "fxdiv"
  (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved))))

(with-test-prefix "fxmod"
  (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved))))

(with-test-prefix "fxdiv0-and-mod0"
  (pass-if "simple"
    (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
      (lambda (d m)
	(or (and (fx=? d 12) (fx=? m -3))
	    (throw 'unresolved))))))

(with-test-prefix "fxdiv0"
  (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved))))

(with-test-prefix "fxmod0"
  (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved))))

;; Without working div and mod implementations and without any example results
;; from the spec, I have no idea what the results of these functions should
;; be.  -juliang

(with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))

(with-test-prefix "fx-/carry" (pass-if "simple" (throw 'unresolved)))

(with-test-prefix "fx*/carry" (pass-if "simple" (throw 'unresolved)))

(with-test-prefix "fxnot" (pass-if "simple" (fx=? (fxnot 3) -4)))

(with-test-prefix "fxand" (pass-if "simple" (fx=? (fxand 5 6) 4)))

(with-test-prefix "fxior" (pass-if "simple" (fx=? (fxior 2 4) 6)))

(with-test-prefix "fxxor" (pass-if "simple" (fx=? (fxxor 5 4) 1)))

(with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))

(with-test-prefix "fxbit-count" (pass-if "simple" (fx=? (fxbit-count 5) 2)))

(with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))

(with-test-prefix "fxfirst-bit-set"
  (pass-if "simple"
    (and (eqv? (fxfirst-bit-set 1) 0)
         (eqv? (fxfirst-bit-set -4) 2)))

  (pass-if "fxfirst-bit-set is -1 on zero"
    (and (eqv? (fxfirst-bit-set 0) -1))))

(with-test-prefix "fxbit-set?"
  (pass-if "fxbit-set? is #t on index of set bit" (fxbit-set? 5 2))

  (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1))))

(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 7) 6)))

(with-test-prefix "fxbit-field"
  (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))

(with-test-prefix "fxcopy-bit-field"
  (pass-if "simple" (fx=? (fxcopy-bit-field 255 2 6 10) 235)))

(with-test-prefix "fxarithmetic-shift"
  (pass-if "simple"
    (and (fx=? (fxarithmetic-shift -6 -1) -3)
         (fx=? (fxarithmetic-shift -5 -1) -3)
	 (fx=? (fxarithmetic-shift -4 -1) -2)
	 (fx=? (fxarithmetic-shift -3 -1) -2)
	 (fx=? (fxarithmetic-shift -2 -1) -1)
	 (fx=? (fxarithmetic-shift -1 -1) -1))))

(with-test-prefix "fxarithmetic-shift-left"
  (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3)))

(with-test-prefix "fxarithmetic-shift-right"
  (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))

(with-test-prefix "fxrotate-bit-field"
  (pass-if "simple" (fx=? (fxrotate-bit-field 227 2 6 2) 203)))

(with-test-prefix "fxreverse-bit-field"
  (pass-if "simple" (fx=? (fxreverse-bit-field 82 1 4) 88)))