mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
244 lines
8 KiB
Scheme
244 lines
8 KiB
Scheme
|
|
(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 "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)
|
|
((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
|
|
(syntax-rules ()
|
|
((define-binary-record-type name x ...)
|
|
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
|
() () ()))))
|