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