X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=0e43da763f5deee0f8c53143c1955dd9e56c744a;hb=7fb597b585fc715537ea644f7d84440eca217ca1;hp=0ce1b1fe214b8f2d42a0769dd69ca2fd7c4d2891;hpb=ba7ca928e3a3bee761f717daaed689dab977c61c;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 0ce1b1f..0e43da7 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -20,6 +20,20 @@
   "List of available buffers. Each buffer is an sap pointing to
   bytes-per-buffer of memory.")
 
+#!+sb-thread
+(defvar *available-buffers-mutex* (sb!thread:make-mutex
+                                   :name "lock for *AVAILABLE-BUFFERS*")
+  #!+sb-doc
+  "Mutex for access to *AVAILABLE-BUFFERS*.")
+
+(defmacro with-available-buffers-lock ((&optional) &body body)
+  ;; WITHOUT-INTERRUPTS because streams are low-level enough to be
+  ;; async signal safe, and in particular a C-c that brings up the
+  ;; debugger while holding the mutex would lose badly
+  `(without-interrupts
+    (sb!thread:with-mutex (*available-buffers-mutex*)
+      ,@body)))
+
 (defconstant bytes-per-buffer (* 4 1024)
   #!+sb-doc
   "Number of bytes per buffer.")
@@ -27,9 +41,10 @@
 ;;; Return the next available buffer, creating one if necessary.
 #!-sb-fluid (declaim (inline next-available-buffer))
 (defun next-available-buffer ()
-  (if *available-buffers*
-      (pop *available-buffers*)
-      (allocate-system-memory bytes-per-buffer)))
+  (with-available-buffers-lock ()
+    (if *available-buffers*
+        (pop *available-buffers*)
+        (allocate-system-memory bytes-per-buffer))))
 
 ;;;; the FD-STREAM structure
 
@@ -172,12 +187,13 @@
                             start
                             length)
       (cond ((not count)
-             (if (= errno sb!unix:ewouldblock)
+             (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
                  (error "Write would have blocked, but SERVER told us to go.")
                  (simple-stream-perror "couldn't write to ~S" stream errno)))
             ((eql count length) ; Hot damn, it worked.
              (when reuse-sap
-               (push base *available-buffers*)))
+               (with-available-buffers-lock ()
+                 (push base *available-buffers*))))
             ((not (null count)) ; sorta worked..
              (push (list base
                          (the index (+ start count))
@@ -222,7 +238,7 @@
         (multiple-value-bind (count errno)
             (sb!unix:unix-write (fd-stream-fd stream) base start length)
           (cond ((not count)
-                 (if (= errno sb!unix:ewouldblock)
+                 (if #!-win32 (= errno sb!unix:ewouldblock) #!+win32 t #!-win32
                      (output-later stream base start end reuse-sap)
                      (simple-stream-perror "couldn't write to ~S"
                                            stream
@@ -486,15 +502,20 @@
         (end (or end (length (the vector thing)))))
     (declare (fixnum start end))
     (if (stringp thing)
-        (let ((last-newline (and (find #\newline (the simple-string thing)
-                                       :start start :end end)
-                                 ;; FIXME why do we need both calls?
-                                 ;; Is find faster forwards than
-                                 ;; position is backwards?
-                                 (position #\newline (the simple-string thing)
-                                           :from-end t
-                                           :start start
-                                           :end end))))
+        (let ((last-newline
+               (string-dispatch (simple-base-string
+                                 #!+sb-unicode
+                                 (simple-array character)
+                                 string)
+                   thing
+                 (and (find #\newline thing :start start :end end)
+                      ;; FIXME why do we need both calls?
+                      ;; Is find faster forwards than
+                      ;; position is backwards?
+                      (position #\newline thing
+                                :from-end t
+                                :start start
+                                :end end)))))
           (if (and (typep thing 'base-string)
                    (eq (fd-stream-external-format stream) :latin-1))
               (ecase (fd-stream-buffering stream)
@@ -666,7 +687,7 @@
                            (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
                            (- buflen tail))
       (cond ((null count)
-             (if (eql errno sb!unix:ewouldblock)
+             (if #!-win32 (eql errno sb!unix:ewouldblock) #!+win32 t #!-win32
                  (progn
                    (unless (sb!sys:wait-until-fd-usable
                             fd :input (fd-stream-timeout stream))
@@ -955,6 +976,20 @@
       (return-from fd-stream-resync
         (funcall (symbol-function (eighth entry)) stream)))))
 
+(defun get-fd-stream-character-sizer (stream)
+  (dolist (entry *external-formats*)
+    (when (member (fd-stream-external-format stream) (first entry))
+      (return-from get-fd-stream-character-sizer (ninth entry)))))
+
+(defun fd-stream-character-size (stream char)
+  (let ((sizer (get-fd-stream-character-sizer stream)))
+    (when sizer (funcall sizer char))))
+
+(defun fd-stream-string-size (stream string)
+  (let ((sizer (get-fd-stream-character-sizer stream)))
+    (when sizer
+      (loop for char across string summing (funcall sizer char)))))
+
 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)
@@ -962,8 +997,12 @@
          (out-function (symbolicate "OUTPUT-BYTES/" name))
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
-         (in-char-function (symbolicate "INPUT-CHAR/" name)))
+         (in-char-function (symbolicate "INPUT-CHAR/" name))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
     `(progn
+      (defun ,size-function (byte)
+        (declare (ignore byte))
+        ,size)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))
               (end (or end (length string))))
