sbcl stuff
This commit is contained in:
Ian Keane
parent
1d1dbc34df
commit
5d91dbb667
335 changed files with 119806 additions and 1 deletions
|
|
@ -0,0 +1,292 @@
|
|||
#+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 () ())
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue