Newer
Older
(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)
"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))))
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
(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))
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
(: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)))))))
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
(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)
"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)
;;;; 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))))
(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)
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
(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
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
(: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))))))
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
(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))
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
(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))))))
(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)