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 shared-initialize :after ((instance simple-stream) slot-names
16 &rest initargs &key &allow-other-keys)
17 (declare (ignore slot-names))
18 (unless (slot-boundp instance 'melded-stream)
19 (setf (slot-value instance 'melded-stream) instance)
20 (setf (slot-value instance 'melding-base) instance))
21 (unless (device-open instance initargs)
22 (device-close instance t)))
24 ;;; From the simple-streams documentation: "A generic function implies
25 ;;; a specialization capability that does not exist for
26 ;;; simple-streams; simple-stream specializations should be on
27 ;;; device-close." So don't do it.
28 (defmethod close ((stream simple-stream) &key abort)
29 (device-close stream abort))
32 ;;; This takes care of the things all device-close methods have to do,
33 ;;; regardless of the type of simple-stream
34 (defmethod device-close :around ((stream simple-stream) abort)
35 (with-stream-class (simple-stream stream)
36 (when (any-stream-instance-flags stream :input :output)
37 (when (any-stream-instance-flags stream :output)
40 (force-output stream)))
42 (setf (sm input-handle stream) nil
43 (sm output-handle stream) nil
44 (sm j-listen stream) #'sb-kernel::closed-flame
45 (sm j-read-char stream) #'sb-kernel::closed-flame
46 (sm j-read-chars stream) #'sb-kernel::closed-flame
47 (sm j-unread-char stream) #'sb-kernel::closed-flame
48 (sm j-write-char stream) #'sb-kernel::closed-flame ;@@
49 (sm j-write-chars stream) #'sb-kernel::closed-flame) ;@@
50 (remove-stream-instance-flags stream :input :output)
51 (sb-ext:cancel-finalization stream))))
57 (defmethod print-object ((object simple-stream) stream)
58 (print-unreadable-object (object stream :type nil :identity nil)
59 (cond ((not (any-stream-instance-flags object :simple))
60 (princ "Invalid " stream))
61 ((not (any-stream-instance-flags object :input :output))
62 (princ "Closed " stream)))
63 (format stream "~:(~A~)" (type-of object))))
65 (defmethod print-object ((object file-simple-stream) stream)
66 (print-unreadable-object (object stream :type nil :identity nil)
67 (with-stream-class (file-simple-stream object)
68 (cond ((not (any-stream-instance-flags object :simple))
69 (princ "Invalid " stream))
70 ((not (any-stream-instance-flags object :input :output))
71 (princ "Closed " stream)))
72 (format stream "~:(~A~) for ~S"
73 (type-of object) (sm filename object)))))
75 (defun make-control-table (&rest inits)
76 (let ((table (make-array 32 :initial-element nil)))
77 (do* ((char (pop inits) (pop inits))
78 (func (pop inits) (pop inits)))
80 (when (< (char-code char) 32)
81 (setf (aref table (char-code char)) func)))
84 (defun std-newline-out-handler (stream character)
85 (declare (ignore character))
86 (with-stream-class (simple-stream stream)
87 (setf (sm charpos stream) -1)
90 (defun std-tab-out-handler (stream character)
91 (declare (ignore character))
92 (with-stream-class (simple-stream stream)
93 (let ((col (sm charpos stream)))
95 (setf (sm charpos stream) (1- (* 8 (1+ (floor col 8)))))))
98 (defun std-dc-newline-in-handler (stream character)
99 (with-stream-class (dual-channel-simple-stream stream)
100 (setf (sm charpos stream) -1) ;; set to 0 "if reading" ???
103 (defvar *std-control-out-table*
104 (make-control-table #\Newline #'std-newline-out-handler
105 #\Tab #'std-tab-out-handler))
107 (defvar *terminal-control-in-table*
108 (make-control-table #\Newline #'std-dc-newline-in-handler))
110 (defun find-external-format (name)
117 (defun vector-elt-width (vector)
118 ;; Return octet-width of vector elements
120 ;; (simple-array fixnum (*)) not supported
121 ;; (simple-array base-char (*)) treated specially; don't call this
122 ((simple-array bit (*)) 1)
123 ((simple-array (unsigned-byte 2) (*)) 1)
124 ((simple-array (unsigned-byte 4) (*)) 1)
125 ((simple-array (signed-byte 8) (*)) 1)
126 ((simple-array (unsigned-byte 8) (*)) 1)
127 ((simple-array (signed-byte 16) (*)) 2)
128 ((simple-array (unsigned-byte 16) (*)) 2)
129 ((simple-array (signed-byte 32) (*)) 4)
130 ((simple-array (unsigned-byte 32) (*)) 4)
131 ((simple-array single-float (*)) 4)
132 ((simple-array double-float (*)) 8)
133 ((simple-array (complex single-float) (*)) 8)
134 ((simple-array (complex double-float) (*)) 16)))
136 (defun endian-swap-value (vector endian-swap)
138 (:network-order (1- (vector-elt-width vector)))
144 (otherwise endian-swap)))
147 (defun read-vector (vector stream &key (start 0) end (endian-swap :byte-8))
148 (declare (type (sb-kernel:simple-unboxed-array (*)) vector)
149 (type stream stream))
150 ;; START and END are octet offsets, not vector indices! [Except for strings]
151 ;; Return value is index of next octet to be read into (i.e., start+count)
154 (with-stream-class (simple-stream stream)
156 (let* ((start (or start 0))
157 (end (or end (length vector)))
158 (char (funcall-stm-handler j-read-char stream nil nil t)))
160 (setf (schar vector start) char)
162 (+ start (funcall-stm-handler j-read-chars stream vector nil
165 (cond ((any-stream-instance-flags stream :string)
166 (error "Can't READ-BYTE on string streams."))
167 ((any-stream-instance-flags stream :dual)
171 (index (or start 0) (1+ index))
172 (end (or end (* (length vector) (vector-elt-width vector))))
173 (endian-swap (endian-swap-value vector endian-swap))
174 (byte (funcall j-read-byte stream nil nil t)
175 (funcall j-read-byte stream nil nil nil)))
176 ((or (null byte) (>= index end)) index)
177 (setf (bref vector (logxor index endian-swap)) byte)))))
178 ((or ansi-stream fundamental-stream)
179 (unless (typep vector '(or string
180 (simple-array (signed-byte 8) (*))
181 (simple-array (unsigned-byte 8) (*))))
182 (error "Wrong vector type for read-vector on stream not of type simple-stream."))
183 ;; FIXME: implement blocking/non-blocking semantics here as well
184 (read-sequence vector stream :start (or start 0) :end end))))
186 #|(defun write-vector ...)|#
188 (defun read-octets (stream buffer start end blocking)
189 (declare (type simple-stream stream)
190 (type (or null simple-stream-buffer) buffer)
192 (type (or null fixnum) end)
193 (optimize (speed 3) (space 2) (safety 0) (debug 0)))
194 (with-stream-class (simple-stream stream)
195 (let ((fd (sm input-handle stream))
196 (end (or end (sm buf-len stream)))
197 (buffer (or buffer (sm buffer stream))))
198 (declare (fixnum end))
201 (let ((flag (sb-sys:wait-until-fd-usable fd :input
202 (if blocking nil 0))))
204 ((and (not blocking) (= start end)) (if flag -3 0))
205 ((and (not blocking) (not flag)) 0)
208 (declare (type fixnum count))
211 ;; Avoid CMUCL gengc write barrier
212 (do ((i start (+ i (the fixnum (sb-posix:getpagesize)))))
214 (declare (type fixnum i))
215 (setf (bref buffer i) 0))
216 (setf (bref buffer (1- end)) 0)
217 (multiple-value-bind (bytes errno)
218 (sb-unix:unix-read fd (buffer-sap buffer start)
219 (the fixnum (- end start)))
220 (declare (type (or null fixnum) bytes)
221 (type (integer 0 100) errno))
226 (format *debug-io* "~&;; UNIX-READ: errno=~D~%" errno)
227 (cond ((= errno sb-unix:eintr) (go again))
229 (or (= errno ;;sb-unix:eagain
234 (= errno sb-unix:ewouldblock)))
235 (sb-sys:wait-until-fd-usable fd :input nil)
237 (t (return (- -10 errno)))))
238 ((zerop count) (return -1))
239 (t (return count)))))))))))
240 ;; Handle encapsulated stream. FIXME: perhaps handle
241 ;; sbcl-vintage ansi-stream type in read-octets too?
242 (stream (read-octets fd buffer start end blocking))
243 (t (error "Don't know how to handle input handle ~S" fd))))))
245 (defun write-octets (stream buffer start end blocking)
246 (declare (type simple-stream stream)
247 (type (or null simple-stream-buffer) buffer)
249 (type (or null fixnum) end))
250 (with-stream-class (simple-stream stream)
251 (let ((fd (sm output-handle stream))
252 (end (or end (error "WRITE-OCTETS: end=NIL")))
253 (buffer (or buffer (error "WRITE-OCTETS: buffer=NIL"))))
256 (let ((flag (sb-sys:wait-until-fd-usable fd :output
257 (if blocking nil 0))))
259 ((and (not blocking) (= start end)) (if flag -3 0))
260 ((and (not blocking) (not flag)) 0)
265 (multiple-value-bind (bytes errno)
266 (sb-unix:unix-write fd (buffer-sap buffer) start
272 (format *debug-io* "~&;; UNIX-WRITE: errno=~D~%"
274 (cond ((= errno sb-unix:eintr) (go again))
275 ;; don't block for subsequent chars
276 (t (return (- -10 errno)))))
277 (t (return count)))))))))))
278 ;; Handle encapsulated stream. FIXME: perhaps handle
279 ;; sbcl-vintage ansi-stream type in write-octets too?
280 (stream (write-octets fd buffer start end blocking))
281 (t (error "Don't know how to handle output handle ~A" fd))))))
289 ;;; simple-stream, dual-channel-simple-stream,
290 ;;; single-channel-simple-stream
292 (defmethod device-buffer-length ((stream simple-stream))
295 (defmethod device-file-position ((stream simple-stream))
296 (with-stream-class (simple-stream stream)
297 (cond ((any-stream-instance-flags stream :dual)
298 (with-stream-class (dual-channel-simple-stream stream)
299 (sm buffpos stream)))
300 ((any-stream-instance-flags stream :string)
301 (with-stream-class (string-simple-stream stream)
302 (sm buffpos stream)))
304 (with-stream-class (single-channel-simple-stream stream)
305 (sm buffpos stream))))))
308 (defmethod (setf device-file-position) (value (stream simple-stream))
309 (with-stream-class (simple-stream stream)
310 (cond ((any-stream-instance-flags stream :dual)
311 (with-stream-class (dual-channel-simple-stream stream)
312 (setf (sm buffpos stream) value)))
313 ((any-stream-instance-flags stream :string)
314 (with-stream-class (string-simple-stream stream)
315 (setf (sm buffpos stream) value)))
317 (with-stream-class (single-channel-simple-stream stream)
318 (setf (sm buffpos stream) value))))))
320 (defmethod device-file-length ((stream simple-stream))
323 (defmethod device-read ((stream single-channel-simple-stream) buffer
325 ;; rudi (2003-06-07): this block commented out in Paul Foley's code
326 ;; (when (and (null buffer) (not (eql start end)))
327 ;; (with-stream-class (single-channel-simple-stream stream)
328 ;; (setq buffer (sm buffer stream))
329 ;; (setq end (sm buf-len stream))))
330 (read-octets stream buffer start end blocking))
332 (defmethod device-read ((stream dual-channel-simple-stream) buffer
335 (with-stream-class (dual-channel-simple-stream stream)
336 (setq buffer (sm buffer stream))
337 (setq end (- (sm buf-len stream) start))))
338 (read-octets stream buffer start end blocking))
340 (defmethod device-clear-input ((stream simple-stream) buffer-only)
341 (declare (ignore buffer-only))
344 (defmethod device-write ((stream single-channel-simple-stream) buffer
346 (when (and (null buffer) (not (eql start end)))
347 (with-stream-class (single-channel-simple-stream stream)
348 (setf buffer (sm buffer stream))))
349 (write-octets stream buffer start end blocking))
351 (defmethod device-write ((stream dual-channel-simple-stream) buffer
353 (when (and (null buffer) (not (eql start end)))
354 (with-stream-class (dual-channel-simple-stream stream)
355 (setf buffer (sm out-buffer stream))))
356 (write-octets stream buffer start end blocking))
358 (defmethod device-clear-output ((stream simple-stream))
362 ;;; Direct-Simple-Stream and Buffer-(Input|Output)-Simple-Stream
364 (defmethod device-file-length ((stream direct-simple-stream))
365 ;; return buffer length
368 (defmethod device-open ((stream buffer-input-simple-stream) options)
372 (defmethod device-open ((stream buffer-output-simple-stream) options)
377 ;;; Definition of File-Simple-Stream and relations
379 (defun open-file-stream (stream options)
380 (let ((filename (pathname (getf options :filename)))
381 (direction (getf options :direction :input))
382 (if-exists (getf options :if-exists))
383 (if-exists-given (not (eql (getf options :if-exists t) t)))
384 (if-does-not-exist (getf options :if-does-not-exist))
385 (if-does-not-exist-given (not (eql (getf options :if-does-not-exist t) t))))
386 (with-stream-class (file-simple-stream stream)
388 (:input (add-stream-instance-flags stream :input))
389 (:output (add-stream-instance-flags stream :output))
390 (:io (add-stream-instance-flags stream :input :output)))
391 (cond ((and (sm input-handle stream) (sm output-handle stream)
392 (not (eql (sm input-handle stream)
393 (sm output-handle stream))))
394 (error "Input-Handle and Output-Handle can't be different."))
395 ((or (sm input-handle stream) (sm output-handle stream))
396 (add-stream-instance-flags stream :simple)
397 ;; get namestring, etc. from handle, if possible (it's a stream)
401 (multiple-value-bind (fd namestring original delete-original)
402 (%fd-open filename direction if-exists if-exists-given
403 if-does-not-exist if-does-not-exist-given)
405 (add-stream-instance-flags stream :simple)
406 (setf (sm pathname stream) filename
407 (sm filename stream) namestring
408 (sm original stream) original
409 (sm delete-original stream) delete-original)
410 (when (any-stream-instance-flags stream :input)
411 (setf (sm input-handle stream) fd))
412 (when (any-stream-instance-flags stream :output)
413 (setf (sm output-handle stream) fd))
414 (sb-ext:finalize stream
416 (sb-unix:unix-close fd)
417 (format *terminal-io* "~&;;; ** closed ~S (fd ~D)~%"
421 (defmethod device-open ((stream file-simple-stream) options)
422 (with-stream-class (file-simple-stream stream)
423 (when (open-file-stream stream options)
425 ;; "The device-open method must be prepared to recognize resource
426 ;; and change-class situations. If no filename is specified in
427 ;; the options list, and if no input-handle or output-handle is
428 ;; given, then the input-handle and output-handle slots should
429 ;; be examined; if non-nil, that means the stream is still open,
430 ;; and thus the operation being requested of device-open is a
431 ;; change-class. Also, a device-open method need not allocate a
432 ;; buffer every time it is called, but may instead reuse a
433 ;; buffer it finds in a stream, if it does not become a security
435 (unless (sm buffer stream)
436 (let ((length (device-buffer-length stream)))
437 ;; Buffer should be array of (unsigned-byte 8), in general
438 ;; use strings for now so it's easy to read the content...
439 (setf (sm buffer stream) (make-string length)
440 (sm buffpos stream) 0
441 (sm buffer-ptr stream) 0
442 (sm buf-len stream) length)))
443 (when (any-stream-instance-flags stream :output)
444 (setf (sm control-out stream) *std-control-out-table*))
445 (let ((efmt (getf options :external-format :default)))
446 (compose-encapsulating-streams stream efmt)
447 (install-single-channel-character-strategy stream efmt nil)))))
449 (defmethod device-close ((stream file-simple-stream) abort)
450 (with-stream-class (file-simple-stream stream)
453 ;; Remove any fd-handler
454 ;; If it's an output stream and has an original name,
459 ;; If there's an original name and delete-original is set
462 (if (sm input-handle stream)
463 (sb-unix:unix-close (sm input-handle stream))
464 (sb-unix:unix-close (sm output-handle stream)))
465 (setf (sm buffer stream) nil))
468 (defmethod device-file-position ((stream file-simple-stream))
469 (with-stream-class (file-simple-stream stream)
470 (values (sb-unix:unix-lseek (or (sm input-handle stream)
471 (sm output-handle stream))
475 (defmethod (setf device-file-position) (value (stream file-simple-stream))
476 (declare (type fixnum value))
477 (with-stream-class (file-simple-stream stream)
478 (values (sb-unix:unix-lseek (or (sm input-handle stream)
479 (sm output-handle stream))
485 (defmethod device-file-length ((stream file-simple-stream))
486 (with-stream-class (file-simple-stream stream)
487 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
488 (sb-unix:unix-fstat (sm input-handle stream))
489 (declare (ignore dev ino mode nlink uid gid rdev))
490 (if okay size nil))))
492 (defmethod device-open ((stream mapped-file-simple-stream) options)
493 (with-stream-class (mapped-file-simple-stream stream)
494 (when (open-file-stream stream options)
495 (let* ((input (any-stream-instance-flags stream :input))
496 (output (any-stream-instance-flags stream :output))
497 (prot (logior (if input sb-posix::PROT-READ 0)
498 (if output sb-posix::PROT-WRITE 0)))
499 (fd (or (sm input-handle stream) (sm output-handle stream))))
500 (multiple-value-bind (okay dev ino mode nlink uid gid rdev size)
501 (sb-unix:unix-fstat fd)
502 (declare (ignore ino mode nlink uid gid rdev))
504 (sb-unix:unix-close fd)
505 (sb-ext:cancel-finalization stream)
506 (error "Error fstating ~S: ~A" stream
507 (sb-int:strerror dev)))
508 (when (> size most-positive-fixnum)
509 ;; Or else BUF-LEN has to be a general integer, or
510 ;; maybe (unsigned-byte 32). In any case, this means
511 ;; BUF-MAX and BUF-PTR have to be the same, which means
512 ;; number-consing every time BUF-PTR moves...
513 ;; Probably don't have the address space available to map
514 ;; bigger files, anyway.
515 (warn "Unable to memory-map entire file.")
516 (setf size most-positive-fixnum))
519 (sb-posix:mmap nil size prot sb-posix::MAP-SHARED fd 0)
520 (sb-posix:syscall-error nil))))
522 (sb-unix:unix-close fd)
523 (sb-ext:cancel-finalization stream)
524 (error "Unable to map file."))
525 (setf (sm buffer stream) buffer
526 (sm buffpos stream) 0
527 (sm buffer-ptr stream) size
528 (sm buf-len stream) size)
529 (install-single-channel-character-strategy
530 stream (getf options :external-format :default) 'mapped)
531 (sb-ext:finalize stream
533 (sb-posix:munmap buffer size)
534 (format *terminal-io* "~&;;; ** unmapped ~S" buffer)))))))
537 (defmethod device-close ((stream mapped-file-simple-stream) abort)
538 (with-stream-class (mapped-file-simple-stream stream)
539 (when (sm buffer stream)
540 (sb-posix:munmap (sm buffer stream) (sm buf-len stream))
541 (setf (sm buffer stream) nil))
543 ;; remove any FD handler
544 ;; if it has an original name (is this possible for mapped files?)
548 ;; if there's an original name and delete-original is set (again,
549 ;; is this even possible?), kill the original
551 (sb-unix:unix-close (sm input-handle stream)))
555 ;;; Definition of Null-Simple-Stream
558 (defmethod device-open ((stream null-simple-stream) options)
559 (with-stream-class (null-simple-stream stream)
560 (add-stream-instance-flags stream :simple :input :output)
561 ;;(install-single-channel-character-strategy
562 ;; stream (getf options :external-format :default) nil)
563 (setf (sm j-read-char stream) #'null-read-char
564 (sm j-read-chars stream) #'null-read-chars
565 (sm j-unread-char stream) #'null-unread-char
566 (sm j-write-char stream) #'null-write-char
567 (sm j-write-chars stream) #'null-write-chars
568 (sm j-listen stream) #'null-listen))
572 (defmethod device-buffer-length ((stream null-simple-stream))
575 (defmethod device-read ((stream null-simple-stream) buffer
577 (declare (ignore buffer start end blocking))
580 (defmethod device-write ((stream null-simple-stream) buffer
582 (declare (ignore buffer blocking))
586 ;;; Socket-Simple-Stream and relatives
589 (defmethod device-open ((stream socket-base-simple-stream) options)
593 (defmethod device-open ((stream socket-simple-stream) options)
594 (with-stream-class (socket-simple-stream stream)
595 (let* ((remote-host (getf options :remote-host))
596 (remote-port (getf options :remote-port))
597 (socket (make-instance 'sb-bsd-sockets:inet-socket
598 :type :stream :protocol :tcp)))
599 (setf (sm socket stream) socket)
600 (sb-bsd-sockets:socket-connect socket remote-host remote-port)
601 (let ((fd (sb-bsd-sockets:socket-file-descriptor socket)))
602 ;; Connect stream to socket, ...
603 (setf (sm input-handle stream) fd)
604 (setf (sm output-handle stream) fd)
605 ;; ... and socket to stream.
606 (setf (slot-value socket 'stream) stream)
607 (sb-ext:cancel-finalization socket)
608 (sb-ext:finalize stream
610 (sb-unix:unix-close fd)
611 (format *terminal-io*
612 "~&;;; ** closed socket (fd ~D)~%" fd))))
613 ;; Now frob the stream slots. FIXME: should we handle a
614 ;; :direction arg from output, defaulting to :input only?
615 (add-stream-instance-flags stream :simple :input :output :dual)
616 (unless (sm buffer stream)
617 (let ((length (device-buffer-length stream)))
618 ;; Buffer should be array of (unsigned-byte 8), in general
619 ;; use strings for now so it's easy to read the content...
620 (setf (sm buffer stream) (make-string length)
621 (sm buffpos stream) 0
622 (sm buffer-ptr stream) 0
623 (sm buf-len stream) length)))
624 (unless (sm out-buffer stream)
625 (let ((length (device-buffer-length stream)))
626 (setf (sm out-buffer stream) (make-string length)
627 (sm max-out-pos stream) length)))
628 (setf (sm control-in stream) *terminal-control-in-table*)
629 (setf (sm control-out stream) *std-control-out-table*)
630 (install-dual-channel-character-strategy
631 stream (getf options :external-format :default)))
634 (defmethod device-close ((stream socket-simple-stream) abort)
635 ;; Abort argument is handled by :around method on base class
636 (declare (ignore abort))
637 (with-stream-class (socket-simple-stream stream)
638 (sb-unix:unix-close (sm input-handle stream))
639 (setf (sm buffer stream) nil)
640 (setf (sm out-buffer stream) nil))
641 (sb-ext:cancel-finalization stream)
645 ;;; String-Simple-Stream and relatives
648 (defmethod device-file-position ((stream string-simple-stream))
649 ;; get string length (of input or output buffer?)
652 (defmethod (setf device-file-position) (value (stream string-simple-stream))
653 ;; set string length (of input or output buffer?)
656 (defmethod device-file-length ((stream string-simple-stream))
657 ;; return string length
660 (defmethod device-open :before ((stream string-input-simple-stream) options)
661 (with-stream-class (string-input-simple-stream stream)
662 (let ((string (getf options :string)))
663 (when (and string (null (sm buffer stream)))
664 (let ((start (getf options :start))
665 (end (or (getf options :end) (length string))))
666 (setf (sm buffer stream) string
667 (sm buffpos stream) start
668 (sm buffer-ptr stream) end))))
669 (install-string-input-character-strategy stream)
670 (add-stream-instance-flags stream :string :input :simple)))
672 (defmethod device-open :before ((stream string-output-simple-stream) options)
673 (with-stream-class (string-output-simple-stream stream)
674 (unless (sm out-buffer stream)
675 (let ((string (getf options :string)))
677 (setf (sm out-buffer stream) string
678 (sm max-out-pos stream) (length string))
679 (let ((buflen (max (device-buffer-length stream) 16)))
680 (setf (sm out-buffer stream) (make-string buflen)
681 (sm max-out-pos stream) buflen)))))
682 (unless (sm control-out stream)
683 (setf (sm control-out stream) *std-control-out-table*))
684 (install-string-output-character-strategy stream)
685 (add-stream-instance-flags stream :string :output :simple)))
688 (defmethod device-open ((stream string-input-simple-stream) options)
693 (defmethod device-open ((stream string-output-simple-stream) options)
698 (defmethod device-open ((stream xp-simple-stream) options)
702 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
706 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
707 ;; get fill pointer (of input or output buffer?)
710 (defmethod (setf device-file-position)
711 (value (stream fill-pointer-output-simple-stream))
712 ;; set fill pointer (of input or output buffer?)
716 ;;; Terminal-Simple-Stream
718 (defmethod device-open ((stream terminal-simple-stream) options)
719 (with-stream-class (terminal-simple-stream stream)
720 (when (getf options :input-handle)
721 (setf (sm input-handle stream) (getf options :input-handle))
722 (add-stream-instance-flags stream :simple :interactive :dual :input)
723 (unless (sm buffer stream)
724 (let ((length (device-buffer-length stream)))
725 (setf (sm buffer stream) (make-string length)
726 (sm buf-len stream) length)))
727 (setf (sm control-in stream) *terminal-control-in-table*))
728 (when (getf options :output-handle)
729 (setf (sm output-handle stream) (getf options :output-handle))
730 (add-stream-instance-flags stream :simple :interactive :dual :output)
731 (unless (sm out-buffer stream)
732 (let ((length (device-buffer-length stream)))
733 (setf (sm out-buffer stream) (make-string length)
734 (sm max-out-pos stream) length)))
735 (setf (sm control-out stream) *std-control-out-table*))
736 (install-dual-channel-character-strategy
737 stream (getf options :external-format :default)))
738 ;; TODO (rudi 2003-06-08): when neither input-handle nor
739 ;; output-handle are given, close the stream again.
743 (defmethod device-read ((stream terminal-simple-stream) buffer
745 (let ((result (call-next-method)))
746 (if (= result -1) -2 result)))
748 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
751 (defmethod device-close ((stream simple-stream) abort)
752 (declare (ignore abort))
765 (defmethod device-read ((stream terminal-simple-stream) buffer
767 (let ((result (call-next-method)))
768 (if (= result -1) -2 result)))
772 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
777 (defmethod device-write ((stream socket-base-simple-stream) buffer
789 ;; device-finish-record apparently has no methods defined
793 ;;; IMPLEMENTATIONS FOR FOREIGN STREAMS
794 ;;; (SYS:LISP-STREAM AND EXT:FUNDAMENTAL-STREAM)
799 ;;; CREATION OF STANDARD STREAMS