3rdparties/software/trivial-gray-streams-20181018-git/streams.lisp (11484 bytes)
1 #+xcvb (module (:depends-on ("package"))) 2 3 (in-package :trivial-gray-streams) 4 5 (defclass fundamental-stream (impl-specific-gray:fundamental-stream) ()) 6 (defclass fundamental-input-stream 7 (fundamental-stream impl-specific-gray:fundamental-input-stream) ()) 8 (defclass fundamental-output-stream 9 (fundamental-stream impl-specific-gray:fundamental-output-stream) ()) 10 (defclass fundamental-character-stream 11 (fundamental-stream impl-specific-gray:fundamental-character-stream) ()) 12 (defclass fundamental-binary-stream 13 (fundamental-stream impl-specific-gray:fundamental-binary-stream) ()) 14 (defclass fundamental-character-input-stream 15 (fundamental-input-stream fundamental-character-stream 16 impl-specific-gray:fundamental-character-input-stream) ()) 17 (defclass fundamental-character-output-stream 18 (fundamental-output-stream fundamental-character-stream 19 impl-specific-gray:fundamental-character-output-stream) ()) 20 (defclass fundamental-binary-input-stream 21 (fundamental-input-stream fundamental-binary-stream 22 impl-specific-gray:fundamental-binary-input-stream) ()) 23 (defclass fundamental-binary-output-stream 24 (fundamental-output-stream fundamental-binary-stream 25 impl-specific-gray:fundamental-binary-output-stream) ()) 26 27 (defgeneric stream-read-sequence 28 (stream sequence start end &key &allow-other-keys)) 29 (defgeneric stream-write-sequence 30 (stream sequence start end &key &allow-other-keys)) 31 32 (defgeneric stream-file-position (stream)) 33 (defgeneric (setf stream-file-position) (newval stream)) 34 35 ;;; Default methods for stream-read/write-sequence. 36 ;;; 37 ;;; It would be nice to implement default methods 38 ;;; in trivial gray streams, maybe borrowing the code 39 ;;; from some of CL implementations. But now, for 40 ;;; simplicity we will fallback to default implementation 41 ;;; of the implementation-specific analogue function which calls us. 42 43 (defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key) 44 (declare (ignore seq start end)) 45 'fallback) 46 47 (defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key) 48 (declare (ignore seq start end)) 49 'fallback) 50 51 (defmacro or-fallback (&body body) 52 `(let ((result ,@body)) 53 (if (eq result (quote fallback)) 54 (call-next-method) 55 result))) 56 57 ;; Implementations should provide this default method, I believe, but 58 ;; at least sbcl and allegro don't. 59 (defmethod stream-terpri ((stream fundamental-output-stream)) 60 (write-char #\newline stream)) 61 62 ;; stream-file-position could be specialized to 63 ;; fundamental-stream, but to support backward 64 ;; compatibility with flexi-streams, we specialize 65 ;; it on T. The reason: flexi-streams calls stream-file-position 66 ;; for non-gray stream: 67 ;; https://github.com/edicl/flexi-streams/issues/4 68 (defmethod stream-file-position ((stream t)) 69 nil) 70 71 (defmethod (setf stream-file-position) (newval (stream t)) 72 (declare (ignore newval)) 73 nil) 74 75 #+abcl 76 (progn 77 (defmethod gray-streams:stream-read-sequence 78 ((s fundamental-input-stream) seq &optional start end) 79 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 80 81 (defmethod gray-streams:stream-write-sequence 82 ((s fundamental-output-stream) seq &optional start end) 83 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 84 85 (defmethod gray-streams:stream-write-string 86 ((stream xp::xp-structure) string &optional (start 0) (end (length string))) 87 (xp::write-string+ string stream start end)) 88 89 #+#.(cl:if (cl:and (cl:find-package :gray-streams) 90 (cl:find-symbol "STREAM-FILE-POSITION" :gray-streams)) 91 '(:and) 92 '(:or)) 93 (defmethod gray-streams:stream-file-position 94 ((s fundamental-stream) &optional position) 95 (if position 96 (setf (stream-file-position s) position) 97 (stream-file-position s)))) 98 99 #+allegro 100 (progn 101 (defmethod excl:stream-read-sequence 102 ((s fundamental-input-stream) seq &optional start end) 103 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 104 105 (defmethod excl:stream-write-sequence 106 ((s fundamental-output-stream) seq &optional start end) 107 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 108 109 (defmethod excl::stream-file-position 110 ((stream fundamental-stream) &optional position) 111 (if position 112 (setf (stream-file-position stream) position) 113 (stream-file-position stream)))) 114 115 ;; Untill 2014-08-09 CMUCL did not have stream-file-position: 116 ;; http://trac.common-lisp.net/cmucl/ticket/100 117 #+cmu 118 (eval-when (:compile-toplevel :load-toplevel :execute) 119 (when (find-symbol (string '#:stream-file-position) '#:ext) 120 (pushnew :cmu-has-stream-file-position *features*))) 121 122 #+cmu 123 (progn 124 (defmethod ext:stream-read-sequence 125 ((s fundamental-input-stream) seq &optional start end) 126 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 127 (defmethod ext:stream-write-sequence 128 ((s fundamental-output-stream) seq &optional start end) 129 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 130 131 #+cmu-has-stream-file-position 132 (defmethod ext:stream-file-position ((stream fundamental-stream)) 133 (stream-file-position stream)) 134 135 #+cmu-has-stream-file-position 136 (defmethod (setf ext:stream-file-position) (position (stream fundamental-stream)) 137 (setf (stream-file-position stream) position))) 138 139 #+lispworks 140 (progn 141 (defmethod stream:stream-read-sequence 142 ((s fundamental-input-stream) seq start end) 143 (or-fallback (stream-read-sequence s seq start end))) 144 (defmethod stream:stream-write-sequence 145 ((s fundamental-output-stream) seq start end) 146 (or-fallback (stream-write-sequence s seq start end))) 147 148 (defmethod stream:stream-file-position ((stream fundamental-stream)) 149 (stream-file-position stream)) 150 (defmethod (setf stream:stream-file-position) 151 (newval (stream fundamental-stream)) 152 (setf (stream-file-position stream) newval))) 153 154 #+openmcl 155 (progn 156 (defmethod ccl:stream-read-vector 157 ((s fundamental-input-stream) seq start end) 158 (or-fallback (stream-read-sequence s seq start end))) 159 (defmethod ccl:stream-write-vector 160 ((s fundamental-output-stream) seq start end) 161 (or-fallback (stream-write-sequence s seq start end))) 162 163 (defmethod ccl:stream-read-list ((s fundamental-input-stream) list count) 164 (or-fallback (stream-read-sequence s list 0 count))) 165 (defmethod ccl:stream-write-list ((s fundamental-output-stream) list count) 166 (or-fallback (stream-write-sequence s list 0 count))) 167 168 (defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position) 169 (if new-position 170 (setf (stream-file-position stream) new-position) 171 (stream-file-position stream)))) 172 173 ;; up to version 2.43 there were no 174 ;; stream-read-sequence, stream-write-sequence 175 ;; functions in CLISP 176 #+clisp 177 (eval-when (:compile-toplevel :load-toplevel :execute) 178 (when (find-symbol (string '#:stream-read-sequence) '#:gray) 179 (pushnew :clisp-has-stream-read/write-sequence *features*))) 180 181 #+clisp 182 (progn 183 184 #+clisp-has-stream-read/write-sequence 185 (defmethod gray:stream-read-sequence 186 (seq (s fundamental-input-stream) &key start end) 187 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 188 189 #+clisp-has-stream-read/write-sequence 190 (defmethod gray:stream-write-sequence 191 (seq (s fundamental-output-stream) &key start end) 192 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 193 194 ;;; for old CLISP 195 (defmethod gray:stream-read-byte-sequence 196 ((s fundamental-input-stream) 197 seq 198 &optional start end no-hang interactive) 199 (when no-hang 200 (error "this stream does not support the NO-HANG argument")) 201 (when interactive 202 (error "this stream does not support the INTERACTIVE argument")) 203 (or-fallback (stream-read-sequence s seq start end))) 204 205 (defmethod gray:stream-write-byte-sequence 206 ((s fundamental-output-stream) 207 seq 208 &optional start end no-hang interactive) 209 (when no-hang 210 (error "this stream does not support the NO-HANG argument")) 211 (when interactive 212 (error "this stream does not support the INTERACTIVE argument")) 213 (or-fallback (stream-write-sequence s seq start end))) 214 215 (defmethod gray:stream-read-char-sequence 216 ((s fundamental-input-stream) seq &optional start end) 217 (or-fallback (stream-read-sequence s seq start end))) 218 219 (defmethod gray:stream-write-char-sequence 220 ((s fundamental-output-stream) seq &optional start end) 221 (or-fallback (stream-write-sequence s seq start end))) 222 223 ;;; end of old CLISP read/write-sequence support 224 225 (defmethod gray:stream-position ((stream fundamental-stream) position) 226 (if position 227 (setf (stream-file-position stream) position) 228 (stream-file-position stream)))) 229 230 #+sbcl 231 (progn 232 (defmethod sb-gray:stream-read-sequence 233 ((s fundamental-input-stream) seq &optional start end) 234 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 235 (defmethod sb-gray:stream-write-sequence 236 ((s fundamental-output-stream) seq &optional start end) 237 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 238 (defmethod sb-gray:stream-file-position 239 ((stream fundamental-stream) &optional position) 240 (if position 241 (setf (stream-file-position stream) position) 242 (stream-file-position stream))) 243 ;; SBCL extension: 244 (defmethod sb-gray:stream-line-length ((stream fundamental-stream)) 245 80)) 246 247 #+(or ecl clasp) 248 (progn 249 (defmethod gray::stream-file-position 250 ((stream fundamental-stream) &optional position) 251 (if position 252 (setf (stream-file-position stream) position) 253 (stream-file-position stream))) 254 (defmethod gray:stream-read-sequence 255 ((s fundamental-input-stream) seq &optional start end) 256 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 257 (defmethod gray:stream-write-sequence 258 ((s fundamental-output-stream) seq &optional start end) 259 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))) 260 261 #+mocl 262 (progn 263 (defmethod gray:stream-read-sequence 264 ((s fundamental-input-stream) seq &optional start end) 265 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 266 (defmethod gray:stream-write-sequence 267 ((s fundamental-output-stream) seq &optional start end) 268 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 269 (defmethod gray:stream-file-position 270 ((stream fundamental-stream) &optional position) 271 (if position 272 (setf (stream-file-position stream) position) 273 (stream-file-position stream)))) 274 275 #+genera 276 (progn 277 (defmethod gray-streams:stream-read-sequence 278 ((s fundamental-input-stream) seq &optional start end) 279 (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq))))) 280 (defmethod gray-streams:stream-write-sequence 281 ((s fundamental-output-stream) seq &optional start end) 282 (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))) 283 (defmethod gray-streams:stream-file-position 284 ((stream fundamental-stream)) 285 (stream-file-position stream)) 286 (defmethod (setf gray-streams:stream-file-position) 287 (position (stream fundamental-stream)) 288 (setf (stream-file-position stream) position))) 289 290 ;; deprecated 291 (defclass trivial-gray-stream-mixin () ()) 292