Fix make-array transforms.
[sbcl.git] / contrib / sb-simple-streams / classes.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 ;;; Base class and generic function definitions for simple-streams
16
17 ;;; See chapter
18 ;;; 12.2 Strategy descriptions necessary for encapsulation
19 ;;; in the Franz documentation for a description of the j-xxx-fn slots.
20
21 ;;;; Types for buffer and strategy functions
22
23 (deftype simple-stream-buffer ()
24   '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
25
26 (deftype blocking ()
27   '(member t nil :bnb))
28
29 (deftype j-listen-fn ()
30   '(function (simple-stream) boolean))
31
32 (deftype j-read-char-fn ()
33   '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
34
35 (deftype j-read-chars-fn ()
36   '(function (simple-stream string (or character null) fixnum fixnum blocking)
37              (values fixnum &optional (member nil t :eof))))
38
39 (deftype j-write-char-fn ()
40   '(function ((or character null) simple-stream) (or character null)))
41
42 (deftype j-write-chars-fn ()
43   '(function (string simple-stream fixnum fixnum) t)) ; return chars-written?
44
45 (deftype j-unread-char-fn ()
46   '(function (simple-stream t) t)) ; "relaxed" arg is boolean?  what return?
47
48 ;;;; Base simple-stream classes
49
50 (def-stream-class simple-stream (standard-object stream)
51   (;; instance flags (not a normal slot in Allegro CL)
52    (%flags :initform 0 :type fixnum)
53    (plist :initform nil :type list :accessor stream-plist)
54
55    ;; Strategy slots.  See section 12.2 of streams.htm for function
56    ;; signatures and possible side-effects.
57
58    ;; A function that determines if one character can be successfully
59    ;; read from stream.
60    (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn)
61    ;; A function that reads one character.
62    (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn)
63    ;; A function that reads characters into a string.
64    (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn)
65    ;; A function that writes one character.
66    (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn)
67    ;; A function that writes characters from a string into the stream.
68    (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn)
69    ;; A function that unreads the last character read.
70    (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn)
71
72    ;; Other slots
73
74    ;; TODO: find out what this one does
75    (oc-state :initform nil)
76    ;; TODO: find out what this one does
77    (co-state :initform nil)
78    (external-format :initform (find-external-format :default))
79
80    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
81    ;; the stream is not open for input.
82    (input-handle :initform nil :initarg :input-handle
83                  :type (or null fixnum stream)
84                  :accessor stream-input-handle)
85    ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
86    ;; the stream is not open for output.
87    (output-handle :initform nil :initarg :output-handle
88                   :type (or null fixnum stream)
89                   :accessor stream-output-handle)
90    (control-in :initform nil :type (or null simple-vector))
91    (control-out :initform nil :type (or null simple-vector))
92
93    ;; a stream, allowing for composing external formats (see
94    ;; streams.htm, section 12.5) TODO: document this better
95    (melded-stream :type (or null simple-stream))
96    ;; a stream, allowing for composing external formats (see
97    ;; streams.htm, section 12.5) TODO: document this better
98    (melding-base :type (or null simple-stream))
99
100    ;; Number of octets the last read-char operation consumed TODO:
101    ;; document this better; what is the difference to
102    ;; last-char-read-size ?
103    (encapsulated-char-read-size :initform 0 :type fixnum)
104    ;; Number of octets the last read-char operation consumed
105    (last-char-read-size :initform 0 :type fixnum)
106    (charpos :initform 0 :type (or null integer)
107             :accessor stream-line-column)
108    (record-end :initform nil :type (or null fixnum))
109
110   ;; Input/output buffer.
111    (buffer :initform nil :type (or simple-stream-buffer null))
112    ;; Current position in buffer.
113    (buffpos :initform 0 :type fixnum)
114    ;; Maximum valid position in buffer, or -1 on eof.
115    (buffer-ptr :initform 0 :type fixnum)
116    (buf-len :initform 0 :type fixnum)
117
118    (pending :initform nil :type list)
119    (handler :initform nil :type (or null sb-impl::handler))))
120
121 (def-stream-class single-channel-simple-stream (simple-stream)
122   (;; the "dirty" flag -- if this is > 0, write out buffer contents
123    ;; before changing position; see flush-buffer
124    (mode :initform 0 :type fixnum)))
125
126 (def-stream-class dual-channel-simple-stream (simple-stream)
127   (;; Output buffer.
128    (out-buffer :initform nil :type (or simple-stream-buffer null))
129    ;; Current position in output buffer.
130    (outpos :initform 0 :type fixnum)
131    ;; Buffer length (one greater than maximum output buffer index)
132    (max-out-pos :initform 0 :type fixnum)))
133
134 ;;; A stream with a string as buffer.
135 (def-stream-class string-simple-stream (simple-stream string-stream)
136   ())
137
138
139 ;;; ======================================================
140
141
142 ;;;
143 ;;; DEVICE-LEVEL FUNCTIONS
144 ;;;
145
146 (defgeneric device-open (stream options))
147
148 (defgeneric device-close (stream abort))
149
150 (defgeneric device-buffer-length (stream))
151
152 (defgeneric device-file-position (stream))
153
154 (defgeneric (setf device-file-position) (value stream))
155
156 (defgeneric device-file-length (stream))
157
158 (defgeneric device-read (stream buffer start end blocking))
159
160 (defgeneric device-clear-input (stream buffer-only))
161
162 (defgeneric device-write (stream buffer start end blocking))
163
164 (defgeneric device-clear-output (stream))
165
166 (defgeneric device-finish-record (stream blocking action))
167
168
169 (defmethod shared-initialize :after ((instance simple-stream) slot-names
170                                      &rest initargs &key &allow-other-keys)
171   (declare (ignore slot-names))
172   (unless (slot-boundp instance 'melded-stream)
173     (setf (slot-value instance 'melded-stream) instance)
174     (setf (slot-value instance 'melding-base) instance))
175   (unless (device-open instance initargs)
176     (device-close instance t)))
177
178
179 (defmethod print-object ((object simple-stream) stream)
180   (print-unreadable-object (object stream :type nil :identity nil)
181     (cond ((not (any-stream-instance-flags object :simple))
182            (princ "Invalid " stream))
183           ((not (any-stream-instance-flags object :input :output))
184            (princ "Closed " stream)))
185     (format stream "~:(~A~)" (type-of object))))
186
187 ;;; This takes care of the things all device-close methods have to do,
188 ;;; regardless of the type of simple-stream
189 (defmethod device-close :around ((stream simple-stream) abort)
190   (with-stream-class (simple-stream stream)
191     (when (any-stream-instance-flags stream :input :output)
192       (when (any-stream-instance-flags stream :output)
193         (ignore-errors (if abort
194                            (clear-output stream)
195                            (finish-output stream))))
196       (call-next-method)
197       (setf (sm input-handle stream) nil
198             (sm output-handle stream) nil)
199       (remove-stream-instance-flags stream :input :output)
200       (sb-ext:cancel-finalization stream)
201       ;; This sets all readers and writers to error-raising functions
202       (setf (stream-external-format stream) :void))))
203
204 (defmethod device-close ((stream simple-stream) abort)
205   (declare (ignore abort))
206   t)
207
208 (defmethod device-buffer-length ((stream simple-stream))
209   4096)
210
211 (defmethod device-file-position ((stream simple-stream))
212   (with-stream-class (simple-stream stream)
213     (sm buffpos stream)))
214
215 (defmethod (setf device-file-position) (value (stream simple-stream))
216   (with-stream-class (simple-stream stream)
217     (setf (sm buffpos stream) value)))
218
219 (defmethod device-file-length ((stream simple-stream))
220   nil)
221
222 (defgeneric (setf stream-external-format) (value stream))
223
224 (defmethod (setf stream-external-format) :before (value (stream simple-stream))
225   ;; (unless (eq value (sm external-format stream))
226   ;;   flush out the existing external-format
227   )
228
229 (defmethod (setf stream-external-format) :after
230     (ef (stream single-channel-simple-stream))
231   (compose-encapsulating-streams stream ef)
232   (install-single-channel-character-strategy (melding-stream stream) ef nil))
233
234 (defmethod (setf stream-external-format) :after
235     (ef (stream dual-channel-simple-stream))
236   (compose-encapsulating-streams stream ef)
237   (install-dual-channel-character-strategy (melding-stream stream) ef))
238
239
240 (defmethod device-read ((stream single-channel-simple-stream) buffer
241                         start end blocking)
242   (read-octets stream buffer start end blocking))
243
244 (defmethod device-read ((stream dual-channel-simple-stream) buffer
245                         start end blocking)
246   (read-octets stream buffer start end blocking))
247
248 (defmethod device-clear-input ((stream simple-stream) buffer-only)
249   (declare (ignore buffer-only))
250   nil)
251
252 (defmethod device-write ((stream single-channel-simple-stream) buffer
253                          start end blocking)
254   ;; buffer may be :flush to force/finish-output
255   (when (or (and (null buffer) (not (eql start end)))
256             (eq buffer :flush))
257     (with-stream-class (single-channel-simple-stream stream)
258       (setf buffer (sm buffer stream))
259       (setf end (sm buffpos stream))))
260   (write-octets stream buffer start end blocking))
261
262 (defmethod device-write ((stream dual-channel-simple-stream) buffer
263                          start end blocking)
264   ;; buffer may be :flush to force/finish-output
265   (when (or (and (null buffer) (not (eql start end)))
266             (eq buffer :flush))
267     (with-stream-class (dual-channel-simple-stream stream)
268       (setf buffer (sm out-buffer stream))
269       (setf end (sm outpos stream))))
270   (write-octets stream buffer start end blocking))
271
272 (defmethod device-clear-output ((stream simple-stream))
273   nil)