-*- text -*-
-- Writing beyond the end of a mapped-simple-stream is funky; arguably,
- it should signal an error.
+- Test writing beyond the end of a mapped-simple-stream
-- write-octets / read-octets handling of encapsulated streams is
- untested.
+- Test write-octets / read-octets handling of encapsulated streams
+
+- handle ansi-streams in write-octets / read-octets
- Implement socket-base-simple-stream and chunked transfer encoding.
-- Implement string streams.
+- Implement / test string streams.
- Make sure the code examples for stream encapsulation from Franz work
- Test every single output function
+
+- Handle character position (slot charpos)
+
+- make file-position work for non-file streams, where applicable
+
+- make pathname work for simple-streams
+
(in-package "SB-SIMPLE-STREAMS")
+;;; 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")
+ ))))
+
;;; Basic functionality for ansi-streams. These are separate
;;; functions because they are called in places where we already know
((or (endp rem) (>= i end)) i)
(declare (type list rem)
(type sb-int:index i))
- (let ((el (funcall read-function stream nil :eof)))
+ (let ((el (funcall read-function stream nil :eof nil)))
(when (eq el :eof)
(return i))
(setf (first rem) el)))))
(do ((i offset-start (1+ i)))
((>= i offset-end) end)
(declare (type sb-int:index i))
- (let ((el (funcall read-function stream nil :eof)))
+ (let ((el (funcall read-function stream nil :eof nil)))
(when (eq el :eof)
(return (+ start (- i offset-start))))
(setf (aref data i) el)))))))))))
(defun interactive-stream-p (stream)
"Return true if Stream does I/O on a terminal or other interactive device."
- (declare (type stream stream))
(etypecase stream
(simple-stream
(any-stream-instance-flags stream :interactive))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :interactive-p))
- (fundamental-stream nil)))
+ (fundamental-stream
+ nil)))
-(defun (setf interactive-stream-p) (value stream)
+(defun (setf interactive-stream-p) (flag stream)
(etypecase stream
(simple-stream
- (if value
- (add-stream-instance-flags stream :interactive)
- (remove-stream-instance-flags stream :interactive)))))
+ (if flag
+ (add-stream-instance-flags stream :interactive)
+ (remove-stream-instance-flags stream :interactive)))
+ (t
+ (error 'simple-type-error
+ :datum stream
+ :expected-type 'simple-stream
+ :format-control "Can't set interactive flag on ~S."
+ :format-arguments (list stream)))))
+
+(defun file-string-length (stream object)
+ (declare (type (or string character) object) (type stream stream))
+ "Return the delta in STREAM's FILE-POSITION that would be caused by writing
+ OBJECT to STREAM. Non-trivial only in implementations that support
+ international character sets."
+ (typecase stream
+ (simple-stream (%simple-stream-file-string-length stream object))
+ (t
+ (etypecase object
+ (character 1)
+ (string (length object))))))
(defun stream-external-format (stream)
"Returns Stream's external-format."
- (declare (type stream stream))
(etypecase stream
(simple-stream
(with-stream-class (simple-stream)
(sm external-format stream)))
(ansi-stream
:default)
- (fundamental-stream #| not defined on Gray streams? |#
+ (fundamental-stream
:default)))
-(defgeneric default-open-class (name &optional element-type)
- (:documentation
- "Determine the stream class to be created when an attempt is made
-to open NAME. This is a CMUCL- and SBCL-specific extension to Franz's
-simple-streams proposal.")
- (:method ((name t) &optional element-type)
- (declare (ignore element-type))
- nil)
- (:method ((name pathname) &optional element-type)
- (declare (ignore element-type))
- 'sb-sys::file-stream)
- (:method ((name string) &optional element-type)
- (declare (ignore element-type))
- 'sb-sys::file-stream)
- (:method ((name stream) &optional element-type)
- (declare (ignore element-type))
- (class-name (class-of name))))
-
(defun open (filename &rest options
&key (direction :input)
(element-type 'character element-type-given)
:class - class of stream object to be created
:mapped - T to open a memory-mapped file
:input-handle - a stream or Unix file descriptor to read from
- :output-handle - a stream or Unix file descriptor to write to
-
- If Class is NIL or not supplied, DEFAULT-OPEN-CLASS is called on
- Filename to determine its value, thus Filename need not be an actual
- file name; it could be any arbitrary user-defined object for which a
- method of DEFAULT-OPEN-CLASS is applicable."
- (declare (ignore if-exists if-does-not-exist external-format
- input-handle output-handle))
- (let ((klass class)
+ :output-handle - a stream or Unix file descriptor to write to"
+ (declare (ignore external-format input-handle output-handle
+ if-exists if-does-not-exist))
+ (let ((class (or class 'sb-sys::file-stream))
(options (copy-list options))
- (filespec (if (stringp filename) (parse-filespec filename) filename)))
- (unless klass
- (setq klass (default-open-class filespec (if element-type-given
- element-type
- nil))))
- (unless klass
- (error 'type-error :datum filename
- :expected-type '(or pathname stream base-string)))
- (cond ((eql klass 'sb-sys::file-stream)
+ (filespec (merge-pathnames filename)))
+ (cond ((eq class 'sb-sys::file-stream)
(remf options :class)
- (remf options :mapped)
- ;; INPUT-HANDLE and OUTPUT-HANDLE must be fixnums or NIL.
- ;; If both are given, they must be the same -- or maybe
- ;; we should make a TWO-WAY-STREAM in that case??
- ;; If they are given, use SYS:MAKE-FD-STREAM to make the
- ;; stream. Direction must be appropriate, too.
- (remf options :input-handle)
- (remf options :output-handle)
- (apply #'open-fd-stream filespec options))
- ((subtypep klass 'simple-stream)
+ (remf options :mapped)
+ (remf options :input-handle)
+ (remf options :output-handle)
+ (apply #'open-fd-stream filespec options))
+ ((subtypep class 'simple-stream)
(when element-type-given
- (error "Can't create simple-streams with an element-type."))
- (when (and (eq klass 'file-simple-stream) mapped)
- (setq klass 'mapped-file-simple-stream)
- (setf (getf options :class) 'mapped-file-simple-stream))
- (when (subtypep klass 'file-simple-stream)
- (when (eq direction :probe)
- (setq klass 'probe-simple-stream)))
- (apply #'make-instance klass (list* :filename filespec options)))
- ((subtypep klass 'fundamental-stream)
- (error "Gray streams are not supported by OPEN."))
- (t
- (if class
- (error "Unable to open streams of class ~S." class)
- (error "DEFAULT-OPEN-CLASS method on ~S instances is broken!"
- (class-name (class-of filespec))))))))
-
-(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)))))))))
+ (error "Can't create simple-streams with an element-type."))
+ (when (and (eq class 'file-simple-stream) mapped)
+ (setq class 'mapped-file-simple-stream)
+ (setf (getf options :class) 'mapped-file-simple-stream))
+ (when (subtypep class 'file-simple-stream)
+ (when (eq direction :probe)
+ (setq class 'probe-simple-stream)))
+ (apply #'make-instance class :filename filespec options))
+ ((subtypep class 'sb-gray:fundamental-stream)
+ (remf options :class)
+ (remf options :mapped)
+ (remf options :input-handle)
+ (remf options :output-handle)
+ (make-instance class :lisp-stream
+ (apply #'open-fd-stream filespec options))))))
-(declaim (inline sc-read-byte dc-read-byte))
-(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))))
-
-(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))))
(declaim (inline read-byte read-char read-char-no-hang unread-char))
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :input)
- (with-stream-class (simple-stream stream)
- (cond ((any-stream-instance-flags stream :eof)
- (sb-impl::eof-or-lose stream eof-error-p eof-value))
- ((any-stream-instance-flags stream :string)
- (with-stream-class (string-simple-stream stream)
- (let ((encap (sm input-handle stream)))
- (unless encap
- (error "Can't read-byte on string streams"))
- (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)))))
- ((any-stream-instance-flags stream :dual)
- (dc-read-byte stream eof-error-p eof-value t))
- (t ;; single-channel-simple-stream
- (sc-read-byte stream eof-error-p eof-value t)))))
+ (%simple-stream-read-byte stream eof-error-p eof-value))
(ansi-stream
(%ansi-stream-read-byte stream eof-error-p eof-value t))
(fundamental-stream
(defun read-char (&optional (stream *standard-input*) (eof-error-p t)
eof-value recursive-p)
"Inputs a character from Stream and returns it."
- (declare (ignore recursive-p))
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :input)
- (with-stream-class (simple-stream)
- (funcall-stm-handler j-read-char stream eof-error-p eof-value t)))
+ (%simple-stream-read-char stream eof-error-p eof-value recursive-p t))
(ansi-stream
(%ansi-stream-read-char stream eof-error-p eof-value t))
(fundamental-stream
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%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))))
+ (%simple-stream-unread-char stream character))
(ansi-stream
(%ansi-stream-unread-char character stream))
(fundamental-stream
(defun peek-char (&optional (peek-type nil) (stream *standard-input*)
(eof-error-p t) eof-value recursive-p)
"Peeks at the next character in the input Stream. See manual for details."
- (declare (ignore recursive-p))
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :input)
- (with-stream-class (simple-stream)
- (let ((char (funcall-stm-handler j-read-char stream
- eof-error-p eof-value t)))
- (cond ((eq char eof-value) char)
- ((characterp peek-type)
- (do ((char char (funcall-stm-handler j-read-char stream
- eof-error-p
- eof-value t)))
- ((or (eq char eof-value) (char= char peek-type))
- (unless (eq char eof-value)
- (funcall-stm-handler j-unread-char stream t))
- char)))
- ((eq peek-type t)
- (do ((char char (funcall-stm-handler j-read-char stream
- eof-error-p
- eof-value t)))
- ((or (eq char eof-value)
- (not (sb-int:whitespace-char-p char)))
- (unless (eq char eof-value)
- (funcall-stm-handler j-unread-char stream t))
- char)))
- (t
- (funcall-stm-handler j-unread-char stream t)
- char)))))
+ (%simple-stream-peek-char stream peek-type eof-error-p eof-value
+ recursive-p))
(ansi-stream
(let ((char (%ansi-stream-read-char stream eof-error-p eof-value t)))
(cond ((eq char eof-value) char)
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :input)
- (with-stream-class (simple-stream stream)
- (if (not (eql width 1))
- (funcall-stm-handler j-listen stream)
- (or (< (sm buffpos stream) (sm buffer-ptr stream))
- ;; Note: should try DEVICE-EXTEND for more on buffer streams
- (when (>= (sm mode stream) 0) ;; device-connected
- (incf (sm last-char-read-size stream))
- (let ((ok (refill-buffer stream nil)))
- (decf (sm last-char-read-size stream))
- (plusp ok)))))))
+ (%simple-stream-listen stream width))
(ansi-stream
(or (/= (the fixnum (sb-kernel:ansi-stream-in-index stream))
sb-impl::+ansi-stream-in-buffer-length+)
(fundamental-stream
(sb-gray:stream-listen stream)))))
-(declaim (inline %simple-stream-read-line))
-(defun %simple-stream-read-line (stream eof-error-p eof-value)
- (declare (type simple-stream stream)
- (optimize (speed 3) (space 2) (safety 0) (debug 0)))
- (with-stream-class (simple-stream)
- (let* ((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-base-string cbuf)
- (type cons bufs tail)
- (type fixnum index total))
- (loop
- (multiple-value-bind (chars done)
- (funcall-stm-handler j-read-chars stream 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
- #-ignore
- (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 read-line (&optional (stream *standard-input*) (eof-error-p t)
eof-value recursive-p)
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :input)
- (%simple-stream-read-line stream eof-error-p eof-value))
+ (%simple-stream-read-line stream eof-error-p eof-value recursive-p))
(ansi-stream
(%ansi-stream-read-line stream eof-error-p eof-value))
(fundamental-stream
(etypecase stream
(simple-stream
(with-stream-class (simple-stream stream)
- (%check-simple-stream stream :input)
- (etypecase seq
- (string
- (funcall-stm-handler j-read-chars stream seq nil start end
- (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")
- ))))
+ (%simple-stream-read-sequence stream seq start end partial-fill)))
(ansi-stream
(%ansi-stream-read-sequence seq stream start end))
(fundamental-stream
(let ((stream (sb-impl::in-synonym-of stream)))
(etypecase stream
(simple-stream
- (with-stream-class (simple-stream stream)
- (%check-simple-stream stream :input)
- (setf (sm buffpos stream) 0
- (sm buffer-ptr stream) 0
- (sm last-char-read-size stream) 0) ;; ??
- (device-clear-input stream buffer-only)))
+ (%simple-stream-clear-input stream buffer-only))
(ansi-stream
(setf (sb-kernel:ansi-stream-in-index stream)
sb-impl::+ansi-stream-in-buffer-length+)
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (cond ((any-stream-instance-flags stream :string)
- (error "Can't write-byte on string streams"))
- ((any-stream-instance-flags stream :dual)
- (let ((ptr (sm outpos stream)))
- (when (>= ptr (sm max-out-pos stream))
- (dc-flush-buffer stream t)
- (setf ptr (1- (sm outpos stream))))
- (setf (sm outpos stream) (1+ ptr))
- (setf (bref (sm out-buffer stream) ptr) integer)))
- (t ;; single-channel-simple-stream
- (let ((ptr (sm buffpos stream)))
- ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
- (when (>= ptr (sm buffer-ptr stream))
- (sc-flush-buffer stream t)
- (setf ptr (1- (sm buffpos stream))))
- (setf (sm buffpos stream) (1+ ptr))
- (setf (bref (sm buffer stream) ptr) integer))))))
+ (%simple-stream-write-byte stream integer))
(ansi-stream
(funcall (sb-kernel:ansi-stream-bout stream) stream integer))
(fundamental-stream
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (funcall-stm-handler-2 j-write-char character stream)))
+ (%simple-stream-write-char stream character))
(ansi-stream
(funcall (sb-kernel:ansi-stream-out stream) stream character))
(fundamental-stream
(end (or end (length string))))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (funcall-stm-handler-2 j-write-chars string stream start end))
+ (%simple-stream-write-string stream string start end)
string)
(ansi-stream
(%ansi-stream-write-string string stream start end))
(end (or end (length seq))))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (etypecase seq
- (string
- (funcall-stm-handler-2 j-write-chars seq stream start end))
- ((or (simple-array (unsigned-byte 8) (*))
- (simple-array (signed-byte 8) (*)))
- ;; TODO: "write-vector" equivalent
- (error "implement me")
- ))))
+ (%simple-stream-write-sequence stream seq start end))
(ansi-stream
(%ansi-stream-write-sequence seq stream start end))
(fundamental-stream
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-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 stream)
- t)))
+ (%simple-stream-fresh-line stream))
(ansi-stream
(when (/= (or (sb-kernel:charpos stream) 1) 0)
(funcall (sb-kernel:ansi-stream-out stream) stream #\Newline)
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (cond ((any-stream-instance-flags stream :string)
- #| nothing to do |#)
- ((any-stream-instance-flags stream :dual)
- (dc-flush-buffer stream t))
- (t
- (sc-flush-buffer stream t)))))
+ (%simple-stream-finish-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :finish-output))
(fundamental-stream
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- (cond ((any-stream-instance-flags stream :string)
- #| nothing to do |#)
- ((any-stream-instance-flags stream :dual)
- (dc-flush-buffer stream nil))
- (t
- (sc-flush-buffer stream nil)))))
+ (%simple-stream-force-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :force-output))
(fundamental-stream
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- (with-stream-class (simple-stream stream)
- #| clear output buffer |#
- (device-clear-output stream)))
+ (%simple-stream-clear-output stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :clear-output))
(fundamental-stream
(sb-gray:stream-clear-output stream))))
nil)
+
(defun file-position (stream &optional position)
"With one argument returns the current position within the file
File-Stream is open to. If the second argument is supplied, then
this becomes the new file position. The second argument may also
be :start or :end for the start and end of the file, respectively."
+ (declare (type (or (integer 0 *) (member nil :start :end)) position))
(etypecase stream
(simple-stream
- (%check-simple-stream stream)
- (cond (position
- ;; set unread to zero
- ;; if position is within buffer, just move pointer; else
- ;; flush output, if necessary
- ;; set buffer pointer to 0, to force a read
- (setf (device-file-position stream) position))
- (t
- (let ((posn (device-file-position stream)))
- ;; adjust for buffer position
- )))
- #| TODO: implement me |#)
+ (%simple-stream-file-position stream position))
(ansi-stream
- (cond (position
- (setf (sb-kernel:ansi-stream-in-index stream)
- sb-impl::+ansi-stream-in-buffer-length+)
- (funcall (sb-kernel:ansi-stream-misc stream)
- stream :file-position position))
- (t
- (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
- stream :file-position nil)))
- (when res
- (- res
- (- sb-impl::+ansi-stream-in-buffer-length+
- (sb-kernel:ansi-stream-in-index stream))))))))
- (fundamental-stream
- (error "file-position not supported on Gray streams."))))
+ (cond
+ (position
+ (setf (sb-kernel:ansi-stream-in-index stream)
+ sb-impl::+ansi-stream-in-buffer-length+)
+ (funcall (sb-kernel:ansi-stream-misc stream)
+ stream :file-position position))
+ (t
+ (let ((res (funcall (sb-kernel:ansi-stream-misc stream)
+ stream :file-position nil)))
+ (when res
+ (- res
+ (- sb-impl::+ansi-stream-in-buffer-length+
+ (sb-kernel:ansi-stream-in-index stream))))))))))
(defun file-length (stream)
"This function returns the length of the file that File-Stream is open to."
(etypecase stream
(simple-stream
- (%check-simple-stream stream)
- (device-file-length stream)
- #| implement me |#)
+ (%simple-stream-file-length stream))
(ansi-stream
- (sb-impl::stream-must-be-associated-with-file stream)
- (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length))
- (fundamental-stream
- (error "file-length not supported on Gray streams."))))
+ (progn (sb-impl::stream-must-be-associated-with-file stream)
+ (funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
(defun line-length (&optional (stream *standard-output*))
"Returns the number of characters that will fit on a line of output on the
(let ((stream (sb-impl::out-synonym-of stream)))
(etypecase stream
(simple-stream
- (%check-simple-stream stream :output)
- #| implement me |#)
+ (%simple-stream-line-length stream))
(ansi-stream
(funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
(fundamental-stream
(length (sb-impl::fd-stream-in-buffer stream)))
(wait-for-input-available (sb-sys:fd-stream-fd stream) timeout))))))
-;;;
-;;; SETUP
-;;;
-
-(defmethod shared-initialize :after ((instance simple-stream) slot-names
- &rest initargs &key &allow-other-keys)
- (declare (ignore slot-names))
- (unless (slot-boundp instance 'melded-stream)
- (setf (slot-value instance 'melded-stream) instance)
- (setf (slot-value instance 'melding-base) instance))
- (unless (device-open instance initargs)
- (device-close instance t)))
-
-;;; From the simple-streams documentation: "A generic function implies
-;;; a specialization capability that does not exist for
-;;; simple-streams; simple-stream specializations should be on
-;;; device-close." So don't do it.
-(defmethod close ((stream simple-stream) &key abort)
- (device-close stream abort))
-
+;; Make PATHNAME and NAMESTRING work
+(defun sb-int:file-name (stream &optional new-name)
+ (typecase stream
+ (file-simple-stream
+ (with-stream-class (file-simple-stream stream)
+ (cond (new-name
+ (%simple-stream-file-rename stream new-name))
+ (t
+ (%simple-stream-file-name stream)))))
+ (sb-sys::file-stream
+ (cond (new-name
+ (setf (sb-impl::fd-stream-pathname stream) new-name)
+ (setf (sb-impl::fd-stream-file stream)
+ (sb-int:unix-namestring new-name nil))
+ t)
+ (t
+ (sb-impl::fd-stream-pathname stream))))))
;;; bugfix
-;;; sat 2003-01-12: What is this for?
+
+;;; TODO: Rudi 2003-01-12: What is this for? Incorporate into sbcl or
+;;; remove it.
#+nil
(defun cl::stream-misc-dispatch (stream operation &optional arg1 arg2)
(declare (type fundamental-stream stream) ;; this is a lie
(values fixnum &optional (member nil t :eof))))
(deftype j-write-char-fn ()
- '(function (character simple-stream) character))
+ '(function ((or character null) simple-stream) (or character null)))
(deftype j-write-chars-fn ()
'(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
(defvar *slot-access-functions* (make-hash-table))
(defvar *automagic-accessors* nil))
+;;; Commented out in favor of standard class machinery that does not
+;;; depend on implementation internals.
+#+nil
(defmacro def-stream-class (name superclasses slots &rest options)
(let ((accessors ())
(real-slots ()))
collect `(setf (gethash ',(car accessor) *slot-access-functions*)
',(cdr accessor)))))))
+
+(defmacro def-stream-class (name superclasses slots &rest options)
+ (let ((slots (copy-tree slots)))
+ (dolist (slot slots) (remf (cdr slot) 'sb-pcl::location))
+ `(defclass ,name ,superclasses ,slots ,@options)))
+
(def-stream-class simple-stream (standard-object stream)
((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
;; A function that determines if one character can be successfully
;; read from stream.
- (j-listen :type j-listen-fn sb-pcl::location 18)
+ (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn sb-pcl::location 18)
;; A function that reads one character.
- (j-read-char :type j-read-char-fn sb-pcl::location 17)
+ (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn sb-pcl::location 17)
;; A function that reads characters into a string.
- (j-read-chars :type j-read-chars-fn sb-pcl::location 16)
+ (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn sb-pcl::location 16)
;; A function that writes one character.
- (j-write-char :type j-write-char-fn sb-pcl::location 15)
+ (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn sb-pcl::location 15)
;; A function that writes characters from a string into the stream.
- (j-write-chars :type j-write-chars-fn sb-pcl::location 14)
+ (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn sb-pcl::location 14)
;; A function that unreads the last character read.
- (j-unread-char :type j-unread-char-fn sb-pcl::location 13)
+ (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn sb-pcl::location 13)
;; Other slots
())
(def-stream-class file-simple-stream (single-channel-simple-stream)
- ((pathname :initform nil :initarg :pathname)
- (filename :initform nil :initarg :filename)
- (original :initform nil :initarg :original)
- (delete-original :initform nil :initarg :delete-original)
+ ((pathname :initform nil :initarg :pathname sb-pcl::location 27)
+ (filename :initform nil :initarg :filename sb-pcl::location 26)
+ (original :initform nil :initarg :original sb-pcl::location 25)
+ (delete-original :initform nil :initarg :delete-original
+ sb-pcl::location 24)
))
(def-stream-class mapped-file-simple-stream (file-simple-stream
;;; A stream with two octet buffers, for example a socket or terminal
;;; stream.
(def-stream-class dual-channel-simple-stream (simple-stream)
- ;; Output buffer.
- ((out-buffer :initform nil :type (or simple-stream-buffer null)
+ (;; Output buffer.
+ (out-buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 26)
;; Current position in output buffer.
(outpos :initform 0 :type fixnum sb-pcl::location 25)
;;; A stream with a string as buffer.
(def-stream-class string-simple-stream (simple-stream)
- ;; The input/output buffer.
- ((buffer :initform nil :type (or simple-stream-buffer null)
+ ())
+
+(def-stream-class composing-stream (string-simple-stream)
+ ())
+
+(def-stream-class string-input-simple-stream (string-simple-stream)
+ (;; The input buffer.
+ (buffer :initform nil :type (or simple-stream-buffer null)
sb-pcl::location 23)
;; Current position in buffer.
(buffpos :initform 0 :type fixnum sb-pcl::location 22)
(buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
(buf-len :initform 0 :type fixnum sb-pcl::location 20)))
-(def-stream-class composing-stream (string-simple-stream)
- ())
-
-(def-stream-class string-input-simple-stream (string-simple-stream)
- ())
-
(def-stream-class string-output-simple-stream (string-simple-stream)
- ;; The output buffer (slot added so that a class can inherit from
- ;; both string-input-simple-stream and string-output-simple-stream
- ;; without the strategies clashing)
- ((out-buffer :initform nil :type (or simple-stream-buffer null)
- sb-pcl::location 26)
+ (;; The input buffer.
+ (buffer :initform nil :type (or simple-stream-buffer null)
+ sb-pcl::location 26)
+ ;; Current position in input buffer.
+ (buffpos :initform 0 :type fixnum sb-pcl::location 25)
+ ;; Maximum valid position in input buffer, or -1 on eof.
+ (buffer-ptr :initform 0 :type fixnum sb-pcl::location 24)
+ (buf-len :initform 0 :type fixnum sb-pcl::location 23)
+ ;; The output buffer (slot added so that a class can inherit from
+ ;; both string-input-simple-stream and string-output-simple-stream
+ ;; without the strategies clashing)
+ (out-buffer :initform nil :type (or simple-stream-buffer null)
+ sb-pcl::location 22)
;; Current position in output buffer.
- (outpos :initform 0 :type fixnum sb-pcl::location 25)
+ (outpos :initform 0 :type fixnum sb-pcl::location 21)
;; Buffer length (one greater than maximum output buffer index)
- (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
+ (max-out-pos :initform 0 :type fixnum sb-pcl::location 20)))
(def-stream-class fill-pointer-output-simple-stream
(string-output-simple-stream)
(defgeneric device-clear-output (stream))
-(defgeneric device-extend (stream need action))
-
(defgeneric device-finish-record (stream blocking action))
+++ /dev/null
-;;; -*- Lisp -*-
-
-;;; 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.
-
-;;; Some constants that are not (yet?) in sbcl itself. Basically,
-;;; constants needed for calling mmap from sbcl.
-
-;;; TODO (Rudi 2003-05-12): The contents of this file, along with
-;;; unix.lisp, should presumably end up somewhere else, either in sbcl
-;;; itself or in sb-posix.
-
-("stdio.h" "sys/types.h" "sys/stat.h" "fcntl.h" "errno.h" "sys/mman.h")
-
-((:integer eacces "EACCES" "Error code for access error")
- (:integer prot-none "PROT_NONE" "mmap: no protection")
- (:integer prot-read "PROT_READ" "mmap: read protection")
- (:integer prot-write "PROT_WRITE" "mmap: write protection")
- (:integer prot-exec "PROT_EXEC" "mmap: execute protection")
- (:integer map-shared "MAP_SHARED" "mmap: shared memory")
- (:integer map-private "MAP_PRIVATE" "mmap: private mapping")
- (:integer map-fixed "MAP_FIXED" "mmap: map at given location"))
-
-
;;; forms, the inner with-stream-class form must specify a stream
;;; argument if the outer one specifies one, or the wrong object will
;;; be accessed.
+
+;;; Commented out in favor of standard class machinery that does not
+;;; depend on implementation internals.
+#+nil
(defmacro with-stream-class ((class-name &optional stream) &body body)
(if stream
(let ((stm (gensym "STREAM"))
- (slt (gensym)))
+ (slt (gensym "SV")))
`(let* ((,stm ,stream)
(,slt (sb-pcl::std-instance-slots ,stm)))
(declare (type ,class-name ,stm) (ignorable ,slt))
(t `(slot-value ,stream ',slot-name))))))
,@body)))
+
+(defmacro with-stream-class ((class-name &optional stream) &body body)
+ (if stream
+ (let ((stm (gensym "STREAM"))
+ (slt (gensym "SV")))
+ `(let* ((,stm ,stream)
+ (,slt (sb-kernel:%instance-ref ,stm 1)))
+ (declare (type ,class-name ,stm)
+ (type simple-vector ,slt)
+ (ignorable ,slt))
+ (macrolet ((sm (slot-name stream)
+ (declare (ignore stream))
+ #-count-sm
+ `(slot-value ,',stm ',slot-name)
+ #+count-sm
+ `(%sm ',slot-name ,',stm))
+ (add-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(setf (sm %flags ,',stm) (logior (sm %flags ,',stm)
+ ,(%flags flags))))
+ (remove-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(setf (sm %flags ,',stm) (logandc2 (sm %flags ,',stm)
+ ,(%flags flags))))
+ (any-stream-instance-flags (stream &rest flags)
+ (declare (ignore stream))
+ `(not (zerop (logand (sm %flags ,',stm)
+ ,(%flags flags))))))
+ ,@body)))
+ `(macrolet ((sm (slot-name stream)
+ #-count-sm
+ `(slot-value ,stream ',slot-name)
+ #+count-sm
+ `(%sm ',slot-name ,stream)))
+ ,@body)))
+
+;;; Commented out in favor of standard class machinery that does not
+;;; depend on implementation internals.
+#+nil
(defmacro sm (slot-name stream)
(let ((slot-access (gethash slot-name *slot-access-functions*)))
(warn "Using ~S macro outside ~S" 'sm 'with-stream-class)
`(the ,(car slot-access) (,(cdr slot-access) ,stream)))
(t `(slot-value ,stream ',slot-name)))))
+
+(defmacro sm (slot-name stream)
+ "Access the named slot in Stream."
+ (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
+ `(slot-value ,stream ',slot-name))
+
(defmacro funcall-stm-handler (slot-name stream &rest args)
(let ((s (gensym)))
`(let ((,s ,stream))
(with-stream-class (simple-stream ,s)
(not (zerop (logand (sm %flags ,s) ,(%flags flags))))))))
+(defmacro simple-stream-dispatch (stream single dual string)
+ (let ((s (gensym "STREAM")))
+ `(let ((,s ,stream))
+ (with-stream-class (simple-stream ,s)
+ (let ((%flags (sm %flags ,s)))
+ (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
+ ,single)
+ ((zerop (logand %flags ,(%flags '(:string))))
+ ,dual)
+ (t
+ ,string)))))))
(declaim (inline buffer-sap bref (setf bref) buffer-copy))
(make-array size :element-type '(unsigned-byte 8))))
(defun free-buffer (buffer)
- (when (not (vectorp buffer))
+ (when (sb-sys:system-area-pointer-p buffer)
(push buffer sb-impl::*available-buffers*))
t)
((:rename :rename-and-delete)
(setf mask (logior mask sb-unix:o_creat)))
((:new-version :supersede)
- (setf mask (logior mask sb-unix:o_trunc)))
- (:append
- (setf mask (logior mask sb-unix:o_append)))))
+ (setf mask (logior mask sb-unix:o_trunc)))))
(t
(setf if-exists nil))) ; :ignore-this-arg
(unless if-does-not-exist-given
(sb-unix:unix-open name mask mode)
(values nil sb-unix:enoent))
(cond ((sb-int:fixnump fd)
+ (when (eql if-exists :append)
+ (sb-unix:unix-lseek fd 0 sb-unix:l_xtnd))
(return (values fd name original delete-original)))
((eql errno sb-unix:enoent)
(case if-does-not-exist
:overwrite :append :supersede nil) if-exists)
(type (member :error :create nil) if-does-not-exist)
(ignore external-format))
- (setq pathname (pathname pathname))
- (multiple-value-bind (fd namestring original delete-original)
- (%fd-open pathname direction if-exists if-exists-given
- if-does-not-exist if-does-not-exist-given)
- (when fd
- (case direction
- ((:input :output :io)
- (sb-sys:make-fd-stream fd
- :input (member direction '(:input :io))
- :output (member direction '(:output :io))
- :element-type element-type
- :file namestring
- :original original
- :delete-original delete-original
- :pathname pathname
- :input-buffer-p t
- :auto-close t))
- (:probe
- (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
- :pathname pathname
- :element-type element-type)))
- (close stream)
- stream))))))
-
-
-;; Make PATHNAME and NAMESTRING work
-(defun cl::file-name (stream &optional new-name)
- (typecase stream
- (file-simple-stream
- (with-stream-class (file-simple-stream stream)
- (cond (new-name
- (setf (sm pathname stream) new-name)
- (setf (sm filename stream) (sb-int:unix-namestring new-name nil))
- t)
- (t
- (sm pathname stream)))))
- (sb-sys::file-stream
- (cond (new-name
- (setf (sb-impl::fd-stream-pathname stream) new-name)
- (setf (sb-impl::fd-stream-file stream)
- (sb-int:unix-namestring new-name nil))
- t)
- (t
- (sb-impl::fd-stream-pathname stream))))))
+ (let ((filespec (merge-pathnames pathname)))
+ (multiple-value-bind (fd namestring original delete-original)
+ (%fd-open filespec direction if-exists if-exists-given
+ if-does-not-exist if-does-not-exist-given)
+ (when fd
+ (case direction
+ ((:input :output :io)
+ (sb-sys:make-fd-stream fd
+ :input (member direction '(:input :io))
+ :output (member direction '(:output :io))
+ :element-type element-type
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream (sb-impl::%make-fd-stream :name namestring :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream)))))))
+
;; Experimental "filespec" stuff
;;; -*- lisp -*-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (require :sb-grovel))
-(defpackage #:sb-simple-stream-system (:use #:asdf #:cl #:sb-grovel))
+(defpackage #:sb-simple-stream-system (:use #:asdf #:cl))
(in-package #:sb-simple-stream-system)
(defsystem sb-simple-streams
- :depends-on (sb-grovel sb-bsd-sockets)
+ :depends-on (sb-bsd-sockets sb-posix)
:components ((:file "package")
(:file "fndb")
- (grovel-constants-file "constants"
- :package :sb-simple-streams
- :pathname "constants.lisp"
- :depends-on ("package"))
- (:file "unix" :depends-on ("constants"))
;;(:file "pcl")
;;(:file "ext-format" :depends-on ("package"))
(:file "classes" :depends-on ("package"))
(:file "internal" :depends-on ("classes"))
(:file "strategy" :depends-on ("internal"))
(:file "cl" :depends-on ("internal" "fndb"))
- (:file "simple-streams" :depends-on ("cl" "strategy" "unix"))
+ (:file "simple-streams" :depends-on ("cl" "strategy"))
;;(:file "gray-compat" :depends-on ("package"))
;;(:file "iodefs" :depends-on ("package"))
))
(in-package #:sb-simple-streams-test)
(defparameter *dumb-string*
- "This file created by simple-stream-tests.lisp. Nothing to see here, move along.")
+ "This file was created by simple-stream-tests.lisp. Nothing to see here, move along.")
(defparameter *test-path*
(merge-pathnames (make-pathname :name nil :type nil :version nil)
(eval-when (:load-toplevel) (ensure-directories-exist *test-path*))
+(defmacro with-test-file ((stream file &rest open-arguments
+ &key (delete-afterwards t)
+ initial-content
+ &allow-other-keys)
+ &body body)
+ (remf open-arguments :delete-afterwards)
+ (remf open-arguments :initial-content)
+ (if initial-content
+ (let ((create-file-stream (gensym)))
+ `(progn
+ (with-open-file (,create-file-stream ,file :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (write-sequence ,initial-content ,create-file-stream))
+ (unwind-protect
+ (with-open-file (,stream ,file ,@open-arguments)
+ (progn ,@body))
+ ,(when delete-afterwards `(ignore-errors (delete-file ,file))))))
+ `(unwind-protect
+ (with-open-file (,stream ,file ,@open-arguments)
+ (progn ,@body))
+ ,(when delete-afterwards `(ignore-errors (delete-file ,file))))))
(deftest create-file-1
(with-open-stream (s (make-instance 'file-simple-stream
:filename file
:direction :output
- :if-exists :overwrite))
+ :if-exists :overwrite
+ :if-does-not-exist :create))
(string= (write-string *dumb-string* s) *dumb-string*))
(delete-file file)))
t)
(deftest create-file-2
;; Create a file-simple-stream via :class argument to open, write data.
(let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
- (prog1
- (with-open-file (s file
- :class 'file-simple-stream
- :direction :output :if-exists :overwrite)
- (string= (write-string *dumb-string* s) *dumb-string*))
- (delete-file file)))
+ (with-test-file (s file :class 'file-simple-stream :direction :output
+ :if-exists :overwrite :if-does-not-exist :create)
+ (string= (write-string *dumb-string* s) *dumb-string*)))
t)
(deftest create-read-file-1
;; Via file-simple-stream objects, write and then re-read data.
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
- (with-open-stream (s (make-instance 'file-simple-stream
- :filename file
- :direction :output
- :if-exists :overwrite))
+ (with-test-file (s file :class 'file-simple-stream :direction :output
+ :if-exists :overwrite :if-does-not-exist :create
+ :delete-afterwards nil)
(write-line *dumb-string* s)
(setf result (and result (string= (write-string *dumb-string* s)
*dumb-string*))))
- (with-open-stream (s (make-instance 'file-simple-stream
- :filename file
- :direction :input
- :if-does-not-exist :error))
+
+ (with-test-file (s file :class 'file-simple-stream
+ :direction :input :if-does-not-exist :error)
;; Check first line
(multiple-value-bind (string missing-newline-p)
(read-line s)
(read-line s)
(setf result (and result (string= string *dumb-string*)
missing-newline-p))))
- (delete-file file)
result)
t)
;; Read data via a mapped-file-simple-stream object.
(let ((result t)
(file (merge-pathnames #p"test-data.txt" *test-path*)))
- (with-open-file (s file
- :class 'file-simple-stream
- :direction :output :if-exists :overwrite)
- (setf result (and result (string= (write-string *dumb-string* s)
- *dumb-string*))))
- (with-open-file (s file
- :class 'mapped-file-simple-stream
- :direction :input)
- (setf result (and result (string= (read-line s) *dumb-string*))))
- (delete-file file)
+ (with-test-file (s file :class 'mapped-file-simple-stream
+ :direction :input :if-does-not-exist :error
+ :initial-content *dumb-string*)
+ (setf result (and result (string= (read-line s) *dumb-string*))))
result)
t)
;; (single-channel simple-stream)
(let* ((file (merge-pathnames #p"test-data.txt" *test-path*))
(stream (make-instance 'file-simple-stream
- :filename file
- :direction :output))
+ :filename file :direction :output
+ :if-exists :overwrite
+ :if-does-not-exist :create))
(content (make-string (1+ (device-buffer-length stream))
:initial-element #\x)))
(with-open-stream (s stream)
(write-string content s))
- (with-open-stream (s (make-instance 'file-simple-stream
- :filename file
- :direction :input))
- (prog1 (string= content (read-line s))
- (delete-file file))))
+ (with-test-file (s file :class 'file-simple-stream
+ :direction :input :if-does-not-exist :error)
+ (string= content (read-line s))))
t)
(deftest write-read-large-dc-1
(sb-bsd-sockets::connection-refused-error () t))
t)
+
+(deftest file-position-1
+ ;; Test reading of file-position
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :input
+ :initial-content *dumb-string*)
+ (file-position s)))
+ 0)
+
+;;; file-position-2 fails ONLY when called with
+;;; (asdf:oos 'asdf:test-op :sb-simple-streams)
+;;; TODO: Find out why
+#+nil
+(deftest file-position-2
+ ;; Test reading of file-position
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :input
+ :initial-content *dumb-string*)
+ (read-byte s)
+ (file-position s)))
+ 1)
+
+(deftest file-position-3
+ ;; Test reading of file-position in the presence of unsaved data
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :output
+ :if-exists :supersede :if-does-not-exist :create)
+ (write-byte 50 s)
+ (file-position s)))
+ 1)
+
+(deftest file-position-4
+ ;; Test file position when opening with :if-exists :append
+ (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-exists :append :if-does-not-exist :create
+ :initial-content "Foo")
+ (= (file-length s) (file-position s))))
+ T)
+
+(deftest write-read-unflushed-sc-1
+ ;; Write something into a single-channel stream and read it back
+ ;; without explicitly flushing the buffer in-between
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-does-not-exist :create :if-exists :supersede)
+ (write-char #\x s)
+ (file-position s :start)
+ (read-char s)))
+ #\x)
+
+(deftest write-read-unflushed-sc-2
+ ;; Write something into a single-channel stream, try to read back too much
+ (handler-case
+ (let* ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-does-not-exist :create :if-exists :supersede)
+ (write-char #\x s)
+ (file-position s :start)
+ (read-char s)
+ (read-char s))
+ nil)
+ (end-of-file () t))
+ t)
+
+(deftest write-read-unflushed-sc-3
+ (let ((file (merge-pathnames #p"test-data.txt" *test-path*))
+ (result t))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-exists :overwrite :if-does-not-exist :create
+ :initial-content *dumb-string*)
+ (setq result (and result (char= (read-char s) (char *dumb-string* 0))))
+ (setq result (and result (= (file-position s) 1)))
+ (let ((pos (file-position s)))
+ (write-char #\x s)
+ (file-position s pos)
+ (setq result (and result (char= (read-char s) #\x)))))
+ result)
+ t)
+
+(deftest write-read-unflushed-sc-4
+ ;; Test flushing of buffers
+ (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-exists :overwrite :if-does-not-exist :create
+ :initial-content "Foo"
+ :delete-afterwards nil)
+ (read-char s) ; Fill the buffer.
+ (file-position s :start) ; Change existing data.
+ (write-char #\X s)
+ (file-position s :end) ; Extend file.
+ (write-char #\X s))
+ (with-test-file (s file :class 'file-simple-stream :direction :input
+ :if-does-not-exist :error)
+ (read-line s)))
+ "XooX"
+ T)
+
+(deftest write-read-append-sc-1
+ ;; Test writing in the middle of a stream opened in append mode
+ (let ((file (merge-pathnames #p"test-data.txt" *test-path*)))
+ (with-test-file (s file :class 'file-simple-stream :direction :io
+ :if-exists :append :if-does-not-exist :create
+ :initial-content "Foo"
+ :delete-afterwards nil)
+ (file-position s :start) ; Jump to beginning.
+ (write-char #\X s)
+ (file-position s :end) ; Extend file.
+ (write-char #\X s))
+ (with-test-file (s file :class 'file-simple-stream :direction :input
+ :if-does-not-exist :error)
+ (read-line s)))
+ "XooX"
+ T)
+
+
+
+
(in-package "SB-SIMPLE-STREAMS")
;;;
+;;; SETUP
+;;;
+
+(defmethod shared-initialize :after ((instance simple-stream) slot-names
+ &rest initargs &key &allow-other-keys)
+ (declare (ignore slot-names))
+ (unless (slot-boundp instance 'melded-stream)
+ (setf (slot-value instance 'melded-stream) instance)
+ (setf (slot-value instance 'melding-base) instance))
+ (unless (device-open instance initargs)
+ (device-close instance t)))
+
+;;; From the simple-streams documentation: "A generic function implies
+;;; a specialization capability that does not exist for
+;;; simple-streams; simple-stream specializations should be on
+;;; device-close." So don't do it.
+(defmethod close ((stream simple-stream) &key abort)
+ (device-close stream abort))
+
+
+;;; This takes care of the things all device-close methods have to do,
+;;; regardless of the type of simple-stream
+(defmethod device-close :around ((stream simple-stream) abort)
+ (with-stream-class (simple-stream stream)
+ (when (any-stream-instance-flags stream :input :output)
+ (when (any-stream-instance-flags stream :output)
+ (if abort
+ (clear-output stream)
+ (force-output stream)))
+ (call-next-method)
+ (setf (sm input-handle stream) nil
+ (sm output-handle stream) nil
+ (sm j-listen stream) #'sb-kernel::closed-flame
+ (sm j-read-char stream) #'sb-kernel::closed-flame
+ (sm j-read-chars stream) #'sb-kernel::closed-flame
+ (sm j-unread-char stream) #'sb-kernel::closed-flame
+ (sm j-write-char stream) #'sb-kernel::closed-flame ;@@
+ (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@
+ (remove-stream-instance-flags stream :input :output)
+ (sb-ext:cancel-finalization stream))))
+
+;;;
;;; Stream printing
;;;
+(defmethod print-object ((object simple-stream) stream)
+ (print-unreadable-object (object stream :type nil :identity nil)
+ (cond ((not (any-stream-instance-flags object :simple))
+ (princ "Invalid " stream))
+ ((not (any-stream-instance-flags object :input :output))
+ (princ "Closed " stream)))
+ (format stream "~:(~A~)" (type-of object))))
+
(defmethod print-object ((object file-simple-stream) stream)
- (print-unreadable-object (object stream :type t :identity t)
- (format stream "for ~S" (slot-value object 'filename))))
+ (print-unreadable-object (object stream :type nil :identity nil)
+ (with-stream-class (file-simple-stream object)
+ (cond ((not (any-stream-instance-flags object :simple))
+ (princ "Invalid " stream))
+ ((not (any-stream-instance-flags object :input :output))
+ (princ "Closed " stream)))
+ (format stream "~:(~A~) for ~S"
+ (type-of object) (sm filename object)))))
(defun make-control-table (&rest inits)
(let ((table (make-array 32 :initial-element nil)))
(defvar *terminal-control-in-table*
(make-control-table #\Newline #'std-dc-newline-in-handler))
+(defun find-external-format (name)
+ nil)
+
;;;
;;; LOW LEVEL STUFF
;;;
(defun vector-elt-width (vector)
;; Return octet-width of vector elements
(etypecase vector
- ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
- ;; [and base-char, which is treated specially]
+ ;; (simple-array fixnum (*)) not supported
+ ;; (simple-array base-char (*)) treated specially; don't call this
+ ((simple-array bit (*)) 1)
+ ((simple-array (unsigned-byte 2) (*)) 1)
+ ((simple-array (unsigned-byte 4) (*)) 1)
((simple-array (signed-byte 8) (*)) 1)
((simple-array (unsigned-byte 8) (*)) 1)
((simple-array (signed-byte 16) (*)) 2)
(defun endian-swap-value (vector endian-swap)
(case endian-swap
- (:network-order (case (vector-elt-width vector)
- (1 0)
- (2 1)
- (4 3)
- (8 7)
- (16 15)))
+ (:network-order (1- (vector-elt-width vector)))
(:byte-8 0)
(:byte-16 1)
(:byte-32 3)
(:byte-128 15)
(otherwise endian-swap)))
+
(defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
(declare (type (sb-kernel:simple-unboxed-array (*)) vector)
(type stream stream))
(simple-array (signed-byte 8) (*))
(simple-array (unsigned-byte 8) (*))))
(error "Wrong vector type for read-vector on stream not of type simple-stream."))
+ ;; FIXME: implement blocking/non-blocking semantics here as well
(read-sequence vector stream :start (or start 0) :end end))))
#|(defun write-vector ...)|#
-;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun getpagesize ()
- (sb-unix::int-syscall ("getpagesize"))))
-
(defun read-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
(type (or null simple-stream-buffer) buffer)
(tagbody
again
;; Avoid CMUCL gengc write barrier
- (do ((i start (+ i ;#.(sb-unix:unix-getpagesize)
- (the fixnum (getpagesize)))))
+ (do ((i start (+ i (the fixnum (sb-posix:getpagesize)))))
((>= i end))
(declare (type fixnum i))
(setf (bref buffer i) 0))
(incf count bytes)
(incf start bytes))
(cond ((null bytes)
- (format t "~&;; UNIX-READ: errno=~D~%" errno)
+ (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
(cond ((= errno sb-unix:eintr) (go again))
((and blocking
(or (= errno ;;sb-unix:eagain
;; Handle encapsulated stream. FIXME: perhaps handle
;; sbcl-vintage ansi-stream type in read-octets too?
(stream (read-octets fd buffer start end blocking))
- (t (error "Don't know how to handle input handle &A" fd))))))
+ (t (error "Don't know how to handle input handle &S" fd))))))
(defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
;;; IMPLEMENTATIONS
;;;
-(defmethod device-open ((stream null-simple-stream) options)
- (add-stream-instance-flags stream :simple :input :output)
- stream)
+
+;;; simple-stream, dual-channel-simple-stream,
+;;; single-channel-simple-stream
+
+(defmethod device-buffer-length ((stream simple-stream))
+ 4096)
+
+(defmethod device-file-position ((stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :dual)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (sm buffpos stream)))
+ ((any-stream-instance-flags stream :string)
+ (with-stream-class (string-simple-stream stream)
+ (sm buffpos stream)))
+ (t
+ (with-stream-class (single-channel-simple-stream stream)
+ (sm buffpos stream))))))
+
+
+(defmethod (setf device-file-position) (value (stream simple-stream))
+ (with-stream-class (simple-stream stream)
+ (cond ((any-stream-instance-flags stream :dual)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setf (sm buffpos stream) value)))
+ ((any-stream-instance-flags stream :string)
+ (with-stream-class (string-simple-stream stream)
+ (setf (sm buffpos stream) value)))
+ (t
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf (sm buffpos stream) value))))))
+
+(defmethod device-file-length ((stream simple-stream))
+ nil)
+
+(defmethod device-read ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ ;; rudi (2003-06-07): this block commented out in Paul Foley's code
+;; (when (and (null buffer) (not (eql start end)))
+;; (with-stream-class (single-channel-simple-stream stream)
+;; (setq buffer (sm buffer stream))
+;; (setq end (sm buf-len stream))))
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-read ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ (when (null buffer)
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setq buffer (sm buffer stream))
+ (setq end (- (sm buf-len stream) start))))
+ (read-octets stream buffer start end blocking))
+
+(defmethod device-clear-input ((stream simple-stream) buffer-only)
+ (declare (ignore buffer-only))
+ nil)
+
+(defmethod device-write ((stream single-channel-simple-stream) buffer
+ start end blocking)
+ (when (and (null buffer) (not (eql start end)))
+ (with-stream-class (single-channel-simple-stream stream)
+ (setf buffer (sm buffer stream))
+ (setf end (sm buffpos stream))))
+ (write-octets stream buffer start end blocking))
+
+(defmethod device-write ((stream dual-channel-simple-stream) buffer
+ start end blocking)
+ (when (and (null buffer) (not (eql start end)))
+ (with-stream-class (dual-channel-simple-stream stream)
+ (setf buffer (sm out-buffer stream))
+ (setf end (sm outpos stream))))
+ (write-octets stream buffer start end blocking))
+
+(defmethod device-clear-output ((stream simple-stream))
+ nil)
+
+
+;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
+
+(defmethod device-file-length ((stream direct-simple-stream))
+ ;; return buffer length
+ )
(defmethod device-open ((stream buffer-input-simple-stream) options)
#| do something |#
#| do something |#
stream)
+
+;;; Definition of File-Simple-Stream and relations
+
(defun open-file-stream (stream options)
(let ((filename (pathname (getf options :filename)))
(direction (getf options :direction :input))
(if-exists (getf options :if-exists))
- (if-exists-given (not (getf options :if-exists t)))
+ (if-exists-given (not (eql (getf options :if-exists t) t)))
(if-does-not-exist (getf options :if-does-not-exist))
- (if-does-not-exist-given (not (getf options :if-does-not-exist t))))
+ (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
(with-stream-class (file-simple-stream stream)
(ecase direction
(:input (add-stream-instance-flags stream :input))
(sm buf-len stream) length)))
(when (any-stream-instance-flags stream :output)
(setf (sm control-out stream) *std-control-out-table*))
- (install-single-channel-character-strategy
- stream (getf options :external-format :default) nil))))
+ (let ((efmt (getf options :external-format :default)))
+ (compose-encapsulating-streams stream efmt)
+ (install-single-channel-character-strategy stream efmt nil)))))
+
+(defmethod device-close ((stream file-simple-stream) abort)
+ (with-stream-class (file-simple-stream stream)
+ (cond (abort
+ ;; TODO:
+ ;; Remove any fd-handler
+ ;; If it's an output stream and has an original name,
+ ;; revert the file
+ )
+ (t
+ ;; TODO:
+ ;; If there's an original name and delete-original is set
+ ;; kill the original
+ ))
+ (if (sm input-handle stream)
+ (sb-unix:unix-close (sm input-handle stream))
+ (sb-unix:unix-close (sm output-handle stream)))
+ (setf (sm buffer stream) nil))
+ t)
+
+(defmethod device-file-position ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (values (sb-unix:unix-lseek (or (sm input-handle stream)
+ (sm output-handle stream))
+ 0
+ sb-unix:l_incr))))
+
+(defmethod (setf device-file-position) (value (stream file-simple-stream))
+ (declare (type fixnum value))
+ (with-stream-class (file-simple-stream stream)
+ (values (sb-unix:unix-lseek (or (sm input-handle stream)
+ (sm output-handle stream))
+ value
+ (if (minusp value)
+ sb-unix:l_xtnd
+ sb-unix:l_set)))))
+
+(defmethod device-file-length ((stream file-simple-stream))
+ (with-stream-class (file-simple-stream stream)
+ (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
+ (sb-unix:unix-fstat (sm input-handle stream))
+ (declare (ignore dev ino mode nlink uid gid rdev))
+ (if okay size nil))))
(defmethod device-open ((stream mapped-file-simple-stream) options)
(with-stream-class (mapped-file-simple-stream stream)
(when (open-file-stream stream options)
(let* ((input (any-stream-instance-flags stream :input))
(output (any-stream-instance-flags stream :output))
- (prot (logior (if input PROT-READ 0)
- (if output PROT-WRITE 0)))
+ (prot (logior (if input sb-posix::PROT-READ 0)
+ (if output sb-posix::PROT-WRITE 0)))
(fd (or (sm input-handle stream) (sm output-handle stream))))
(multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
(sb-unix:unix-fstat fd)
;; BUF-MAX and BUF-PTR have to be the same, which means
;; number-consing every time BUF-PTR moves...
;; Probably don't have the address space available to map
- ;; bigger files, anyway. Maybe DEVICE-EXTEND can adjust
- ;; the mapped portion of the file?
+ ;; bigger files, anyway.
(warn "Unable to memory-map entire file.")
(setf size most-positive-fixnum))
(let ((buffer
- (sb-unix:unix-mmap nil size prot MAP-SHARED fd 0)))
+ (handler-case
+ (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
+ (sb-posix:syscall-error nil))))
(when (null buffer)
(sb-unix:unix-close fd)
(sb-ext:cancel-finalization stream)
stream (getf options :external-format :default) 'mapped)
(sb-ext:finalize stream
(lambda ()
- (sb-unix:unix-munmap buffer size)
+ (sb-posix:munmap buffer size)
(format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
stream))
-(defmethod device-open ((stream string-input-simple-stream) options)
- #| do something |#
- stream)
+(defmethod device-close ((stream mapped-file-simple-stream) abort)
+ (with-stream-class (mapped-file-simple-stream stream)
+ (when (sm buffer stream)
+ (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
+ (setf (sm buffer stream) nil))
+ (cond (abort
+ ;; remove any FD handler
+ ;; if it has an original name (is this possible for mapped files?)
+ ;; revert the file
+ )
+ (t
+ ;; if there's an original name and delete-original is set (again,
+ ;; is this even possible?), kill the original
+ ))
+ (sb-unix:unix-close (sm input-handle stream)))
+ t)
-(defmethod device-open ((stream string-output-simple-stream) options)
- #| do something |#
- stream)
-(defmethod device-open ((stream xp-simple-stream) options)
- #| do something |#
- stream)
+;;; Definition of Null-Simple-Stream
-(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
- #| do something |#
+
+(defmethod device-open ((stream null-simple-stream) options)
+ (with-stream-class (null-simple-stream stream)
+ (add-stream-instance-flags stream :simple :input :output)
+ ;;(install-single-channel-character-strategy
+ ;; stream (getf options :external-format :default) nil)
+ (setf (sm j-read-char stream) #'null-read-char
+ (sm j-read-chars stream) #'null-read-chars
+ (sm j-unread-char stream) #'null-unread-char
+ (sm j-write-char stream) #'null-write-char
+ (sm j-write-chars stream) #'null-write-chars
+ (sm j-listen stream) #'null-listen))
stream)
+
+(defmethod device-buffer-length ((stream null-simple-stream))
+ 256)
+
+(defmethod device-read ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer start end blocking))
+ -1)
+
+(defmethod device-write ((stream null-simple-stream) buffer
+ start end blocking)
+ (declare (ignore buffer blocking))
+ (- end start))
+
+
+;;; Socket-Simple-Stream and relatives
+
+
(defmethod device-open ((stream socket-base-simple-stream) options)
#| do something |#
stream)
(sb-unix:unix-close fd)
(format *terminal-io*
"~&;;; ** closed socket (fd ~D)~%" fd))))
- ;; Now frob the stream slots.
+ ;; Now frob the stream slots. FIXME: should we handle a
+ ;; :direction arg from output, defaulting to :input only?
(add-stream-instance-flags stream :simple :input :output :dual)
(unless (sm buffer stream)
(let ((length (device-buffer-length stream)))
stream (getf options :external-format :default)))
stream))
-(defmethod device-open ((stream terminal-simple-stream) options)
- (with-stream-class (terminal-simple-stream stream)
- (when (getf options :input-handle)
- (setf (sm input-handle stream) (getf options :input-handle))
- (add-stream-instance-flags stream :simple :interactive :dual :input)
- (unless (sm buffer stream)
- (let ((length (device-buffer-length stream)))
- (setf (sm buffer stream) (make-string length)
- (sm buf-len stream) length)))
- (setf (sm control-in stream) *terminal-control-in-table*))
- (when (getf options :output-handle)
- (setf (sm output-handle stream) (getf options :output-handle))
- (add-stream-instance-flags stream :simple :interactive :dual :output)
- (unless (sm out-buffer stream)
- (let ((length (device-buffer-length stream)))
- (setf (sm out-buffer stream) (make-string length)
- (sm max-out-pos stream) length)))
- (setf (sm control-out stream) *std-control-out-table*))
- (install-dual-channel-character-strategy
- stream (getf options :external-format :default)))
- #| do something |#
- stream)
-
-
-(defmethod device-close :around ((stream simple-stream) abort)
- (with-stream-class (simple-stream stream)
- (when (any-stream-instance-flags stream :input :output)
- (when (any-stream-instance-flags stream :output)
- (if abort
- (clear-output stream)
- (force-output stream)))
- (call-next-method)
- (setf (sm input-handle stream) nil
- (sm output-handle stream) nil)
- (remove-stream-instance-flags stream :input :output)
- (sb-ext:cancel-finalization stream))))
-
-(defmethod device-close ((stream simple-stream) abort)
- (declare (ignore abort))
- t)
-
-(defmethod device-close ((stream file-simple-stream) abort)
- (with-stream-class (file-simple-stream stream)
- (cond (abort
- ;; Remove any fd-handler
- ;; If it's an output stream and has an original name,
- ;; revert the file
- )
- (t
- ;; If there's an original name and delete-original is set
- ;; kill the original
- ))
- (if (sm input-handle stream)
- (sb-unix:unix-close (sm input-handle stream))
- (sb-unix:unix-close (sm output-handle stream)))
- (setf (sm buffer stream) nil))
- t)
-
-(defmethod device-close ((stream mapped-file-simple-stream) abort)
- (with-stream-class (mapped-file-simple-stream stream)
- (when (sm buffer stream)
- (sb-unix:unix-munmap (sm buffer stream) (sm buf-len stream))
- (setf (sm buffer stream) nil))
- (cond (abort
- ;; remove any FD handler
- ;; if it has an original name (is this possible for mapped files?)
- ;; revert the file
- )
- (t
- ;; if there's an original name and delete-original is set (again,
- ;; is this even possible?), kill the original
- ))
- (sb-unix:unix-close (sm input-handle stream)))
- t)
-
(defmethod device-close ((stream socket-simple-stream) abort)
;; Abort argument is handled by :around method on base class
(declare (ignore abort))
(sb-ext:cancel-finalization stream)
t)
-(defmethod device-buffer-length ((stream simple-stream))
- 4096)
-
-(defmethod device-buffer-length ((stream null-simple-stream))
- 256)
-
-(defmethod device-file-position ((stream simple-stream))
- (with-stream-class (simple-stream stream)
- ;; this may be wrong if :DUAL flag is set!
- (sm buffpos stream)))
+;;; String-Simple-Stream and relatives
-(defmethod (setf device-file-position) (value (stream simple-stream))
- (with-stream-class (simple-stream stream)
- ;; this may be wrong if :DUAL flag is set!
- (setf (sm buffpos stream) value)))
(defmethod device-file-position ((stream string-simple-stream))
;; get string length (of input or output buffer?)
;; set string length (of input or output buffer?)
)
+(defmethod device-file-length ((stream string-simple-stream))
+ ;; return string length
+ )
+
+(defmethod device-open :before ((stream string-input-simple-stream) options)
+ (with-stream-class (string-input-simple-stream stream)
+ (let ((string (getf options :string)))
+ (when (and string (null (sm buffer stream)))
+ (let ((start (getf options :start))
+ (end (or (getf options :end) (length string))))
+ (setf (sm buffer stream) string
+ (sm buffpos stream) start
+ (sm buffer-ptr stream) end))))
+ (install-string-input-character-strategy stream)
+ (add-stream-instance-flags stream :string :input :simple)))
+
+(defmethod device-open :before ((stream string-output-simple-stream) options)
+ (with-stream-class (string-output-simple-stream stream)
+ (unless (sm out-buffer stream)
+ (let ((string (getf options :string)))
+ (if string
+ (setf (sm out-buffer stream) string
+ (sm max-out-pos stream) (length string))
+ (let ((buflen (max (device-buffer-length stream) 16)))
+ (setf (sm out-buffer stream) (make-string buflen)
+ (sm max-out-pos stream) buflen)))))
+ (unless (sm control-out stream)
+ (setf (sm control-out stream) *std-control-out-table*))
+ (install-string-output-character-strategy stream)
+ (add-stream-instance-flags stream :string :output :simple)))
+
+
+(defmethod device-open ((stream string-input-simple-stream) options)
+ #| do something |#
+ stream)
+
+
+(defmethod device-open ((stream string-output-simple-stream) options)
+ #| do something |#
+ stream)
+
+
+(defmethod device-open ((stream xp-simple-stream) options)
+ #| do something |#
+ stream)
+
+(defmethod device-open ((stream fill-pointer-output-simple-stream) options)
+ #| do something |#
+ stream)
+
(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
;; get fill pointer (of input or output buffer?)
)
;; set fill pointer (of input or output buffer?)
)
-(defmethod device-file-position ((stream file-simple-stream))
- (with-stream-class (file-simple-stream stream)
- (values (sb-unix:unix-lseek (or (sm input-handle stream)
- (sm output-handle stream))
- 0
- sb-unix:l_incr))))
-(defmethod (setf device-file-position) (value (stream file-simple-stream))
- (declare (type fixnum value))
- (with-stream-class (file-simple-stream stream)
- (values (sb-unix:unix-lseek (or (sm input-handle stream)
- (sm output-handle stream))
- value
- (if (minusp value)
- sb-unix:l_xtnd
- sb-unix:l_set)))))
+;;; Terminal-Simple-Stream
+(defmethod device-open ((stream terminal-simple-stream) options)
+ (with-stream-class (terminal-simple-stream stream)
+ (when (getf options :input-handle)
+ (setf (sm input-handle stream) (getf options :input-handle))
+ (add-stream-instance-flags stream :simple :interactive :dual :input)
+ (unless (sm buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm buffer stream) (make-string length)
+ (sm buf-len stream) length)))
+ (setf (sm control-in stream) *terminal-control-in-table*))
+ (when (getf options :output-handle)
+ (setf (sm output-handle stream) (getf options :output-handle))
+ (add-stream-instance-flags stream :simple :interactive :dual :output)
+ (unless (sm out-buffer stream)
+ (let ((length (device-buffer-length stream)))
+ (setf (sm out-buffer stream) (make-string length)
+ (sm max-out-pos stream) length)))
+ (setf (sm control-out stream) *std-control-out-table*))
+ (install-dual-channel-character-strategy
+ stream (getf options :external-format :default)))
+ ;; TODO (rudi 2003-06-08): when neither input-handle nor
+ ;; output-handle are given, close the stream again.
+ #| do something |#
+ stream)
-(defmethod device-file-length ((stream simple-stream))
- nil)
+(defmethod device-read ((stream terminal-simple-stream) buffer
+ start end blocking)
+ (let ((result (call-next-method)))
+ (if (= result -1) -2 result)))
-(defmethod device-file-length ((stream direct-simple-stream))
- ;; return buffer length
+(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
)
-(defmethod device-file-length ((stream string-simple-stream))
- ;; return string length
- )
+(defmethod device-close ((stream simple-stream) abort)
+ (declare (ignore abort))
+ t)
+
+
+
+
+
-(defmethod device-file-length ((stream file-simple-stream))
- (with-stream-class (file-simple-stream stream)
- (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
- (sb-unix:unix-fstat (sm input-handle stream))
- (declare (ignore dev ino mode nlink uid gid rdev))
- (if okay size nil))))
-(defmethod device-read ((stream single-channel-simple-stream) buffer
- start end blocking)
-;; (when (and (null buffer) (not (eql start end)))
-;; (with-stream-class (single-channel-simple-stream stream)
-;; (setq buffer (sm buffer stream))
-;; (setq end (sm buf-len stream))))
- (read-octets stream buffer start end blocking))
-(defmethod device-read ((stream dual-channel-simple-stream) buffer
- start end blocking)
- (when (null buffer)
- (with-stream-class (dual-channel-simple-stream stream)
- (setq buffer (sm buffer stream))
- (setq end (- (sm buf-len stream) start))))
- (read-octets stream buffer start end blocking))
-(defmethod device-read ((stream null-simple-stream) buffer
- start end blocking)
- (declare (ignore buffer start end blocking))
- -1)
(defmethod device-read ((stream terminal-simple-stream) buffer
start end blocking)
(if (= result -1) -2 result)))
-(defmethod device-clear-input ((stream simple-stream) buffer-only)
- (declare (ignore buffer-only))
- nil)
(defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
)
-(defmethod device-write ((stream single-channel-simple-stream) buffer
- start end blocking)
- (when (and (null buffer) (not (eql start end)))
- (with-stream-class (single-channel-simple-stream stream)
- (setf buffer (sm buffer stream))
- (setf end (sm buffpos stream))))
- (write-octets stream buffer start end blocking))
-
-(defmethod device-write ((stream dual-channel-simple-stream) buffer
- start end blocking)
- (when (and (null buffer) (not (eql start end)))
- (with-stream-class (dual-channel-simple-stream stream)
- (setf buffer (sm out-buffer stream))
- (setf end (sm outpos stream))))
- (write-octets stream buffer start end blocking))
-
-(defmethod device-write ((stream null-simple-stream) buffer
- start end blocking)
- (declare (ignore buffer blocking))
- (- end start))
(defmethod device-write ((stream socket-base-simple-stream) buffer
start end blocking)
(call-next-method))
-(defmethod device-clear-output ((stream simple-stream))
- nil)
-(defmethod device-extend ((stream direct-simple-stream) need action)
- (declare (ignore need action))
- nil)
-(defmethod device-extend ((stream string-input-simple-stream) need action)
- (declare (ignore need action))
- nil)
-(defmethod device-extend ((stream string-output-simple-stream) need action)
- ;; @@3
- )
-
-(defmethod device-extend ((stream fill-pointer-output-simple-stream)
- need action)
- ;; @@4
- )
-
-(defmethod device-extend ((stream mapped-file-simple-stream) need action)
- (declare (ignore need action))
- nil)
;; device-finish-record apparently has no methods defined
(in-package "SB-SIMPLE-STREAMS")
-(defun refill-buffer (stream blocking)
- (with-stream-class (simple-stream stream)
+
+(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))
(let* ((unread (sm last-char-read-size stream))
- (buffer (sm buffer stream)))
+ (buffer (sm buffer stream)))
(unless (zerop unread)
- ;; Keep last read character at beginning of buffer
- (buffer-copy buffer (- (sm buffer-ptr stream) unread) buffer 0 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))))
+ (declare (type fixnum bytes))
+ (setf (sm buffpos stream) unread
+ (sm buffer-ptr stream) (if (plusp bytes)
+ (+ bytes unread)
+ unread))
+ bytes))))
+
(defun sc-flush-buffer (stream blocking)
(with-stream-class (single-channel-simple-stream stream)
(let ((ptr 0)
(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)
+ (setf (device-file-position stream)
+ (- (device-file-position stream) (sm buffer-ptr stream))))
(loop
- (when (>= ptr bytes) (setf (sm buffpos stream) 0) (return))
+ (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 nil 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)
(with-stream-class (dual-channel-simple-stream stream)
(let ((ptr 0)
(bytes (sm outpos stream)))
(declare (type fixnum ptr bytes))
(loop
- (when (>= ptr bytes) (setf (sm outpos stream) 0) (return))
+ (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)
(progn
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))
- (let ((bytes (refill-buffer stream blocking)))
+ (let ((bytes (sc-refill-buffer stream blocking)))
(declare (type fixnum bytes))
(unless (minusp bytes)
(let ((ptr (sm buffpos stream)))
(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)
- ;; Should arrange for the last character to be unreadable
+ ;; FIXME: Should arrange for the last character to be unreadable
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(max (sm buffer-ptr stream))
(prog1
(bref buffer ptr)
(incf ptr))
- (let ((bytes (refill-buffer stream blocking)))
+ (let ((bytes (sc-refill-buffer stream blocking)))
(declare (type fixnum bytes))
(setf ptr (sm buffpos stream)
max (sm buffer-ptr stream))
(type fixnum start end)
(type boolean blocking)
(optimize (speed 3) (space 2) (safety 0) (debug 0)))
- ;; TODO: what about the blocking parameter?
+ (declare (ignore blocking)) ; everything is in the buffer
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
(funcall (the (or symbol function) (svref ctrl code))
stream character))
(return-from sc-write-char character))
- ;; FIXME: Shouldn't this be buf-len, not buffer-ptr?
- (unless (< ptr (sm buffer-ptr stream))
- (sc-flush-buffer stream t)
- (setf ptr (sm buffpos stream)))
+ (when (>= ptr (sm buf-len stream))
+ (setf ptr (sc-flush-buffer stream t)))
(setf (bref buffer ptr) code)
- (setf (sm buffpos stream) (1+ ptr))))
+ (setf (sm buffpos stream) (1+ ptr))
+ (add-stream-instance-flags stream :dirty)))
character)
(declaim (ftype j-write-chars-fn sc-write-chars))
(with-stream-class (single-channel-simple-stream stream)
(do ((buffer (sm buffer stream))
(ptr (sm buffpos stream))
- ;; xxx buffer-ptr or buf-len? TODO: look them up in the
- ;; docs; was: buffer-ptr, but it's initialized to 0 in
- ;; (device-open file-simple-stream); buf-len seems to work(tm)
- (max #+nil(sm buffer-ptr stream) ;; or buf-len?
- (sm buf-len 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) count)
+ ((>= posn end)
+ (setf (sm buffpos stream) ptr)
+ (add-stream-instance-flags stream :dirty)
+ count)
(declare (type fixnum ptr max 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))
(-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
;;;
(progn
(setf (sm buffpos stream) (1+ ptr))
(bref buffer ptr))
- (let ((bytes (refill-buffer stream blocking)))
+ (let ((bytes (dc-refill-buffer stream blocking)))
(declare (type fixnum bytes))
(unless (minusp bytes)
(let ((ptr (sm buffpos stream)))
(prog1
(bref buffer ptr)
(incf ptr))
- (let ((bytes (refill-buffer stream blocking)))
+ (let ((bytes (dc-refill-buffer stream blocking)))
(declare (type fixnum bytes))
(setf ptr (sm buffpos stream)
max (sm buffer-ptr stream))
(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
+ (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)))
+ (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))
- )))
+ (setf (sm outpos stream) (1+ ptr)))))
character)
(declaim (ftype j-write-chars-fn dc-write-chars))
(-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 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
(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
+ (with-stream-class (simple-stream)
+ (loop
+ (when (eq (sm melded-stream stream) (sm melding-base stream))
+ (return stream))
+ (setq stream (sm melded-stream stream)))))
(defun install-single-channel-character-strategy (stream external-format
access)
- (declare (ignore 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)))
+ (find-external-format external-format)
+ (let ((stream (%find-topmost-stream stream)))
+ ;; 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))))
stream)
(defun install-dual-channel-character-strategy (stream external-format)
- (declare (ignore external-format))
- (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))
+ (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)))
stream)
-(defun install-string-character-strategy (stream)
- (with-stream-class (string-simple-stream stream)
- (setf (sm j-read-char stream) #'string-read-char))
+(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)))
stream)
+
+(defun install-string-output-character-strategy (stream)
+ #| 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)))))))
+
+;;;
+;;; NULL STRATEGY FUNCTIONS
+;;;
+
+(declaim (ftype j-read-char-fn null-read-char))
+(defun null-read-char (stream eof-error-p eof-value blocking)
+ (declare (ignore blocking))
+ (sb-impl::eof-or-lose stream eof-error-p eof-value))
+
+(declaim (ftype j-read-chars-fn null-read-chars))
+(defun null-read-chars (stream string search start end blocking)
+ (declare (ignore stream string search start end blocking))
+ (values 0 :eof))
+
+(declaim (ftype j-unread-char-fn null-unread-char))
+(defun null-unread-char (stream relaxed)
+ (declare (ignore stream relaxed)))
+
+(declaim (ftype j-write-char-fn null-write-char))
+(defun null-write-char (character stream)
+ (declare (ignore stream))
+ character)
+
+(declaim (ftype j-write-chars-fn null-write-chars))
+(defun null-write-chars (string stream start end)
+ (declare (ignore string stream))
+ (- end start))
+
+(declaim (ftype j-listen-fn null-listen))
+(defun null-listen (stream)
+ (declare (ignore stream))
+ nil)
+++ /dev/null
-;;; -*- lisp -*-
-
-;;; 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.
-
-;;; TODO (Rudi 2003-05-12): The contents of this file, along with
-;;; constants.lisp, should presumably end up somewhere else, either in
-;;; sbcl itself or in sb-posix.
-
-(in-package "SB-UNIX")
-
-
-(export '(prot-read prot-write prot-exec prot-none
- map-shared map-private map-fixed
- unix-mmap unix-munmap
- unix-mlock unix-munlock))
-
-
-(defun unix-mmap (addr length prot flags fd offset)
- (declare (type (or null system-area-pointer) addr)
- (type (unsigned-byte 32) length)
- (type (integer 1 7) prot)
- (type (unsigned-byte 32) flags)
- (type (or null unix-fd) fd)
- (type (signed-byte 32) offset))
- (let ((result (alien-funcall (extern-alien "mmap"
- (function system-area-pointer
- system-area-pointer
- size-t int int int
- off-t))
- (or addr (sb-sys:int-sap 0)) length prot flags
- (or fd -1) offset)))
- ;; FIXME (Rudi 2003-05-12) : here, we assume that a sap is 32
- ;; bits. Revisit during the 64-bit port. #XFFFFFFFF is (void
- ;; *)-1, which is the charming return value of mmap on failure.
- (if (= (sb-sys:sap-int result) #XFFFFFFFF)
- (values nil (get-errno))
- result)))
-
-(defun unix-munmap (start length)
- (declare (type system-area-pointer start)
- (type (unsigned-byte 32) length))
- (void-syscall ("munmap" system-area-pointer size-t) start length))
-
-(defun unix-mlock (addr length)
- (declare (type system-area-pointer addr)
- (type (unsigned-byte 32) length))
- (void-syscall ("mlock" system-area-pointer size-t) addr length))
-
-(defun unix-munlock (addr length)
- (declare (type system-area-pointer addr)
- (type (unsigned-byte 32) length))
- (void-syscall ("munlock" system-area-pointer size-t) addr length))
-
-
-
projects / sbcl.git / commitdiff