(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
(t (return (- -10 errno)))))
((zerop count) (return -1))
(t (return count)))))))))))
- (t (error "implement me"))))))
+ ;; 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 ~S" fd))))))
(defun write-octets (stream buffer start end blocking)
(declare (type simple-stream stream)
(incf count bytes)
(incf start bytes))
(cond ((null bytes)
- (format t "~&;; UNIX-WRITE: errno=~D~%" errno)
+ (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
+ errno)
(cond ((= errno sb-unix:eintr) (go again))
;; don't block for subsequent chars
(t (return (- -10 errno)))))
(t (return count)))))))))))
- (t (error "implement me"))))))
+ ;; Handle encapsulated stream. FIXME: perhaps handle
+ ;; sbcl-vintage ansi-stream type in write-octets too?
+ (stream (write-octets fd buffer start end blocking))
+ (t (error "Don't know how to handle output handle &A" fd))))))
;;;
;;; 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))))
+ (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))))
+ (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 (getf options :filename))
+ (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-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)
+
+
+;;; Definition of Null-Simple-Stream
+
+
+(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)
+
+(defmethod device-open ((stream socket-simple-stream) options)
+ (with-stream-class (socket-simple-stream stream)
+ (let* ((remote-host (getf options :remote-host))
+ (remote-port (getf options :remote-port))
+ (socket (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream :protocol :tcp)))
+ (setf (sm socket stream) socket)
+ (sb-bsd-sockets:socket-connect socket remote-host remote-port)
+ (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
+ ;; Connect stream to socket, ...
+ (setf (sm input-handle stream) fd)
+ (setf (sm output-handle stream) fd)
+ ;; ... and socket to stream.
+ (setf (slot-value socket 'stream) stream)
+ (sb-ext:cancel-finalization socket)
+ (sb-ext:finalize stream
+ (lambda ()
+ (sb-unix:unix-close fd)
+ (format *terminal-io*
+ "~&;;; ** closed socket (fd ~D)~%" fd))))
+ ;; 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)))
+ ;; Buffer should be array of (unsigned-byte 8), in general
+ ;; use strings for now so it's easy to read the content...
+ (setf (sm buffer stream) (make-string length)
+ (sm buffpos stream) 0
+ (sm buffer-ptr stream) 0
+ (sm buf-len stream) length)))
+ (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-in stream) *terminal-control-in-table*)
+ (setf (sm control-out stream) *std-control-out-table*)
+ (install-dual-channel-character-strategy
+ stream (getf options :external-format :default)))
+ stream))
+
+(defmethod device-close ((stream socket-simple-stream) abort)
+ ;; Abort argument is handled by :around method on base class
+ (declare (ignore abort))
+ (with-stream-class (socket-simple-stream stream)
+ (sb-unix:unix-close (sm input-handle stream))
+ (setf (sm buffer stream) nil)
+ (setf (sm out-buffer stream) nil))
+ (sb-ext:cancel-finalization stream)
+ t)
+
+
+;;; String-Simple-Stream and relatives
+
+
+(defmethod device-file-position ((stream string-simple-stream))
+ ;; get string length (of input or output buffer?)
+ )
+
+(defmethod (setf device-file-position) (value (stream string-simple-stream))
+ ;; 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)
#| do something |#
stream)
-(defmethod device-open ((stream socket-base-simple-stream) options)
- #| do something |#
- stream)
+(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
+ ;; get fill pointer (of input or output buffer?)
+ )
-(defmethod device-open ((stream socket-simple-stream) options)
- #| do something |#
- stream)
+(defmethod (setf device-file-position)
+ (value (stream fill-pointer-output-simple-stream))
+ ;; set fill pointer (of input or output buffer?)
+ )
+
+
+;;; Terminal-Simple-Stream
(defmethod device-open ((stream terminal-simple-stream) options)
(with-stream-class (terminal-simple-stream stream)
(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-read ((stream terminal-simple-stream) buffer
+ start end blocking)
+ (let ((result (call-next-method)))
+ (if (= result -1) -2 result)))
-(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-clear-input ((stream terminal-simple-stream) buffer-only)
+ )
(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-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)))
-
-(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?)
- )
-
-(defmethod (setf device-file-position) (value (stream string-simple-stream))
- ;; set string length (of input or output buffer?)
- )
-
-(defmethod device-file-position ((stream fill-pointer-output-simple-stream))
- ;; get fill pointer (of input or output buffer?)
- )
-
-(defmethod (setf device-file-position)
- (value (stream fill-pointer-output-simple-stream))
- ;; 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)))))
-(defmethod device-file-length ((stream simple-stream))
- nil)
-(defmethod device-file-length ((stream direct-simple-stream))
- ;; return buffer length
- )
-(defmethod device-file-length ((stream string-simple-stream))
- ;; return string length
- )
-(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
projects / sbcl.git / blobdiff