;;; **********************************************************************
;;; This code was written by Paul Foley and has been placed in the public
;;; domain.
-;;;
+;;;
;;; Sbcl port by Rudi Schlatte.
(with-stream-class (simple-stream stream)
(let* ((unread (sm last-char-read-size stream))
(buffer (sm buffer stream))
- (bufptr (sm buffer-ptr 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)))
(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))
+ (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)))))
+ (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))
- (buffpos (sm buffpos stream))
- (ctrl (sm control-in stream))
- (ef (sm external-format stream))
- (state (sm oc-state 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))
+ (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))))))
+ (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))
(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)))
+ (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
+ (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))))))
+ (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))
(type (or null character) search)
(type fixnum start end)
(type boolean blocking)
- #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ #|(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))
(do ((buffer (sm buffer stream))
(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))
+ (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))
+ (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))))))))
+ (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))
(type fixnum start end)
(type boolean blocking)
(ignore blocking)
- #|(optimize (speed 3) (space 2) (safety 0) (debug 0))|#)
+ #|(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))
(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))
+ (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))
+ (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)
+ (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))))))))
+ (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))
(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)
+ (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))))))
+ (if (sm charpos stream) (incf (sm charpos stream))))))
character)
(declaim (ftype j-write-chars-fn sc-write-chars-ef))
(do ((buffer (sm buffer stream))
(buffpos (sm buffpos stream))
(buf-len (sm buf-len stream))
- (ef (sm external-format stream))
+ (ef (sm external-format stream))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
(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)))
+ (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))))))
(when character
(with-stream-class (dual-channel-simple-stream 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-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))))))
+ (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-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)
(do ((buffer (sm out-buffer stream))
(outpos (sm outpos stream))
(max-out-pos (sm max-out-pos stream))
- (ef (sm external-format stream))
+ (ef (sm external-format stream))
(ctrl (sm control-out stream))
(posn start (1+ posn))
(count 0 (1+ count)))
(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))))))))
+ (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
(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))
+ (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...
(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)))))
+ (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))))
+ (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)
(defun melding-stream (stream)
(with-stream-class (simple-stream)
(do ((stm stream (sm melded-stream stm)))
- ((eq (sm melded-stream stm) stream) stm))))
+ ((eq (sm melded-stream stm) stream) stm))))
(defun meld (stream encap)
(with-stream-class (simple-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))))))
+ (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))))
+ (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)
;; (Avoids checking "mode" flags by installing special strategy)
(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))))
+ (%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)
(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)))))
+ (%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!
(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))))
+ (: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)
(when (consp external-format)
(with-stream-class (simple-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))
- ))))
+ 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)
projects / sbcl.git / blobdiff