/[cxml]/closure-common/xstream.lisp
ViewVC logotype

Contents of /closure-common/xstream.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Sun Feb 24 20:38:35 2008 UTC (6 years, 1 month ago) by dlichteblau
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +5 -1 lines
allow Microsoft BOM (thanks to Ivan Shvedunov)
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
2 ;;; ---------------------------------------------------------------------------
3 ;;; Title: Fast streams
4 ;;; Created: 1999-07-17
5 ;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
6 ;;; License: Lisp-LGPL (See file COPYING for details).
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 1999 by Gilbert Baumann
9
10 ;;; This library is free software; you can redistribute it and/or
11 ;;; modify it under the terms of the GNU Library General Public
12 ;;; License as published by the Free Software Foundation; either
13 ;;; version 2 of the License, or (at your option) any later version.
14 ;;;
15 ;;; This library is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;;; Library General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU Library General Public
21 ;;; License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307 USA.
24
25 (in-package :runes)
26
27 ;;; API
28 ;;
29 ;; MAKE-XSTREAM cl-stream &key name! speed initial-speed initial-encoding
30 ;; [function]
31 ;; MAKE-ROD-XSTREAM rod &key name [function]
32 ;; CLOSE-XSTREAM xstream [function]
33 ;; XSTREAM-P object [function]
34 ;;
35 ;; READ-RUNE xstream [macro]
36 ;; PEEK-RUNE xstream [macro]
37 ;; FREAD-RUNE xstream [function]
38 ;; FPEEK-RUNE xstream [function]
39 ;; CONSUME-RUNE xstream [macro]
40 ;; UNREAD-RUNE rune xstream [function]
41 ;;
42 ;; XSTREAM-NAME xstream [accessor]
43 ;; XSTREAM-POSITION xstream [function]
44 ;; XSTREAM-LINE-NUMBER xstream [function]
45 ;; XSTREAM-COLUMN-NUMBER xstream [function]
46 ;; XSTREAM-PLIST xstream [accessor]
47 ;; XSTREAM-ENCODING xstream [accessor] <-- be careful here. [*]
48 ;; SET-TO-FULL-SPEED xstream [function]
49
50 ;; [*] switching the encoding on the fly is only possible when the
51 ;; stream's buffer is empty; therefore to be able to switch the
52 ;; encoding, while some runes are already read, set the stream's speed
53 ;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM)
54 ;; and later set it to full speed. (The encoding of the runes
55 ;; sequence, you fetch off with READ-RUNE is always UTF-16 though).
56 ;; After switching the encoding, SET-TO-FULL-SPEED can be used to bump the
57 ;; speed up to a full buffer length.
58
59 ;; An encoding is simply something, which provides the DECODE-SEQUENCE
60 ;; method.
61
62 ;;; Controller protocol
63 ;;
64 ;; READ-OCTECTS sequence os-stream start end -> first-non-written
65 ;; XSTREAM/CLOSE os-stream
66 ;;
67
68 (eval-when (:compile-toplevel :load-toplevel :execute)
69 (defparameter *fast* '(optimize (speed 3) (safety 0))))
70
71 ;; Let us first define fast fixnum arithmetric get rid of type
72 ;; checks. (After all we know what we do here).
73
74 (defmacro fx-op (op &rest xs)
75 `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
76 (defmacro fx-pred (op &rest xs)
77 `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
78
79 (defmacro %+ (&rest xs) `(fx-op + ,@xs))
80 (defmacro %= (&rest xs) `(fx-pred = ,@xs))
81
82 (deftype buffer-index ()
83 `(unsigned-byte ,(integer-length array-total-size-limit)))
84
85 (deftype buffer-byte ()
86 #+rune-is-utf-16
87 `(unsigned-byte 16)
88 #-rune-is-utf-16
89 `(unsigned-byte 32))
90
91 (deftype octet ()
92 `(unsigned-byte 8))
93
94 ;; The usage of a special marker for EOF is experimental and
95 ;; considered unhygenic.
96
97 (defconstant +end+ #xFFFF
98 "Special marker inserted into stream buffers to indicate end of buffered data.")
99
100 (defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte))
101 (defvar +null-octet-buffer+ (make-array 0 :element-type 'octet))
102
103 (defstruct (xstream
104 (:constructor make-xstream/low)
105 (:copier nil)
106 (:print-function print-xstream))
107
108 ;;; Read buffer
109
110 ;; the buffer itself
111 (buffer +null-buffer+
112 :type (simple-array buffer-byte (*)))
113 ;; points to the next element of `buffer' containing the next rune
114 ;; about to be read.
115 (read-ptr 0 :type buffer-index)
116 ;; points to the first element of `buffer' not containing a rune to
117 ;; be read.
118 (fill-ptr 0 :type buffer-index)
119
120 ;;; OS buffer
121
122 ;; a scratch pad for READ-SEQUENCE
123 (os-buffer +null-octet-buffer+
124 :type (simple-array octet (*)))
125
126 ;; `os-left-start', `os-left-end' designate a region of os-buffer,
127 ;; which still contains some undecoded data. This is needed because
128 ;; of the DECODE-SEQUENCE protocol
129 (os-left-start 0 :type buffer-index)
130 (os-left-end 0 :type buffer-index)
131
132 ;; How much to read each time
133 (speed 0 :type buffer-index)
134 (full-speed 0 :type buffer-index)
135
136 ;; Some stream object obeying to a certain protcol
137 os-stream
138
139 ;; The external format
140 ;; (some object offering the ENCODING protocol)
141 (encoding :utf-8)
142
143 ;;A STREAM-NAME object
144 (name nil)
145
146 ;; a plist a struct keeps the hack away
147 (plist nil)
148
149 ;; Stream Position
150 (line-number 1 :type integer) ;current line number
151 (line-start 0 :type integer) ;stream position the current line starts at
152 (buffer-start 0 :type integer) ;stream position the current buffer starts at
153
154 ;; There is no need to maintain a column counter for each character
155 ;; read, since we can easily compute it from `line-start' and
156 ;; `buffer-start'.
157 )
158
159 (defun print-xstream (self sink depth)
160 (declare (ignore depth))
161 (format sink "#<~S ~S>" (type-of self) (xstream-name self)))
162
163 (defmacro read-rune (input)
164 "Read a single rune off the xstream `input'. In case of end of file :EOF
165 is returned."
166 `((lambda (input)
167 (declare (type xstream input)
168 #.*fast*)
169 (let ((rp (xstream-read-ptr input)))
170 (declare (type buffer-index rp))
171 (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
172 rp)))
173 (declare (type buffer-byte ch))
174 (setf (xstream-read-ptr input) (%+ rp 1))
175 (cond ((%= ch +end+)
176 (the (or (member :eof) rune)
177 (xstream-underflow input)))
178 ((%= ch #x000A) ;line break
179 (account-for-line-break input)
180 (code-rune ch))
181 (t
182 (code-rune ch))))))
183 ,input))
184
185 (defmacro peek-rune (input)
186 "Peek a single rune off the xstream `input'. In case of end of file :EOF
187 is returned."
188 `((lambda (input)
189 (declare (type xstream input)
190 #.*fast*)
191 (let ((rp (xstream-read-ptr input)))
192 (declare (type buffer-index rp))
193 (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
194 rp)))
195 (declare (type buffer-byte ch))
196 (cond ((%= ch +end+)
197 (prog1
198 (the (or (member :eof) rune) (xstream-underflow input))
199 (setf (xstream-read-ptr input) 0)))
200 (t
201 (code-rune ch))))))
202 ,input))
203
204 (defmacro consume-rune (input)
205 "Like READ-RUNE, but does not actually return the read rune."
206 `((lambda (input)
207 (declare (type xstream input)
208 #.*fast*)
209 (let ((rp (xstream-read-ptr input)))
210 (declare (type buffer-index rp))
211 (let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
212 rp)))
213 (declare (type buffer-byte ch))
214 (setf (xstream-read-ptr input) (%+ rp 1))
215 (when (%= ch +end+)
216 (xstream-underflow input))
217 (when (%= ch #x000A) ;line break
218 (account-for-line-break input) )))
219 nil)
220 ,input))
221
222 (definline unread-rune (rune input)
223 "Unread the last recently read rune; if there wasn't such a rune, you
224 deserve to lose."
225 (declare (ignore rune))
226 (decf (xstream-read-ptr input))
227 (when (rune= (peek-rune input) #/u+000A) ;was it a line break?
228 (unaccount-for-line-break input)))
229
230 (defun fread-rune (input)
231 (read-rune input))
232
233 (defun fpeek-rune (input)
234 (peek-rune input))
235
236 ;;; Line counting
237
238 (defun account-for-line-break (input)
239 (declare (type xstream input))
240 (incf (xstream-line-number input))
241 (setf (xstream-line-start input)
242 (+ (xstream-buffer-start input) (xstream-read-ptr input))))
243
244 (defun unaccount-for-line-break (input)
245 ;; incomplete!
246 ;; We better use a traditional lookahead technique or forbid unread-rune.
247 (decf (xstream-line-number input)))
248
249 ;; User API:
250
251 (defun xstream-position (input)
252 (+ (xstream-buffer-start input) (xstream-read-ptr input)))
253
254 ;; xstream-line-number is structure accessor
255
256 (defun xstream-column-number (input)
257 (+ (- (xstream-position input)
258 (xstream-line-start input))
259 1))
260
261 ;;; Underflow
262
263 (defconstant +default-buffer-size+ 100)
264
265 (defmethod xstream-underflow ((input xstream))
266 (declare (type xstream input))
267 ;; we are about to fill new data into the buffer, so we need to
268 ;; adjust buffer-start.
269 (incf (xstream-buffer-start input)
270 (- (xstream-fill-ptr input) 0))
271 (let (n m)
272 ;; when there is something left in the os-buffer, we move it to
273 ;; the start of the buffer.
274 (setf m (- (xstream-os-left-end input) (xstream-os-left-start input)))
275 (unless (zerop m)
276 (replace (xstream-os-buffer input) (xstream-os-buffer input)
277 :start1 0 :end1 m
278 :start2 (xstream-os-left-start input)
279 :end2 (xstream-os-left-end input))
280 ;; then we take care that the buffer is large enough to carry at
281 ;; least 100 bytes (a random number)
282 ;;
283 ;; David: My understanding is that any number of octets large enough
284 ;; to record the longest UTF-8 sequence or UTF-16 sequence is okay,
285 ;; so 100 is plenty for this purpose.
286 (unless (>= (length (xstream-os-buffer input))
287 +default-buffer-size+)
288 (error "You lost")))
289 (setf n
290 (read-octets (xstream-os-buffer input) (xstream-os-stream input)
291 m (min (1- (length (xstream-os-buffer input)))
292 (+ m (xstream-speed input)))))
293 (cond ((%= n 0)
294 (setf (xstream-read-ptr input) 0
295 (xstream-fill-ptr input) n)
296 (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
297 :eof)
298 (t
299 (multiple-value-bind (fnw fnr)
300 (runes-encoding:decode-sequence
301 (xstream-encoding input)
302 (xstream-os-buffer input) 0 n
303 (xstream-buffer input) 0 (1- (length (xstream-buffer input)))
304 (= n m))
305 (setf (xstream-os-left-start input) fnr
306 (xstream-os-left-end input) n
307 (xstream-read-ptr input) 0
308 (xstream-fill-ptr input) fnw)
309 (setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
310 (read-rune input))))))
311
312 ;;; constructor
313
314 (defun make-xstream (os-stream &key name
315 (speed 8192)
316 (initial-speed 1)
317 (initial-encoding :guess))
318 ;; XXX if initial-speed isn't 1, encoding will me munged up
319 (assert (eql initial-speed 1))
320 (multiple-value-bind (encoding preread)
321 (if (eq initial-encoding :guess)
322 (figure-encoding os-stream)
323 (values initial-encoding nil))
324 (let* ((bufsize (max speed +default-buffer-size+))
325 (osbuf (make-array bufsize :element-type '(unsigned-byte 8))))
326 (replace osbuf preread)
327 (make-xstream/low
328 :buffer (let ((r (make-array bufsize :element-type 'buffer-byte)))
329 (setf (elt r 0) #xFFFF)
330 r)
331 :read-ptr 0
332 :fill-ptr 0
333 :os-buffer osbuf
334 :speed initial-speed
335 :full-speed speed
336 :os-stream os-stream
337 :os-left-start 0
338 :os-left-end (length preread)
339 :encoding encoding
340 :name name))))
341
342 (defun make-rod-xstream (string &key name)
343 (unless (typep string 'simple-array)
344 (setf string (coerce string 'simple-string)))
345 (let ((n (length string)))
346 (let ((buffer (make-array (1+ n) :element-type 'buffer-byte)))
347 (declare (type (simple-array buffer-byte (*)) buffer))
348 ;; copy the rod
349 (do ((i (1- n) (- i 1)))
350 ((< i 0))
351 (declare (type fixnum i))
352 (setf (aref buffer i) (rune-code (%rune string i))))
353 (setf (aref buffer n) +end+)
354 ;;
355 (make-xstream/low :buffer buffer
356 :read-ptr 0
357 :fill-ptr n
358 ;; :os-buffer nil
359 :speed 1
360 :os-stream nil
361 :name name))))
362
363 (defmethod figure-encoding ((stream null))
364 (values :utf-8 nil))
365
366 (defmethod figure-encoding ((stream stream))
367 (let ((c0 (read-byte stream nil :eof)))
368 (cond ((eq c0 :eof)
369 (values :utf-8 nil))
370 (t
371 (let ((c1 (read-byte stream nil :eof)))
372 (cond ((eq c1 :eof)
373 (values :utf-8 (list c0)))
374 (t
375 (cond ((and (= c0 #xFE) (= c1 #xFF)) (values :utf-16-big-endian nil))
376 ((and (= c0 #xFF) (= c1 #xFE)) (values :utf-16-little-endian nil))
377 ((and (= c0 #xEF) (= c1 #xBB))
378 (let ((c2 (read-byte stream nil :eof)))
379 (if (= c2 #xBF)
380 (values :utf-8 nil)
381 (values :utf-8 (list c0 c1 c2)))))
382 (t
383 (values :utf-8 (list c0 c1)))))))))))
384
385 ;;; misc
386
387 (defun close-xstream (input)
388 (xstream/close (xstream-os-stream input)))
389
390 (defun set-to-full-speed (xstream)
391 (setf (xstream-speed xstream) (xstream-full-speed xstream)))
392
393 ;;; controller implementations
394
395 (defmethod read-octets (sequence (stream stream) start end)
396 (#+CLISP ext:read-byte-sequence
397 #-CLISP read-sequence
398 sequence stream :start start :end end))
399
400 #+cmu
401 (defmethod read-octets :around (sequence (stream stream) start end)
402 ;; CMUCL <= 19a on non-SunOS accidentally triggers EFAULT in read(2)
403 ;; if SEQUENCE has been write protected by GC. Workaround: Touch all pages
404 ;; in SEQUENCE and make sure no GC happens between that and the read(2).
405 (ext::without-gcing
406 (loop for i from start below end
407 do (setf (elt sequence i) (elt sequence i)))
408 (call-next-method)))
409
410 (defmethod read-octets (sequence (stream null) start end)
411 (declare (ignore sequence start end))
412 0)
413
414 (defmethod xstream/close ((stream stream))
415 (close stream))
416
417 (defmethod xstream/close ((stream null))
418 nil)

  ViewVC Help
Powered by ViewVC 1.1.5