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")
15 (pushnew :sb-simple-stream *features*)
17 (eval-when (:compile-toplevel :load-toplevel :execute)
18 #+(or X86) (pushnew :little-endian *features*))
20 (eval-when (:compile-toplevel :load-toplevel :execute)
21 #-little-endian (pushnew :big-endian *features*))
23 (eval-when (:compile-toplevel :load-toplevel :execute)
24 #-(or big-endian little-endian) (error "Unsupported architecture"))
28 ;;; TYPES FOR BUFFER AND STRATEGY FUNCTIONS
32 ;;; 12.2 Strategy descriptions necessary for encapsulation
33 ;;; in the Franz documentation for a description of the j-xxx-fn slots.
35 (deftype simple-stream-buffer ()
36 '(or sb-sys:system-area-pointer (sb-kernel:simple-unboxed-array (*))))
41 (deftype j-listen-fn ()
42 '(function (simple-stream) boolean))
44 (deftype j-read-char-fn ()
45 '(function (simple-stream boolean t boolean) t)) ; may return EOF-VALUE
47 (deftype j-read-chars-fn ()
48 '(function (simple-stream string (or character null) fixnum fixnum blocking)
49 (values fixnum &optional (member nil t :eof))))
51 (deftype j-write-char-fn ()
52 '(function (character simple-stream) character))
54 (deftype j-write-chars-fn ()
55 '(function (string simple-stream fixnum fixnum) t)) ;; return chars-written?
57 (deftype j-unread-char-fn ()
58 '(function (simple-stream t) t)) ;; "relaxed" arg is boolean? what return?
64 ;;; KLUDGE (sat 2003-01-15): def-stream-class and the
65 ;;; with-stream-class / sm accessors implement a form of "sealing" of
66 ;;; classes -- i.e., implementing very fast slot access at the price
67 ;;; of not being able to change the class definition at runtime.
68 ;;; Instead of a method call, a slot access for a simple-stream
69 ;;; subclass is a funcall or (when the def-stream-class form has a
70 ;;; location argument for the slot) a sb-pcl::clos-slots-ref. Given a
71 ;;; sufficiently advanced PCL with (non-standard) sealing
72 ;;; declarations, this machinery would be superfluous. For the time
73 ;;; being, replacing 4 method calls with vector accesses for the fast
74 ;;; path of read-char seems worthwhile to me. Besides, it's the
75 ;;; documented interface to simple-stream internals, and so it's worth
78 (eval-when (:compile-toplevel :load-toplevel :execute)
79 (declaim (type hash-table *slot-access-functions*))
80 (defvar *slot-access-functions* (make-hash-table))
81 (defvar *automagic-accessors* nil))
83 (defmacro def-stream-class (name superclasses slots &rest options)
87 ;; Frob the slot arguments, memorizing either the location (an
88 ;; integer) or the accessor of the slot. Optionally construct
89 ;; an accessor if none is given.
90 (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
91 ;; We have got a location specifier. Memorize it and
92 ;; extract it until pcl itself can work with these.
93 (push (cons (first slot)
94 (cons (getf (rest slot) :type t)
95 (getf (rest slot) 'sb-pcl::location)))
97 (let ((slot (copy-list slot)))
98 (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
99 (push slot real-slots)))
100 ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
101 (if *automagic-accessors*
102 ;; Add an :accessor argument, and memorize it. FIXME:
103 ;; will this work with sbcl? reader/writers are
104 ;; named differently there (see
105 ;; src/pcl/slot-name.lisp)
106 (let* ((slot (if (consp slot) slot (list slot)))
107 (accessor (or (cdr (gethash (first slot)
108 *slot-access-functions*))
109 (intern (format nil "~A ~A slot ACCESSOR"
111 "SB-SLOT-ACCESSOR-NAME"))))
112 (push (cons (first slot)
113 (cons (getf (rest slot) :type t) accessor))
115 (push (append slot `(:accessor ,accessor)) real-slots))
116 (push slot real-slots)))
118 ;; No location given, but we have an accessor. Memorize it.
119 (push (cons (first slot)
120 (cons (getf (rest slot) :type t)
121 (getf (rest slot) :accessor)))
123 (push slot real-slots))))
125 (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
126 (eval-when (:compile-toplevel :load-toplevel :execute)
127 ,@(loop for accessor in accessors
128 do (let ((exists (gethash (car accessor)
129 *slot-access-functions*)))
131 (integerp (cdr exists))
132 (integerp (cddr accessor))
133 (/= (cdr exists) (cddr accessor)))
134 (warn "~S slot ~S has moved! ~
135 I hope you know what you're doing!"
136 name (car accessor))))
137 collect `(setf (gethash ',(car accessor) *slot-access-functions*)
138 ',(cdr accessor)))))))
140 (def-stream-class simple-stream (standard-object stream)
141 ((plist :initform nil :type list :accessor stream-plist sb-pcl::location 19)
143 ;; Strategy slots. See section 12.2 of streams.htm for function
144 ;; signatures and possible side-effects.
146 ;; A function that determines if one character can be successfully
148 (j-listen :type j-listen-fn sb-pcl::location 18)
149 ;; A function that reads one character.
150 (j-read-char :type j-read-char-fn sb-pcl::location 17)
151 ;; A function that reads characters into a string.
152 (j-read-chars :type j-read-chars-fn sb-pcl::location 16)
153 ;; A function that writes one character.
154 (j-write-char :type j-write-char-fn sb-pcl::location 15)
155 ;; A function that writes characters from a string into the stream.
156 (j-write-chars :type j-write-chars-fn sb-pcl::location 14)
157 ;; A function that unreads the last character read.
158 (j-unread-char :type j-unread-char-fn sb-pcl::location 13)
162 ;; Always a stream, allowing for composing external formats (see
163 ;; streams.htm, section 12.5) TODO: document this better
164 (melded-stream sb-pcl::location 12)
165 ;; Always a stream, allowing for composing external formats (see
166 ;; streams.htm, section 12.5) TODO: document this better
167 (melding-base sb-pcl::location 11)
168 ;; Number of octets the last read-char operation consumed TODO:
169 ;; document this better; what is the difference to
170 ;; last-char-read-size ?
171 (encapsulated-char-read-size :initform 0 :type fixnum sb-pcl::location 10)
172 (mode :initform 0 :type fixnum sb-pcl::location 9)
173 (control-in :initform nil :type (or null simple-vector)
175 (control-out :initform nil :type (or null simple-vector)
177 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
178 ;; the stream is not open for input.
179 (input-handle :initform nil :initarg :input-handle sb-pcl::location 6
180 :type (or null fixnum stream)
181 :accessor stream-input-handle)
182 ;; A fixnum (denoting a valid file descriptor), a stream, or nil if
183 ;; the stream is not open for output.
184 (output-handle :initform nil :initarg :output-handle sb-pcl::location 5
185 :type (or null fixnum stream)
186 :accessor stream-output-handle)
187 (external-format :initform :default sb-pcl::location 4)
188 (record-end :initform nil :type (or null fixnum) sb-pcl::location 3)
189 ;; The character position of the stream.
190 (charpos :initform 0 :type (or null integer) sb-pcl::location 2)
191 ;; Number of octets the last read-char operation consumed
192 (last-char-read-size :initform 0 :type fixnum sb-pcl::location 1)
193 ;; instance flags (not a normal slot in Allegro CL)
194 (%flags :initform 0 :type fixnum sb-pcl::location 0)))
196 (def-stream-class probe-simple-stream (simple-stream)
199 ;;; A stream with a single buffer, for example a file stream.
200 (def-stream-class single-channel-simple-stream (simple-stream)
201 ;; Input/output buffer.
202 ((buffer :initform nil :type (or simple-stream-buffer null)
204 ;; Current position in buffer.
205 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
206 ;; Maximum valid position in buffer, or -1 on eof.
207 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
208 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
210 (def-stream-class direct-simple-stream (single-channel-simple-stream)
213 (def-stream-class buffer-input-simple-stream (direct-simple-stream)
216 (def-stream-class buffer-output-simple-stream (direct-simple-stream)
217 ((out-buffer :initform nil :type (or simple-stream-buffer null)
219 ;; Current position in output buffer.
220 (outpos :initform 0 :type fixnum sb-pcl::location 25)
221 ;; Buffer length (one greater than maximum output buffer index)
222 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
224 (def-stream-class null-simple-stream (single-channel-simple-stream)
227 (def-stream-class file-simple-stream (single-channel-simple-stream)
228 ((pathname :initform nil :initarg :pathname)
229 (filename :initform nil :initarg :filename)
230 (original :initform nil :initarg :original)
231 (delete-original :initform nil :initarg :delete-original)
234 (def-stream-class mapped-file-simple-stream (file-simple-stream
235 direct-simple-stream)
238 ;;; A stream with two octet buffers, for example a socket or terminal
240 (def-stream-class dual-channel-simple-stream (simple-stream)
242 ((out-buffer :initform nil :type (or simple-stream-buffer null)
244 ;; Current position in output buffer.
245 (outpos :initform 0 :type fixnum sb-pcl::location 25)
246 ;; Buffer length (one greater than maximum output buffer index)
247 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)
248 ;; Input buffer (in this case; the 'buffer' slot serves as
249 ;; bidirectional buffer for single-channel-simple-streams).
250 (buffer :initform nil :type (or simple-stream-buffer null)
252 ;; Current position in buffer.
253 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
254 ;; Maximum valid position in buffer, or -1 on eof.
255 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
256 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
258 (def-stream-class terminal-simple-stream (dual-channel-simple-stream)
261 (def-stream-class socket-simple-stream (dual-channel-simple-stream)
264 (def-stream-class socket-base-simple-stream (dual-channel-simple-stream)
267 (def-stream-class hiper-socket-simple-stream (dual-channel-simple-stream)
270 ;;; A stream with a string as buffer.
271 (def-stream-class string-simple-stream (simple-stream)
272 ;; The input/output buffer.
273 ((buffer :initform nil :type (or simple-stream-buffer null)
275 ;; Current position in buffer.
276 (buffpos :initform 0 :type fixnum sb-pcl::location 22)
277 ;; Maximum valid position in buffer, or -1 on eof.
278 (buffer-ptr :initform 0 :type fixnum sb-pcl::location 21)
279 (buf-len :initform 0 :type fixnum sb-pcl::location 20)))
281 (def-stream-class composing-stream (string-simple-stream)
284 (def-stream-class string-input-simple-stream (string-simple-stream)
287 (def-stream-class string-output-simple-stream (string-simple-stream)
288 ;; The output buffer (slot added so that a class can inherit from
289 ;; both string-input-simple-stream and string-output-simple-stream
290 ;; without the strategies clashing)
291 ((out-buffer :initform nil :type (or simple-stream-buffer null)
293 ;; Current position in output buffer.
294 (outpos :initform 0 :type fixnum sb-pcl::location 25)
295 ;; Buffer length (one greater than maximum output buffer index)
296 (max-out-pos :initform 0 :type fixnum sb-pcl::location 24)))
298 (def-stream-class fill-pointer-output-simple-stream
299 (string-output-simple-stream)
302 (def-stream-class limited-string-output-simple-stream
303 (string-output-simple-stream)
306 (def-stream-class xp-simple-stream (string-output-simple-stream)
309 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
313 (defclass default-latin1-base-ef () ())
314 (defclass stream-recording-mixin () ())
315 (defclass stream-recording-repaint-mixin () ())
318 (eval-when (:compile-toplevel :load-toplevel :execute)
319 (setf *automagic-accessors* nil))
322 ;;; DEVICE-LEVEL FUNCTIONS
325 (defgeneric device-open (stream options))
327 (defgeneric device-close (stream abort))
329 (defgeneric device-buffer-length (stream))
331 (defgeneric device-file-position (stream))
333 (defgeneric (setf device-file-position) (value stream))
335 (defgeneric device-file-length (stream))
337 (defgeneric device-read (stream buffer start end blocking))
339 (defgeneric device-clear-input (stream buffer-only))
341 (defgeneric device-write (stream buffer start end blocking))
343 (defgeneric device-clear-output (stream))
345 (defgeneric device-extend (stream need action))
347 (defgeneric device-finish-record (stream blocking action))