[functional tests] more work on the binary-format macro

This commit is contained in:
Joe Thornber 2017-08-10 15:07:20 +01:00
parent 78488e8909
commit d0040a169d
4 changed files with 59 additions and 38 deletions

View File

@ -1,7 +1,14 @@
(library (library
(binary-format) (binary-format)
(export binary-format) (export size-type binary-format le32 le64 bytes)
(import (rnrs)) (import (rnrs)
(list-utils))
(define-syntax size-type
(syntax-rules (le32 le64 bytes)
((_ le32) 4)
((_ le64) 8)
((_ (bytes count)) count)))
(define-syntax unpack-type (define-syntax unpack-type
(syntax-rules (le32 le64 bytes) (syntax-rules (le32 le64 bytes)
@ -16,26 +23,34 @@
(bytevector-copy! bv offset copy 0 count) (bytevector-copy! bv offset copy 0 count)
copy)))) copy))))
(define (size-type t)
(syntax-case t (le32 le64 bytes)
(le32 #'4)
(le64 #'8)
((bytes count) #'count)))
;;; FIXME: (bytes <count>) has to use a literal rather than a symbol.
(define-syntax binary-format (define-syntax binary-format
(lambda (x) (syntax-rules ()
(syntax-case x () ((_ (name pack-name unpack-name) (field type) ...)
((_ (name pack-name unpack-name) (field type) ...) (begin
(with-syntax ((((t o) ...) (define-record-type name (fields field ...))
(let f ((acc 0) (types #'(type ...)))
(if (null? types) (define (unpack-name bv offset)
'() (let ((offset offset))
(cons (list (car types) acc)
(f (+ (syntax->datum (size-type (car types))) acc) (cdr types))))))) (define (inc-offset n v)
#`(begin (set! offset (+ offset n))
(define-record-type name (fields field ...)) v)
((record-constructor (record-constructor-descriptor name))
(inc-offset (size-type type) (unpack-type bv offset type)) ...)))))))
;;; since le32, le64 and bytes are used as auxiliary keywords, we must export
;;; definitions of them as well.
;;; FIXME: use a macro to remove duplication
(define-syntax le32
(lambda (x)
(syntax-violation 'le32 "misplaced auxiliary keyword" x)))
(define-syntax le64
(lambda (x)
(syntax-violation 'le64 "misplaced auxiliary keyword" x)))
(define-syntax bytes
(lambda (x)
(syntax-violation 'bytes "misplaced auxiliary keyword" x))))
(define (unpack-name bv offset)
((record-constructor (record-type-descriptor name))
(unpack-type bv (+ offset o) t) ...)))))))))

View File

@ -3,7 +3,8 @@
(export btree-open (export btree-open
btree-lookup btree-lookup
btree-each) btree-each
le64-type)
(import (block-io) (import (block-io)
(chezscheme) (chezscheme)
@ -68,16 +69,15 @@
;;; Performs a binary search looking for the key and returns the index of the ;;; Performs a binary search looking for the key and returns the index of the
;;; lower bound. ;;; lower bound.
(define (lower-bound node header key) (define (lower-bound node header key)
(let ((nr-entries (node-header-nr-entries header))) (let loop ((lo 0) (hi (node-header-nr-entries header)))
(let loop ((lo 0) (hi nr-entries)) (if (<= (- hi lo) 1)
(if (= 1 (- hi lo))
lo lo
(let* ((mid (+ lo (/ (- hi lo) 2))) (let* ((mid (+ lo (/ (- hi lo) 2)))
(k (key-at mid))) (k (key-at node mid)))
(cond (cond
((= key k) mid) ((= key k) mid)
((< k key) (loop mid hi)) ((< k key) (loop mid hi))
(else (loop lo mid)))))))) (else (loop lo mid)))))))
;;;;---------------------------------------------- ;;;;----------------------------------------------
;;;; Lookup ;;;; Lookup

View File

@ -1,20 +1,21 @@
(import (import
(binary-format)
(block-io) (block-io)
(fmt fmt) (fmt fmt)
(matchable)) (matchable)
(rnrs))
;;;;--------------------------------------------------- ;;;;---------------------------------------------------
;;;; Constants ;;;; Constants
;;;;--------------------------------------------------- ;;;;---------------------------------------------------
;; FIXME: duplicate with main.scm ;; FIXME: duplicate with main.scm
(define (current-metadata) (define (current-metadata) "./metadata.bin")
"./metadata.bin")
(define superblock-magic 27022010) (define $superblock-magic 27022010)
(define superblock-salt 160774) (define $superblock-salt 160774)
(define uuid-size 16) (define $uuid-size 16)
(define space-map-root-size 128) (define $space-map-root-size 128)
(binary-format (superblock pack-superblock unpack-superblock) (binary-format (superblock pack-superblock unpack-superblock)
(csum le32) (csum le32)
@ -54,5 +55,5 @@
(with-metadata (md (current-metadata)) (with-metadata (md (current-metadata))
(let ((superblock (read-block md 0))) (let ((superblock (read-block md 0)))
(fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl) (fmt #t (dsp "checksum on disk: ") (dsp (bytevector-u32-ref superblock 0 (endianness little))) nl)
(fmt #t (dsp "calculated checksum: ") (dsp (crc32-region superblock-salt superblock 4 4092)) nl) ;(fmt #t (dsp "calculated checksum: ") (dsp (crc32-region $superblock-salt superblock 4 4092)) nl)
(check-magic superblock)))) (check-magic superblock))))

View File

@ -1,8 +1,13 @@
(library (library
(list-utils) (list-utils)
(export intersperse iterate accumulate) (export tails intersperse iterate accumulate)
(import (rnrs)) (import (rnrs))
(define (tails xs)
(if (null? xs)
'()
(cons xs (tails (cdr xs)))))
(define (intersperse sep xs) (define (intersperse sep xs)
(cond (cond
((null? xs) '()) ((null? xs) '())