Fix make-array transforms.
[sbcl.git] / contrib / sb-simple-streams / terminal.lisp
1 ;;; -*- lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written by Paul Foley and has been placed in the public
5 ;;; domain.
6 ;;;
7
8 ;;; Sbcl port by Rudi Schlatte.
9
10 (in-package "SB-SIMPLE-STREAMS")
11
12 ;;;
13 ;;; **********************************************************************
14 ;;;
15 ;;; Terminal-Simple-Stream
16
17 (defvar *terminal-control-in-table*
18   (make-control-table #\Newline #'std-dc-newline-in-handler))
19
20 (def-stream-class terminal-simple-stream (dual-channel-simple-stream)
21   ())
22
23 (defmethod device-open ((stream terminal-simple-stream) options)
24   (with-stream-class (terminal-simple-stream stream)
25     (when (getf options :input-handle)
26       (setf (sm input-handle stream) (getf options :input-handle))
27       (add-stream-instance-flags stream :simple :dual :input)
28       (when (sb-unix:unix-isatty (sm input-handle stream))
29         (add-stream-instance-flags stream :interactive))
30       (unless (sm buffer stream)
31         (let ((length (device-buffer-length stream)))
32           (setf (sm buffer stream) (allocate-buffer length)
33                 (sm buf-len stream) length)))
34       (setf (sm control-in stream) *terminal-control-in-table*))
35     (when (getf options :output-handle)
36       (setf (sm output-handle stream) (getf options :output-handle))
37       (add-stream-instance-flags stream :simple :dual :output)
38       (unless (sm out-buffer stream)
39         (let ((length (device-buffer-length stream)))
40           (setf (sm out-buffer stream) (make-string length)
41                 (sm max-out-pos stream) length)))
42       (setf (sm control-out stream) *std-control-out-table*))
43     (let ((efmt (getf options :external-format :default)))
44       (compose-encapsulating-streams stream efmt)
45       (install-dual-channel-character-strategy
46        (melding-stream stream) efmt)))
47   stream)
48
49 (defmethod device-read ((stream terminal-simple-stream) buffer
50                         start end blocking)
51   (let ((result (call-next-method)))
52     (if (= result -1) -2 result)))
53
54 (defmethod device-clear-input ((stream terminal-simple-stream) buffer-only)
55   (unless buffer-only
56     (let ((buffer (allocate-buffer sb-impl::+bytes-per-buffer+)))
57       (unwind-protect
58            (loop until (<= (read-octets stream buffer
59                                         0 sb-impl::+bytes-per-buffer+ nil)
60                            0))
61         (free-buffer buffer)))))