;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; This code is in the public domain.
-
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;; Sbcl port by Rudi Schlatte.
(in-package "SB-SIMPLE-STREAMS")
+;;;
+;;; **********************************************************************
+;;;
+;;; Strategy functions for base simple-stream classes
+;;;; Helper functions
-(defun sc-refill-buffer (stream blocking)
- (with-stream-class (single-channel-simple-stream stream)
- (when (any-stream-instance-flags stream :dirty)
- ;; FIXME: Implement flush-buffer failure protocol instead of
- ;; blocking here
- (sc-flush-buffer stream t))
+(defun refill-buffer (stream blocking)
+ (declare (type blocking blocking))
+ (with-stream-class (simple-stream stream)
(let* ((unread (sm last-char-read-size stream))
- (buffer (sm buffer stream)))
- (unless (zerop unread)
- (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
+ (buffer (sm buffer stream))
+ (bufptr (sm buffer-ptr stream)))
+ (unless (or (zerop unread) (zerop bufptr))
+ (buffer-copy buffer (- bufptr unread) buffer 0 unread))
(let ((bytes (device-read stream nil unread nil blocking)))
(declare (type fixnum bytes))
(setf (sm buffpos stream) unread
unread))
bytes))))
+(defun sc-set-dirty (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm mode stream)
+ (if (<= (sm buffpos stream)
+ (sm buffer-ptr stream))
+ 3 ; read-modify
+ 1 ; write
+ ))))
+
+(defun sc-set-clean (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm mode stream) 0)))
-(defun sc-flush-buffer (stream blocking)
+(defun sc-dirty-p (stream)
+ (with-stream-class (single-channel-simple-stream stream)
+ (> (sm mode stream) 0)))
+
+(defun flush-buffer (stream blocking)
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr 0)
- (bytes (sm buffpos stream)))
+ (bytes (sm buffpos stream)))
(declare (type fixnum ptr bytes))
- ;; Seek to the left before flushing buffer -- the user could
- ;; have set the file-position, and scribbled something in the
- ;; data that was read from the file.
- (when (> (sm buffer-ptr stream) 0)
+ (when (and (> (sm mode stream) 0) (> (sm buffer-ptr stream) 0))
+ ;; The data read in from the file could have been changed if
+ ;; the stream is opened in read-write mode -- write back
+ ;; everything in the buffer at the correct position just in
+ ;; case.
(setf (device-file-position stream)
(- (device-file-position stream) (sm buffer-ptr stream))))
(loop
- (when (>= ptr bytes)
- (setf (sm buffpos stream) 0
- (sm buffer-ptr stream) 0)
- (remove-stream-instance-flags stream :dirty)
- (return 0))
- (let ((bytes-written (device-write stream nil ptr bytes blocking)))
- (declare (fixnum bytes-written))
- (when (minusp bytes-written)
- (error "DEVICE-WRITE error."))
- (incf ptr bytes-written))))))
-
-(defun dc-refill-buffer (stream blocking)
- (with-stream-class (dual-channel-simple-stream stream)
- (let* ((unread (sm last-char-read-size stream))
- (buffer (sm buffer stream)))
- (unless (zerop unread)
- (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 unread))
- (let ((bytes (device-read stream nil unread nil blocking)))
- (declare (type fixnum bytes))
- (setf (sm buffpos stream) unread
- (sm buffer-ptr stream) (if (plusp bytes)
- (+ bytes unread)
- unread))
- bytes))))
-
-(defun dc-flush-buffer (stream blocking)
+ (when (>= ptr bytes) (setf (sm buffpos stream) 0) (setf (sm mode stream) 0) (return 0))
+ (let ((bytes-written (device-write stream nil ptr nil blocking)))
+ (declare (fixnum bytes-written))
+ (when (minusp bytes-written)
+ (error "DEVICE-WRITE error."))
+ (incf ptr bytes-written))))))
+
+(defun flush-out-buffer (stream blocking)
(with-stream-class (dual-channel-simple-stream stream)
(let ((ptr 0)
- (bytes (sm outpos stream)))
+ (bytes (sm outpos stream)))
(declare (type fixnum ptr bytes))
(loop
- (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
- (let ((bytes-written (device-write stream nil ptr bytes blocking)))
- (declare (fixnum bytes-written))
- (when (minusp bytes-written)
- (error "DEVICE-WRITE error."))
- (incf ptr bytes-written))))))
+ (when (>= ptr bytes) (setf (sm outpos stream) 0) (return 0))
+ (let ((bytes-written (device-write stream nil ptr nil blocking)))
+ (declare (fixnum bytes-written))
+ (when (minusp bytes-written)
+ (error "DEVICE-WRITE error."))
+ (incf ptr bytes-written))))))
+
+(defun read-byte-internal (stream eof-error-p eof-value blocking)
+ (with-stream-class (simple-stream stream)
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buffer-ptr stream))
+ (let ((bytes (device-read stream nil 0 nil blocking)))
+ (declare (type fixnum bytes))
+ (if (plusp bytes)
+ (setf (sm buffer-ptr stream) bytes
+ ptr 0)
+ (return-from read-byte-internal
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
+ (setf (sm buffpos stream) (1+ ptr))
+ (setf (sm last-char-read-size stream) 0)
+ (setf (sm charpos stream) nil)
+ (bref (sm buffer stream) ptr))))
-;;;
-;;; SINGLE-CHANNEL STRATEGY FUNCTIONS
-;;;
+;;;; Single-Channel-Simple-Stream strategy functions
-(declaim (ftype j-read-char-fn sc-read-char))
-(defun sc-read-char (stream eof-error-p eof-value blocking)
- (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
- ;; if stream is open for read-write, may need to flush the buffer
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (if (< ptr (sm buffer-ptr stream))
- (progn
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))
- (let ((bytes (sc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (unless (minusp bytes)
- (let ((ptr (sm buffpos stream)))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char))))
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-(declaim (ftype j-read-char-fn sc-read-char--buffer))
-(defun sc-read-char--buffer (stream eof-error-p eof-value blocking)
- (declare (ignore blocking)) ;; everything is already in the buffer
- (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
+(declaim (ftype j-listen-fn sc-listen-ef))
+(defun sc-listen-ef (stream)
+ (with-stream-class (simple-stream stream)
+ (let ((lcrs (sm last-char-read-size stream))
+ (buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (cnt 0)
+ (char nil))
+ (unwind-protect
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (let ((bytes (refill-buffer stream nil)))
+ (cond ((= bytes 0)
+ (return-from sc-listen-ef nil))
+ ((< bytes 0)
+ (return-from sc-listen-ef t))
+ (t
+ (setf buffpos (sm buffpos stream))))))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (setq char (octets-to-char (sm external-format stream)
+ (sm oc-state stream)
+ cnt #'input #'unput))
+ (characterp char))
+ (setf (sm last-char-read-size stream) lcrs)))))
+
+(declaim (ftype j-read-char-fn sc-read-char-ef))
+(defun sc-read-char-ef (stream eof-error-p eof-value blocking)
+ #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
+ (with-stream-class (simple-stream stream)
(let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (when (< ptr (sm buffer-ptr stream))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr)))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char))))
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-
-(declaim (ftype j-read-chars-fn sc-read-chars))
-(defun sc-read-chars (stream string search start end blocking)
+ (buffpos (sm buffpos stream))
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream)))
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (when (and (not (any-stream-instance-flags stream :dual :string))
+ (sc-dirty-p stream))
+ (flush-buffer stream t))
+ (let ((bytes (refill-buffer stream blocking)))
+ (cond ((= bytes 0)
+ (return-from sc-read-char-ef nil))
+ ((minusp bytes)
+ (return-from sc-read-char-ef
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (t
+ (setf buffpos (sm buffpos stream))))))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) cnt
+ (sm oc-state stream) state)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (if (null char)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+
+(declaim (ftype j-read-char-fn sc-read-char-ef-mapped))
+(defun sc-read-char-ef-mapped (stream eof-error-p eof-value blocking)
+ #|(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))|#
+ (declare (ignore blocking))
+ (with-stream-class (simple-stream stream)
+ (let* ((buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream)))
+ (flet ((input ()
+ (when (>= buffpos (sm buffer-ptr stream))
+ (return-from sc-read-char-ef-mapped
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)))
+ (incf (sm last-char-read-size stream))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) cnt
+ (sm oc-state stream) state)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (if (null char)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))))
+
+
+(declaim (ftype j-read-chars-fn sc-read-chars-ef))
+(defun sc-read-chars-ef (stream string search start end blocking)
;; string is filled from START to END, or until SEARCH is found
;; Return two values: count of chars read and
;; NIL if SEARCH was not found
- ;; T is SEARCH was found
+ ;; T if SEARCH was found
;; :EOF if eof encountered before end
(declare (type simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (single-channel-simple-stream stream)
- (setf (sm last-char-read-size stream) 0)
- ;; FIXME: Should arrange for the last character to be unreadable
+ (type string string)
+ (type (or null character) search)
+ (type fixnum start end)
+ (type boolean blocking)
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ (with-stream-class (simple-stream stream)
+ (when (and (not (any-stream-instance-flags stream :dual :string))
+ (sc-dirty-p stream))
+ (flush-buffer stream t))
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((= posn end) (setf (sm buffpos stream) ptr) (values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (if (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))
- (let ((bytes (sc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (setf ptr (sm buffpos stream)
- max (sm buffer-ptr stream))
- (when (plusp bytes)
- (prog1
- (bref buffer ptr)
- (incf ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-read-chars-fn sc-read-chars--buffer))
-(defun sc-read-chars--buffer (stream string search start end blocking)
+ (buffpos (sm buffpos stream))
+ (buffer-ptr (sm buffer-ptr stream))
+ (lcrs 0)
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (values count nil))
+ (declare (type sb-int:index buffpos buffer-ptr posn count))
+ (flet ((input ()
+ (when (>= buffpos buffer-ptr)
+ (setf (sm last-char-read-size stream) lcrs)
+ (let ((bytes (refill-buffer stream blocking)))
+ (declare (type fixnum bytes))
+ (setf buffpos (sm buffpos stream)
+ buffer-ptr (sm buffer-ptr stream))
+ (unless (plusp bytes)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (if (zerop bytes)
+ (return (values count nil))
+ (return (values count :eof))))))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)
+ (incf lcrs)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setq lcrs cnt)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (cond ((null char)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count :eof)))
+ ((and search (char= char search))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count t)))
+ (t
+ (setf (char string posn) char))))))))
+
+
+(declaim (ftype j-read-chars-fn sc-read-chars-ef-mapped))
+(defun sc-read-chars-ef-mapped (stream string search start end blocking)
+ ;; string is filled from START to END, or until SEARCH is found
+ ;; Return two values: count of chars read and
+ ;; NIL if SEARCH was not found
+ ;; T if SEARCH was found
+ ;; :EOF if eof encountered before end
(declare (type simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (declare (ignore blocking)) ; everything is in the buffer
- (with-stream-class (single-channel-simple-stream stream)
+ (type string string)
+ (type (or null character) search)
+ (type fixnum start end)
+ (type boolean blocking)
+ (ignore blocking)
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ (with-stream-class (simple-stream stream)
+ ;; if stream is single-channel and mode == 3, flush buffer (if dirty)
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((= posn end)
- (setf (sm buffpos stream) ptr)
- (unless (zerop count) (setf (sm last-char-read-size stream) 1))
- (values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (when (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (unless (zerop count) (setf (sm last-char-read-size stream) 1))
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- ;; Unread of last char must unread the search character, too
- ;; If no characters were read, just add the length of the
- ;; search char to that of the previously read char.
- (if (zerop count)
- (incf (sm last-char-read-size stream))
- (setf (sm last-char-read-size stream) 2))
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-unread-char-fn sc-unread-char))
-(defun sc-unread-char (stream relaxed)
+ (buffpos (sm buffpos stream))
+ (buffer-ptr (sm buffer-ptr stream))
+ (lcrs 0)
+ (ctrl (sm control-in stream))
+ (ef (sm external-format stream))
+ (state (sm oc-state stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (values count nil))
+ (declare (type sb-int:index buffpos buffer-ptr posn count))
+ (flet ((input ()
+ (when (>= buffpos buffer-ptr)
+ (return (values count :eof)))
+ (prog1 (bref buffer buffpos)
+ (incf buffpos)
+ (incf lcrs)))
+ (unput (n)
+ (decf buffpos n)))
+ (let* ((cnt 0)
+ (char (octets-to-char ef state cnt #'input #'unput))
+ (code (char-code char)))
+ (setq lcrs cnt)
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))
+ (cond ((null char)
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count :eof)))
+ ((and search (char= char search))
+ (setf (sm buffpos stream) buffpos
+ (sm last-char-read-size stream) lcrs
+ (sm oc-state stream) state)
+ (return (values count t)))
+ (t
+ (setf (char string posn) char))))))))
+
+
+(declaim (ftype j-unread-char-fn sc-unread-char-ef))
+(defun sc-unread-char-ef (stream relaxed)
(declare (ignore relaxed))
- (with-stream-class (single-channel-simple-stream stream)
+ (with-stream-class (simple-stream stream)
(let ((unread (sm last-char-read-size stream)))
(if (>= (sm buffpos stream) unread)
- (decf (sm buffpos stream) unread)
- (error "Unreading needs work"))
- (setf (sm last-char-read-size stream) 0))))
+ (decf (sm buffpos stream) unread)
+ (error "This shouldn't happen.")))))
-(declaim (ftype j-write-char-fn sc-write-char))
-(defun sc-write-char (character stream)
- (with-stream-class (single-channel-simple-stream stream)
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (char-code character))
- (ctrl (sm control-out stream)))
- (when (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream character))
- (return-from sc-write-char character))
- (when (>= ptr (sm buf-len stream))
- (setf ptr (sc-flush-buffer stream t)))
- (setf (bref buffer ptr) code)
- (setf (sm buffpos stream) (1+ ptr))
- (add-stream-instance-flags stream :dirty)))
+(declaim (ftype j-write-char-fn sc-write-char-ef))
+(defun sc-write-char-ef (character stream)
+ (when character
+ (with-stream-class (single-channel-simple-stream stream)
+ (let ((buffer (sm buffer stream))
+ (buffpos (sm buffpos stream))
+ (buf-len (sm buf-len stream))
+ (code (char-code character))
+ (ctrl (sm control-out stream)))
+ (when (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream character))
+ (return-from sc-write-char-ef character))
+ (flet ((output (byte)
+ (when (>= buffpos buf-len)
+ (setf (sm buffpos stream) buffpos)
+ (setq buffpos (flush-buffer stream t)))
+ (setf (bref buffer buffpos) byte)
+ (incf buffpos)))
+ (char-to-octets (sm external-format stream) character
+ (sm co-state stream) #'output))
+ (setf (sm buffpos stream) buffpos)
+ (sc-set-dirty stream)
+ (if (sm charpos stream) (incf (sm charpos stream))))))
character)
-(declaim (ftype j-write-chars-fn sc-write-chars))
-(defun sc-write-chars (string stream start end)
+(declaim (ftype j-write-chars-fn sc-write-chars-ef))
+(defun sc-write-chars-ef (string stream start end)
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buf-len stream))
- (ctrl (sm control-out stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end)
- (setf (sm buffpos stream) ptr)
- (add-stream-instance-flags stream :dirty)
- count)
- (declare (type fixnum ptr max posn count))
+ (buffpos (sm buffpos stream))
+ (buf-len (sm buf-len stream))
+ (ef (sm external-format stream))
+ (ctrl (sm control-out stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end) (setf (sm buffpos stream) buffpos) count)
+ (declare (type fixnum buffpos buf-len posn count))
(let* ((char (char string posn))
- (code (char-code char)))
- ;; FIXME: Can functions in the control-out table side-effect
- ;; the stream? Section 9.0 prohibits this only for control-in
- ;; functions. If they can, update (sm buffpos stream) here,
- ;; like around the call to sc-flush-buffer below
- (unless (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream char))
- (unless (< ptr max)
- ;; need to update buffpos before control leaves this
- ;; function in any way
- (setf (sm buffpos stream) ptr)
- (sc-flush-buffer stream t)
- (setf ptr (sm buffpos stream)))
- (setf (bref buffer ptr) code)
- (incf ptr))))))
-
-(declaim (ftype j-listen-fn sc-listen))
-(defun sc-listen (stream)
- (with-stream-class (single-channel-simple-stream stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (case (device-read stream nil 0 0 nil)
- ((0 -2) nil)
- (-1 #| latch EOF |# nil)
- (-3 t)
- (t (error "DEVICE-READ error."))))))
-
-;;; SC-READ-BYTE doesn't actually live in a strategy slot
-(defun sc-read-byte (stream eof-error-p eof-value blocking)
- (with-stream-class (single-channel-simple-stream stream)
- ;; @@1
- (let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buffer-ptr stream))
- (let ((bytes (device-read stream nil 0 nil blocking)))
- (declare (type fixnum bytes))
- (if (plusp bytes)
- (setf (sm buffer-ptr stream) bytes
- ptr 0)
- (return-from sc-read-byte
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
- (setf (sm buffpos stream) (1+ ptr))
- (setf (sm last-char-read-size stream) 0)
- (bref (sm buffer stream) ptr))))
-
-;;;
-;;; DUAL-CHANNEL STRATEGY FUNCTIONS
-;;;
-
-(declaim (ftype j-read-char-fn dc-read-char))
-(defun dc-read-char (stream eof-error-p eof-value blocking)
- ;;(declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (dual-channel-simple-stream stream)
- ;; if interactive flag is set, finish-output first
- (let* ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (code (if (< ptr (sm buffer-ptr stream))
- (progn
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))
- (let ((bytes (dc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (unless (minusp bytes)
- (let ((ptr (sm buffpos stream)))
- (setf (sm buffpos stream) (1+ ptr))
- (bref buffer ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when code
- (setf (sm last-char-read-size stream) 1)
- (when (and (< code 32) ctrl (svref ctrl code))
- ;; Does this have to be a function, or can it be a symbol?
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#)
- (if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- char))))
-
-(declaim (ftype j-read-chars-fn dc-read-chars))
-(defun dc-read-chars (stream string search start end blocking)
- (declare (type dual-channel-simple-stream stream)
- (type string string)
- (type (or null character) search)
- (type fixnum start end)
- (type boolean blocking)
- #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
- (with-stream-class (dual-channel-simple-stream stream)
- ;; if interactive flag is set, finish-output first
- (setf (sm last-char-read-size stream) 0)
- ;; Should arrange for the last character to be unreadable
- (do ((buffer (sm buffer stream))
- (ptr (sm buffpos stream))
- (max (sm buffer-ptr stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end) (setf (sm buffpos stream) ptr) (values count nil))
- (declare (type fixnum ptr max posn count))
- (let* ((code (if (< ptr max)
- (prog1
- (bref buffer ptr)
- (incf ptr))
- (let ((bytes (dc-refill-buffer stream blocking)))
- (declare (type fixnum bytes))
- (setf ptr (sm buffpos stream)
- max (sm buffer-ptr stream))
- (when (plusp bytes)
- (prog1
- (bref buffer ptr)
- (incf ptr))))))
- (char (if code (code-char code) nil))
- (ctrl (sm control-in stream)))
- (when (and code (< code 32) ctrl (svref ctrl code))
- (setq char (funcall (the (or symbol function) (svref ctrl code))
- stream char)))
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#
- (cond ((null char)
- (setf (sm buffpos stream) ptr)
- (return (values count :eof)))
- ((and search (char= char search))
- (setf (sm buffpos stream) ptr)
- (return (values count t)))
- (t
- (setf (char string posn) char)))))))
-
-(declaim (ftype j-unread-char-fn dc-unread-char))
-(defun dc-unread-char (stream relaxed)
- (declare (ignore relaxed))
- (with-stream-class (dual-channel-simple-stream stream)
- (let ((unread (sm last-char-read-size stream)))
- (if (>= (sm buffpos stream) unread)
- (decf (sm buffpos stream) unread)
- (error "Unreading needs work"))
- (setf (sm last-char-read-size stream) 0))))
-
-(declaim (ftype j-write-char-fn dc-write-char))
-(defun dc-write-char (character stream)
+ (code (char-code char)))
+ (unless (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream char))
+ (flet ((output (byte)
+ (when (>= buffpos buf-len)
+ (setf (sm buffpos stream) buffpos)
+ (setq buffpos (flush-buffer stream t)))
+ (setf (bref buffer buffpos) byte)
+ (incf buffpos)))
+ (char-to-octets ef char (sm co-state stream) #'output))
+ (setf (sm buffpos stream) buffpos)
+ (if (sm charpos stream) (incf (sm charpos stream)))
+ (sc-set-dirty stream))))))
+
+
+;;;; Dual-Channel-Simple-Stream strategy functions
+
+;; single-channel read-side functions work for dual-channel streams too
+
+(declaim (ftype j-write-char-fn dc-write-char-ef))
+(defun dc-write-char-ef (character stream)
(when character
(with-stream-class (dual-channel-simple-stream stream)
- (let* ((buffer (sm out-buffer stream))
- (ptr (sm outpos stream))
- (code (char-code character))
- (ctrl (sm control-out stream)))
+ (let ((out-buffer (sm out-buffer stream))
+ (outpos (sm outpos stream))
+ (max-out-pos (sm max-out-pos stream))
+ (code (char-code character))
+ (ctrl (sm control-out stream)))
(when (and (< code 32) ctrl (svref ctrl code)
(funcall (the (or symbol function) (svref ctrl code))
stream character))
- (return-from dc-write-char character))
- (when (>= ptr (sm max-out-pos stream))
- (setq ptr (dc-flush-buffer stream t)))
- (setf (bref buffer ptr) code)
- (setf (sm outpos stream) (1+ ptr)))))
+ (return-from dc-write-char-ef character))
+ (flet ((output (byte)
+ (when (>= outpos max-out-pos)
+ (setf (sm outpos stream) outpos)
+ (setq outpos (flush-out-buffer stream t)))
+ (setf (bref out-buffer outpos) byte)
+ (incf outpos)))
+ (char-to-octets (sm external-format stream) character
+ (sm co-state stream) #'output))
+ (setf (sm outpos stream) outpos)
+ (if (sm charpos stream) (incf (sm charpos stream))))))
character)
-(declaim (ftype j-write-chars-fn dc-write-chars))
-(defun dc-write-chars (string stream start end)
+
+(declaim (ftype j-write-chars-fn dc-write-chars-ef))
+(defun dc-write-chars-ef (string stream start end)
(with-stream-class (dual-channel-simple-stream stream)
(do ((buffer (sm out-buffer stream))
- (ptr (sm outpos stream))
- (max (sm max-out-pos stream))
- (ctrl (sm control-out stream))
- (posn start (1+ posn))
- (count 0 (1+ count)))
- ((>= posn end) (setf (sm outpos stream) ptr) count)
- (declare (type fixnum ptr max posn count))
+ (outpos (sm outpos stream))
+ (max-out-pos (sm max-out-pos stream))
+ (ef (sm external-format stream))
+ (ctrl (sm control-out stream))
+ (posn start (1+ posn))
+ (count 0 (1+ count)))
+ ((>= posn end) (setf (sm outpos stream) outpos) count)
+ (declare (type fixnum outpos max-out-pos posn count))
(let* ((char (char string posn))
- (code (char-code char)))
- (unless (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream char))
- (unless (< ptr max)
- (setf (sm outpos stream) ptr)
- (dc-flush-buffer stream t)
- (setf ptr (sm outpos stream)))
- (setf (bref buffer ptr) code)
- (incf ptr))
- ))))
-
-(declaim (ftype j-listen-fn dc-listen))
-(defun dc-listen (stream)
- (with-stream-class (dual-channel-simple-stream stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- (case (device-read stream nil 0 0 nil)
- ((0 -2) nil)
- (-1 #| latch EOF |# nil)
- (-3 t)
- (t (error "DEVICE-READ error."))))))
-
-;;; DC-READ-BYTE doesn't actually live in a strategy slot
-(defun dc-read-byte (stream eof-error-p eof-value blocking)
- (with-stream-class (dual-channel-simple-stream stream)
- (let ((ptr (sm buffpos stream)))
- (when (>= ptr (sm buffer-ptr stream))
- (let ((bytes (device-read stream nil 0 nil blocking)))
- (declare (type fixnum bytes))
- (if (plusp bytes)
- (setf (sm buffer-ptr stream) bytes
- ptr 0)
- (return-from dc-read-byte
- (sb-impl::eof-or-lose stream eof-error-p eof-value)))))
- (setf (sm buffpos stream) (1+ ptr))
- (setf (sm last-char-read-size stream) 0)
- (bref (sm buffer stream) ptr))))
-
-;;;
-;;; STRING STRATEGY FUNCTIONS
-;;;
-
-(declaim (ftype j-read-char-fn string-read-char))
-(defun string-read-char (stream eof-error-p eof-value blocking)
+ (code (char-code char)))
+ (unless (and (< code 32) ctrl (svref ctrl code)
+ (funcall (the (or symbol function) (svref ctrl code))
+ stream char))
+ (flet ((output (byte)
+ (when (>= outpos max-out-pos)
+ (setf (sm outpos stream) outpos)
+ (setq outpos (flush-out-buffer stream t)))
+ (setf (bref buffer outpos) byte)
+ (incf outpos)))
+ (char-to-octets ef char (sm co-state stream) #'output))
+ (setf (sm outpos stream) outpos)
+ (if (sm charpos stream) (incf (sm charpos stream))))))))
+
+;;;; String-Simple-Stream strategy functions
+
+(declaim (ftype j-read-char-fn str-read-char))
+(defun str-read-char (stream eof-error-p eof-value blocking)
(declare (type string-input-simple-stream stream) (ignore blocking)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#
+ )
(with-stream-class (string-input-simple-stream stream)
(when (any-stream-instance-flags stream :eof)
(sb-impl::eof-or-lose stream eof-error-p eof-value))
(let* ((ptr (sm buffpos stream))
- (char (if (< ptr (sm buffer-ptr stream))
- (schar (sm buffer stream) ptr)
- nil)))
+ (char (if (< ptr (sm buffer-ptr stream))
+ (schar (sm buffer stream) ptr)
+ nil)))
(if (null char)
- (sb-impl::eof-or-lose stream eof-error-p eof-value)
- (progn
- (setf (sm last-char-read-size stream) 1)
- ;; do string-streams do control-in processing?
- #|(let ((column (sm charpos stream)))
- (declare (type (or null fixnum) column))
- (when column
- (setf (sm charpos stream) (1+ column))))|#
- char)))))
-
-
-(declaim (ftype j-read-char-fn composing-crlf-read-char))
-(defun composing-crlf-read-char (stream eof-error-p eof-value blocking)
- ;; TODO: what about the eof-error-p parameter?
- (declare (ignore eof-error-p eof-value))
- (with-stream-class (simple-stream stream)
- (let* ((melded-stream (sm melded-stream stream))
- (char (funcall-stm-handler j-read-char melded-stream nil stream
- blocking)))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ (progn
+ (setf (sm last-char-read-size stream) 1)
+ ;; do string-streams do control-in processing?
+ #|(let ((column (sm charpos stream)))
+ (declare (type (or null fixnum) column))
+ (when column
+ (setf (sm charpos stream) (1+ column))))
+ |#
+ char)))))
+
+(declaim (ftype j-listen-fn str-listen-e-crlf))
+(defun str-listen-e-crlf (stream)
+ (with-stream-class (composing-stream stream)
+ ;; if this says there's a character available, it may be #\Return,
+ ;; in which case read-char will only return if there's a following
+ ;; #\Linefeed, so this really has to read the char...
+ ;; but without precluding the later unread-char of a character which
+ ;; has already been read.
+ (funcall-stm-handler j-listen (sm melded-stream stream))))
+
+(declaim (ftype j-read-char-fn str-read-char-e-crlf))
+(defun str-read-char-e-crlf (stream eof-error-p eof-value blocking)
+ (with-stream-class (composing-stream stream)
+ (let* ((encap (sm melded-stream stream))
+ (ctrl (sm control-in stream))
+ (char (funcall-stm-handler j-read-char encap nil stream blocking)))
;; if CHAR is STREAM, we hit EOF; if NIL, blocking is NIL and no
;; character was available...
(when (eql char #\Return)
- (let ((next (funcall-stm-handler j-read-char melded-stream
- nil stream blocking)))
- ;; if NEXT is STREAM, we hit EOF, so we should just return the
- ;; #\Return (and mark the stream :EOF? At least unread if we
- ;; got a soft EOF, from a terminal, etc.
- ;; if NEXT is NIL, blocking is NIL and there's a CR but no
- ;; LF available on the stream: have to unread the CR and
- ;; return NIL, letting the CR be reread later.
- ;;
- ;; If we did get a linefeed, adjust the last-char-read-size
- ;; so that an unread of the resulting newline will unread both
- ;; the linefeed _and_ the carriage return.
- (if (eql next #\Linefeed)
- (setq char #\Newline)
- (funcall-stm-handler j-unread-char melded-stream nil))))
- ;; do control-in processing on whatever character we've got
- char)))
-
-(declaim (ftype j-unread-char-fn composing-crlf-unread-char))
-(defun composing-crlf-unread-char (stream relaxed)
+ (let ((next (funcall-stm-handler j-read-char encap nil stream blocking)))
+ ;; if NEXT is STREAM, we hit EOF, so we should just return the
+ ;; #\Return (and mark the stream :EOF? At least unread if we
+ ;; got a soft EOF, from a terminal, etc.
+ ;; if NEXT is NIL, blocking is NIL and there's a CR but no
+ ;; LF available on the stream: have to unread the CR and
+ ;; return NIL, letting the CR be reread later.
+ ;;
+ ;; If we did get a linefeed, adjust the last-char-read-size
+ ;; so that an unread of the resulting newline will unread both
+ ;; the linefeed _and_ the carriage return.
+ (if (eql next #\Linefeed)
+ (setq char #\Newline)
+ (funcall-stm-handler j-unread-char encap nil))))
+ (when (characterp char)
+ (let ((code (char-code char)))
+ (when (and (< code 32) ctrl (svref ctrl code))
+ (setq char (funcall (the (or symbol function) (svref ctrl code))
+ stream char)))))
+ (if (eq char stream)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ char))))
+
+(declaim (ftype j-unread-char-fn str-unread-char-e-crlf))
+(defun str-unread-char-e-crlf (stream relaxed)
(declare (ignore relaxed))
- (with-stream-class (simple-stream stream)
+ (with-stream-class (composing-stream stream)
(funcall-stm-handler j-unread-char (sm melded-stream stream) nil)))
-;;;
+
;;; Functions to install the strategy functions in the appropriate slots
-;;;
-(defun %find-topmost-stream (stream)
- ;; N.B.: the topmost stream in the chain of encapsulations is actually
- ;; the bottommost in the "melding" chain
+(defun melding-stream (stream)
(with-stream-class (simple-stream)
- (loop
- (when (eq (sm melded-stream stream) (sm melding-base stream))
- (return stream))
- (setq stream (sm melded-stream stream)))))
+ (do ((stm stream (sm melded-stream stm)))
+ ((eq (sm melded-stream stm) stream) stm))))
+
+(defun meld (stream encap)
+ (with-stream-class (simple-stream)
+ (setf (sm melding-base encap) (sm melding-base stream))
+ (setf (sm melded-stream encap) (sm melded-stream stream))
+ (setf (sm melded-stream stream) encap)
+ (rotatef (sm j-listen encap) (sm j-listen stream))
+ (rotatef (sm j-read-char encap) (sm j-read-char stream))
+ (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
+ (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
+ (rotatef (sm j-write-char encap) (sm j-write-char stream))
+ (rotatef (sm j-write-chars encap) (sm j-write-chars stream))))
+
+(defun unmeld (stream)
+ (with-stream-class (simple-stream)
+ (let ((encap (sm melded-stream stream)))
+ (unless (eq encap (sm melding-base stream))
+ (setf (sm melding-base encap) encap)
+ (setf (sm melded-stream stream) (sm melded-stream encap))
+ (setf (sm melded-stream encap) encap)
+ (rotatef (sm j-listen stream) (sm j-listen encap))
+ (rotatef (sm j-read-char encap) (sm j-read-char stream))
+ (rotatef (sm j-read-chars stream) (sm j-read-chars encap))
+ (rotatef (sm j-unread-char stream) (sm j-unread-char encap))
+ (rotatef (sm j-write-char stream) (sm j-write-char encap))
+ (rotatef (sm j-write-chars stream) (sm j-write-chars encap))))))
+
+;;; In cmucl, this is done with define-function-name-syntax (lists as
+;;; function names), we make do with symbol frobbing.
+(defun %sf (kind name format &optional access)
+ (flet ((find-strategy-function (&rest args)
+ (let ((name
+ (find-symbol (format nil "~{~A~^-~}" (mapcar #'string args))
+ #.*package*)))
+ (if (fboundp name) (fdefinition name) nil))))
+ (or (find-strategy-function kind name format access)
+ (find-strategy-function kind name format)
+ (find-strategy-function kind name :ef access)
+ (find-strategy-function kind name :ef))))
+
(defun install-single-channel-character-strategy (stream external-format
- access)
- (find-external-format external-format)
- (let ((stream (%find-topmost-stream stream)))
+ access)
+ (let ((format (find-external-format external-format)))
;; ACCESS is usually NIL
;; May be "undocumented" values: stream::buffer, stream::mapped
;; to install strategies suitable for direct buffer streams
;; (i.e., ones that call DEVICE-EXTEND instead of DEVICE-READ)
;; (Avoids checking "mode" flags by installing special strategy)
- (with-stream-class (single-channel-simple-stream stream)
- (if (or (eq access 'buffer) (eq access 'mapped))
- (setf (sm j-read-char stream) #'sc-read-char--buffer
- (sm j-read-chars stream) #'sc-read-chars--buffer
- (sm j-unread-char stream) #'sc-unread-char
- (sm j-write-char stream) #'sc-write-char
- (sm j-write-chars stream) #'sc-write-chars
- (sm j-listen stream) #'sc-listen)
- (setf (sm j-read-char stream) #'sc-read-char
- (sm j-read-chars stream) #'sc-read-chars
- (sm j-unread-char stream) #'sc-unread-char
- (sm j-write-char stream) #'sc-write-char
- (sm j-write-chars stream) #'sc-write-chars
- (sm j-listen stream) #'sc-listen))))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-listen stream)
+ (%sf 'sc 'listen (ef-name format) access)
+ (sm j-read-char stream)
+ (%sf 'sc 'read-char (ef-name format) access)
+ (sm j-read-chars stream)
+ (%sf 'sc 'read-chars (ef-name format) access)
+ (sm j-unread-char stream)
+ (%sf 'sc 'unread-char (ef-name format) access)
+ (sm j-write-char stream)
+ (%sf 'sc 'write-char (ef-name format) access)
+ (sm j-write-chars stream)
+ (%sf 'sc 'write-chars (ef-name format) access))))
stream)
(defun install-dual-channel-character-strategy (stream external-format)
- (find-external-format external-format)
- (let ((stream (%find-topmost-stream stream)))
- (with-stream-class (dual-channel-simple-stream stream)
- (setf (sm j-read-char stream) #'dc-read-char
- (sm j-read-chars stream) #'dc-read-chars
- (sm j-unread-char stream) #'dc-unread-char
- (sm j-write-char stream) #'dc-write-char
- (sm j-write-chars stream) #'dc-write-chars
- (sm j-listen stream) #'dc-listen)))
+ (let ((format (find-external-format external-format)))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-listen stream)
+ (%sf 'sc 'listen (ef-name format))
+ (sm j-read-char stream)
+ (%sf 'sc 'read-char (ef-name format))
+ (sm j-read-chars stream)
+ (%sf 'sc 'read-chars (ef-name format))
+ (sm j-unread-char stream)
+ (%sf 'sc 'unread-char (ef-name format))
+ (sm j-write-char stream)
+ (%sf 'dc 'write-char (ef-name format))
+ (sm j-write-chars stream)
+ (%sf 'dc 'write-chars (ef-name format)))))
+ stream)
+
+;; Deprecated -- use install-string-{input,output}-character-strategy instead!
+(defun install-string-character-strategy (stream)
+ (when (any-stream-instance-flags stream :input)
+ (install-string-input-character-strategy stream))
+ (when (any-stream-instance-flags stream :output)
+ (install-string-output-character-strategy stream))
stream)
(defun install-string-input-character-strategy (stream)
#| implement me |#
- (let ((stream (%find-topmost-stream stream)))
- (with-stream-class (simple-stream stream)
- (setf (sm j-read-char stream) #'string-read-char)))
+ (with-stream-class (simple-stream stream)
+ (setf (sm j-read-char stream) #'str-read-char))
stream)
(defun install-string-output-character-strategy (stream)
#| implement me |#
stream)
+(defun install-composing-format-character-strategy (stream composing-format)
+ (let ((format composing-format))
+ (with-stream-class (simple-stream stream)
+ (case format
+ (:e-crlf (setf (sm j-read-char stream) #'str-read-char-e-crlf
+ (sm j-unread-char stream) #'str-unread-char-e-crlf))))
+ #| implement me |#)
+ stream)
+
(defun compose-encapsulating-streams (stream external-format)
(when (consp external-format)
(with-stream-class (simple-stream)
- (dolist (fmt (butlast external-format))
- (let ((encap (make-instance 'composing-stream :composing-format fmt)))
- (setf (sm melding-base encap) stream)
- (setf (sm melded-stream encap) (sm melded-stream stream))
- (setf (sm melded-stream stream) encap)
- (rotatef (sm j-listen encap) (sm j-listen stream))
- (rotatef (sm j-read-char encap) (sm j-read-char stream))
- (rotatef (sm j-read-chars encap) (sm j-read-chars stream))
- (rotatef (sm j-unread-char encap) (sm j-unread-char stream))
- (rotatef (sm j-write-char encap) (sm j-write-char stream))
- (rotatef (sm j-write-chars encap) (sm j-write-chars stream)))))))
+ (let ((encap (if (eq (sm melded-stream stream) stream)
+ nil
+ (sm melded-stream stream))))
+ (when (null encap)
+ (setq encap (make-instance 'composing-stream))
+ (meld stream encap))
+ (setf (stream-external-format encap) (car (last external-format)))
+ (setf (sm external-format stream) external-format)
+ (install-composing-format-character-strategy stream
+ (butlast external-format))
+ ))))
+
+(defmethod (setf stream-external-format) (ef (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (setf (sm external-format stream) (find-external-format ef)))
+ ef)
;;;
;;; NULL STRATEGY FUNCTIONS
projects / sbcl.git / blobdiff