/[movitz]/binary-types/binary-types.lisp
ViewVC logotype

Contents of /binary-types/binary-types.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Apr 20 08:32:50 2004 UTC (9 years, 11 months ago) by ffjeld
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +12 -11 lines
I think I simply forgot to check in this. Maybe this fixes the problem
with binary-types and CMUCL.
1 ;;;;------------------------------------------------------------------
2 ;;;;
3 ;;;; Copyright (C) 1999-2004,
4 ;;;; Department of Computer Science, University of Tromsoe, Norway
5 ;;;;
6 ;;;; Filename: binary-types.lisp
7 ;;;; Description: Reading and writing of binary data in streams.
8 ;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
9 ;;;; Created at: Fri Nov 19 18:53:57 1999
10 ;;;; Distribution: See the accompanying file COPYING.
11 ;;;;
12 ;;;; $Id: binary-types.lisp,v 1.3 2004/04/20 08:32:50 ffjeld Exp $
13 ;;;;
14 ;;;;------------------------------------------------------------------
15
16 (defpackage #:binary-types
17 (:nicknames #:bt)
18 (:use #:common-lisp)
19 (:export #:*endian* ; [dynamic-var] must be bound when reading integers
20 #:endianess ; [deftype] The set of endian names
21 ;; built-in types
22 #:char8 ; [type-name] 8-bit character
23 #:u8 ; [type-name] 8-bit unsigned integer
24 #:u16 ; [type-name] 16-bit unsigned integer
25 #:u32 ; [type-name] 32-bit unsigned integer
26 #:s8 ; [type-name] 8-bit signed integer
27 #:s16 ; [type-name] 16-bit signed integer
28 #:s32 ; [type-name] 32-bit signed integer
29 ; (you may define additional integer types
30 ; of any size yourself.)
31 ;; type defining macros
32 #:define-unsigned ; [macro] declare an unsigned-int type
33 #:define-signed ; [macro] declare a signed-int type
34 #:define-binary-struct ; [macro] declare a binary defstruct type
35 #:define-binary-class ; [macro] declare a binary defclass type
36 #:define-bitfield ; [macro] declare a bitfield (symbolic integer) type
37 #:define-enum ; [macro] declare an enumerated type
38 #:define-binary-string ; [macro] declare a string type
39 #:define-null-terminated-string ; [macro] declare a null-terminated string
40 ;; readers and writers
41 #:read-binary ; [func] reads a binary-type from a stream
42 #:read-binary-record ; [method]
43 #:write-binary ; [func] writes an binary object to a stream
44 #:write-binary-record ; [method]
45 #:read-binary-string
46 ;; record handling
47 #:binary-record-slot-names ; [func] list names of binary slots.
48 #:binary-slot-value ; [func] get "binary" version of slot's value
49 #:binary-slot-type ; [func] get binary slot's binary type
50 #:binary-slot-tags ; [func] get the tags of a binary slot
51 #:slot-offset ; [func] determine offset of slot.
52 ;; misc
53 #:find-binary-type ; [func] accessor to binary-types namespace
54 #:sizeof ; [func] The size in octets of a binary type
55 #:enum-value ; [func] Calculate numeric version of enum value
56 #:enum-symbolic-value ; [func] Inverse of enum-value.
57 #:with-binary-file ; [macro] variant of with-open-file
58 #:with-binary-output-to-list ; [macro]
59 #:with-binary-output-to-vector ; [macro]
60 #:with-binary-input-from-list ; [macro]
61 #:with-binary-input-from-vector ; [macro]
62 #:*binary-write-byte* ; [dynamic-var]
63 #:*binary-read-byte* ; [dynamic-var]
64 #:*padding-byte* ; [dynamic-var] The value filled in when writing paddings
65 #:split-bytes ; [func] utility
66 #:merge-bytes ; [func] utility
67 ))
68
69 (in-package binary-types)
70
71 (defvar *ignore-hidden-slots-for-pcl* nil
72 "Really ugly hack to allow older PCL-infested lisps to work in the
73 precense of :map-binary-read-delayed.")
74
75 (defvar *binary-write-byte* #'common-lisp:write-byte
76 "The low-level WRITE-BYTE function used by binary-types.")
77 (defvar *binary-read-byte* #'common-lisp:read-byte
78 "The low-level READ-BYTE function used by binary-types.")
79
80 ;;; ----------------------------------------------------------------
81 ;;; Utilities
82 ;;; ----------------------------------------------------------------
83
84 (defun make-pairs (list)
85 "(make-pairs '(1 2 3 4)) => ((1 . 2) (3 . 4))"
86 (loop for x on list by #'cddr collect (cons (first x) (second x))))
87
88 ;;; ----------------------------------------------------------------
89 ;;;
90 ;;; ----------------------------------------------------------------
91
92 (eval-when (:compile-toplevel :load-toplevel :execute)
93 (deftype endianess ()
94 "These are the legal declarations of endianess. The value NIL
95 means that the endianess is determined by the dynamic value of *endian*."
96 '(member nil :big-endian :little-endian)))
97
98 (defvar *endian* nil
99 "*endian* must be (dynamically) bound to either :big-endian or
100 :little-endian while reading endian-sensitive types.")
101
102 ;;; ----------------------------------------------------------------
103 ;;; Binary Types Namespace
104 ;;; ----------------------------------------------------------------
105
106 (defvar *binary-type-namespace* (make-hash-table :test #'eq)
107 "Maps binary type's names (which are symbols) to their binary-type class object.")
108
109 (defun find-binary-type (name &optional (errorp t))
110 (or (gethash name *binary-type-namespace*)
111 (if errorp
112 (error "Unable to find binary type named ~S." name)
113 nil)))
114
115 (defun (setf find-binary-type) (value name)
116 (check-type value binary-type)
117 (let ((old-value (find-binary-type name nil)))
118 (when (and old-value (not (eq (class-of value) (class-of old-value))))
119 (warn "Redefining binary-type ~A from ~A to ~A."
120 name (type-of old-value) (type-of value))))
121 (setf (gethash name *binary-type-namespace*) value))
122
123 (defun find-binary-type-name (type)
124 (maphash #'(lambda (key val)
125 (when (eq type val)
126 (return-from find-binary-type-name key)))
127 *binary-type-namespace*))
128
129 ;;; ----------------------------------------------------------------
130 ;;; Base Binary Type (Abstract)
131 ;;; ----------------------------------------------------------------
132
133 (defgeneric sizeof (type)
134 (:documentation "Return the size in octets of the single argument TYPE,
135 or nil if TYPE is not constant-sized."))
136
137 (defmethod sizeof (obj)
138 (sizeof (find-binary-type (type-of obj))))
139
140 (defmethod sizeof ((type symbol))
141 (sizeof (find-binary-type type)))
142
143 (defgeneric read-binary (type stream &key &allow-other-keys)
144 (:documentation "Read an object of binary TYPE from STREAM."))
145
146 (defmethod read-binary ((type symbol) stream &rest key-args)
147 (apply #'read-binary (find-binary-type type) stream key-args))
148
149 (defgeneric write-binary (type stream object &key &allow-other-keys)
150 (:documentation "Write an OBJECT of TYPE to STREAM."))
151
152 (defmethod write-binary ((type symbol) stream object &rest key-args)
153 (apply #'write-binary (find-binary-type type) stream object key-args))
154
155 (defclass binary-type ()
156 ((name
157 :initarg name
158 :initform '#:anonymous-binary-type
159 :reader binary-type-name)
160 (sizeof
161 :initarg sizeof
162 :reader sizeof))
163 (:documentation "BINARY-TYPE is the base class for binary types meta-classes."))
164
165 (defmethod print-object ((object binary-type) stream)
166 (print-unreadable-object (object stream :type 'binary-type)
167 (format stream "~A" (binary-type-name object))))
168
169 ;;; ----------------------------------------------------------------
170 ;;; Integer Type (Abstract)
171 ;;; ----------------------------------------------------------------
172
173 (defclass binary-integer (binary-type)
174 ((endian :type endianess
175 :reader binary-integer-endian
176 :initarg endian
177 :initform nil)))
178
179 (defmethod print-object ((type binary-integer) stream)
180 (if (not *print-readably*)
181 (print-unreadable-object (type stream :type t)
182 (format stream "~D-BIT~@[ ~A~] INTEGER TYPE: ~A"
183 (* 8 (slot-value type 'sizeof))
184 (slot-value type 'endian)
185 (binary-type-name type)))
186 (call-next-method type stream)))
187
188 ;;; WRITE-BINARY is identical for SIGNED and UNSIGNED, but READ-BINARY
189 ;;; is not.
190
191 (defmethod write-binary ((type binary-integer) stream object &key &allow-other-keys)
192 (check-type object integer)
193 (if (= 1 (sizeof type))
194 (progn (funcall *binary-write-byte* object stream) 1)
195 (ecase (or (binary-integer-endian type)
196 *endian*)
197 ((:big-endian big-endian)
198 (do ((i (* 8 (1- (sizeof type))) (- i 8)))
199 ((minusp i) (sizeof type))
200 (funcall *binary-write-byte* (ldb (byte 8 i) object) stream)))
201 ((:little-endian little-endian)
202 (dotimes (i (sizeof type))
203 (funcall *binary-write-byte* (ldb (byte 8 (* 8 i)) object) stream))
204 (sizeof type)))))
205
206 ;;; ----------------------------------------------------------------
207 ;;; Unsigned Integer Types
208 ;;; ----------------------------------------------------------------
209
210 (defclass binary-unsigned (binary-integer) ())
211
212 (defmacro define-unsigned (name size &optional endian)
213 (check-type size (integer 1 *))
214 (check-type endian endianess)
215 `(progn
216 (deftype ,name () '(unsigned-byte ,(* 8 size)))
217 (setf (find-binary-type ',name)
218 (make-instance 'binary-unsigned
219 'name ',name
220 'sizeof ,size
221 'endian ,endian))
222 ',name))
223
224 (define-unsigned u8 1)
225 (define-unsigned u16 2)
226 (define-unsigned u32 4)
227
228 (defmethod read-binary ((type binary-unsigned) stream &key &allow-other-keys)
229 (if (= 1 (sizeof type))
230 (values (funcall *binary-read-byte* stream)
231 1)
232 (let ((unsigned-value 0))
233 (ecase (or (binary-integer-endian type)
234 *endian*)
235 ((:big-endian big-endian)
236 (dotimes (i (sizeof type))
237 (setf unsigned-value (+ (* unsigned-value #x100)
238 (funcall *binary-read-byte* stream)
239 ))))
240 ((:little-endian little-endian)
241 (dotimes (i (sizeof type))
242 (setf unsigned-value (+ unsigned-value
243 (ash (funcall *binary-read-byte* stream)
244 (* 8 i)))))))
245 (values unsigned-value
246 (sizeof type)))))
247
248 ;;; ----------------------------------------------------------------
249 ;;; Twos Complement Signed Integer Types
250 ;;; ----------------------------------------------------------------
251
252 (defclass binary-signed (binary-integer) ())
253
254 (defmacro define-signed (name size &optional (endian nil))
255 (check-type size (integer 1 *))
256 (check-type endian endianess)
257 `(progn
258 (deftype ,name () '(signed-byte ,(* 8 size)))
259 (setf (find-binary-type ',name)
260 (make-instance 'binary-signed
261 'name ',name
262 'sizeof ,size
263 'endian ,endian))
264 ',name))
265
266 (define-signed s8 1)
267 (define-signed s16 2)
268 (define-signed s32 4)
269
270 (defmethod read-binary ((type binary-signed) stream &key &allow-other-keys)
271 (let ((unsigned-value 0))
272 (if (= 1 (sizeof type))
273 (setf unsigned-value (funcall *binary-read-byte* stream))
274 (ecase (or (binary-integer-endian type)
275 *endian*)
276 ((:big-endian big-endian)
277 (dotimes (i (sizeof type))
278 (setf unsigned-value (+ (* unsigned-value #x100)
279 (funcall *binary-read-byte* stream)
280 ))))
281 ((:little-endian little-endian)
282 (dotimes (i (sizeof type))
283 (setf unsigned-value (+ unsigned-value
284 (ash (funcall *binary-read-byte* stream)
285 (* 8 i))))))))
286 (values (if (>= unsigned-value (ash 1 (1- (* 8 (sizeof type)))))
287 (- unsigned-value (ash 1 (* 8 (sizeof type))))
288 unsigned-value)
289 (sizeof type))))
290
291 ;;; ----------------------------------------------------------------
292 ;;; Character Types
293 ;;; ----------------------------------------------------------------
294
295 ;;; There are probably lots of things one _could_ do with character
296 ;;; sets etc..
297
298 (defclass binary-char8 (binary-type) ())
299
300 (setf (find-binary-type 'char8)
301 (make-instance 'binary-char8
302 'name 'char8
303 'sizeof 1))
304
305 (deftype char8 () 'character)
306
307 (defmethod read-binary ((type binary-char8) stream &key &allow-other-keys)
308 (values (code-char (read-binary 'u8 stream))
309 1))
310
311 (defmethod write-binary ((type binary-char8) stream object &key &allow-other-keys)
312 (write-binary 'u8 stream (char-code object)))
313
314 ;;; ----------------------------------------------------------------
315 ;;; Padding Type (Implicitly defined and named by integers)
316 ;;; ----------------------------------------------------------------
317
318 ;;; The padding type of size 3 octets is named by the integer 3, and
319 ;;; so on.
320
321 (defmethod sizeof ((type integer)) type)
322
323 (defmethod read-binary ((type integer) stream &key &allow-other-keys)
324 (dotimes (i type)
325 (read-binary 'u8 stream))
326 (values nil type))
327
328 (defvar *padding-byte* #x00
329 "The value written to padding octets.")
330
331 (defmethod write-binary ((type integer) stream object &key &allow-other-keys)
332 (declare (ignore object))
333 (check-type *padding-byte* (unsigned-byte 8))
334 (dotimes (i type)
335 (write-binary 'u8 stream *padding-byte*))
336 type)
337
338 ;;; ----------------------------------------------------------------
339 ;;; String library functions
340 ;;; ----------------------------------------------------------------
341
342 (defun read-binary-string (stream &key size terminators)
343 "Read a string from STREAM, terminated by any member of the list TERMINATORS.
344 If SIZE is provided and non-nil, exactly SIZE octets are read, but the returned
345 string is still terminated by TERMINATORS. The string and the number of octets
346 read are returned."
347 (check-type size (or null (integer 0 *)))
348 (check-type terminators list)
349 (assert (or size terminators) (size terminators)
350 "Can't read a binary-string without a size limitation nor terminating bytes.")
351 (let (bytes-read)
352 (values (with-output-to-string (string)
353 (loop with string-terminated = nil
354 for count upfrom 0
355 until (if size (= count size) string-terminated)
356 do (let ((byte (funcall *binary-read-byte* stream)))
357 (cond
358 ((member byte terminators :test #'=)
359 (setf string-terminated t))
360 ((not string-terminated)
361 (write-char (code-char byte) string))))
362 finally (setf bytes-read count)))
363 bytes-read)))
364
365 ;;; ----------------------------------------------------------------
366 ;;; String Types
367 ;;; ----------------------------------------------------------------
368
369 (defclass binary-string (binary-type)
370 ((terminators
371 :initarg terminators
372 :reader binary-string-terminators)))
373
374 (defmacro define-binary-string (type-name size &key terminators)
375 (check-type size (integer 1 *))
376 `(progn
377 (deftype ,type-name () 'string)
378 (setf (find-binary-type ',type-name)
379 (make-instance 'binary-string
380 'name ',type-name
381 'sizeof ,size
382 'terminators ,terminators))
383 ',type-name))
384
385 (defmacro define-null-terminated-string (type-name size)
386 `(define-binary-string ,type-name ,size :terminators '(0)))
387
388 (defmacro define-fixed-size-nt-string (type-name size)
389 ;; compatibility..
390 `(define-null-terminated-string ,type-name ,size))
391
392 (defmethod read-binary ((type binary-string) stream &key &allow-other-keys)
393 (read-binary-string stream
394 :size (sizeof type)
395 :terminators (binary-string-terminators type)))
396
397 (defmethod write-binary ((type binary-string) stream obj &key &allow-other-keys)
398 (check-type obj string)
399 (dotimes (i (sizeof type))
400 (if (< i (length obj))
401 (funcall *binary-write-byte* (char-code (aref obj i)) stream)
402 (funcall *binary-write-byte*
403 ;; use the first member of TERMINATORS as writing terminator.
404 (or (first (binary-string-terminators type)) 0)
405 stream)))
406 (sizeof type))
407
408 ;;; ----------------------------------------------------------------
409 ;;; Record Types ("structs")
410 ;;; ----------------------------------------------------------------
411
412 ;;;(defstruct compound-slot
413 ;;; name
414 ;;; type
415 ;;; on-write)
416
417 ;;;(defun make-record-slot (&key name type map-write)
418 ;;; (list name type map-write map-read))
419 ;;;
420 ;;;(defun record-slot-name (s) (first s))
421 ;;;(defun record-slot-type (s) (second s))
422 ;;;(defun record-slot-on-write (s) (third s))
423
424 (eval-when (:load-toplevel :compile-toplevel)
425 (defstruct record-slot
426 name
427 type
428 map-write
429 map-read
430 map-read-delayed
431 hidden-read-slot
432 tags)) ; for map-read-delayed, the binary value is stored here.
433
434 (defmethod make-load-form ((object record-slot) &optional environment)
435 (declare (ignore environment))
436 (with-slots (name type map-write map-read map-read-delayed hidden-read-slot)
437 object
438 `(make-record-slot :name ',name
439 :type ',type
440 :map-write ,map-write
441 :map-read ,map-read
442 :map-read-delayed ,map-read-delayed
443 :hidden-read-slot ',hidden-read-slot)))
444
445 (defclass binary-record (binary-type)
446 ((slots
447 :initarg slots
448 :accessor binary-record-slots)
449 (offset
450 :initarg offset
451 :reader binary-record-slot-offset)))
452
453 (defclass binary-class (binary-record)
454 ;; a DEFCLASS class with binary properties
455 ((instance-class
456 :type standard-class
457 :initarg instance-class)))
458
459 (defmethod binary-record-make-instance ((type binary-class))
460 (make-instance (slot-value type 'instance-class)))
461
462 (defclass binary-struct (binary-record)
463 ;; A DEFSTRUCT type with binary properties
464 ((constructor :initarg constructor)))
465
466 (defmethod binary-record-make-instance ((type binary-struct))
467 (funcall (slot-value type 'constructor)))
468
469 (defun slot-offset (type slot-name)
470 "Return the offset (in number of octets) of SLOT-NAME in TYPE."
471 (unless (typep type 'binary-record)
472 (setf type (find-binary-type type)))
473 (check-type type binary-record)
474 (unless (find-if #'(lambda (slot)
475 (eq slot-name (record-slot-name slot)))
476 (binary-record-slots type))
477 (error "Slot ~S doesn't exist in type ~S."
478 slot-name type))
479 (+ (binary-record-slot-offset type)
480 (loop for slot in (binary-record-slots type)
481 until (eq slot-name (record-slot-name slot))
482 summing (sizeof (record-slot-type slot)))))
483
484 (defun binary-slot-tags (type slot-name)
485 (when (symbolp type)
486 (setf type (find-binary-type type)))
487 (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name)))
488 (assert slot (slot-name)
489 "No slot named ~S in binary-type ~S." slot-name type)
490 (record-slot-tags slot)))
491
492 (defun binary-record-slot-names (type &key (padding-slots-p nil)
493 (match-tags nil))
494 "Returns a list of the slot-names of TYPE, in sequence."
495 (when (symbolp type)
496 (setf type (find-binary-type type)))
497 (when (and match-tags (atom match-tags))
498 (setf match-tags (list match-tags)))
499 (let ((slot-names (if padding-slots-p
500 (mapcar #'record-slot-name (binary-record-slots type))
501 (mapcan #'(lambda (slot)
502 (if (integerp (record-slot-type slot))
503 nil
504 (list (record-slot-name slot))))
505 (binary-record-slots type)))))
506 (if (null match-tags)
507 slot-names
508 (loop for slot-name in slot-names
509 when (intersection (binary-slot-tags type slot-name)
510 match-tags)
511 collect slot-name))))
512
513 (defun binary-slot-type (type slot-name)
514 (when (symbolp type)
515 (setf type (find-binary-type type)))
516 (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name)))
517 (assert slot (slot-name)
518 "No slot named ~S in binary-type ~S." slot-name type)
519 (record-slot-type slot)))
520
521 (defun quoted-name-p (form)
522 (and (listp form)
523 (= 2 (length form))
524 (eq 'cl:quote (first form))
525 (symbolp (second form))
526 (second form)))
527
528 (defun parse-bt-spec (expr)
529 "Takes a binary-type specifier (a symbol, integer, or define-xx form),
530 and returns three values: the binary-type's name, the equivalent lisp type,
531 and any nested declaration that must be expanded separately."
532 (cond
533 ((eq :label expr) (values 0 nil)) ; a label
534 ((symbolp expr) (values expr expr)) ; a name
535 ((integerp expr) (values expr nil)) ; a padding type
536 ((quoted-name-p expr)
537 (values (second expr) (second expr))) ; a quoted name
538 ((and (listp expr) ; a nested declaration
539 (symbolp (first expr))
540 (eq (find-package 'binary-types)
541 (symbol-package (first expr))))
542 (values (second expr) (second expr) expr))
543 (t (error "Unknown nested binary-type specifier: ~S" expr))))
544
545 (defmacro define-binary-class (type-name supers slots &rest class-options)
546 (let (embedded-declarations)
547 (flet ((parse-slot-specifier (slot-specifier)
548 "For a class slot-specifier, return the slot-specifier to forward
549 (sans binary-type options), the binary-type of the slot (or nil),
550 and the slot's name, and map-write, map-read and map-read-delayed
551 functions if present."
552 (when (symbolp slot-specifier)
553 (setf slot-specifier (list slot-specifier)))
554 (loop for slot-options on (rest slot-specifier) by #'cddr
555 as slot-option = (first slot-options)
556 as slot-option-arg = (second slot-options)
557 with bintype = nil
558 and typetype = nil
559 and map-write = nil
560 and map-read = nil
561 and map-read-delayed = nil
562 and tags = nil
563 unless
564 (case slot-option
565 (:binary-tag
566 (prog1 t
567 (setf tags (if (atom slot-option-arg)
568 (list slot-option-arg)
569 slot-option-arg))))
570 ((:bt-on-write :map-binary-write)
571 (prog1 t
572 (setf map-write slot-option-arg)))
573 (:map-binary-read
574 (prog1 t
575 (setf map-read slot-option-arg)))
576 (:map-binary-read-delayed
577 (prog1 t
578 (setf map-read-delayed slot-option-arg)))
579 ((:bt :btt :binary-type :binary-lisp-type)
580 (prog1 t
581 (multiple-value-bind (bt tt nested-form)
582 (parse-bt-spec slot-option-arg)
583 (setf bintype bt)
584 (when nested-form
585 (push nested-form embedded-declarations))
586 (when (and (symbolp tt)
587 (member slot-option '(:btt :binary-lisp-type)))
588 (setf typetype tt))))))
589 nconc (list slot-option
590 slot-option-arg) into options
591 finally (return (values (list* (first slot-specifier)
592 (if typetype
593 (list* :type typetype options)
594 options))
595 bintype
596 (first slot-specifier)
597 map-write
598 map-read
599 map-read-delayed
600 tags)))))
601 (multiple-value-bind (binslot-forms binslot-types hidden-slots)
602 (loop for slot-specifier in slots with binslot-forms and binslot-types and hidden-slots
603 do (multiple-value-bind (options bintype slot-name map-write map-read map-read-delayed tags)
604 (parse-slot-specifier slot-specifier)
605 (declare (ignore options))
606 (when bintype
607 (let ((hidden-read-slot-name (when map-read-delayed
608 (make-symbol (format nil "hidden-slot-~A"
609 slot-name)))))
610 (push `(make-record-slot
611 :name ',slot-name
612 :type ',bintype
613 :map-write ,map-write
614 :map-read ,map-read
615 :map-read-delayed ,map-read-delayed
616 :hidden-read-slot ',hidden-read-slot-name
617 :tags ',tags)
618 binslot-forms)
619 (when (and hidden-read-slot-name
620 (not *ignore-hidden-slots-for-pcl*))
621 (push (list hidden-read-slot-name slot-name map-read-delayed bintype)
622 hidden-slots))
623 (push bintype binslot-types))))
624 finally (return (values (reverse binslot-forms)
625 (reverse binslot-types)
626 (reverse hidden-slots))))
627 (let* ((forward-class-options (loop for co in class-options
628 unless (member (car co)
629 '(:slot-align :class-slot-offset))
630 collect co))
631 (class-slot-offset (or (second (assoc :class-slot-offset class-options)) 0))
632 (slot-align-slot (second (assoc :slot-align class-options)))
633 (slot-align-offset (third (assoc :slot-align class-options))))
634 `(progn
635 ,@embedded-declarations
636 (defclass ,type-name ,supers
637 ,(append (mapcar #'parse-slot-specifier slots)
638 (mapcar #'first hidden-slots))
639 ,@forward-class-options)
640 (let ((record-size (loop for s in ',binslot-types summing (sizeof s))))
641 (setf (find-binary-type ',type-name)
642 (make-instance 'binary-class
643 'name ',type-name
644 'sizeof record-size
645 'slots (list ,@binslot-forms)
646 'offset ,class-slot-offset
647 'instance-class (find-class ',type-name)))
648 ,@(when slot-align-slot
649 `((setf (slot-value (find-binary-type ',type-name) 'offset)
650 (- ,slot-align-offset
651 (slot-offset ',type-name ',slot-align-slot)))))
652 ,@(loop for bs in hidden-slots
653 collect `(defmethod slot-unbound (class (instance ,type-name)
654 (slot-name (eql ',(second bs))))
655 (if (not (slot-boundp instance ',(first bs)))
656 (call-next-method class instance slot-name)
657 (setf (slot-value instance slot-name)
658 (funcall ,(third bs)
659 (slot-value instance ',(first bs))
660 ',(fourth bs))))))
661 ',type-name)))))))
662
663
664 (defmacro define-binary-struct (name-and-options dummy-options &rest doc-slot-descriptions)
665 (declare (ignore dummy-options)) ; clisp seems to require this..
666 (let (embedded-declarations)
667 (flet ((parse-slot-description (slot-description)
668 (cond
669 ((symbolp slot-description)
670 (values slot-description nil slot-description))
671 ((>= 2 (list-length slot-description))
672 (values slot-description nil (first slot-description)))
673 (t (loop for descr on (cddr slot-description) by #'cddr
674 with bintype = nil
675 and typetype = nil
676 if (member (first descr)
677 '(:bt :btt :binary-type :binary-lisp-type))
678 do (multiple-value-bind (bt lisp-type nested-form)
679 (parse-bt-spec (second descr))
680 (declare (ignore lisp-type))
681 (setf bintype bt)
682 (when nested-form
683 (push nested-form embedded-declarations))
684 (when (and (symbolp bt)
685 (member (first descr)
686 '(:btt :binary-lisp-type)))
687 (setf typetype bintype)))
688 else nconc
689 (list (first descr) (second descr)) into descriptions
690 finally
691 (return (values (list* (first slot-description)
692 (second slot-description)
693 (if typetype
694 (list* :type typetype descriptions)
695 descriptions))
696 bintype
697 (first slot-description))))))))
698 (multiple-value-bind (doc slot-descriptions)
699 (if (stringp (first doc-slot-descriptions))
700 (values (list (first doc-slot-descriptions))
701 (rest doc-slot-descriptions))
702 (values nil doc-slot-descriptions))
703 (let* ((type-name (if (consp name-and-options)
704 (first name-and-options)
705 name-and-options))
706 (binslots (mapcan (lambda (slot-description)
707 (multiple-value-bind (options bintype slot-name)
708 (parse-slot-description slot-description)
709 (declare (ignore options))
710 (if bintype
711 (list (make-record-slot :name slot-name
712 :type bintype))
713 nil)))
714 slot-descriptions))
715 (slot-types (mapcar #'record-slot-type binslots)))
716 `(progn
717 ,@embedded-declarations
718 (defstruct ,name-and-options
719 ,@doc
720 ,@(mapcar #'parse-slot-description slot-descriptions))
721 (setf (find-binary-type ',type-name)
722 (make-instance 'binary-struct
723 'name ',type-name
724 'sizeof (loop for s in ',slot-types sum (sizeof s))
725 'slots ',binslots
726 'offset 0
727 'constructor (find-symbol (format nil "~A-~A" '#:make ',type-name))))
728 ',type-name))))))
729
730 (defmethod read-binary-record (type-name stream &key start stop &allow-other-keys)
731 (let ((type (find-binary-type type-name))
732 (start-slot 0)
733 (stop-slot nil))
734 (check-type type binary-record)
735 (when start
736 (setf start-slot (position-if #'(lambda (sp)
737 (eq start (record-slot-name sp)))
738 (binary-record-slots type)))
739 (unless start-slot
740 (error "start-slot ~S not found in type ~A"
741 start type)))
742 (when stop
743 (setf stop-slot (position-if #'(lambda (sp)
744 (eq stop (record-slot-name sp)))
745 (binary-record-slots type)))
746 (unless stop-slot
747 (error "stop-slot ~S not found in type ~A"
748 stop type)))
749 (let ((total-read-bytes 0)
750 (slot-list (subseq (binary-record-slots type) start-slot stop-slot))
751 (object (binary-record-make-instance type)))
752 (dolist (slot slot-list)
753 (multiple-value-bind (read-slot-value read-slot-bytes)
754 (read-binary (record-slot-type slot) stream)
755 (cond
756 ((record-slot-map-read-delayed slot)
757 (setf (slot-value object (record-slot-hidden-read-slot slot))
758 read-slot-value)
759 (slot-makunbound object (record-slot-name slot)))
760 ((record-slot-map-read slot)
761 (setf (slot-value object (record-slot-name slot))
762 (funcall (record-slot-map-read slot) read-slot-value)))
763 (t (setf (slot-value object (record-slot-name slot)) read-slot-value)))
764 (incf total-read-bytes read-slot-bytes)))
765 (values object total-read-bytes))))
766
767 (defmethod read-binary ((type binary-record) stream &key start stop &allow-other-keys)
768 (read-binary-record (binary-type-name type) stream :start start :stop stop))
769
770 (defmethod write-binary-record (object stream)
771 (write-binary (find-binary-type (type-of object)) stream object))
772
773 (defun binary-slot-value (object slot-name)
774 "Return the ``binary'' value of a slot, i.e the value mapped
775 by any MAP-ON-WRITE slot mapper function."
776 (let ((slot (find slot-name (binary-record-slots (find-binary-type (type-of object)))
777 :key #'record-slot-name)))
778 (assert slot ()
779 "Slot-name ~A not found in ~S of type ~S."
780 slot-name object (find-binary-type (type-of object)))
781 ;;; (warn "slot: ~S value: ~S" slot (slot-value object slot-name))
782 (cond
783 ((integerp (record-slot-type slot)) nil) ; padding
784 ((and (record-slot-map-read-delayed slot)
785 (not (slot-boundp object slot-name))
786 (slot-boundp object (record-slot-hidden-read-slot slot)))
787 (slot-value object (record-slot-hidden-read-slot slot)))
788 ((record-slot-map-write slot)
789 (funcall (record-slot-map-write slot)
790 (slot-value object slot-name)
791 (record-slot-type slot)))
792 (t (slot-value object slot-name)))))
793
794 (defmethod write-binary ((type binary-record) stream object
795 &key start stop &allow-other-keys)
796 (let ((start-slot 0)
797 (stop-slot nil))
798 (when start
799 (setf start-slot (position-if #'(lambda (sp)
800 (eq start (record-slot-name sp)))
801 (binary-record-slots type)))
802 (unless start-slot
803 (error "start-slot ~S not found in type ~A"
804 start type)))
805 (when stop
806 (setf stop-slot (position-if #'(lambda (sp)
807 (eq stop (record-slot-name sp)))
808 (binary-record-slots type)))
809 (unless stop-slot
810 (error "stop-slot ~S not found in type ~A"
811 stop type)))
812 (let ((written-bytes 0)
813 (slot-list (subseq (binary-record-slots type) start-slot stop-slot)))
814 (dolist (slot slot-list)
815 (let* ((slot-name (record-slot-name slot))
816 (slot-type (record-slot-type slot))
817 (value (cond
818 ((integerp slot-type) nil) ; padding
819 ((record-slot-map-write slot)
820 (funcall (record-slot-map-write slot)
821 (slot-value object slot-name)
822 slot-type))
823 (t (slot-value object slot-name)))))
824 (incf written-bytes
825 (write-binary slot-type stream value))))
826 written-bytes)))
827
828 (defun merge-binary-records (obj1 obj2)
829 "Returns a record where every non-bound slot in obj1 is replaced
830 with that slot's value from obj2."
831 (let ((class (class-of obj1)))
832 (unless (eq class (class-of obj2))
833 (error "cannot merge incompatible records ~S and ~S" obj1 obj2))
834 (let ((new-obj (make-instance class)))
835 (dolist (slot (binary-record-slots (find-binary-type (type-of obj1))))
836 (let ((slot-name (record-slot-name slot)))
837 (cond
838 ((slot-boundp obj1 slot-name)
839 (setf (slot-value new-obj slot-name)
840 (slot-value obj1 slot-name)))
841 ((slot-boundp obj2 slot-name)
842 (setf (slot-value new-obj slot-name)
843 (slot-value obj2 slot-name))))))
844 new-obj)))
845
846 (defun binary-record-alist (obj)
847 "Returns an assoc-list representation of (the slots of) a binary
848 record object."
849 (mapcan #'(lambda (slot)
850 (unless (integerp (record-slot-type slot))
851 (list (cons (record-slot-name slot)
852 (if (slot-boundp obj (record-slot-name slot))
853 (slot-value obj (record-slot-name slot))
854 'unbound-slot)))))
855 (binary-record-slots (find-binary-type (type-of obj)))))
856
857 ;;; ----------------------------------------------------------------
858 ;;; Bitfield Types
859 ;;; ----------------------------------------------------------------
860
861 (defclass bitfield (binary-type)
862 ((storage-type
863 :type t
864 :accessor storage-type
865 :initarg storage-type)
866 (hash
867 :type hash-table
868 :initform (make-hash-table :test #'eq)
869 :accessor bitfield-hash)))
870
871 (defstruct bitfield-entry
872 value
873 bytespec)
874
875 (defmacro define-bitfield (type-name (storage-type) spec)
876 (let ((slot-list ; (slot-name value byte-size byte-pos)
877 (mapcan #'(lambda (set)
878 (ecase (caar set)
879 (:bits
880 (mapcar #'(lambda (slot)
881 (list (car slot)
882 1
883 1
884 (cdr slot)))
885 (make-pairs (cdr set))))
886 (:enum
887 (destructuring-bind (&key byte)
888 (rest (car set))
889 (mapcar #'(lambda (slot)
890 (list (car slot)
891 (cdr slot)
892 (first byte)
893 (second byte)))
894 (make-pairs (cdr set)))))
895 (:numeric
896 (let ((s (car set)))
897 (list (list (second s)
898 nil
899 (third s)
900 (fourth s)))))))
901 spec)))
902 `(let ((type-obj (make-instance 'bitfield
903 'name ',type-name
904 'sizeof (sizeof ',storage-type)
905 'storage-type (find-binary-type ',storage-type))))
906 (deftype ,type-name () '(or list symbol))
907 (dolist (slot ',slot-list)
908 (setf (gethash (first slot) (bitfield-hash type-obj))
909 (make-bitfield-entry :value (second slot)
910 :bytespec (if (and (third slot)
911 (fourth slot))
912 (byte (third slot)
913 (fourth slot))
914 nil))))
915 (setf (find-binary-type ',type-name) type-obj)
916 ',type-name)))
917
918 (defmacro define-enum (type-name (storage-name &optional byte-spec) &rest spec)
919 "A simple wrapper around DEFINE-BITFIELD for simple enum types."
920 `(define-bitfield ,type-name (,storage-name)
921 (((:enum :byte ,byte-spec)
922 ,@spec))))
923
924 (defun bitfield-compute-symbolic-value (type numeric-value)
925 "Return the symbolic value of a numeric bitfield"
926 (check-type numeric-value integer)
927 (let (result)
928 (maphash #'(lambda (slot-name entry)
929 (let ((e-value (bitfield-entry-value entry))
930 (e-bytespec (bitfield-entry-bytespec entry)))
931 (cond
932 ((and e-value e-bytespec)
933 (when (= e-value
934 (ldb e-bytespec numeric-value))
935 (push slot-name
936 result)))
937 (e-value
938 ;; no mask => this must be the sole entry present
939 (when (= numeric-value e-value)
940 (setf result slot-name)))
941 (e-bytespec
942 ;; no value => this is a numeric sub-field
943 (push (cons slot-name
944 (ldb e-bytespec numeric-value))
945 result))
946 (t (error "bitfield-value type ~A has NIL value and bytespec" type)))))
947 (bitfield-hash type))
948 ;;;;; Consistency check by symmetry. Uncomment for debugging.
949 ;;; (unless (= numeric-value
950 ;;; (bitfield-compute-numeric-value type result))
951 ;;; (error "bitfield inconsitency with ~A: ~X => ~A => ~X."
952 ;;; (type-of type)
953 ;;; numeric-value
954 ;;; result
955 ;;; (bitfield-compute-numeric-value type result)))
956 result))
957
958 (defun enum-value (type symbolic-value)
959 "For an enum type (actually, for any bitfield-based type), ~
960 look up the numeric value of a symbol."
961 (unless (typep type 'bitfield)
962 (setf type (find-binary-type type)))
963 (bitfield-compute-numeric-value type symbolic-value))
964
965 (defun enum-symbolic-value (type binary-value)
966 "The inverse of ENUM-VALUE."
967 (unless (typep type 'bitfield)
968 (setf type (find-binary-type type)))
969 (bitfield-compute-symbolic-value type binary-value))
970
971 (defun bitfield-compute-numeric-value (type symbolic-value)
972 "Returns the numeric representation of a bitfields symbolic value."
973 (etypecase symbolic-value
974 (list
975 (let ((result 0))
976 (dolist (slot symbolic-value)
977 (etypecase slot
978 (symbol ; enum sub-field
979 (let ((entry (gethash slot (bitfield-hash type))))
980 (assert entry (entry) "Unknown bitfield slot ~S of ~S."
981 slot (find-binary-type-name type))
982 (setf (ldb (bitfield-entry-bytespec entry) result)
983 (bitfield-entry-value entry))))
984 (cons ; numeric sub-field
985 (let ((entry (gethash (car slot) (bitfield-hash type))))
986 (assert entry (entry) "Unknown bitfield slot ~S of ~S."
987 (car slot) (find-binary-type-name type))
988 (setf (ldb (bitfield-entry-bytespec entry) result)
989 (cdr slot))))))
990 result))
991 (symbol ; enum
992 (let ((entry (gethash symbolic-value
993 (bitfield-hash type))))
994 (assert entry (entry) "Unknown bitfield slot ~A:~S of ~S."
995 (package-name (symbol-package symbolic-value))
996 symbolic-value
997 (find-binary-type-name type))
998 (if (bitfield-entry-bytespec entry)
999 (dpb (bitfield-entry-value entry)
1000 (bitfield-entry-bytespec entry)
1001 0)
1002 (bitfield-entry-value entry))))))
1003
1004 (defmethod read-binary ((type bitfield) stream &key &allow-other-keys)
1005 (multiple-value-bind (storage-obj num-octets-read)
1006 (read-binary (storage-type type) stream)
1007 (values (bitfield-compute-symbolic-value type storage-obj)
1008 num-octets-read)))
1009
1010 (defmethod write-binary ((type bitfield) stream symbolic-value &rest key-args)
1011 (apply #'write-binary
1012 (storage-type type)
1013 stream
1014 (bitfield-compute-numeric-value type symbolic-value)
1015 key-args))
1016
1017 ;;;; Macros:
1018
1019 (defmacro with-binary-file ((stream-var path &rest key-args) &body body)
1020 "This is a thin wrapper around WITH-OPEN-FILE, that tries to set the
1021 stream's element-type to that required by READ-BINARY and WRITE-BINARY.
1022 A run-time assertion on the stream's actual element type is performed,
1023 unless you disable this feature by setting the keyword option :check-stream
1024 to nil."
1025 (let ((check-stream (getf key-args :check-stream t))
1026 (fwd-key-args (copy-list key-args)))
1027 ;; This is manual parsing of keyword arguments. We force :element-type
1028 ;; to (unsigned-byte 8), and remove :check-stream from the arguments
1029 ;; passed on to WITH-OPEN-FILE.
1030 (remf fwd-key-args :check-stream)
1031 ;; #-(and allegro-version>= (version>= 6 0))
1032 (setf (getf fwd-key-args :element-type) ''(unsigned-byte 8))
1033 `(with-open-file (,stream-var ,path ,@fwd-key-args)
1034 ,@(when check-stream
1035 `((let ((stream-type (stream-element-type ,stream-var)))
1036 (assert (and (subtypep '(unsigned-byte 8) stream-type)
1037 (subtypep stream-type '(unsigned-byte 8)))
1038 ()
1039 "Failed to open ~S in 8-bit binary mode, stream element-type was ~S"
1040 ,path stream-type))))
1041 ,@body)))
1042
1043 (defmacro with-binary-output-to-list ((stream-var) &body body)
1044 "Inside BODY, calls to WRITE-BINARY with stream STREAM-VAR will
1045 collect the individual 8-bit bytes in a list (of integers).
1046 This list is returned by the form. (There is no way to get at
1047 the return-value of BODY.)
1048 This macro depends on the binding of *BINARY-WRITE-BYTE*, which should
1049 not be shadowed."
1050 (let ((save-bwt-var (make-symbol "save-bwt"))
1051 (closure-byte-var (make-symbol "closure-byte"))
1052 (closure-stream-var (make-symbol "closure-stream")))
1053 `(let* ((,save-bwt-var *binary-write-byte*)
1054 (,stream-var (cons nil nil)) ; (head . tail)
1055 (*binary-write-byte*
1056 #'(lambda (,closure-byte-var ,closure-stream-var)
1057 (if (eq ,stream-var ,closure-stream-var)
1058 (if (endp (cdr ,stream-var))
1059 (setf (cdr ,stream-var)
1060 (setf (car ,stream-var) (list ,closure-byte-var)))
1061 (setf (cdr ,stream-var)
1062 (setf (cddr ,stream-var) (list ,closure-byte-var))))
1063 (funcall ,save-bwt-var ; it's not our stream, so pass it ...
1064 ,closure-byte-var ; along to the next function.
1065 ,closure-stream-var)))))
1066 ,@body
1067 (car ,stream-var))))
1068
1069 (defmacro with-binary-input-from-list ((stream-var list-form) &body body)
1070 "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides
1071 8-bit bytes from LIST-FORM, which must yield a list.
1072 Binds *BINARY-READ-BYTE* appropriately. This macro will break if this
1073 binding is shadowed."
1074 (let ((save-brb-var (make-symbol "save-brb")))
1075 `(let* ((,save-brb-var *binary-read-byte*)
1076 (,stream-var (cons ,list-form nil)) ; use cell as stream id.
1077 (*binary-read-byte* #'(lambda (s)
1078 (if (eq s ,stream-var)
1079 (if (null (car s))
1080 (error "WITH-BINARY-INPUT-FROM-LIST reached end of list.")
1081 (pop (car s)))
1082 (funcall ,save-brb-var s)))))
1083 ,@body)))
1084
1085 (defmacro with-binary-input-from-vector
1086 ((stream-var vector-form &key (start 0)) &body body)
1087 "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides
1088 8-bit bytes from VECTOR-FORM, which must yield a vector.
1089 Binds *BINARY-READ-BYTE* appropriately. This macro will break if this
1090 binding is shadowed."
1091 (let ((save-brb-var (make-symbol "save-brb")))
1092 `(let* ((,save-brb-var *binary-read-byte*)
1093 (,stream-var (cons (1- ,start) ,vector-form))
1094 (*binary-read-byte* #'(lambda (s)
1095 (if (eq s ,stream-var)
1096 (aref (cdr s) (incf (car s)))
1097 (funcall ,save-brb-var s)))))
1098 ,@body)))
1099
1100 (defmacro with-binary-output-to-vector
1101 ((stream-var &optional (vector-or-size-form 0)
1102 &key (adjustable (and (integerp vector-or-size-form)
1103 (zerop vector-or-size-form)))
1104 (fill-pointer 0)
1105 (element-type ''(unsigned-byte 8))
1106 (on-full-array :error))
1107 &body body)
1108 "Arrange for STREAM-VAR to collect octets in a vector.
1109 VECTOR-OR-SIZE-FORM is either a form that evaluates to a vector, or an
1110 integer in which case a new vector of that size is created. The vector's
1111 fill-pointer is used as the write-index. If ADJUSTABLE nil (or not provided),
1112 an error will occur if the array is too small. Otherwise, the array will
1113 be adjusted in size, using VECTOR-PUSH-EXTEND. If ADJUSTABLE is an integer,
1114 that value will be passed as the EXTENSION argument to VECTOR-PUSH-EXTEND.
1115 If VECTOR-OR-SIZE-FORM is an integer, the created vector is returned,
1116 otherwise the value of BODY."
1117 (let ((vector-form
1118 (if (integerp vector-or-size-form)
1119 `(make-array ,vector-or-size-form
1120 :element-type ,element-type
1121 :adjustable ,(and adjustable t)
1122 :fill-pointer ,fill-pointer)
1123 vector-or-size-form)))
1124 (let ((save-bwb-var (make-symbol "save-bwb")))
1125 `(let* ((,save-bwb-var *binary-write-byte*)
1126 (,stream-var ,vector-form)
1127 (*binary-write-byte*
1128 #'(lambda (byte stream)
1129 (if (eq stream ,stream-var)
1130 ,(cond
1131 (adjustable
1132 `(vector-push-extend byte stream
1133 ,@(when (integerp adjustable)
1134 (list adjustable))))
1135 ((eq on-full-array :error)
1136 `(assert (vector-push byte stream) (stream)
1137 "Binary output vector is full when writing byte value ~S: ~S"
1138 byte stream))
1139 ((eq on-full-array :ignore)
1140 `(vector-push byte stream))
1141 (t (error "Unknown ON-FULL-ARRAY argument ~S, must be one of :ERROR, :IGNORE."
1142 on-full-array)))
1143 (funcall ,save-bwb-var byte stream)))))
1144 ,@body
1145 ,@(when (integerp vector-or-size-form)
1146 (list stream-var))))))
1147
1148
1149 ;;;
1150
1151 (defun split-bytes (bytes from-size to-size)
1152 "From a list of BYTES sized FROM-SIZE bits, split each byte into bytes of size TO-SIZE,
1153 according to *ENDIAN*. TO-SIZE must divide FROM-SIZE evenly. If this is not the case,
1154 you might want to apply MERGE-BYTES to the list of BYTES first."
1155 (assert (zerop (rem from-size to-size)) (from-size to-size)
1156 "TO-SIZE ~D doesn't evenly divide FROM-SIZE ~D." to-size from-size)
1157 (ecase *endian*
1158 (:little-endian
1159 (loop for byte in bytes
1160 append (loop for x from 0 below (truncate from-size to-size)
1161 collect (ldb (byte to-size (* x to-size)) byte))))
1162 (:big-endian
1163 (loop for byte in bytes
1164 append (loop for x from (1- (truncate from-size to-size)) downto 0
1165 collect (ldb (byte to-size (* x to-size)) byte))))))
1166 (defun merge-bytes (bytes from-size to-size)
1167 "Combine BYTES sized FROM-SIZE bits into new bytes sized TO-SIZE bits."
1168 (assert (zerop (rem to-size from-size)))
1169 (let ((factor (truncate to-size from-size)))
1170 (ecase *endian*
1171 (:little-endian
1172 (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x))
1173 collect (loop for n from 0 below factor
1174 as sub-byte = (or (nth n bytes) 0)
1175 summing (ash sub-byte (* n from-size)))))
1176 (:big-endian
1177 (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x))
1178 collect (loop for n from 0 below factor
1179 as sub-byte = (or (nth (- factor 1 n) bytes) 0)
1180 summing (ash sub-byte (* n from-size))))))))

  ViewVC Help
Powered by ViewVC 1.1.5