From d0040a169db9f4d7087d3f86264836912fc6b476 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Thu, 10 Aug 2017 15:07:20 +0100
Subject: [PATCH] [functional tests] more work on the binary-format macro

---
 functional-tests/binary-format.scm    | 61 +++++++++++++++++----------
 functional-tests/btree.scm            | 12 +++---
 functional-tests/check-superblock.scm | 17 ++++----
 functional-tests/list-utils.scm       |  7 ++-
 4 files changed, 59 insertions(+), 38 deletions(-)

diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
index 95c18e0..4c67801 100644
--- a/functional-tests/binary-format.scm
+++ b/functional-tests/binary-format.scm
@@ -1,7 +1,14 @@
 (library
   (binary-format)
-  (export binary-format)
-  (import (rnrs))
+  (export size-type binary-format le32 le64 bytes)
+  (import (rnrs)
+          (list-utils))
+
+  (define-syntax size-type
+    (syntax-rules (le32 le64 bytes)
+      ((_ le32) 4)
+      ((_ le64) 8)
+      ((_ (bytes count)) count)))
 
   (define-syntax unpack-type
     (syntax-rules (le32 le64 bytes)
@@ -16,26 +23,34 @@
         (bytevector-copy! bv offset copy 0 count)
         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
-    (lambda (x)
-      (syntax-case x ()
-                   ((_ (name pack-name unpack-name) (field type) ...)
-                    (with-syntax ((((t o) ...)
-                                   (let f ((acc 0) (types #'(type ...)))
-                                    (if (null? types)
-                                        '()
-                                        (cons (list (car types) acc)
-                                              (f (+ (syntax->datum (size-type (car types))) acc) (cdr types)))))))
-                                 #`(begin
-                                     (define-record-type name (fields field ...))
+    (syntax-rules ()
+      ((_ (name pack-name unpack-name) (field type) ...)
+       (begin
+         (define-record-type name (fields field ...))
+
+       (define (unpack-name bv offset)
+         (let ((offset offset))
+
+          (define (inc-offset n v)
+            (set! offset (+ offset n))
+            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) ...)))))))))
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index bd39de0..78a61bd 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -3,7 +3,8 @@
 
   (export btree-open
           btree-lookup
-          btree-each)
+          btree-each
+          le64-type)
 
   (import (block-io)
           (chezscheme)
@@ -68,16 +69,15 @@
   ;;; Performs a binary search looking for the key and returns the index of the
   ;;; lower bound.
   (define (lower-bound node header key)
-    (let ((nr-entries (node-header-nr-entries header)))
-     (let loop ((lo 0) (hi nr-entries))
-      (if (= 1 (- hi lo))
+    (let loop ((lo 0) (hi (node-header-nr-entries header)))
+      (if (<= (- hi lo) 1)
           lo
           (let* ((mid (+ lo (/ (- hi lo) 2)))
-                 (k (key-at mid)))
+                 (k (key-at node mid)))
             (cond
               ((= key k) mid)
               ((< k key) (loop mid hi))
-              (else (loop lo mid))))))))
+              (else (loop lo mid)))))))
 
   ;;;;----------------------------------------------
   ;;;; Lookup
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index e3cccb8..d6e1437 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -1,20 +1,21 @@
 (import
+  (binary-format)
   (block-io)
   (fmt fmt)
-  (matchable))
+  (matchable)
+  (rnrs))
 
 ;;;;---------------------------------------------------
 ;;;; Constants
 ;;;;---------------------------------------------------
 
 ;; FIXME: duplicate with main.scm
-(define (current-metadata)
-  "./metadata.bin")
+(define (current-metadata) "./metadata.bin")
 
-(define superblock-magic 27022010)
-(define superblock-salt 160774)
-(define uuid-size 16)
-(define space-map-root-size 128)
+(define $superblock-magic 27022010)
+(define $superblock-salt 160774)
+(define $uuid-size 16)
+(define $space-map-root-size 128)
 
 (binary-format (superblock pack-superblock unpack-superblock)
   (csum le32)
@@ -54,5 +55,5 @@
   (with-metadata (md (current-metadata))
                  (let ((superblock (read-block md 0)))
                   (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))))
diff --git a/functional-tests/list-utils.scm b/functional-tests/list-utils.scm
index a4b8d1e..3f7bdb0 100644
--- a/functional-tests/list-utils.scm
+++ b/functional-tests/list-utils.scm
@@ -1,8 +1,13 @@
 (library
   (list-utils)
-  (export intersperse iterate accumulate)
+  (export tails intersperse iterate accumulate)
   (import (rnrs))
 
+  (define (tails xs)
+    (if (null? xs)
+        '()
+        (cons xs (tails (cdr xs)))))
+
   (define (intersperse sep xs)
     (cond
       ((null? xs) '())