X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Fimpl.lisp;h=c537300ac911d4190fc9540c43c19cf2d4f60818;hb=fb8533122551bbb7aea669f40bc91c1211809b58;hp=35c316ac1ee7e07f38c971f7f7b1a00d6267e34c;hpb=3189006493c5d7389dde68eff83f713074946d5e;p=sbcl.git diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index 35c316a..c537300 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -475,38 +475,46 @@ (defun %read-sequence (stream seq start end partial-fill) (declare (type simple-stream stream) (type sequence seq) - (type sb-int:index start) - (type (or null sb-int:index) end) + (type sb-int:index start end) (type boolean partial-fill)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-sequence 0)) + (when (and (not (any-stream-instance-flags stream :dual :string)) + (sc-dirty-p stream)) + (flush-buffer stream t)) (etypecase seq (string (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil - start (or end (length seq)) + start end (if partial-fill :bnb t))) ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) + (when (any-stream-instance-flags stream :string) + (error "Can't read into byte sequence from a string stream.")) ;; "read-vector" equivalent, but blocking if partial-fill is NIL - (error "implement me") - ) + ;; FIXME: this could be implemented faster via buffer-copy + (loop with encap = (sm melded-stream stream) + for index from start below end + for byte = (read-byte-internal encap nil nil t) + then (read-byte-internal encap nil nil partial-fill) + while byte + do (setf (bref seq index) byte) + finally (return index))) ;; extend to work on other sequences: repeated read-byte ))) - (defun %write-sequence (stream seq start end) (declare (type simple-stream stream) (type sequence seq) - (type sb-int:index start) - (type (or null sb-int:index) end)) + (type sb-int:index start end)) (with-stream-class (simple-stream stream) (%check stream :output) (etypecase seq (string (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream) - start (or end (length seq)))) + start end)) ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent @@ -514,31 +522,43 @@ (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (loop with max-ptr = (sm buf-len stream) - with real-end = (or end (length seq)) - for src-pos = start then (+ src-pos count) - for src-rest = (- real-end src-pos) + (loop with max-ptr fixnum = (sm buf-len stream) + for src-pos fixnum = start then (+ src-pos count) + for src-rest fixnum = (- end src-pos) while (> src-rest 0) ; FIXME: this is non-ANSI - for ptr = (let ((ptr (sm buffpos stream))) - (if (>= ptr max-ptr) - (flush-buffer stream t) - ptr)) - for buf-rest = (- max-ptr ptr) - for count = (min buf-rest src-rest) + for ptr fixnum = (let ((ptr (sm buffpos stream))) + (if (>= ptr max-ptr) + (flush-buffer stream t) + ptr)) + for buf-rest fixnum = (- max-ptr ptr) + for count fixnum = (min buf-rest src-rest) do (progn (setf (sm mode stream) 1) (setf (sm buffpos stream) (+ ptr count)) (buffer-copy seq src-pos (sm buffer stream) ptr count))))) (dual-channel-simple-stream - (error "Implement me")) + (with-stream-class (dual-channel-simple-stream stream) + (loop with max-ptr fixnum = (sm max-out-pos stream) + for src-pos fixnum = start then (+ src-pos count) + for src-rest fixnum = (- end src-pos) + while (> src-rest 0) ; FIXME: this is non-ANSI + for ptr fixnum = (let ((ptr (sm outpos stream))) + (if (>= ptr max-ptr) + (flush-out-buffer stream t) + ptr)) + for buf-rest fixnum = (- max-ptr ptr) + for count fixnum = (min buf-rest src-rest) + do (progn (setf (sm outpos stream) (+ ptr count)) + (buffer-copy seq src-pos (sm out-buffer stream) ptr count))))) (string-simple-stream (error 'simple-type-error :datum stream :expected-type 'stream - :format-control "Can't write-byte on string streams." + :format-control "Can't write a byte sequence to a string stream." :format-arguments '()))) ) ;; extend to work on other sequences: repeated write-byte - ))) + )) + seq) (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8)) @@ -549,27 +569,27 @@ (etypecase stream (simple-stream (with-stream-class (simple-stream stream) - (if (stringp vector) - (let* ((start (or start 0)) - (end (or end (length vector))) - (encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap nil nil t))) - (when char - (setf (schar vector start) char) - (incf start) - (+ start (funcall-stm-handler j-read-chars encap vector nil - start end nil)))) - (do* ((j-read-byte (if (any-stream-instance-flags stream :string) - (error "Can't READ-BYTE on string streams.") - #'read-byte-internal)) - (encap (sm melded-stream stream)) - (index (or start 0) (1+ index)) - (end (or end (* (length vector) (vector-elt-width vector)))) - (endian-swap (endian-swap-value vector endian-swap)) - (byte (funcall j-read-byte encap nil nil t) - (funcall j-read-byte encap nil nil nil))) - ((or (null byte) (>= index end)) index) - (setf (bref vector (logxor index endian-swap)) byte))))) + (cond ((stringp vector) + (let* ((start (or start 0)) + (end (or end (length vector))) + (encap (sm melded-stream stream)) + (char (funcall-stm-handler j-read-char encap nil nil t))) + (when char + (setf (schar vector start) char) + (incf start) + (+ start (funcall-stm-handler j-read-chars encap vector nil + start end nil))))) + ((any-stream-instance-flags stream :string) + (error "Can't READ-BYTE on string streams.")) + (t + (do* ((encap (sm melded-stream stream)) + (index (or start 0) (1+ index)) + (end (or end (* (length vector) (vector-elt-width vector)))) + (endian-swap (endian-swap-value vector endian-swap)) + (byte (read-byte-internal encap nil nil t) + (read-byte-internal encap nil nil nil))) + ((or (null byte) (>= index end)) index) + (setf (bref vector (logxor index endian-swap)) byte)))))) ((or ansi-stream fundamental-stream) (unless (typep vector '(or string (simple-array (signed-byte 8) (*)) @@ -953,6 +973,8 @@ (etypecase stream (simple-stream (%peek-char stream peek-type eof-error-p eof-value recursive-p)) + ;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) -- + ;; CSR, 2004-01-19 (ansi-stream (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t))) (cond ((eq char eof-value) char) @@ -967,7 +989,7 @@ (do ((char char (%ansi-stream-read-char stream eof-error-p eof-value t))) ((or (eq char eof-value) - (not (sb-int:whitespace-char-p char))) + (not (sb-impl::whitespacep char))) (unless (eq char eof-value) (%ansi-stream-unread-char char stream)) char))) @@ -987,7 +1009,7 @@ ((eq peek-type t) (do ((char (sb-gray:stream-read-char stream) (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (not (sb-int:whitespace-char-p char))) + ((or (eq char :eof) (not (sb-impl::whitespacep char))) (cond ((eq char :eof) (sb-impl::eof-or-lose stream eof-error-p eof-value)) (t @@ -1305,37 +1327,3 @@ t) (t (sb-impl::fd-stream-pathname stream)))))) - -;;; bugfix - -;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or -;;; remove it. -#+nil -(defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2) - (declare (type fundamental-stream stream) ;; this is a lie - (ignore arg2)) - (case operation - (:listen - (ext:stream-listen stream)) - (:unread - (ext:stream-unread-char stream arg1)) - (:close - (close stream)) - (:clear-input - (ext:stream-clear-input stream)) - (:force-output - (ext:stream-force-output stream)) - (:finish-output - (ext:stream-finish-output stream)) - (:element-type - (stream-element-type stream)) - (:interactive-p - (interactive-stream-p stream)) - (:line-length - (ext:stream-line-length stream)) - (:charpos - (ext:stream-line-column stream)) - (:file-length - (file-length stream)) - (:file-position - (file-position stream arg1))))