292 lines
11 KiB
Common Lisp
292 lines
11 KiB
Common Lisp
#+xcvb (module (:depends-on ("package")))
|
|
|
|
(in-package :trivial-gray-streams)
|
|
|
|
(defclass fundamental-stream (impl-specific-gray:fundamental-stream) ())
|
|
(defclass fundamental-input-stream
|
|
(fundamental-stream impl-specific-gray:fundamental-input-stream) ())
|
|
(defclass fundamental-output-stream
|
|
(fundamental-stream impl-specific-gray:fundamental-output-stream) ())
|
|
(defclass fundamental-character-stream
|
|
(fundamental-stream impl-specific-gray:fundamental-character-stream) ())
|
|
(defclass fundamental-binary-stream
|
|
(fundamental-stream impl-specific-gray:fundamental-binary-stream) ())
|
|
(defclass fundamental-character-input-stream
|
|
(fundamental-input-stream fundamental-character-stream
|
|
impl-specific-gray:fundamental-character-input-stream) ())
|
|
(defclass fundamental-character-output-stream
|
|
(fundamental-output-stream fundamental-character-stream
|
|
impl-specific-gray:fundamental-character-output-stream) ())
|
|
(defclass fundamental-binary-input-stream
|
|
(fundamental-input-stream fundamental-binary-stream
|
|
impl-specific-gray:fundamental-binary-input-stream) ())
|
|
(defclass fundamental-binary-output-stream
|
|
(fundamental-output-stream fundamental-binary-stream
|
|
impl-specific-gray:fundamental-binary-output-stream) ())
|
|
|
|
(defgeneric stream-read-sequence
|
|
(stream sequence start end &key &allow-other-keys))
|
|
(defgeneric stream-write-sequence
|
|
(stream sequence start end &key &allow-other-keys))
|
|
|
|
(defgeneric stream-file-position (stream))
|
|
(defgeneric (setf stream-file-position) (newval stream))
|
|
|
|
;;; Default methods for stream-read/write-sequence.
|
|
;;;
|
|
;;; It would be nice to implement default methods
|
|
;;; in trivial gray streams, maybe borrowing the code
|
|
;;; from some of CL implementations. But now, for
|
|
;;; simplicity we will fallback to default implementation
|
|
;;; of the implementation-specific analogue function which calls us.
|
|
|
|
(defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key)
|
|
(declare (ignore seq start end))
|
|
'fallback)
|
|
|
|
(defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key)
|
|
(declare (ignore seq start end))
|
|
'fallback)
|
|
|
|
(defmacro or-fallback (&body body)
|
|
`(let ((result ,@body))
|
|
(if (eq result (quote fallback))
|
|
(call-next-method)
|
|
result)))
|
|
|
|
;; Implementations should provide this default method, I believe, but
|
|
;; at least sbcl and allegro don't.
|
|
(defmethod stream-terpri ((stream fundamental-output-stream))
|
|
(write-char #\newline stream))
|
|
|
|
;; stream-file-position could be specialized to
|
|
;; fundamental-stream, but to support backward
|
|
;; compatibility with flexi-streams, we specialize
|
|
;; it on T. The reason: flexi-streams calls stream-file-position
|
|
;; for non-gray stream:
|
|
;; https://github.com/edicl/flexi-streams/issues/4
|
|
(defmethod stream-file-position ((stream t))
|
|
nil)
|
|
|
|
(defmethod (setf stream-file-position) (newval (stream t))
|
|
(declare (ignore newval))
|
|
nil)
|
|
|
|
#+abcl
|
|
(progn
|
|
(defmethod gray-streams:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
(defmethod gray-streams:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
(defmethod gray-streams:stream-write-string
|
|
((stream xp::xp-structure) string &optional (start 0) (end (length string)))
|
|
(xp::write-string+ string stream start end))
|
|
|
|
#+#.(cl:if (cl:and (cl:find-package :gray-streams)
|
|
(cl:find-symbol "STREAM-FILE-POSITION" :gray-streams))
|
|
'(:and)
|
|
'(:or))
|
|
(defmethod gray-streams:stream-file-position
|
|
((s fundamental-stream) &optional position)
|
|
(if position
|
|
(setf (stream-file-position s) position)
|
|
(stream-file-position s))))
|
|
|
|
#+allegro
|
|
(progn
|
|
(defmethod excl:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
(defmethod excl:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
(defmethod excl::stream-file-position
|
|
((stream fundamental-stream) &optional position)
|
|
(if position
|
|
(setf (stream-file-position stream) position)
|
|
(stream-file-position stream))))
|
|
|
|
;; Untill 2014-08-09 CMUCL did not have stream-file-position:
|
|
;; http://trac.common-lisp.net/cmucl/ticket/100
|
|
#+cmu
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(when (find-symbol (string '#:stream-file-position) '#:ext)
|
|
(pushnew :cmu-has-stream-file-position *features*)))
|
|
|
|
#+cmu
|
|
(progn
|
|
(defmethod ext:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod ext:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
#+cmu-has-stream-file-position
|
|
(defmethod ext:stream-file-position ((stream fundamental-stream))
|
|
(stream-file-position stream))
|
|
|
|
#+cmu-has-stream-file-position
|
|
(defmethod (setf ext:stream-file-position) (position (stream fundamental-stream))
|
|
(setf (stream-file-position stream) position)))
|
|
|
|
#+lispworks
|
|
(progn
|
|
(defmethod stream:stream-read-sequence
|
|
((s fundamental-input-stream) seq start end)
|
|
(or-fallback (stream-read-sequence s seq start end)))
|
|
(defmethod stream:stream-write-sequence
|
|
((s fundamental-output-stream) seq start end)
|
|
(or-fallback (stream-write-sequence s seq start end)))
|
|
|
|
(defmethod stream:stream-file-position ((stream fundamental-stream))
|
|
(stream-file-position stream))
|
|
(defmethod (setf stream:stream-file-position)
|
|
(newval (stream fundamental-stream))
|
|
(setf (stream-file-position stream) newval)))
|
|
|
|
#+openmcl
|
|
(progn
|
|
(defmethod ccl:stream-read-vector
|
|
((s fundamental-input-stream) seq start end)
|
|
(or-fallback (stream-read-sequence s seq start end)))
|
|
(defmethod ccl:stream-write-vector
|
|
((s fundamental-output-stream) seq start end)
|
|
(or-fallback (stream-write-sequence s seq start end)))
|
|
|
|
(defmethod ccl:stream-read-list ((s fundamental-input-stream) list count)
|
|
(or-fallback (stream-read-sequence s list 0 count)))
|
|
(defmethod ccl:stream-write-list ((s fundamental-output-stream) list count)
|
|
(or-fallback (stream-write-sequence s list 0 count)))
|
|
|
|
(defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position)
|
|
(if new-position
|
|
(setf (stream-file-position stream) new-position)
|
|
(stream-file-position stream))))
|
|
|
|
;; up to version 2.43 there were no
|
|
;; stream-read-sequence, stream-write-sequence
|
|
;; functions in CLISP
|
|
#+clisp
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(when (find-symbol (string '#:stream-read-sequence) '#:gray)
|
|
(pushnew :clisp-has-stream-read/write-sequence *features*)))
|
|
|
|
#+clisp
|
|
(progn
|
|
|
|
#+clisp-has-stream-read/write-sequence
|
|
(defmethod gray:stream-read-sequence
|
|
(seq (s fundamental-input-stream) &key start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
#+clisp-has-stream-read/write-sequence
|
|
(defmethod gray:stream-write-sequence
|
|
(seq (s fundamental-output-stream) &key start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
|
|
;;; for old CLISP
|
|
(defmethod gray:stream-read-byte-sequence
|
|
((s fundamental-input-stream)
|
|
seq
|
|
&optional start end no-hang interactive)
|
|
(when no-hang
|
|
(error "this stream does not support the NO-HANG argument"))
|
|
(when interactive
|
|
(error "this stream does not support the INTERACTIVE argument"))
|
|
(or-fallback (stream-read-sequence s seq start end)))
|
|
|
|
(defmethod gray:stream-write-byte-sequence
|
|
((s fundamental-output-stream)
|
|
seq
|
|
&optional start end no-hang interactive)
|
|
(when no-hang
|
|
(error "this stream does not support the NO-HANG argument"))
|
|
(when interactive
|
|
(error "this stream does not support the INTERACTIVE argument"))
|
|
(or-fallback (stream-write-sequence s seq start end)))
|
|
|
|
(defmethod gray:stream-read-char-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq start end)))
|
|
|
|
(defmethod gray:stream-write-char-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq start end)))
|
|
|
|
;;; end of old CLISP read/write-sequence support
|
|
|
|
(defmethod gray:stream-position ((stream fundamental-stream) position)
|
|
(if position
|
|
(setf (stream-file-position stream) position)
|
|
(stream-file-position stream))))
|
|
|
|
#+sbcl
|
|
(progn
|
|
(defmethod sb-gray:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod sb-gray:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod sb-gray:stream-file-position
|
|
((stream fundamental-stream) &optional position)
|
|
(if position
|
|
(setf (stream-file-position stream) position)
|
|
(stream-file-position stream)))
|
|
;; SBCL extension:
|
|
(defmethod sb-gray:stream-line-length ((stream fundamental-stream))
|
|
80))
|
|
|
|
#+(or ecl clasp)
|
|
(progn
|
|
(defmethod gray::stream-file-position
|
|
((stream fundamental-stream) &optional position)
|
|
(if position
|
|
(setf (stream-file-position stream) position)
|
|
(stream-file-position stream)))
|
|
(defmethod gray:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod gray:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))))
|
|
|
|
#+mocl
|
|
(progn
|
|
(defmethod gray:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod gray:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod gray:stream-file-position
|
|
((stream fundamental-stream) &optional position)
|
|
(if position
|
|
(setf (stream-file-position stream) position)
|
|
(stream-file-position stream))))
|
|
|
|
#+genera
|
|
(progn
|
|
(defmethod gray-streams:stream-read-sequence
|
|
((s fundamental-input-stream) seq &optional start end)
|
|
(or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod gray-streams:stream-write-sequence
|
|
((s fundamental-output-stream) seq &optional start end)
|
|
(or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
|
|
(defmethod gray-streams:stream-file-position
|
|
((stream fundamental-stream))
|
|
(stream-file-position stream))
|
|
(defmethod (setf gray-streams:stream-file-position)
|
|
(position (stream fundamental-stream))
|
|
(setf (stream-file-position stream) position)))
|
|
|
|
;; deprecated
|
|
(defclass trivial-gray-stream-mixin () ())
|
|
|