From 526b71d5fed2f6a79c41fe482a578a8634a0345a Mon Sep 17 00:00:00 2001
From: Thomas Bauereiss
Date: Sat, 12 May 2018 11:16:27 +0100
Subject: Fix bug in handling of registers with option type

Also add test cases and Isabelle lemmas
---
 src/state.ml                        | 15 ++++++++++++++-
 test/typecheck/pass/reg_list.sail   |  7 +++++++
 test/typecheck/pass/reg_option.sail | 16 ++++++++++++++++
 3 files changed, 37 insertions(+), 1 deletion(-)
 create mode 100644 test/typecheck/pass/reg_list.sail
 create mode 100644 test/typecheck/pass/reg_option.sail

diff --git a/src/state.ml b/src/state.ml
index 5a360456..ab63747c 100644
--- a/src/state.ml
+++ b/src/state.ml
@@ -286,7 +286,7 @@ let register_refs_lem mwords registers =
       "";
       "val option_of_regval : forall 'a. (register_value -> maybe 'a) -> register_value -> maybe (maybe 'a)";
       "let option_of_regval of_regval = function";
-      "  | Regval_option v -> Maybe.map of_regval v";
+      "  | Regval_option v -> Just (Maybe.bind v of_regval)";
       "  | _ -> Nothing";
       "end";
       "";
@@ -388,6 +388,19 @@ let generate_isa_lemmas mwords (Defs defs : tannot defs) =
     "proof -";
     "  from assms have \"of_rv \\<circ> rv_of = Some\" by auto";
     "  then show ?thesis by (auto simp: vector_of_regval_def regval_of_vector_def)";
+    "qed";
+    "";
+    "lemma option_of_rv_rv_of_option[simp]:";
+    "  assumes \"\\<And>v. of_rv (rv_of v) = Some v\"";
+    "  shows \"option_of_regval of_rv (regval_of_option rv_of v) = Some v\"";
+    "  using assms by (cases v) (auto simp: option_of_regval_def regval_of_option_def)";
+    "";
+    "lemma list_of_rv_rv_of_list[simp]:";
+    "  assumes \"\\<And>v. of_rv (rv_of v) = Some v\"";
+    "  shows \"list_of_regval of_rv (regval_of_list rv_of v) = Some v\"";
+    "proof -";
+    "  from assms have \"of_rv \\<circ> rv_of = Some\" by auto";
+    "  with assms show ?thesis by (induction v) (auto simp: list_of_regval_def regval_of_list_def)";
     "qed"] ^^
   hardline ^^ hardline ^^
   separate_map (hardline ^^ hardline) register_lemmas registers
diff --git a/test/typecheck/pass/reg_list.sail b/test/typecheck/pass/reg_list.sail
new file mode 100644
index 00000000..bf776942
--- /dev/null
+++ b/test/typecheck/pass/reg_list.sail
@@ -0,0 +1,7 @@
+register X : list(bool)
+
+val init_X : unit -> unit effect {wreg}
+function init_X () = {
+  X = [||];
+}
+
diff --git a/test/typecheck/pass/reg_option.sail b/test/typecheck/pass/reg_option.sail
new file mode 100644
index 00000000..55317d1f
--- /dev/null
+++ b/test/typecheck/pass/reg_option.sail
@@ -0,0 +1,16 @@
+$include <arith.sail>
+$include <flow.sail>
+$include <option.sail>
+
+register X : option(int)
+
+val inc_X : unit -> int effect {rreg, wreg}
+function inc_X () = {
+  let x : int = match X {
+    Some(x) => x + 1,
+    None() => 0
+  };
+  X = Some(x);
+  return x;
+}
+
-- 
cgit v1.2.3