X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fstream.impure.lisp;h=8d0fc37ce138a422199d06248d07b341acde2c5e;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=f133a356ed33dfd814ac9f08ef196e918fc0f067;hpb=eadbbfbdfa228593bbc0841f38a44b5d8985a2fe;p=sbcl.git

diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index f133a35..8d0fc37 100644
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -6,7 +6,7 @@
 ;;;; While most of SBCL is derived from the CMU CL system, the test
 ;;;; files (like this one) were written from scratch after the fork
 ;;;; from CMU CL.
-;;;; 
+;;;;
 ;;;; This software is in the public domain and is provided with
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
@@ -19,11 +19,11 @@
 (locally
     (declare (optimize (safety 3)))
   (assert (raises-error? (make-two-way-stream (make-string-output-stream)
-					      (make-string-output-stream))
-			 type-error))
+                                              (make-string-output-stream))
+                         type-error))
   (assert (raises-error? (make-two-way-stream (make-string-input-stream "foo")
-					      (make-string-input-stream "bar"))
-			 type-error))
+                                              (make-string-input-stream "bar"))
+                         type-error))
   ;; the following two aren't actually guaranteed, because ANSI, as it
   ;; happens, doesn't say "should signal an error" for
   ;; MAKE-ECHO-STREAM. It's still good to have, but if future
