- (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)