Initial checkin of the Guile test suite.

test-suite/README

@@ -0,0 +1,21 @@
+This directory contains some tests for Guile, and some generic test
+support code.
+
+Right now, we only have tests for I/O ports.
+
+To run the test suite, you'll need to:
+- edit the path to the guile interpreter in `guile-test', and 
+- edit the paths in `paths.scm', so `guile-test' can find the test
+  scripts.
+
+Once that's done, you can just run the `guile-test' script.  That
+script has usage instructions in the comments at the top.
+
+You can reference the file `lib.scm' from your own code as the module
+(test-suite lib); it also has comments at the top and before each
+function explaining what's going on.
+
+Please write more Guile tests, and send them to bug-guile@gnu.org.
+We'll merge them into the distribution.  All test suites must be
+licensed for our use under the GPL, but I don't think I'm going to
+collect assignment papers for them.

test-suite/guile-test

@@ -0,0 +1,162 @@
+#!/usr/local/bin/guile \
+-e main -s
+!#
+
+;;;; guile-test --- run the Guile test suite
+;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
+;;;;
+;;;; 	Copyright (C) 1999 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+
+
+;;;; Usage: guile-test [--log-file LOG] [TEST ...]
+;;;;
+;;;; Run tests from the Guile test suite.  Report failures and
+;;;; unexpected passes to the standard output, along with a summary of
+;;;; all the results.  Record each reported test outcome in the log
+;;;; file, `guile.log'.
+;;;;
+;;;; Normally, guile-test scans the test directory, and executes all
+;;;; files whose names end in `.test'.  (It assumes they contain
+;;;; Scheme code.)  However, you can have it execute specific tests by
+;;;; listing their filenames on the command line.
+;;;;
+;;;; If present, the `--log-file LOG' option tells `guile-test' to put
+;;;; the log output in a file named LOG.
+;;;;
+;;;; Installation:
+;;;;
+;;;; Change the #! line at the top of this script to point at the
+;;;; Guile interpreter you want to test.  Edit `test-suite/paths.scm'
+;;;; so that datadir points to the parent directory of the `tests' tree.
+;;;;
+;;;; Shortcomings:
+;;;;
+;;;; At the moment, due to a simple-minded implementation, test files
+;;;; must live in the test directory, and you must specify their names
+;;;; relative to the top of the test directory.  If you want to send
+;;;; me a patche that fixes this, but still leaves sane test names in
+;;;; the log file, that would be great.  At the moment, all the tests
+;;;; I care about are in the test directory, though.
+;;;;
+;;;; It would be nice if you could specify the Guile interpreter you
+;;;; want to test on the command line.  As it stands, if you want to
+;;;; change which Guile interpreter you're testing, you need to edit
+;;;; the #! line at the top of this file, which is stupid.
+
+(use-modules (test-suite lib)
+	     (test-suite paths)
+	     (ice-9 getopt-long)
+	     (ice-9 and-let*))
+
+
+;;; General utilities, that probably should be in a library somewhere.
+
+;;; Traverse the directory tree at ROOT, applying F to the name of
+;;; each file in the tree, including ROOT itself.  For a subdirectory
+;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
+;;; symlinks.
+(define (for-each-file f root)
+
+  ;; A "hard directory" is a path that denotes a directory and is not a 
+  ;; symlink.
+  (define (file-is-hard-directory? filename)
+    (eq? (stat:type (lstat filename)) 'directory))
+
+  (let visit ((root root))
+    (let ((should-recur (f root)))
+      (if (and should-recur (file-is-hard-directory? root))
+	  (let ((dir (opendir root)))
+	    (let loop ()
+	      (let ((entry (readdir dir)))
+		(cond 
+		 ((eof-object? entry) #f)
+		 ((or (string=? entry ".")
+		      (string=? entry ".."))
+		  (loop))
+		 (else
+		  (visit (string-append root "/" entry))
+		  (loop))))))))))
+
+
+
+;;; The test driver.
+
+(define test-root (in-vicinity datadir "tests"))
+
+(define (test-file-name test)
+  (in-vicinity test-root test))
+
+;;; Return a list of all the test files in the test tree.
+(define (enumerate-tests)
+  (let ((root-len (+ 1 (string-length test-root)))
+	(tests '()))
+    (for-each-file (lambda (file)
+		     (if (has-suffix? file ".test")
+			 (let ((short-name
+				(substring file root-len)))
+			   (set! tests (cons short-name tests))))
+		     #t)
+		   test-root)
+
+    ;; for-each-file presents the files in whatever order it finds
+    ;; them in the directory.  We sort them here, so they'll always
+    ;; appear in the same order.  This makes it easier to compare test
+    ;; log files mechanically.
+    (sort tests string<?)))
+
+(define (main args)
+  (let ((options (getopt-long args
+			      `((log-file (single-char #\l)
+					  (value #t))))))
+    (define (opt tag default)
+      (let ((pair (assq tag options)))
+	(if pair (cdr pair) default)))
+    (let ((log-file (opt 'log-file "guile.log"))
+	  (tests (let ((foo (opt '() '())))
+		   (if (null? foo) (enumerate-tests)
+		       foo))))
+
+      ;; Open the log file.
+      (let ((log-port (open-output-file log-file)))
+
+	;; Register some reporters.
+	(let ((counter (make-count-reporter)))
+	  (register-reporter (car counter))
+	  (register-reporter (make-log-reporter log-port))
+	  (register-reporter user-reporter)
+
+	  ;; Run the tests.
+	  (for-each (lambda (test)
+		      (with-test-prefix test
+			(catch-test-errors
+			 (load (test-file-name test)))))
+		    tests)
+
+	  ;; Display the final counts, both to the user and in the log
+	  ;; file.
+	  (let ((counts ((cadr counter))))
+	    (print-counts counts)
+	    (print-counts counts log-port))
+
+	  (close-port log-port))))))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; End:

test-suite/lib.scm

@@ -0,0 +1,381 @@
+;;;; test-suite/lib.scm --- generic support for testing
+;;;; 	Copyright (C) 1999 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(define-module (test-suite lib))
+
+(export
+
+ ;; Reporting passes and failures.
+ pass fail pass-if
+
+ ;; Indicating tests that are expected to fail.
+ expect-failure expect-failure-if expect-failure-if*
+
+ ;; Marking independent groups of tests.
+ catch-test-errors catch-test-errors*
+
+ ;; Naming groups of tests in a regular fashion.
+ with-test-prefix with-test-prefix* current-test-prefix
+
+ ;; Reporting results in various ways.
+ register-reporter unregister-reporter reporter-registered?
+ make-count-reporter print-counts
+ make-log-reporter 
+ user-reporter
+ format-test-name)
+
+
+;;;; If you're using Emacs's Scheme mode:
+;;;;   (put 'expect-failure 'scheme-indent-function 0)
+;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
+
+
+;;;; TEST NAMES
+;;;;
+;;;; Every test in the test suite has a unique name, to help
+;;;; developers find tests that are failing (or unexpectedly passing),
+;;;; and to help gather statistics.
+;;;;
+;;;; A test name is a list of printable objects.  For example:
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Test names may contain arbitrary objects, but they always have
+;;;; the following properties:
+;;;; - Test names can be compared with EQUAL?.
+;;;; - Test names can be reliably stored and retrieved with the standard WRITE
+;;;;   and READ procedures; doing so preserves their identity.
+;;;; 
+;;;; The functions for reporting results (PASS, FAIL, PASS-IF, ...)
+;;;; take the name of the passing/failing test as an argument.
+;;;; For example:
+;;;; 
+;;;;    (if (= 4 (+ 2 2))
+;;;;      (pass "simple addition"))
+;;;; 
+;;;; In that case, the test name is the list ("simple addition").
+;;;;
+;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
+;;;; a prefix for the names of all tests whose results are reported
+;;;; within their dynamic scope.  For example:
+;;;; 
+;;;; (begin
+;;;;   (with-test-prefix "basic arithmetic"
+;;;;     (pass-if "addition" (= (+ 2 2) 4))
+;;;;     (pass-if "division" (= (- 4 2) 2)))
+;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
+;;;; 
+;;;; In that example, the three test names are:
+;;;;   ("basic arithmetic" "addition"),
+;;;;   ("basic arithmetic" "division"), and
+;;;;   ("multiplication").
+;;;;
+;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
+;;;; a new element to the current prefix:
+;;;; 
+;;;; (with-test-prefix "arithmetic"
+;;;;   (with-test-prefix "addition"
+;;;;     (pass-if "integer" (= (+ 2 2) 4))
+;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
+;;;;   (with-test-prefix "subtraction"
+;;;;     (pass-if "integer" (= (- 2 2) 0))
+;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
+;;;; 
+;;;; The four test names here are:
+;;;;   ("arithmetic" "addition" "integer")
+;;;;   ("arithmetic" "addition" "complex")
+;;;;   ("arithmetic" "subtraction" "integer")
+;;;;   ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by ": ".  So, the last set of test names would be
+;;;; reported as:
+;;;; 
+;;;;   arithmetic: addition: integer
+;;;;   arithmetic: addition: complex
+;;;;   arithmetic: subtraction: integer
+;;;;   arithmetic: subtraction: complex
+;;;;
+;;;; The Guile benchmarks use with-test-prefix to include the name of
+;;;; the source file containing the test in the test name, to help
+;;;; developers to find failing tests, and to provide each file with its
+;;;; own namespace.
+
+
+;;;; REPORTERS
+
+;;;; A reporter is a function which we apply to each test outcome.
+;;;; Reporters can log results, print interesting results to the
+;;;; standard output, collect statistics, etc.
+;;;; 
+;;;; A reporter function takes one argument, RESULT; its return value
+;;;; is ignored.  RESULT has one of the following forms:
+;;;;
+;;;; (pass TEST)    - The test named TEST passed.
+;;;; (fail TEST)    - The test named TEST failed.
+;;;; (xpass TEST)   - The test named TEST passed unexpectedly.
+;;;; (xfail TEST)   - The test named TEST failed, as expected.
+;;;; (error PREFIX) - An error occurred, with TEST as the current
+;;;;                  test name prefix.  Some tests were
+;;;;                  probably not executed because of this.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, and
+;;;; collecting totals.
+
+
+;;;; with-test-prefix: naming groups of tests
+;;;; See the discussion of TEST
+
+;;; A fluid containing the current test prefix, as a list.
+(define prefix-fluid (make-fluid))
+(fluid-set! prefix-fluid '())
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-test-prefix*.  Return the value returned by THUNK.
+(define (with-test-prefix* prefix thunk)
+  (with-fluids ((prefix-fluid
+		 (append (fluid-ref prefix-fluid) (list prefix))))
+    (thunk)))
+
+;;; (with-test-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-test-prefix expression.  Return the value returned by the last
+;;; BODY expression.
+(defmacro with-test-prefix (prefix . body)
+  `(with-test-prefix* ,prefix (lambda () ,@body)))
+
+(define (current-test-prefix)
+  (fluid-ref prefix-fluid))
+
+
+;;;; register-reporter, etc. --- the global reporter list
+
+;;; The global list of reporters.
+(define reporters '())
+
+;;; Add the procedure REPORTER to the current set of reporter functions.
+;;; Signal an error if that reporter procedure object is already registered.
+(define (register-reporter reporter)
+  (if (memq reporter reporters)
+      (error "register-reporter: reporter already registered: " reporter))
+  (set! reporters (cons reporter reporters)))
+
+;;; Remove the procedure REPORTER from the current set of reporter
+;;; functions.  Signal an error if REPORTER is not currently registered.
+(define (unregister-reporter reporter)
+  (if (memq reporter reporters)
+      (set! reporters (delq! reporter reporters))
+      (error "unregister-reporter: reporter not registered: " reporter)))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+  (if (memq reporter reporters) #t #f))
+
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report result)
+  (for-each (lambda (reporter) (reporter result))
+	    reporters))
+
+
+;;;; Some useful reporter functions.
+
+;;; Return a list of the form (COUNTER RESULTS), where:
+;;; - COUNTER is a reporter procedure, and
+;;; - RESULTS is a procedure taking no arguments which returns the
+;;;   results seen so far by COUNTER.  The return value is an alist
+;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
+(define (make-count-reporter)
+  (let ((counts (map (lambda (outcome) (cons outcome 0))
+		     '(pass fail xpass xfail error))))
+    (list
+     (lambda (result)
+       (let ((pair (assq (car result) counts)))
+	 (if pair (set-cdr! pair (+ 1 (cdr pair)))
+	     (error "count-reporter: unexpected test result: " result))))
+     (lambda ()
+       (append counts '())))))
+
+;;; Print a count reporter's results nicely.  Pass this function the value
+;;; returned by a count reporter's RESULTS procedure.
+(define print-counts
+  (let ((tags '(pass fail xpass xfail error))
+	(labels
+	 '("passes:               "
+	   "failures:             "
+	   "unexpected passes:    "
+	   "unexpected failures:  "
+	   "errors:               ")))
+    (lambda (results . port?)
+      (let ((port (if (pair? port?) 
+		      (car port?)
+		      (current-output-port))))
+	(newline port)
+	(display-line-port port "Totals for this test run:")
+	(for-each
+	 (lambda (tag label)
+	   (let ((result (assq tag results)))
+	     (if result
+		 (display-line-port port label (cdr result))
+		 (display-line-port port
+				    "Test suite bug: "
+				    "no total available for `" tag "'"))))
+	 tags labels)
+	(newline port)))))
+				 
+;;; Handy functions.  Should be in a library somewhere.
+(define (display-line . objs)
+  (for-each display objs)
+  (newline))
+(define (display-line-port port . objs)
+  (for-each (lambda (obj) (display obj port))
+	    objs)
+  (newline port))
+
+;;; Turn a test name into a nice human-readable string.
+(define (format-test-name name)
+  (call-with-output-string
+   (lambda (port)
+     (let loop ((name name))
+       (if (pair? name) 
+	   (begin 
+	     (display (car name) port)
+	     (if (pair? (cdr name))
+		 (display ": " port))
+	     (loop (cdr name))))))))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form.  FILE may be a filename, or a port.
+(define (make-log-reporter file)
+  (let ((port (if (output-port? file) file
+		  (open-output-file file))))
+    (lambda (result)
+      (display (car result) port)
+      (display ": " port)
+      (display (format-test-name (cadr result)) port)
+      (newline port)
+      (force-output port))))
+
+;;; A reporter procedure which shows interesting results (failures,
+;;; unexpected passes) to the user.
+(define (user-reporter result)
+  (let ((label (case (car result)
+		 ((fail) "FAIL")
+		 ((xpass) "XPASS")
+		 (else #f))))
+    (if label
+	(display-line label ": " (format-test-name (cdr result))))))
+
+
+;;;; Marking independent groups of tests.
+
+;;; When test code encounters an error (like "file not found" or "()
+;;; is not a pair"), that may mean that that particular test can't
+;;; continue, or that some nearby tests shouldn't be run, but it
+;;; doesn't mean the whole test suite must be aborted.
+;;;
+;;; Wrap each group of interdependent tests in a CATCH-TEST-ERRORS
+;;; form, so that if an error occurs, that group will be aborted, but
+;;; control will continue after the catch-test-errors form.
+
+;;; Evaluate thunk, catching errors.  If THUNK returns without
+;;; signalling any errors, return a list containing its value.
+;;; Otherwise, return #f.
+(define (catch-test-errors* thunk)
+
+  (letrec ((handler
+	    (lambda (key . args)
+	      (display-line "ERROR in test "
+			    (format-test-name (current-test-prefix))
+			    ":")
+	      (apply display-error
+		     (make-stack #t handler)
+		     (current-error-port)
+		     args)
+	      (throw 'catch-test-errors))))
+
+    ;; I don't know if we should really catch everything here.  If you
+    ;; find a case where an error is signalled which really should abort
+    ;; the whole test case, feel free to adjust this appropriately.
+    (catch 'catch-test-errors
+	   (lambda ()
+	     (lazy-catch #t
+			 (lambda () (list (thunk)))
+			 handler))
+	   (lambda args
+	     (report (list 'error (current-test-prefix)))
+	     #f))))
+
+;;; (catch-test-errors BODY ...)
+;;; Evaluate the expressions BODY ...  If a BODY expression signals an
+;;; error, record that in the test results, and return #f.  Otherwise,
+;;; return a list containing the value of the last BODY expression.
+(defmacro catch-test-errors body
+  `(catch-test-errors* (lambda () ,@body)))
+
+
+;;;; Indicating tests that are expected to fail.
+
+;;; Fluid indicating whether we're currently expecting tests to fail.
+(define expected-failure-fluid (make-fluid))
+
+;;; Hmm.  The documentation treats EXPECT-FAILURE-IF as the primitive,
+;;; but in the implementation, EXPECT-FAILURE-IF* is the primitive.
+
+;;; (expect-failure-if TEST BODY ...)
+;;; Evaluate the expression TEST, then evaluate BODY ...
+;;; If TEST evaluates to a true value, expect all tests whose results
+;;; are reported by the BODY expressions to fail.
+;;; Return the value of the last BODY form.
+(defmacro expect-failure-if (test . body)
+  `(expect-failure-if* ,test (lambda () ,@body)))
+
+;;; Call THUNK; if SHOULD-FAIL is true, expect any tests whose results
+;;; are reported by THUNK to fail.  Return the value returned by THUNK.
+(define (expect-failure-if* should-fail thunk)
+  (with-fluids ((expected-failure-fluid (not (not should-fail))))
+    (thunk)))
+
+;;; (expect-failure BODY ...)
+;;; Evaluate the expressions BODY ..., expecting all tests whose results
+;;; they report to fail.
+(defmacro expect-failure body 
+  `(expect-failure-if #t ,@body))
+
+(define (pessimist?)
+  (fluid-ref expected-failure-fluid))
+
+
+;;;; Reporting passes and failures.
+
+(define (full-name name)
+  (append (current-test-prefix) (list name)))
+
+(define (pass name)
+  (report (list (if (pessimist?) 'xpass 'pass)
+		(full-name name))))
+
+(define (fail name)
+  (report (list (if (pessimist?) 'xfail 'fail)
+		(full-name name))))
+
+(define (pass-if name condition)
+  ((if condition pass fail) name))

test-suite/paths.scm

@@ -0,0 +1,2 @@
+(define-module (test-suite paths))
+(define-public datadir "/home/jimb/guile/src/modules/guile-modules/test-suite")

test-suite/tests/ports.test

@@ -0,0 +1,193 @@
+;;;; ports.test --- test suite for Guile I/O ports
+;;;; Jim Blandy <jimb@red-bean.com> --- October 1998
+;;;;
+;;;; 	Copyright (C) 1999 Free Software Foundation, Inc.
+;;;; 
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;; 
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING.  If not, write to
+;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;;;; Boston, MA 02111-1307 USA
+
+(use-modules (test-suite lib))
+
+(define (display-line . args)
+  (for-each display args)
+  (newline))
+
+(define (test-file)
+  (tmpnam))
+
+
+;;;; Some general utilities for testing ports.
+
+;;; Read from PORT until EOF, and return the result as a string.
+(define (read-all port)
+  (let loop ((chars '()))
+    (let ((char (read-char port)))
+      (if (eof-object? char)
+	  (list->string (reverse! chars))
+	  (loop (cons char chars))))))
+
+(define (read-file filename)
+  (let* ((port (open-input-file filename))
+	 (string (read-all port)))
+    (close-port port)
+    string))
+
+
+;;;; Normal file ports.
+
+;;; Write out an s-expression, and read it back.
+(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))
+
+
+;;;; Pipe ports.
+
+;;; Run a command, and read its output.
+(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
+       (in-string (read-all pipe)))
+  (close-port 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-port 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.
+
+;;; 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 "output string: 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 "input and output string: write/read sexpr"
+	   (equal? in-sexpr sexpr)))
+
+
+;;;; Soft ports.  No tests implemented yet.
+
+
+;;;; Generic operations across all port types.
+
+(let ((port-loop-temp (test-file)))
+
+  ;; Return a list of input ports that all return the same text.
+  ;; We map tests over this list.
+  (define (input-port-list text)
+    
+    ;; Create a text file some of the ports will use.
+    (let ((out-port (open-output-file port-loop-temp)))
+      (display text out-port)
+      (close-port out-port))
+
+    (list (open-input-file port-loop-temp)
+	  (open-input-pipe (string-append "cat " port-loop-temp))
+	  (call-with-input-string text (lambda (x) x))
+	  ;; We don't test soft ports at the moment.
+	  ))
+
+  (define port-list-names '("file" "pipe" "string"))
+
+  ;; Test the line counter.
+  (define (test-line-counter text second-line)
+    (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))
+	     (let loop ()
+	       (if (not (eof-object? (read-line port)))
+		   (loop)))
+	     (pass-if "line count is 5 at EOF"
+		      (= (port-line port) 5))))
+	 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"))
+
+  (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")))