pack.diff

--- binary/pack.scm.org  Sun Apr 01 17:09:10 2012
+++ binary/pack.scm	Wed Jan 23 16:18:05 2013
@@ -1,6 +1,8 @@
+#!r6rs
 ;;;; binary.pack -- packing and unpacking binary data
 
 ;;; Author:     Alex Shinn <foof@synthcode.com>
+;;; Modified by SAITO Atsushi for Sagittarius scheme
 
 ;; It is really insupportable that every hen lays an egg of a different
 ;; size!  What symmetry can there be on the breakfast table?  At least
@@ -14,22 +16,237 @@
 ;;   an @ following a variable length template, without which all the
 ;;   "vlp" references would be gone.
 
-(define-module binary.pack
-  (use srfi-1)
-  (use srfi-11)   ;; let-values
-  (use srfi-13)   ;; string library
-  (use srfi-14)   ;; char-set library
-  (use util.list) ;; list library (srfi-1+)
-  (use text.parse)
-  (use gauche.uvector)
-  (use gauche.parameter)
-  (use binary.io)
-  (export pack unpack unpack-skip make-packer))
-(select-module binary.pack)
+(library (binary pack)
+  (export pack unpack unpack-skip make-packer)
+  (import (except (rnrs) when)
+          (rnrs bytevectors (6))
+          (rnrs io ports (6))
+          (rnrs hashtables (6))
+          (rnrs arithmetic bitwise (6))
+          (rnrs r5rs (6))
+          (srfi :1 lists)
+          (srfi :13 strings)
+          (srfi :14 char-set)
+          (srfi :26 cut)
+          (srfi :29 format)
+          (srfi :39 parameters)
+          (sagittarius control)
+          (sagittarius io)
+          (sagittarius object)
+          (text parse))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; general io utilities
 
+(define-syntax push!
+  (syntax-rules ()
+    ((_ var val)
+     (set! var (cons val var)))))
+
+(define-syntax pop!
+  (syntax-rules ()
+    ((_ var)
+     (let ((tmp (car var)))
+       (set! var (cdr var))
+       tmp))))
+
+(define-syntax while
+  (syntax-rules (=>)
+    ((_ expr guard => var b1 ...)
+     (let loop ()
+       (let ((var expr))
+         (when (guard var) b1 ... (loop)))))
+    ((_ pred b1 ...)
+     (let loop () (when pred b1 ... (loop))))
+    ))
+
+(define-syntax when
+  (syntax-rules (=>)
+    ((_ expr guard => var b1 ...)
+     (let ((var expr))
+       (if (guard var) (begin b1 ...))))
+    ((_ pred b1 ...)
+     (if pred (begin b1 ...)))))
+
+(define-syntax until
+  (syntax-rules ()
+    ((_ pred b1 ...)
+     (while (not pred) b1 ...))))
+
+(define (string-incomplete->complete! _) #f)
+
+(define copy-bit-field bitwise-copy-bit-field)
+
+(define x->number ->number)
+  
+(define (copy-bit index n bit)
+  (bitwise-copy-bit n index (if bit 1 0)))
+
+(define (open-output-buffered-port flusher size)
+  (make-custom-textual-output-port "buffered"
+    (lambda(str start count)
+      (flusher (substring str start (+ start count))))
+    #f
+    #f
+    #f))
+  
+(define (logbit? index n)
+  (bitwise-bit-set? n index))
+
+(define (ash n count)
+  (bitwise-arithmetic-shift-left n count))
+
+(define logand bitwise-and)
+
+(define string-size string-length)
+
+(define (port-seek port n)
+  (set-port-position! port (+ (port-position port) n)))
+
+(define (read-block n . opt)
+  (let-optionals* opt ((port (current-input-port)))
+    (get-bytevector-n port n)))
+
+(define (compose-chunks chunks)
+  (let* ((size (fold-left (lambda(a e) (+ a (bytevector-length e))) 0 chunks))
+         (vec (make-bytevector size))
+         (chunks (reverse! chunks)))
+    (do ((chunks chunks (cdr chunks))
+         (i 0 (+ i (bytevector-length (car chunks)))))
+        ((null? chunks) vec)
+      (bytevector-copy! (car chunks) 0 vec i
+                        (bytevector-length (car chunks))))))
+
+(define (call-with-output-binary proc)
+  (let ((chunks '()))
+    (proc
+     (make-custom-binary-output-port "binary-output-port"
+       (lambda(vec start count)
+         (let ((cp (make-bytevector count)))
+           (bytevector-copy! vec start cp 0 count)
+           (push! chunks cp))
+         count)
+       #f #f #f))
+    (compose-chunks chunks)))
+
+(define (open-binary-input-port src)
+  (let ((i 0)
+        (len (bytevector-length src)))
+    (make-custom-binary-input-port "binary-input-port"
+      (lambda(vec start count)
+        (let ((copy-size (min count (- len i))))
+          (bytevector-copy! src i vec start copy-size)
+          copy-size))
+      (lambda() i)
+      (lambda(x) (set! i x))
+      #f)))
+  
+
+(define (endian-convert x)
+  (case x
+    ((big-endian big) (endianness big))
+    ((little-endian little) (endianness little))))
+
+(define-syntax define-read-procedure
+  (syntax-rules ()
+    ((_ name size accessor)
+     (define name
+       (let ((vec (make-bytevector size)))
+         (lambda arg
+           (let-optionals* arg ((port (current-input-port))
+                                (endian (native-endianness)))
+             (unless port (set! port (current-input-port)))
+             (get-bytevector-n! port vec 0 size)
+             (accessor vec 0 (endian-convert endian)))))))))
+
+(define-syntax define-read-procedure*
+  (syntax-rules ()
+    ((_ name size accessor)
+     (define name
+       (let ((vec (make-bytevector size)))
+         (lambda arg
+           (let-optionals* arg ((port (current-input-port)))
+             (unless port (set! port (current-input-port)))
+             (get-bytevector-n! port vec 0 size)
+             (accessor vec 0))))))))
+
+(define-read-procedure* read-binary-uint8 1 bytevector-u8-ref)
+(define-read-procedure* read-binary-sint8 1 bytevector-s8-ref)
+(define-read-procedure read-binary-uint16 2 bytevector-u16-ref)
+(define-read-procedure read-binary-sint16 2 bytevector-s16-ref)
+(define-read-procedure read-binary-short 2 bytevector-s16-ref)
+(define-read-procedure read-binary-uint32 4 bytevector-u32-ref)
+(define-read-procedure read-binary-sint32 4 bytevector-s32-ref)
+(define-read-procedure read-binary-uint64 8 bytevector-u64-ref)
+(define-read-procedure read-binary-sint64 8 bytevector-s64-ref)
+
+(define-read-procedure read-binary-double 8 bytevector-ieee-double-ref)
+(define-read-procedure read-binary-float 4 bytevector-ieee-single-ref)
+
+(define-syntax define-write-procedure
+  (syntax-rules ()
+    ((_ name size setter)
+     (define name 
+       (let ((vec (make-bytevector size)))
+         (lambda (val . opt)
+           (let-optionals* opt ((port (current-output-port))
+                                (endian (native-endianness)))
+             (unless port (set! port (current-output-port)))
+             (setter vec 0 val (endian-convert endian))
+             (put-bytevector port vec 0 size))))))))
+
+(define-syntax define-write-procedure*
+  (syntax-rules ()
+    ((_ name size setter)
+     (define name 
+       (let ((vec (make-bytevector size)))
+         (lambda (val . opt)
+           (let-optionals* opt ((port (current-output-port)))
+             (unless port (set! port (current-output-port)))
+             (setter vec 0 val)
+             (put-bytevector port vec 0 size))))))))
+
+(define-write-procedure* write-binary-uint8 1 bytevector-u8-set!)
+(define-write-procedure* write-binary-sint8 1 bytevector-s8-set!)
+(define-write-procedure write-binary-uint16 2 bytevector-u16-set!)
+(define-write-procedure write-binary-sint16 2 bytevector-s16-set!)
+(define-write-procedure write-binary-uint32 4 bytevector-u32-set!)
+(define-write-procedure write-binary-sint32 4 bytevector-s32-set!)
+(define-write-procedure write-binary-uint64 8 bytevector-u64-set!)
+(define-write-procedure write-binary-sint64 8 bytevector-s64-set!)
+(define-write-procedure write-binary-double 8 bytevector-ieee-double-set!)
+(define-write-procedure write-binary-float 4 bytevector-ieee-single-set!)
+
+(define (split-at* lis k . opt)
+  (let-optionals* opt ((fill? #f) (filler #f))
+    (when (or (not (integer? k)) (negative? k))
+      (error "index must be non-negative integer" k))
+    (let loop ((i 0)
+               (lis lis)
+               (r '()))
+      (cond [(= i k) (values (reverse! r) lis)]
+            [(null? lis)
+             (values (if fill?
+                         (append! (reverse! r) (make-list (- k i) filler))
+                         (reverse! r))
+                     lis)]
+            [else (loop (+ i 1) (cdr lis) (cons (car lis) r))]))))
+
+(define read-byte
+  (case-lambda
+   ((port) (get-u8 port))
+   (() (get-u8 (current-input-port)))))
+
+(define write-byte
+  (case-lambda
+   ((byte port) (put-u8 port byte))
+   ((byte) (put-u8 (current-output-port) byte))))
+
+(define peek-byte
+  (case-lambda
+   ((port) (lookahead-u8 port))
+   (() (lookahead-u8 (current-input-port)))))
+  
 (define (read-number)
   (let loop ((c (peek-char))
              (ls '()))
@@ -40,12 +257,11 @@
       (string->number (reverse-list->string ls)))))
 
 (define (string-byte-for-each proc str)
-  (with-input-from-string str
-    (lambda ()
-      (let loop ((i (read-byte)))
-        (unless (eof-object? i)
-          (proc i)
-          (loop (read-byte)))))))
+  (let* ((vec (string->utf8 str))
+         (len (bytevector-length vec)))
+    (do ((i 0 (+ 1 i)))
+        ((>= i len))
+      (proc (bytevector-u8-ref vec i)))))
 
 (define (while-input-from-string str proc)
   (with-input-from-string str
@@ -69,44 +285,45 @@
    (else (error "CHAR-LIST must be a char-set or a list of characters, char-sets and/or symbol '*eof*" char-list))))
 
 ;; text.parse's next-token with a limit
-(define (next-token-n prefix-char-list/pred break-char-list/pred limit
-                      :optional (comment "unexpected EOF") (port (current-input-port)))
-  (define (bad) (errorf "~a~a" (port-position-prefix port) comment))
-  (let ((c (skip-while prefix-char-list/pred port)))
-    (cond
-     ((procedure? break-char-list/pred)
-      (with-output-to-string
-        (lambda ()
-          (let loop ((c c)
-                     (i 0))
-            (cond ((break-char-list/pred c))
-                  ((eof-object? c) (bad))
-                  ((= i limit))
-                  (else
-                   (display (read-char port))
-                   (loop (peek-char port) (+ i 1)))))))
-      )
-     (else
-      (receive (cs eof-ok?) (fold-char-list break-char-list/pred)
+(define (next-token-n prefix-char-list/pred break-char-list/pred limit . opt)
+  (let-optionals* opt ((comment "unexpected EOF") (port (current-input-port)))
+    (let ((bad (lambda()(errorf "~a~a" (port-position-prefix port) comment)))
+          (c (skip-while prefix-char-list/pred port)))
+      (cond
+       ((procedure? break-char-list/pred)
         (with-output-to-string
           (lambda ()
             (let loop ((c c)
                        (i 0))
-              (cond ((eof-object? c) (unless eof-ok? (bad)))
-                    ((char-set-contains? cs c))
+              (cond ((break-char-list/pred c))
+                    ((eof-object? c) (bad))
                     ((= i limit))
-                    (else (display (read-char port))
-                          (loop (peek-char port) (+ i 1))))))))
-      ))))
+                    (else
+                     (display (read-char port))
+                     (loop (peek-char port) (+ i 1)))))))
+        )
+       (else
+        (receive (cs eof-ok?) (fold-char-list break-char-list/pred)
+          (with-output-to-string
+            (lambda ()
+              (let loop ((c c)
+                         (i 0))
+                (cond ((eof-object? c) (unless eof-ok? (bad)))
+                      ((char-set-contains? cs c))
+                      ((= i limit))
+                      (else (display (read-char port))
+                            (loop (peek-char port) (+ i 1))))))))
+        )))))
 
 ;; same as above but consumes the break-char
-(define (next-token-n* prefix-char-list/pred break-char-list/pred limit
-                       :optional (comment "unexpected EOF") (port (current-input-port)))
-  (let ((res (next-token-n prefix-char-list/pred
-                           break-char-list/pred limit comment port)))
-    (if (< (string-size res) limit)
-      (read-char port))
-    res))
+(define (next-token-n* prefix-char-list/pred break-char-list/pred limit . opt)
+  (let-optionals* opt ((comment "unexpected EOF")
+                       (port (current-input-port)))
+    (let ((res (next-token-n prefix-char-list/pred
+                             break-char-list/pred limit comment port)))
+      (if (< (string-size res) limit)
+          (read-char port))
+      res)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; numeric utilities
@@ -124,9 +341,16 @@
     (if (logbit? i int) (proc 1) (proc 0))))
 
 (define (hex-char->number c)
-  (if (< c 16)
-    c
-    (or (digit->integer (integer->char c) 16) 0)))
+  (or (digit->integer c 16) 0))
+
+(define digit->integer
+  (let ((as '((#\0 . 0) (#\1 . 1) (#\2 . 2) (#\3 . 3) (#\4 . 4) (#\5 . 5)
+              (#\6 . 6) (#\6 . 6) (#\7 . 7) (#\8 . 8) (#\9 . 9) (#\a . 10)
+              (#\b . 11) (#\c . 12) (#\d . 13) (#\e . 14) (#\f . 15))))
+    (lambda(c . opt)
+      (let-optionals* opt ((radix 10))
+        (let ((res-pair (assv c as)))
+          (if res-pair (cdr res-pair) #f))))))
 
 (define (number-writer writer . opt-endian)
   (if (pair? opt-endian)
@@ -144,7 +368,7 @@
       (cut split-at* <> count #t))))
 
 (define (read-bang)
-  (and (equal? (char->integer #\!) (peek-byte)) (read-byte) #t))
+  (and (equal? (char->integer #\!) (peek-char)) (read-char) #t))
 
 (define (read-count)
   (skip-pack-comments)
@@ -188,7 +412,7 @@
             (count
              (cut string-pad-right <> count))
             (else
-             identity)))))
+             values)))))
 
 (define (make-port-byte-iterator proc count)
   (cond
@@ -232,11 +456,11 @@
      (let ((unpacker (n 'unpacker)))
        (lambda ()
          (let ((count (unpacker)))
-           (or (port-seek (current-input-port) count SEEK_CUR)
+           (or (port-seek (current-input-port) count)
                (read-block count))))))
     (else
      (lambda ()
-       (or (port-seek (current-input-port) n SEEK_CUR)
+       (or (port-seek (current-input-port) n)
            (read-block n))))))
 
 (define (char-complement ch)
@@ -250,7 +474,7 @@
 (define (make-pack-token c)
   (list '*token* c))
 
-(define the-eof-object (with-input-from-string "" read-char))
+(define the-eof-object (eof-object))
 
 (define (skip-pack-comments)
   (let loop ((c (peek-char)))
@@ -313,7 +537,7 @@
   (if (null? args)
     packer
     (let-optionals* args ((accessor #f)
-                          (mutator identity))
+                          (mutator values))
       (packer 'set! accessor (mutator (packer accessor)))
       (apply modify-pack-dispatch packer (cddr args)))))
 
@@ -381,7 +605,7 @@
               (concatenate (reverse res))))
           (lambda ()
             (let ((n (* size (get-count (unpacker)))))
-              (or (port-seek (current-input-port) n SEEK_CUR)
+              (or (port-seek (current-input-port) n)
                   (read-block n)))))))
       (else
        (make-pack-dispatch
@@ -430,7 +654,8 @@
      param
      (lambda (values)
        (with-output-to-port (make-out-filter (current-output-port))
-         (lambda () (let ((v (orig-pack values))) (flush) v))))
+         (lambda () (let ((v (orig-pack values)))
+                      (flush-output-port (current-output-port)) v))))
      (lambda ()
        (with-input-from-port (make-in-filter (current-input-port))
          (lambda () (orig-unpack))))
@@ -590,7 +815,7 @@
 
            ;; a   A string with arbitrary binary data, will be null padded.
            ((#\a)
-            (let ((pad (get-string-padder count #\null)))
+            (let ((pad (get-string-padder count #\nul)))
               (make-pack-dispatch
                (if (number? count) count 0)
                (not (number? count))
@@ -606,18 +831,15 @@
                            (str (or (string-incomplete->complete! bstr) bstr))
                            (size (string-size str)))
                       (list
-                       (if (< size actual-count)
-                         (string-append str (make-string (- actual-count size) #\null))
-                         str)))))
+                         bstr))))
                  (else
                   (lambda ()
-                    (let* ((bstr (read-block count))
-                           (str (or (string-incomplete->complete! bstr) bstr))
-                           (size (string-size str)))
-                      (list
-                       (if (< size count)
-                         (string-append str (make-string (- count size) #\null))
-                         str)))))
+                    (let* ((bstr (make-bytevector count 0))
+                           (size (get-bytevector-n! (current-input-port)
+                                                    bstr
+                                                    0
+                                                    count)))
+                      bstr)))
                  )
                (make-skipper count)
                )))
@@ -633,19 +855,19 @@
              vlp
              (cond
                ((number? count)
-                (let ((pad (get-string-padder (- count 1) #\null)))
-                  (lambda (v) (display (pad (pop! v))) (display #\null))))
+                (let ((pad (get-string-padder (- count 1) #\nul)))
+                  (lambda (v) (display (pad (pop! v))) (display #\nul))))
                (else
-                (let ((pad (get-string-padder count #\null)))
-                  (lambda (v) (display (pad (pop! v))) (display #\null)))))
+                (let ((pad (get-string-padder count #\nul)))
+                  (lambda (v) (display (pad (pop! v))) (display #\nul)))))
              (cond
                ((eq? count #\*)
-                (cut list (next-token '() '(#\null *eof*))))
+                (cut list (next-token '() '(#\nul *eof*))))
                ((procedure? count)
                 (let ((unpacker (count 'unpacker)))
-                  (cut list (next-token-n* '() '(#\null *eof*) (get-count (unpacker))))))
+                  (cut list (next-token-n* '() '(#\nul *eof*) (get-count (unpacker))))))
                (else
-                (cut list (next-token-n* '() '(#\null *eof*) count))))
+                (cut list (next-token-n* '() '(#\nul *eof*) count))))
              (make-skipper count)
              ))
 
@@ -696,12 +918,15 @@
                (lambda (v)
                  (while-input-from-string (pad (pop! v))
                    (lambda ()
-                     (let* ((n1 (hex-char->number (read-byte)))
-                            (n2 (hex-char->number (read-byte))))
+                     (let* ((n1 (hex-char->number (read-char)))
+                            (n2 (hex-char->number (read-char))))
                        (write-byte (copy-bit-field n1 4 8 n2)))))
                  v)
                (make-port-byte-iterator
-                (lambda (i) (format #t "~x~x" (logand i #b1111) (ash i -4))) count)
+                (lambda (i)
+                  (string-append (number->string (logand i #b1111) 16)
+                                 (number->string (ash i -4))))
+                count)
                (make-skipper count))))
 
            ;; H   A hex string (high nybble first).
@@ -714,12 +939,15 @@
                (lambda (v)
                  (while-input-from-string (pad (pop! v))
                    (lambda ()
-                     (let* ((n1 (hex-char->number (read-byte)))
-                            (n2 (hex-char->number (read-byte))))
+                     (let* ((n1 (hex-char->number (read-char)))
+                            (n2 (hex-char->number (read-char))))
                        (write-byte (copy-bit-field n2 4 8 n1)))))
                  v)
                (make-port-byte-iterator
-                (lambda (i) (format #t "~x~x" (ash i -4) (logand i #b1111))) count)
+                (lambda (i)
+                  (string-append (number->string (ash i -4) 16)
+                                 (number->string (logand i #b1111) 16)))
+                count)
                (make-skipper count))))
 
            ;; c   A signed char value.
@@ -883,7 +1111,7 @@
                vlp
                (lambda (v)
                  (unless (eq? count #\*)
-                   (display (make-string count #\null)))
+                   (display (make-string count #\nul)))
                  v)
                ;; unpack means skip but return '() to append as nothing
                (lambda () (skipper) '())
@@ -901,14 +1129,14 @@
                var-len-param
                (lambda (v)
                  (let ((diff (- var-count (var-len-param))))
-                   (display (make-string diff #\null))
+                   (display (make-string diff #\nul))
                    (var-len-param (+ (var-len-param) diff))
                    )
                  v)
                (lambda ()
                  (let ((diff (- var-count (var-len-param))))
                    (var-len-param (+ (var-len-param) diff))
-                   (or (port-seek (current-input-port) diff SEEK_CUR)
+                   (or (port-seek (current-input-port) diff)
                        (read-block diff))
                    '()))
                #f)))
@@ -965,38 +1193,40 @@
     a
     (merge-pack-dispatch b a)))
 
-(define (read-packers-until-token token :optional (fixed-len 0) (var-len? #f)
-                                  (vlp #f))
-  (let ((packers (read-until-token (make-pack-token token)
-                                   fixed-len var-len? vlp)))
-    ;; update var-len fields if we have an @
-    ;; with make-count-update-pack-dispatch
-    (let loop ((ls packers)
-               (res '()))
-      (if (null? ls)
-        (fold pack-merge-folder #f (reverse res))
-        (let ((a (car ls))
-              (rest (cdr ls)))
-          (if (null? rest)
-            (loop rest (cons a res))
-            (let ((b (car rest)))
-              (if (and (not (a 'var-len-param))
-                       (b 'var-len-param))
-                (let ((b-vlp (b 'var-len-param)))
-                  (loop rest
-                        (list
-                         (modify-pack-dispatch
-                          (fold pack-merge-folder #f
-                                (reverse
-                                 (map (lambda (p)
-                                        (if (p 'variable-length?)
-                                          (make-count-update-pack-dispatch p (b 'var-len-param))
-                                          p))
-                                      (cons a res))))
-                          'packer (lambda (orig) (lambda (v) (b-vlp 0) (orig v)))
-                          'unpacker (lambda (orig) (lambda () (b-vlp 0) (orig)))
-                          ))))
-                (loop rest (cons a res))))))))))
+(define (read-packers-until-token token . opt)
+  (let-optionals* opt ((fixed-len 0)
+                       (var-len? #f)
+                       (vlp #f))
+    (let ((packers (read-until-token (make-pack-token token)
+                                     fixed-len var-len? vlp)))
+      ;; update var-len fields if we have an @
+      ;; with make-count-update-pack-dispatch
+      (let loop ((ls packers)
+                 (res '()))
+        (if (null? ls)
+            (fold pack-merge-folder #f (reverse res))
+            (let ((a (car ls))
+                  (rest (cdr ls)))
+              (if (null? rest)
+                  (loop rest (cons a res))
+                  (let ((b (car rest)))
+                    (if (and (not (a 'var-len-param))
+                             (b 'var-len-param))
+                        (let ((b-vlp (b 'var-len-param)))
+                          (loop rest
+                                (list
+                                 (modify-pack-dispatch
+                                  (fold pack-merge-folder #f
+                                        (reverse
+                                         (map (lambda (p)
+                                                (if (p 'variable-length?)
+                                                    (make-count-update-pack-dispatch p (b 'var-len-param))
+                                                    p))
+                                              (cons a res))))
+                                  'packer (lambda (orig) (lambda (v) (b-vlp 0) (orig v)))
+                                  'unpacker (lambda (orig) (lambda () (b-vlp 0) (orig)))
+                                  ))))
+                        (loop rest (cons a res)))))))))))
 
 (define (read-all-packers template)
   (with-input-from-string template
@@ -1009,48 +1239,49 @@
 ;; making a parameter for thread safety, maybe better shared between
 ;; threads with a mutex.
 (define make-packer
-  (let ((cache (make-parameter (make-hash-table 'equal?))))
+  (let ((cache (make-parameter (make-hashtable string-hash string=?))))
     (lambda (template cached?)
       (if cached?
-        (let ((res (hash-table-get (cache) template #f)))
+        (let ((res (hashtable-ref (cache) template #f)))
           (unless res
             (set! res (read-all-packers template))
-            (hash-table-put! (cache) template res))
+            (hashtable-set! (cache) template res))
           res)
         (read-all-packers template)))))
 
-(define (pack template values :key (output #f) (to-string? #f) (cached? #t))
-  (let ((packer (make-packer template cached?))
-        (out (or output
-                 (and to-string? (open-output-string))
-                 (current-output-port))))
-    (with-output-to-port out
-      (lambda ()
-        (let ((res (packer 'pack values)))
-          (if (pair? res)
-            (error "pack: extra values remaining: ~S" res)
-            (if to-string?
-              (get-output-string out)
-              #t)))))))
+(define (pack template values . opt)
+  (let-keywords opt ((cached? #t))
+    (call-with-output-binary
+     (lambda(out)
+       (with-output-to-port out
+         (let ((packer (make-packer template cached?)))
+           (lambda ()
+             (let ((res (packer 'pack values)))
+               (when (pair? res)
+                 (error "pack: extra values remaining: ~S" res))))))))))
 
 (define (get-input-port keys)
   (let-keywords keys ((input #f)
-                      (from-string #f))
+                      (from-string (current-input-port)))
     (or input
-        (and from-string (open-input-string from-string))
+        (and (string? from-string)
+             (open-binary-input-port (string->utf8 from-string)))
+        (and from-string (open-binary-input-port from-string))
         (current-input-port))))
 
-(define (unpack template :key (cached? #t) :allow-other-keys rest)
-  (let ((packer (make-packer template cached?))
-        (in (get-input-port rest)))
-    (with-input-from-port in
-      (cut packer 'unpack))))
+(define (unpack template . opt)
+  (let-keywords opt ((cached? #t) . rest)
+      (let ((packer (make-packer template cached?))
+            (in (get-input-port rest)))
+        (with-input-from-port in
+          (cut packer 'unpack)))))
 
 ;; just "skip" is too vague
-(define (unpack-skip template :key (cached? #t) :allow-other-keys rest)
-  (let ((packer (make-packer template cached?))
-        (in (get-input-port rest)))
-    (with-input-from-port in
-      (cut packer 'skip))))
-
+(define (unpack-skip template . opt)
+  (let-keywords opt ((cached? #t) . rest)
+      (let ((packer (make-packer template cached?))
+            (in (get-input-port rest)))
+        (with-input-from-port in
+          (cut packer 'skip)))))
 
+)
\ No newline at end of file