Coverage report: /home/ellis/.stash/quicklisp/dists/ultralisp/software/trivial-gray-streams-trivial-gray-streams-20240301173944/streams.lisp

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