@@ -972,26 +1011,38 @@
                      (> (fd-stream-ibuf-tail stream)
                         (fd-stream-ibuf-head stream)))
             (file-position stream (file-position stream)))
-          (when (< end start)
-            (error ":END before :START!"))
+          (unless (<= 0 start end (length string))
+            (signal-bounding-indices-bad-error string start end))
           (do ()
               ((= end start))
             (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
-                            (let* ((byte (aref string start))
-                                   (bits (char-code byte)))
-                              ,out-expr
-                              (incf tail ,size)))
-                         `(let* ((byte (aref string start))
-                                  (bits (char-code byte)))
-                             ,out-expr
-                             (incf tail ,size)))
-                    (incf start)))
+                  (string-dispatch (simple-base-string
+                                    #!+sb-unicode
+                                    (simple-array character)
+                                    string)
+                      string
+                    (let ((len (fd-stream-obuf-length stream))
+                          (sap (fd-stream-obuf-sap stream))
+                          (tail (fd-stream-obuf-tail stream)))
+                      (declare (type index tail)
+                               ;; STRING bounds have already been checked.
+                               (optimize (safety 0)))
+                      (loop
+                         (,@(if output-restart
+                                `(catch 'output-nothing)
+                                `(progn))
+                            (do* ()
+                                 ((or (= start end) (< (- len tail) 4)))
+                              (let* ((byte (aref string start))
+                                     (bits (char-code byte)))
+                                ,out-expr
+                                (incf tail ,size)
+                                (incf start)))
+                            ;; Exited from the loop normally
+                            (return tail))
+                         ;; Exited via CATCH. Skip the current character
+                         ;; and try the inner loop again.
+                         (incf start)))))
             (when (< start end)
               (flush-output-buffer stream)))
           (when flush-p
@@ -1010,41 +1061,41 @@
               (tail (fd-stream-obuf-tail stream)))
           ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
-                           &aux (total-copied 0))
+                           &aux (index start) (end (+ start requested)))
         (declare (type fd-stream stream))
-        (declare (type index start requested total-copied))
+        (declare (type index start requested index end))
         (declare (type (simple-array character (#.+ansi-stream-in-buffer-length+)) buffer))
         (let ((unread (fd-stream-unread stream)))
           (when unread
-            (setf (aref buffer start) unread)
+            (setf (aref buffer index) unread)
             (setf (fd-stream-unread stream) nil)
             (setf (fd-stream-listen stream) nil)
-            (incf total-copied)))
+            (incf index)))
         (do ()
             (nil)
           (let* ((head (fd-stream-ibuf-head stream))
                  (tail (fd-stream-ibuf-tail stream))
                  (sap (fd-stream-ibuf-sap stream)))
-            (declare (type index head tail))
+            (declare (type index head tail)
+                     (type system-area-pointer sap))
             ;; Copy data from stream buffer into user's buffer.
-            (do ()
-                ((or (= tail head) (= requested total-copied)))
+            (dotimes (i (min (truncate (- tail head) ,size)
+                             (- end index)))
+              (declare (optimize speed))
               (let* ((byte (sap-ref-8 sap head)))
-                (when (> ,size (- tail head))
-                  (return))
-                (setf (aref buffer (+ start total-copied)) ,in-expr)
-                (incf total-copied)
+                (setf (aref buffer index) ,in-expr)
+                (incf index)
                 (incf head ,size)))
             (setf (fd-stream-ibuf-head stream) head)
             ;; Maybe we need to refill the stream buffer.
-            (cond ( ;; If there were enough data in the stream buffer, we're done.
-                   (= total-copied requested)
-                   (return total-copied))
+            (cond ( ;; If there was enough data in the stream buffer, we're done.
+                   (= index end)
+                   (return (- index start)))
                   ( ;; If EOF, we're done in another way.
                    (null (catch 'eof-input-catcher (refill-buffer/fd stream)))
                    (if eof-error-p
                        (error 'end-of-file :stream stream)
-                       (return total-copied)))
+                       (return (- index start))))
                   ;; Otherwise we refilled the stream buffer, so fall
                   ;; through into another pass of the loop.
                   ))))
@@ -1055,7 +1106,9 @@
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
-                         '(:none :line :full)))
+                         '(:none :line :full))
+               nil ; no resync-function
+               ,size-function)
         *external-formats*)))))
 
 (defmacro define-external-format/variable-width
@@ -1066,8 +1119,11 @@
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
          (in-char-function (symbolicate "INPUT-CHAR/" name))
-         (resync-function (symbolicate "RESYNC/" name)))
+         (resync-function (symbolicate "RESYNC/" name))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
     `(progn
+      (defun ,size-function (byte)
+        ,out-size-expr)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))
               (end (or end (length string))))
