0.8.3.93

        Make double-channel simple streams work
        ... conditionalize flush-buffer etc. for code shared between
            single-channel and double-channel simple streams
        (Thanks to David Lichteblau for the reports)

diff --git a/contrib/sb-simple-streams/TODO b/contrib/sb-simple-streams/TODO
index 668dfb2..9f37d97 100644 (file)
--- a/contrib/sb-simple-streams/TODO
+++ b/contrib/sb-simple-streams/TODO
@@ -2,6 +2,8 @@
 
 - Implement & test read-sequence, write-sequence for (un)signed-8 vectors
 
+- Eliminate consing in sc-read-chars-ef
+
 - Make reader work with simple-streams
 
 - external format handling: load aliases, load formats, etc.

diff --git a/contrib/sb-simple-streams/classes.lisp b/contrib/sb-simple-streams/classes.lisp
index a3a8cec..0bc782d 100644 (file)
--- a/contrib/sb-simple-streams/classes.lisp
+++ b/contrib/sb-simple-streams/classes.lisp
@@ -75,7 +75,7 @@
    (oc-state :initform nil)
    ;; TODO: find out what this one does
    (co-state :initform nil)
-   (external-format :initform :default)
+   (external-format :initform (find-external-format :default))
 
    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
    ;; the stream is not open for input.
@@ -191,8 +191,8 @@
     (when (any-stream-instance-flags stream :input :output)
       (when (any-stream-instance-flags stream :output)
        (ignore-errors (if abort
-                           (clear-output stream)
-                           (force-output stream))))
+                          (clear-output stream)
+                          (finish-output stream))))
       (call-next-method)
       (setf (sm input-handle stream) nil
            (sm output-handle stream) nil)

diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp
index f85edeb..35c316a 100644 (file)
--- a/contrib/sb-simple-streams/impl.lisp
+++ b/contrib/sb-simple-streams/impl.lisp
@@ -292,7 +292,8 @@
     (if (not (or (eql width 1) (null width)))
        (funcall-stm-handler j-listen (sm melded-stream stream))
        (or (< (sm buffpos stream) (sm buffer-ptr stream))
-           (when (>= (sm mode stream) 0) ;; device-connected @@ single-channel
+           (when (or (not (any-stream-instance-flags stream :dual :string))
+                      (>= (sm mode stream) 0)) ;; device-connected @@ single-channel
              (let ((lcrs (sm last-char-read-size stream)))
                (unwind-protect
                     (progn

diff --git a/contrib/sb-simple-streams/internal.lisp b/contrib/sb-simple-streams/internal.lisp
index da127f7..1df77e9 100644 (file)
--- a/contrib/sb-simple-streams/internal.lisp
+++ b/contrib/sb-simple-streams/internal.lisp
@@ -13,7 +13,6 @@
 ;;; **********************************************************************
 ;;;
 ;;; Various functions needed by simple-streams
-
 (declaim (inline buffer-sap bref (setf bref) buffer-copy
                 allocate-buffer free-buffer))
 
@@ -28,13 +27,17 @@
 (defun bref (buffer index)
   (declare (type simple-stream-buffer buffer)
           (type (integer 0 #.most-positive-fixnum) index))
-  (sb-sys:sap-ref-8 (buffer-sap buffer) index))
+  (if (vectorp buffer)
+      (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index))
+      (sb-sys:sap-ref-8 buffer index))
 
 (defun (setf bref) (octet buffer index)
   (declare (type (unsigned-byte 8) octet)
           (type simple-stream-buffer buffer)
           (type (integer 0 #.most-positive-fixnum) index))
-  (setf (sb-sys:sap-ref-8 (buffer-sap buffer) index) octet))
+  (if (vectorp buffer)
+      (setf (sb-sys:sap-ref-8 (sb-sys:vector-sap buffer) index) octet)
+      (setf (sb-sys:sap-ref-8 buffer index) octet)))
 
 (defun buffer-copy (src soff dst doff length)
   (declare (type simple-stream-buffer src dst)
@@ -303,6 +306,7 @@
           (type (or null simple-stream-buffer) buffer)
           (type fixnum start)
           (type (or null fixnum) end)
+           (type blocking blocking)
           (optimize (speed 3) (space 2) (safety 0) (debug 0)))
   (with-stream-class (simple-stream stream)
     (let ((fd (sm input-handle stream))

diff --git a/contrib/sb-simple-streams/simple-stream-tests.lisp b/contrib/sb-simple-streams/simple-stream-tests.lisp
index b57d17d..6515a94 100644 (file)
--- a/contrib/sb-simple-streams/simple-stream-tests.lisp
+++ b/contrib/sb-simple-streams/simple-stream-tests.lisp
@@ -10,10 +10,14 @@
   "This file was created by simple-stream-tests.lisp. Nothing to see here, move along.")
 
 (defparameter *test-path*
-  (merge-pathnames (make-pathname :name nil :type nil :version nil)
+  (merge-pathnames (make-pathname :name :unspecific :type :unspecific
+                                  :version :unspecific)
                    *load-truename*)
   "Directory for temporary test files.")
 
+(defparameter *test-file*
+  (merge-pathnames #p"test-data.txt" *test-path*))
+
 (eval-when (:load-toplevel) (ensure-directories-exist *test-path* :verbose t))
 
 ;;; Non-destructive functional analog of REMF
@@ -49,38 +53,36 @@
 
 
 (deftest create-file-1
-  ;; Create a file-simple-stream, write data.
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+    ;; Create a file-simple-stream, write data.
     (prog1
         (with-open-stream (s (make-instance 'file-simple-stream
-                                            :filename file
+                                            :filename *test-file*
                                             :direction :output
                                             :if-exists :overwrite
                                             :if-does-not-exist :create))
           (string= (write-string *dumb-string* s) *dumb-string*))
-      (delete-file file)))
+      (delete-file *test-file*))
   t)
 
 (deftest create-file-2
-  ;; Create a file-simple-stream via :class argument to open, write data.
-  (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :output
-                       :if-exists :overwrite :if-does-not-exist :create)
-      (string= (write-string *dumb-string* s) *dumb-string*)))
+    ;; Create a file-simple-stream via :class argument to open, write data.
+    (with-test-file (s *test-file* :class 'file-simple-stream
+                       :direction :output :if-exists :overwrite
+                       :if-does-not-exist :create)
+      (string= (write-string *dumb-string* s) *dumb-string*))
   t)
 
 (deftest create-read-file-1
   ;; Via file-simple-stream objects, write and then re-read data.
-  (let ((result t)
-        (file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :output
-                       :if-exists :overwrite :if-does-not-exist :create
-                       :delete-afterwards nil)
+  (let ((result t))
+    (with-test-file (s *test-file* :class 'file-simple-stream
+                       :direction :output :if-exists :overwrite
+                       :if-does-not-exist :create :delete-afterwards nil)
       (write-line *dumb-string* s)
       (setf result (and result (string= (write-string *dumb-string* s)
                                         *dumb-string*))))
 
-    (with-test-file (s file :class 'file-simple-stream
+    (with-test-file (s *test-file* :class 'file-simple-stream
                        :direction :input :if-does-not-exist :error)
       ;; Check first line
       (multiple-value-bind (string missing-newline-p)
@@ -97,9 +99,8 @@
 
 (deftest create-read-mapped-file-1
   ;; Read data via a mapped-file-simple-stream object.
-  (let ((result t)
-        (file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'mapped-file-simple-stream
+  (let ((result t))
+    (with-test-file (s *test-file* :class 'mapped-file-simple-stream
                        :direction :input :if-does-not-exist :error
                        :initial-content *dumb-string*)
       (setf result (and result (string= (read-line s) *dumb-string*))))
@@ -110,7 +111,8 @@
   (handler-case
       (with-open-stream (s (make-instance 'socket-simple-stream
                                          :remote-host #(127 0 0 1)
-                                         :remote-port 7))
+                                         :remote-port 7
+                                          :direction :io))
        (string= (prog1 (write-line "Got it!" s) (finish-output s))
                 (read-line s)))
     (sb-bsd-sockets::connection-refused-error () t))
@@ -119,24 +121,22 @@
 (deftest write-read-large-sc-1
   ;; Do write and read with more data than the buffer will hold
   ;; (single-channel simple-stream)
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
-         (stream (make-instance 'file-simple-stream
-                                :filename file :direction :output
+  (let* ((stream (make-instance 'file-simple-stream
+                                :filename *test-file* :direction :output
                                 :if-exists :overwrite
                                 :if-does-not-exist :create))
          (content (make-string (1+ (device-buffer-length stream))
                                :initial-element #\x)))
     (with-open-stream (s stream)
       (write-string content s))
-    (with-test-file (s file :class 'file-simple-stream
+    (with-test-file (s *test-file* :class 'file-simple-stream
                        :direction :input :if-does-not-exist :error)
       (string= content (read-line s))))
   t)
 
 (deftest write-read-large-sc-2
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
-         (stream (make-instance 'file-simple-stream
-                                :filename file :direction :output
+  (let* ((stream (make-instance 'file-simple-stream
+                                :filename *test-file* :direction :output
                                 :if-exists :overwrite
                                 :if-does-not-exist :create))
          (length (1+ (* 3 (device-buffer-length stream))))
@@ -145,7 +145,7 @@
       (setf (aref content i) (code-char (random 256))))
     (with-open-stream (s stream)
       (write-string content s))
-    (with-test-file (s file :class 'file-simple-stream
+    (with-test-file (s *test-file* :class 'file-simple-stream
                        :direction :input :if-does-not-exist :error)
       (let ((seq (make-string length)))
         #+nil (read-sequence seq s)
@@ -155,9 +155,8 @@
   t)
 
 (deftest write-read-large-sc-3
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
-         (stream (make-instance 'file-simple-stream
-                                :filename file :direction :output
+  (let* ((stream (make-instance 'file-simple-stream
+                                :filename *test-file* :direction :output
                                 :if-exists :overwrite
                                 :if-does-not-exist :create))
          (length (1+ (* 3 (device-buffer-length stream))))
@@ -166,7 +165,7 @@
       (setf (aref content i) (random 256)))
     (with-open-stream (s stream)
       (write-sequence content s))
-    (with-test-file (s file :class 'file-simple-stream
+    (with-test-file (s *test-file* :class 'file-simple-stream
                        :direction :input :if-does-not-exist :error)
       (let ((seq (make-array length :element-type '(unsigned-byte 8))))
         #+nil (read-sequence seq s)
@@ -181,7 +180,8 @@
   (handler-case
    (let* ((stream (make-instance 'socket-simple-stream
                                  :remote-host #(127 0 0 1)
-                                 :remote-port 7))
+                                 :remote-port 7
+                                 :direction :io))
           (content (make-string (1+ (device-buffer-length stream))
                                 :initial-element #\x)))
      (with-open-stream (s stream)
@@ -192,75 +192,79 @@
 
 
 (deftest file-position-1
-  ;; Test reading of file-position
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :input
+    ;; Test reading of file-position
+    (with-test-file (s *test-file* :class 'file-simple-stream :direction :input
                        :initial-content *dumb-string*)
-      (file-position s)))
+      (file-position s))
   0)
 
-;;; file-position-2 fails ONLY when called with
-;;; (asdf:oos 'asdf:test-op :sb-simple-streams)
-;;; TODO: Find out why
 (deftest file-position-2
-  ;; Test reading of file-position
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :input
+    ;; Test reading of file-position
+    (with-test-file (s *test-file* :class 'file-simple-stream :direction :input
                        :initial-content *dumb-string*)
       (read-byte s)
-      (file-position s)))
+      (file-position s))
   1)
 
 (deftest file-position-3
-  ;; Test reading of file-position in the presence of unsaved data
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :output
-                       :if-exists :supersede :if-does-not-exist :create)
+    ;; Test reading of file-position in the presence of unsaved data
+    (with-test-file (s *test-file* :class 'file-simple-stream
+                       :direction :output :if-exists :supersede
+                       :if-does-not-exist :create)
       (write-byte 50 s)
-      (file-position s)))
+      (file-position s))
   1)
 
 (deftest file-position-4
+    ;; Test reading of file-position in the presence of unsaved data and
+    ;; filled buffer
+    (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
+                       :if-exists :overwrite :if-does-not-exist :create
+                       :initial-content *dumb-string*)
+      (read-byte s)                     ; fill buffer
+      (write-byte 50 s)                 ; advance file-position
+      (file-position s))
+  2)
+
+(deftest file-position-5
     ;; Test file position when opening with :if-exists :append
-    (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-      (with-test-file (s file :class 'file-simple-stream :direction :io
-                         :if-exists :append :if-does-not-exist :create
-                         :initial-content "Foo")
-        (= (file-length s) (file-position s))))
+    (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
+                       :if-exists :append :if-does-not-exist :create
+                       :initial-content *dumb-string*)
+      (= (file-length s) (file-position s)))
   T)
 
 (deftest write-read-unflushed-sc-1
-  ;; Write something into a single-channel stream and read it back
-  ;; without explicitly flushing the buffer in-between
-  (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-    (with-test-file (s file :class 'file-simple-stream :direction :io
+    ;; Write something into a single-channel stream and read it back
+    ;; without explicitly flushing the buffer in-between
+    (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
                        :if-does-not-exist :create :if-exists :supersede)
       (write-char #\x s)
       (file-position s :start)
-      (read-char s)))
+      (read-char s))
   #\x)
 
 (deftest write-read-unflushed-sc-2
-  ;; Write something into a single-channel stream, try to read back too much
-  (handler-case
-   (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-     (with-test-file (s file :class 'file-simple-stream :direction :io
-                        :if-does-not-exist :create :if-exists :supersede)
-       (write-char #\x s)
-       (file-position s :start)
-       (read-char s)
-       (read-char s))
-     nil)
-    (end-of-file () t))
+    ;; Write something into a single-channel stream, try to read back too much
+    (handler-case
+        (with-test-file (s *test-file* :class 'file-simple-stream
+                           :direction :io :if-does-not-exist :create
+                           :if-exists :supersede)
+            (write-char #\x s)
+            (file-position s :start)
+            (read-char s)
+            (read-char s)
+            nil)
+      (end-of-file () t))
   t)
 
 (deftest write-read-unflushed-sc-3
-    (let ((file (merge-pathnames #p"test-data.txt" *test-path*))
-          (result t))
-      (with-test-file (s file :class 'file-simple-stream :direction :io
+    ;; Test writing in a buffer filled with previous file contents
+    (let ((result t))
+      (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
                          :if-exists :overwrite :if-does-not-exist :create
                          :initial-content *dumb-string*)
-        (setq result (and result (char= (read-char s) (char *dumb-string* 0))))
+        (setq result (and result (char= (read-char s) (schar *dumb-string* 0))))
         (setq result (and result (= (file-position s) 1)))
         (let ((pos (file-position s)))
           (write-char #\x s)
@@ -271,8 +275,8 @@
 
 (deftest write-read-unflushed-sc-4
     ;; Test flushing of buffers
-    (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-      (with-test-file (s file :class 'file-simple-stream :direction :io
+    (progn
+      (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
                          :if-exists :overwrite :if-does-not-exist :create
                          :initial-content "Foo"
                          :delete-afterwards nil)
@@ -281,16 +285,16 @@
         (write-char #\X s)
         (file-position s :end)          ; Extend file.
         (write-char #\X s))
-      (with-test-file (s file :class 'file-simple-stream :direction :input
-                         :if-does-not-exist :error)
+      (with-test-file (s *test-file* :class 'file-simple-stream
+                         :direction :input :if-does-not-exist :error)
         (read-line s)))
   "XooX"
   T)
 
 (deftest write-read-append-sc-1
     ;; Test writing in the middle of a stream opened in append mode
-    (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
-      (with-test-file (s file :class 'file-simple-stream :direction :io
+    (progn
+      (with-test-file (s *test-file* :class 'file-simple-stream :direction :io
                          :if-exists :append :if-does-not-exist :create
                          :initial-content "Foo"
                          :delete-afterwards nil)
@@ -298,8 +302,9 @@
         (write-char #\X s)
         (file-position s :end)          ; Extend file.
         (write-char #\X s))
-      (with-test-file (s file :class 'file-simple-stream :direction :input
-                         :if-does-not-exist :error)
+      (with-test-file (s *test-file* :class 'file-simple-stream
+                         :direction :input :if-does-not-exist :error)
         (read-line s)))
   "XooX"
   T)
+

diff --git a/contrib/sb-simple-streams/strategy.lisp b/contrib/sb-simple-streams/strategy.lisp
index ebbddf3..b080292 100644 (file)
--- a/contrib/sb-simple-streams/strategy.lisp
+++ b/contrib/sb-simple-streams/strategy.lisp
@@ -17,6 +17,7 @@
 ;;;; Helper functions
 
 (defun refill-buffer (stream blocking)
+  (declare (type blocking blocking))
   (with-stream-class (simple-stream stream)
     (let* ((unread (sm last-char-read-size stream))
            (buffer (sm buffer stream))
@@ -140,7 +141,8 @@
           (state (sm oc-state stream)))
       (flet ((input ()
               (when (>= buffpos (sm buffer-ptr stream))
-                 (when (sc-dirty-p stream)
+                 (when (and (not (any-stream-instance-flags stream :dual :string))
+                            (sc-dirty-p stream))
                    (flush-buffer stream t))
                 (let ((bytes (refill-buffer stream blocking)))
                   (cond ((= bytes 0)
@@ -216,7 +218,8 @@
            (type boolean blocking)
           #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
   (with-stream-class (simple-stream stream)
-    (when (sc-dirty-p stream)
+    (when (and (not (any-stream-instance-flags stream :dual :string))
+               (sc-dirty-p stream))
       (flush-buffer stream t))
     (do ((buffer (sm buffer stream))
          (buffpos (sm buffpos stream))

diff --git a/version.lisp-expr b/version.lisp-expr
index 04cb12d..0e9f387 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.3.92"
+"0.8.3.93"