/[cmucl]/src/clx/buffer.lisp
ViewVC logotype

Contents of /src/clx/buffer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Wed Jun 17 18:22:45 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.9: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; This file contains definitions for the BUFFER object for Common-Lisp X
4 ;;; windows version 11
5
6 ;;;
7 ;;; TEXAS INSTRUMENTS INCORPORATED
8 ;;; P.O. BOX 2909
9 ;;; AUSTIN, TEXAS 78769
10 ;;;
11 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
12 ;;;
13 ;;; Permission is granted to any individual or institution to use, copy, modify,
14 ;;; and distribute this software, provided that this complete copyright and
15 ;;; permission notice is maintained, intact, in all copies and supporting
16 ;;; documentation.
17 ;;;
18 ;;; Texas Instruments Incorporated provides this software "as is" without
19 ;;; express or implied warranty.
20 ;;;
21
22 ;; A few notes:
23 ;;
24 ;; 1. The BUFFER implements a two-way buffered byte / half-word
25 ;; / word stream. Hooks are left for implementing this with a
26 ;; shared memory buffer, or with effenciency hooks to the network
27 ;; code.
28 ;;
29 ;; 2. The BUFFER object uses overlapping displaced arrays for
30 ;; inserting and removing bytes half-words and words.
31 ;;
32 ;; 3. The BYTE component of these arrays is written to a STREAM
33 ;; associated with the BUFFER. The stream has its own buffer.
34 ;; This may be made more efficient by using the Zetalisp
35 ;; :Send-Output-Buffer operation.
36 ;;
37 ;; 4. The BUFFER object is INCLUDED in the DISPLAY object.
38 ;; This was done to reduce access time when sending requests,
39 ;; while maintaing some code modularity.
40 ;; Several buffer functions are duplicated (with-buffer,
41 ;; buffer-force-output, close-buffer) to keep the naming
42 ;; conventions consistent.
43 ;;
44 ;; 5. A nother layer of software is built on top of this for generating
45 ;; both client and server interface routines, given a specification
46 ;; of the protocol. (see the INTERFACE file)
47 ;;
48 ;; 6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
49 ;; a point after a complete request. This is to ensure that a partial
50 ;; request won't be left after aborts (e.g. control-abort on a lispm).
51
52 #+cmu
53 (ext:file-comment "$Id: buffer.lisp,v 1.10 2009/06/17 18:22:45 rtoy Rel $")
54
55 (in-package :xlib)
56
57 (defconstant +requestsize+ 160) ;; Max request size (excluding variable length requests)
58
59 ;;; This is here instead of in bufmac so that with-display can be
60 ;;; compiled without macros and bufmac being loaded.
61
62 (defmacro with-buffer ((buffer &key timeout inline)
63 &body body &environment env)
64 ;; This macro is for use in a multi-process environment. It provides
65 ;; exclusive access to the local buffer object for request generation and
66 ;; reply processing.
67 `(macrolet ((with-buffer ((buffer &key timeout) &body body)
68 ;; Speedup hack for lexically nested with-buffers
69 `(progn
70 (progn ,buffer ,@(and timeout `(,timeout)) nil)
71 ,@body)))
72 ,(if (and (null inline) (macroexpand '(use-closures) env))
73 `(flet ((.with-buffer-body. () ,@body))
74 #+clx-ansi-common-lisp
75 (declare (dynamic-extent #'.with-buffer-body.))
76 (with-buffer-function ,buffer ,timeout #'.with-buffer-body.))
77 (let ((buf (if (or (symbolp buffer) (constantp buffer))
78 buffer
79 '.buffer.)))
80 `(let (,@(unless (eq buf buffer) `((,buf ,buffer))))
81 ,@(unless (eq buf buffer) `((declare (type buffer ,buf))))
82 ,(declare-bufmac)
83 (when (buffer-dead ,buf)
84 (x-error 'closed-display :display ,buf))
85 (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock"
86 ,@(and timeout `(:timeout ,timeout)))
87 ,@body))))))
88
89 (defun with-buffer-function (buffer timeout function)
90 (declare (type display buffer)
91 (type (or null number) timeout)
92 (type function function)
93 #+clx-ansi-common-lisp
94 (dynamic-extent function)
95 ;; FIXME: This is probably more a bug in SBCL (logged as
96 ;; bug #243)
97 (ignorable timeout)
98 #+(and lispm (not clx-ansi-common-lisp))
99 (sys:downward-funarg function))
100 (with-buffer (buffer :timeout timeout :inline t)
101 (funcall function)))
102
103 ;;; The following are here instead of in bufmac so that event-case can
104 ;;; be compiled without macros and bufmac being loaded.
105
106 (defmacro read-card8 (byte-index)
107 `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
108
109 (defmacro read-int8 (byte-index)
110 `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
111
112 (defmacro read-card16 (byte-index)
113 #+clx-overlapping-arrays
114 `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
115 #-clx-overlapping-arrays
116 `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
117
118 (defmacro read-int16 (byte-index)
119 #+clx-overlapping-arrays
120 `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
121 #-clx-overlapping-arrays
122 `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
123
124 (defmacro read-card32 (byte-index)
125 #+clx-overlapping-arrays
126 `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
127 #-clx-overlapping-arrays
128 `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
129
130 (defmacro read-int32 (byte-index)
131 #+clx-overlapping-arrays
132 `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
133 #-clx-overlapping-arrays
134 `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
135
136 (defmacro read-card29 (byte-index)
137 #+clx-overlapping-arrays
138 `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
139 #-clx-overlapping-arrays
140 `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
141
142 (defmacro event-code (reply-buffer)
143 ;; The reply-buffer structure is used for events.
144 ;; The size slot is used for the event code.
145 `(reply-size ,reply-buffer))
146
147 (defmacro reading-event ((event &rest options) &body body)
148 (declare (arglist (buffer &key sizes) &body body))
149 ;; BODY may contain calls to (READ32 &optional index) etc.
150 ;; These calls will read from the input buffer at byte
151 ;; offset INDEX. If INDEX is not supplied, then the next
152 ;; word, half-word or byte is returned.
153 `(with-buffer-input (,event ,@options) ,@body))
154
155 (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index)
156 &body body)
157 (unless (listp sizes) (setq sizes (list sizes)))
158 ;; 160 is a special hack for client-message-events
159 (when (set-difference sizes '(0 8 16 32 160 256))
160 (error "Illegal sizes in ~a" sizes))
161 `(let ((%reply-buffer ,reply-buffer)
162 ,@(and display `((%buffer ,display))))
163 (declare (type reply-buffer %reply-buffer)
164 ,@(and display '((type display %buffer))))
165 ,(declare-bufmac)
166 ,@(and display '(%buffer))
167 (let* ((buffer-boffset (the array-index ,(or index 0)))
168 #-clx-overlapping-arrays
169 (buffer-bbuf (reply-ibuf8 %reply-buffer))
170 #+clx-overlapping-arrays
171 ,@(append
172 (when (member 8 sizes)
173 `((buffer-bbuf (reply-ibuf8 %reply-buffer))))
174 (when (or (member 16 sizes) (member 160 sizes))
175 `((buffer-woffset (index-ash buffer-boffset -1))
176 (buffer-wbuf (reply-ibuf16 %reply-buffer))))
177 (when (member 32 sizes)
178 `((buffer-loffset (index-ash buffer-boffset -2))
179 (buffer-lbuf (reply-ibuf32 %reply-buffer))))))
180 (declare (type array-index buffer-boffset))
181 #-clx-overlapping-arrays
182 (declare (type buffer-bytes buffer-bbuf))
183 #+clx-overlapping-arrays
184 ,@(append
185 (when (member 8 sizes)
186 '((declare (type buffer-bytes buffer-bbuf))))
187 (when (member 16 sizes)
188 '((declare (type array-index buffer-woffset))
189 (declare (type buffer-words buffer-wbuf))))
190 (when (member 32 sizes)
191 '((declare (type array-index buffer-loffset))
192 (declare (type buffer-longs buffer-lbuf)))))
193 buffer-boffset
194 #-clx-overlapping-arrays
195 buffer-bbuf
196 #+clx-overlapping-arrays
197 ,@(append
198 (when (member 8 sizes) '(buffer-bbuf))
199 (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
200 (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
201 #+clx-overlapping-arrays
202 (macrolet ((%buffer-sizes () ',sizes))
203 ,@body)
204 #-clx-overlapping-arrays
205 ,@body)))
206
207 (defun make-buffer (output-size constructor &rest options)
208 (declare (dynamic-extent options))
209 ;; Output-Size is the output-buffer size in bytes.
210 (let ((byte-output (make-array output-size :element-type 'card8
211 :initial-element 0)))
212 (apply constructor
213 :size output-size
214 :obuf8 byte-output
215 #+clx-overlapping-arrays
216 :obuf16
217 #+clx-overlapping-arrays
218 (make-array (index-ash output-size -1)
219 :element-type 'overlap16
220 :displaced-to byte-output)
221 #+clx-overlapping-arrays
222 :obuf32
223 #+clx-overlapping-arrays
224 (make-array (index-ash output-size -2)
225 :element-type 'overlap32
226 :displaced-to byte-output)
227 options)))
228
229 (defun make-reply-buffer (size)
230 ;; Size is the buffer size in bytes
231 (let ((byte-input (make-array size :element-type 'card8
232 :initial-element 0)))
233 (make-reply-buffer-internal
234 :size size
235 :ibuf8 byte-input
236 #+clx-overlapping-arrays
237 :ibuf16
238 #+clx-overlapping-arrays
239 (make-array (index-ash size -1)
240 :element-type 'overlap16
241 :displaced-to byte-input)
242 #+clx-overlapping-arrays
243 :ibuf32
244 #+clx-overlapping-arrays
245 (make-array (index-ash size -2)
246 :element-type 'overlap32
247 :displaced-to byte-input))))
248
249 (defun buffer-ensure-size (buffer size)
250 (declare (type buffer buffer)
251 (type array-index size))
252 (when (index> size (buffer-size buffer))
253 (with-buffer (buffer)
254 (buffer-flush buffer)
255 (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size))))
256 (new-buffer (make-array new-buffer-size :element-type 'card8
257 :initial-element 0)))
258 (setf (buffer-obuf8 buffer) new-buffer)
259 #+clx-overlapping-arrays
260 (setf (buffer-obuf16 buffer)
261 (make-array (index-ash new-buffer-size -1)
262 :element-type 'overlap16
263 :displaced-to new-buffer)
264 (buffer-obuf32 buffer)
265 (make-array (index-ash new-buffer-size -2)
266 :element-type 'overlap32
267 :displaced-to new-buffer))))))
268
269 (defun buffer-pad-request (buffer pad)
270 (declare (type buffer buffer)
271 (type array-index pad))
272 (unless (index-zerop pad)
273 (when (index> (index+ (buffer-boffset buffer) pad)
274 (buffer-size buffer))
275 (buffer-flush buffer))
276 (incf (buffer-boffset buffer) pad)
277 (unless (index-zerop (index-mod (buffer-boffset buffer) 4))
278 (buffer-flush buffer))))
279
280 (declaim (inline buffer-new-request-number))
281
282 (defun buffer-new-request-number (buffer)
283 (declare (type buffer buffer))
284 (setf (buffer-request-number buffer)
285 (ldb (byte 16 0) (1+ (buffer-request-number buffer)))))
286
287 (defun with-buffer-request-function (display gc-force request-function)
288 (declare (type display display)
289 (type (or null gcontext) gc-force))
290 (declare (type function request-function)
291 #+clx-ansi-common-lisp
292 (dynamic-extent request-function)
293 #+(and lispm (not clx-ansi-common-lisp))
294 (sys:downward-funarg request-function))
295 (with-buffer (display :inline t)
296 (multiple-value-prog1
297 (progn
298 (when gc-force (force-gcontext-changes-internal gc-force))
299 (without-aborts (funcall request-function display)))
300 (display-invoke-after-function display))))
301
302 (defun with-buffer-request-function-nolock (display gc-force request-function)
303 (declare (type display display)
304 (type (or null gcontext) gc-force))
305 (declare (type function request-function)
306 #+clx-ansi-common-lisp
307 (dynamic-extent request-function)
308 #+(and lispm (not clx-ansi-common-lisp))
309 (sys:downward-funarg request-function))
310 (multiple-value-prog1
311 (progn
312 (when gc-force (force-gcontext-changes-internal gc-force))
313 (without-aborts (funcall request-function display)))
314 (display-invoke-after-function display)))
315
316 (defstruct (pending-command (:copier nil) (:predicate nil))
317 (sequence 0 :type card16)
318 (reply-buffer nil :type (or null reply-buffer))
319 (process nil)
320 (next nil #-explorer :type #-explorer (or null pending-command)))
321
322 (defun with-buffer-request-and-reply-function
323 (display multiple-reply request-function reply-function)
324 (declare (type display display)
325 (type generalized-boolean multiple-reply))
326 (declare (type function request-function reply-function)
327 #+clx-ansi-common-lisp
328 (dynamic-extent request-function reply-function)
329 #+(and lispm (not clx-ansi-common-lisp))
330 (sys:downward-funarg request-function reply-function))
331 (let ((pending-command nil)
332 (reply-buffer nil))
333 (declare (type (or null pending-command) pending-command)
334 (type (or null reply-buffer) reply-buffer))
335 (unwind-protect
336 (progn
337 (with-buffer (display :inline t)
338 (setq pending-command (start-pending-command display))
339 (without-aborts (funcall request-function display))
340 (buffer-force-output display)
341 (display-invoke-after-function display))
342 (cond (multiple-reply
343 (loop
344 (setq reply-buffer (read-reply display pending-command))
345 (when (funcall reply-function display reply-buffer) (return nil))
346 (deallocate-reply-buffer (shiftf reply-buffer nil))))
347 (t
348 (setq reply-buffer (read-reply display pending-command))
349 (funcall reply-function display reply-buffer))))
350 (when reply-buffer (deallocate-reply-buffer reply-buffer))
351 (when pending-command (stop-pending-command display pending-command)))))
352
353 ;;
354 ;; Buffer stream operations
355 ;;
356
357 (defun buffer-write (vector buffer start end)
358 ;; Write out VECTOR from START to END into BUFFER
359 ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
360 (declare (type buffer buffer)
361 (type array-index start end))
362 (when (buffer-dead buffer)
363 (x-error 'closed-display :display buffer))
364 (wrap-buf-output (buffer)
365 (funcall (buffer-write-function buffer) vector buffer start end))
366 nil)
367
368 (defun buffer-flush (buffer)
369 ;; Write the buffer contents to the server stream - doesn't force-output the stream
370 ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
371 (declare (type buffer buffer))
372 (unless (buffer-flush-inhibit buffer)
373 (let ((boffset (buffer-boffset buffer)))
374 (declare (type array-index boffset))
375 (when (index-plusp boffset)
376 (buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
377 (setf (buffer-boffset buffer) 0)
378 (setf (buffer-last-request buffer) nil))))
379 nil)
380
381 (defmacro with-buffer-flush-inhibited ((buffer) &body body)
382 (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.)))
383 `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer)))
384 (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf)))
385 (unwind-protect
386 (progn
387 (setf (buffer-flush-inhibit ,buf) t)
388 ,@body)
389 (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.)))))
390
391 (defun buffer-force-output (buffer)
392 ;; Output is normally buffered, this forces any buffered output to the server.
393 (declare (type buffer buffer))
394 (when (buffer-dead buffer)
395 (x-error 'closed-display :display buffer))
396 (buffer-flush buffer)
397 (wrap-buf-output (buffer)
398 (without-aborts
399 (funcall (buffer-force-output-function buffer) buffer)))
400 nil)
401
402 (defun close-buffer (buffer &key abort)
403 ;; Close the host connection in BUFFER
404 (declare (type buffer buffer))
405 (unless (null (buffer-output-stream buffer))
406 (wrap-buf-output (buffer)
407 (funcall (buffer-close-function buffer) buffer :abort abort))
408 (setf (buffer-dead buffer) t)
409 ;; Zap pointers to the streams, to ensure they're GC'd
410 (setf (buffer-output-stream buffer) nil)
411 (setf (buffer-input-stream buffer) nil)
412 )
413 nil)
414
415 (defun buffer-input (buffer vector start end &optional timeout)
416 ;; Read into VECTOR from the buffer stream
417 ;; Timeout, when non-nil, is in seconds
418 ;; Returns non-nil if EOF encountered
419 ;; Returns :TIMEOUT when timeout exceeded
420 (declare (type buffer buffer)
421 (type vector vector)
422 (type array-index start end)
423 (type (or null number) timeout))
424 (declare (clx-values eof-p))
425 (when (buffer-dead buffer)
426 (x-error 'closed-display :display buffer))
427 (unless (= start end)
428 (let ((result
429 (wrap-buf-input (buffer)
430 (funcall (buffer-input-function buffer)
431 buffer vector start end timeout))))
432 (unless (or (null result) (eq result :timeout))
433 (close-buffer buffer))
434 result)))
435
436 (defun buffer-input-wait (buffer timeout)
437 ;; Timeout, when non-nil, is in seconds
438 ;; Returns non-nil if EOF encountered
439 ;; Returns :TIMEOUT when timeout exceeded
440 (declare (type buffer buffer)
441 (type (or null number) timeout))
442 (declare (clx-values timeout))
443 (when (buffer-dead buffer)
444 (x-error 'closed-display :display buffer))
445 (let ((result
446 (wrap-buf-input (buffer)
447 (funcall (buffer-input-wait-function buffer)
448 buffer timeout))))
449 (unless (or (null result) (eq result :timeout))
450 (close-buffer buffer))
451 result))
452
453 (defun buffer-listen (buffer)
454 ;; Returns T if there is input available for the buffer. This should never
455 ;; block, so it can be called from the scheduler.
456 (declare (type buffer buffer))
457 (declare (clx-values input-available))
458 (or (not (null (buffer-dead buffer)))
459 (wrap-buf-input (buffer)
460 (funcall (buffer-listen-function buffer) buffer))))
461
462 ;;; Reading sequences of strings
463
464 ;;; a list of pascal-strings with card8 lengths, no padding in between
465 ;;; can't use read-sequence-char
466 (defun read-sequence-string (buffer-bbuf length nitems result-type
467 &optional (buffer-boffset 0))
468 (declare (type buffer-bytes buffer-bbuf)
469 (type array-index length nitems buffer-boffset))
470 length
471 (with-vector (buffer-bbuf buffer-bytes)
472 (let ((result (make-sequence result-type nitems)))
473 (do* ((index 0 (index+ index 1 string-length))
474 (count 0 (index1+ count))
475 (string-length 0)
476 (string ""))
477 ((index>= count nitems)
478 result)
479 (declare (type array-index index count string-length)
480 (type string string))
481 (setq string-length (read-card8 index)
482 string (make-sequence 'string string-length))
483 (do ((i (index1+ index) (index1+ i))
484 (j 0 (index1+ j)))
485 ((index>= j string-length)
486 (setf (elt result count) string))
487 (declare (type array-index i j))
488 (setf (aref string j) (card8->char (read-card8 i))))))))
489
490 ;;; Reading sequences of chars
491
492 (defmacro define-transformed-sequence-reader (name totype transformer reader)
493 (let ((ntrans (gensym)))
494 `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
495 (declare
496 (type reply-buffer reply-buffer)
497 (type t result-type)
498 (type array-index nitems start index)
499 (type (or null sequence) data)
500 (type (or null (function (,totype) t)) transform)
501 #+clx-ansi-common-lisp (dynamic-extent transform)
502 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
503 (if transform
504 (flet ((,ntrans (v) (funcall transform (,transformer v))))
505 #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
506 (,reader reply-buffer result-type nitems #',ntrans data start index))
507 (,reader reply-buffer result-type nitems #',transformer data start index)))))
508
509 (define-transformed-sequence-reader read-sequence-char character
510 card8->char read-sequence-card8)
511
512 ;;; Reading sequences of card8's
513
514 (defmacro define-list-readers ((name tname) type size step reader)
515 `(progn
516 (defun ,name (reply-buffer nitems data start index)
517 (declare (type reply-buffer reply-buffer)
518 (type array-index nitems start index)
519 (type list data))
520 (with-buffer-input (reply-buffer :sizes (,size) :index index)
521 (do* ((j nitems (index- j 1))
522 (list (nthcdr start data) (cdr list))
523 (index 0 (index+ index ,step)))
524 ((index-zerop j))
525 (declare (type array-index index j) (type list list))
526 (setf (car list) (,reader index)))))
527 (defun ,tname (reply-buffer nitems data transform start index)
528 (declare (type reply-buffer reply-buffer)
529 (type array-index nitems start index)
530 (type list data)
531 (type (function (,type) t) transform)
532 #+clx-ansi-common-lisp (dynamic-extent transform)
533 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
534 (with-buffer-input (reply-buffer :sizes (,size) :index index)
535 (do* ((j nitems (index- j 1))
536 (list (nthcdr start data) (cdr list))
537 (index 0 (index+ index ,step)))
538 ((index-zerop j))
539 (declare (type array-index index j) (type list list))
540 (setf (car list) (funcall transform (,reader index))))))))
541
542 (define-list-readers (read-list-card8 read-list-card8-with-transform) card8
543 8 1 read-card8)
544
545 #-lispm
546 (defun read-simple-array-card8 (reply-buffer nitems data start index)
547 (declare (type reply-buffer reply-buffer)
548 (type array-index nitems start index)
549 (type (simple-array card8 (*)) data))
550 (with-vector (data (simple-array card8 (*)))
551 (with-buffer-input (reply-buffer :sizes (8))
552 (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
553
554 #-lispm
555 (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index)
556 (declare (type reply-buffer reply-buffer)
557 (type array-index nitems start index)
558 (type (simple-array card8 (*)) data))
559 (declare (type (function (card8) card8) transform)
560 #+clx-ansi-common-lisp
561 (dynamic-extent transform)
562 #+(and lispm (not clx-ansi-common-lisp))
563 (sys:downward-funarg transform))
564 (with-vector (data (simple-array card8 (*)))
565 (with-buffer-input (reply-buffer :sizes (8) :index index)
566 (do* ((j start (index+ j 1))
567 (end (index+ start nitems))
568 (index 0 (index+ index 1)))
569 ((index>= j end))
570 (declare (type array-index j end index))
571 (setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
572
573 (defun read-vector-card8 (reply-buffer nitems data start index)
574 (declare (type reply-buffer reply-buffer)
575 (type array-index nitems start index)
576 (type vector data)
577 (optimize #+cmu(ext:inhibit-warnings 3)))
578 (with-vector (data vector)
579 (with-buffer-input (reply-buffer :sizes (8) :index index)
580 (do* ((j start (index+ j 1))
581 (end (index+ start nitems))
582 (index 0 (index+ index 1)))
583 ((index>= j end))
584 (declare (type array-index j end index))
585 (setf (aref data j) (read-card8 index))))))
586
587 (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index)
588 (declare (type reply-buffer reply-buffer)
589 (type array-index nitems start index)
590 (type vector data)
591 (optimize #+cmu(ext:inhibit-warnings 3)))
592 (declare (type (function (card8) t) transform)
593 #+clx-ansi-common-lisp
594 (dynamic-extent transform)
595 #+(and lispm (not clx-ansi-common-lisp))
596 (sys:downward-funarg transform))
597 (with-vector (data vector)
598 (with-buffer-input (reply-buffer :sizes (8) :index index)
599 (do* ((j start (index+ j 1))
600 (end (index+ start nitems))
601 (index 0 (index+ index 1)))
602 ((index>= j end))
603 (declare (type array-index j end index))
604 (setf (aref data j) (funcall transform (read-card8 index)))))))
605
606 (defmacro define-sequence-reader (name type (list tlist) (sa tsa) (vec tvec))
607 `(defun ,name (reply-buffer result-type nitems &optional transform data (start 0) (index 0))
608 (declare
609 (type reply-buffer reply-buffer)
610 (type t result-type)
611 (type array-index nitems start index)
612 (type (or null sequence) data)
613 (type (or null (function (,type) t)) transform)
614 #+clx-ansi-common-lisp (dynamic-extent transform)
615 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
616 (let ((result (or data (make-sequence result-type nitems))))
617 (typecase result
618 (list
619 (if transform
620 (,tlist reply-buffer nitems result transform start index)
621 (,list reply-buffer nitems result start index)))
622 #-lispm
623 ((simple-array ,type (*))
624 (if transform
625 (,tsa reply-buffer nitems result transform start index)
626 (,sa reply-buffer nitems result start index)))
627 ;; FIXME: general sequences
628 (t
629 (if transform
630 (,tvec reply-buffer nitems result transform start index)
631 (,vec reply-buffer nitems result start index))))
632 result)))
633
634 (define-sequence-reader read-sequence-card8 card8
635 (read-list-card8 read-list-card8-with-transform)
636 (read-simple-array-card8 read-simple-array-card8-with-transform)
637 (read-vector-card8 read-vector-card8-with-transform))
638
639 (define-transformed-sequence-reader read-sequence-int8 int8
640 card8->int8 read-sequence-card8)
641
642 ;;; Reading sequences of card16's
643
644 (define-list-readers (read-list-card16 read-list-card16-with-transform) card16
645 16 2 read-card16)
646
647 #-lispm
648 (defun read-simple-array-card16 (reply-buffer nitems data start index)
649 (declare (type reply-buffer reply-buffer)
650 (type array-index nitems start index)
651 (type (simple-array card16 (*)) data))
652 (with-vector (data (simple-array card16 (*)))
653 (with-buffer-input (reply-buffer :sizes (16) :index index)
654 #-clx-overlapping-arrays
655 (do* ((j start (index+ j 1))
656 (end (index+ start nitems))
657 (index 0 (index+ index 2)))
658 ((index>= j end))
659 (declare (type array-index j end index))
660 (setf (aref data j) (the card16 (read-card16 index))))
661 #+clx-overlapping-arrays
662 (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
663
664 #-lispm
665 (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index)
666 (declare (type reply-buffer reply-buffer)
667 (type array-index nitems start index)
668 (type (simple-array card16 (*)) data))
669 (declare (type (function (card16) card16) transform)
670 #+clx-ansi-common-lisp
671 (dynamic-extent transform)
672 #+(and lispm (not clx-ansi-common-lisp))
673 (sys:downward-funarg transform))
674 (with-vector (data (simple-array card16 (*)))
675 (with-buffer-input (reply-buffer :sizes (16) :index index)
676 (do* ((j start (index+ j 1))
677 (end (index+ start nitems))
678 (index 0 (index+ index 2)))
679 ((index>= j end))
680 (declare (type array-index j end index))
681 (setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
682
683 (defun read-vector-card16 (reply-buffer nitems data start index)
684 (declare (type reply-buffer reply-buffer)
685 (type array-index nitems start index)
686 (type vector data)
687 (optimize #+cmu(ext:inhibit-warnings 3)))
688 (with-vector (data vector)
689 (with-buffer-input (reply-buffer :sizes (16) :index index)
690 #-clx-overlapping-arrays
691 (do* ((j start (index+ j 1))
692 (end (index+ start nitems))
693 (index 0 (index+ index 2)))
694 ((index>= j end))
695 (declare (type array-index j end index))
696 (setf (aref data j) (read-card16 index)))
697 #+clx-overlapping-arrays
698 (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
699
700 (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index)
701 (declare (type reply-buffer reply-buffer)
702 (type array-index nitems start index)
703 (type vector data)
704 (optimize #+cmu(ext:inhibit-warnings 3)))
705 (declare (type (function (card16) t) transform)
706 #+clx-ansi-common-lisp
707 (dynamic-extent transform)
708 #+(and lispm (not clx-ansi-common-lisp))
709 (sys:downward-funarg transform))
710 (with-vector (data vector)
711 (with-buffer-input (reply-buffer :sizes (16) :index index)
712 (do* ((j start (index+ j 1))
713 (end (index+ start nitems))
714 (index 0 (index+ index 2)))
715 ((index>= j end))
716 (declare (type array-index j end index))
717 (setf (aref data j) (funcall transform (read-card16 index)))))))
718
719 (define-sequence-reader read-sequence-card16 card16
720 (read-list-card16 read-list-card16-with-transform)
721 (read-simple-array-card16 read-simple-array-card16-with-transform)
722 (read-vector-card16 read-vector-card16-with-transform))
723
724 (define-transformed-sequence-reader read-sequence-int16 int16
725 card16->int16 read-sequence-card16)
726
727 ;;; Reading sequences of card32's
728
729 (define-list-readers (read-list-card32 read-list-card32-with-transform) card32
730 32 4 read-card32)
731
732 #-lispm
733 (defun read-simple-array-card32 (reply-buffer nitems data start index)
734 (declare (type reply-buffer reply-buffer)
735 (type array-index nitems start index)
736 (type (simple-array card32 (*)) data))
737 (with-vector (data (simple-array card32 (*)))
738 (with-buffer-input (reply-buffer :sizes (32) :index index)
739 #-clx-overlapping-arrays
740 (do* ((j start (index+ j 1))
741 (end (index+ start nitems))
742 (index 0 (index+ index 4)))
743 ((index>= j end))
744 (declare (type array-index j end index))
745 (setf (aref data j) (the card32 (read-card32 index))))
746 #+clx-overlapping-arrays
747 (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
748
749 #-lispm
750 (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index)
751 (declare (type reply-buffer reply-buffer)
752 (type array-index nitems start index)
753 (type (simple-array card32 (*)) data))
754 (declare (type (function (card32) card32) transform)
755 #+clx-ansi-common-lisp
756 (dynamic-extent transform)
757 #+(and lispm (not clx-ansi-common-lisp))
758 (sys:downward-funarg transform))
759 (with-vector (data (simple-array card32 (*)))
760 (with-buffer-input (reply-buffer :sizes (32) :index index)
761 (do* ((j start (index+ j 1))
762 (end (index+ start nitems))
763 (index 0 (index+ index 4)))
764 ((index>= j end))
765 (declare (type array-index j end index))
766 (setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
767
768 (defun read-vector-card32 (reply-buffer nitems data start index)
769 (declare (type reply-buffer reply-buffer)
770 (type array-index nitems start index)
771 (type vector data)
772 (optimize #+cmu(ext:inhibit-warnings 3)))
773 (with-vector (data vector)
774 (with-buffer-input (reply-buffer :sizes (32) :index index)
775 #-clx-overlapping-arrays
776 (do* ((j start (index+ j 1))
777 (end (index+ start nitems))
778 (index 0 (index+ index 4)))
779 ((index>= j end))
780 (declare (type array-index j end index))
781 (setf (aref data j) (read-card32 index)))
782 #+clx-overlapping-arrays
783 (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
784
785 (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index)
786 (declare (type reply-buffer reply-buffer)
787 (type array-index nitems start index)
788 (type vector data)
789 (optimize #+cmu(ext:inhibit-warnings 3)))
790 (declare (type (function (card32) t) transform)
791 #+clx-ansi-common-lisp
792 (dynamic-extent transform)
793 #+(and lispm (not clx-ansi-common-lisp))
794 (sys:downward-funarg transform))
795 (with-vector (data vector)
796 (with-buffer-input (reply-buffer :sizes (32) :index index)
797 (do* ((j start (index+ j 1))
798 (end (index+ start nitems))
799 (index 0 (index+ index 4)))
800 ((index>= j end))
801 (declare (type array-index j end index))
802 (setf (aref data j) (funcall transform (read-card32 index)))))))
803
804 (define-sequence-reader read-sequence-card32 card32
805 (read-list-card32 read-list-card32-with-transform)
806 (read-simple-array-card32 read-simple-array-card32-with-transform)
807 (read-vector-card32 read-vector-card32-with-transform))
808
809 (define-transformed-sequence-reader read-sequence-int32 int32
810 card32->int32 read-sequence-card32)
811
812 ;;; Writing sequences of chars
813
814 (defmacro define-transformed-sequence-writer (name fromtype transformer writer)
815 (let ((ntrans (gensym)))
816 `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
817 (declare
818 (type buffer buffer)
819 (type sequence data)
820 (type array-index boffset start end)
821 (type (or null (function (t) ,fromtype)) transform)
822 #+clx-ansi-common-lisp (dynamic-extent transform)
823 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
824 (if transform
825 (flet ((,ntrans (x) (,transformer (the ,fromtype (funcall transform x)))))
826 #+clx-ansi-common-lisp (declare (dynamic-extent #',ntrans))
827 (,writer buffer boffset data start end #',ntrans))
828 (,writer buffer boffset data start end #',transformer)))))
829
830 (define-transformed-sequence-writer write-sequence-char character
831 char->card8 write-sequence-card8)
832
833 ;;; Writing sequences of card8's
834
835 (defmacro define-list-writers ((name tname) type step writer)
836 `(progn
837 (defun ,name (buffer boffset data start end)
838 (declare
839 (type buffer buffer)
840 (type list data)
841 (type array-index boffset start end))
842 (writing-buffer-chunks ,type
843 ((list (nthcdr start data)))
844 ((type list list))
845 (do ((j 0 (index+ j ,step)))
846 ((index>= j chunk))
847 (declare (type array-index j))
848 (,writer j (pop list)))))
849 (defun ,tname (buffer boffset data start end transform)
850 (declare
851 (type buffer buffer)
852 (type list data)
853 (type array-index boffset start end)
854 (type (function (t) ,type) transform)
855 #+clx-ansi-common-lisp (dynamic-extent transform)
856 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
857 (writing-buffer-chunks ,type
858 ((list (nthcdr start data)))
859 ((type list list))
860 (do ((j 0 (index+ j ,step)))
861 ((index>= j chunk))
862 (declare (type array-index j))
863 (,writer j (funcall transform (pop list))))))))
864
865 ;;; original CLX comment: "TI Compiler bug", in WRITE-LIST-CARD8
866 #+ti
867 (progn
868 (defun write-list-card8 (buffer boffset data start end)
869 (writing-buffer-chunks card8
870 ((list (nthcdr start data)))
871 ((type list list))
872 (dotimes (j chunk)
873 (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop list)))))
874 (defun write-list-card8-with-transform (buffer boffset data start end transform)
875 (writing-buffer-chunks card8
876 ((list (nthcdr start data)))
877 ((type list lst))
878 (dotimes (j chunk)
879 (declare (type array-index j))
880 (write-card8 j (funcall transform (pop lst)))))))
881
882 #-ti
883 (define-list-writers (write-list-card8 write-list-card8-with-transform) card8
884 1 write-card8)
885
886 ;;; Should really write directly from data, instead of into the buffer first
887 #-lispm
888 (defun write-simple-array-card8 (buffer boffset data start end)
889 (declare (type buffer buffer)
890 (type (simple-array card8 (*)) data)
891 (type array-index boffset start end))
892 (with-vector (data (simple-array card8 (*)))
893 (writing-buffer-chunks card8
894 ((index start (index+ index chunk)))
895 ((type array-index index))
896 (buffer-replace buffer-bbuf data
897 buffer-boffset
898 (index+ buffer-boffset chunk)
899 index)))
900 nil)
901
902 #-lispm
903 (defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
904 (declare (type buffer buffer)
905 (type (simple-array card8 (*)) data)
906 (type array-index boffset start end))
907 (declare (type (function (card8) card8) transform)
908 #+clx-ansi-common-lisp
909 (dynamic-extent transform)
910 #+(and lispm (not clx-ansi-common-lisp))
911 (sys:downward-funarg transform))
912 (with-vector (data (simple-array card8 (*)))
913 (writing-buffer-chunks card8
914 ((index start))
915 ((type array-index index))
916 (dotimes (j chunk)
917 (declare (type array-index j))
918 (write-card8 j (funcall transform (aref data index)))
919 (setq index (index+ index 1)))))
920 nil)
921
922 (defun write-vector-card8 (buffer boffset data start end)
923 (declare (type buffer buffer)
924 (type vector data)
925 (type array-index boffset start end)
926 (optimize #+cmu(ext:inhibit-warnings 3)))
927 (with-vector (data vector)
928 (writing-buffer-chunks card8
929 ((index start))
930 ((type array-index index))
931 (dotimes (j chunk)
932 (declare (type array-index j))
933 (write-card8 j (aref data index))
934 (setq index (index+ index 1)))))
935 nil)
936
937 (defun write-vector-card8-with-transform (buffer boffset data start end transform)
938 (declare (type buffer buffer)
939 (type vector data)
940 (type array-index boffset start end))
941 (declare (type (function (t) card8) transform)
942 #+clx-ansi-common-lisp
943 (dynamic-extent transform)
944 #+(and lispm (not clx-ansi-common-lisp))
945 (sys:downward-funarg transform))
946 (with-vector (data vector)
947 (writing-buffer-chunks card8
948 ((index start))
949 ((type array-index index))
950 (dotimes (j chunk)
951 (declare (type array-index j))
952 (write-card8 j (funcall transform (aref data index)))
953 (setq index (index+ index 1)))))
954 nil)
955
956 (defmacro define-sequence-writer (name type (list tlist) (sa tsa) (vec tvec))
957 `(defun ,name (buffer boffset data &optional (start 0) (end (length data)) transform)
958 (declare
959 (type buffer buffer)
960 (type sequence data)
961 (type array-index boffset start end)
962 (type (or null (function (t) ,type)) transform)
963 #+clx-ansi-common-lisp (dynamic-extent transform)
964 #+(and lispm (not clx-ansi-common-lisp)) (sys:downward-funarg transform))
965 (typecase data
966 (list
967 (if transform
968 (,tlist buffer boffset data start end transform)
969 (,list buffer boffset data start end)))
970 #-lispm
971 ((simple-array ,type (*))
972 (if transform
973 (,tsa buffer boffset data start end transform)
974 (,sa buffer boffset data start end)))
975 (t ; FIXME: general sequences
976 (if transform
977 (,tvec buffer boffset data start end transform)
978 (,vec buffer boffset data start end))))))
979
980 (define-sequence-writer write-sequence-card8 card8
981 (write-list-card8 write-list-card8-with-transform)
982 (write-simple-array-card8 write-simple-array-card8-with-transform)
983 (write-vector-card8 write-vector-card8-with-transform))
984
985 (define-transformed-sequence-writer write-sequence-int8 int8
986 int8->card8 write-sequence-card8)
987
988 ;;; Writing sequences of card16's
989
990 (define-list-writers (write-list-card16 write-list-card16-with-transform) card16
991 2 write-card16)
992
993 #-lispm
994 (defun write-simple-array-card16 (buffer boffset data start end)
995 (declare (type buffer buffer)
996 (type (simple-array card16 (*)) data)
997 (type array-index boffset start end))
998 (with-vector (data (simple-array card16 (*)))
999 (writing-buffer-chunks card16
1000 ((index start))
1001 ((type array-index index))
1002 ;; Depends upon the chunks being an even multiple of card16's big
1003 (do ((j 0 (index+ j 2)))
1004 ((index>= j chunk))
1005 (declare (type array-index j))
1006 (write-card16 j (aref data index))
1007 (setq index (index+ index 1)))
1008 ;; overlapping case
1009 (let ((length (floor chunk 2)))
1010 (buffer-replace buffer-wbuf data
1011 buffer-woffset
1012 (index+ buffer-woffset length)
1013 index)
1014 (setq index (index+ index length)))))
1015 nil)
1016
1017 #-lispm
1018 (defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
1019 (declare (type buffer buffer)
1020 (type (simple-array card16 (*)) data)
1021 (type array-index boffset start end))
1022 (declare (type (function (card16) card16) transform)
1023 #+clx-ansi-common-lisp
1024 (dynamic-extent transform)
1025 #+(and lispm (not clx-ansi-common-lisp))
1026 (sys:downward-funarg transform))
1027 (with-vector (data (simple-array card16 (*)))
1028 (writing-buffer-chunks card16
1029 ((index start))
1030 ((type array-index index))
1031 ;; Depends upon the chunks being an even multiple of card16's big
1032 (do ((j 0 (index+ j 2)))
1033 ((index>= j chunk))
1034 (declare (type array-index j))
1035 (write-card16 j (funcall transform (aref data index)))
1036 (setq index (index+ index 1)))))
1037 nil)
1038
1039 (defun write-vector-card16 (buffer boffset data start end)
1040 (declare (type buffer buffer)
1041 (type vector data)
1042 (type array-index boffset start end)
1043 (optimize #+cmu(ext:inhibit-warnings 3)))
1044 (with-vector (data vector)
1045 (writing-buffer-chunks card16
1046 ((index start))
1047 ((type array-index index))
1048 ;; Depends upon the chunks being an even multiple of card16's big
1049 (do ((j 0 (index+ j 2)))
1050 ((index>= j chunk))
1051 (declare (type array-index j))
1052 (write-card16 j (aref data index))
1053 (setq index (index+ index 1)))
1054 ;; overlapping case
1055 (let ((length (floor chunk 2)))
1056 (buffer-replace buffer-wbuf data
1057 buffer-woffset
1058 (index+ buffer-woffset length)
1059 index)
1060 (setq index (index+ index length)))))
1061 nil)
1062
1063 (defun write-vector-card16-with-transform (buffer boffset data start end transform)
1064 (declare (type buffer buffer)
1065 (type vector data)
1066 (type array-index boffset start end)
1067 (optimize #+cmu(ext:inhibit-warnings 3)))
1068 (declare (type (function (t) card16) transform)
1069 #+clx-ansi-common-lisp
1070 (dynamic-extent transform)
1071 #+(and lispm (not clx-ansi-common-lisp))
1072 (sys:downward-funarg transform))
1073 (with-vector (data vector)
1074 (writing-buffer-chunks card16
1075 ((index start))
1076 ((type array-index index))
1077 ;; Depends upon the chunks being an even multiple of card16's big
1078 (do ((j 0 (index+ j 2)))
1079 ((index>= j chunk))
1080 (declare (type array-index j))
1081 (write-card16 j (funcall transform (aref data index)))
1082 (setq index (index+ index 1)))))
1083 nil)
1084
1085 (define-sequence-writer write-sequence-card16 card16
1086 (write-list-card16 write-list-card16-with-transform)
1087 (write-simple-array-card16 write-simple-array-card16-with-transform)
1088 (write-vector-card16 write-vector-card16-with-transform))
1089
1090 ;;; Writing sequences of int16's
1091
1092 (define-list-writers (write-list-int16 write-list-int16-with-transform) int16
1093 2 write-int16)
1094
1095 #-lispm
1096 (defun write-simple-array-int16 (buffer boffset data start end)
1097 (declare (type buffer buffer)
1098 (type (simple-array int16 (*)) data)
1099 (type array-index boffset start end))
1100 (with-vector (data (simple-array int16 (*)))
1101 (writing-buffer-chunks int16
1102 ((index start))
1103 ((type array-index index))
1104 ;; Depends upon the chunks being an even multiple of int16's big
1105 (do ((j 0 (index+ j 2)))
1106 ((index>= j chunk))
1107 (declare (type array-index j))
1108 (write-int16 j (aref data index))
1109 (setq index (index+ index 1)))
1110 ;; overlapping case
1111 (let ((length (floor chunk 2)))
1112 (buffer-replace buffer-wbuf data
1113 buffer-woffset
1114 (index+ buffer-woffset length)
1115 index)
1116 (setq index (index+ index length)))))
1117 nil)
1118
1119 #-lispm
1120 (defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
1121 (declare (type buffer buffer)
1122 (type (simple-array int16 (*)) data)
1123 (type array-index boffset start end))
1124 (declare (type (function (int16) int16) transform)
1125 #+clx-ansi-common-lisp
1126 (dynamic-extent transform)
1127 #+(and lispm (not clx-ansi-common-lisp))
1128 (sys:downward-funarg transform))
1129 (with-vector (data (simple-array int16 (*)))
1130 (writing-buffer-chunks int16
1131 ((index start))
1132 ((type array-index index))
1133 ;; Depends upon the chunks being an even multiple of int16's big
1134 (do ((j 0 (index+ j 2)))
1135 ((index>= j chunk))
1136 (declare (type array-index j))
1137 (write-int16 j (funcall transform (aref data index)))
1138 (setq index (index+ index 1)))))
1139 nil)
1140
1141 (defun write-vector-int16 (buffer boffset data start end)
1142 (declare (type buffer buffer)
1143 (type vector data)
1144 (type array-index boffset start end)
1145 (optimize #+cmu(ext:inhibit-warnings 3)))
1146 (with-vector (data vector)
1147 (writing-buffer-chunks int16
1148 ((index start))
1149 ((type array-index index))
1150 ;; Depends upon the chunks being an even multiple of int16's big
1151 (do ((j 0 (index+ j 2)))
1152 ((index>= j chunk))
1153 (declare (type array-index j))
1154 (write-int16 j (aref data index))
1155 (setq index (index+ index 1)))
1156 ;; overlapping case
1157 (let ((length (floor chunk 2)))
1158 (buffer-replace buffer-wbuf data
1159 buffer-woffset
1160 (index+ buffer-woffset length)
1161 index)
1162 (setq index (index+ index length)))))
1163 nil)
1164
1165 (defun write-vector-int16-with-transform (buffer boffset data start end transform)
1166 (declare (type buffer buffer)
1167 (type vector data)
1168 (type array-index boffset start end)
1169 (optimize #+cmu(ext:inhibit-warnings 3)))
1170 (declare (type (function (t) int16) transform)
1171 #+clx-ansi-common-lisp
1172 (dynamic-extent transform)
1173 #+(and lispm (not clx-ansi-common-lisp))
1174 (sys:downward-funarg transform))
1175 (with-vector (data vector)
1176 (writing-buffer-chunks int16
1177 ((index start))
1178 ((type array-index index))
1179 ;; Depends upon the chunks being an even multiple of int16's big
1180 (do ((j 0 (index+ j 2)))
1181 ((index>= j chunk))
1182 (declare (type array-index j))
1183 (write-int16 j (funcall transform (aref data index)))
1184 (setq index (index+ index 1)))))
1185 nil)
1186
1187 (define-sequence-writer write-sequence-int16 int16
1188 (write-list-int16 write-list-int16-with-transform)
1189 (write-simple-array-int16 write-simple-array-int16-with-transform)
1190 (write-vector-int16 write-vector-int16-with-transform))
1191
1192 ;;; Writing sequences of card32's
1193
1194 (define-list-writers (write-list-card32 write-list-card32-with-transform) card32
1195 4 write-card32)
1196
1197 #-lispm
1198 (defun write-simple-array-card32 (buffer boffset data start end)
1199 (declare (type buffer buffer)
1200 (type (simple-array card32 (*)) data)
1201 (type array-index boffset start end))
1202 (with-vector (data (simple-array card32 (*)))
1203 (writing-buffer-chunks card32
1204 ((index start))
1205 ((type array-index index))
1206 ;; Depends upon the chunks being an even multiple of card32's big
1207 (do ((j 0 (index+ j 4)))
1208 ((index>= j chunk))
1209 (declare (type array-index j))
1210 (write-card32 j (aref data index))
1211 (setq index (index+ index 1)))
1212 ;; overlapping case
1213 (let ((length (floor chunk 4)))
1214 (buffer-replace buffer-lbuf data
1215 buffer-loffset
1216 (index+ buffer-loffset length)
1217 index)
1218 (setq index (index+ index length)))))
1219 nil)
1220
1221 #-lispm
1222 (defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
1223 (declare (type buffer buffer)
1224 (type (simple-array card32 (*)) data)
1225 (type array-index boffset start end))
1226 (declare (type (function (card32) card32) transform)
1227 #+clx-ansi-common-lisp
1228 (dynamic-extent transform)
1229 #+(and lispm (not clx-ansi-common-lisp))
1230 (sys:downward-funarg transform))
1231 (with-vector (data (simple-array card32 (*)))
1232 (writing-buffer-chunks card32
1233 ((index start))
1234 ((type array-index index))
1235 ;; Depends upon the chunks being an even multiple of card32's big
1236 (do ((j 0 (index+ j 4)))
1237 ((index>= j chunk))
1238 (declare (type array-index j))
1239 (write-card32 j (funcall transform (aref data index)))
1240 (setq index (index+ index 1)))))
1241 nil)
1242
1243 (defun write-vector-card32 (buffer boffset data start end)
1244 (declare (type buffer buffer)
1245 (type vector data)
1246 (type array-index boffset start end)
1247 (optimize #+cmu(ext:inhibit-warnings 3)))
1248 (with-vector (data vector)
1249 (writing-buffer-chunks card32
1250 ((index start))
1251 ((type array-index index))
1252 ;; Depends upon the chunks being an even multiple of card32's big
1253 (do ((j 0 (index+ j 4)))
1254 ((index>= j chunk))
1255 (declare (type array-index j))
1256 (write-card32 j (aref data index))
1257 (setq index (index+ index 1)))
1258 ;; overlapping case
1259 (let ((length (floor chunk 4)))
1260 (buffer-replace buffer-lbuf data
1261 buffer-loffset
1262 (index+ buffer-loffset length)
1263 index)
1264 (setq index (index+ index length)))))
1265 nil)
1266
1267 (defun write-vector-card32-with-transform (buffer boffset data start end transform)
1268 (declare (type buffer buffer)
1269 (type vector data)
1270 (type array-index boffset start end)
1271 (optimize #+cmu(ext:inhibit-warnings 3)))
1272 (declare (type (function (t) card32) transform)
1273 #+clx-ansi-common-lisp
1274 (dynamic-extent transform)
1275 #+(and lispm (not clx-ansi-common-lisp))
1276 (sys:downward-funarg transform))
1277 (with-vector (data vector)
1278 (writing-buffer-chunks card32
1279 ((index start))
1280 ((type array-index index))
1281 ;; Depends upon the chunks being an even multiple of card32's big
1282 (do ((j 0 (index+ j 4)))
1283 ((index>= j chunk))
1284 (declare (type array-index j))
1285 (write-card32 j (funcall transform (aref data index)))
1286 (setq index (index+ index 1)))))
1287 nil)
1288
1289 (define-sequence-writer write-sequence-card32 card32
1290 (write-list-card32 write-list-card32-with-transform)
1291 (write-simple-array-card32 write-simple-array-card32-with-transform)
1292 (write-vector-card32 write-vector-card32-with-transform))
1293
1294 (define-transformed-sequence-writer write-sequence-int32 int32
1295 int32->card32 write-sequence-card32)
1296
1297 (defun read-bitvector256 (buffer-bbuf boffset data)
1298 (declare (type buffer-bytes buffer-bbuf)
1299 (type array-index boffset)
1300 (type (or null (simple-bit-vector 256)) data))
1301 (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
1302 (declare (type (simple-bit-vector 256) result))
1303 (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
1304 (j 8 (index+ j 8)))
1305 ((index>= j 256))
1306 (declare (type array-index i j))
1307 (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
1308 (k j (index+ k 1)))
1309 ((zerop byte)
1310 (when data ;; Clear uninitialized bits in data
1311 (do ((end (index+ j 8)))
1312 ((index= k end))
1313 (declare (type array-index end))
1314 (setf (aref result k) 0)
1315 (index-incf k))))
1316 (declare (type array-index k)
1317 (type card8 byte))
1318 (setf (aref result k) (the bit (logand byte 1)))))
1319 result))
1320
1321 (defun write-bitvector256 (buffer boffset map)
1322 (declare (type buffer buffer)
1323 (type array-index boffset)
1324 (type (simple-array bit (*)) map))
1325 (with-buffer-output (buffer :index boffset :sizes 8)
1326 (do* ((i (index+ buffer-boffset 1) (index+ i 1)) ; Skip first byte
1327 (j 8 (index+ j 8)))
1328 ((index>= j 256))
1329 (declare (type array-index i j))
1330 (do ((byte 0)
1331 (bit (index+ j 7) (index- bit 1)))
1332 ((index< bit j)
1333 (aset-card8 byte buffer-bbuf i))
1334 (declare (type array-index bit)
1335 (type card8 byte))
1336 (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
1337
1338 ;;; Writing sequences of char2b's
1339
1340 (define-list-writers (write-list-char2b write-list-char2b-with-transform) card16
1341 2 write-char2b)
1342
1343 #-lispm
1344 (defun write-simple-array-char2b (buffer boffset data start end)
1345 (declare (type buffer buffer)
1346 (type (simple-array card16 (*)) data)
1347 (type array-index boffset start end))
1348 (with-vector (data (simple-array card16 (*)))
1349 (writing-buffer-chunks card16
1350 ((index start))
1351 ((type array-index index))
1352 (do ((j 0 (index+ j 2)))
1353 ((index>= j (1- chunk)) (setf chunk j))
1354 (declare (type array-index j))
1355 (write-char2b j (aref data index))
1356 (setq index (index+ index 1)))))
1357 nil)
1358
1359 #-lispm
1360 (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform)
1361 (declare (type buffer buffer)
1362 (type (simple-array card16 (*)) data)
1363 (type array-index boffset start end))
1364 (declare (type (function (card16) card16) transform)
1365 #+clx-ansi-common-lisp
1366 (dynamic-extent transform)
1367 #+(and lispm (not clx-ansi-common-lisp))
1368 (sys:downward-funarg transform))
1369 (with-vector (data (simple-array card16 (*)))
1370 (writing-buffer-chunks card16
1371 ((index start))
1372 ((type array-index index))
1373 (do ((j 0 (index+ j 2)))
1374 ((index>= j (1- chunk)) (setf chunk j))
1375 (declare (type array-index j))
1376 (write-char2b j (funcall transform (aref data index)))
1377 (setq index (index+ index 1)))))
1378 nil)
1379
1380 (defun write-vector-char2b (buffer boffset data start end)
1381 (declare (type buffer buffer)
1382 (type vector data)
1383 (type array-index boffset start end)
1384 (optimize #+cmu(ext:inhibit-warnings 3)))
1385 (with-vector (data vector)
1386 (writing-buffer-chunks card16
1387 ((index start))
1388 ((type array-index index))
1389 (do ((j 0 (index+ j 2)))
1390 ((index>= j (1- chunk)) (setf chunk j))
1391 (declare (type array-index j))
1392 (write-char2b j (aref data index))
1393 (setq index (index+ index 1)))))
1394 nil)
1395
1396 (defun write-vector-char2b-with-transform (buffer boffset data start end transform)
1397 (declare (type buffer buffer)
1398 (type vector data)
1399 (type array-index boffset start end)
1400 (optimize #+cmu(ext:inhibit-warnings 3)))
1401 (declare (type (function (t) card16) transform)
1402 #+clx-ansi-common-lisp
1403 (dynamic-extent transform)
1404 #+(and lispm (not clx-ansi-common-lisp))
1405 (sys:downward-funarg transform))
1406 (with-vector (data vector)
1407 (writing-buffer-chunks card16
1408 ((index start))
1409 ((type array-index index))
1410 (do ((j 0 (index+ j 2)))
1411 ((index>= j (1- chunk)) (setf chunk j))
1412 (declare (type array-index j))
1413 (write-char2b j (funcall transform (aref data index)))
1414 (setq index (index+ index 1)))))
1415 nil)
1416
1417 (define-sequence-writer write-sequence-char2b card16
1418 (write-list-char2b write-list-char2b-with-transform)
1419 (write-simple-array-char2b write-simple-array-char2b-with-transform)
1420 (write-vector-char2b write-vector-char2b-with-transform))

  ViewVC Help
Powered by ViewVC 1.1.5