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")
11 ;;; (pushnew :sb-simple-stream *features*)
14 ;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
18 ;;; 12.2 Strategy descriptions necessary for encapsulation
19 ;;; in the Franz documentation for a description of the j-xxx-fn slots.
21 (deftype simple-stream-buffer ()
22 '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
27 (deftype j-listen-fn ()
28 '(function (simple-stream) boolean))
30 (deftype j-read-char-fn ()
31 '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
33 (deftype j-read-chars-fn ()
34 '(function (simple-stream string (or character null) fixnum fixnum blocking)
35 (values fixnum &optional (member nil t :eof))))
37 (deftype j-write-char-fn ()
38 '(function (character simple-stream) character))
40 (deftype j-write-chars-fn ()
41 '(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
43 (deftype j-unread-char-fn ()
44 '(function (simple-stream t) t)) ;; "relaxed" arg is boolean? what return?
50 ;;; KLUDGE (sat 2003-01-15): def-stream-class and the
51 ;;; with-stream-class / sm accessors implement a form of "sealing" of
52 ;;; classes -- i.e., implementing very fast slot access at the price
53 ;;; of not being able to change the class definition at runtime.
54 ;;; Instead of a method call, a slot access for a simple-stream
55 ;;; subclass is a funcall or (when the def-stream-class form has a
56 ;;; location argument for the slot) a sb-pcl::clos-slots-ref. Given a
57 ;;; sufficiently advanced PCL with (non-standard) sealing
58 ;;; declarations, this machinery would be superfluous. For the time
59 ;;; being, replacing 4 method calls with vector accesses for the fast
60 ;;; path of read-char seems worthwhile to me. Besides, it's the
61 ;;; documented interface to simple-stream internals, and so it's worth
64 (eval-when (:compile-toplevel :load-toplevel :execute)
65 (declaim (type hash-table *slot-access-functions*))
66 (defvar *slot-access-functions* (make-hash-table))
67 (defvar *automagic-accessors* nil))
69 (defmacro def-stream-class (name superclasses slots &rest options)
73 ;; Frob the slot arguments, memorizing either the location (an
74 ;; integer) or the accessor of the slot. Optionally construct
75 ;; an accessor if none is given.
76 (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
77 ;; We have got a location specifier. Memorize it and
78 ;; extract it until pcl itself can work with these.
79 (push (cons (first slot)
80 (cons (getf (rest slot) :type t)
81 (getf (rest slot) 'sb-pcl::location)))
83 (let ((slot (copy-list slot)))
84 (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
85 (push slot real-slots)))
86 ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
87 (if *automagic-accessors*
88 ;; Add an :accessor argument, and memorize it. FIXME:
89 ;; will this work with sbcl? reader/writers are
90 ;; named differently there (see
91 ;; src/pcl/slot-name.lisp)
92 (let* ((slot (if (consp slot) slot (list slot)))
93 (accessor (or (cdr (gethash (first slot)
94 *slot-access-functions*))
95 (intern (format nil "~A ~A slot ACCESSOR"
97 "SB-SLOT-ACCESSOR-NAME"))))
98 (push (cons (first slot)
99 (cons (getf (rest slot) :type t) accessor))
101 (push (append slot `(:accessor ,accessor)) real-slots))
102 (push slot real-slots)))
104 ;; No location given, but we have an accessor. Memorize it.
105 (push (cons (first slot)
106 (cons (getf (rest slot) :type t)
107 (getf (rest slot) :accessor)))
109 (push slot real-slots))))
111 (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
112 (eval-when (:compile-toplevel :load-toplevel :execute)
113 ,@(loop for accessor in accessors
114 do (let ((exists (gethash (car accessor)
115 *slot-access-functions*)))
117 (integerp (cdr exists))
118 (integerp (cddr accessor))
119 (/= (cdr exists) (cddr accessor)))
120 (warn "~S slot ~S has moved! ~
121 I hope you know what you're doing!"
122 name (car accessor))))
123 collect `(setf (gethash ',(car accessor) *slot-access-functions*)
124 ',(cdr accessor)))))))
126 (def-stream-class simple-stream (standard-object stream)
127 ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
129 ;; Strategy slots. See section 12.2 of streams.htm for function
130 ;; signatures and possible side-effects.
132 ;; A function that determines if one character can be successfully
134 (j-listen :type j-listen-fn sb-pcl::location 18)
135 ;; A function that reads one character.
136 (j-read-char :type j-read-char-fn sb-pcl::location 17)
137 ;; A function that reads characters into a string.
138 (j-read-chars :type j-read-chars-fn sb-pcl::location 16)
139 ;; A function that writes one character.
140 (j-write-char :type j-write-char-fn sb-pcl::location 15)
141 ;; A function that writes characters from a string into the stream.
142 (j-write-chars :type j-write-chars-fn sb-pcl::location 14)
143 ;; A function that unreads the last character read.
144 (j-unread-char :type j-unread-char-fn sb-pcl::location 13)
148 ;; Always a stream, allowing for composing external formats (see
149 ;; streams.htm, section 12.5) TODO: document this better
150 (melded-stream sb-pcl::location 12)
151 ;; Always a stream, allowing for composing external formats (see
152 ;; streams.htm, section 12.5) TODO: document this better
153 (melding-base sb-pcl::location 11)
154 ;; Number of octets the last read-char operation consumed TODO:
155 ;; document this better; what is the difference to
156 ;; last-char-read-size ?
157 (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
158 (mode :initform 0 :type fixnum sb-pcl::location 9)
159 (control-in :initform nil :type (or null simple-vector)
161 (control-out :initform nil :type (or null simple-vector)
163 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
164 ;; the stream is not open for input.
165 (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
166 :type (or null fixnum stream)
167 :accessor stream-input-handle)
168 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
169 ;; the stream is not open for output.
170 (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
171 :type (or null fixnum stream)
172 :accessor stream-output-handle)
173 (external-format :initform :default sb-pcl::location 4)
174 (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
175 ;; The character position of the stream.
176 (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
177 ;; Number of octets the last read-char operation consumed
178 (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
179 ;; instance flags (not a normal slot in Allegro CL)
180 (%flags :initform 0 :type fixnum sb-pcl::location 0)))
182 (def-stream-class probe-simple-stream (simple-stream)
185 ;;; A stream with a single buffer, for example a file stream.
186 (def-stream-class single-channel-simple-stream (simple-stream)
187 ;; Input/output buffer.
188 ((buffer :initform nil :type (or simple-stream-buffer null)
190 ;; Current position in buffer.
191 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
192 ;; Maximum valid position in buffer, or -1 on eof.
193 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
194 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
196 (def-stream-class direct-simple-stream (single-channel-simple-stream)
199 (def-stream-class buffer-input-simple-stream (direct-simple-stream)
202 (def-stream-class buffer-output-simple-stream (direct-simple-stream)
203 ((out-buffer :initform nil :type (or simple-stream-buffer null)
205 ;; Current position in output buffer.
206 (outpos :initform 0 :type fixnum sb-pcl::location 25)
207 ;; Buffer length (one greater than maximum output buffer index)
208 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
210 (def-stream-class null-simple-stream (single-channel-simple-stream)
213 (def-stream-class file-simple-stream (single-channel-simple-stream)
214 ((pathname :initform nil :initarg :pathname)
215 (filename :initform nil :initarg :filename)
216 (original :initform nil :initarg :original)
217 (delete-original :initform nil :initarg :delete-original)
220 (def-stream-class mapped-file-simple-stream (file-simple-stream
221 direct-simple-stream)
224 ;;; A stream with two octet buffers, for example a socket or terminal
226 (def-stream-class dual-channel-simple-stream (simple-stream)
228 ((out-buffer :initform nil :type (or simple-stream-buffer null)
230 ;; Current position in output buffer.
231 (outpos :initform 0 :type fixnum sb-pcl::location 25)
232 ;; Buffer length (one greater than maximum output buffer index)
233 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
234 ;; Input buffer (in this case; the 'buffer' slot serves as
235 ;; bidirectional buffer for single-channel-simple-streams).
236 (buffer :initform nil :type (or simple-stream-buffer null)
238 ;; Current position in buffer.
239 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
240 ;; Maximum valid position in buffer, or -1 on eof.
241 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
242 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
244 (def-stream-class terminal-simple-stream (dual-channel-simple-stream)
247 (def-stream-class socket-simple-stream (dual-channel-simple-stream)
248 ((socket :initform nil :type (or sb-bsd-sockets:socket null)
249 :initarg :socket sb-pcl::location 27)))
251 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
254 (def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
257 ;;; A stream with a string as buffer.
258 (def-stream-class string-simple-stream (simple-stream)
259 ;; The input/output buffer.
260 ((buffer :initform nil :type (or simple-stream-buffer null)
262 ;; Current position in buffer.
263 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
264 ;; Maximum valid position in buffer, or -1 on eof.
265 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
266 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
268 (def-stream-class composing-stream (string-simple-stream)
271 (def-stream-class string-input-simple-stream (string-simple-stream)
274 (def-stream-class string-output-simple-stream (string-simple-stream)
275 ;; The output buffer (slot added so that a class can inherit from
276 ;; both string-input-simple-stream and string-output-simple-stream
277 ;; without the strategies clashing)
278 ((out-buffer :initform nil :type (or simple-stream-buffer null)
280 ;; Current position in output buffer.
281 (outpos :initform 0 :type fixnum sb-pcl::location 25)
282 ;; Buffer length (one greater than maximum output buffer index)
283 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
285 (def-stream-class fill-pointer-output-simple-stream
286 (string-output-simple-stream)
289 (def-stream-class limited-string-output-simple-stream
290 (string-output-simple-stream)
293 (def-stream-class xp-simple-stream (string-output-simple-stream)
296 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
300 (defclass default-latin1-base-ef () ())
301 (defclass stream-recording-mixin () ())
302 (defclass stream-recording-repaint-mixin () ())
305 (eval-when (:compile-toplevel :load-toplevel :execute)
306 (setf *automagic-accessors* nil))
309 ;;; DEVICE-LEVEL FUNCTIONS
312 (defgeneric device-open (stream options))
314 (defgeneric device-close (stream abort))
316 (defgeneric device-buffer-length (stream))
318 (defgeneric device-file-position (stream))
320 (defgeneric (setf device-file-position) (value stream))
322 (defgeneric device-file-length (stream))
324 (defgeneric device-read (stream buffer start end blocking))
326 (defgeneric device-clear-input (stream buffer-only))
328 (defgeneric device-write (stream buffer start end blocking))
330 (defgeneric device-clear-output (stream))
332 (defgeneric device-extend (stream need action))
334 (defgeneric device-finish-record (stream blocking action))