3 ;;; This code is in the public domain.
5 ;;; The cmucl implementation of simple-streams was done by Paul Foley,
6 ;;; who placed the code in the public domain. Sbcl port by Rudi
9 (in-package "SB-SIMPLE-STREAMS")
15 (defmethod print-object ((object file-simple-stream
) stream
)
16 (print-unreadable-object (object stream
:type t
:identity t
)
17 (format stream
"for ~S" (slot-value object
'filename
))))
19 (defun make-control-table (&rest inits
)
20 (let ((table (make-array 32 :initial-element nil
)))
21 (do* ((char (pop inits
) (pop inits
))
22 (func (pop inits
) (pop inits
)))
24 (when (< (char-code char
) 32)
25 (setf (aref table
(char-code char
)) func
)))
28 (defun std-newline-out-handler (stream character
)
29 (declare (ignore character
))
30 (with-stream-class (simple-stream stream
)
31 (setf (sm charpos stream
) -
1)
34 (defun std-tab-out-handler (stream character
)
35 (declare (ignore character
))
36 (with-stream-class (simple-stream stream
)
37 (let ((col (sm charpos stream
)))
39 (setf (sm charpos stream
) (1- (* 8 (1+ (floor col
8)))))))
42 (defun std-dc-newline-in-handler (stream character
)
43 (with-stream-class (dual-channel-simple-stream stream
)
44 (setf (sm charpos stream
) -
1) ;; set to 0 "if reading" ???
47 (defvar *std-control-out-table
*
48 (make-control-table #\Newline
#'std-newline-out-handler
49 #\Tab
#'std-tab-out-handler
))
51 (defvar *terminal-control-in-table
*
52 (make-control-table #\Newline
#'std-dc-newline-in-handler
))
58 (defun vector-elt-width (vector)
59 ;; Return octet-width of vector elements
61 ;; missing are: bit, unsigned-byte 2, unsigned-byte 4, signed-byte 30
62 ;; [and base-char, which is treated specially]
63 ((simple-array (signed-byte 8) (*)) 1)
64 ((simple-array (unsigned-byte 8) (*)) 1)
65 ((simple-array (signed-byte 16) (*)) 2)
66 ((simple-array (unsigned-byte 16) (*)) 2)
67 ((simple-array (signed-byte 32) (*)) 4)
68 ((simple-array (unsigned-byte 32) (*)) 4)
69 ((simple-array single-float
(*)) 4)
70 ((simple-array double-float
(*)) 8)
71 ((simple-array (complex single-float
) (*)) 8)
72 ((simple-array (complex double-float
) (*)) 16)))
74 (defun endian-swap-value (vector endian-swap
)
76 (:network-order
(case (vector-elt-width vector
)
87 (otherwise endian-swap
)))
89 (defun read-vector (vector stream
&key
(start 0) end
(endian-swap :byte-8
))
90 (declare (type (sb-kernel:simple-unboxed-array
(*)) vector
)
92 ;; START and END are octet offsets, not vector indices! [Except for strings]
93 ;; Return value is index of next octet to be read into (i.e., start+count)
96 (with-stream-class (simple-stream stream
)
98 (let* ((start (or start
0))
99 (end (or end
(length vector
)))
100 (char (funcall-stm-handler j-read-char stream nil nil t
)))
102 (setf (schar vector start
) char
)
104 (+ start
(funcall-stm-handler j-read-chars stream vector nil
107 (cond ((any-stream-instance-flags stream
:string
)
108 (error "Can't READ-BYTE on string streams."))
109 ((any-stream-instance-flags stream
:dual
)
113 (index (or start
0) (1+ index
))
114 (end (or end
(* (length vector
) (vector-elt-width vector
))))
115 (endian-swap (endian-swap-value vector endian-swap
))
116 (byte (funcall j-read-byte stream nil nil t
)
117 (funcall j-read-byte stream nil nil nil
)))
118 ((or (null byte
) (>= index end
)) index
)
119 (setf (bref vector
(logxor index endian-swap
)) byte
)))))
120 ((or ansi-stream fundamental-stream
)
121 (unless (typep vector
'(or string
122 (simple-array (signed-byte 8) (*))
123 (simple-array (unsigned-byte 8) (*))))
124 (error "Wrong vector type for read-vector on stream not of type simple-stream."))
125 (read-sequence vector stream
:start
(or start
0) :end end
))))
127 #|
(defun write-vector ...
)|
#
129 ;;; TODO: move getpagesize into sbcl/unix.lisp, where it belongs
130 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
131 (defun getpagesize ()
132 (sb-unix::int-syscall
("getpagesize"))))
134 (defun read-octets (stream buffer start end blocking
)
135 (declare (type simple-stream stream
)
136 (type (or null simple-stream-buffer
) buffer
)
138 (type (or null fixnum
) end
)
139 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
140 (with-stream-class (simple-stream stream
)
141 (let ((fd (sm input-handle stream
))
142 (end (or end
(sm buf-len stream
)))
143 (buffer (or buffer
(sm buffer stream
))))
144 (declare (fixnum end
))
147 (let ((flag (sb-sys:wait-until-fd-usable fd
:input
148 (if blocking nil
0))))
150 ((and (not blocking
) (= start end
)) (if flag -
3 0))
151 ((and (not blocking
) (not flag
)) 0)
154 (declare (type fixnum count
))
157 ;; Avoid CMUCL gengc write barrier
158 (do ((i start
(+ i
;#.(sb-unix:unix-getpagesize)
159 (the fixnum
(getpagesize)))))
161 (declare (type fixnum i
))
162 (setf (bref buffer i
) 0))
163 (setf (bref buffer
(1- end
)) 0)
164 (multiple-value-bind (bytes errno
)
165 (sb-unix:unix-read fd
(buffer-sap buffer start
)
166 (the fixnum
(- end start
)))
167 (declare (type (or null fixnum
) bytes
)
168 (type (integer 0 100) errno
))
173 (format t
"~&;; UNIX-READ: errno=~D~%" errno
)
174 (cond ((= errno sb-unix
:eintr
) (go again
))
176 (or (= errno
;;sb-unix:eagain
181 (= errno sb-unix
:ewouldblock
)))
182 (sb-sys:wait-until-fd-usable fd
:input nil
)
184 (t (return (- -
10 errno
)))))
185 ((zerop count
) (return -
1))
186 (t (return count
)))))))))))
187 (t (error "implement me"))))))
189 (defun write-octets (stream buffer start end blocking
)
190 (declare (type simple-stream stream
)
191 (type (or null simple-stream-buffer
) buffer
)
193 (type (or null fixnum
) end
))
194 (with-stream-class (simple-stream stream
)
195 (let ((fd (sm output-handle stream
))
196 (end (or end
(error "WRITE-OCTETS: end=NIL")))
197 (buffer (or buffer
(error "WRITE-OCTETS: buffer=NIL"))))
200 (let ((flag (sb-sys:wait-until-fd-usable fd
:output
201 (if blocking nil
0))))
203 ((and (not blocking
) (= start end
)) (if flag -
3 0))
204 ((and (not blocking
) (not flag
)) 0)
209 (multiple-value-bind (bytes errno
)
210 (sb-unix:unix-write fd
(buffer-sap buffer
) start
216 (format t
"~&;; UNIX-WRITE: errno=~D~%" errno
)
217 (cond ((= errno sb-unix
:eintr
) (go again
))
218 ;; don't block for subsequent chars
219 (t (return (- -
10 errno
)))))
220 (t (return count
)))))))))))
221 (t (error "implement me"))))))
228 (defmethod device-open ((stream null-simple-stream
) options
)
229 (add-stream-instance-flags stream
:simple
:input
:output
)
232 (defmethod device-open ((stream buffer-input-simple-stream
) options
)
236 (defmethod device-open ((stream buffer-output-simple-stream
) options
)
240 (defun open-file-stream (stream options
)
241 (let ((filename (getf options
:filename
))
242 (direction (getf options
:direction
:input
))
243 (if-exists (getf options
:if-exists
))
244 (if-exists-given (not (getf options
:if-exists t
)))
245 (if-does-not-exist (getf options
:if-does-not-exist
))
246 (if-does-not-exist-given (not (getf options
:if-does-not-exist t
))))
247 (with-stream-class (file-simple-stream stream
)
249 (:input
(add-stream-instance-flags stream
:input
))
250 (:output
(add-stream-instance-flags stream
:output
))
251 (:io
(add-stream-instance-flags stream
:input
:output
)))
252 (cond ((and (sm input-handle stream
) (sm output-handle stream
)
253 (not (eql (sm input-handle stream
)
254 (sm output-handle stream
))))
255 (error "Input-Handle and Output-Handle can't be different."))
256 ((or (sm input-handle stream
) (sm output-handle stream
))
257 (add-stream-instance-flags stream
:simple
)
258 ;; get namestring, etc. from handle, if possible (it's a stream)
262 (multiple-value-bind (fd namestring original delete-original
)
263 (%fd-open filename direction if-exists if-exists-given
264 if-does-not-exist if-does-not-exist-given
)
266 (add-stream-instance-flags stream
:simple
)
267 (setf (sm pathname stream
) filename
268 (sm filename stream
) namestring
269 (sm original stream
) original
270 (sm delete-original stream
) delete-original
)
271 (when (any-stream-instance-flags stream
:input
)
272 (setf (sm input-handle stream
) fd
))
273 (when (any-stream-instance-flags stream
:output
)
274 (setf (sm output-handle stream
) fd
))
275 (sb-ext:finalize stream
277 (sb-unix:unix-close fd
)
278 (format *terminal-io
* "~&;;; ** closed ~S (fd ~D)~%"
282 (defmethod device-open ((stream file-simple-stream
) options
)
283 (with-stream-class (file-simple-stream stream
)
284 (when (open-file-stream stream options
)
286 ;; "The device-open method must be prepared to recognize resource
287 ;; and change-class situations. If no filename is specified in
288 ;; the options list, and if no input-handle or output-handle is
289 ;; given, then the input-handle and output-handle slots should
290 ;; be examined; if non-nil, that means the stream is still open,
291 ;; and thus the operation being requested of device-open is a
292 ;; change-class. Also, a device-open method need not allocate a
293 ;; buffer every time it is called, but may instead reuse a
294 ;; buffer it finds in a stream, if it does not become a security
296 (unless (sm buffer stream
)
297 (let ((length (device-buffer-length stream
)))
298 ;; Buffer should be array of (unsigned-byte 8), in general
299 ;; use strings for now so it's easy to read the content...
300 (setf (sm buffer stream
) (make-string length
)
301 (sm buffpos stream
) 0
302 (sm buffer-ptr stream
) 0
303 (sm buf-len stream
) length
)))
304 (when (any-stream-instance-flags stream
:output
)
305 (setf (sm control-out stream
) *std-control-out-table
*))
306 (install-single-channel-character-strategy
307 stream
(getf options
:external-format
:default
) nil
))))
309 (defmethod device-open ((stream mapped-file-simple-stream
) options
)
310 (with-stream-class (mapped-file-simple-stream stream
)
311 (when (open-file-stream stream options
)
312 (let* ((input (any-stream-instance-flags stream
:input
))
313 (output (any-stream-instance-flags stream
:output
))
314 (prot (logior (if input PROT-READ
0)
315 (if output PROT-WRITE
0)))
316 (fd (or (sm input-handle stream
) (sm output-handle stream
))))
317 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
)
318 (sb-unix:unix-fstat fd
)
319 (declare (ignore ino mode nlink uid gid rdev
))
321 (sb-unix:unix-close fd
)
322 (sb-ext:cancel-finalization stream
)
323 (error "Error fstating ~S: ~A" stream
324 (sb-int:strerror dev
)))
325 (when (> size most-positive-fixnum
)
326 ;; Or else BUF-LEN has to be a general integer, or
327 ;; maybe (unsigned-byte 32). In any case, this means
328 ;; BUF-MAX and BUF-PTR have to be the same, which means
329 ;; number-consing every time BUF-PTR moves...
330 ;; Probably don't have the address space available to map
331 ;; bigger files, anyway. Maybe DEVICE-EXTEND can adjust
332 ;; the mapped portion of the file?
333 (warn "Unable to memory-map entire file.")
334 (setf size most-positive-fixnum
))
336 (sb-unix:unix-mmap nil size prot MAP-SHARED fd
0)))
338 (sb-unix:unix-close fd
)
339 (sb-ext:cancel-finalization stream
)
340 (error "Unable to map file."))
341 (setf (sm buffer stream
) buffer
342 (sm buffpos stream
) 0
343 (sm buffer-ptr stream
) size
344 (sm buf-len stream
) size
)
345 (install-single-channel-character-strategy
346 stream
(getf options
:external-format
:default
) 'mapped
)
347 (sb-ext:finalize stream
349 (sb-unix:unix-munmap buffer size
)
350 (format *terminal-io
* "~&;;; ** unmapped ~S" buffer
)))))))
353 (defmethod device-open ((stream string-input-simple-stream
) options
)
357 (defmethod device-open ((stream string-output-simple-stream
) options
)
361 (defmethod device-open ((stream xp-simple-stream
) options
)
365 (defmethod device-open ((stream fill-pointer-output-simple-stream
) options
)
369 (defmethod device-open ((stream socket-base-simple-stream
) options
)
373 (defmethod device-open ((stream socket-simple-stream
) options
)
377 (defmethod device-open ((stream terminal-simple-stream
) options
)
378 (with-stream-class (terminal-simple-stream stream
)
379 (when (getf options
:input-handle
)
380 (setf (sm input-handle stream
) (getf options
:input-handle
))
381 (add-stream-instance-flags stream
:simple
:interactive
:dual
:input
)
382 (unless (sm buffer stream
)
383 (let ((length (device-buffer-length stream
)))
384 (setf (sm buffer stream
) (make-string length
)
385 (sm buf-len stream
) length
)))
386 (setf (sm control-in stream
) *terminal-control-in-table
*))
387 (when (getf options
:output-handle
)
388 (setf (sm output-handle stream
) (getf options
:output-handle
))
389 (add-stream-instance-flags stream
:simple
:interactive
:dual
:output
)
390 (unless (sm out-buffer stream
)
391 (let ((length (device-buffer-length stream
)))
392 (setf (sm out-buffer stream
) (make-string length
)
393 (sm max-out-pos stream
) length
)))
394 (setf (sm control-out stream
) *std-control-out-table
*))
395 (install-dual-channel-character-strategy
396 stream
(getf options
:external-format
:default
)))
401 (defmethod device-close :around
((stream simple-stream
) abort
)
402 (with-stream-class (simple-stream stream
)
403 (when (any-stream-instance-flags stream
:input
:output
)
404 (when (any-stream-instance-flags stream
:output
)
406 (clear-output stream
)
407 (force-output stream
)))
409 (setf (sm input-handle stream
) nil
410 (sm output-handle stream
) nil
)
411 (remove-stream-instance-flags stream
:input
:output
)
412 (sb-ext:cancel-finalization stream
))))
414 (defmethod device-close ((stream simple-stream
) abort
)
415 (declare (ignore abort
))
418 (defmethod device-close ((stream file-simple-stream
) abort
)
419 (with-stream-class (file-simple-stream stream
)
421 ;; Remove any fd-handler
422 ;; If it's an output stream and has an original name,
426 ;; If there's an original name and delete-original is set
429 (if (sm input-handle stream
)
430 (sb-unix:unix-close
(sm input-handle stream
))
431 (sb-unix:unix-close
(sm output-handle stream
)))
432 (setf (sm buffer stream
) nil
))
435 (defmethod device-close ((stream mapped-file-simple-stream
) abort
)
436 (with-stream-class (mapped-file-simple-stream stream
)
437 (when (sm buffer stream
)
438 (sb-unix:unix-munmap
(sm buffer stream
) (sm buf-len stream
))
439 (setf (sm buffer stream
) nil
))
441 ;; remove any FD handler
442 ;; if it has an original name (is this possible for mapped files?)
446 ;; if there's an original name and delete-original is set (again,
447 ;; is this even possible?), kill the original
449 (sb-unix:unix-close
(sm input-handle stream
)))
453 (defmethod device-buffer-length ((stream simple-stream
))
456 (defmethod device-buffer-length ((stream null-simple-stream
))
460 (defmethod device-file-position ((stream simple-stream
))
461 (with-stream-class (simple-stream stream
)
462 ;; this may be wrong if :DUAL flag is set!
463 (sm buffpos stream
)))
465 (defmethod (setf device-file-position
) (value (stream simple-stream
))
466 (with-stream-class (simple-stream stream
)
467 ;; this may be wrong if :DUAL flag is set!
468 (setf (sm buffpos stream
) value
)))
470 (defmethod device-file-position ((stream string-simple-stream
))
471 ;; get string length (of input or output buffer?)
474 (defmethod (setf device-file-position
) (value (stream string-simple-stream
))
475 ;; set string length (of input or output buffer?)
478 (defmethod device-file-position ((stream fill-pointer-output-simple-stream
))
479 ;; get fill pointer (of input or output buffer?)
482 (defmethod (setf device-file-position
)
483 (value (stream fill-pointer-output-simple-stream
))
484 ;; set fill pointer (of input or output buffer?)
487 (defmethod device-file-position ((stream file-simple-stream
))
488 (with-stream-class (file-simple-stream stream
)
489 (values (sb-unix:unix-lseek
(or (sm input-handle stream
)
490 (sm output-handle stream
))
494 (defmethod (setf device-file-position
) (value (stream file-simple-stream
))
495 (declare (type fixnum value
))
496 (with-stream-class (file-simple-stream stream
)
497 (values (sb-unix:unix-lseek
(or (sm input-handle stream
)
498 (sm output-handle stream
))
505 (defmethod device-file-length ((stream simple-stream
))
508 (defmethod device-file-length ((stream direct-simple-stream
))
509 ;; return buffer length
512 (defmethod device-file-length ((stream string-simple-stream
))
513 ;; return string length
516 (defmethod device-file-length ((stream file-simple-stream
))
517 (with-stream-class (file-simple-stream stream
)
518 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
)
519 (sb-unix:unix-fstat
(sm input-handle stream
))
520 (declare (ignore dev ino mode nlink uid gid rdev
))
521 (if okay size nil
))))
524 (defmethod device-read ((stream single-channel-simple-stream
) buffer
526 ;; (when (and (null buffer) (not (eql start end)))
527 ;; (with-stream-class (single-channel-simple-stream stream)
528 ;; (setq buffer (sm buffer stream))
529 ;; (setq end (sm buf-len stream))))
530 (read-octets stream buffer start end blocking
))
532 (defmethod device-read ((stream dual-channel-simple-stream
) buffer
535 (with-stream-class (dual-channel-simple-stream stream
)
536 (setq buffer
(sm buffer stream
))
537 (setq end
(- (sm buf-len stream
) start
))))
538 (read-octets stream buffer start end blocking
))
540 (defmethod device-read ((stream null-simple-stream
) buffer
542 (declare (ignore buffer start end blocking
))
545 (defmethod device-read ((stream terminal-simple-stream
) buffer
547 (let ((result (call-next-method)))
548 (if (= result -
1) -
2 result
)))
551 (defmethod device-clear-input ((stream simple-stream
) buffer-only
)
552 (declare (ignore buffer-only
))
555 (defmethod device-clear-input ((stream terminal-simple-stream
) buffer-only
)
559 (defmethod device-write ((stream single-channel-simple-stream
) buffer
561 (when (and (null buffer
) (not (eql start end
)))
562 (with-stream-class (single-channel-simple-stream stream
)
563 (setf buffer
(sm buffer stream
))
564 (setf end
(sm buffpos stream
))))
565 (write-octets stream buffer start end blocking
))
567 (defmethod device-write ((stream dual-channel-simple-stream
) buffer
569 (when (and (null buffer
) (not (eql start end
)))
570 (with-stream-class (dual-channel-simple-stream stream
)
571 (setf buffer
(sm out-buffer stream
))
572 (setf end
(sm outpos stream
))))
573 (write-octets stream buffer start end blocking
))
575 (defmethod device-write ((stream null-simple-stream
) buffer
577 (declare (ignore buffer blocking
))
580 (defmethod device-write ((stream socket-base-simple-stream
) buffer
586 (defmethod device-clear-output ((stream simple-stream
))
590 (defmethod device-extend ((stream direct-simple-stream
) need action
)
591 (declare (ignore need action
))
594 (defmethod device-extend ((stream string-input-simple-stream
) need action
)
595 (declare (ignore need action
))
598 (defmethod device-extend ((stream string-output-simple-stream
) need action
)
602 (defmethod device-extend ((stream fill-pointer-output-simple-stream
)
607 (defmethod device-extend ((stream mapped-file-simple-stream
) need action
)
608 (declare (ignore need action
))
612 ;; device-finish-record apparently has no methods defined
616 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
617 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
622 ;;; CREATION OF STANDARD STREAMS