- (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)
- ;; 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."))))))
-
-;;;
-;;; 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 (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 (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)
- (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)))
- (when (and (< code 32) ctrl (svref ctrl code)
- (funcall (the (or symbol function) (svref ctrl code))
- stream character))
- (return-from dc-write-char character))
- (unless (< ptr (sm max-out-pos stream))
- (dc-flush-buffer stream t)
- (setf ptr (sm outpos stream)))
- (progn
- (setf (bref buffer ptr) code)
- (setf (sm outpos stream) (1+ ptr))
- )))
+ (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 ((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))))))