From b2355df7198fc4bfe06c785cebd43fd73d44a967 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Sat, 12 Aug 2017 19:27:21 +0100
Subject: [PATCH] [functional tests] we can now walk both levels of the mapping
 tree.

---
 functional-tests/binary-format.scm    | 20 ++++++++++----------
 functional-tests/btree.scm            |  4 ++--
 functional-tests/check-superblock.scm |  3 ++-
 functional-tests/mapping-tree.scm     | 14 +++++++++++---
 4 files changed, 25 insertions(+), 16 deletions(-)

diff --git a/functional-tests/binary-format.scm b/functional-tests/binary-format.scm
index be1611a..e36a787 100644
--- a/functional-tests/binary-format.scm
+++ b/functional-tests/binary-format.scm
@@ -43,16 +43,16 @@
          #,gens)))))
 |#
 
-(define-syntax ordered-funcall
-  (lambda (x)
-    (syntax-case x ()
-       ((k f v ...)
-        (with-syntax
-          ([(t ...) (map (lambda (_)
-                           (datum->syntax #'k (gensym)))
-                         #'(v ...))])
-          #'(let* ([t v] ...)
-              (f t ...)))))))
+  (define-syntax ordered-funcall
+    (lambda (x)
+      (syntax-case x ()
+        ((k f v ...)
+         (with-syntax
+           ([(t ...) (map (lambda (_)
+                            (datum->syntax #'k (gensym)))
+                          #'(v ...))])
+           #'(let* ([t v] ...)
+               (f t ...)))))))
 
   (define-syntax binary-format-names
     (syntax-rules ()
diff --git a/functional-tests/btree.scm b/functional-tests/btree.scm
index 052bc5b..e2c0f26 100644
--- a/functional-tests/btree.scm
+++ b/functional-tests/btree.scm
@@ -57,10 +57,10 @@
                        (unpack-type bv offset le64))))
 
   (define (internal-node? header)
-    (bitwise-bit-set? 0 (node-header-flags header)))
+    (bitwise-bit-set? (node-header-flags header) 0))
 
   (define (leaf-node? header)
-    (bitwise-bit-set? 1 (node-header-flags header)))
+    (bitwise-bit-set? (node-header-flags header) 1))
 
   (define (key-at node index)
     (unpack-type node (key-offset index) le64))
diff --git a/functional-tests/check-superblock.scm b/functional-tests/check-superblock.scm
index b8b6779..f2707a5 100644
--- a/functional-tests/check-superblock.scm
+++ b/functional-tests/check-superblock.scm
@@ -73,11 +73,12 @@
                  (let ((sb (superblock-unpack (read-block md 0) 0)))
                   (let ((mappings (mapping-tree-open md (superblock-data-mapping-root sb))))
                    (mapping-tree-each mappings
-                                      (lambda (dev-id vblock pblock)
+                                      (lambda (dev-id vblock pblock time)
                                         (fmt #t
                                              (dsp "thin dev ") (num dev-id)
                                              (dsp ", vblock ") (num vblock)
                                              (dsp ", pblock ") (num pblock)
+                                             (dsp ", time ") (num time)
                                              nl)))))))
 
 (define (check-superblock)
diff --git a/functional-tests/mapping-tree.scm b/functional-tests/mapping-tree.scm
index 229acdd..1f28e7a 100644
--- a/functional-tests/mapping-tree.scm
+++ b/functional-tests/mapping-tree.scm
@@ -7,7 +7,8 @@
 
   (import (btree)
           (chezscheme)
-          (binary-format))
+          (binary-format)
+          (srfi s8 receive))
 
   (define-record-type mapping-tree (fields dev-tree))
 
@@ -22,13 +23,20 @@
          default
          (btree-lookup (btree-open le64-type (btree-dev dev-tree) root2) vblock default))))
 
-  ;;; Visits every entry in the mapping tree calling (fn dev-id vblock mapping).
+  ;; (values <block> <time>)
+  (define time-mask (- (fxsll 1 24) 1))
+
+  (define (unpack-block-time bt)
+    (values (fxsrl bt 24) (fxlogand bt time-mask)))
+
+  ;;; Visits every entry in the mapping tree calling (fn dev-id vblock pblock time).
   (define (mapping-tree-each mtree fn)
     (let ((dev-tree (mapping-tree-dev-tree mtree)))
 
      (define (visit-dev dev-id mapping-root)
        (btree-each (btree-open le64-type (btree-dev dev-tree) mapping-root)
                    (lambda (vblock mapping)
-                     (fn dev-id vblock mapping))))
+                     (receive (block time) (unpack-block-time mapping)
+                              (fn dev-id vblock block time)))))
 
      (btree-each dev-tree visit-dev))))