converting (chibi binary-record) to pure syntax-rules

lib/chibi/binary-record.scm

@@ -19,25 +19,25 @@
 (define (assert-read-u8 in i)
   (let ((i2 (read-u8 in)))
     (if (not (eqv? i i2))
-        (error "unexpected value: " i i2)
+        (error "unmatched value, expected: " i " but got: " i2)
         i2)))
 
 (define (assert-read-char in ch)
   (let ((ch2 (read-char in)))
     (if (not (eqv? ch ch2))
-        (error "unexpected value: " ch ch2)
+        (error "unmatched value, expected: " ch " but got: " ch2)
         ch2)))
 
 (define (assert-read-string in s)
   (let ((s2 (read-string (string-length s) in)))
     (if (not (equal? s s2))
-        (error "unexpected value: " s s2)
+        (error "unmatched value, expected: " s " but got: " s2)
         s2)))
 
 (define (assert-read-bytevector in bv)
   (let ((bv2 (read-bytevector (bytevector-length bv) in)))
     (if (not (equal? bv bv2))
-        (error "unexpected value: " bv bv2)
+        (error "unmatched value, expected: " bv " but got: " bv2)
         bv2)))
 
 (define (assert-read-integer in len radix)
@@ -49,36 +49,21 @@
 (define (read-padded-string in len pad)
   (string-trim-right (read-string len in) pad))
 
-(define (expand-read rename in spec)
+(define (read-literal val)
-  (case (car spec)
+  (cond
-    ((literal)
+   ((integer? val) (lambda (in) (assert-read-u8 in val)))
-     (let ((val (cadr spec)))
+   ((char? val) (lambda (in) (assert-read-char in val)))
-       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
+   ((string? val) (lambda (in) (assert-read-string in val)))
-             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
+   ((bytevector? val) (lambda (in) (assert-read-bytevector in val)))
-             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
+   (else (error "unknown binary literal: " val))))
-             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
+
-             (else (error "unknown binary literal: " val)))))
+(define (write-literal val)
-    ((u8)
+  (cond
-     `(,(rename 'read-u8) ,in))
+   ((integer? val) (lambda (x out) (write-u8 val out)))
-    ((u16/be)
+   ((char? val) (lambda (x out) (write-char val out)))
-     `(,(rename 'read-u16/be) ,in))
+   ((string? val) (lambda (x out) (write-string val out)))
-    ((u16/le)
+   ((bytevector? val) (lambda (x out) (write-bytevector val out)))
-     `(,(rename 'read-u16/le) ,in))
+   (else (error "unknown binary literal: " val))))
-    ((octal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
-    ((decimal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
-    ((hexadecimal)
-     `(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
-    ((fixed-string)
-     (let ((len (cadr spec)))
-       `(,(rename 'read-string) ,len ,in)))
-    ((padded-string)
-     (let ((len (cadr spec))
-           (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
-       `(,(rename 'read-padded-string) ,in ,len ,pad)))
-    (else
-     (error "unknown binary format: " spec))))
 
 (define (string-pad-left str len . o)
   (let ((diff (- len (string-length str)))
@@ -111,190 +96,149 @@
   (write-u8 (bitwise-and n #xFF) out)
   (write-u8 (arithmetic-shift n -8) out))
 
-(define (expand-write rename out val spec)
+(define-syntax define-binary-type
-  (let ((_if (rename 'if))
+  (syntax-rules ()
-        (_not (rename 'not))
+    ((define-binary-type name gen-pred gen-read gen-write)
-        (_let (rename 'let))
+     (define-syntax name
-        (_string-length (rename 'string-length))
+       (syntax-rules (predicate reader writer)
-        (_write-string (rename 'write-string))
+         ((name predicate args) (gen-pred args))
-        (_write-bytevector (rename 'write-bytevector))
+         ((name reader args) (gen-read args))
-        (_error (rename 'error))
+         ((name writer args) (gen-write args)))))))
-        (_> (rename '>))
-        (_= (rename '=)))
-    (case (car spec)
-      ((literal)
-       (let ((val (cadr spec)))
-         (cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
-               ((char? val) `(,(rename 'write-char) ,val ,out))
-               ((string? val) `(,_write-string ,val ,out))
-               ((bytevector? val) `(,_write-bytevector ,val ,out))
-               (else (error "unknown binary literal: " val)))))
-      ((u8)
-       `(,(rename 'write-u8) ,val ,out))
-      ((u16/be)
-       `(,(rename 'write-u16/be) ,val ,out))
-      ((u16/le)
-       `(,(rename 'write-u16/le) ,val ,out))
-      ((octal)
-       `(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
-      ((decimal)
-       `(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
-      ((hexadecimal)
-       `(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
-      ((fixed-string)
-       (let ((len (cadr spec)))
-         `(,_if (,_not (,_= ,len (,_string-length ,val)))
-              (,_error "wrong field length: " ,val ,len)
-              (,_write-string ,val ,out))))
-      ((padded-string)
-       (let ((len (cadr spec))
-             (pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
-         `(,_let ((l (,_string-length ,val)))
-            (,_if (,_> l ,len)
-                (,_error "field too large: " ,val ,len)
-                (,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
-                                ,out)))))
-      (else
-       (error "unknown binary format: " spec)))))
 
-(define (expand-assert rename spec x v)
+(define-binary-type u8
-  (let ((_if (rename 'if))
+  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 255))))
-        (_not (rename 'not))
+  (lambda (args) read-u8)
-        (_error (rename 'error))
+  (lambda (args) write-u8))
-        (_integer? (rename 'integer?))
-        (_string? (rename 'string?))
-        (_string-length (rename 'string-length))
-        (_> (rename '>)))
-    (case (car spec)
-      ((literal) #t)
-      ((u8 u16/be u16/le octal decimal hexadecimal)
-       `(,_if (,_not (,_integer? ,v))
-            (,_error "expected an integer" ,v)))
-      ((fixed-string padded-string)
-       (let ((len (cadr spec)))
-         `(,_if (,_not (,_string? ,v))
-              (,_error "expected a string" ,v)
-              (,_if (,_> (,_string-length ,v) ,len)
-                  (,_error "string too long" ,v ,len)))))
-      (else (error "unknown binary format: " spec)))))
 
-(define (expand-default rename spec)
+(define-binary-type u16/le
-  (case (car spec)
+  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
-    ((literal) (cadr spec))
+  (lambda (args) read-u16/le)
-    ((u8 u16/be u16/le octal decimal hexadecimal) 0)
+  (lambda (args) write-u16/le))
-    ((fixed-string) (make-string (cadr spec) #\space))
-    ((padded-string) "")
-    (else (error "unknown binary format: " spec))))
 
-(define (param-ref ls key . o)
+(define-binary-type u16/be
-  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
+  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
+  (lambda (args) read-u16/be)
+  (lambda (args) write-u16/be))
 
-(define (symbol-append a b)
+(define-binary-type padded-string
-  (string->symbol (string-append (symbol->string a) (symbol->string b))))
+  (lambda (args)
+    (let ((len (car args)))
+      (lambda (x) (and (string? x) (<= (string-length x) len)))))
+  (lambda (args)
+    (let ((len (car args))
+          (pad (if (pair? (cdr args)) (cadr args) #\null)))
+      (lambda (in) (read-padded-string in len pad))))
+  (lambda (args)
+    (let ((len (car args))
+          (pad (if (pair? (cdr args)) (cadr args) #\null)))
+      (lambda (str out)
+        (write-string (string-pad-right str len pad) out)))))
 
-(define-record-type Field
+(define-binary-type fixed-string
-  (make-field name get set raw-set spec)
+  (lambda (args)
-  field?
+    (let ((len (car args)))
-  (name field-name)
+      (lambda (x) (and (string? x) (= (string-length x) len)))))
-  (get field-get)
+  (lambda (args)
-  (set field-set)
+    (let ((len (car args)))
-  (raw-set field-raw-set)
+      (lambda (in)
-  (spec field-spec))
+        (read-string len in))))
+  (lambda (args)
+    (lambda (str out)
+      (write-string str out))))
 
-(define (extract-fields type ls)
+(define-binary-type octal
-  (let lp ((ls ls) (res '()))
+  (lambda (args) exact-integer?)
-    (cond
+  (lambda (args)
-     ((null? ls)
+    (let ((len (car args)))
-      (reverse res))
+      (lambda (in) (assert-read-integer in len 8))))
-     ((not (pair? (car ls)))
+  (lambda (args)
-      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
+    (let ((len (car args)))
-     (else
+      (lambda (n out)
-      (let* ((name (caar ls))
+        (write-padded-integer out n 8 len #\0 #\null)))))
-             (get (or (param-ref (car ls) 'getter)
+
-                      (and (not (eq? name '_))
+(define-binary-type decimal
-                           (symbol-append type (symbol-append '- name)))))
+  (lambda (args) exact-integer?)
-             (set (or (param-ref (car ls) 'setter)
+  (lambda (args)
-                      (and (not (eq? name '_))
+    (let ((len (car args)))
-                           (symbol-append (symbol-append type '-)
+      (lambda (in) (assert-read-integer in len 10))))
-                                          (symbol-append name '-set!)))))
+  (lambda (args)
-             (raw-set (and set (symbol-append '% set)))
+    (let ((len (car args)))
-             (spec0 (cadr (car ls)))
+      (lambda (n out)
-             (spec (if (pair? spec0) spec0 (list spec0))))
+        (write-padded-integer out n 10 len #\0 #\null)))))
-        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
+
+(define-binary-type hexadecimal
+  (lambda (args) exact-integer?)
+  (lambda (args)
+    (let ((len (car args)))
+      (lambda (in) (assert-read-integer in len 16))))
+  (lambda (args)
+    (let ((len (car args)))
+      (lambda (n out)
+        (write-padded-integer out n 16 len #\0 #\null)))))
+
+(define-syntax defrec
+  (syntax-rules (make pred read write block)
+    ((defrec () n m p r w
+       ((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
+       ((field getter . s) ...)
+       (defs ...))
+     (begin
+       (define-record-type n (m field ...) p
+         (field getter . s) ...)
+       (define r
+         (let ((field-read field-read-expr) ...)
+           (lambda (in)
+             (let* ((field-tmp (field-read in)) ...)
+               (m field ...)))))
+       (define w
+         (let ((field-write field-write-expr) ...)
+           (lambda (x out)
+             (field-write (field-get x) out) ...)))
+       defs ...))
+    ((defrec ((make x) . rest) n m p r w b f s)
+     (defrec rest n x p r w b f s))
+    ((defrec ((pred x) . rest) n m p r w b f s)
+     (defrec rest n m x r w b f s))
+    ((defrec ((read x) . rest) n m p r w b f s)
+     (defrec rest n m p x w b f s))
+    ((defrec ((write x) . rest) n m p r w b f s)
+     (defrec rest n m p r x b f s))
+    ((defrec ((block (field (type . args) getter setter) . fields) . rest) n m p r w
+       (b ...) (f ...) (s ...))
+     (defrec ((block . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
+       (f ...
+          (field getter tmp-setter))
+       (s ...
+          (define setter
+            (let ((pred? (type predicate 'args)))
+              (lambda (x val)
+                (if (not (pred? val))
+                    (error "invalid val for" 'field val))
+                (tmp-setter x val)))))))
+    ((defrec ((block (field (type . args) getter) . fields) . rest) n m p r w
+       (b ...) (f ...) s)
+     (defrec ((block . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
+       (f ...
+          (field getter))
+       s))
+    ((defrec ((block (field . x)) . rest) n m p r w b f s)
+     (syntax-error "invalid field in block" (field . x)))
+    ((defrec ((block data . fields) . rest) n m p r w (b ...) f s)
+     (defrec ((block . fields) . rest) n m p r w
+       (b ...
+          (tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
+       f
+       s))
+    ((defrec ((block) . rest) n m p r w b f s)
+     (defrec rest n m p r w b f s))
+    ))
 
 (define-syntax define-binary-record-type
-  (er-macro-transformer
+  (syntax-rules ()
-   (lambda (expr rename compare)
+    ((define-binary-record-type name x ...)
-     (let ((name (cadr expr))
+     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
-           (ls (cddr expr)))
+       () () ()))))
-       (if (not (and (identifier? name) (every list? ls)))
-           (error "invalid syntax: " expr))
-       (let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
-              (pred (or (param-ref ls 'predicate) (symbol-append name '?)))
-              (make (or (param-ref ls 'make) (symbol-append 'make- name)))
-              (make-spec (if (pair? make) make (list make)))
-              (%make (rename (symbol-append '% (car make-spec))))
-              (%%make (rename (symbol-append '%% (car make-spec))))
-              (reader (or (param-ref ls 'read) (symbol-append 'read- name)))
-              (writer (or (param-ref ls 'write) (symbol-append 'write- name)))
-              (block (assq 'block ls))
-              (_begin (rename 'begin))
-              (_define (rename 'define))
-              (_define-record-type (rename 'define-record-type))
-              (_let (rename 'let)))
-         (if (not block)
-             (error "missing binary record block: " expr))
-         (let* ((fields (extract-fields name (cdr block)))
-                (named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
-                                      fields)))
-           `(,_begin
-             (,_define ,name ',ls)
-             (,_define-record-type
-              ,type (,%%make) ,pred
-              ,@(map
-                 (lambda (f)
-                   `(,(field-name f) ,(field-get f) ,(field-raw-set f)))
-                 named-fields))
-             ,@(map
-                (lambda (f)
-                  `(,_define (,(field-set f) x v)
-                     ,(expand-assert rename (field-spec f) 'x 'v)
-                     (,(field-raw-set f) x v)))
-                named-fields)
-             (,_define (,%make)
-               (let ((res (,%%make)))
-                 ,@(map
-                    (lambda (f)
-                      `(,(field-raw-set f)
-                        res
-                        ,(expand-default rename (field-spec f))))
-                    named-fields)
-                 res))
-             (,_define ,make-spec
-               (,_let ((res (,%make)))
-                 ,@(map
-                    (lambda (x)
-                      (let ((field (find (lambda (f) (eq? x (field-name f)))
-                                         fields)))
-                        `(,(field-set field) res ,x)))
-                    (cdr make-spec))
-                 res))
-             (,_define (,reader in)
-               (,_let ((res (,%make)))
-                 ,@(map
-                    (lambda (f)
-                      (if (eq? '_ (field-name f))
-                          (expand-read rename 'in (field-spec f))
-                          `(,(field-set f)
-                            res
-                            ,(expand-read rename 'in (field-spec f)))))
-                    fields)
-                 res))
-             (,_define (,writer x out)
-               ,@(map
-                  (lambda (f)
-                    (expand-write rename
-                                  'out
-                                  `(,(field-get f) x)
-                                  (field-spec f)))
-                  fields)))))))))

lib/chibi/binary-record.sld

@@ -6,16 +6,7 @@
   (cond-expand
    ((library (srfi 33)) (import (srfi 33)))
    (else (import (srfi 60))))
-  (cond-expand
+  (export define-binary-record-type
-   (chibi
+          u8 u16/le u16/be padded-string fixed-string
-    (import (only (chibi) identifier? er-macro-transformer)))
+          octal decimal hexadecimal)
-   (chicken
-    (import chicken)
-    (begin
-      (define identifier? symbol?)))
-   (sagittarius
-    (import (sagittarius))
-    (begin
-      (define identifier? symbol?))))
-  (export define-binary-record-type)
   (include "binary-record.scm"))

lib/chibi/tar-test.sld

@@ -39,14 +39,7 @@
           (test "foo" (tar-path x))
           (test 501 (tar-uid x))
           (test "bob" (tar-owner x)))
-        (let ((x (make-tar)))
+        (let ((x (make-tar "bar" #o644 501 502 123 456 "0")))
-          (tar-path-set! x "bar")
-          (tar-mode-set! x #o644)
-          (tar-uid-set! x 501)
-          (tar-gid-set! x 502)
-          (tar-size-set! x 123)
-          (tar-time-set! x 456)
-          (tar-ustar-set! x "ustar")
           (tar-owner-set! x "john")
           (tar-group-set! x "john")
           (test "bar" (tar-path x))

lib/chibi/tar.scm

@@ -1,52 +1,75 @@
+
 (define-binary-record-type tar
-  (make (make-tar))
+  (make make-tar/full)
-  (write write-tar-raw)
+  (pred tar?)
+  (read read-tar)
+  (write write-tar/raw)
   (block
-   (path (padded-string 100) (getter tar-path-raw) (setter tar-path-raw-set!))
+   (path (padded-string 100) tar-path-raw tar-path-raw-set!)
-   (mode (octal 8))
+   (mode (octal 8) tar-mode tar-mode-set!)
-   (uid (octal 8))
+   (uid (octal 8) tar-uid tar-uid-set!)
-   (gid (octal 8))
+   (gid (octal 8) tar-gid tar-gid-set!)
-   (size (octal 12))
+   (size (octal 12) tar-size tar-size-set!)
-   (time (octal 12))
+   (time (octal 12) tar-time tar-time-set!)
-   (checksum (octal 8))
+   (checksum (octal 8) tar-checksum tar-checksum-set!)
-   (type (fixed-string 1))
+   (type (fixed-string 1) tar-type tar-type-set!)
-   (link-name (padded-string 100))
+   (link-name (padded-string 100) tar-link-name tar-link-name-set!)
-   (ustar (padded-string 6))
+   (ustar (padded-string 6) tar-ustar tar-ustar-set!)
-   (ustar-version (padded-string 2))
+   (ustar-version (padded-string 2) tar-ustar-version)
-   (owner (padded-string 32))
+   (owner (padded-string 32) tar-owner tar-owner-set!)
-   (group (padded-string 32))
+   (group (padded-string 32) tar-group tar-group-set!)
-   (device-major (octal 8))
+   (device-major (octal 8) tar-device-major tar-device-major-set!)
-   (device-minor (octal 8))
+   (device-minor (octal 8) tar-device-minor tar-device-minor-set!)
-   (path-prefix (padded-string 155))
+   (path-prefix (padded-string 155) tar-path-prefix tar-path-prefix-set!)
    #u8(0 0 0 0 0 0 0 0 0 0 0 0)))
 
+(define (file-owner-or-nobody uid)
+  (or (user-name (user-information uid)) "nobody"))
+(define (file-group-or-nobody gid)
+  (or (group-name (group-information gid)) "nobody"))
+
+(define (make-tar file mode uid gid size mod-time type . o)
+  (let* ((link (if (pair? o) (car o) ""))
+         (raw-path (tar-normalize-path file (equal? "5" type)))
+         (len (string-length raw-path))
+         (path
+          (if (< len 100) raw-path (substring raw-path (- len 100))))
+         (path-prefix
+          (if (< len 100) "" (substring raw-path 0 (- len 100)))))
+    (if (>= len 255)
+        (error "path name too long" raw-path))
+    (make-tar/full path (bitwise-and #o7777 mode) uid gid size
+                   mod-time 0 type link "ustar" "00"
+                   (file-owner-or-nobody uid) (file-group-or-nobody gid)
+                   0 0 path-prefix)))
+
 (define (tar-compute-checksum tar)
-  (let ((tmp (open-output-bytevector)))
+  (let ((tmp-out (open-output-bytevector)))
-    (write-tar-raw tar tmp)
+    (write-tar/raw tar tmp-out)
-    (let ((bv (get-output-bytevector tmp)))
+    (let ((bv (get-output-bytevector tmp-out)))
-      (do ((i 0 (+ i 1))) ((= i 8))
-        (bytevector-u8-set! bv (+ i 148) 32))
       (do ((i 0 (+ i 1))
-           (sum 0 (+ sum (bytevector-u8-ref bv i))))
+           (sum 0 (+ sum (if (<= 148 i 155)  ; checksum itself is spaces
+                             32
+                             (bytevector-u8-ref bv i)))))
           ((= i 512) sum)))))
 
 ;; wrap the writer to automatically compute the checksum
 (define (write-tar tar out)
   (tar-checksum-set! tar (tar-compute-checksum tar))
-  (write-tar-raw tar out))
+  (write-tar/raw tar out))
 
 ;; wrap the path to use the prefix
 (define (tar-path tar)
   (string-append (tar-path-prefix tar) (tar-path-raw tar)))
 
-(define (tar-normalize-path tar path)
+(define (tar-normalize-path path . o)
   (cond ((string-suffix? "/." path) (string-trim-right path #\.))
-        ((and (not (string-suffix? "/" path)) (equal? "5" (tar-type tar)))
+        ((and (not (string-suffix? "/" path)) (and (pair? o) (car o)))
          (string-append path "/"))
         (else path)))
 
 (define (tar-path-set! tar path)
-  (let* ((path (tar-normalize-path tar path))
+  (let* ((path (tar-normalize-path path (equal? "5" (tar-type tar))))
          (len (string-length path)))
     (cond ((< len 100)
            (tar-path-raw-set! tar path))
@@ -147,50 +170,30 @@
       (lambda (tar bv) (if (equal? (tar-path tar) file) (return bv))))
      #f)))
 
-(define (file-owner-or-nobody st)
-  (or (user-name (user-information (file-owner st))) "nobody"))
-(define (file-group-or-nobody st)
-  (or (group-name (group-information (file-group st))) "nobody"))
-
 (define (file->tar file)
-  (let ((tar (make-tar))
+  (let* ((st (file-link-status file))
-        (st (file-link-status file)))
+         (type (cond ((file-link? st) "2")
-    (tar-path-set! tar file)
+                     ((file-character? st) "3")
-    (tar-ustar-set! tar "ustar")
+                     ((file-block? st) "4")
-    (tar-ustar-version-set! tar "00")
+                     ((file-directory? st) "5")
-    (cond
+                     (else "0"))))
-     (st
+    (make-tar file
-      (tar-mode-set! tar (bitwise-and #o7777 (file-mode st)))
+              (file-mode st)
-      (tar-uid-set! tar (file-owner st))
+              (file-owner st)
-      (tar-gid-set! tar (file-group st))
+              (file-group st)
-      (tar-owner-set! tar (file-owner-or-nobody st))
+              (if (equal? "0" type) (file-size st) 0)
-      (tar-group-set! tar (file-group-or-nobody st))
+              (file-modification-time st)
-      (tar-time-set! tar (file-modification-time st))
+              type
-      (tar-type-set! tar (cond ((file-link? st) "2")
+              (if (file-link? st) (read-link file) ""))))
-                               ((file-character? st) "3")
-                               ((file-block? st) "4")
-                               ((file-directory? st) "5")
-                               (else "0")))
-      (if (equal? "0" (tar-type tar))
-          (tar-size-set! tar (file-size st)))
-      (if (file-link? st)
-          (tar-link-name-set! tar (read-link file)))))
-    tar))
 
 (define (inline->tar file content . o)
-  (let ((tar (make-tar)))
+  (make-tar file
-    (tar-path-set! tar file)
+            (if (pair? o) (car o) #o644)
-    (tar-ustar-set! tar "ustar")
+            (current-user-id)
-    (tar-ustar-version-set! tar "00")
+            (current-group-id)
-    (tar-mode-set! tar (if (pair? o) (car o) #o644))
+            (bytevector-length content)
-    (tar-uid-set! tar (current-user-id))
+            (exact (round (current-second)))
-    (tar-gid-set! tar (current-group-id))
+            "0"))
-    (tar-owner-set! tar (user-name (user-information (current-user-id))))
-    (tar-group-set! tar (group-name (group-information (current-group-id))))
-    (tar-time-set! tar (exact (round (current-second))))
-    (tar-type-set! tar "0")
-    (tar-size-set! tar (bytevector-length content))
-    tar))
 
 (define (tar-add-directories tar out acc)
   (let lp ((dir (path-directory (tar-path tar))) (acc acc))
@@ -200,18 +203,13 @@
        ((assoc dir/ acc) (lp (path-directory dir) acc))
        (else
         (let ((acc (lp (path-directory dir) (cons (cons dir/ #f) acc))))
-          (let ((tar2 (make-tar)))
+          (let ((tar2 (make-tar dir/
-            (tar-path-set! tar2 dir/)
+                                (bitwise-ior #o111 (tar-mode tar))
-            (tar-ustar-set! tar2 "ustar")
+                                (tar-uid tar)
-            (tar-ustar-version-set! tar2 "00")
+                                (tar-gid tar)
-            (tar-mode-set! tar2 (bitwise-ior #o111 (tar-mode tar) ))
+                                0
-            (tar-uid-set! tar2 (tar-uid tar))
+                                (tar-time tar)
-            (tar-gid-set! tar2 (tar-gid tar))
+                                "5")))
-            (tar-owner-set! tar2 (tar-owner tar))
-            (tar-group-set! tar2 (tar-group tar))
-            (tar-time-set! tar2 (tar-time tar))
-            (tar-type-set! tar2 "5")
-            (tar-size-set! tar2 0)
             (write-tar tar2 out)
             acc)))))))