X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-simple-streams%2Fimpl.lisp;h=d3e3293905b36c5221535f5496b653e3ffa625bd;hb=f7e3e709f7c2207f1923375942f7fb1c092f92b0;hp=f85edeb0f12d2c038bec5d5b7acbb2034a248f3d;hpb=cc9a73604f696b6e69842a95b1e11f40f8cdd7bf;p=sbcl.git diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index f85edeb..d3e3293 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; This code was written by Paul Foley and has been placed in the public ;;; domain. -;;; +;;; ;;; Sbcl port by Rudi Schlatte. @@ -19,19 +19,19 @@ (defun %check (stream kind) (declare (type simple-stream stream) - (optimize (speed 3) (space 1) (debug 0) (safety 0))) + (optimize (speed 3) (space 1) (debug 0) (safety 0))) (with-stream-class (simple-stream stream) (cond ((not (any-stream-instance-flags stream :simple)) - (%uninitialized stream)) - ((and (eq kind :open) - (not (any-stream-instance-flags stream :input :output))) - (sb-kernel:closed-flame stream)) - ((and (or (eq kind :input) (eq kind :io)) - (not (any-stream-instance-flags stream :input))) - (sb-kernel:ill-in stream)) - ((and (or (eq kind :output) (eq kind :io)) - (not (any-stream-instance-flags stream :output))) - (sb-kernel:ill-out stream))))) + (%uninitialized stream)) + ((and (eq kind :open) + (not (any-stream-instance-flags stream :input :output))) + (sb-kernel:closed-flame stream)) + ((and (or (eq kind :input) (eq kind :io)) + (not (any-stream-instance-flags stream :input))) + (sb-kernel:ill-in stream)) + ((and (or (eq kind :output) (eq kind :io)) + (not (any-stream-instance-flags stream :output))) + (sb-kernel:ill-out stream))))) (defmethod input-stream-p ((stream simple-stream)) (any-stream-instance-flags stream :input)) @@ -51,54 +51,54 @@ (defun %file-position (stream position) (declare (type simple-stream stream) - (type (or (integer 0 *) (member nil :start :end)) position)) + (type (or (integer 0 *) (member nil :start :end)) position)) (with-stream-class (simple-stream stream) (%check stream :open) (if position - ;; Adjust current position - (let ((position (case position (:start 0) (:end -1) - (otherwise position)))) - (etypecase stream - (single-channel-simple-stream + ;; Adjust current position + (let ((position (case position (:start 0) (:end -1) + (otherwise position)))) + (etypecase stream + (single-channel-simple-stream (when (sc-dirty-p stream) (flush-buffer stream t))) - (dual-channel-simple-stream + (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (when (> (sm outpos stream) 0) + (when (> (sm outpos stream) 0) (device-write stream :flush 0 nil t)))) - (string-simple-stream + (string-simple-stream nil)) - (setf (sm last-char-read-size stream) 0) - (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read - (sm buffer-ptr stream) 0) - (setf (sm charpos stream) nil) - (remove-stream-instance-flags stream :eof) - (setf (device-file-position stream) position)) - ;; Just report current position - (let ((posn (device-file-position stream))) - (when posn - (when (sm handler stream) - (dolist (queued (sm pending stream)) - (incf posn (- (the sb-int:index (third queued)) - (the sb-int:index (second queued)))))) - (etypecase stream - (single-channel-simple-stream + (setf (sm last-char-read-size stream) 0) + (setf (sm buffpos stream) 0 ; set pointer to 0 to force a read + (sm buffer-ptr stream) 0) + (setf (sm charpos stream) nil) + (remove-stream-instance-flags stream :eof) + (setf (device-file-position stream) position)) + ;; Just report current position + (let ((posn (device-file-position stream))) + (when posn + (when (sm handler stream) + (dolist (queued (sm pending stream)) + (incf posn (- (the sb-int:index (third queued)) + (the sb-int:index (second queued)))))) + (etypecase stream + (single-channel-simple-stream (case (sm mode stream) - ((0 3) ; read, read-modify + ((0 3) ; read, read-modify ;; Note that posn can increase here if we wrote ;; past the end of previously-read data (decf posn (- (sm buffer-ptr stream) (sm buffpos stream)))) - (1 ; write + (1 ; write (incf posn (sm buffpos stream))))) - (dual-channel-simple-stream + (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (incf posn (sm outpos stream)) + (incf posn (sm outpos stream)) (when (>= (sm buffer-ptr stream) 0) (decf posn (- (sm buffer-ptr stream) (sm buffpos stream)))))) - (string-simple-stream + (string-simple-stream nil))) - posn)))) + posn)))) (defun %file-length (stream) (declare (type simple-stream stream)) @@ -125,9 +125,9 @@ (%check stream nil) (if (typep stream 'file-simple-stream) (with-stream-class (file-simple-stream stream) - (setf (sm pathname stream) new-name) - (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) - t) + (setf (sm pathname stream) new-name) + (setf (sm filename stream) (sb-int:unix-namestring new-name nil)) + t) nil)) @@ -138,102 +138,102 @@ ;; FIXME: need to account for compositions on the stream... (let ((count 0)) (flet ((fn (octet) - (declare (ignore octet)) - (incf count))) - (etypecase object - (character - (let ((x nil)) - (char-to-octets (sm external-format stream) object x #'fn))) - (string - (let ((x nil) - (ef (sm external-format stream))) - (dotimes (i (length object)) - (declare (type sb-int:index i)) - (char-to-octets ef (char object i) x #'fn)))))) + (declare (ignore octet)) + (incf count))) + (etypecase object + (character + (let ((x nil)) + (char-to-octets (sm external-format stream) object x #'fn))) + (string + (let ((x nil) + (ef (sm external-format stream))) + (dotimes (i (length object)) + (declare (type sb-int:index i)) + (char-to-octets ef (char object i) x #'fn)))))) count))) (defun %read-line (stream eof-error-p eof-value recursive-p) (declare (optimize (speed 3) (space 1) (safety 0) (debug 0)) - (type simple-stream stream) - (ignore recursive-p)) + (type simple-stream stream) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-line - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) - (any-stream-instance-flags stream :interactive)) + (any-stream-instance-flags stream :interactive)) (%finish-output stream)) (let* ((encap (sm melded-stream stream)) ; encapsulating stream - (cbuf (make-string 80)) ; current buffer - (bufs (list cbuf)) ; list of buffers - (tail bufs) ; last cons of bufs list - (index 0) ; current index in current buffer - (total 0)) ; total characters + (cbuf (make-string 80)) ; current buffer + (bufs (list cbuf)) ; list of buffers + (tail bufs) ; last cons of bufs list + (index 0) ; current index in current buffer + (total 0)) ; total characters (declare (type simple-stream encap) - (type simple-base-string cbuf) - (type cons bufs tail) - (type sb-int:index index total)) + (type simple-string cbuf) + (type cons bufs tail) + (type sb-int:index index total)) (loop - (multiple-value-bind (chars done) - (funcall-stm-handler j-read-chars encap cbuf - #\Newline index (length cbuf) t) - (declare (type sb-int:index chars)) - (incf index chars) - (incf total chars) - (when (and (eq done :eof) (zerop total)) - (if eof-error-p - (error 'end-of-file :stream stream) - (return (values eof-value t)))) - (when done - ;; If there's only one buffer in use, return it directly - (when (null (cdr bufs)) - (return (values (sb-kernel:shrink-vector cbuf total) - (eq done :eof)))) - ;; If total fits in final buffer, use it - (when (<= total (length cbuf)) - (replace cbuf cbuf :start1 (- total index) :end2 index) - (let ((idx 0)) - (declare (type sb-int:index idx)) - (do ((list bufs (cdr list))) - ((eq list tail)) - (let ((buf (car list))) - (declare (type simple-base-string buf)) - (replace cbuf buf :start1 idx) - (incf idx (length buf))))) - (return (values (sb-kernel:shrink-vector cbuf total) - (eq done :eof)))) - ;; Allocate new string of appropriate length - (let ((string (make-string total)) - (index 0)) - (declare (type sb-int:index index)) - (dolist (buf bufs) - (declare (type simple-base-string buf)) - (replace string buf :start1 index) - (incf index (length buf))) - (return (values string (eq done :eof))))) - (when (>= index (length cbuf)) - (setf cbuf (make-string (the sb-int:index (* 2 index)))) - (setf index 0) - (setf (cdr tail) (cons cbuf nil)) - (setf tail (cdr tail)))))))) + (multiple-value-bind (chars done) + (funcall-stm-handler j-read-chars encap cbuf + #\Newline index (length cbuf) t) + (declare (type sb-int:index chars)) + (incf index chars) + (incf total chars) + (when (and (eq done :eof) (zerop total)) + (if eof-error-p + (error 'end-of-file :stream stream) + (return (values eof-value t)))) + (when done + ;; If there's only one buffer in use, return it directly + (when (null (cdr bufs)) + (return (values (sb-kernel:shrink-vector cbuf total) + (eq done :eof)))) + ;; If total fits in final buffer, use it + (when (<= total (length cbuf)) + (replace cbuf cbuf :start1 (- total index) :end2 index) + (let ((idx 0)) + (declare (type sb-int:index idx)) + (do ((list bufs (cdr list))) + ((eq list tail)) + (let ((buf (car list))) + (declare (type simple-string buf)) + (replace cbuf buf :start1 idx) + (incf idx (length buf))))) + (return (values (sb-kernel:shrink-vector cbuf total) + (eq done :eof)))) + ;; Allocate new string of appropriate length + (let ((string (make-string total)) + (index 0)) + (declare (type sb-int:index index)) + (dolist (buf bufs) + (declare (type simple-string buf)) + (replace string buf :start1 index) + (incf index (length buf))) + (return (values string (eq done :eof))))) + (when (>= index (length cbuf)) + (setf cbuf (make-string (the sb-int:index (* 2 index)))) + (setf index 0) + (setf (cdr tail) (cons cbuf nil)) + (setf tail (cdr tail)))))))) (defun %read-char (stream eof-error-p eof-value recursive-p blocking-p) (declare (type simple-stream stream) - (ignore recursive-p)) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %read-char - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) ;; for interactive streams, finish output first to force prompt (when (and (any-stream-instance-flags stream :output) - (any-stream-instance-flags stream :interactive)) + (any-stream-instance-flags stream :interactive)) (%finish-output stream)) (funcall-stm-handler j-read-char (sm melded-stream stream) - eof-error-p eof-value blocking-p))) + eof-error-p eof-value blocking-p))) (defun %unread-char (stream character) @@ -241,45 +241,45 @@ (with-stream-class (simple-stream stream) (%check stream :input) (if (zerop (sm last-char-read-size stream)) - (error "Nothing to unread.") - (progn - (funcall-stm-handler j-unread-char (sm melded-stream stream) nil) - (remove-stream-instance-flags stream :eof) - (setf (sm last-char-read-size stream) 0))))) + (error "Nothing to unread.") + (progn + (funcall-stm-handler j-unread-char (sm melded-stream stream) nil) + (remove-stream-instance-flags stream :eof) + (setf (sm last-char-read-size stream) 0))))) (defun %peek-char (stream peek-type eof-error-p eof-value recursive-p) (declare (type simple-stream stream) - (ignore recursive-p)) + (ignore recursive-p)) (with-stream-class (simple-stream stream) (%check stream :input) (when (any-stream-instance-flags stream :eof) (return-from %peek-char - (sb-impl::eof-or-lose stream eof-error-p eof-value))) + (sb-impl::eof-or-lose stream eof-error-p eof-value))) (let* ((encap (sm melded-stream stream)) - (char (funcall-stm-handler j-read-char encap - eof-error-p stream t))) + (char (funcall-stm-handler j-read-char encap + eof-error-p stream t))) (cond ((eq char stream) eof-value) - ((characterp peek-type) - (do ((char char (funcall-stm-handler j-read-char encap - eof-error-p - stream t))) - ((or (eq char stream) (char= char peek-type)) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - ((eq peek-type t) - (do ((char char (funcall-stm-handler j-read-char encap - eof-error-p - stream t))) - ((or (eq char stream) - (not (sb-impl::whitespacep char))) - (unless (eq char stream) - (funcall-stm-handler j-unread-char encap t)) - (if (eq char stream) eof-value char)))) - (t - (funcall-stm-handler j-unread-char encap t) - char))))) + ((characterp peek-type) + (do ((char char (funcall-stm-handler j-read-char encap + eof-error-p + stream t))) + ((or (eq char stream) (char= char peek-type)) + (unless (eq char stream) + (funcall-stm-handler j-unread-char encap t)) + (if (eq char stream) eof-value char)))) + ((eq peek-type t) + (do ((char char (funcall-stm-handler j-read-char encap + eof-error-p + stream t))) + ((or (eq char stream) + (not (sb-impl::whitespace[2]p char))) + (unless (eq char stream) + (funcall-stm-handler j-unread-char encap t)) + (if (eq char stream) eof-value char)))) + (t + (funcall-stm-handler j-unread-char encap t) + char))))) (defun %listen (stream width) (declare (type simple-stream stream)) @@ -290,24 +290,23 @@ (when (any-stream-instance-flags stream :eof) (return-from %listen nil)) (if (not (or (eql width 1) (null width))) - (funcall-stm-handler j-listen (sm melded-stream stream)) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (when (>= (sm mode stream) 0) ;; device-connected @@ single-channel - (let ((lcrs (sm last-char-read-size stream))) - (unwind-protect - (progn - (setf (sm last-char-read-size stream) (1+ lcrs)) - (plusp (refill-buffer stream nil))) - (setf (sm last-char-read-size stream) lcrs)))))))) + (funcall-stm-handler j-listen (sm melded-stream stream)) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + ;; Attempt buffer refill + (when (and (not (any-stream-instance-flags stream :dual :string)) + (>= (sm mode stream) 0)) + ;; single-channel stream dirty -> write data before reading + (flush-buffer stream nil)) + (>= (refill-buffer stream nil) width))))) (defun %clear-input (stream buffer-only) (declare (type simple-stream stream)) (with-stream-class (simple-stream stream) (%check stream :input) (setf (sm buffpos stream) 0 - (sm buffer-ptr stream) 0 - (sm last-char-read-size stream) 0 - #|(sm unread-past-soft-eof stream) nil|#) + (sm buffer-ptr stream) 0 + (sm last-char-read-size stream) 0 + #|(sm unread-past-soft-eof stream) nil|#) #| (setf (sm reread-count stream) 0) on dual-channel streams? |# ) (device-clear-input stream buffer-only)) @@ -318,15 +317,15 @@ (with-stream-class (simple-stream stream) (%check stream :input) (if (any-stream-instance-flags stream :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - (etypecase stream - (single-channel-simple-stream + (sb-impl::eof-or-lose stream eof-error-p eof-value) + (etypecase stream + (single-channel-simple-stream (read-byte-internal stream eof-error-p eof-value t)) (dual-channel-simple-stream (read-byte-internal stream eof-error-p eof-value t)) - (string-simple-stream + (string-simple-stream (with-stream-class (string-simple-stream stream) - (let ((encap (sm input-handle stream))) + (let ((encap (sm input-handle stream))) (unless encap (error 'simple-type-error :datum stream @@ -360,7 +359,7 @@ (with-stream-class (simple-stream stream) (%check stream :output) (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream) - start end))) + start end))) (defun %line-length (stream) @@ -376,8 +375,8 @@ (%check stream :output) (when (sm handler stream) (do () - ((null (sm pending stream))) - (sb-sys:serve-all-events))) + ((null (sm pending stream))) + (sb-sys:serve-all-events))) (etypecase stream (single-channel-simple-stream ;(when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0)) @@ -389,7 +388,7 @@ (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) (device-write stream :flush 0 nil t) - (setf (sm outpos stream) 0))) + (setf (sm outpos stream) 0))) (string-simple-stream (device-write stream :flush 0 nil t)))) nil) @@ -410,7 +409,7 @@ (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) (device-write stream :flush 0 nil nil) - (setf (sm outpos stream) 0))) + (setf (sm outpos stream) 0))) (string-simple-stream (device-write stream :flush 0 nil nil)))) nil) @@ -423,11 +422,11 @@ (when (sm handler stream) (sb-sys:remove-fd-handler (sm handler stream)) (setf (sm handler stream) nil - (sm pending stream) nil)) + (sm pending stream) nil)) (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (case (sm mode stream) + (case (sm mode stream) (1 (setf (sm buffpos stream) 0)) (3 (setf (sm mode stream) 0))))) (dual-channel-simple-stream @@ -444,16 +443,16 @@ (etypecase stream (single-channel-simple-stream (with-stream-class (single-channel-simple-stream stream) - (let ((ptr (sm buffpos stream))) - (when (>= ptr (sm buf-len stream)) - (setf ptr (flush-buffer stream t))) - (setf (sm buffpos stream) (1+ ptr)) + (let ((ptr (sm buffpos stream))) + (when (>= ptr (sm buf-len stream)) + (setf ptr (flush-buffer stream t))) + (setf (sm buffpos stream) (1+ ptr)) (setf (sm charpos stream) nil) - (setf (bref (sm buffer stream) ptr) integer) + (setf (bref (sm buffer stream) ptr) integer) (sc-set-dirty stream)))) (dual-channel-simple-stream (with-stream-class (dual-channel-simple-stream stream) - (let ((ptr (sm outpos stream))) + (let ((ptr (sm outpos stream))) (when (>= ptr (sm max-out-pos stream)) (setf ptr (flush-out-buffer stream t))) (setf (sm outpos stream) (1+ ptr)) @@ -461,7 +460,7 @@ (setf (bref (sm out-buffer stream) ptr) integer)))) (string-simple-stream (with-stream-class (string-simple-stream stream) - (let ((encap (sm output-handle stream))) + (let ((encap (sm output-handle stream))) (unless encap (error 'simple-type-error :datum stream @@ -473,294 +472,129 @@ (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 boolean partial-fill)) + (type sequence seq) + (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)) - (if partial-fill :bnb t))) + start end + (if partial-fill :bnb t))) ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-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 sequence seq) + (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) (*))) + (simple-array (signed-byte 8) (*))) ;; "write-vector" equivalent (setf (sm charpos stream) nil) (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)) (declare (type (sb-kernel:simple-unboxed-array (*)) vector) - (type stream stream)) + (type stream stream)) ;; START and END are octet offsets, not vector indices! [Except for strings] ;; Return value is index of next octet to be read into (i.e., start+count) (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) (*)) - (simple-array (unsigned-byte 8) (*)))) + (simple-array (signed-byte 8) (*)) + (simple-array (unsigned-byte 8) (*)))) (error "Wrong vector type for read-vector on stream not of type simple-stream.")) (read-sequence vector stream :start (or start 0) :end end)))) -;;; Basic functionality for ansi-streams. These are separate -;;; functions because they are called in places where we already know -;;; we operate on an ansi-stream (as opposed to a simple- or -;;; gray-stream, or the symbols t or nil), so we can evade typecase -;;; and (in|out)-synonym-of calls. - -(declaim (inline %ansi-stream-read-byte %ansi-stream-read-char - %ansi-stream-unread-char %ansi-stream-read-line - %ansi-stream-read-sequence)) - -(defun %ansi-stream-read-byte (stream eof-error-p eof-value blocking) - (declare (ignore blocking)) - #+nil - (sb-kernel:ansi-stream-read-byte stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-byte stream - (prog1 - (sb-int:fast-read-byte eof-error-p eof-value t) - (sb-int:done-with-fast-read-byte)))) - -(defun %ansi-stream-read-char (stream eof-error-p eof-value blocking) - (declare (ignore blocking)) - #+nil - (sb-kernel:ansi-stream-read-char stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-char stream - (prog1 - (sb-int:fast-read-char eof-error-p eof-value) - (sb-int:done-with-fast-read-char)))) - -(defun %ansi-stream-unread-char (character stream) - (let ((index (1- (sb-kernel:ansi-stream-in-index stream))) - (buffer (sb-kernel:ansi-stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "nothing to unread")) - (cond (buffer - (setf (aref buffer index) (char-code character)) - (setf (sb-kernel:ansi-stream-in-index stream) index)) - (t - (funcall (sb-kernel:ansi-stream-misc stream) stream - :unread character))))) - -(defun %ansi-stream-read-line (stream eof-error-p eof-value) - (sb-int:prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (sb-int:fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (sb-int:done-with-fast-read-char) - (return (values (sb-kernel:shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (sb-int:done-with-fast-read-char) - (return (values (sb-impl::eof-or-lose stream eof-error-p - eof-value) - t))) - ;; Since FAST-READ-CHAR already hit the eof char, we - ;; shouldn't do another READ-CHAR. - (t - (sb-int:done-with-fast-read-char) - (return (values (sb-kernel:shrink-vector res index) t))))))))) - -(defun %ansi-stream-read-sequence (seq stream start %end) - (declare (type sequence seq) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start) - (type sb-kernel:sequence-end %end) - (values sb-int:index)) - (let ((end (or %end (length seq)))) - (declare (type sb-int:index end)) - (etypecase seq - (list - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'%ansi-stream-read-char - #'%ansi-stream-read-byte))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end)) i) - (declare (type list rem) - (type sb-int:index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return i)) - (setf (first rem) el))))) - (vector - (sb-kernel:with-array-data ((data seq) (offset-start start) - (offset-end end)) - (typecase data - ((or (simple-array (unsigned-byte 8) (*)) - (simple-array (signed-byte 8) (*)) - simple-string) - (let* ((numbytes (- end start)) - (bytes-read (sb-sys:read-n-bytes stream - data - offset-start - numbytes - nil))) - (if (< bytes-read numbytes) - (+ start bytes-read) - end))) - (t - (let ((read-function - (if (subtypep (stream-element-type stream) 'character) - #'%ansi-stream-read-char - #'%ansi-stream-read-byte))) - (do ((i offset-start (1+ i))) - ((>= i offset-end) end) - (declare (type sb-int:index i)) - (let ((el (funcall read-function stream nil :eof nil))) - (when (eq el :eof) - (return (+ start (- i offset-start)))) - (setf (aref data i) el))))))))))) - - -(defun %ansi-stream-write-string (string stream start end) - (declare (type string string) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start end)) - - ;; Note that even though you might expect, based on the behavior of - ;; things like AREF, that the correct upper bound here is - ;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for - ;; "bounding index" and "length" indicate that in this case (i.e. - ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE - ;; which are implemented in terms of this function), (LENGTH STRING) - ;; is the required upper bound. A foolish consistency is the - ;; hobgoblin of lesser languages.. - (unless (<= 0 start end (length string)) - (error "~@" - start - end - string)) - - (if (sb-kernel:array-header-p string) - (sb-kernel:with-array-data ((data string) (offset-start start) - (offset-end end)) - (funcall (sb-kernel:ansi-stream-sout stream) - stream data offset-start offset-end)) - (funcall (sb-kernel:ansi-stream-sout stream) stream string start end)) - string) - -(defun %ansi-stream-write-sequence (seq stream start %end) - (declare (type sequence seq) - (type sb-kernel:ansi-stream stream) - (type sb-int:index start) - (type sb-kernel:sequence-end %end) - (values sequence)) - (let ((end (or %end (length seq)))) - (declare (type sb-int:index end)) - (etypecase seq - (list - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - ;; TODO: Replace these with ansi-stream specific - ;; functions too. - #'write-char - #'write-byte))) - (do ((rem (nthcdr start seq) (rest rem)) - (i start (1+ i))) - ((or (endp rem) (>= i end)) seq) - (declare (type list rem) - (type sb-int:index i)) - (funcall write-function (first rem) stream)))) - (string - (%ansi-stream-write-string seq stream start end)) - (vector - (let ((write-function - (if (subtypep (stream-element-type stream) 'character) - ;; TODO: Replace these with ansi-stream specific - ;; functions too. - #'write-char - #'write-byte))) - (do ((i start (1+ i))) - ((>= i end) seq) - (declare (type sb-int:index i)) - (funcall write-function (aref seq i) stream))))))) - ;;; ;;; USER-LEVEL FUNCTIONS @@ -851,17 +685,17 @@ :output-handle - a stream or Unix file descriptor to write to" (declare (ignore element-type external-format input-handle output-handle if-exists if-does-not-exist)) - (let ((class (or class 'sb-sys::file-stream)) - (options (copy-list options)) + (let ((class (or class 'sb-sys:fd-stream)) + (options (copy-list options)) (filespec (merge-pathnames filename))) - (cond ((eq class 'sb-sys::file-stream) - (remf options :class) + (cond ((eq class 'sb-sys:fd-stream) + (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) (apply #'open-fd-stream filespec options)) - ((subtypep class 'simple-stream) - (when element-type-given + ((subtypep class 'simple-stream) + (when element-type-given (cerror "Do it anyway." "Can't create simple-streams with an element-type.")) (when (and (eq class 'file-simple-stream) mapped) @@ -871,12 +705,12 @@ (when (eq direction :probe) (setq class 'probe-simple-stream))) (apply #'make-instance class :filename filespec options)) - ((subtypep class 'sb-gray:fundamental-stream) - (remf options :class) + ((subtypep class 'sb-gray:fundamental-stream) + (remf options :class) (remf options :mapped) (remf options :input-handle) (remf options :output-handle) - (make-instance class :lisp-stream + (make-instance class :lisp-stream (apply #'open-fd-stream filespec options)))))) @@ -889,47 +723,46 @@ (simple-stream (%read-byte stream eof-error-p eof-value)) (ansi-stream - (%ansi-stream-read-byte stream eof-error-p eof-value t)) + (sb-impl::ansi-stream-read-byte stream eof-error-p eof-value nil)) (fundamental-stream (let ((char (sb-gray:stream-read-byte stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun read-char (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Inputs a character from Stream and returns it." (let ((stream (sb-impl::in-synonym-of stream))) (etypecase stream (simple-stream (%read-char stream eof-error-p eof-value recursive-p t)) (ansi-stream - (%ansi-stream-read-char stream eof-error-p eof-value t)) + (sb-impl::ansi-stream-read-char stream eof-error-p eof-value + recursive-p)) (fundamental-stream (let ((char (sb-gray:stream-read-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun read-char-no-hang (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Returns the next character from the Stream if one is availible, or nil." - (declare (ignore recursive-p)) (let ((stream (sb-impl::in-synonym-of stream))) (etypecase stream (simple-stream (%check stream :input) (with-stream-class (simple-stream) - (funcall-stm-handler j-read-char stream eof-error-p eof-value nil))) + (funcall-stm-handler j-read-char stream eof-error-p eof-value nil))) (ansi-stream - (if (funcall (sb-kernel:ansi-stream-misc stream) stream :listen) - (%ansi-stream-read-char stream eof-error-p eof-value t) - nil)) + (sb-impl::ansi-stream-read-char-no-hang stream eof-error-p eof-value + recursive-p)) (fundamental-stream (let ((char (sb-gray:stream-read-char-no-hang stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))) (defun unread-char (character &optional (stream *standard-input*)) "Puts the Character back on the front of the input Stream." @@ -938,7 +771,7 @@ (simple-stream (%unread-char stream character)) (ansi-stream - (%ansi-stream-unread-char character stream)) + (sb-impl::ansi-stream-unread-char character stream)) (fundamental-stream (sb-gray:stream-unread-char stream character)))) nil) @@ -946,61 +779,46 @@ (declaim (notinline read-byte read-char read-char-no-hang unread-char)) (defun peek-char (&optional (peek-type nil) (stream *standard-input*) - (eof-error-p t) eof-value recursive-p) + (eof-error-p t) eof-value recursive-p) "Peeks at the next character in the input Stream. See manual for details." (let ((stream (sb-impl::in-synonym-of stream))) (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) - ((characterp peek-type) - (do ((char char (%ansi-stream-read-char stream eof-error-p - eof-value t))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (%ansi-stream-unread-char char stream)) - char))) - ((eq peek-type t) - (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))) - (unless (eq char eof-value) - (%ansi-stream-unread-char char stream)) - char))) - (t - (%ansi-stream-unread-char char stream) - char)))) + (sb-impl::ansi-stream-peek-char peek-type stream eof-error-p eof-value + recursive-p)) (fundamental-stream (cond ((characterp peek-type) - (do ((char (sb-gray:stream-read-char stream) - (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (char= char peek-type)) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - ((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))) - (cond ((eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value)) - (t - (sb-gray:stream-unread-char stream char) - char))))) - (t - (let ((char (sb-gray:stream-peek-char stream))) - (if (eq char :eof) - (sb-impl::eof-or-lose stream eof-error-p eof-value) - char)))))))) + (do ((char (sb-gray:stream-read-char stream) + (sb-gray:stream-read-char stream))) + ((or (eq char :eof) (char= char peek-type)) + (cond ((eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value)) + (t + (sb-gray:stream-unread-char stream char) + char))))) + ((eq peek-type t) + (do ((char (sb-gray:stream-read-char stream) + (sb-gray:stream-read-char stream))) + ((or (eq char :eof) (not (sb-impl::whitespace[2]p char))) + (cond ((eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value)) + (t + (sb-gray:stream-unread-char stream char) + char))))) + (t + (let ((char (sb-gray:stream-peek-char stream))) + (if (eq char :eof) + (sb-impl::eof-or-lose stream eof-error-p eof-value) + char)))))))) (defun listen (&optional (stream *standard-input*) (width 1)) - "Returns T if Width octets are available on the given Stream. If Width - is given as 'character, check for a character." + "Returns T if WIDTH octets are available on STREAM. If WIDTH is +given as 'CHARACTER, check for a character. Note: the WIDTH argument +is supported only on simple-streams." ;; WIDTH is number of octets which must be available; any value ;; other than 1 is treated as 'character. (let ((stream (sb-impl::in-synonym-of stream))) @@ -1008,17 +826,13 @@ (simple-stream (%listen stream width)) (ansi-stream - (or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream)) - sb-impl::+ansi-stream-in-buffer-length+) - ;; Test for T explicitly since misc methods return :EOF sometimes. - (eq (funcall (sb-kernel:ansi-stream-misc stream) stream :listen) - t))) + (sb-impl::ansi-stream-listen stream)) (fundamental-stream (sb-gray:stream-listen stream))))) (defun read-line (&optional (stream *standard-input*) (eof-error-p t) - eof-value recursive-p) + eof-value recursive-p) "Returns a line of text read from the Stream as a string, discarding the newline character." (let ((stream (sb-impl::in-synonym-of stream))) @@ -1026,12 +840,13 @@ (simple-stream (%read-line stream eof-error-p eof-value recursive-p)) (ansi-stream - (%ansi-stream-read-line stream eof-error-p eof-value)) + (sb-impl::ansi-stream-read-line stream eof-error-p eof-value + recursive-p)) (fundamental-stream (multiple-value-bind (string eof) (sb-gray:stream-read-line stream) - (if (and eof (zerop (length string))) - (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) - (values string eof))))))) + (if (and eof (zerop (length string))) + (values (sb-impl::eof-or-lose stream eof-error-p eof-value) t) + (values string eof))))))) (defun read-sequence (seq stream &key (start 0) (end nil) partial-fill) "Destructively modify SEQ by reading elements from STREAM. @@ -1041,13 +856,13 @@ then the extra elements near the end of sequence are not updated, and the index of the next element is returned." (let ((stream (sb-impl::in-synonym-of stream)) - (end (or end (length seq)))) + (end (or end (length seq)))) (etypecase stream (simple-stream (with-stream-class (simple-stream stream) - (%read-sequence stream seq start end partial-fill))) + (%read-sequence stream seq start end partial-fill))) (ansi-stream - (%ansi-stream-read-sequence seq stream start end)) + (sb-impl::ansi-stream-read-sequence seq stream start end)) (fundamental-stream (sb-gray:stream-read-sequence stream seq start end))))) @@ -1058,9 +873,7 @@ (simple-stream (%clear-input stream buffer-only)) (ansi-stream - (setf (sb-kernel:ansi-stream-in-index stream) - sb-impl::+ansi-stream-in-buffer-length+) - (funcall (sb-kernel:ansi-stream-misc stream) stream :clear-input)) + (sb-impl::ansi-stream-clear-input stream)) (fundamental-stream (sb-gray:stream-clear-input stream)))) nil) @@ -1090,34 +903,32 @@ character) (defun write-string (string &optional (stream *standard-output*) - &key (start 0) (end nil)) + &key (start 0) (end nil)) "Outputs the String to the given Stream." (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length string)))) + (end (sb-impl::%check-vector-sequence-bounds string start end))) (etypecase stream (simple-stream (%write-string stream string start end) string) (ansi-stream - (%ansi-stream-write-string string stream start end)) + (sb-impl::ansi-stream-write-string string stream start end)) (fundamental-stream (sb-gray:stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) - &key (start 0) end) + &key (start 0) end) (declare (type string string)) - ;; FIXME: Why is there this difference between the treatments of the - ;; STREAM argument in WRITE-STRING and WRITE-LINE? (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length string)))) + (end (sb-impl::%check-vector-sequence-bounds string start end))) (etypecase stream (simple-stream (%check stream :output) (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-chars string stream start end) - (funcall-stm-handler-2 j-write-char #\Newline stream))) + (funcall-stm-handler-2 j-write-chars string stream start end) + (funcall-stm-handler-2 j-write-char #\Newline stream))) (ansi-stream - (%ansi-stream-write-string string stream start end) + (sb-impl::ansi-stream-write-string string stream start end) (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) (fundamental-stream (sb-gray:stream-write-string stream string start end) @@ -1127,12 +938,12 @@ (defun write-sequence (seq stream &key (start 0) (end nil)) "Write the elements of SEQ bounded by START and END to STREAM." (let ((stream (sb-impl::out-synonym-of stream)) - (end (or end (length seq)))) + (end (or end (length seq)))) (etypecase stream (simple-stream (%write-sequence stream seq start end)) (ansi-stream - (%ansi-stream-write-sequence seq stream start end)) + (sb-impl::ansi-stream-write-sequence seq stream start end)) (fundamental-stream (sb-gray:stream-write-sequence stream seq start end))))) @@ -1143,7 +954,7 @@ (simple-stream (%check stream :output) (with-stream-class (simple-stream stream) - (funcall-stm-handler-2 j-write-char #\Newline stream))) + (funcall-stm-handler-2 j-write-char #\Newline stream))) (ansi-stream (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)) (fundamental-stream @@ -1158,9 +969,7 @@ (simple-stream (%fresh-line stream)) (ansi-stream - (when (/= (or (sb-kernel:charpos stream) 1) 0) - (funcall (sb-kernel:ansi-stream-out stream) stream #\Newline) - t)) + (sb-impl::ansi-stream-fresh-line stream)) (fundamental-stream (sb-gray:stream-fresh-line stream))))) @@ -1207,24 +1016,12 @@ File-Stream is open to. If the second argument is supplied, then this becomes the new file position. The second argument may also be :start or :end for the start and end of the file, respectively." - (declare (type (or (integer 0 *) (member nil :start :end)) position)) + (declare (type (or sb-int:index (member nil :start :end)) position)) (etypecase stream (simple-stream (%file-position stream position)) (ansi-stream - (cond - (position - (setf (sb-kernel:ansi-stream-in-index stream) - sb-impl::+ansi-stream-in-buffer-length+) - (funcall (sb-kernel:ansi-stream-misc stream) - stream :file-position position)) - (t - (let ((res (funcall (sb-kernel:ansi-stream-misc stream) - stream :file-position nil))) - (when res - (- res - (- sb-impl::+ansi-stream-in-buffer-length+ - (sb-kernel:ansi-stream-in-index stream)))))))))) + (sb-impl::ansi-stream-file-position stream position)))) (defun file-length (stream) "This function returns the length of the file that File-Stream is open to." @@ -1232,8 +1029,8 @@ (simple-stream (%file-length stream)) (ansi-stream - (progn (sb-impl::stream-must-be-associated-with-file stream) - (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))))) + (sb-impl::stream-must-be-associated-with-file stream) + (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))) (defun charpos (&optional (stream *standard-output*)) "Returns the number of characters on the current line of output of the given @@ -1275,17 +1072,17 @@ (simple-stream (%check stream :input) (with-stream-class (simple-stream stream) - (or (< (sm buffpos stream) (sm buffer-ptr stream)) - (wait-for-input-available (sm input-handle stream) timeout)))) + (or (< (sm buffpos stream) (sm buffer-ptr stream)) + (wait-for-input-available (sm input-handle stream) timeout)))) (two-way-stream (wait-for-input-available (two-way-stream-input-stream stream) timeout)) (synonym-stream (wait-for-input-available (symbol-value (synonym-stream-symbol stream)) - timeout)) - (sb-sys::file-stream + timeout)) + (sb-sys:fd-stream (or (< (sb-impl::fd-stream-in-index stream) - (length (sb-impl::fd-stream-in-buffer stream))) - (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) + (length (sb-impl::fd-stream-in-buffer stream))) + (wait-for-input-available (sb-sys:fd-stream-fd stream) timeout)))))) ;; Make PATHNAME and NAMESTRING work (defun sb-int:file-name (stream &optional new-name) @@ -1294,47 +1091,13 @@ (with-stream-class (file-simple-stream stream) (cond (new-name (%file-rename stream new-name)) - (t - (%file-name stream))))) - (sb-sys::file-stream + (t + (%file-name stream))))) + (sb-sys:fd-stream (cond (new-name - (setf (sb-impl::fd-stream-pathname stream) new-name) - (setf (sb-impl::fd-stream-file stream) - (sb-int:unix-namestring new-name nil)) - 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)))) + (setf (sb-impl::fd-stream-pathname stream) new-name) + (setf (sb-impl::fd-stream-file stream) + (sb-int:unix-namestring new-name nil)) + t) + (t + (sb-impl::fd-stream-pathname stream))))))