diff --git a/pcl/simple-streams/impl.lisp b/pcl/simple-streams/impl.lisp index 7d3a0c556419d4b325745efe0f6c6fa5c181c6db..dd6a45d6b330cab3bc7376b7df17d31a3a1ba870 100644 --- a/pcl/simple-streams/impl.lisp +++ b/pcl/simple-streams/impl.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.4 2003/06/26 13:27:43 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/impl.lisp,v 1.5 2004/07/09 21:54:30 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -397,7 +397,8 @@ (declare (type simple-stream stream)) (%check stream :output) ;; implement me - ) + nil) + (defun %finish-output (stream) (declare (type simple-stream stream)) @@ -493,6 +494,9 @@ (%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 @@ -500,9 +504,17 @@ (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 (or end (length seq)) + 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 ))) @@ -520,28 +532,64 @@ ((or (simple-array (unsigned-byte 8) (*)) (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent - (error "implement me") + (setf (sm charpos stream) nil) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + (with-stream-class (single-channel-simple-stream stream) + (loop with max-ptr fixnum = (sm buf-len stream) + for src-pos fixnum = start then (+ src-pos count) + for src-rest fixnum = (- (or end (length seq)) src-pos) + while (> src-rest 0) ; FIXME: this is non-ANSI + 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 + (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 = (- (or end (length seq)) 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 a byte sequence to a string stream." + :format-arguments '())) ) ;; extend to work on other sequences: repeated write-byte - ))) - + )) + seq) (defun read-no-hang-p (stream) (declare (type (or integer stream) stream)) (etypecase stream (integer (sys:wait-until-fd-usable stream :input 0)) (simple-stream (%check stream :input) - (when (any-stream-instance-flags stream :eof) - (return-from read-no-hang-p nil)) - (simple-stream-dispatch stream - ;; single-channel-simple-stream - nil - ;; dual-channel-simple-stream - ;; if record-end is -1, call device-finish-record - ;; return NIL if it returns NIL, T if it returns :EOF - nil - ;; string-simple-stream - nil)) + (when (any-stream-instance-flags stream :eof) + (return-from read-no-hang-p nil)) + (simple-stream-dispatch stream + ;; single-channel-simple-stream + nil + ;; dual-channel-simple-stream + ;; if record-end is -1, call device-finish-record + ;; return NIL if it returns NIL, T if it returns :EOF + nil + ;; string-simple-stream + nil)) (stream (listen stream)))) (defun write-no-hang-p (stream) @@ -551,7 +599,6 @@ (simple-stream #| ... |#) (stream #| ... |#))) - (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8)) (declare (type (kernel:simple-unboxed-array (*)) vector) (type stream stream)) @@ -585,7 +632,5 @@ (unless (typep vector '(or string (simple-array (signed-byte 8) (*)) (simple-array (unsigned-byte 8) (*)))) - (error "Bad vector.")) + (error "Wrong vector type for read-vector on stream not of type simple-stream.")) (read-sequence vector stream :start (or start 0) :end end)))) - -#|(defun write-vector ...)|# diff --git a/pcl/simple-streams/strategy.lisp b/pcl/simple-streams/strategy.lisp index 734871f384f66794c35b685ab41c5233c984e8dd..e9ca48b8ba4593b8a9f8c1945de0d9bd40718224 100644 --- a/pcl/simple-streams/strategy.lisp +++ b/pcl/simple-streams/strategy.lisp @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.6 2003/07/19 15:32:58 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/simple-streams/strategy.lisp,v 1.7 2004/07/09 21:54:30 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -58,13 +58,30 @@ unread)) bytes)))) +(defun sc-set-dirty (stream) + (with-stream-class (single-channel-simple-stream stream) + (setf (sm mode stream) + (if (<= (sm buffpos stream) + (sm buffer-ptr stream)) + 3 ; read-modify + 1 ; write + )))) + +(defun sc-set-clean (stream) + (with-stream-class (single-channel-simple-stream stream) + (setf (sm mode stream) 0))) + +(defun sc-dirty-p (stream) + (with-stream-class (single-channel-simple-stream stream) + (> (sm mode stream) 0))) + (defun flush-buffer (stream blocking) (with-stream-class (single-channel-simple-stream stream) (let ((ptr 0) (bytes (sm buffpos stream))) (declare (type fixnum ptr bytes)) (loop - (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return 0)) + (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0)) (let ((bytes-written (device-write stream nil ptr nil blocking))) (declare (fixnum bytes-written)) (when (minusp bytes-written) @@ -170,6 +187,39 @@ (lisp::eof-or-lose stream eof-error-p eof-value) char)))))) + +(declaim (ftype j-read-char-fn (sc read-char :ef mapped))) +(defun (sc read-char :ef mapped) (stream eof-error-p eof-value blocking) + #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|# + (declare (ignore blocking)) + (with-stream-class (simple-stream stream) + (let* ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream))) + (flet ((input () + (when (>= buffpos (sm buffer-ptr stream)) + (return-from read-char + (lisp::eof-or-lose stream eof-error-p eof-value))) + (incf (sm last-char-read-size stream)) + (prog1 (bref buffer buffpos) + (incf buffpos))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) cnt + (sm oc-state stream) state) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (if (null char) + (lisp::eof-or-lose stream eof-error-p eof-value) + char)))))) + (declaim (ftype j-read-chars-fn (sc read-chars :ef))) (defun (sc read-chars :ef) (stream string search start end blocking) ;; string is filled from START to END, or until SEARCH is found @@ -239,6 +289,67 @@ (t (setf (char string posn) char)))))))) + +(declaim (ftype j-read-chars-fn (sc read-chars :ef mapped))) +(defun (sc read-chars :ef mapped) (stream string search start end blocking) + ;; string is filled from START to END, or until SEARCH is found + ;; Return two values: count of chars read and + ;; NIL if SEARCH was not found + ;; T if SEARCH was found + ;; :EOF if eof encountered before end + (declare (type simple-stream stream) + (type string string) + (type (or null character) search) + (type fixnum start end) + (type boolean blocking) + (ignore blocking) + #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#) + (with-stream-class (simple-stream stream) + ;; if stream is single-channel and mode == 3, flush buffer (if dirty) + (do ((buffer (sm buffer stream)) + (buffpos (sm buffpos stream)) + (buffer-ptr (sm buffer-ptr stream)) + (lcrs 0) + (ctrl (sm control-in stream)) + (ef (sm external-format stream)) + (state (sm oc-state stream)) + (posn start (1+ posn)) + (count 0 (1+ count))) + ((>= posn end) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (values count nil)) + (declare (type lisp::index buffpos buffer-ptr posn count)) + (flet ((input () + (when (>= buffpos buffer-ptr) + (return (values count :eof))) + (prog1 (bref buffer buffpos) + (incf buffpos) + (incf lcrs))) + (unput (n) + (decf buffpos n))) + (let* ((cnt 0) + (char (octets-to-char ef state cnt #'input #'unput)) + (code (char-code char))) + (setq lcrs cnt) + (when (and (< code 32) ctrl (svref ctrl code)) + (setq char (funcall (the (or symbol function) (svref ctrl code)) + stream char))) + (cond ((null char) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count :eof))) + ((and search (char= char search)) + (setf (sm buffpos stream) buffpos + (sm last-char-read-size stream) lcrs + (sm oc-state stream) state) + (return (values count t))) + (t + (setf (char string posn) char)))))))) + + (declaim (ftype j-unread-char-fn (sc unread-char :ef))) (defun (sc unread-char :ef) (stream relaxed) (declare (ignore relaxed)) @@ -470,6 +581,7 @@ (defun %sf (kind name format &optional access) (or (ignore-errors (fdefinition (list kind name format access))) (ignore-errors (fdefinition (list kind name format))) + (ignore-errors (fdefinition (list kind name :ef access))) (fdefinition (list kind name :ef)))) (defun install-single-channel-character-strategy (stream external-format