Newer
Older
(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)
"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))
(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))))
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
(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 #'ill-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))
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
(: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-value)))))
(generalized-peeking-mechanism
arg1 eof-value char
(infn)
(unread-char char in)
(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)))))))
(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)
"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
(if arg1
(setf (string-input-stream-current stream) 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)))
(defun make-string-input-stream (string &optional
(start 0) (end (length string)))
"Returns an input stream which will supply the characters of String between
Start and End in order."
(declare (type string string)
(type index start)
(internal-make-string-input-stream (coerce string 'simple-string)
start end))
;;;; 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)))
(defun get-output-stream-string (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))
(defun dump-output-stream-string (in-stream out-stream)
"Dumps the characters buffer up in the In-Stream to the Out-Stream as
Get-Output-Stream-String would return them."
(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 start new-workspace 0 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 dst-start new-workspace 0 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 start
workspace offset-current 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 (the fixnum found))
current)))))
(: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)
"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
(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)
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
(if (lisp-stream-p sub-stream)
(let ((method (lisp-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))))
;; 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))
;;;; Case frobbing streams, used by format ~(...~).
(defstruct (case-frob-stream
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
(:misc #'case-frob-misc))
(:constructor %make-case-frob-stream (target out sout)))
(target (required-argument) :type stream))
(defun make-case-frob-stream (target kind)
"Returns a stream that sends all output to the stream TARGET, but modifies
the case of letters, depending on KIND, which should be one of:
:upcase - convert to upper case.
:downcase - convert to lower case.
:capitalize - convert the first letter of words to upper case and the
rest of the word to lower case.
:capitalize-first - convert the first letter of the first word to upper
case and everything else to lower case."
(declare (type stream target)
(type (member :upcase :downcase :capitalize :capitalize-first)
kind)
(values stream))
(if (case-frob-stream-p target)
;; If we are going to be writing to a stream that already does case
;; frobbing, why bother frobbing the case just so it can frob it
;; again?
target
(multiple-value-bind
(out sout)
(ecase kind
(:upcase
(values #'case-frob-upcase-out
#'case-frob-upcase-sout))
(:downcase
(values #'case-frob-downcase-out
#'case-frob-downcase-sout))
(:capitalize
(values #'case-frob-capitalize-out
#'case-frob-capitalize-sout))
(:capitalize-first
(values #'case-frob-capitalize-first-out
#'case-frob-capitalize-first-sout)))
(%make-case-frob-stream target out sout))))
(defun case-frob-misc (stream op &optional arg1 arg2)
(declare (type case-frob-stream stream))
(case op
(:close)
(t
(let ((target (case-frob-stream-target stream)))
(if (lisp-stream-p target)
(funcall (lisp-stream-misc target) target op arg1 arg2)
(stream-misc-dispatch target op arg1 arg2))))))
(defun case-frob-upcase-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream))
(char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-upcase-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(len (length str))
(end (or end len))
(string (if (and (zerop start) (= len end))
(string-upcase str)
(nstring-upcase (subseq str start end))))
(string-len (- end start)))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-downcase-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream))
(char (char-downcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(defun case-frob-downcase-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(len (length str))
(end (or end len))
(string (if (and (zerop start) (= len end))
(string-downcase str)
(nstring-downcase (subseq str start end))))
(string-len (- end start)))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target string 0 string-len)
(stream-write-string target string 0 string-len))))
(defun case-frob-capitalize-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
(t
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))))
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
(defun case-frob-capitalize-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str))
(inside-word nil))
(dotimes (i len)
(let ((char (schar str i)))
(cond ((not (alphanumericp char))
(setf inside-word nil))
(inside-word
(setf (schar str i) (char-downcase char)))
(t
(setf inside-word t)
(setf (schar str i) (char-upcase char))))))
(when inside-word
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-aux-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-aux-sout))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-aux-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-downcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-sout)))))
(defun case-frob-capitalize-aux-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str))
(inside-word t))
(dotimes (i len)
(let ((char (schar str i)))
(cond ((not (alphanumericp char))
(setf inside-word nil))
(inside-word
(setf (schar str i) (char-downcase char)))
(t
(setf inside-word t)
(setf (schar str i) (char-upcase char))))))
(unless inside-word
(setf (case-frob-stream-out stream)
#'case-frob-capitalize-out)
(setf (case-frob-stream-sout stream)
#'case-frob-capitalize-sout))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
(defun case-frob-capitalize-first-out (stream char)
(declare (type case-frob-stream stream)
(let ((target (case-frob-stream-target stream)))
(cond ((alphanumericp char)
(let ((char (char-upcase char)))
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char)))
(setf (case-frob-stream-out stream)
#'case-frob-downcase-out)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout))
(t
(if (lisp-stream-p target)
(funcall (lisp-stream-out target) target char)
(stream-write-char target char))))))
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
(defun case-frob-capitalize-first-sout (stream str start end)
(declare (type case-frob-stream stream)
(type simple-base-string str)
(type index start)
(type (or index null) end))
(let* ((target (case-frob-stream-target stream))
(str (subseq str start end))
(len (length str)))
(dotimes (i len)
(let ((char (schar str i)))
(when (alphanumericp char)
(setf (schar str i) (char-upcase char))
(do ((i (1+ i) (1+ i)))
((= i len))
(setf (schar str i) (char-downcase (schar str i))))
(setf (case-frob-stream-out stream)
#'case-frob-downcase-out)
(setf (case-frob-stream-sout stream)
#'case-frob-downcase-sout)
(return))))
(if (lisp-stream-p target)
(funcall (lisp-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
;;;; Public interface from "EXTENSIONS" package.
(defstruct (stream-command (:print-function print-stream-command)
(:constructor make-stream-command
(name &optional args)))
(name nil :type symbol)
(args nil :type list))
(defun print-stream-command (obj str n)
(declare (ignore n))
(format str "#<Stream-Cmd ~S>" (stream-command-name obj)))
;;; GET-STREAM-COMMAND -- Public.
;;;
;;; We can't simply call the stream's misc method because nil is an
;;; ambiguous return value: does it mean text arrived, or does it mean the
;;; stream's misc method had no :get-command implementation. We can't return
;;; nil until there is text input. We don't need to loop because any stream
;;; implementing :get-command would wait until it had some input. If the
;;; LISTEN fails, then we have some random stream we must wait on.
;;;
(defun get-stream-command (stream)
"This takes a stream and waits for text or a command to appear on it. If
text appears before a command, this returns nil, and otherwise it returns
a command."
(let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))