streams.lisp

;;;; -*- Mode: LISP; Base: 10; Syntax: ANSI-Common-lisp; Package: TRIVIAL-GRAY-STREAMS -*-

#+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 mkcl)
(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)))

#+mezzano
(progn
  (defmethod mezzano.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 mezzano.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 mezzano.gray:stream-file-position
      ((stream fundamental-stream) &optional position)
    (if position
	(setf (stream-file-position stream) position)
	(stream-file-position stream))))

;; deprecated
(defclass trivial-gray-stream-mixin () ())