summaryrefslogtreecommitdiff
path: root/modules/language/python/module/struct.scm
diff options
context:
space:
mode:
Diffstat (limited to 'modules/language/python/module/struct.scm')
-rw-r--r--modules/language/python/module/struct.scm222
1 files changed, 125 insertions, 97 deletions
diff --git a/modules/language/python/module/struct.scm b/modules/language/python/module/struct.scm
index 5f5e872..b3d5b9f 100644
--- a/modules/language/python/module/struct.scm
+++ b/modules/language/python/module/struct.scm
@@ -1,19 +1,31 @@
(define-module (language python module struct)
#:use-module (oop pf-objects)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs bytevectors)
+ #:use-module (parser stis-parser)
#:use-module (language python list)
+ #:use-module (language python bool)
#:use-module (language python yield)
+ #:use-module (language python def)
+ #:use-module (language python exceptions)
#:export (calcsize pack pack_into unpack unpack_from
iter_unpack Struct error))
-(define-python-class StructError (Error))
+(define-python-class StructError (Exception))
+
+(define bytevector-f32-ref bytevector-ieee-single-ref)
+(define bytevector-f32-set! bytevector-ieee-single-set!)
+(define bytevector-f64-ref bytevector-ieee-double-ref)
+(define bytevector-f64-set! bytevector-ieee-double-set!)
+
(define error StructError)
(define (analyze s)
;; Parser
- (define f-head (make-token (f-or! (f-reg! "[@=<>!]") (f-out "@"))))
- (define f-1 (make-token (f-reg! "[xcbB?hHiIlLqQnNefdspP]")))
- (define f-item (f-or! (f-list (make-token (f+ (f-tag! "[0-9]"))
- string->number)
+ (define f-head (f-or! (mk-token (f-reg! "[@=<>!]")) (f-out "@")))
+ (define f-1 (mk-token (f-reg! "[xcbB?hHiIlLqQnNefdspP]")))
+ (define f-item (f-or! (f-list (mk-token (f+ (f-reg! "[0-9]"))
+ string->number)
f-1)
(f-list (f-out 1) f-1)))
(define f-e (f-cons f-head (ff* f-item)))
@@ -37,10 +49,10 @@
(define (incr i n)
(+ i (if pack
n
- (+ n (let ((x (modulo n 8)))
+ (+ n (let ((x (modulo n 4)))
(if (= x 0)
0
- (- 8 x)))))))
+ (- 4 x)))))))
(define c-x
(lambda (k)
@@ -110,8 +122,8 @@
(cons (bytevector-u64-ref bv i end)
(k bv (incr i 8))))))
- (define c-i c-i8)
- (define c-I c-I8)
+ (define c-i c-i4)
+ (define c-I c-I4)
(define c-l (if standard c-i4 c-l8))
(define c-L (if standard c-I4 c-L8))
@@ -134,7 +146,7 @@
(cons (bytevector-f64-ref bv i end)
(k bv (incr i 8))))))
- (define c-g
+ (define c-e
(lambda (k)
(lambda (bv i)
(let* ((num (bytevector-u16-ref bv i end))
@@ -143,7 +155,7 @@
(mant (logand #x3ff num)))
(cons (cond
((= exp 0)
- (* (if (= sign 0) 0 -1)
+ (* (if (= sign 0) 1 -1)
(expt 2 -14)
(string->number (format #f "0.~a" mant))))
((= exp #x1f)
@@ -151,9 +163,16 @@
(inf)
(- (inf))))
(else
- (* (if (= sign 0) 0 -1)
+ (* (if (= sign 0) 1 -1)
(expt 2 (- exp 15))
- (string->number (format #f "1.~a" mant)))))
+ (+ 1
+ (cond
+ ((< mant 10)
+ (/ mant 1000.0))
+ ((< mant 100)
+ (/ mant 100.0))
+ (else
+ (/ mant 10.0)))))))
(k bv (incr i 2)))))))
@@ -182,7 +201,7 @@
(let lp ((j 0) (l i))
(if (and (< j size) (< j N))
(begin
- (bytevector-u8-set! bvv j (bytevector-u8-ref bv l) r)
+ (bytevector-u8-set! bvv j (bytevector-u8-ref bv l))
(lp (+ j 1) (+ l 1)))
(cons bvv (k bv (incr i N)))))))))
@@ -227,7 +246,7 @@
l
(cons (list (- n 1) tp) l))))
bv i)))
- (() (lambda (bv i) '())))))
+ (() '()))))
bv n))
(define (unpack format buffer)
@@ -238,9 +257,9 @@
(unpacker (analyze format) buffer offset)))
(define (iter_unpack format buffer)
- (let ((l (analyze format))
- (n (len buffer))
- (m (calcsize l)))
+ (let* ((l format)
+ (n (len buffer))
+ (m (calcsize l)))
((make-generator
(lambda (yield)
(let lp ((i 0))
@@ -250,60 +269,61 @@
(lp (+ i m))))))))))
(define (calcsize format)
- (define type (car format))
- (define rest (cdr l))
- (define pack (member type '("@")))
- (define end (if (member type '("@"))
- (native-endianness)
- (if (member type '("<"))
- 'little
- 'big)))
- (define standard (not (member type '("@"))))
-
- (define (sz p i)
- (if p
- i
- (let ((x (modulo i 8)))
- (if (= x 0) i (+ i (- 8 x))))))
-
- (define (size n p tp)
- (sz p
- (match tp
- ((or "x" "c" "B" "b" "?")
- 1)
- ((or "h" "H" "g")
- 2)
- ((or "i" "I" "f")
- 4)
- ((or "q" "Q" "n" "N" "d" "P")
- 8)
- ((or "l" "L")
- (if standard 4 8))
- ((or "s" "p")
- n))))
-
- (if (string? format)
- (calcsize (analyze format))
- (let ((type (car format)))
- (let lp ((l (cdr format)))
- (match l
- (((1 tp) . l)
- (+ (size 1 (null? l) tp)))
- (((n (or "s" "p")) . l)
- (+ (size n (null? l) tp)
- (lp l)))
- (((n tp) . l)
- (+ (size (- n 1) #f tp)
- (lp (cons (list 1 tp) l))))
- (() 0))))))
-
+ (let lp ((format format))
+ (if (string? format)
+ (lp (analyze format))
+ (let ()
+ (define type (car format))
+ (define rest (cdr format))
+ (define pack (member type '("@")))
+ (define end (if (member type '("@"))
+ (native-endianness)
+ (if (member type '("<"))
+ 'little
+ 'big)))
+ (define standard (not (member type '("@"))))
+
+ (define (sz p i)
+ (if p
+ i
+ (let ((x (modulo i 4)))
+ (if (= x 0) i (+ i (- 4 x))))))
+
+ (define (size n p tp)
+ (sz p
+ (match tp
+ ((or "x" "c" "B" "b" "?")
+ 1)
+ ((or "h" "H" "e")
+ 2)
+ ((or "i" "I" "f")
+ 4)
+ ((or "q" "Q" "n" "N" "d" "P")
+ 8)
+ ((or "l" "L")
+ (if standard 4 8))
+ ((or "s" "p")
+ n))))
+
+ (let lp ((l (cdr format)))
+ (match l
+ (((1 tp) . l)
+ (+ (size 1 (null? l) tp)))
+ (((n (and tp (or "s" "p"))) . l)
+ (+ (size n (null? l) tp)
+ (lp l)))
+ (((n tp) . l)
+ (+ (size (- n 1) #f tp)
+ (lp (cons (list 1 tp) l))))
+ (() 0)))))))
+
(define (pack_into_ format bv offset l)
- (let lp ((l format))
- (if (string? l)
- (lp (analyze l))
+ (let lp ((format format))
+ (if (string? format)
+ (lp (analyze format))
(let ()
- (define type (car l))
- (define rest (cdr l))
+ (define type (car format))
+ (define rest (cdr format))
(define pack (member type '("@")))
(define end (if (member type '("@"))
(native-endianness)
@@ -311,7 +331,15 @@
'little
'big)))
(define standard (not (member type '("@"))))
-
+
+ (define (incr i n)
+ (+ i (if pack
+ n
+ (+ n (let ((x (modulo n 4)))
+ (if (= x 0)
+ 0
+ (- 4 x)))))))
+
(define c-x
(lambda (i)
(bytevector-u8-set! bv i 0)
@@ -320,52 +348,52 @@
(define c-c
(lambda (i l)
(bytevector-u8-set! bv i (pylist-ref (car l) 0))
- (values (inc i 1) (cdr l))))
+ (values (incr i 1) (cdr l))))
(define c-b
(lambda (i l)
(bytevector-s8-set! bv i (car l))
- (values (inc i 1) (cdr l))))
+ (values (incr i 1) (cdr l))))
(define c-B
(lambda (i l)
(bytevector-u8-set! bv i (car l))
- (values (inc i 1) (cdr l))))
+ (values (incr i 1) (cdr l))))
(define c-?
(lambda (i l)
(bytevector-u8-set! bv i (if (bool (car l)) 1 0))
- (values (inc i 1) (cdr l))))
+ (values (incr i 1) (cdr l))))
(define c-h
(lambda (i l)
(bytevector-s16-set! bv i (car l) end)
- (values (inc i 2) (cdr l))))
+ (values (incr i 2) (cdr l))))
(define c-H
(lambda (i l)
(bytevector-u16-set! bv i (car l) end)
- (values (inc i 2) (cdr l))))
+ (values (incr i 2) (cdr l))))
(define c-i
(lambda (i l)
(bytevector-s32-set! bv i (car l) end)
- (values (inc i 4) (cdr l))))
+ (values (incr i 4) (cdr l))))
(define c-I
(lambda (i l)
(bytevector-u32-set! bv i (car l) end)
- (values (inc i 4) (cdr l))))
+ (values (incr i 4) (cdr l))))
(define c-l8
(lambda (i l)
(bytevector-s64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-L8
(lambda (i l)
(bytevector-u64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-l (if standard c-i c-l8))
(define c-L (if standard c-I c-L8))
@@ -373,36 +401,36 @@
(define c-q
(lambda (i l)
(bytevector-s64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-Q
(lambda (i l)
(bytevector-u64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-n
(lambda (i l)
(bytevector-s64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-N
(lambda (i l)
(bytevector-u64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-e
(let ((X (expt 2 -14))
(XX (expt 2 -24)))
(lambda (i l)
(let* ((x (car l))
- (s (>= x 0) 0 1)
+ (s (if (>= x 0) 0 1))
(x (abs x))
(e (if (< x X)
(if (< x XX)
#x1f
- 0))
- (inexact->exact
- (floor (+ (log2 x) 15))))
+ 0)
+ (inexact->exact
+ (floor (+ (/ (log x) (log 2)) 15)))))
(s? (= e 0))
(i? (= e #x1f))
(m (if i?
@@ -414,26 +442,26 @@
(inexact->exact
(floor
(* x (expt 2 14)))))))
- (x (logand (ash s 16)
+ (x (logior (ash s 16)
(ash (logand e #x1f ) 10)
(ash (logand m #x3ff) 00))))
(bytevector-u16-set! bv i x end)
- (values (inc i 2) (cdr l))))))
+ (values (incr i 2) (cdr l))))))
(define c-f
(lambda (i l)
(bytevector-f32-set! bv i (car l) end)
- (values (inc i 4) (cdr l))))
+ (values (incr i 4) (cdr l))))
(define c-d
(lambda (i l)
(bytevector-f64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-P
(lambda (i l)
(bytevector-u64-set! bv i (car l) end)
- (values (inc i 8) (cdr l))))
+ (values (incr i 8) (cdr l))))
(define c-s
(lambda (i l n)
@@ -443,7 +471,7 @@
(begin
(bytevector-u8-set! bv k (pylist-ref x j))
(lp (+ j 1) (+ k 1)))
- (values (inc i n) (cdr l)))))))
+ (values (incr i n) (cdr l)))))))
(define c-p
(lambda (i l n)
@@ -461,7 +489,7 @@
(begin
(bytevector-u8-set! bv k 0)
(lp (+ j 1) (+ k 1)))
- (values (inc i n) (cdr l)))))))))
+ (values (incr i n) (cdr l)))))))))
(define tr (make-hash-table))
@@ -488,7 +516,7 @@
(hash-set! tr "p" c-p)
(hash-set! tr "P" c-P)
- (let lp ((p rest) (i offset) (l rest))
+ (let lp ((p rest) (i offset) (l l))
(match p
(((n (and tp (or "p" "s"))) . p)
(call-with-values
generated by cgit v1.2.3 (git 2.46.0) at 2024-10-19 12:32:43 +0000