"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.")
;;; 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))))
\f
;;;; the FD-STREAM structure
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))
(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
(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)
(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))
(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)
(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))))
(> (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
(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.
))))
(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
(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))))
(> (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
(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.
(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.
,@(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)
(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)
;; 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)
(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)
(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)
(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))))
;;; 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))
;;; 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))
\f
;;;; miscellany
projects / sbcl.git / blobdiff