Mercurial > emacs

comparison lisp/emacs-lisp/bindat.el @ 75994:1879f509b310

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(bindat--unpack-u*): Optimize. (bindat--unpack-item, bindat--length-group, bindat--pack-item) (bindat--unpack-group, bindat--pack-group): Handle vectors with optional element type.
author Kim F. Storm <storm@cua.dk>
date Sat, 17 Feb 2007 22:02:25 +0000
parents 7a3f13e2dd57
children 935157c0b596 dd7c098af727
comparison
equal deleted inserted replaced
75993:b980e6c73752 75994:1879f509b310
145 ;; | u24 -- 3-byte value 145 ;; | u24 -- 3-byte value
146 ;; | u32 | dword | long -- length 4, network byte order 146 ;; | u32 | dword | long -- length 4, network byte order
147 ;; | u16r | u24r | u32r -- little endian byte order. 147 ;; | u16r | u24r | u32r -- little endian byte order.
148 ;; | str LEN -- LEN byte string 148 ;; | str LEN -- LEN byte string
149 ;; | strz LEN -- LEN byte (zero-terminated) string 149 ;; | strz LEN -- LEN byte (zero-terminated) string
150 ;; | vec LEN -- LEN byte vector 150 ;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8)
151 ;; | ip -- 4 byte vector 151 ;; | ip -- 4 byte vector
152 ;; | bits LEN -- List with bits set in LEN bytes. 152 ;; | bits LEN -- List with bits set in LEN bytes.
153 ;; 153 ;;
154 ;; -- Note: 32 bit values may be limited by emacs' INTEGER 154 ;; -- Note: 32 bit values may be limited by emacs' INTEGER
155 ;; implementation limits. 155 ;; implementation limits.
205 (prog1 205 (prog1
206 (aref bindat-raw bindat-idx) 206 (aref bindat-raw bindat-idx)
207 (setq bindat-idx (1+ bindat-idx)))) 207 (setq bindat-idx (1+ bindat-idx))))
208 208
209 (defun bindat--unpack-u16 () 209 (defun bindat--unpack-u16 ()
210 (let* ((a (bindat--unpack-u8)) (b (bindat--unpack-u8))) 210 (logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8)))
211 (logior (lsh a 8) b)))
212 211
213 (defun bindat--unpack-u24 () 212 (defun bindat--unpack-u24 ()
214 (let* ((a (bindat--unpack-u16)) (b (bindat--unpack-u8))) 213 (logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8)))
215 (logior (lsh a 8) b)))
216 214
217 (defun bindat--unpack-u32 () 215 (defun bindat--unpack-u32 ()
218 (let* ((a (bindat--unpack-u16)) (b (bindat--unpack-u16))) 216 (logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16)))
219 (logior (lsh a 16) b)))
220 217
221 (defun bindat--unpack-u16r () 218 (defun bindat--unpack-u16r ()
222 (let* ((a (bindat--unpack-u8)) (b (bindat--unpack-u8))) 219 (logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8)))
223 (logior a (lsh b 8))))
224 220
225 (defun bindat--unpack-u24r () 221 (defun bindat--unpack-u24r ()
226 (let* ((a (bindat--unpack-u16r)) (b (bindat--unpack-u8))) 222 (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16)))
227 (logior a (lsh b 16))))
228 223
229 (defun bindat--unpack-u32r () 224 (defun bindat--unpack-u32r ()
230 (let* ((a (bindat--unpack-u16r)) (b (bindat--unpack-u16r))) 225 (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16)))
231 (logior a (lsh b 16)))) 226
232 227 (defun bindat--unpack-item (type len &optional vectype)
233 (defun bindat--unpack-item (type len)
234 (if (eq type 'ip) 228 (if (eq type 'ip)
235 (setq type 'vec len 4)) 229 (setq type 'vec len 4))
236 (cond 230 (cond
237 ((memq type '(u8 byte)) 231 ((memq type '(u8 byte))
238 (bindat--unpack-u8)) 232 (bindat--unpack-u8))
272 (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) 266 (setq s (substring bindat-raw bindat-idx (+ bindat-idx i)))
273 (setq bindat-idx (+ bindat-idx len)) 267 (setq bindat-idx (+ bindat-idx len))
274 (if (stringp s) s 268 (if (stringp s) s
275 (string-make-unibyte (concat s))))) 269 (string-make-unibyte (concat s)))))
276 ((eq type 'vec) 270 ((eq type 'vec)
277 (let ((v (make-vector len 0)) (i 0)) 271 (let ((v (make-vector len 0)) (i 0) (vlen 1))
272 (if (consp vectype)
273 (setq vlen (nth 1 vectype)
274 vectype (nth 2 vectype))
275 (setq type (or vectype 'u8)
276 vectype nil))
278 (while (< i len) 277 (while (< i len)
279 (aset v i (bindat--unpack-u8)) 278 (aset v i (bindat--unpack-item type vlen vectype))
280 (setq i (1+ i))) 279 (setq i (1+ i)))
281 v)) 280 v))
282 (t nil))) 281 (t nil)))
283 282
284 (defun bindat--unpack-group (spec) 283 (defun bindat--unpack-group (spec)
286 (while spec 285 (while spec
287 (let* ((item (car spec)) 286 (let* ((item (car spec))
288 (field (car item)) 287 (field (car item))
289 (type (nth 1 item)) 288 (type (nth 1 item))
290 (len (nth 2 item)) 289 (len (nth 2 item))
290 (vectype (and (eq type 'vec) (nth 3 item)))
291 (tail 3) 291 (tail 3)
292 data) 292 data)
293 (setq spec (cdr spec)) 293 (setq spec (cdr spec))
294 (if (and (consp field) (eq (car field) 'eval)) 294 (if (and (consp field) (eq (car field) 'eval))
295 (setq field (eval (car (cdr field))))) 295 (setq field (eval (car (cdr field)))))
333 (if (or (equal cc tag) (equal cc t) 333 (if (or (equal cc tag) (equal cc t)
334 (and (consp cc) (eval cc))) 334 (and (consp cc) (eval cc)))
335 (setq data (bindat--unpack-group (cdr case)) 335 (setq data (bindat--unpack-group (cdr case))
336 cases nil))))) 336 cases nil)))))
337 (t 337 (t
338 (setq data (bindat--unpack-item type len) 338 (setq data (bindat--unpack-item type len vectype)
339 last data))) 339 last data)))
340 (if data 340 (if data
341 (if field 341 (if field
342 (setq struct (cons (cons field data) struct)) 342 (setq struct (cons (cons field data) struct))
343 (setq struct (append data struct)))))) 343 (setq struct (append data struct))))))
382 (while spec 382 (while spec
383 (let* ((item (car spec)) 383 (let* ((item (car spec))
384 (field (car item)) 384 (field (car item))
385 (type (nth 1 item)) 385 (type (nth 1 item))
386 (len (nth 2 item)) 386 (len (nth 2 item))
387 (vectype (and (eq type 'vec) (nth 3 item)))
387 (tail 3)) 388 (tail 3))
388 (setq spec (cdr spec)) 389 (setq spec (cdr spec))
389 (if (and (consp field) (eq (car field) 'eval)) 390 (if (and (consp field) (eq (car field) 'eval))
390 (setq field (eval (car (cdr field))))) 391 (setq field (eval (car (cdr field)))))
391 (if (and type (consp type) (eq (car type) 'eval)) 392 (if (and type (consp type) (eq (car type) 'eval))
399 field nil)) 400 field nil))
400 (if (and (consp len) (not (eq type 'eval))) 401 (if (and (consp len) (not (eq type 'eval)))
401 (setq len (apply 'bindat-get-field struct len))) 402 (setq len (apply 'bindat-get-field struct len)))
402 (if (not len) 403 (if (not len)
403 (setq len 1)) 404 (setq len 1))
405 (while (eq type 'vec)
406 (let ((vlen 1))
407 (if (consp vectype)
408 (setq len (* len (nth 1 vectype))
409 type (nth 2 vectype))
410 (setq type (or vectype 'u8)
411 vectype nil))))
404 (cond 412 (cond
405 ((eq type 'eval) 413 ((eq type 'eval)
406 (if field 414 (if field
407 (setq struct (cons (cons field (eval len)) struct)) 415 (setq struct (cons (cons field (eval len)) struct))
408 (eval len))) 416 (eval len)))
432 (progn 440 (progn
433 (bindat--length-group struct (cdr case)) 441 (bindat--length-group struct (cdr case))
434 (setq cases nil)))))) 442 (setq cases nil))))))
435 (t 443 (t
436 (if (setq type (assq type bindat--fixed-length-alist)) 444 (if (setq type (assq type bindat--fixed-length-alist))
437 (setq len (cdr type))) 445 (setq len (* len (cdr type))))
438 (if field 446 (if field
439 (setq last (bindat-get-field struct field))) 447 (setq last (bindat-get-field struct field)))
440 (setq bindat-idx (+ bindat-idx len)))))))) 448 (setq bindat-idx (+ bindat-idx len))))))))
441 449
442 (defun bindat-length (spec struct) 450 (defun bindat-length (spec struct)
476 484
477 (defun bindat--pack-u32r (v) 485 (defun bindat--pack-u32r (v)
478 (bindat--pack-u16r v) 486 (bindat--pack-u16r v)
479 (bindat--pack-u16r (lsh v -16))) 487 (bindat--pack-u16r (lsh v -16)))
480 488
481 (defun bindat--pack-item (v type len) 489 (defun bindat--pack-item (v type len &optional vectype)
482 (if (eq type 'ip) 490 (if (eq type 'ip)
483 (setq type 'vec len 4)) 491 (setq type 'vec len 4))
484 (cond 492 (cond
485 ((null v) 493 ((null v)
486 (setq bindat-idx (+ bindat-idx len))) 494 (setq bindat-idx (+ bindat-idx len)))
509 (if (memq bnum v) 517 (if (memq bnum v)
510 (setq m (logior m j))) 518 (setq m (logior m j)))
511 (setq bnum (1- bnum) 519 (setq bnum (1- bnum)
512 j (lsh j -1)))) 520 j (lsh j -1))))
513 (bindat--pack-u8 m)))) 521 (bindat--pack-u8 m))))
514 ((memq type '(str strz vec)) 522 ((memq type '(str strz))
515 (let ((l (length v)) (i 0)) 523 (let ((l (length v)) (i 0))
516 (if (> l len) (setq l len)) 524 (if (> l len) (setq l len))
517 (while (< i l) 525 (while (< i l)
518 (aset bindat-raw (+ bindat-idx i) (aref v i)) 526 (aset bindat-raw (+ bindat-idx i) (aref v i))
519 (setq i (1+ i))) 527 (setq i (1+ i)))
520 (setq bindat-idx (+ bindat-idx len)))) 528 (setq bindat-idx (+ bindat-idx len))))
529 ((eq type 'vec)
530 (let ((l (length v)) (i 0) (vlen 1))
531 (if (consp vectype)
532 (setq vlen (nth 1 vectype)
533 vectype (nth 2 vectype))
534 (setq type (or vectype 'u8)
535 vectype nil))
536 (if (> l len) (setq l len))
537 (while (< i l)
538 (bindat--pack-item (aref v i) type vlen vectype)
539 (setq i (1+ i)))))
521 (t 540 (t
522 (setq bindat-idx (+ bindat-idx len))))) 541 (setq bindat-idx (+ bindat-idx len)))))
523 542
524 (defun bindat--pack-group (struct spec) 543 (defun bindat--pack-group (struct spec)
525 (let (last) 544 (let (last)
526 (while spec 545 (while spec
527 (let* ((item (car spec)) 546 (let* ((item (car spec))
528 (field (car item)) 547 (field (car item))
529 (type (nth 1 item)) 548 (type (nth 1 item))
530 (len (nth 2 item)) 549 (len (nth 2 item))
550 (vectype (and (eq type 'vec) (nth 3 item)))
531 (tail 3)) 551 (tail 3))
532 (setq spec (cdr spec)) 552 (setq spec (cdr spec))
533 (if (and (consp field) (eq (car field) 'eval)) 553 (if (and (consp field) (eq (car field) 'eval))
534 (setq field (eval (car (cdr field))))) 554 (setq field (eval (car (cdr field)))))
535 (if (and type (consp type) (eq (car type) 'eval)) 555 (if (and type (consp type) (eq (car type) 'eval))
576 (progn 596 (progn
577 (bindat--pack-group struct (cdr case)) 597 (bindat--pack-group struct (cdr case))
578 (setq cases nil)))))) 598 (setq cases nil))))))
579 (t 599 (t
580 (setq last (bindat-get-field struct field)) 600 (setq last (bindat-get-field struct field))
581 (bindat--pack-item last type len) 601 (bindat--pack-item last type len vectype)
582 )))))) 602 ))))))
583 603
584 (defun bindat-pack (spec struct &optional bindat-raw bindat-idx) 604 (defun bindat-pack (spec struct &optional bindat-raw bindat-idx)
585 "Return binary data packed according to SPEC for structured data STRUCT. 605 "Return binary data packed according to SPEC for structured data STRUCT.
586 Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to 606 Optional third arg BINDAT-RAW is a pre-allocated unibyte string or vector to