adding version of define-binary-record-type that works with chicken

lib/chibi/binary-record-chicken.scm

@@ -0,0 +1,52 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; binary records, simpler version with type-checking on set! removed
+
+(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) ...))
+     (begin
+       (define-record-type n (m field ...) p
+         (field getter . s) ...)
+       (define n 'n)  ; chicken define-record-type doesn't define the rtd
+       (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) ...)))))
+    ((defrec ((make: x) . rest) n m p r w b f)
+     (defrec rest n x p r w b f))
+    ((defrec ((pred: x) . rest) n m p r w b f)
+     (defrec rest n m x r w b f))
+    ((defrec ((read: x) . rest) n m p r w b f)
+     (defrec rest n m p x w b f))
+    ((defrec ((write: x) . rest) n m p r w b f)
+     (defrec rest n m p r x b f))
+    ((defrec ((block: (field (type . args) getter . s) . fields) . rest) n m p r w
+       (b ...) (f ...))
+     (defrec ((block: . fields) . rest) n m p r w
+       (b ...
+          (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter))
+       (f ...
+          (field getter . s))))
+    ((defrec ((block: (field . x)) . rest) n m p r w b f)
+     (syntax-error "invalid field in block" (field . x)))
+    ((defrec ((block: data . fields) . rest) n m p r w (b ...) f)
+     (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))
+    ((defrec ((block:) . rest) n m p r w b f)
+     (defrec rest n m p r w b f))
+    ))
+
+(define-syntax define-binary-record-type
+  (syntax-rules ()
+    ((define-binary-record-type name x ...)
+     (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
+       () ()))))

lib/chibi/binary-record.scm

@@ -1,187 +1,13 @@
 
