X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=0e43da763f5deee0f8c53143c1955dd9e56c744a;hb=7fb597b585fc715537ea644f7d84440eca217ca1;hp=6e2b2b4b7720d119cfd5e19e9cf4256407ecf77d;hpb=c1b609d072224eddf850a0e3f85e578c6919117f;p=sbcl.git diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6e2b2b4..0e43da7 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -187,7 +187,7 @@ 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. @@ -238,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 @@ -503,25 +503,19 @@ (declare (fixnum start end)) (if (stringp thing) (let ((last-newline - (flet ((do-it (string) - (and (find #\newline string :start start :end end) - ;; FIXME why do we need both calls? - ;; Is find faster forwards than - ;; position is backwards? - (position #\newline string - :from-end t - :start start - :end end)))) - (declare (inline do-it)) - ;; Specialize the common cases - (etypecase thing - (simple-base-string - (do-it (the simple-base-string thing))) - #!+sb-unicode - ((simple-array character) - (do-it (the (simple-array character) thing))) - (string - (do-it thing)))))) + (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) @@ -693,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)) @@ -982,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) @@ -989,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)))) @@ -1004,44 +1016,33 @@ (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (flet ((do-it (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-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) + (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 @@ -1105,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 @@ -1116,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)))) @@ -1131,45 +1137,34 @@ (do () ((= end start)) (setf (fd-stream-obuf-tail stream) - (flet ((do-it (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-from do-it tail)) - ;; Exited via CATCH. Skip the current character - ;; and try the inner loop again. - (incf start))))) - (declare (inline do-it)) - ;; Specialized versions for the common cases of - ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) - ;; to avoid doing a generic AREF. - (etypecase string - (simple-base-string - (do-it (the simple-base-string string))) - #!+sb-unicode - ((simple-array character) - ;; For some reason the type information from the - ;; etypecase doesn't propagate through here without - ;; an explicit THE. - (do-it (the (simple-array character) string))) - (string - (do-it string))))) + (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 @@ -1273,7 +1268,8 @@ ,@(mapcar #'(lambda (buffering) (intern (format nil format (string buffering)))) '(:none :line :full)) - ,resync-function) + ,resync-function + ,size-function) *external-formats*))))) ;;; Multiple names for the :ISO{,-}8859-* families are needed because on @@ -1719,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)))) @@ -1885,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 "~@" namestring))