:format-arguments (list stream)))
(defun closed-flame (stream &rest ignore)
(declare (ignore ignore))
- (error "~S is closed." stream))
+ (error 'closed-stream-error :stream stream))
(defun no-op-placeholder (&rest ignore)
(declare (ignore ignore)))
\f
;;; stream manipulation functions
-(declaim (inline ansi-stream-input-stream-p))
(defun ansi-stream-input-stream-p (stream)
(declare (type ansi-stream stream))
-
- (when (synonym-stream-p stream)
- (setf stream
- (symbol-value (synonym-stream-symbol stream))))
-
- (and (not (eq (ansi-stream-in stream) #'closed-flame))
+ (if (synonym-stream-p stream)
+ (input-stream-p (symbol-value (synonym-stream-symbol stream)))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
;;; KLUDGE: It's probably not good to have EQ tests on function
;;; values like this. What if someone's redefined the function?
;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
- (or (not (eq (ansi-stream-in stream) #'ill-in))
- (not (eq (ansi-stream-bin stream) #'ill-bin)))))
+ (or (not (eq (ansi-stream-in stream) #'ill-in))
+ (not (eq (ansi-stream-bin stream) #'ill-bin))))))
(defun input-stream-p (stream)
(declare (type stream stream))
(and (ansi-stream-p stream)
(ansi-stream-input-stream-p stream)))
-(declaim (inline ansi-stream-output-stream-p))
(defun ansi-stream-output-stream-p (stream)
(declare (type ansi-stream stream))
-
- (when (synonym-stream-p stream)
- (setf stream (symbol-value
- (synonym-stream-symbol stream))))
-
- (and (not (eq (ansi-stream-in stream) #'closed-flame))
- (or (not (eq (ansi-stream-out stream) #'ill-out))
- (not (eq (ansi-stream-bout stream) #'ill-bout)))))
+ (if (synonym-stream-p stream)
+ (output-stream-p (symbol-value (synonym-stream-symbol stream)))
+ (and (not (eq (ansi-stream-in stream) #'closed-flame))
+ (or (not (eq (ansi-stream-out stream) #'ill-out))
+ (not (eq (ansi-stream-bout stream) #'ill-bout))))))
(defun output-stream-p (stream)
(declare (type stream stream))
(setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-bin stream) #'closed-flame)
(setf (ansi-stream-n-bin stream) #'closed-flame)
- (setf (ansi-stream-in stream) #'closed-flame)
(setf (ansi-stream-out stream) #'closed-flame)
(setf (ansi-stream-bout stream) #'closed-flame)
(setf (ansi-stream-sout stream) #'closed-flame)
(setf (ansi-stream-misc stream) #'closed-flame))
\f
;;;; file position and file length
+(defun external-format-char-size (external-format)
+ (let ((ef-entry (find-external-format external-format)))
+ (if (variable-width-external-format-p ef-entry)
+ (bytes-for-char-fun ef-entry)
+ (funcall (bytes-for-char-fun ef-entry) #\x))))
;;; Call the MISC method with the :FILE-POSITION operation.
#!-sb-fluid (declaim (inline ansi-stream-file-position))
(- +ansi-stream-in-buffer-length+
(ansi-stream-in-index stream)))
#!+sb-unicode
- (let* ((external-format (stream-external-format stream))
- (ef-entry (find-external-format external-format))
- (variable-width-p (variable-width-external-format-p ef-entry))
- (char-len (bytes-for-char-fun ef-entry)))
+ (let ((char-size (if (fd-stream-p stream)
+ (fd-stream-char-size stream)
+ (external-format-char-size (stream-external-format stream)))))
(- res
- (if variable-width-p
- (loop with buffer = (ansi-stream-cin-buffer stream)
- with start = (ansi-stream-in-index stream)
- for i from start below +ansi-stream-in-buffer-length+
- sum (funcall char-len (aref buffer i)))
- (* (funcall char-len #\x) ; arbitrary argument
- (- +ansi-stream-in-buffer-length+
- (ansi-stream-in-index stream)))))))))))
+ (etypecase char-size
+ (function
+ (loop with buffer = (ansi-stream-cin-buffer stream)
+ with start = (ansi-stream-in-index stream)
+ for i from start below +ansi-stream-in-buffer-length+
+ sum (funcall char-size (aref buffer i))))
+ (fixnum
+ (* char-size
+ (- +ansi-stream-in-buffer-length+
+ (ansi-stream-in-index stream))))))))))))
(defun file-position (stream &optional position)
(if (ansi-stream-p stream)
:start2 %frc-index% :end2 pos)
(setf %frc-index% (1+ pos)))
(done-with-fast-read-char)
- (return-from ansi-stream-read-line-from-frc-buffer res)))
+ (return-from ansi-stream-read-line-from-frc-buffer (values res (null pos)))))
(add-chunk ()
(let* ((end (length %frc-buffer%))
(len (- end %frc-index%))
(incf chunks-total-length len)
(when (refill-buffer)
(make-and-return-result-string nil)))))
- (declare (inline make-and-return-result-string))
+ (declare (inline make-and-return-result-string
+ refill-buffer))
(when (and (= %frc-index% +ansi-stream-in-buffer-length+)
(refill-buffer))
;; EOF had been reached before we read anything
;; must be Gray streams FUNDAMENTAL-STREAM
(stream-fresh-line stream))))
-(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) end)
- (declare (type string string))
- ;; 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]),
- ;; (LENGTH STRING) is the required upper bound. A foolish
- ;; consistency is the hobgoblin of lesser languages..
- (%write-string string stream start (%check-vector-sequence-bounds
- string start end))
- string)
-
#!-sb-fluid (declaim (inline ansi-stream-write-string))
(defun ansi-stream-write-string (string stream start end)
- (declare (type string string))
- (declare (type ansi-stream stream))
- (declare (type index start end))
(with-array-data ((data string) (offset-start start)
(offset-end end)
:check-fill-pointer t)
(funcall (ansi-stream-sout stream)
- stream data offset-start offset-end))
- string)
+ stream data offset-start offset-end)))
(defun %write-string (string stream start end)
+ (let ((stream (out-synonym-of stream)))
+ (if (ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ ;; must be Gray streams FUNDAMENTAL-STREAM
+ (stream-write-string stream string start end)))
+ string)
+
+(defun write-string (string &optional (stream *standard-output*)
+ &key (start 0) end)
(declare (type string string))
(declare (type stream-designator stream))
- (declare (type index start end))
- (let ((stream (out-synonym-of stream)))
- (if(ansi-stream-p stream)
- (ansi-stream-write-string string stream start end)
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (stream-write-string stream string start end))))
+ (%write-string string stream start end))
;;; A wrapper function for all those (MACROLET OUT-FUN) definitions,
-;;; which cannot deal with keyword arguments.
+;;; which cannot deal with keyword arguments. %WRITE-STRING cannot
+;;; replace this, as this needs to deal with simple-strings as well.
(declaim (inline write-string-no-key))
(defun write-string-no-key (string stream start end)
(write-string string stream :start start :end 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 ((defaulted-stream (out-synonym-of stream)))
- (%write-string string defaulted-stream start (%check-vector-sequence-bounds
- string start end))
- (write-char #\newline defaulted-stream))
+ (declare (type stream-designator stream))
+ (let ((stream (out-synonym-of stream)))
+ (cond ((ansi-stream-p stream)
+ (ansi-stream-write-string string stream start end)
+ (funcall (ansi-stream-out stream) stream #\newline))
+ (t
+ (stream-write-string stream string start end)
+ (stream-write-char stream #\newline))))
string)
(defun charpos (&optional (stream *standard-output*))
(flet ((replace-all (fun)
(let ((start 0))
(declare (index start))
- (dolist (buffer (nreverse prev))
+ (setf prev (nreverse prev))
+ (dolist (buffer prev)
(funcall fun buffer start)
(incf start (length buffer)))
(funcall fun this start)
(incf start (length this))
(dolist (buffer next)
(funcall fun buffer start)
- (incf start (length buffer))))))
+ (incf start (length buffer)))
+ ;; Hack: erase the pointers to strings, to make it less
+ ;; likely that the conservative GC will accidentally
+ ;; retain the buffers.
+ (fill prev nil)
+ (fill next nil))))
(macrolet ((frob (type)
`(replace-all (lambda (buffer from)
(declare (type ,type result)
(:element-type (array-element-type
(fill-pointer-output-stream-string stream)))))
\f
-;;;; indenting streams
-
-(defstruct (indenting-stream (:include ansi-stream
- (out #'indenting-out)
- (sout #'indenting-sout)
- (misc #'indenting-misc))
- (:constructor make-indenting-stream (stream))
- (:copier nil))
- ;; the stream we're based on
- stream
- ;; how much we indent on each line
- (indentation 0))
-
-#!+sb-doc
-(setf (fdocumentation 'make-indenting-stream 'function)
- "Return an output stream which indents its output by some amount.")
-
-;;; INDENTING-INDENT writes the correct number of spaces needed to indent
-;;; output on the given STREAM based on the specified SUB-STREAM.
-(defmacro indenting-indent (stream sub-stream)
- ;; KLUDGE: bare magic number 60
- `(do ((i 0 (+ i 60))
- (indentation (indenting-stream-indentation ,stream)))
- ((>= i indentation))
- (%write-string
- #.(make-string 60 :initial-element #\Space)
- ,sub-stream
- 0
- (min 60 (- indentation i)))))
-
-;;; INDENTING-OUT writes a character to an indenting stream.
-(defun indenting-out (stream char)
- (let ((sub-stream (indenting-stream-stream stream)))
- (write-char char sub-stream)
- (if (char= char #\newline)
- (indenting-indent stream sub-stream))))
-
-;;; INDENTING-SOUT writes a string to an indenting stream.
-(defun indenting-sout (stream string start end)
- (declare (simple-string string) (fixnum start end))
- (do ((i start)
- (sub-stream (indenting-stream-stream stream)))
- ((= i end))
- (let ((newline (position #\newline string :start i :end end)))
- (cond (newline
- (%write-string string sub-stream i (1+ newline))
- (indenting-indent stream sub-stream)
- (setq i (+ newline 1)))
- (t
- (%write-string string sub-stream i end)
- (setq i end))))))
-
-;;; INDENTING-MISC just treats just the :LINE-LENGTH message
-;;; differently. INDENTING-CHARPOS says the charpos is the charpos of
-;;; the base stream minus the stream's indentation.
-(defun indenting-misc (stream operation &optional arg1 arg2)
- (let ((sub-stream (indenting-stream-stream stream)))
- (if (ansi-stream-p sub-stream)
- (let ((method (ansi-stream-misc sub-stream)))
- (case operation
- (:line-length
- (let ((line-length (funcall method sub-stream operation)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (funcall method sub-stream operation)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (funcall method sub-stream operation arg1 arg2))))
- ;; must be Gray streams FUNDAMENTAL-STREAM
- (case operation
- (:line-length
- (let ((line-length (stream-line-length sub-stream)))
- (if line-length
- (- line-length (indenting-stream-indentation stream)))))
- (:charpos
- (let ((charpos (stream-line-column sub-stream)))
- (if charpos
- (- charpos (indenting-stream-indentation stream)))))
- (t
- (stream-misc-dispatch sub-stream operation arg1 arg2))))))
-
-(declaim (maybe-inline read-char unread-char read-byte listen))
-\f
;;;; case frobbing streams, used by FORMAT ~(...~)
(defstruct (case-frob-stream
(done-with-fast-read-char)
(return-from ansi-stream-read-string-from-frc-buffer
read)))))
+ (declare (inline refill-buffer))
(when (and (= %frc-index% +ansi-stream-in-buffer-length+)
(refill-buffer))
;; EOF had been reached before we read anything
projects / sbcl.git / blobdiff