Merge branch 'master' of https://gitlab.com/python-on-guile/python-on-guile

1 files changed, 525 insertions, 0 deletions

diff --git a/modules/language/python/module/struct.scm b/modules/language/python/module/struct.scm
new file mode 100644
index 0000000..5f5e872
--- /dev/null
+++ b/modules/language/python/module/struct.scm
@@ -0,0 +1,525 @@
+(define-module (language python module struct)
+  #:use-module (oop pf-objects)
+  #:use-module (language python list)
+  #:use-module (language python yield)
+  #:export (calcsize pack pack_into unpack unpack_from
+                     iter_unpack Struct error))
+
+(define-python-class StructError (Error))
+(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)
+                                f-1)
+                        (f-list (f-out 1) f-1)))
+  (define f-e    (f-cons f-head (ff* f-item)))
+
+
+  (parse s (f-seq f-e f-eof)))
+
+(define (unpacker l bv n)
+  ;; Kind
+  (define type     (car l))
+  (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 '("@"))))
+  
+  ;; Util
+  (define (incr i n)
+    (+ i (if pack
+             n
+             (+ n (let ((x (modulo n 8)))
+                    (if (= x 0)
+                        0
+                        (- 8 x)))))))
+  
+  (define c-x
+    (lambda (k)
+      (lambda (bv i)
+        (if pack
+            (k bv (+ i 1))
+            (k bv i)))))
+  
+  (define c-c
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-s8-ref bv i)
+              (k bv (incr i 1))))))
+
+  (define c-b
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-s8-ref bv i)
+              (k bv (incr i 1))))))
+
+  (define c-B
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-u8-ref bv i)
+              (k bv (incr i 1))))))
+
+  (define c-?
+    (lambda (k)
+      (lambda (bv i)
+        (cons (if (= (bytevector-u8-ref bv i) 0)
+                  #f #t)
+              (k bv (incr i 1))))))
+
+  (define c-h
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-s16-ref bv i end)
+              (k bv (incr i 2))))))
+
+  (define c-H
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-u16-ref bv i end)
+              (k bv (incr i 2))))))
+
+  (define c-i4
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-s32-ref bv i end)
+              (k bv (incr i 4))))))
+
+  (define c-I4
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-u32-ref bv i end)
+              (k bv (incr i 4))))))
+
+  (define c-l8
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-s64-ref bv i end)
+              (k bv (incr i 8))))))
+
+  (define c-L8
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-u64-ref bv i end)
+              (k bv (incr i 8))))))
+
+  (define c-i c-i8)
+  (define c-I c-I8)
+  
+  (define c-l (if standard c-i4 c-l8))
+  (define c-L (if standard c-I4 c-L8)) 
+  
+  (define c-q c-l8)
+  (define c-Q c-L8)
+
+  (define c-n (if standard c-l8 c-l8))
+  (define c-N (if standard c-L8 c-L8))
+
+  (define c-f 
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-f32-ref bv i end)
+              (k bv (incr i 4))))))
+  
+  (define c-d   
+    (lambda (k)
+      (lambda (bv i)
+        (cons (bytevector-f64-ref bv i end)
+              (k bv (incr i 8))))))
+
+  (define c-g
+    (lambda (k)
+      (lambda (bv i)
+        (let* ((num   (bytevector-u16-ref bv i end))
+               (sign  (logand #x8000 num))
+               (exp   (ash (logand #x7c00 num) -10))
+               (mant  (logand #x3ff num)))
+          (cons (cond
+                 ((= exp 0)
+                  (* (if (= sign 0) 0 -1)
+                     (expt 2 -14)
+                     (string->number (format #f "0.~a" mant))))
+                 ((= exp #x1f)
+                  (if (= sign 0)
+                      (inf)
+                      (- (inf))))
+                 (else
+                  (* (if (= sign 0) 0 -1)
+                     (expt 2 (- exp 15))
+                     (string->number (format #f "1.~a" mant)))))
+                (k bv (incr i 2)))))))
+                  
+                  
+
+  (define c-s
+    (lambda (N k)
+      (lambda (bv i)
+        (let lp ((m i) (n 0) (r '()))
+          (let ((x (bytevector-u8-ref bv m)))
+            (if (< n N)
+                (lp (+ m 1) (+ n 1) (cons (bytevector-u8-ref bv m) r))
+                (let ((bvv (make-bytevector n 0)))
+                  (let lp ((j (- n 1)) (r r))
+                    (if (>= j 0)
+                        (begin
+                          (bytevector-u8-set! bvv j (car r))
+                          (lp (- j 1) (cdr r)))
+                        (cons bvv (k bv (incr i N))))))))))))
+
+
+  (define c-p
+    (lambda (N k)
+      (lambda (bv i)
+        (let* ((size (bytevector-u8-ref bv i))
+               (bvv  (make-bytevector size)))
+          (let lp ((j 0) (l i))
+            (if (and (< j size) (< j N))
+                (begin
+                  (bytevector-u8-set! bvv j (bytevector-u8-ref bv l) r)
+                  (lp (+ j 1) (+ l 1)))
+                (cons bvv (k bv (incr i N)))))))))
+
+  (define c-P c-L8)
+
+  (define tr (make-hash-table))
+
+  (hash-set! tr "x" c-x)
+  (hash-set! tr "c" c-c)
+  (hash-set! tr "b" c-b)
+  (hash-set! tr "B" c-B)
+  (hash-set! tr "?" c-?)
+  (hash-set! tr "h" c-h)
+  (hash-set! tr "H" c-H)
+  (hash-set! tr "i" c-i)
+  (hash-set! tr "I" c-I)
+  (hash-set! tr "l" c-l)
+  (hash-set! tr "L" c-L)
+  (hash-set! tr "q" c-q)
+  (hash-set! tr "Q" c-Q)
+  (hash-set! tr "n" c-n)
+  (hash-set! tr "N" c-N)
+  (hash-set! tr "e" c-e)
+  (hash-set! tr "f" c-f)
+  (hash-set! tr "d" c-d)
+  (hash-set! tr "s" c-s)
+  (hash-set! tr "p" c-p)
+  (hash-set! tr "P" c-P)
+
+  ((let lp ((l rest))
+     (lambda (bv i)
+       (match l
+         (((n tp) . l)
+          (if (member tp '("p" "s"))
+              (((hash-ref tr tp)
+                n
+                (lp l))
+               bv i)
+              (((hash-ref tr tp)
+                (lp
+                 (if (= n 1)
+                     l
+                     (cons (list (- n 1) tp) l))))
+               bv i)))
+         (() (lambda (bv i) '())))))
+   bv n))
+              
+(define (unpack format buffer)  
+  (unpacker (analyze format) buffer 0))
+
+(define unpack_from
+  (lam (format buffer (= offset 0)) 
+       (unpacker (analyze format) buffer offset)))
+
+(define (iter_unpack format buffer)
+  (let ((l (analyze format))
+        (n (len buffer))
+        (m (calcsize l)))
+    ((make-generator
+      (lambda (yield)
+        (let lp ((i 0))
+          (if (< (+ i m) n)
+              (begin
+                (yield (unpacker l buffer i))
+                (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))))))
+                   
+(define (pack_into_ format bv offset l)
+  (let lp ((l format))
+    (if (string? l)
+        (lp (analyze l))
+        (let ()
+          (define type (car l))
+          (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 c-x
+            (lambda (i)
+              (bytevector-u8-set! bv i 0)
+              (values (+ i 1) l)))
+
+          (define c-c
+            (lambda (i l)
+              (bytevector-u8-set! bv i (pylist-ref (car l) 0))
+              (values (inc i 1) (cdr l))))
+
+          (define c-b
+            (lambda (i l)
+              (bytevector-s8-set! bv i (car l))
+              (values (inc i 1) (cdr l))))
+
+          (define c-B
+            (lambda (i l)
+              (bytevector-u8-set! bv i (car l))
+              (values (inc 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))))
+
+          (define c-h
+            (lambda (i l)
+              (bytevector-s16-set! bv i (car l) end)
+              (values (inc i 2) (cdr l))))
+
+          (define c-H
+            (lambda (i l)
+              (bytevector-u16-set! bv i (car l) end)
+              (values (inc i 2) (cdr l))))
+
+          (define c-i
+            (lambda (i l)
+              (bytevector-s32-set! bv i (car l) end)
+              (values (inc i 4) (cdr l))))
+
+          (define c-I
+            (lambda (i l)
+              (bytevector-u32-set! bv i (car l) end)
+              (values (inc i 4) (cdr l))))
+
+          (define c-l8
+            (lambda (i l)
+              (bytevector-s64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-L8
+            (lambda (i l)
+              (bytevector-u64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-l (if standard c-i c-l8))
+          (define c-L (if standard c-I c-L8))
+
+          (define c-q
+            (lambda (i l)
+              (bytevector-s64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-Q
+            (lambda (i l)
+              (bytevector-u64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-n
+            (lambda (i l)
+              (bytevector-s64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-N
+            (lambda (i l)
+              (bytevector-u64-set! bv i (car l) end)
+              (values (inc 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)
+                       (x (abs x))
+                       (e (if (< x X)
+                              (if (< x XX)
+                                  #x1f
+                                  0))
+                          (inexact->exact
+                           (floor (+ (log2 x) 15))))
+                       (s? (= e 0))
+                       (i? (= e #x1f))
+                       (m  (if i?
+                               0
+                               (if s?
+                                   (inexact->exact
+                                    (floor
+                                     (* x (expt 2 24))))
+                                   (inexact->exact
+                                    (floor
+                                     (* x (expt 2 14)))))))
+                       (x   (logand (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))))))
+
+          (define c-f
+            (lambda (i l)
+              (bytevector-f32-set! bv i (car l) end)
+              (values (inc i 4) (cdr l))))
+
+          (define c-d
+            (lambda (i l)
+              (bytevector-f64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-P
+            (lambda (i l)
+              (bytevector-u64-set! bv i (car l) end)
+              (values (inc i 8) (cdr l))))
+
+          (define c-s
+            (lambda (i l n)
+              (let ((x (car l)))
+                (let lp ((j 0) (k i))
+                  (if (< j n)
+                      (begin
+                        (bytevector-u8-set! bv k (pylist-ref x j))
+                        (lp (+ j 1) (+ k 1)))
+                      (values (inc i n) (cdr l)))))))
+
+          (define c-p
+            (lambda (i l n)
+              (let* ((x (car l))
+                     (N (len x))
+                     (s (min n (- N 1))))
+                (bytevector-u8-set! bv i s)
+                (let lp ((j 0) (k (+ i 1)))
+                  (if (< j s)
+                      (begin
+                        (bytevector-u8-set! bv k (pylist-ref x j))
+                        (lp (+ j 1) (+ k 1)))
+                      (let lp ((j j) (k k))
+                        (if (< j n)
+                            (begin
+                              (bytevector-u8-set! bv k 0)
+                              (lp (+ j 1) (+ k 1)))
+                            (values (inc i n) (cdr l)))))))))
+          
+                  
+          (define tr (make-hash-table))
+
+          (hash-set! tr "x" c-x)
+          (hash-set! tr "c" c-c)
+          (hash-set! tr "b" c-b)
+          (hash-set! tr "B" c-B)
+          (hash-set! tr "?" c-?)
+          (hash-set! tr "h" c-h)
+          (hash-set! tr "H" c-H)
+          (hash-set! tr "i" c-i)
+          (hash-set! tr "I" c-I)
+          (hash-set! tr "l" c-l)
+          (hash-set! tr "L" c-L)
+          (hash-set! tr "q" c-q)
+          (hash-set! tr "Q" c-Q)
+          (hash-set! tr "n" c-n)
+          (hash-set! tr "N" c-N)
+          (hash-set! tr "e" c-e)
+          (hash-set! tr "f" c-f)
+          (hash-set! tr "d" c-d)
+          (hash-set! tr "s" c-s)
+          (hash-set! tr "p" c-p)
+          (hash-set! tr "P" c-P)
+          
+          (let lp ((p rest) (i offset) (l rest))
+            (match p
+              (((n (and tp (or "p" "s"))) . p)
+               (call-with-values
+                   (lambda ()
+                     ((hash-ref tr tp) i l n))
+                 (lambda (i l)
+                   (lp p i l))))
+              (((n tp) . p)
+               (call-with-values
+                   (lambda ()
+                     ((hash-ref tr tp) i l))
+                 (lambda (i l)
+                   (lp (if (= n 1) p (cons (list (- n 1) tp) p))
+                       i l))))
+              (()
+               bv)))))))
+
+
+(define (pack format . u)
+  (let lp ((l format))
+    (if (string? l)
+        (lp (analyze l))
+        (let* ((size (calcsize l))
+               (bv   (make-bytevector size)))
+          (pack_into_ l bv 0 u)))))
+
+
+(define (pack_into format bv i . u)
+  (pack_into_ format bv i u))
+
+
+    
+                
+