mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
300 lines
11 KiB
Scheme
300 lines
11 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 "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)))))))))
|