Skip to content

Commit

Permalink
1.0.6.30: clean up FD-SOUT a little bit
Browse files Browse the repository at this point in the history
	* Apparently the bozos have been dealt with; we now receive strings
	  to all calls to this function;
	* Declare types appropriately.
  • Loading branch information
Nathan Froyd committed Jun 6, 2007
1 parent 88439f4 commit b7f3ef0
Show file tree
Hide file tree
Showing 2 changed files with 31 additions and 44 deletions.
73 changes: 30 additions & 43 deletions src/code/fd-stream.lisp
Expand Up @@ -538,53 +538,40 @@
;;; unbuffered, slam the string down the file descriptor, otherwise
;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
;;; checking to see where the last newline was.
;;;
;;; Note: some bozos (the FASL dumper) call write-string with things
;;; other than strings. Therefore, we must make sure we have a string
;;; before calling POSITION on it.
;;; KLUDGE: It would be better to fix the bozos instead of trying to
;;; cover for them here. -- WHN 20000203
(defun fd-sout (stream thing start end)
(declare (type fd-stream stream) (type string thing))
(let ((start (or start 0))
(end (or end (length (the vector thing)))))
(declare (fixnum start end))
(if (stringp thing)
(let ((last-newline
(string-dispatch (simple-base-string
#!+sb-unicode
(simple-array character)
string)
thing
(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)
(:full
(output-raw-bytes stream thing start end))
(:line
(output-raw-bytes stream thing start end)
(when last-newline
(flush-output-buffer stream)))
(:none
(frob-output stream thing start end nil)))
(ecase (fd-stream-buffering stream)
(:full (funcall (fd-stream-output-bytes stream)
stream thing nil start end))
(:line (funcall (fd-stream-output-bytes stream)
stream thing last-newline start end))
(:none (funcall (fd-stream-output-bytes stream)
stream thing t start end))))
(if last-newline
(setf (fd-stream-char-pos stream)
(- end last-newline 1))
(incf (fd-stream-char-pos stream)
(- end start))))
(ecase (fd-stream-buffering stream)
((:line :full)
(output-raw-bytes stream thing start end))
(:none
(frob-output stream thing start end nil))))))
(let ((last-newline
(string-dispatch (simple-base-string
#!+sb-unicode
(simple-array character (*))
string)
thing
(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)
(:full
(output-raw-bytes stream thing start end))
(:line
(output-raw-bytes stream thing start end)
(when last-newline
(flush-output-buffer stream)))
(:none
(frob-output stream thing start end nil)))
(ecase (fd-stream-buffering stream)
(:full (funcall (fd-stream-output-bytes stream)
stream thing nil start end))
(:line (funcall (fd-stream-output-bytes stream)
stream thing last-newline start end))
(:none (funcall (fd-stream-output-bytes stream)
stream thing t start end))))
(if last-newline
(setf (fd-stream-char-pos stream) (- end last-newline 1))
(incf (fd-stream-char-pos stream) (- end start))))))

(defvar *external-formats* ()
#!+sb-doc
Expand Down
2 changes: 1 addition & 1 deletion version.lisp-expr
Expand Up @@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"1.0.6.29"
"1.0.6.30"

0 comments on commit b7f3ef0

Please sign in to comment.