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 ((or character null) simple-stream) (or character null)))
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 ;;; Commented out in favor of standard class machinery that does not
70 ;;; depend on implementation internals.
72 (defmacro def-stream-class (name superclasses slots &rest options)
76 ;; Frob the slot arguments, memorizing either the location (an
77 ;; integer) or the accessor of the slot. Optionally construct
78 ;; an accessor if none is given.
79 (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
80 ;; We have got a location specifier. Memorize it and
81 ;; extract it until pcl itself can work with these.
82 (push (cons (first slot)
83 (cons (getf (rest slot) :type t)
84 (getf (rest slot) 'sb-pcl::location)))
86 (let ((slot (copy-list slot)))
87 (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
88 (push slot real-slots)))
89 ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
90 (if *automagic-accessors*
91 ;; Add an :accessor argument, and memorize it. FIXME:
92 ;; will this work with sbcl? reader/writers are
93 ;; named differently there (see
94 ;; src/pcl/slot-name.lisp)
95 (let* ((slot (if (consp slot) slot (list slot)))
96 (accessor (or (cdr (gethash (first slot)
97 *slot-access-functions*))
98 (intern (format nil "~A ~A slot ACCESSOR"
100 "SB-SLOT-ACCESSOR-NAME"))))
101 (push (cons (first slot)
102 (cons (getf (rest slot) :type t) accessor))
104 (push (append slot `(:accessor ,accessor)) real-slots))
105 (push slot real-slots)))
107 ;; No location given, but we have an accessor. Memorize it.
108 (push (cons (first slot)
109 (cons (getf (rest slot) :type t)
110 (getf (rest slot) :accessor)))
112 (push slot real-slots))))
114 (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
115 (eval-when (:compile-toplevel :load-toplevel :execute)
116 ,@(loop for accessor in accessors
117 do (let ((exists (gethash (car accessor)
118 *slot-access-functions*)))
120 (integerp (cdr exists))
121 (integerp (cddr accessor))
122 (/= (cdr exists) (cddr accessor)))
123 (warn "~S slot ~S has moved! ~
124 I hope you know what you're doing!"
125 name (car accessor))))
126 collect `(setf (gethash ',(car accessor) *slot-access-functions*)
127 ',(cdr accessor)))))))
130 (defmacro def-stream-class (name superclasses slots &rest options)
131 (let ((slots (copy-tree slots)))
132 (dolist (slot slots) (remf (cdr slot) 'sb-pcl::location))
133 `(defclass ,name ,superclasses ,slots ,@options)))
135 (def-stream-class simple-stream (standard-object stream)
136 ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
138 ;; Strategy slots. See section 12.2 of streams.htm for function
139 ;; signatures and possible side-effects.
141 ;; A function that determines if one character can be successfully
143 (j-listen :initform #'sb-kernel:ill-in :type j-listen-fn sb-pcl::location 18)
144 ;; A function that reads one character.
145 (j-read-char :initform #'sb-kernel:ill-in :type j-read-char-fn sb-pcl::location 17)
146 ;; A function that reads characters into a string.
147 (j-read-chars :initform #'sb-kernel:ill-in :type j-read-chars-fn sb-pcl::location 16)
148 ;; A function that writes one character.
149 (j-write-char :initform #'sb-kernel:ill-out :type j-write-char-fn sb-pcl::location 15)
150 ;; A function that writes characters from a string into the stream.
151 (j-write-chars :initform #'sb-kernel:ill-out :type j-write-chars-fn sb-pcl::location 14)
152 ;; A function that unreads the last character read.
153 (j-unread-char :initform #'sb-kernel:ill-in :type j-unread-char-fn sb-pcl::location 13)
157 ;; Always a stream, allowing for composing external formats (see
158 ;; streams.htm, section 12.5) TODO: document this better
159 (melded-stream sb-pcl::location 12)
160 ;; Always a stream, allowing for composing external formats (see
161 ;; streams.htm, section 12.5) TODO: document this better
162 (melding-base sb-pcl::location 11)
163 ;; Number of octets the last read-char operation consumed TODO:
164 ;; document this better; what is the difference to
165 ;; last-char-read-size ?
166 (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
167 (mode :initform 0 :type fixnum sb-pcl::location 9)
168 (control-in :initform nil :type (or null simple-vector)
170 (control-out :initform nil :type (or null simple-vector)
172 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
173 ;; the stream is not open for input.
174 (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
175 :type (or null fixnum stream)
176 :accessor stream-input-handle)
177 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
178 ;; the stream is not open for output.
179 (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
180 :type (or null fixnum stream)
181 :accessor stream-output-handle)
182 (external-format :initform :default sb-pcl::location 4)
183 (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
184 ;; The character position of the stream.
185 (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
186 ;; Number of octets the last read-char operation consumed
187 (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
188 ;; instance flags (not a normal slot in Allegro CL)
189 (%flags :initform 0 :type fixnum sb-pcl::location 0)))
191 (def-stream-class probe-simple-stream (simple-stream)
194 ;;; A stream with a single buffer, for example a file stream.
195 (def-stream-class single-channel-simple-stream (simple-stream)
196 ;; Input/output buffer.
197 ((buffer :initform nil :type (or simple-stream-buffer null)
199 ;; Current position in buffer.
200 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
201 ;; Maximum valid position in buffer, or -1 on eof.
202 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
203 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
205 (def-stream-class direct-simple-stream (single-channel-simple-stream)
208 (def-stream-class buffer-input-simple-stream (direct-simple-stream)
211 (def-stream-class buffer-output-simple-stream (direct-simple-stream)
212 ((out-buffer :initform nil :type (or simple-stream-buffer null)
214 ;; Current position in output buffer.
215 (outpos :initform 0 :type fixnum sb-pcl::location 25)
216 ;; Buffer length (one greater than maximum output buffer index)
217 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
219 (def-stream-class null-simple-stream (single-channel-simple-stream)
222 (def-stream-class file-simple-stream (single-channel-simple-stream)
223 ((pathname :initform nil :initarg :pathname sb-pcl::location 27)
224 (filename :initform nil :initarg :filename sb-pcl::location 26)
225 (original :initform nil :initarg :original sb-pcl::location 25)
226 (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)
271 (def-stream-class composing-stream (string-simple-stream)
274 (def-stream-class string-input-simple-stream (string-simple-stream)
275 (;; The input buffer.
276 (buffer :initform nil :type (or simple-stream-buffer null)
278 ;; Current position in buffer.
279 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
280 ;; Maximum valid position in buffer, or -1 on eof.
281 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
282 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
284 (def-stream-class string-output-simple-stream (string-simple-stream)
285 (;; The input buffer.
286 (buffer :initform nil :type (or simple-stream-buffer null)
288 ;; Current position in input buffer.
289 (buffpos :initform 0 :type fixnum sb-pcl::location 25)
290 ;; Maximum valid position in input buffer, or -1 on eof.
291 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 24)
292 (buf-len :initform 0 :type fixnum sb-pcl::location 23)
293 ;; The output buffer (slot added so that a class can inherit from
294 ;; both string-input-simple-stream and string-output-simple-stream
295 ;; without the strategies clashing)
296 (out-buffer :initform nil :type (or simple-stream-buffer null)
298 ;; Current position in output buffer.
299 (outpos :initform 0 :type fixnum sb-pcl::location 21)
300 ;; Buffer length (one greater than maximum output buffer index)
301 (max-out-pos :initform 0 :type fixnum sb-pcl::location 20)))
303 (def-stream-class fill-pointer-output-simple-stream
304 (string-output-simple-stream)
307 (def-stream-class limited-string-output-simple-stream
308 (string-output-simple-stream)
311 (def-stream-class xp-simple-stream (string-output-simple-stream)
314 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
318 (defclass default-latin1-base-ef () ())
319 (defclass stream-recording-mixin () ())
320 (defclass stream-recording-repaint-mixin () ())
323 (eval-when (:compile-toplevel :load-toplevel :execute)
324 (setf *automagic-accessors* nil))
327 ;;; DEVICE-LEVEL FUNCTIONS
330 (defgeneric device-open (stream options))
332 (defgeneric device-close (stream abort))
334 (defgeneric device-buffer-length (stream))
336 (defgeneric device-file-position (stream))
338 (defgeneric (setf device-file-position) (value stream))
340 (defgeneric device-file-length (stream))
342 (defgeneric device-read (stream buffer start end blocking))
344 (defgeneric device-clear-input (stream buffer-only))
346 (defgeneric device-write (stream buffer start end blocking))
348 (defgeneric device-clear-output (stream))
350 (defgeneric device-finish-record (stream blocking action))