0.9.2.38: thread cleanup, paranoid

[sbcl.git] / src / code / fd-stream.lisp

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 1d8b567..69660e8 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -638,22 +638,19 @@
             (setf (fd-stream-ibuf-head stream) 0)
             (setf (fd-stream-ibuf-tail stream) tail))))
     (setf (fd-stream-listen stream) nil)
             (setf (fd-stream-ibuf-head stream) 0)
             (setf (fd-stream-ibuf-tail stream) tail))))
     (setf (fd-stream-listen stream) nil)

-    (multiple-value-bind (count errno)
-       ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
-       ;; into something which uses the not-yet-defined type
-       ;;   (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
-       ;; This is probably inefficient and unsafe and generally bad, so
-       ;; try to find some way to make that type known before
-       ;; this is compiled.
-       (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
-         (sb!unix:fd-zero read-fds)
-         (sb!unix:fd-set fd read-fds)
-         (sb!unix:unix-fast-select (1+ fd)
-                                   (sb!alien:addr read-fds)
-                                   nil
-                                   nil
-                                   0
-                                   0))
+    (sb!unix:with-restarted-syscall (count errno)
+      ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
+      ;; into something which uses the not-yet-defined type
+      ;;   (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
+      ;; This is probably inefficient and unsafe and generally bad, so
+      ;; try to find some way to make that type known before
+      ;; this is compiled.
+      (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
+        (sb!unix:fd-zero read-fds)
+        (sb!unix:fd-set fd read-fds)
+        (sb!unix:unix-fast-select (1+ fd)
+                                  (sb!alien:addr read-fds)
+                                  nil nil 0 0))

       (case count
        (1)
        (0
       (case count
        (1)
        (0

@@ -1070,22 +1067,22 @@
         (in-char-function (symbolicate "INPUT-CHAR/" name))
         (resync-function (symbolicate "RESYNC/" name)))
     `(progn
         (in-char-function (symbolicate "INPUT-CHAR/" name))
         (resync-function (symbolicate "RESYNC/" name)))
     `(progn

-      (defun ,out-function (fd-stream string flush-p start end)
+      (defun ,out-function (stream string flush-p start end)

        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))

-         (when (and (not (fd-stream-dual-channel-p fd-stream))
-                    (> (fd-stream-ibuf-tail fd-stream)
-                       (fd-stream-ibuf-head fd-stream)))
-           (file-position fd-stream (file-position fd-stream)))
+         (when (and (not (fd-stream-dual-channel-p stream))
+                    (> (fd-stream-ibuf-tail stream)
+                       (fd-stream-ibuf-head stream)))
+           (file-position stream (file-position stream)))

          (when (< end start)
            (error ":END before :START!"))
          (do ()
              ((= end start))
          (when (< end start)
            (error ":END before :START!"))
          (do ()
              ((= end start))

-           (setf (fd-stream-obuf-tail fd-stream)
-                 (do* ((len (fd-stream-obuf-length fd-stream))
-                       (sap (fd-stream-obuf-sap fd-stream))
-                       (tail (fd-stream-obuf-tail fd-stream)))
+           (setf (fd-stream-obuf-tail stream)
+                 (do* ((len (fd-stream-obuf-length stream))
+                       (sap (fd-stream-obuf-sap stream))
+                       (tail (fd-stream-obuf-tail stream)))

                       ((or (= start end) (< (- len tail) 4)) tail)
                    ,(if output-restart
                         `(catch 'output-nothing
                       ((or (= start end) (< (- len tail) 4)) tail)
                    ,(if output-restart
                         `(catch 'output-nothing

@@ -1093,8 +1090,7 @@
                                   (bits (char-code byte))
                                   (size ,out-size-expr))
                              ,out-expr
                                   (bits (char-code byte))
                                   (size ,out-size-expr))
                              ,out-expr

-                             (incf tail size)
-                             (incf start)))
+                             (incf tail size)))

                         `(let* ((byte (aref string start))
                                 (bits (char-code byte))
                                 (size ,out-size-expr))
                         `(let* ((byte (aref string start))
                                 (bits (char-code byte))
                                 (size ,out-size-expr))

@@ -1102,9 +1098,9 @@
                            (incf tail size)))
                    (incf start)))
            (when (< start end)
                            (incf tail size)))
                    (incf start)))
            (when (< start end)

-             (flush-output-buffer fd-stream)))
+             (flush-output-buffer stream)))

          (when flush-p
          (when flush-p

-           (flush-output-buffer fd-stream))))
+           (flush-output-buffer stream))))

       (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                            ,output-restart
       (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                            ,output-restart

@@ -1331,128 +1327,157 @@
 ;;; Fill in the various routine slots for the given type. INPUT-P and
 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
 ;;; set prior to calling this routine.
 ;;; Fill in the various routine slots for the given type. INPUT-P and
 ;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
 ;;; set prior to calling this routine.

-(defun set-fd-stream-routines (fd-stream type input-p output-p buffer-p)
-  (let ((target-type (case type
-                      ((:default unsigned-byte)
-                       '(unsigned-byte 8))
-                      (signed-byte
-                       '(signed-byte 8))
-                      (t
-                       type)))
-       (input-type nil)
-       (output-type nil)
-       (input-size nil)
-       (output-size nil)
-       (character-stream-p (subtypep type 'character)))
-
-    (when (fd-stream-obuf-sap fd-stream)
+(defun set-fd-stream-routines (fd-stream element-type external-format
+                              input-p output-p buffer-p)
+  (let* ((target-type (case element-type
+                       (unsigned-byte '(unsigned-byte 8))
+                       (signed-byte '(signed-byte 8))
+                       (:default 'character)
+                       (t element-type)))
+        (character-stream-p (subtypep target-type 'character))
+        (bivalent-stream-p (eq element-type :default))
+        normalized-external-format
+        (bin-routine #'ill-bin)
+        (bin-type nil)
+        (bin-size nil)
+        (cin-routine #'ill-in)
+        (cin-type nil)
+        (cin-size nil)
+        (input-type nil)           ;calculated from bin-type/cin-type
+        (input-size nil)           ;calculated from bin-size/cin-size
+        (read-n-characters #'ill-in)
+        (bout-routine #'ill-bout)
+        (bout-type nil)
+        (bout-size nil)
+        (cout-routine #'ill-out)
+        (cout-type nil)
+        (cout-size nil)
+        (output-type nil)
+        (output-size nil)
+        (output-bytes #'ill-bout))
+
+    ;; drop buffers when direction changes
+    (when (and (fd-stream-obuf-sap fd-stream) (not output-p))

       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-obuf-sap fd-stream) nil))
       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-obuf-sap fd-stream) nil))

-    (when (fd-stream-ibuf-sap fd-stream)
+    (when (and (fd-stream-ibuf-sap fd-stream) (not input-p))

       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))
       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))

+    (when input-p
+      (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
+      (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
+      (setf (fd-stream-ibuf-tail fd-stream) 0))
+    (when output-p
+      (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
+      (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
+      (setf (fd-stream-obuf-tail fd-stream) 0)
+      (setf (fd-stream-char-pos fd-stream) 0))

 
     (when (and character-stream-p
 
     (when (and character-stream-p

-              (eq (fd-stream-external-format fd-stream) :default))
+              (eq external-format :default))

       (/show0 "/getting default external format")
       (/show0 "/getting default external format")

-      (setf (fd-stream-external-format fd-stream)
-            (default-external-format))
+      (setf external-format (default-external-format))

       (/show0 "cold-printing defaulted external-format:")
       #!+sb-show
       (/show0 "cold-printing defaulted external-format:")
       #!+sb-show

-      (cold-print (fd-stream-external-format fd-stream))
+      (cold-print external-format)

       (/show0 "matching to known aliases")
       (dolist (entry *external-formats*
                     (restart-case
                          (error "Invalid external-format ~A" 
       (/show0 "matching to known aliases")
       (dolist (entry *external-formats*
                     (restart-case
                          (error "Invalid external-format ~A" 

-                                (fd-stream-external-format fd-stream))
+                                external-format)

                      (use-default ()
                         :report "Set external format to LATIN-1"
                      (use-default ()
                         :report "Set external format to LATIN-1"

-                        (setf (fd-stream-external-format fd-stream) :latin-1))))
+                        (setf external-format :latin-1))))

         (/show0 "cold printing known aliases:")
         #!+sb-show
         (dolist (alias (first entry)) (cold-print alias))
         (/show0 "done cold-printing known aliases")
         (/show0 "cold printing known aliases:")
         #!+sb-show
         (dolist (alias (first entry)) (cold-print alias))
         (/show0 "done cold-printing known aliases")

-       (when (member (fd-stream-external-format fd-stream) (first entry))
+       (when (member external-format (first entry))

           (/show0 "matched")
          (return)))
       (/show0 "/default external format ok"))
     
     (when input-p
           (/show0 "matched")
          (return)))
       (/show0 "/default external format ok"))
     
     (when input-p

-      (multiple-value-bind (routine type size read-n-characters
-                                    normalized-external-format)
-         (pick-input-routine target-type
-                              (fd-stream-external-format fd-stream))
-        (when normalized-external-format
-          (setf (fd-stream-external-format fd-stream)
-                normalized-external-format))
-       (unless routine
-         (error "could not find any input routine for ~S" target-type))
-       (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
-       (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
-       (setf (fd-stream-ibuf-tail fd-stream) 0)
-       (if character-stream-p
-           (setf (fd-stream-in fd-stream) routine
-                 (fd-stream-bin fd-stream) #'ill-bin)
-           (setf (fd-stream-in fd-stream) #'ill-in
-                 (fd-stream-bin fd-stream) routine))
-       (when (eql size 1)
-         (setf (fd-stream-n-bin fd-stream)
-                (if character-stream-p
-                    read-n-characters
-                    #'fd-stream-read-n-bytes))
-         (when (and buffer-p
-                    ;; We only create this buffer for streams of type
-                    ;; (unsigned-byte 8).  Because there's no buffer, the
-                    ;; other element-types will dispatch to the appropriate
-                    ;; input (output) routine in fast-read-byte.
-                    (or character-stream-p
-                        (equal target-type '(unsigned-byte 8)))
-                    (not output-p) ; temporary disable on :io streams
-                    #+(or)
-                    (or (eq type 'unsigned-byte)
-                        (eq type :default)))
-            (if character-stream-p
-                (setf (ansi-stream-cin-buffer fd-stream)
-                      (make-array +ansi-stream-in-buffer-length+
-                                  :element-type 'character))
-                (setf (ansi-stream-in-buffer fd-stream)
-                      (make-array +ansi-stream-in-buffer-length+
-                                  :element-type '(unsigned-byte 8))))))
-       (setf input-size size)
-       (setf input-type type)))
+      (when (or (not character-stream-p) bivalent-stream-p)
+       (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
+                                         normalized-external-format)
+         (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
+                                 target-type)
+                             external-format))
+       (unless bin-routine
+         (error "could not find any input routine for ~S" target-type)))
+      (when character-stream-p
+       (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
+                                         normalized-external-format)
+         (pick-input-routine target-type external-format))
+       (unless cin-routine
+         (error "could not find any input routine for ~S" target-type)))      
+      (setf (fd-stream-in fd-stream) cin-routine
+           (fd-stream-bin fd-stream) bin-routine)
+      ;; character type gets preferential treatment
+      (setf input-size (or cin-size bin-size))
+      (setf input-type (or cin-type bin-type))
+      (when normalized-external-format
+       (setf (fd-stream-external-format fd-stream)
+             normalized-external-format))
+      (when (= (or cin-size 1) (or bin-size 1) 1)
+       (setf (fd-stream-n-bin fd-stream) ;XXX
+             (if (and character-stream-p (not bivalent-stream-p))
+                 read-n-characters
+                 #'fd-stream-read-n-bytes))
+       ;; Sometimes turn on fast-read-char/fast-read-byte.  Switch on
+       ;; for character and (unsigned-byte 8) streams.  In these
+       ;; cases, fast-read-* will read from the
+       ;; ansi-stream-(c)in-buffer, saving function calls.
+       ;; Otherwise, the various data-reading functions in the stream
+       ;; structure will be called.
+       (when (and buffer-p
+                  (not bivalent-stream-p)
+                  ;; temporary disable on :io streams
+                  (not output-p))
+         (cond (character-stream-p 
+                (setf (ansi-stream-cin-buffer fd-stream)
+                      (make-array +ansi-stream-in-buffer-length+
+                                  :element-type 'character)))
+               ((equal target-type '(unsigned-byte 8))
+                (setf (ansi-stream-in-buffer fd-stream)
+                      (make-array +ansi-stream-in-buffer-length+
+                                  :element-type '(unsigned-byte 8))))))))

 
     (when output-p
 
     (when output-p

-      (multiple-value-bind (routine type size output-bytes
-                                   normalized-external-format)
+      (when (or (not character-stream-p) bivalent-stream-p)
+       (multiple-value-setq (bout-routine bout-type bout-size output-bytes
+                                          normalized-external-format)
+         (pick-output-routine (if bivalent-stream-p
+                                  '(unsigned-byte 8)
+                                  target-type)
+                              (fd-stream-buffering fd-stream)
+                              external-format))
+       (unless bout-routine
+         (error "could not find any output routine for ~S buffered ~S"
+                (fd-stream-buffering fd-stream)
+                target-type)))
+      (when character-stream-p
+       (multiple-value-setq (cout-routine cout-type cout-size output-bytes
+                                          normalized-external-format)

          (pick-output-routine target-type
                               (fd-stream-buffering fd-stream)
          (pick-output-routine target-type
                               (fd-stream-buffering fd-stream)

-                              (fd-stream-external-format fd-stream))
-       (when normalized-external-format
-         (setf (fd-stream-external-format fd-stream)
-               normalized-external-format))
-       (unless routine
+                              external-format))
+       (unless cout-routine

          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)

-                target-type))
-       (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
-       (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
-       (setf (fd-stream-obuf-tail fd-stream) 0)
-       (when character-stream-p
-         (setf (fd-stream-output-bytes fd-stream) output-bytes))
-       (if character-stream-p
-         (setf (fd-stream-out fd-stream) routine
-               (fd-stream-bout fd-stream) #'ill-bout)
-         (setf (fd-stream-out fd-stream)
-               (or (if (eql size 1)
-                         (pick-output-routine
-                          'base-char (fd-stream-buffering fd-stream)))
-                   #'ill-out)
-               (fd-stream-bout fd-stream) routine))
-       (setf (fd-stream-sout fd-stream)
-             (if (eql size 1) #'fd-sout #'ill-out))
-       (setf (fd-stream-char-pos fd-stream) 0)
-       (setf output-size size)
-       (setf output-type type)))
+                target-type)))
+      (when normalized-external-format
+       (setf (fd-stream-external-format fd-stream)
+             normalized-external-format))
+      (when character-stream-p
+       (setf (fd-stream-output-bytes fd-stream) output-bytes))
+      (setf (fd-stream-out fd-stream) cout-routine
+           (fd-stream-bout fd-stream) bout-routine
+           (fd-stream-sout fd-stream) (if (eql cout-size 1)
+                                          #'fd-sout #'ill-out))
+      (setf output-size (or cout-size bout-size))
+      (setf output-type (or cout-type bout-type)))

 
     (when (and input-size output-size
               (not (eq input-size output-size)))
 
     (when (and input-size output-size
               (not (eq input-size output-size)))

@@ -1487,13 +1512,14 @@
                   (fd-stream-ibuf-tail fd-stream)))
         (fd-stream-listen fd-stream)
         (setf (fd-stream-listen fd-stream)
                   (fd-stream-ibuf-tail fd-stream)))
         (fd-stream-listen fd-stream)
         (setf (fd-stream-listen fd-stream)

-              (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
-                                                    sb!unix:fd-set)))
-                     (sb!unix:fd-zero read-fds)
-                     (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
-                     (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
-                                               (sb!alien:addr read-fds)
-                                               nil nil 0 0))
+              (eql (sb!unix:with-restarted-syscall ()
+                      (sb!alien:with-alien ((read-fds (sb!alien:struct
+                                                       sb!unix:fd-set)))
+                        (sb!unix:fd-zero read-fds)
+                        (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+                        (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+                                                  (sb!alien:addr read-fds)
+                                                  nil nil 0 0)))

                    1))))
     (:unread
      (setf (fd-stream-unread fd-stream) arg1)
                    1))))
     (:unread
      (setf (fd-stream-unread fd-stream) arg1)

@@ -1574,16 +1600,14 @@
      (setf (fd-stream-ibuf-tail fd-stream) 0)
      (catch 'eof-input-catcher
        (loop
      (setf (fd-stream-ibuf-tail fd-stream) 0)
      (catch 'eof-input-catcher
        (loop

-       (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
-                                                     sb!unix:fd-set)))
-                      (sb!unix:fd-zero read-fds)
-                      (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
-                      (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
-                                                (sb!alien:addr read-fds)
-                                                nil
-                                                nil
-                                                0
-                                                0))))
+       (let ((count (sb!unix:with-restarted-syscall ()
+                       (sb!alien:with-alien ((read-fds (sb!alien:struct
+                                                        sb!unix:fd-set)))
+                         (sb!unix:fd-zero read-fds)
+                         (sb!unix:fd-set (fd-stream-fd fd-stream) read-fds)
+                         (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+                                                   (sb!alien:addr read-fds)
+                                                   nil nil 0 0)))))

          (cond ((eql count 1)
                 (refill-buffer/fd fd-stream)
                 (setf (fd-stream-ibuf-head fd-stream) 0)
          (cond ((eql count 1)
                 (refill-buffer/fd fd-stream)
                 (setf (fd-stream-ibuf-head fd-stream) 0)

@@ -1599,6 +1623,8 @@
        (sb!sys:serve-all-events)))
     (:element-type
      (fd-stream-element-type fd-stream))
        (sb!sys:serve-all-events)))
     (:element-type
      (fd-stream-element-type fd-stream))

+    (:external-format
+     (fd-stream-external-format fd-stream))

     (:interactive-p
      (= 1 (the (member 0 1)
             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
     (:interactive-p
      (= 1 (the (member 0 1)
             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))

@@ -1627,6 +1653,12 @@
        (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream)))))
        (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream)))))

+    ;; FIXME: I doubt this is correct in the presence of Unicode,
+    ;; since fd-stream FILE-POSITION is measured in bytes. 
+    (:file-string-length
+     (etypecase arg1
+       (character 1)
+       (string (length arg1))))

     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 
     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 

@@ -1738,7 +1770,7 @@
                       input-buffer-p
                       dual-channel-p
                       (name (if file
                       input-buffer-p
                       dual-channel-p
                       (name (if file

-                                (format nil "file ~S" file)
+                                (format nil "file ~A" file)

                                 (format nil "descriptor ~W" fd)))
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)
                                 (format nil "descriptor ~W" fd)))
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)

@@ -1757,7 +1789,8 @@
                                 :dual-channel-p dual-channel-p
                                 :external-format external-format
                                 :timeout timeout)))
                                 :dual-channel-p dual-channel-p
                                 :external-format external-format
                                 :timeout timeout)))

-    (set-fd-stream-routines stream element-type input output input-buffer-p)
+    (set-fd-stream-routines stream element-type external-format
+                           input output input-buffer-p)

     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()

@@ -2040,29 +2073,3 @@
             t)
            (t
             (fd-stream-pathname stream)))))
             t)
            (t
             (fd-stream-pathname stream)))))

-\f
-;;;; international character support (which is trivial for our simple
-;;;; character sets)
-
-;;;; (Those who do Lisp only in English might not remember that ANSI
-;;;; requires these functions to be exported from package
-;;;; COMMON-LISP.)
-
-(defun file-string-length (stream object)
-  (declare (type (or string character) object) (type fd-stream stream))
-  #!+sb-doc
-  "Return the delta in STREAM's FILE-POSITION that would be caused by writing
-   OBJECT to STREAM. Non-trivial only in implementations that support
-   international character sets."
-  (declare (ignore stream))
-  (etypecase object
-    (character 1)
-    (string (length object))))
-
-(defun stream-external-format (stream)
-  (declare (type fd-stream stream))
-  #!+sb-doc
-  "Return the actual external format for fd-streams, otherwise :DEFAULT."
-  (if (typep stream 'fd-stream)
-      (fd-stream-external-format stream)
-      :default))