-(define (read-u16/be in)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  (let* ((i (read-u8 in))
+;; binary records
-         (j (read-u8 in)))
-    (if (eof-object? j)
-        (error "end of input")
-        (+ (arithmetic-shift i 8) j))))
-
-(define (read-u16/le in)
-  (let* ((i (read-u8 in))
-         (j (read-u8 in)))
-    (if (eof-object? j)
-        (error "end of input")
-        (+ (arithmetic-shift j 8) i))))
-
-;; Record types with user-specified binary formats.
-;; A work in progress, but sufficient for tar files.
-
-(define (assert-read-u8 in i)
-  (let ((i2 (read-u8 in)))
-    (if (not (eqv? 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 "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 "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 "unmatched value, expected: " bv " but got: " bv2)
-        bv2)))
-
-(define (assert-read-integer in len radix)
-  (let* ((s (string-trim (read-string len in)
-                         (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null)))))
-         (n (if (equal? s "") 0 (string->number s radix))))
-    (or n (error "invalid number syntax: " s))))
-
-(define (read-padded-string in len pad)
-  (string-trim-right (read-string len in) pad))
-
-(define (read-literal val)
-  (cond
-   ((integer? val) (lambda (in) (assert-read-u8 in val)))
-   ((char? val) (lambda (in) (assert-read-char in val)))
-   ((string? val) (lambda (in) (assert-read-string in val)))
-   ((bytevector? val) (lambda (in) (assert-read-bytevector in val)))
-   (else (error "unknown binary literal: " val))))
-
-(define (write-literal val)
-  (cond
-   ((integer? val) (lambda (x out) (write-u8 val out)))
-   ((char? val) (lambda (x out) (write-char val out)))
-   ((string? val) (lambda (x out) (write-string val out)))
-   ((bytevector? val) (lambda (x out) (write-bytevector val out)))
-   (else (error "unknown binary literal: " val))))
-
-(define (string-pad-left str len . o)
-  (let ((diff (- len (string-length str)))
-        (pad-ch (if (pair? o) (car o) #\space)))
-    (if (positive? diff)
-        (string-append (make-string diff pad-ch) str)
-        str)))
-
-(define (string-pad-right str len . o)
-  (let ((diff (- len (string-length str)))
-        (pad-ch (if (pair? o) (car o) #\space)))
-    (if (positive? diff)
-        (string-append str (make-string diff pad-ch))
-        str)))
-
-(define (write-padded-integer out n radix len left-pad-ch right-pad-ch)
-  (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch)))
-    (cond
-     ((>= (string-length s) len)
-      (error "number too large for width" n radix len))
-     (else
-      (write-string s out)
-      (write-char right-pad-ch out)))))
-
-(define (write-u16/be n out)
-  (write-u8 (arithmetic-shift n -8) out)
-  (write-u8 (bitwise-and n #xFF) out))
-
-(define (write-u16/le n out)
-  (write-u8 (bitwise-and n #xFF) out)
-  (write-u8 (arithmetic-shift n -8) out))
-
-(define-syntax define-binary-type
-  (syntax-rules ()
-    ((define-binary-type name gen-pred gen-read gen-write)
-     (define-syntax name
-       (syntax-rules (predicate reader writer)
-         ((name predicate args) (gen-pred args))
-         ((name reader args) (gen-read args))
-         ((name writer args) (gen-write args)))))))
-
-(define-binary-type u8
-  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 255))))
-  (lambda (args) read-u8)
-  (lambda (args) write-u8))
-
-(define-binary-type u16/le
-  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
-  (lambda (args) read-u16/le)
-  (lambda (args) write-u16/le))
-
-(define-binary-type u16/be
-  (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
-  (lambda (args) read-u16/be)
-  (lambda (args) write-u16/be))
-
-(define-binary-type padded-string
-  (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-binary-type fixed-string
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (x) (and (string? x) (= (string-length x) len)))))
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (in)
-        (read-string len in))))
-  (lambda (args)
-    (lambda (str out)
-      (write-string str out))))
-
-(define-binary-type octal
-  (lambda (args) exact-integer?)
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (in) (assert-read-integer in len 8))))
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (n out)
-        (write-padded-integer out n 8 len #\0 #\null)))))
-
-(define-binary-type decimal
-  (lambda (args) exact-integer?)
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (in) (assert-read-integer in len 10))))
-  (lambda (args)
-    (let ((len (car args)))
-      (lambda (n out)
-        (write-padded-integer out n 10 len #\0 #\null)))))
-
-(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)
+  (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 ...))
+       ((def setter val) ...))
      (begin
        (define-record-type n (m field ...) p
          (field getter . s) ...)
@@ -194,46 +20,68 @@
          (let ((field-write field-write-expr) ...)
            (lambda (x out)
              (field-write (field-get x) out) ...)))
-       defs ...))
+       (def setter val) ...)
-    ((defrec ((make x) . rest) n m p r w b f s)
+     ;; workaround for impls which strip hygiene from top-level defs
+     ;; for some reason, works in chicken but not across libraries
+     ;;
+     ;; (begin
+     ;;   (define-values (n m p getter ... setter ...)
+     ;;     (let ()
+     ;;       (define-record-type n (m field ...) p
+     ;;         (field getter . s) ...)
+     ;;       (def setter val) ...
+     ;;       (values (record-rtd n) m p getter ... setter ...)))
+     ;;   (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) ...))))
+     )
+    ((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 ((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 ((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 ((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
+    ((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s)
+     (defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s))
+    ((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w
        (b ...) (f ...) (s ...))
-     (defrec ((block . fields) . rest) n m p r w
+     (defrec ((block: . fields) . rest) n m p r w
        (b ...
-          (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
+          (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter))
        (f ...
           (field getter tmp-setter))
        (s ...
           (define setter
-            (let ((pred? (type predicate 'args)))
+            (let ((pred? (type pred: '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
+    ((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
+     (defrec ((block: . fields) . rest) n m p r w
        (b ...
-          (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
+          (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter))
        (f ...
           (field getter))
        s))
-    ((defrec ((block (field . x)) . rest) n m p r w b f 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: data . fields) . rest) n m p r w (b ...) f s)
-     (defrec ((block . fields) . rest) n m p r w
+     (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 ((block:) . rest) n m p r w b f s)
      (defrec rest n m p r w b f s))
     ))
 

lib/chibi/binary-record.sld

@@ -1,12 +1,25 @@
 
 (define-library (chibi binary-record)
-  (import (scheme base)
+  (import (scheme base) (srfi 1))
-          (srfi 1)
-          (chibi string))
   (cond-expand
    ((library (srfi 33)) (import (srfi 33)))
    (else (import (srfi 60))))
-  (export define-binary-record-type
+  (cond-expand
+   ((library (srfi 130)) (import (srfi 130)))
+   (else (import (srfi 13))))
+  (export
+   ;; interface
+   define-binary-record-type
+   ;; binary types
    u8 u16/le u16/be padded-string fixed-string
-          octal decimal hexadecimal)
+   octal decimal hexadecimal
-  (include "binary-record.scm"))
+   ;; auxiliary syntax
+   make: pred: read: write: block:
+   ;; indirect exports
+   define-binary-type defrec define-auxiliary-syntax)
+  (include "binary-types.scm")
+  (cond-expand
+   (chicken
+    (include "binary-record-chicken.scm"))
+   (else
+    (include "binary-record.scm"))))

lib/chibi/tar-test.sld

@@ -40,10 +40,17 @@
           (test 501 (tar-uid x))
           (test "bob" (tar-owner x)))
         (let ((x (make-tar "bar" #o644 501 502 123 456 "0")))
-          (tar-owner-set! x "john")
+          (test "foof" (tar-owner x))
-          (tar-group-set! x "john")
+          (test "nobody" (tar-group x))
           (test "bar" (tar-path x))
-          (test-error (tar-mode-set! x "r"))
+          (test "" (tar-path-prefix x))
+          (tar-owner-set! x "john")
+          (tar-group-set! x "smith")
+          (test "john" (tar-owner x))
+          (test "smith" (tar-group x))
+          (test "bar" (tar-path x))
+          (test "" (tar-path-prefix x))
+          ;;(test-error (tar-mode-set! x "r"))
           (let ((out (open-output-bytevector)))
             (write-tar x out)
             (let ((bv2 (get-output-bytevector out)))

lib/chibi/tar.scm

@@ -1,10 +1,10 @@
 
 (define-binary-record-type tar
-  (make make-tar/full)
+  (make: make-tar/full)
-  (pred tar?)
+  (pred: tar?)
-  (read read-tar)
+  (read: read-tar)
-  (write write-tar/raw)
+  (write: write-tar/raw)
-  (block
+  (block:
    (path (padded-string 100) tar-path-raw tar-path-raw-set!)
    (mode (octal 8) tar-mode tar-mode-set!)
    (uid (octal 8) tar-uid tar-uid-set!)
@@ -72,7 +72,8 @@
   (let* ((path (tar-normalize-path path (equal? "5" (tar-type tar))))
          (len (string-length path)))
     (cond ((< len 100)
-           (tar-path-raw-set! tar path))
+           (tar-path-raw-set! tar path)
+           (tar-path-prefix-set! tar ""))
           ((< len 255)
            (tar-path-raw-set! tar (substring path (- len 100)))
            (tar-path-prefix-set! tar (substring path 0 (- len 100))))

lib/chibi/tar.sld

@@ -1,6 +1,6 @@
 
 (define-library (chibi tar)
-  (import (scheme base) (scheme file) (scheme time) (srfi 1)
+  (import (scheme base) (scheme file) (scheme time) (srfi 1) (scheme write)
           (chibi string) (chibi binary-record) (chibi pathname)
           (chibi filesystem))
   (cond-expand
@@ -14,15 +14,15 @@
    (chicken
     (import posix)
     (begin
-      (define user-name car)
+      (define (user-name x) (if (pair? x) (car x) "nobody"))
-      (define group-name car))))
+      (define (group-name x) (if (pair? x) (car x) "nobody")))))
   (export
    ;; basic
    tar make-tar tar? read-tar write-tar
    ;; utilities
    tar-safe? tar-files tar-fold tar-extract tar-extract-file tar-create
    ;; accessors
-   tar-path tar-mode tar-uid tar-gid
+   tar-path tar-path-prefix tar-mode tar-uid tar-gid
    tar-owner tar-group tar-size
    tar-time tar-type tar-link-name
    tar-path-set! tar-mode-set! tar-uid-set! tar-gid-set!