@@ -1076,28 +1132,39 @@
                      (> (fd-stream-ibuf-tail stream)
                         (fd-stream-ibuf-head stream)))
             (file-position stream (file-position stream)))
-          (when (< end start)
-            (error ":END before :START!"))
+          (unless (<= 0 start end (length string))
+            (signal-bounding-indices-bad-error string start end))
           (do ()
               ((= end start))
             (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
-                            (let* ((byte (aref string start))
-                                   (bits (char-code byte))
-                                   (size ,out-size-expr))
-                              ,out-expr
-                              (incf tail size)))
-                         `(let* ((byte (aref string start))
-                                 (bits (char-code byte))
-                                 (size ,out-size-expr))
-                            ,out-expr
-                            (incf tail size)))
-                    (incf start)))
+                  (string-dispatch (simple-base-string
+                                    #!+sb-unicode
+                                    (simple-array character)
+                                    string)
+                      string
+                    (let ((len (fd-stream-obuf-length stream))
+                          (sap (fd-stream-obuf-sap stream))
+                          (tail (fd-stream-obuf-tail stream)))
+                      (declare (type index tail)
+                               ;; STRING bounds have already been checked.
+                               (optimize (safety 0)))
+                      (loop
+                         (,@(if output-restart
+                                `(catch 'output-nothing)
+                                `(progn))
+                            (do* ()
+                                 ((or (= start end) (< (- len tail) 4)))
+                              (let* ((byte (aref string start))
+                                     (bits (char-code byte))
+                                     (size ,out-size-expr))
+                                ,out-expr
+                                (incf tail size)
+                                (incf start)))
+                            ;; Exited from the loop normally
+                            (return tail))
+                         ;; Exited via CATCH. Skip the current character
+                         ;; and try the inner loop again.
+                         (incf start)))))
             (when (< start end)
               (flush-output-buffer stream)))
           (when flush-p
@@ -1132,7 +1199,6 @@
           (let* ((head (fd-stream-ibuf-head stream))
                  (tail (fd-stream-ibuf-tail stream))
                  (sap (fd-stream-ibuf-sap stream))
-                 (head-start head)
                  (decode-break-reason nil))
             (declare (type index head tail))
             ;; Copy data from stream buffer into user's buffer.
@@ -1149,17 +1215,22 @@
                         (incf head size))
                       nil))
               (setf (fd-stream-ibuf-head stream) head)
-              (when (and decode-break-reason
-                         (= head head-start))
+              (when decode-break-reason
+                ;; If we've already read some characters on when the invalid
+                ;; code sequence is detected, we return immediately. The
+                ;; handling of the error is deferred until the next call
+                ;; (where this check will be false). This allows establishing
+                ;; high-level handlers for decode errors (for example
+                ;; automatically resyncing in Lisp comments).
+                (when (plusp total-copied)
+                  (return-from ,in-function total-copied))
                 (when (stream-decoding-error-and-handle
                        stream decode-break-reason)
                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return-from ,in-function total-copied)))
                 (setf head (fd-stream-ibuf-head stream))
-                (setf tail (fd-stream-ibuf-tail stream)))
-              (when (plusp total-copied)
-                (return-from ,in-function total-copied)))
+                (setf tail (fd-stream-ibuf-tail stream))))
             (setf (fd-stream-ibuf-head stream) head)
             ;; Maybe we need to refill the stream buffer.
             (cond ( ;; If there were enough data in the stream buffer, we're done.
@@ -1197,10 +1268,14 @@
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
-               ,resync-function)
+               ,resync-function
+               ,size-function)
         *external-formats*)))))
 
-(define-external-format (:latin-1 :latin1 :iso-8859-1)
+;;; Multiple names for the :ISO{,-}8859-* families are needed because on
+;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
+;;; return "ISO8859-1" instead of "ISO-8859-1".
+(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
     1 t
   (if (>= bits 256)
       (stream-encoding-error-and-handle stream bits)
@@ -1267,7 +1342,7 @@
       (latin-9-reverse-2 (make-array 16
                                      :element-type '(unsigned-byte 8)
                                      :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
-  (define-external-format (:latin-9 :latin9 :iso-8859-15)
+  (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15)
       1 t
     (setf (sap-ref-8 sap tail)
           (if (< bits 256)
@@ -1360,11 +1435,13 @@
 
     ;; 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))
+      (with-available-buffers-lock ()
+        (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+        (setf (fd-stream-obuf-sap fd-stream) nil)))
     (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))
+      (with-available-buffers-lock ()
+        (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)
@@ -1378,26 +1455,7 @@
     (when (and character-stream-p
                (eq external-format :default))
       (/show0 "/getting default external format")
-      (setf external-format (default-external-format))
-      (/show0 "cold-printing defaulted external-format:")
-      #!+sb-show
-      (cold-print external-format)
-      (/show0 "matching to known aliases")
-      (dolist (entry *external-formats*
-                     (restart-case
-                         (error "Invalid external-format ~A"
-                                external-format)
-                      (use-default ()
-                        :report "Set external format to 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")
-        (when (member external-format (first entry))
-          (/show0 "matched")
-          (return)))
-      (/show0 "/default external format ok"))
+      (setf external-format (default-external-format)))
 
     (when input-p
       (when (or (not character-stream-p) bivalent-stream-p)
@@ -1590,11 +1648,13 @@
        (cancel-finalization fd-stream))
      (sb!unix:unix-close (fd-stream-fd fd-stream))
      (when (fd-stream-obuf-sap fd-stream)
-       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
-       (setf (fd-stream-obuf-sap fd-stream) nil))
+       (with-available-buffers-lock ()
+         (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
+         (setf (fd-stream-obuf-sap fd-stream) nil)))
      (when (fd-stream-ibuf-sap fd-stream)
-       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
-       (setf (fd-stream-ibuf-sap fd-stream) nil))
+       (with-available-buffers-lock ()
+         (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
+         (setf (fd-stream-ibuf-sap fd-stream) nil)))
      (sb!impl::set-closed-flame fd-stream))
     (:clear-input
      (setf (fd-stream-unread fd-stream) nil)
@@ -1655,12 +1715,10 @@
        (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))))
+       (character (fd-stream-character-size fd-stream arg1))
+       (string (fd-stream-string-size fd-stream arg1))))
     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 
@@ -1821,6 +1879,7 @@
 ;;; Rename NAMESTRING to ORIGINAL. First, check whether we have write
 ;;; access, since we don't want to trash unwritable files even if we
 ;;; technically can. We return true if we succeed in renaming.
+#!-win32
 (defun rename-the-old-one (namestring original)
   (unless (sb!unix:unix-access namestring sb!unix:w_ok)
     (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
@@ -2036,23 +2095,25 @@
 ;;; This is called whenever a saved core is restarted.
 (defun stream-reinit ()
   (setf *available-buffers* nil)
-  (setf *stdin*
-        (make-fd-stream 0 :name "standard input" :input t :buffering :line))
-  (setf *stdout*
-        (make-fd-stream 1 :name "standard output" :output t :buffering :line))
-  (setf *stderr*
-        (make-fd-stream 2 :name "standard error" :output t :buffering :line))
-  (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
-         (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
-    (if tty
-        (setf *tty*
-              (make-fd-stream tty
-                              :name "the terminal"
-                              :input t
-                              :output t
-                              :buffering :line
-                              :auto-close t))
-        (setf *tty* (make-two-way-stream *stdin* *stdout*))))
+  (with-output-to-string (*error-output*)
+    (setf *stdin*
+          (make-fd-stream 0 :name "standard input" :input t :buffering :line))
+    (setf *stdout*
+          (make-fd-stream 1 :name "standard output" :output t :buffering :line))
+    (setf *stderr*
+          (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+    (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
+           (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
+      (if tty
+          (setf *tty*
+                (make-fd-stream tty
+                                :name "the terminal"
+                                :input t
+                                :output t
+                                :buffering :line
+                                :auto-close t))
+          (setf *tty* (make-two-way-stream *stdin* *stdout*))))
+    (princ (get-output-stream-string *error-output*) *stderr*))
   (values))
 
 ;;;; miscellany