(define (read-u16/be in)
  (let* ((i (read-u8 in))
         (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 "unexpected value: " i i2)
        i2)))

(define (assert-read-char in ch)
  (let ((ch2 (read-char in)))
    (if (not (eqv? ch ch2))
        (error "unexpected value: " ch 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)
        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)
        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 (expand-read rename in spec)
  (case (car spec)
    ((literal)
     (let ((val (cadr spec)))
       (cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
             ((char? val) `(,(rename 'assert-read-char) ,in ,val))
             ((string? val) `(,(rename 'assert-read-string) ,in ,val))
             ((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
             (else (error "unknown binary literal: " val)))))
    ((u8)
     `(,(rename 'read-u8) ,in))
    ((u16/be)
     `(,(rename 'read-u16/be) ,in))
    ((u16/le)
     `(,(rename 'read-u16/le) ,in))
    ((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)))
        (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 (expand-write rename out val spec)
  (let ((_if (rename 'if))
        (_not (rename 'not))
        (_let (rename 'let))
        (_string-length (rename 'string-length))
        (_write-string (rename 'write-string))
        (_write-bytevector (rename 'write-bytevector))
        (_error (rename 'error))
        (_> (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)
  (let ((_if (rename 'if))
        (_not (rename 'not))
        (_error (rename 'error))
        (_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)
  (case (car spec)
    ((literal) (cadr spec))
    ((u8 u16/be u16/le octal decimal hexadecimal) 0)
    ((fixed-string) (make-string (cadr spec) #\space))
    ((padded-string) "")
    (else (error "unknown binary format: " spec))))

(define (param-ref ls key . o)
  (cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))

(define (symbol-append a b)
  (string->symbol (string-append (symbol->string a) (symbol->string b))))

(define-record-type Field
  (make-field name get set raw-set spec)
  field?
  (name field-name)
  (get field-get)
  (set field-set)
  (raw-set field-raw-set)
  (spec field-spec))

(define (extract-fields type ls)
  (let lp ((ls ls) (res '()))
    (cond
     ((null? ls)
      (reverse res))
     ((not (pair? (car ls)))
      (lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
     (else
      (let* ((name (caar ls))
             (get (or (param-ref (car ls) 'getter)
                      (and (not (eq? name '_))
                           (symbol-append type (symbol-append '- name)))))
             (set (or (param-ref (car ls) 'setter)
                      (and (not (eq? name '_))
                           (symbol-append (symbol-append type '-)
                                          (symbol-append name '-set!)))))
             (raw-set (and set (symbol-append '% set)))
             (spec0 (cadr (car ls)))
             (spec (if (pair? spec0) spec0 (list spec0))))
        (lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))

(define-syntax define-binary-record-type
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((name (cadr expr))
           (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)))))))))