@@ -31,15 +31,15 @@
   ;; MAKE-ECHO-STREAM clauses, consider simply removing these clauses
   ;; from the test. -- CSR, 2002-10-06
   (assert (raises-error? (make-echo-stream (make-string-output-stream)
-					   (make-string-output-stream))
-			 type-error))
+                                           (make-string-output-stream))
+                         type-error))
   (assert (raises-error? (make-echo-stream (make-string-input-stream "foo")
-					   (make-string-input-stream "bar"))
-			 type-error))
+                                           (make-string-input-stream "bar"))
+                         type-error))
   (assert (raises-error? (make-concatenated-stream
-			  (make-string-output-stream)
-			  (make-string-input-stream "foo"))
-			 type-error)))
+                          (make-string-output-stream)
+                          (make-string-input-stream "foo"))
+                         type-error)))
 
 ;;; bug 225: STRING-STREAM was not a class
 (eval `(defgeneric bug225 (s)
@@ -58,9 +58,9 @@
 ;;; improper buffering on (SIGNED-BYTE 8) streams (fixed by David Lichteblau):
 (let ((p "signed-byte-8-test.data"))
   (with-open-file (s p
-		     :direction :output
-		     :element-type '(unsigned-byte 8)
-		     :if-exists :supersede)
+                     :direction :output
+                     :element-type '(unsigned-byte 8)
+                     :if-exists :supersede)
     (write-byte 255 s))
   (with-open-file (s p :element-type '(signed-byte 8))
     (assert (= (read-byte s) -1)))
@@ -72,15 +72,16 @@
        (stream (open p :direction :output :if-exists :error)))
   (assert (null (with-open-file (s p :direction :output :if-exists nil) s)))
   (assert (raises-error?
-	   (with-open-file (s p :direction :output :if-exists :error))))
+           (with-open-file (s p :direction :output :if-exists :error))))
   (close stream)
   (delete-file p))
 
 (assert (raises-error? (read-byte (make-string-input-stream "abc"))
-		       type-error))
+                       type-error))
 (assert (raises-error? (with-open-file (s "/dev/zero")
-			 (read-byte s))
-		       type-error))
+                         (read-byte s))
+                       #-win32 type-error
+                       #+win32 sb-int:simple-file-error))
 ;;; bidirectional streams getting confused about their position
 (let ((p "bidirectional-stream-test"))
   (with-open-file (s p :direction :output :if-exists :supersede)
@@ -91,7 +92,10 @@
     (with-standard-io-syntax
       (prin1 'insert s)))
   (with-open-file (s p)
-    (assert (string= (read-line s) "THESE INSERTMBOLS")))
+    (let ((line (read-line s))
+          (want "THESE INSERTMBOLS"))
+      (unless (equal line want)
+        (error "wanted ~S, got ~S" want line))))
   (delete-file p))
 
 ;;; :DIRECTION :IO didn't work on non-existent pathnames
@@ -128,26 +132,28 @@
 
 ;;; CLOSING a non-new streams should not delete them, and superseded
 ;;; files should be restored.
-(let ((test "test-file-for-close-should-not-delete"))
-  (macrolet ((test-mode (mode)
-	       `(progn
-		 (catch :close-test-exit
-		   (with-open-file (f test :direction :output :if-exists ,mode)
-		     (write-line "test" f)
-		     (throw :close-test-exit t)))
-		 (assert (and (probe-file test) ,mode)))))
-    (unwind-protect
-	 (progn
-	   (with-open-file (f test :direction :output)
-	     (write-line "test" f))
-	   (test-mode :append)
-	   ;; FIXME: We really should recover supersede files as well, according to
-	   ;; CLOSE in CLHS, but at the moment we don't.
-	   ;; (test-mode :supersede)
-	   (test-mode :rename)
-	   (test-mode :rename-and-delete))
-      (when (probe-file test)
-	(delete-file test)))))
+(with-test (:name :test-file-for-close-should-not-delete :fails-on :win32)
+  (let ((test "test-file-for-close-should-not-delete"))
+    (macrolet ((test-mode (mode)
+                          `(progn
+                             (catch :close-test-exit
+                               (with-open-file (f test :direction :output :if-exists ,mode)
+                                               (write-line "test" f)
+                                               (throw :close-test-exit t)))
+                             (assert (and (probe-file test) ,mode)))))
+      (unwind-protect
+          (progn
+            (with-open-file (f test :direction :output)
+                            (write-line "test" f))
+            (test-mode :append)
+            (test-mode :overwrite)
+            ;; FIXME: We really should recover supersede files as well, according to
+            ;; CLOSE in CLHS, but at the moment we don't.
+            ;; (test-mode :supersede)
+            (test-mode :rename)
+            (test-mode :rename-and-delete))
+        (when (probe-file test)
+          (delete-file test))))))
 
 ;;; test for read-write invariance of signed bytes, from Bruno Haible
 ;;; cmucl-imp 2004-09-06
@@ -177,6 +183,554 @@
                               (by-out size byte) (by-out size nb))))))
     (delete-file file-name)))
 (loop for size from 2 to 40 do (bin-stream-test :size size :type 'signed-byte))
+
+;;; Check READ-SEQUENCE signals a TYPE-ERROR when the sequence can't
+;;; contain a stream element.
+;;;
+;;; These tests check READ-SEQUENCE correctness, not whether the fast
+;;; or slow paths are being taken for each element type.  To check the
+;;; fast or slow paths, trace ANSI-STREAM-READ-BYTE (slow path) and/or
+;;; READ-N-BYTES:
+;;;
+;;; (trace sb-impl::ansi-stream-read-byte sb-impl::read-n-bytes)
+;;;
+;;; The order should be ANSI-STREAM-READ-BYTE, READ-N-BYTES,
+;;; READ-N-BYTES, ANSI-STREAM-READ-BYTE, ANSI-STREAM-READ-BYTE.
+
+(let ((pathname "read-sequence.data"))
+
+  ;; Create the binary data.
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type '(unsigned-byte 8))
+    (write-byte 255 stream))
+
+  ;; Check the slow path for generic vectors.
+  (let ((sequence (make-array 1)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type '(unsigned-byte 8))
+    (read-sequence sequence stream)
+    (assert (equalp sequence #(255)))))
+
+  (let ((sequence (make-array 1)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin-1
+                            :element-type 'character)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(#.(code-char 255))))))
+
+  ;; Check the fast path works for (UNSIGNED-BYTE 8) and (SIGNED-BYTE
+  ;; 8) vectors.
+  (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type '(unsigned-byte 8))
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(255)))))
+
+  (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type '(signed-byte 8))
+    (read-sequence sequence stream)
+    (assert (equalp sequence #(-1)))))
+
+  ;; A bivalent stream can be read to a unsigned-byte vector, a
+  ;; string, or a generic vector
+
+  (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type :default)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(255)))))
+
+  (let ((sequence (make-array 1 :element-type 'character)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin-1
+                            :element-type :default)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(#.(code-char 255))))))
+
+  (let ((sequence (make-array 1)))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin-1
+                            :element-type :default)
+      (read-sequence sequence stream)
+      (assert (equalp sequence #(#.(code-char 255))))))
+
+  ;; Check that a TYPE-ERROR is signalled for incompatible (sequence,
+  ;; stream) pairs.
+
+  (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type '(unsigned-byte 8))
+      (handler-case (progn
+                      (read-sequence sequence stream)
+                      (error "READ-SEQUENCE didn't signal an error"))
+        (type-error (condition)
+          (assert (= (type-error-datum condition) 255))
+          (assert (subtypep (type-error-expected-type condition)
+                            '(signed-byte 8)))))))
+
+  (let ((sequence (make-array 1 :element-type '(unsigned-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :element-type '(signed-byte 8))
+      (handler-case (progn
+                      (read-sequence sequence stream)
+                      (error "READ-SEQUENCE didn't signal an error"))
+        (type-error (condition)
+          (assert (= (type-error-datum condition) -1))
+          (assert (subtypep (type-error-expected-type condition)
+                            '(unsigned-byte 8)))))))
+
+  ;; Can't read a signed-byte from a bivalent stream
+
+  (let ((sequence (make-array 1 :element-type '(signed-byte 8))))
+    (with-open-file (stream pathname
+                            :direction :input
+                            :external-format :latin1
+                            :element-type :default)
+      (handler-case (progn
+                      (read-sequence sequence stream)
+                      (error "READ-SEQUENCE didn't signal an error"))
+        (type-error (condition)
+          (assert (eql (type-error-datum condition) (code-char 255)))
+          (assert (subtypep (type-error-expected-type condition)
+                            '(signed-byte 8)))))))
+  (delete-file pathname))
+
+;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't
+;;; write a sequence element.
+;;;
+;;; These tests check WRITE-SEQUENCE correctness, not whether the fast
+;;; or slow paths are being taken for each element type.  See the
+;;; READ-SEQUENCE tests above for more information.
+;;;
+;;; (trace sb-impl::output-unsigned-byte-full-buffered sb-impl::output-signed-byte-full-buffered sb-impl::output-raw-bytes)
+
+(let ((pathname "write-sequence.data")
+      (generic-sequence (make-array 1 :initial-contents '(255)))
+      (generic-character-sequence (make-array 1 :initial-element #\a))
+      (generic-mixed-sequence (make-array 2 :initial-element #\a))
+      (string (make-array 1 :element-type 'character
+                          :initial-element (code-char 255)))
+      (unsigned-sequence (make-array 1
+                                     :element-type '(unsigned-byte 8)
+                                     :initial-contents '(255)))
+      (signed-sequence (make-array 1
+                                   :element-type '(signed-byte 8)
+                                   :initial-contents '(-1))))
+
+  (setf (aref generic-mixed-sequence 1) 255)
+
+  ;; Check the slow path for generic vectors.
+  (with-open-file (stream pathname
+                           :direction :output
+                           :if-exists :supersede
+                           :element-type '(unsigned-byte 8))
+    (write-sequence generic-sequence stream))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type 'character)
+    (write-sequence generic-character-sequence stream))
+
+  ;; Check the fast path for unsigned and signed vectors.
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type '(unsigned-byte 8))
+    (write-sequence unsigned-sequence stream))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type '(signed-byte 8))
+    (write-sequence signed-sequence stream))
+
+  ;; Bivalent streams on unsigned-byte vectors, strings, and a simple
+  ;; vector with mixed characters and bytes
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type :default)
+    (write-sequence unsigned-sequence stream))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :external-format :latin-1
+                          :if-exists :supersede
+                          :element-type :default)
+    (write-sequence string stream))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :external-format :latin-1
+                          :if-exists :supersede
+                          :element-type :default)
+    (write-sequence generic-mixed-sequence stream))
+
+  ;; Check a TYPE-ERROR is signalled for unsigned and signed vectors
+  ;; which are incompatible with the stream element type.
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type '(signed-byte 8))
+    (handler-case (progn
+                    (write-sequence unsigned-sequence stream)
+                    (error "WRITE-SEQUENCE didn't signal an error"))
+      (type-error (condition)
+        (assert (= (type-error-datum condition) 255))
+        (assert (subtypep (type-error-expected-type condition)
+                          '(signed-byte 8))))))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type '(unsigned-byte 8))
+    (handler-case (progn
+                    (write-sequence signed-sequence stream)
+                    (error "WRITE-SEQUENCE didn't signal an error"))
+      (type-error (condition)
+        (assert (= (type-error-datum condition) -1))
+        (assert (subtypep (type-error-expected-type condition)
+                          '(unsigned-byte 8))))))
+
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :element-type :default)
+    (handler-case (progn
+                    (write-sequence signed-sequence stream)
+                    (error "WRITE-SEQUENCE didn't signal an error"))
+      (type-error (condition)
+        (assert (= (type-error-datum condition) -1))
+        (assert (subtypep (type-error-expected-type condition)
+                          '(unsigned-byte 8))))))
+
+  (delete-file pathname))
+
+;;; writing looong lines. takes way too long and way too much space
+;;; to test on 64 bit platforms
+#-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(and) '(or))
+(let ((test "long-lines-write-test.tmp"))
+    (unwind-protect
+         (with-open-file (f test
+                            :direction :output
+                            :external-format :ascii
+                            :element-type 'character
+                            :if-does-not-exist :create
+                            :if-exists :supersede)
+           (let* ((n (truncate most-positive-fixnum 16))
+                  (m 18)
+                  (p (* n m))
+                  (buffer (make-string n)))
+             (dotimes (i m)
+               (write-char #\.)
+               (finish-output)
+               (write-sequence buffer f))
+             (assert (= p (sb-impl::fd-stream-char-pos f)))
+             (write-char #\! f)
+             (assert (= (+ 1 p) (sb-impl::fd-stream-char-pos f)))
+             (assert (typep p 'bignum))))
+      (when (probe-file test)
+        (delete-file test))))
+
+;;; read-sequence misreported the amount read and lost position
+(let ((string (make-array (* 3 sb-impl::+ansi-stream-in-buffer-length+)
+                          :element-type 'character)))
+  (dotimes (i (length string))
+    (setf (char string i) (code-char (mod i char-code-limit))))
+  (with-open-file (f "read-sequence-character-test-data.tmp"
+                     :if-exists :supersede
+                     :direction :output
+                     :external-format :utf-8)
+    (write-sequence string f))
+  (let ((copy
+         (with-open-file (f "read-sequence-character-test-data.tmp"
+                            :if-does-not-exist :error
+                            :direction :input
+                            :external-format :utf-8)
+           (let ((buffer (make-array 128 :element-type 'character))
+                 (total 0))
+             (with-output-to-string (datum)
+               (loop for n-read = (read-sequence buffer f)
+                     do (write-sequence buffer datum :start 0 :end n-read)
+                        (assert (<= (incf total n-read) (length string)))
+                     while (and (= n-read 128))))))))
+    (assert (equal copy string)))
+  (delete-file "read-sequence-character-test-data.tmp"))
+
+;;; ANSI-STREAM-OUTPUT-STREAM-P used to assume that a SYNONYM-STREAM's
+;;; target was an ANSI stream, but it could be a user-defined stream,
+;;; e.g., a SLIME stream.
+(defclass user-output-stream (fundamental-output-stream)
+  ())
+
+(let ((*stream* (make-instance 'user-output-stream)))
+  (declare (special *stream*))
+  (with-open-stream (stream (make-synonym-stream '*stream*))
+    (assert (output-stream-p stream))))
+
+(defclass user-input-stream (fundamental-input-stream)
+  ())
+
+(let ((*stream* (make-instance 'user-input-stream)))
+  (declare (special *stream*))
+  (with-open-stream (stream (make-synonym-stream '*stream*))
+    (assert (input-stream-p stream))))
+
+;;; READ-LINE on ANSI-STREAM did not return T for the last line
+;;; (reported by Yoshinori Tahara)
+(let ((pathname "test-read-line-eol"))
+  (with-open-file (out pathname :direction :output :if-exists :supersede)
+    (format out "a~%b"))
+  (let ((result (with-open-file (in pathname)
+                  (list (multiple-value-list (read-line in nil nil))
+                        (multiple-value-list (read-line in nil nil))
+                        (multiple-value-list (read-line in nil nil))))))
+    (delete-file pathname)
+    (assert (equal result '(("a" nil) ("b" t) (nil t))))))
+
+;;; READ-LINE used to work on closed streams because input buffers were left in place
+(with-test (:name :bug-425)
+  ;; Normal close
+  (let ((f (open "stream.impure.lisp" :direction :input)))
+    (assert (stringp (read-line f)))
+    (close f)
+    (assert (eq :fii
+                (handler-case
+                    (read-line f)
+                  (sb-int:closed-stream-error () :fii)))))
+  ;; Abort
+  (let ((f (open "stream.impure.lisp" :direction :input)))
+    (assert (stringp (read-line f nil nil)))
+    (close f :abort t)
+    (assert (eq :faa
+                (handler-case
+                    (read-line f)
+                  (sb-int:closed-stream-error () :faa))))))
+
+(with-test (:name :regression-1.0.12.22)
+  (with-open-file (s "stream.impure.lisp" :direction :input)
+    (let ((buffer (make-string 20)))
+      (assert (= 2 (read-sequence buffer s :start 0 :end 2)))
+      (assert (= 3 (read-sequence buffer s :start 2 :end 3)))
+      (file-position s :end)
+      (assert (= 3 (read-sequence buffer s :start 3))))))
+
+;;; In 1.0.27 (and also 0.9.16; presumably in between, too), binary
+;;; input operations on a bivalent stream did something bad after
+;;; unread-char: READ-BYTE would return the character, and
+;;; READ-SEQUENCE into a byte buffer would lose when attempting to
+;;; store the character in the vector.
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
+
+(with-test (:name :delete-file-on-streams)
+  (with-open-file (f "delete-file-on-stream-test.tmp"
+                     :direction :io)
+    (delete-file f)
+    #-win32
+    (progn
+      (write-line "still open" f)
+      (file-position f :start)
+      (assert (equal "still open" (read-line f)))))
+  (assert (not (probe-file "delete-file-on-stream-test.tmp"))))
+
+;;; READ-CHAR-NO-HANG on bivalent streams (as returned by RUN-PROGRAM)
+;;; was wrong.  CSR managed to promote the wrongness to all streams in
+;;; the 1.0.32.x series, breaking slime instantly.
+(with-test (:name :read-char-no-hang-after-unread-char :skipped-on :win32)
+  (let* ((process (run-program "/bin/sh" '("-c" "echo a && sleep 10")
+                               :output :stream :wait nil))
+         (stream (process-output process))
+         (char (read-char stream)))
+    (assert (char= char #\a))
+    (unread-char char stream)
+    (assert (char= (read-char stream) #\a))
+    (assert (char= (read-char stream) #\Newline))
+    (let ((time (get-universal-time)))
+      ;; no input, not yet known to be at EOF: should return
+      ;; immediately
+      (read-char-no-hang stream)
+      (assert (< (- (get-universal-time) time) 2)))))
+
+(require :sb-posix)
+#-win32
+(with-test (:name :interrupt-open :skipped-on :win32)
+  (let ((fifo nil)
+        (to 0))
+    (unwind-protect
+         (progn
+           ;; Make a FIFO
+           (setf fifo (sb-posix:mktemp "SBCL-fifo.XXXXXXX"))
+           (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+           ;; Try to open it (which hangs), and interrupt ourselves with a timer,
+           ;; continue (this used to result in an error due to open(2) returning with
+           ;; EINTR, then interupt again and unwind.
+           (handler-case
+               (with-timeout 2
+                 (handler-bind ((timeout (lambda (c)
+                                           (when (eql 1 (incf to))
+                                             (continue c)))))
+                   (with-timeout 1
+                     (with-open-file (f fifo :direction :input)
+                       :open))))
+             (timeout ()
+               (if (eql 2 to)
+                   :timeout
+                   :wtf))
+             (error (e)
+               e)))
+      (when fifo
+        (ignore-errors (delete-file fifo))))))
+
+#-win32
+(with-test (:name :overeager-character-buffering :skipped-on :win32)
+  (let ((fifo nil)
+        (proc nil))
+    (maphash
+     (lambda (format _)
+       (declare (ignore _))
+       (format t "trying ~A~%" format)
+       (finish-output t)
+       (unwind-protect
+            (progn
+              (setf fifo (sb-posix:mktemp "SBCL-fifo-XXXXXXX"))
+              (sb-posix:mkfifo fifo (logior sb-posix:s-iwusr sb-posix:s-irusr))
+              ;; KLUDGE: because we have both ends in the same process, we would
+              ;; need to use O_NONBLOCK, but this works too.
+              (setf proc
+                    (run-program "/bin/sh"
+                                 (list "-c"
+                                       (format nil "cat > ~A" (native-namestring fifo)))
+                                 :input :stream
+                                 :wait nil
+                                 :external-format format))
+              (write-line "foobar" (process-input proc))
+              (finish-output (process-input proc))
+              (with-open-file (f fifo :direction :input :external-format format)
+                (assert (equal "foobar" (read-line f)))))
+         (when proc
+           (ignore-errors
+             (close (process-input proc) :abort t)
+             (process-wait proc))
+           (ignore-errors (process-close proc))
+           (setf proc nil))
+         (when fifo
+           (ignore-errors (delete-file fifo))
+           (setf fifo nil))))
+     sb-impl::*external-formats*)))
+
+(with-test (:name :bug-657183 :skipped-on '(not :sb-unicode))
+  #+sb-unicode
+  (let ((name (merge-pathnames "stream-impure.temp-test"))
+        (text '(#\GREEK_SMALL_LETTER_LAMDA
+                #\JAPANESE_BANK_SYMBOL
+                #\Space
+                #\HEAVY_BLACK_HEART))
+        (positions '(2 5 6 9))
+        (sb-impl::*default-external-format* :utf-8))
+    (unwind-protect
+         (progn
+           (with-open-file (f name :external-format :default :direction :output
+                              :if-exists :supersede)
+             (assert (eql 0 (file-position f)))
+             (mapc (lambda (char pos)
+                     (write-char char f)
+                     (assert (eql pos (file-position f))))
+                   text
+                   positions))
+           (with-open-file (f name :external-format :default :direction :input)
+             (assert (eql 0 (file-position f)))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 2))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 5))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 6))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 9))
+             (assert (eql (file-length f) 9))))
+      (ignore-errors (delete-file name)))))
+
+(with-test (:name :bug-561642)
+  (let ((p "bug-561642-test.tmp"))
+    (unwind-protect
+         (progn
+           (with-open-file (f p
+                              :if-exists :supersede
+                              :if-does-not-exist :create
+                              :direction :output)
+             (write-line "FOOBAR" f))
+           (with-open-file (f p
+                              :if-exists :append
+                              :direction :output)
+             (let ((p0 (file-position f))
+                   (p1 (progn
+                         (write-char #\newline f)
+                         (file-position f)))
+                   (p2 (progn
+                         (write-char #\newline f)
+                         (finish-output f)
+                         (file-position f))))
+               (assert (eql 7 p0))
+               (assert (eql 8 p1))
+               (assert (eql 9 p2)))))
+      (ignore-errors (delete-file p)))))
 
 ;;; success
-(quit :unix-status 104)