Newer
Older
(defun write-string* (string &optional (stream *standard-output*)
(start 0) (end (length (the vector string))))
(declare (type streamlike stream) (fixnum start end))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(if (array-header-p string)
(with-array-data ((data string) (offset-start start)
(offset-end end))
(stream::%write-string stream data offset-start offset-end))
(stream::%write-string stream string start end))
(if (array-header-p string)
(with-array-data ((data string) (offset-start start)
(offset-end end))
(funcall (lisp-stream-sout stream)
stream data offset-start offset-end))
(funcall (lisp-stream-sout stream) stream string start end))
;; fundamental-stream
(stream-write-string stream string start end)))
string)
(defun write-line (string &optional (stream *standard-output*)
&key (start 0) (end (length string)))
"Outputs the String to the given Stream, followed by a newline character."
(write-line* string stream start (or end (length string))))
(defun write-line* (string &optional (stream *standard-output*)
(start 0) (end (length string)))
(declare (type streamlike stream) (fixnum start end))
(let ((stream (out-synonym-of stream)))
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
(stream-dispatch stream
;; simple-stream
(progn
(if (array-header-p string)
(with-array-data ((data string) (offset-start start)
(offset-end end))
(stream::%write-string stream data offset-start offset-end))
(stream::%write-string stream string start end))
(stream::%write-char stream #\Newline))
;; lisp-stream
(progn
(if (array-header-p string)
(with-array-data ((data string) (offset-start start)
(offset-end end))
(funcall (lisp-stream-sout stream) stream data offset-start
offset-end))
(funcall (lisp-stream-sout stream) stream string start end))
(funcall (lisp-stream-out stream) stream #\newline))
;; fundamental-stream
(progn
(stream-write-string stream string start end)
(stream-write-char stream #\Newline)))
"Returns the number of characters on the current line of output of the given
(declare (type streamlike stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%charpos stream)
;; lisp-stream
(funcall (lisp-stream-misc stream) stream :charpos)
;; fundamental-stream
(stream-line-column stream))))
"Returns the number of characters that will fit on a line of output on the
(declare (type streamlike stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%line-length stream)
;; lisp-stream
(funcall (lisp-stream-misc stream) stream :line-length)
;; fundamental-stream
(stream-line-length stream))))
(defun finish-output (&optional (stream *standard-output*))
"Attempts to ensure that all output sent to the Stream has reached its
(declare (type streamlike stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%finish-output stream)
;; lisp-stream
(funcall (lisp-stream-misc stream) stream :finish-output)
;; fundamental-stream
(stream-finish-output stream)))
nil)
(defun force-output (&optional (stream *standard-output*))
"Attempts to force any buffered output to be sent."
(declare (type streamlike stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%force-output stream)
;; lisp-stream-misc
(funcall (lisp-stream-misc stream) stream :force-output)
;; fundamental-stream
(stream-force-output stream)))
nil)
(defun clear-output (&optional (stream *standard-output*))
"Clears the given output Stream."
(declare (type streamlike stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%clear-output stream)
;; lisp-stream
(funcall (lisp-stream-misc stream) stream :clear-output)
;; fundamental-stream
(stream-clear-output stream)))
"Outputs the Integer to the binary Stream."
(declare (type stream stream))
(let ((stream (out-synonym-of stream)))
(stream-dispatch stream
;; simple-stream
(stream::%write-byte stream integer)
;; lisp-stream
(funcall (lisp-stream-bout stream) stream integer)
;; fundamental-stream
(stream-write-byte stream integer)))
;;; Stream-misc-dispatch
;;;
;;; Called from lisp-stream routines that encapsulate CLOS streams to
;;; handle the misc routines and dispatch to the appropriate Gray
;;; stream functions.
;;;
(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
(declare (type fundamental-stream stream)
(ignore arg2))
(case operation
(:listen
;; Return true if input available, :eof for end-of-file, otherwise Nil.
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
(let ((char (stream-read-char-no-hang stream)))
(when (characterp char)
(stream-unread-char stream char))
char))
(:unread
(stream-unread-char stream arg1))
(:close
(close stream))
(:clear-input
(stream-clear-input stream))
(:force-output
(stream-force-output stream))
(:finish-output
(stream-finish-output stream))
(:element-type
(stream-element-type stream))
(:interactive-p
(interactive-stream-p stream))
(:line-length
(stream-line-length stream))
(:charpos
(stream-line-column stream))
(:file-length
(file-length stream))
(:file-position
(file-position stream arg1))))
(out #'broadcast-out)
(bout #'broadcast-bout)
(sout #'broadcast-sout)
(misc #'broadcast-misc))
(:print-function %print-broadcast-stream)
(:constructor %make-broadcast-stream (&rest streams)))
(streams () :type list :read-only t))
(defun make-broadcast-stream (&rest streams)
"Returns an output stream which sends its output to all of the given
streams."
(dolist (s streams)
(unless (output-stream-p s)
(ill-out-any s)))
(apply #'%make-broadcast-stream streams))
(defun %print-broadcast-stream (s stream d)
(declare (ignore s d))
(write-string "#<Broadcast Stream>" stream))
(macrolet ((out-fun (fun method stream-method &rest args)
`(defun ,fun (stream ,@args)
(dolist (stream (broadcast-stream-streams stream))
(stream-dispatch stream
;; simple-stream
(,stream-method stream ,@args) ; use gray-compat for now
;; lisp-stream
(funcall (,method stream) stream ,@args)
;; fundamental-stream
(,stream-method stream ,@args))))))
(out-fun broadcast-out lisp-stream-out stream-write-char char)
(out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
(out-fun broadcast-sout lisp-stream-sout stream-write-string
string start end))
(defun broadcast-misc (stream operation &optional arg1 arg2)
(let ((streams (broadcast-stream-streams stream)))
(case operation
(:charpos
(let ((charpos (charpos stream)))
(if charpos (return charpos)))))
(:line-length
(let ((min nil))
(dolist (stream streams min)
(let ((res (line-length stream)))
;; CLHS: The functions file-length, file-position, file-string-length, and
;; stream-external-format return the value from the last component
;; stream; if there are no component streams, file-length and
;; file-position return 0, file-string-length returns 1, and
;; stream-external-format returns :default.
(:file-length
(if (null streams) 0
(pushnew (stream-element-type stream) res :test #'equal)))
;; ANSI-specified version (under System Class BROADCAST-STREAM)
(let ((res t))
(do ((streams streams (cdr streams)))
((null streams) res)
(when (null (cdr streams))
(setq res (stream-element-type (car streams)))))))
(setq res
(if (lisp-stream-p stream)
(funcall (lisp-stream-misc stream) stream operation
arg1 arg2)
(stream-misc-dispatch stream operation arg1 arg2)))))))))
(in #'synonym-in)
(bin #'synonym-bin)
(n-bin #'synonym-n-bin)
(out #'synonym-out)
(bout #'synonym-bout)
(sout #'synonym-sout)
(misc #'synonym-misc))
(:print-function %print-synonym-stream)
(:constructor make-synonym-stream (symbol)))
;; This is the symbol, the value of which is the stream we are synonym to.
(symbol nil :type symbol :read-only t))
(defun %print-synonym-stream (s stream d)
(declare (ignore d))
(format stream "#<Synonym Stream to ~S>" (synonym-stream-symbol s)))
(setf (documentation 'make-synonym-stream 'function)
_N"Returns a stream which performs its operations on the stream which is the
value of the dynamic variable named by Symbol.")
;;; The output simple output methods just call the corresponding method
;;; in the synonymed stream.
;;;
(macrolet ((out-fun (name slot stream-method &rest args)
(declare (optimize (safety 1)))
(if (lisp-stream-p syn)
(funcall (,slot syn) syn ,@args)
(,stream-method syn ,@args))))))
(out-fun synonym-out lisp-stream-out stream-write-char ch)
(out-fun synonym-bout lisp-stream-bout stream-write-byte n)
(out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
;;; Bind synonym stream to this so that SPIO can turn on the right frob in
;;; the icon when we are in a terminal input wait.
;;;
(defvar *previous-stream* nil)
;;; For the input methods, we just call the corresponding function on the
;;; synonymed stream. These functions deal with getting input out of
;;; the In-Buffer if there is any.
;;;
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(declare (optimize (safety 1)))
(let ((*previous-stream* stream))
(,fun (symbol-value (synonym-stream-symbol stream)) ,@args)))))
(in-fun synonym-in read-char eof-errorp eof-value)
(in-fun synonym-bin read-byte eof-errorp eof-value)
(in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-errorp))
;;; Synonym-Misc -- Internal
;;;
;;; We have to special-case the operations which could look at stuff in
;;; the in-buffer.
;;;
(defun synonym-misc (stream operation &optional arg1 arg2)
(declare (optimize (safety 1)))
(let ((syn (symbol-value (synonym-stream-symbol stream)))
(*previous-stream* stream))
(if (lisp-stream-p syn)
(case operation
(:listen (or (/= (the fixnum (lisp-stream-in-index syn))
in-buffer-length)
(funcall (lisp-stream-misc syn) syn :listen)))
(:clear-input (clear-input syn))
(:unread (unread-char arg1 syn))
(t
(funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
(stream-misc-dispatch syn operation arg1 arg2))))
(in #'two-way-in)
(bin #'two-way-bin)
(n-bin #'two-way-n-bin)
(out #'two-way-out)
(bout #'two-way-bout)
(sout #'two-way-sout)
(misc #'two-way-misc))
(:print-function %print-two-way-stream)
(:constructor %make-two-way-stream (input-stream output-stream)))
(input-stream (required-argument) :type stream :read-only t)
(output-stream (required-argument) :type stream :read-only t))
(defun %print-two-way-stream (s stream d)
(declare (ignore d))
(format stream "#<Two-Way Stream, Input = ~S, Output = ~S>"
(two-way-stream-input-stream s)
(two-way-stream-output-stream s)))
(defun make-two-way-stream (input-stream output-stream)
"Returns a bidirectional stream which gets its input from Input-Stream and
sends its output to Output-Stream."
(unless (input-stream-p input-stream)
(ill-in-any input-stream))
(unless (output-stream-p output-stream)
(ill-out-any output-stream))
(%make-two-way-stream input-stream output-stream))
(macrolet ((out-fun (name slot stream-method &rest args)
`(defun ,name (stream ,@args)
(let ((syn (two-way-stream-output-stream stream)))
(if (lisp-stream-p syn)
(funcall (,slot syn) syn ,@args)
(,stream-method syn ,@args))))))
(out-fun two-way-out lisp-stream-out stream-write-char ch)
(out-fun two-way-bout lisp-stream-bout stream-write-byte n)
(out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
(macrolet ((in-fun (name fun &rest args)
`(defun ,name (stream ,@args)
(force-output (two-way-stream-output-stream stream))
(,fun (two-way-stream-input-stream stream) ,@args))))
(in-fun two-way-in read-char eof-errorp eof-value)
(in-fun two-way-bin read-byte eof-errorp eof-value)
(in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-errorp))
(defun two-way-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
(out (two-way-stream-output-stream stream))
(in-lisp-stream-p (lisp-stream-p in))
(out-lisp-stream-p (lisp-stream-p out)))
(:listen
(if in-lisp-stream-p
(or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
(funcall (lisp-stream-misc in) in :listen))
(stream-listen in)))
(if out-lisp-stream-p
(funcall (lisp-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))
(:clear-input (clear-input in))
(:unread (unread-char arg1 in))
(let ((in-type (stream-element-type in))
(out-type (stream-element-type out)))
(if (equal in-type out-type)
in-type `(and ,in-type ,out-type))))
(:file-length
(error 'type-error :datum stream :expected-type 'file-stream))
(:charpos
(charpos out))
(:line-length
(line-length out))
(or (if in-lisp-stream-p
(funcall (lisp-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
(if out-lisp-stream-p
(funcall (lisp-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
;;;; Concatenated Streams:
(defstruct (concatenated-stream
(misc #'concatenated-misc))
(:print-function %print-concatenated-stream)
(:constructor %make-concatenated-stream (&rest streams)))
;; This is a list of all the streams. The car of this is the stream
;; we are reading from now.
(streams nil :type list))
(defun %print-concatenated-stream (s stream d)
(declare (ignore d))
(format stream "#<Concatenated Stream, Streams = ~S>"
(concatenated-stream-streams s)))
(defun make-concatenated-stream (&rest streams)
"Returns a stream which takes its input from each of the Streams in turn,
going on to the next at EOF."
(dolist (s streams)
(unless (input-stream-p s)
(ill-in-any s)))
(apply #'%make-concatenated-stream streams))
(macrolet ((in-fun (name fun)
`(defun ,name (stream eof-errorp eof-value)
(do ((current (concatenated-stream-streams stream)
(cdr current)))
((null current)
(eof-or-lose stream eof-errorp eof-value))
(let* ((stream (car current))
(result (,fun stream nil nil)))
(when result (return result)))
(setf (concatenated-stream-streams stream) (cdr current))))))
(in-fun concatenated-in read-char)
(in-fun concatenated-bin read-byte))
(defun concatenated-n-bin (stream buffer start numbytes eof-errorp)
(do ((current (concatenated-stream-streams stream) (cdr current))
(current-start start)
(remaining-bytes numbytes))
((null current)
(if eof-errorp
(error 'end-of-file :stream stream)
(- numbytes remaining-bytes)))
(let* ((stream (car current))
(bytes-read (read-n-bytes stream buffer current-start
remaining-bytes nil)))
(incf current-start bytes-read)
(decf remaining-bytes bytes-read)
(when (zerop remaining-bytes) (return numbytes)))
(setf (concatenated-stream-streams stream) (cdr current))))
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
(let ((current (first (concatenated-stream-streams stream))))
(case operation
(:listen
(if current
(loop
(let ((stuff (if (lisp-stream-p current)
(funcall (lisp-stream-misc current) current
:listen)
(stream-misc-dispatch current :listen))))
(cond ((eq stuff :eof)
;; Advance current, and try again.
(pop (concatenated-stream-streams stream))
(setf current (first (concatenated-stream-streams stream)))
(unless current (return :eof)))
(stuff
;; Stuff's available.
(return t))
(t
;; Nothing available yet.
(return nil)))))
:eof))
(:close
(set-closed-flame stream))
(:clear-input
(when current (clear-input current)))
(:unread
(when current (unread-char arg1 current)))
(:file-length
(error 'type-error :datum stream :expected-type 'file-stream))
(t
(if (lisp-stream-p current)
(funcall (lisp-stream-misc current) current operation arg1 arg2)
(stream-misc-dispatch current operation arg1 arg2))))))
;;;; Echo Streams:
(defstruct (echo-stream
(:include two-way-stream
(in #'echo-in)
(bin #'echo-bin)
(misc #'echo-misc)
(n-bin #'echo-n-bin))
(:constructor %make-echo-stream (input-stream output-stream)))
(defun make-echo-stream (input-stream output-stream)
"Returns an echo stream that takes input from Input-stream and sends
output to Output-stream"
(unless (input-stream-p input-stream)
(ill-in-any input-stream))
(unless (output-stream-p output-stream)
(ill-out-any output-stream))
(%make-echo-stream input-stream output-stream))
(macrolet ((in-fun (name fun out-slot stream-method)
`(defun ,name (stream eof-errorp eof-value)
(or (pop (echo-stream-unread-stuff stream))
(let* ((in (echo-stream-input-stream stream))
(out (echo-stream-output-stream stream))
(result (,fun in nil :eof)))
(cond ((eq result :eof)
(eof-or-lose stream eof-errorp eof-value))
(t
(if (lisp-stream-p out)
(funcall (,out-slot out) out result)
(,stream-method out result))
result)))))))
(in-fun echo-in read-char lisp-stream-out stream-write-char)
(in-fun echo-bin read-byte lisp-stream-bout stream-write-byte))
(defun echo-misc (stream operation &optional arg1 arg2)
(let* ((in (two-way-stream-input-stream stream))
(out (two-way-stream-output-stream stream)))
(:listen
(or (not (null (echo-stream-unread-stuff stream)))
(if (lisp-stream-p in)
(or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
(funcall (lisp-stream-misc in) in :listen))
(stream-misc-dispatch in :listen))))
(:unread (push arg1 (echo-stream-unread-stuff stream)))
(let ((in-type (stream-element-type in))
(out-type (stream-element-type out)))
(if (equal in-type out-type)
in-type `(and ,in-type ,out-type))))
(:close
(set-closed-flame stream))
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
(:peek-char
;; For the special case of peeking into an echo-stream
;; arg1 is peek-type, arg2 is (eof-errorp eof-value)
;; returns peeked-char, eof-value, or errors end-of-file
(let ((unread-char-p nil))
(destructuring-bind (eof-errorp eof-value)
arg2
(flet ((outfn (c)
(unless unread-char-p
(if (lisp-stream-p out)
(funcall (lisp-stream-out out) out c)
;; gray-stream
(stream-write-char out c))))
(infn ()
;; Obtain input from unread buffer or input stream,
;; and set the flag appropriately.
(cond ((not (null (echo-stream-unread-stuff stream)))
(setf unread-char-p t)
(pop (echo-stream-unread-stuff stream)))
(t
(setf unread-char-p nil)
(read-char in eof-errorp :eof)))))
(generalized-peeking-mechanism
arg1 eof-value char
(infn)
:skipped-char-form (outfn char))))))
(:file-length
(error 'type-error :datum stream :expected-type 'file-stream))
(or (if (lisp-stream-p in)
(funcall (lisp-stream-misc in) in operation arg1 arg2)
(stream-misc-dispatch in operation arg1 arg2))
(if (lisp-stream-p out)
(funcall (lisp-stream-misc out) out operation arg1 arg2)
(stream-misc-dispatch out operation arg1 arg2)))))))
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
(defun echo-n-bin (stream buffer start numbytes eof-error-p)
(let ((new-start start)
(read 0))
(loop
(let ((thing (pop (echo-stream-unread-stuff stream))))
(cond
(thing
(setf (aref buffer new-start) thing)
(incf new-start)
(incf read)
(when (= read numbytes)
(return-from echo-n-bin numbytes)))
(t (return nil)))))
(let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
new-start (- numbytes read) nil)))
(cond
((not eof-error-p)
(write-sequence buffer (echo-stream-output-stream stream)
:start new-start :end (+ new-start bytes-read))
(+ bytes-read read))
((> numbytes (+ read bytes-read))
(write-sequence buffer (echo-stream-output-stream stream)
:start new-start :end (+ new-start bytes-read))
(error 'end-of-file :stream stream))
(t
(write-sequence buffer (echo-stream-output-stream stream)
:start new-start :end (+ new-start bytes-read))
numbytes)))))
(defun %print-echo-stream (s stream d)
(declare (ignore d))
(format stream "#<Echo Stream, Input = ~S, Output = ~S>"
(two-way-stream-input-stream s)
(two-way-stream-output-stream s)))
(setf (documentation 'make-echo-stream 'function)
_N"Returns a bidirectional stream which gets its input from Input-Stream and
sends its output to Output-Stream. In addition, all input is echoed to
the output stream")
;;;; Superclass of all string streams
(defstruct (string-stream
(:include lisp-stream)
(:constructor nil)
(:copier nil)))
;;;; String Input Streams:
(defstruct (string-input-stream
(in #'string-inch)
(bin #'string-binch)
(n-bin #'string-stream-read-n-bytes)
(misc #'string-in-misc))
(:print-function %print-string-input-stream)
;(:constructor nil)
(:constructor internal-make-string-input-stream
(string current end)))
(current nil :type index)
(end nil :type index))
(defun %print-string-input-stream (s stream d)
(declare (ignore s d))
(write-string "#<String-Input Stream>" stream))
(defun string-inch (stream eof-errorp eof-value)
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
(declare (simple-string string) (fixnum index))
(cond ((= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-errorp eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
(aref string index)))))
(defun string-binch (stream eof-errorp eof-value)
(let ((string (string-input-stream-string stream))
(index (string-input-stream-current stream)))
(declare (simple-string string)
(type index index))
(cond ((= index (the index (string-input-stream-end stream)))
(eof-or-lose stream eof-errorp eof-value))
(t
(setf (string-input-stream-current stream) (1+ index))
(char-code (aref string index))))))
(defun string-stream-read-n-bytes (stream buffer start requested eof-errorp)
(declare (type string-input-stream stream)
(type index start requested))
(let* ((string (string-input-stream-string stream))
(index (string-input-stream-current stream))
(available (- (string-input-stream-end stream) index))
(copy (min available requested)))
(declare (simple-string string)
(type index index available copy))
(when (plusp copy)
(setf (string-input-stream-current stream)
(truly-the index (+ index copy)))
(system:without-gcing
(system-area-copy (vector-sap string)
(* index vm:byte-bits)
(if (typep buffer 'system-area-pointer)
buffer
(vector-sap buffer))
(* start vm:byte-bits)
(* copy vm:byte-bits))))
(if (and (> requested copy) eof-errorp)
(error 'end-of-file :stream stream)
copy)))
(:file-position
(setf (string-input-stream-current stream)
(case arg1
(:start 0)
(:end (length (string-input-stream-string stream)))
(t arg1)))
(string-input-stream-current stream)))
(error 'type-error :datum stream :expected-type 'file-stream))
(:listen (or (/= (the fixnum (string-input-stream-current stream))
(the fixnum (string-input-stream-end stream)))
:eof))
(:element-type 'base-char)
(:close
(set-closed-flame stream))))
(defun make-string-input-stream (string &optional
(start 0) (end (length string)))
"Returns an input stream which will supply the characters of String between
(declare (type string string)
(type index start)
(internal-make-string-input-stream (coerce string 'simple-string)
;;;; String Output Streams:
(defstruct (string-output-stream
(out #'string-ouch)
(sout #'string-sout)
(misc #'string-out-misc))
(:print-function %print-string-output-stream)
(:constructor %make-string-output-stream ()))
;; The string we throw stuff in.
(string (make-string 40) :type simple-string)
;; Index of the next location to use.
(index 0 :type fixnum))
(defun %print-string-output-stream (s stream d)
(declare (ignore s d))
(write-string "#<String-Output Stream>" stream))
(defun make-string-output-stream (&key (element-type 'character))
"Returns an Output stream which will accumulate all output given to it for
the benefit of the function Get-Output-Stream-String."
(declare (ignore element-type))
(%make-string-output-stream))
(defun string-ouch (stream character)
(let ((current (string-output-stream-index stream))
(workspace (string-output-stream-string stream)))
(declare (simple-string workspace) (fixnum current))
(if (= current (the fixnum (length workspace)))
(let ((new-workspace (make-string (* current 2))))
(replace new-workspace workspace)
(setf (aref new-workspace current) character)
(setf (string-output-stream-string stream) new-workspace))
(setf (aref workspace current) character))
(setf (string-output-stream-index stream) (1+ current))))
(defun string-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(let* ((current (string-output-stream-index stream))
(length (- end start))
(dst-end (+ length current))
(workspace (string-output-stream-string stream)))
(declare (simple-string workspace)
(fixnum current length dst-end))
(if (> dst-end (the fixnum (length workspace)))
(let ((new-workspace (make-string (+ (* current 2) length))))
(replace new-workspace workspace :end2 current)
(replace new-workspace string
:start1 current :end1 dst-end
:start2 start :end2 end)
(replace workspace string
:start1 current :end1 dst-end
:start2 start :end2 end))
(setf (string-output-stream-index stream) dst-end)))
(defun string-out-misc (stream operation &optional arg1 arg2)
(:file-position
(if (null arg1)
(:file-length
(error 'type-error :datum stream :expected-type 'file-stream))
(:charpos
(do ((index (1- (the fixnum (string-output-stream-index stream)))
(1- index))
(count 0 (1+ count))
(string (string-output-stream-string stream)))
((< index 0) count)
(declare (simple-string string)
(fixnum index count))
(if (char= (schar string index) #\newline)
(return count))))
(:element-type 'base-char)
(:close
(set-closed-flame stream))))
"Returns a string of all the characters sent to a stream made by
Make-String-Output-Stream since the last call to this function."
(declare (type string-output-stream stream))
(let* ((length (string-output-stream-index stream))
(result (make-string length)))
(replace result (string-output-stream-string stream))
(setf (string-output-stream-index stream) 0)
result))
"Dumps the characters buffer up in the In-Stream to the Out-Stream as
(write-string* (string-output-stream-string in-stream) out-stream
0 (string-output-stream-index in-stream))
(setf (string-output-stream-index in-stream) 0))
;;;; Fill-pointer streams:
;;;
;;; Fill pointer string output streams are not explicitly mentioned in
;;; the CLM, but they are required for the implementation of With-Output-To-String.
(defstruct (fill-pointer-output-stream
(out #'fill-pointer-ouch)
(sout #'fill-pointer-sout)
(misc #'fill-pointer-misc))
(:print-function
(lambda (s stream d)
(declare (ignore s d))
(write-string "#<Fill-Pointer String Output Stream>" stream)))
(:constructor make-fill-pointer-output-stream (string)))
;; The string we throw stuff in.
string)
(defun fill-pointer-ouch (stream character)
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer))
(current+1 (1+ current)))
(declare (fixnum current))
(with-array-data ((workspace buffer) (start) (end))
(declare (simple-string workspace))
(let ((offset-current (+ start current)))
(declare (fixnum offset-current))
(if (= offset-current end)
(let* ((new-length (if (zerop current) 1 (* current 2)))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
(%primitive byte-blt workspace (* vm:char-bytes start)
new-workspace 0 (* vm:char-bytes current))
(setf workspace new-workspace)
(setf offset-current current)
(set-array-header buffer workspace new-length
current+1 0 new-length nil))
(setf (fill-pointer buffer) current+1))
(setf (schar workspace offset-current) character)))
current+1))
(defun fill-pointer-sout (stream string start end)
(declare (simple-string string) (fixnum start end))
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer))
(string-len (- end start))
(dst-end (+ string-len current)))
(declare (fixnum current dst-end string-len))
(with-array-data ((workspace buffer) (dst-start) (dst-length))
(declare (simple-string workspace))
(let ((offset-dst-end (+ dst-start dst-end))
(offset-current (+ dst-start current)))
(declare (fixnum offset-dst-end offset-current))
(if (> offset-dst-end dst-length)
(let* ((new-length (+ (the fixnum (* current 2)) string-len))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
(%primitive byte-blt workspace (* vm:char-bytes dst-start)
new-workspace 0 (* vm:char-bytes current))
(setf workspace new-workspace)
(setf offset-current current)
(setf offset-dst-end dst-end)
(set-array-header buffer workspace new-length
dst-end 0 new-length nil))
(setf (fill-pointer buffer) dst-end))
(%primitive byte-blt string (* vm:char-bytes start)
workspace (* vm:char-bytes offset-current)
(* vm:char-bytes offset-dst-end))))
dst-end))
(defun fill-pointer-misc (stream operation &optional arg1 arg2)
(declare (ignore arg1 arg2))
(case operation
(:charpos
(let* ((buffer (fill-pointer-output-stream-string stream))
(current (fill-pointer buffer)))
(with-array-data ((string buffer) (start) (end current))
(declare (simple-string string) (ignore start))
(let ((found (position #\newline string :test #'char=
:end end :from-end t)))
(if found
;; END points to where the next character goes, not the
;; last character. FOUND is where the newline is.
;; Subtract 1 to adjust for the difference.
(- end (the fixnum found) 1)
(:element-type 'base-char)))
(out #'indenting-out)
(sout #'indenting-sout)
(misc #'indenting-misc))
(:print-function %print-indenting-stream)
(:constructor make-indenting-stream (stream)))
;; The stream we're based on:
stream
;; How much we indent on each line:
(indentation 0))
(setf (documentation 'make-indenting-stream 'function)
_N"Returns an output stream which indents its output by some amount.")
(defun %print-indenting-stream (s stream d)
(declare (ignore s d))
(write-string "#<Indenting Stream>" stream))
;;; Indenting-Indent writes the right number of spaces needed to indent
;;; output on the given Stream based on the specified Sub-Stream.
(defmacro indenting-indent (stream sub-stream)
`(do ((i 0 (+ i 60))
(indentation (indenting-stream-indentation ,stream)))
((>= i indentation))
(write-string*
" "
,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)))
(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
(indenting-indent stream sub-stream)
(setq i (+ newline 1)))
(t