+;;; Implementations of standard Common Lisp functions for simple-streams
+
+(defmacro %check-simple-stream (stream &optional direction)
+ ;; Check that STREAM is valid and open in the appropriate direction.
+ `(locally
+ (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (with-stream-class (simple-stream ,stream)
+ (let ((flags (sm %flags ,stream)))
+ (cond ((zerop (logand flags ,(%flags '(:simple))))
+ (error "~S is not properly initialized." stream))
+ ((zerop (logand flags ,(%flags '(:input :output))))
+ (error "~S is closed." stream))
+ ,@(when direction
+ `(((zerop (logand flags ,(%flags (list direction))))
+ (error ,(format nil "~~S is not an ~(~A~) stream."
+ direction)
+ stream)))))))))
+
+
+(defun %simple-stream-file-position (stream position)
+ (if (typep stream 'file-simple-stream)
+ (with-stream-class (file-simple-stream stream)
+ (if (null position)
+ (let ((posn (device-file-position stream)))
+ (when posn
+ ;; Adjust for data read from device but not yet
+ ;; consumed from buffer, or written after the end of
+ ;; the buffer
+ (decf posn (- (sm buffer-ptr stream) (sm buffpos stream))))
+ posn)
+ (progn
+ (setf (sm last-char-read-size stream) 0)
+ (let ((position
+ (cond ((numberp position) position)
+ ((eq position :start) 0)
+ ((eq position :end)
+ (%simple-stream-file-length stream))
+ (t (error "Invalid position-spec: ~A" position))))
+ (device-position (device-file-position stream)))
+ (if (and (<= (- device-position (sm buffer-ptr stream))
+ position
+ device-position)
+ (not (any-stream-instance-flags stream :dirty)))
+ ;; new position is within buffer; just move pointer
+ (setf (sm buffpos stream)
+ (- position (- device-position (sm buffer-ptr stream))))
+ (progn
+ (when (any-stream-instance-flags stream :dirty)
+ (sc-flush-buffer stream t))
+ (setf (device-file-position stream) position
+ (sm buffer-ptr stream) 0
+ (sm buffpos stream) 0)))))))
+ ;; TODO: implement file-position for other types of stream where
+ ;; it makes sense
+ nil))
+
+
+(defun %simple-stream-file-length (stream)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream)
+ (device-file-length stream)
+ ;; implement me
+ )
+
+
+(defun %simple-stream-file-name (stream)
+ (declare (type simple-stream stream))
+ (if (typep stream 'file-simple-stream)
+ (with-stream-class (file-simple-stream stream)
+ (sm pathname stream))
+ nil))
+
+
+(defun %simple-stream-file-rename (stream new-name)
+ (declare (type simple-stream stream))
+ (if (typep stream 'file-simple-stream)
+ (with-stream-class (file-simple-stream stream)
+ (setf (sm pathname stream) new-name)
+ (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
+ t)
+ nil))
+
+
+(defun %simple-stream-file-string-length (stream object)
+ (declare (type simple-stream stream))
+ (etypecase object
+ (character 1)
+ (string (length object))))
+
+
+(defun %simple-stream-read-char (stream eof-error-p eof-value
+ recursive-p blocking-p)
+ (declare (type simple-stream stream)
+ (ignore recursive-p))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :input)
+ (funcall-stm-handler j-read-char (sm melded-stream stream)
+ eof-error-p eof-value blocking-p)))
+
+
+(defun %simple-stream-unread-char (stream character)
+ (declare (type simple-stream stream) (ignore character))
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream)
+ (if (zerop (sm last-char-read-size stream))
+ (error "Nothing to unread.")
+ (funcall-stm-handler j-unread-char stream nil))))
+
+(defun %simple-stream-peek-char (stream peek-type eof-error-p
+ eof-value recursive-p)
+ (declare (type simple-stream stream)
+ (ignore recursive-p))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :input)
+ (let* ((encap (sm melded-stream stream))
+ (char (funcall-stm-handler j-read-char encap
+ eof-error-p stream t)))
+ (cond ((eq char stream) eof-value)
+ ((characterp peek-type)
+ (do ((char char (funcall-stm-handler j-read-char encap
+ eof-error-p
+ stream t)))
+ ((or (eq char stream) (char= char peek-type))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ ((eq peek-type t)
+ (do ((char char (funcall-stm-handler j-read-char stream
+ eof-error-p
+ stream t)))
+ ((or (eq char stream)
+ (not (sb-impl::whitespacep char)))
+ (unless (eq char stream)
+ (funcall-stm-handler j-unread-char encap t))
+ (if (eq char stream) eof-value char))))
+ (t
+ (funcall-stm-handler j-unread-char encap t)
+ char)))))
+
+
+(defun %simple-stream-read-line (stream eof-error-p eof-value recursive-p)
+ (declare (type simple-stream stream)
+ (ignore recursive-p)
+ (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream stream)
+ (let* ((encap (sm melded-stream stream)) ; encapsulating stream
+ (cbuf (make-string 80)) ; current buffer
+ (bufs (list cbuf)) ; list of buffers
+ (tail bufs) ; last cons of bufs list
+ (index 0) ; current index in current buffer
+ (total 0)) ; total characters
+ (declare (type simple-stream encap)
+ (type simple-base-string cbuf)
+ (type cons bufs tail)
+ (type fixnum index total))
+ (loop
+ (multiple-value-bind (chars done)
+ (funcall-stm-handler j-read-chars encap cbuf
+ #\Newline index (length cbuf) t)
+ (declare (type fixnum chars))
+ (incf index chars)
+ (incf total chars)
+ (when (and (eq done :eof) (zerop index))
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return (values eof-value t))))
+ (when done
+ ;; If there's only one buffer in use, return it directly
+ (when (null (cdr bufs))
+ (return (values (sb-kernel:shrink-vector cbuf index)
+ (eq done :eof))))
+ ;; If total fits in final buffer, use it
+ #+(or)
+ (when (<= total (length cbuf))
+ (replace cbuf cbuf :start1 (- total index) :end2 index)
+ (let ((idx 0))
+ (declare (type fixnum idx))
+ (dolist (buf bufs)
+ (declare (type simple-base-string buf))
+ (replace cbuf buf :start1 idx)
+ (incf idx (length buf))))
+ (return (values (sb-kernel:shrink-vector cbuf index)
+ (eq done :eof))))
+ ;; Allocate new string of appropriate length
+ (let ((string (make-string total))
+ (index 0))
+ (declare (type fixnum index))
+ (dolist (buf bufs)
+ (declare (type simple-base-string buf))
+ (replace string buf :start1 index)
+ (incf index (length buf)))
+ (return (values string (eq done :eof)))))
+ (when (>= index (length cbuf))
+ (setf cbuf (make-string (the fixnum (* 2 index))))
+ (setf index 0)
+ (setf (cdr tail) (cons cbuf nil))
+ (setf tail (cdr tail))))))))
+
+
+(defun %simple-stream-listen (stream width)
+ (declare (type simple-stream stream))
+ ;; WIDTH is number of octets which must be available; any value
+ ;; other than 1 is treated as 'character.
+ (%check-simple-stream stream :input)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (if (not (eql width 1))
+ (funcall-stm-handler j-listen stream)
+ (or (< (sm buffpos stream) (sm buffer-ptr stream))
+ (when (>= (sm mode stream) 0) ;; device-connected
+ (incf (sm last-char-read-size stream))
+ (let ((ok (sc-refill-buffer stream nil)))
+ (decf (sm last-char-read-size stream))
+ (plusp ok))))))
+ ;; dual-channel-simple-stream
+ (error "Implement %LISTEN")
+ ;; string-simple-stream
+ (error "Implement %LISTEN")))
+
+
+(defun %simple-stream-clear-input (stream buffer-only)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :input)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm last-char-read-size stream) 0))
+ ;; dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setf (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm last-char-read-size stream) 0))
+ ;; string-simple-stream
+ nil)
+ (unless buffer-only (device-clear-input stream buffer-only)))
+
+
+(defun %simple-stream-read-byte (stream eof-error-p eof-value)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :input)
+ (with-stream-class (simple-stream stream)
+ (if (any-stream-instance-flags stream :eof)
+ (sb-impl::eof-or-lose stream eof-error-p eof-value)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (sc-read-byte stream eof-error-p eof-value t)
+ ;; dual-channel-simple-stream
+ (dc-read-byte stream eof-error-p eof-value t)
+ ;; string-simple-stream
+ (with-stream-class (string-simple-stream stream)
+ (let ((encap (sm input-handle stream)))
+ (unless encap
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't read-byte on string streams"
+ :format-arguments '()))
+ (prog1
+ (locally (declare (notinline read-byte))
+ (read-byte encap eof-error-p eof-value))
+ (setf (sm last-char-read-size stream) 0
+ (sm encapsulated-char-read-size stream) 0))))))))
+
+
+(defun %simple-stream-write-char (stream character)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-char character (sm melded-stream stream))))
+
+
+(defun %simple-stream-fresh-line (stream)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (when (/= (or (sm charpos stream) 1) 0)
+ (funcall-stm-handler-2 j-write-char #\Newline (sm melded-stream stream))
+ t)))
+
+
+(defun %simple-stream-write-string (stream string start end)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ (funcall-stm-handler-2 j-write-chars string (sm melded-stream stream)
+ start end)))
+
+
+(defun %simple-stream-line-length (stream)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :output)
+ #| TODO: implement me |#
+ nil ;; implement me
+ )
+
+
+(defun %simple-stream-finish-output (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :output)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (sc-flush-buffer stream t)
+ ;; dual-channel-simple-stream
+ (dc-flush-buffer stream t)
+ ;; string-simple-stream
+ nil)))
+
+
+(defun %simple-stream-force-output (stream)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :output)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (sc-flush-buffer stream nil)
+ ;; dual-channel-simple-stream
+ (dc-flush-buffer stream nil)
+ ;; string-simple-stream
+ nil)))
+
+
+(defun %simple-stream-clear-output (stream)
+ (declare (type simple-stream stream))
+ (%check-simple-stream stream :output)
+ (with-stream-class (simple-stream stream)
+ #| TODO: clear output buffer |#
+ (device-clear-output stream)))
+
+
+(defun %simple-stream-write-byte (stream integer)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :output)
+ (simple-stream-dispatch stream
+ ;; single-channel-simple-stream
+ (with-stream-class (single-channel-simple-stream stream)
+ (let ((ptr (sm buffpos stream)))
+ (when (>= ptr (sm buffer-ptr stream))
+ (setf ptr (sc-flush-buffer stream t)))
+ (add-stream-instance-flags stream :dirty)
+ (setf (sm buffpos stream) (1+ ptr))
+ (setf (bref (sm buffer stream) ptr) integer)))
+ ;; dual-channel-simple-stream
+ (with-stream-class (dual-channel-simple-stream stream)
+ (let ((ptr (sm outpos stream)))
+ (when (>= ptr (sm max-out-pos stream))
+ (setf ptr (dc-flush-buffer stream t)))
+ (setf (sm outpos stream) (1+ ptr))
+ (setf (bref (sm out-buffer stream) ptr) integer)))
+ ;; string-simple-stream
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'stream
+ :format-control "Can't write-byte on string streams."
+ :format-arguments '()))))
+
+
+(defun %simple-stream-read-sequence (stream seq start end partial-fill)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :input)
+ (etypecase seq
+ (string
+ (funcall-stm-handler j-read-chars (sm melded-stream stream) seq nil
+ start (or end (length seq))
+ (if partial-fill :bnb t)))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; TODO: "read-vector" equivalent, but blocking if partial-fill is NIL
+ (error "implement me")
+ ))))
+
+
+(defun %simple-stream-write-sequence (stream seq start end)
+ (declare (type simple-stream stream))
+ (with-stream-class (simple-stream stream)
+ (%check-simple-stream stream :output)
+ (etypecase seq
+ (string
+ (funcall-stm-handler-2 j-write-chars seq (sm melded-stream stream)
+ start (or end (length seq))))
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*)))
+ ;; "write-vector" equivalent
+ (error "implement me")
+ ))))
+