From ccb7dcd52ba9ed5114115acf472dd8de3916b5b2 Mon Sep 17 00:00:00 2001
From: Magnus Myreen <myreen@chalmers.se>
Date: Mon, 9 Dec 2024 12:03:11 +0100
Subject: [PATCH 001/100] First commit towards Scheme-to-CakeML compiler

---
 compiler/README.md                       |   3 +
 compiler/scheme/Holmakefile              |  20 ++++
 compiler/scheme/readmePrefix             |   1 +
 compiler/scheme/scheme_parsingScript.sml |  88 +++++++++++++++
 compiler/scheme/scheme_valuesScript.sml  | 135 +++++++++++++++++++++++
 5 files changed, 247 insertions(+)
 create mode 100644 compiler/scheme/Holmakefile
 create mode 100644 compiler/scheme/readmePrefix
 create mode 100644 compiler/scheme/scheme_parsingScript.sml
 create mode 100644 compiler/scheme/scheme_valuesScript.sml

diff --git a/compiler/README.md b/compiler/README.md
index 0560186d2b..0c0fd093fa 100644
--- a/compiler/README.md
+++ b/compiler/README.md
@@ -46,3 +46,6 @@ Correctness proof for the CakeML compiler.
 [repl](repl):
 Some definitions and proofs used in the proof of the CakeML
 and Candle read-eval-print loop (REPL).
+
+[scheme](scheme):
+A compiler from Scheme to CakeML
diff --git a/compiler/scheme/Holmakefile b/compiler/scheme/Holmakefile
new file mode 100644
index 0000000000..c40a5047ed
--- /dev/null
+++ b/compiler/scheme/Holmakefile
@@ -0,0 +1,20 @@
+INCLUDES = $(CAKEMLDIR)/translator \
+           $(CAKEMLDIR)/basis \
+           $(CAKEMLDIR)/basis/pure \
+           $(CAKEMLDIR)/compiler/parsing \
+           $(CAKEMLDIR)/semantics \
+           $(CAKEMLDIR)/misc \
+           $(HOLDIR)/examples/formal-languages/context-free
+
+all: $(DEFAULT_TARGETS) README.md
+.PHONY: all
+
+README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
+# Filter out tests/ (they don't have a readmePrefix)
+DIRS = $(patsubst tests/,,$(wildcard */))
+README.md: $(CAKEMLDIR)/developers/readme_gen tests/README.md readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+	$(CAKEMLDIR)/developers/readme_gen $(README_SOURCES)
+
+ifdef POLY
+HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap
+endif
diff --git a/compiler/scheme/readmePrefix b/compiler/scheme/readmePrefix
new file mode 100644
index 0000000000..c0bfb8520e
--- /dev/null
+++ b/compiler/scheme/readmePrefix
@@ -0,0 +1 @@
+A compiler from Scheme to CakeML
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
new file mode 100644
index 0000000000..dd3e5db788
--- /dev/null
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -0,0 +1,88 @@
+(*
+  Parser for Scheme
+*)
+open preamble;
+open arithmeticTheory listTheory pairTheory finite_mapTheory stringTheory;
+open scheme_valuesTheory;
+
+val _ = new_theory "scheme_parsing";
+
+
+(* lexing *)
+
+Datatype:
+  token = OPEN | CLOSE | DOT | NUM num | QUOTE num
+End
+
+Definition read_num_def:
+  read_num l h f x acc [] = (acc,[]) ∧
+  read_num l h f x acc (c::cs) =
+    if ORD l ≤ ORD c ∧ ORD c ≤ ORD h then
+      read_num l h f x (f * acc + (ORD c - x)) cs
+    else (acc,c::cs)
+End
+
+Theorem read_num_length:
+  ∀l h xs n ys f acc x.
+    read_num l h f x acc xs = (n,ys) ⇒
+    LENGTH ys ≤ LENGTH xs ∧ (xs ≠ ys ⇒ LENGTH ys < LENGTH xs)
+Proof
+  Induct_on ‘xs’ \\ rw [read_num_def]
+  \\ TRY pairarg_tac \\ fs [] \\ rw [] \\ res_tac \\ fs []
+QED
+
+Definition end_line_def:
+  end_line [] = [] ∧
+  end_line (c::cs) = if c = #"\n" then cs else end_line cs
+End
+
+Theorem end_line_length:
+  ∀cs. STRLEN (end_line cs) < SUC (STRLEN cs)
+Proof
+  Induct \\ rw [end_line_def]
+QED
+
+Definition lex_def:
+  lex q [] acc = acc ∧
+  lex q (c::cs) acc =
+      if MEM c " \t\n" then lex NUM cs acc else
+      if c = #"#" then lex NUM (end_line cs) acc else
+      if c = #"." then lex NUM cs (DOT::acc) else
+      if c = #"(" then lex NUM cs (OPEN::acc) else
+      if c = #")" then lex NUM cs (CLOSE::acc) else
+      if c = #"'" then lex QUOTE cs acc else
+        let (n,rest) = read_num #"0" #"9" 10 (ORD #"0") 0 (c::cs) in
+          if rest ≠ c::cs then lex NUM rest (q n::acc) else
+            let (n,rest) = read_num #"*" #"z" 256 0 0 (c::cs) in
+              if rest ≠ c::cs then lex NUM rest (q n::acc) else
+                lex NUM cs acc
+Termination
+  WF_REL_TAC ‘measure (LENGTH o FST o SND)’ \\ rw []
+  \\ imp_res_tac (GSYM read_num_length) \\ fs [end_line_length]
+End
+
+Definition lexer_def:
+  lexer input = lex NUM input []
+End
+
+
+(* parsing *)
+
+Definition quote_def:
+  quote n = list [Num (name "'"); Num n]
+End
+
+Definition parse_def:
+  parse [] x s = x ∧
+  parse (CLOSE :: rest) x s = parse rest (Num 0) (x::s) ∧
+  parse (OPEN :: rest) x s =
+    (case s of [] => parse rest x s
+     | (y::ys) => parse rest (Pair x y) ys) ∧
+  parse (NUM n :: rest) x s = parse rest (Pair (Num n) x) s ∧
+  parse (QUOTE n :: rest) x s = parse rest (Pair (quote n) x) s ∧
+  parse (DOT :: rest) x s = parse rest (head x) s
+End
+
+
+
+val _ = export_theory();
diff --git a/compiler/scheme/scheme_valuesScript.sml b/compiler/scheme/scheme_valuesScript.sml
new file mode 100644
index 0000000000..51296b284c
--- /dev/null
+++ b/compiler/scheme/scheme_valuesScript.sml
@@ -0,0 +1,135 @@
+(*
+  Definition of Scheme values
+*)
+open preamble;
+open arithmeticTheory listTheory stringTheory;
+
+val _ = new_theory "scheme_values";
+
+(* Values in the source semantics are binary trees where the
+   leaves are natural numbers (num) *)
+Datatype:
+  v = Pair v v | Num num
+End
+
+(* Since strings are not in the representation, we have a function that
+   coverts strings into numbers. Note that parsing and pretty printing
+   is set up so that printing reproduces these strings when possible. *)
+Definition name_def:
+  name [] = 0 ∧
+  name (c::cs) = ORD c * 256 ** (LENGTH cs) + name cs
+End
+
+Overload Name = “λn. Num (name n)”
+
+(* Lists are terminated with Num 0 *)
+Definition list_def[simp]:
+  list [] = Num 0 ∧
+  list (x::xs) = Pair x (list xs)
+End
+
+(* various convenience functions below, most are automatic rewrites [simp] *)
+
+Definition less_def[simp]:
+  less (Num n) (Num m) <=> n < m
+End
+
+Definition plus_def[simp]:
+  plus (Num n) (Num m) = Num (n + m)
+End
+
+Definition minus_def[simp]:
+  minus (Num n) (Num m) = Num (n - m)
+End
+
+Definition div_def[simp]:
+  div (Num n) (Num m) = Num (n DIV m)
+End
+
+Definition head_def[simp]:
+  head (Pair x y) = x ∧
+  head v = v
+End
+
+Definition tail_def[simp]:
+  tail (Pair x y) = y ∧
+  tail v = v
+End
+
+Definition cons_def[simp]:
+  cons x y = Pair x y
+End
+
+Definition bool_def[simp]:
+  bool T = Num 1 ∧
+  bool F = Num 0
+End
+
+Definition map_def[simp]:
+  map f xs = list (MAP f xs)
+End
+
+Overload "list" = “map”;
+
+Definition pair_def[simp]:
+  pair f g (x,y) = Pair (f x) (g y)
+End
+
+Definition option_def[simp]:
+  option f NONE = list [] ∧
+  option f (SOME x) = list [f x]
+End
+
+Definition char_def[simp]:
+  char c = Num (ORD c)
+End
+
+Definition isNum_def[simp]:
+  isNum (Num n) = T ∧ isNum _ = F
+End
+
+Definition getNum_def[simp]:
+  getNum (Num n) = n ∧
+  getNum _ = 0
+End
+
+Definition el1_def[simp]:
+  el1 v = head (tail v)
+End
+
+Definition el2_def[simp]:
+  el2 v = el1 (tail v)
+End
+
+Definition el3_def[simp]:
+  el3 v = el2 (tail v)
+End
+
+Overload isNil[inferior] = “isNum”;
+Overload el0[inferior] = “head”;
+
+Theorem isNum_bool[simp]:
+  isNum (bool b)
+Proof
+  Cases_on ‘b’ \\ EVAL_TAC
+QED
+
+Theorem v_size_def[simp,allow_rebind] = fetch "-" "v_size_def";
+
+Theorem all_macro_defs = LIST_CONJ [list_def, cons_def, bool_def,
+   map_def, pair_def, option_def];
+
+Definition is_upper_def:
+  (* checks whether string (represented as num) starts with uppercase letter *)
+  is_upper n =
+    if n < 256:num then
+      if n < 65 (* ord A = 65 *) then F else
+      if n < 91 (* ord Z = 90 *) then T else F
+    else is_upper (n DIV 256)
+End
+
+Definition otherwise_def[simp]:
+  otherwise x = x
+End
+
+val _ = export_theory();

From 9efd210ed552c5fb81695dc315cf511a797c4a5a Mon Sep 17 00:00:00 2001
From: Magnus Myreen <myreen@chalmers.se>
Date: Tue, 17 Dec 2024 13:45:35 +0100
Subject: [PATCH 002/100] More set up of Scheme-to-CakeML compiler

---
 compiler/scheme/Holmakefile                   |  2 +-
 compiler/scheme/README.md                     | 22 +++++++
 compiler/scheme/compilation/Holmakefile       | 34 ++++++++++
 compiler/scheme/compilation/README.md         |  4 ++
 compiler/scheme/compilation/readmePrefix      |  1 +
 .../scheme_compilerCompileScript.sml          | 13 ++++
 compiler/scheme/scheme_astScript.sml          | 14 +++++
 compiler/scheme/scheme_compilerScript.sml     | 41 ++++++++++++
 compiler/scheme/scheme_parsingScript.sml      | 22 ++++++-
 compiler/scheme/scheme_to_cakeScript.sml      | 21 +++++++
 compiler/scheme/translation/Holmakefile       | 13 ++++
 compiler/scheme/translation/README.md         |  7 +++
 compiler/scheme/translation/readmePrefix      |  1 +
 .../translation/scheme_compilerProgScript.sml | 62 +++++++++++++++++++
 .../scheme/translation/to_sexpProgScript.sml  | 43 +++++++++++++
 15 files changed, 298 insertions(+), 2 deletions(-)
 create mode 100644 compiler/scheme/README.md
 create mode 100644 compiler/scheme/compilation/Holmakefile
 create mode 100644 compiler/scheme/compilation/README.md
 create mode 100644 compiler/scheme/compilation/readmePrefix
 create mode 100644 compiler/scheme/compilation/scheme_compilerCompileScript.sml
 create mode 100644 compiler/scheme/scheme_astScript.sml
 create mode 100644 compiler/scheme/scheme_compilerScript.sml
 create mode 100644 compiler/scheme/scheme_to_cakeScript.sml
 create mode 100644 compiler/scheme/translation/Holmakefile
 create mode 100644 compiler/scheme/translation/README.md
 create mode 100644 compiler/scheme/translation/readmePrefix
 create mode 100644 compiler/scheme/translation/scheme_compilerProgScript.sml
 create mode 100644 compiler/scheme/translation/to_sexpProgScript.sml

diff --git a/compiler/scheme/Holmakefile b/compiler/scheme/Holmakefile
index c40a5047ed..4fe6e61bb5 100644
--- a/compiler/scheme/Holmakefile
+++ b/compiler/scheme/Holmakefile
@@ -12,7 +12,7 @@ all: $(DEFAULT_TARGETS) README.md
 README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
 # Filter out tests/ (they don't have a readmePrefix)
 DIRS = $(patsubst tests/,,$(wildcard */))
-README.md: $(CAKEMLDIR)/developers/readme_gen tests/README.md readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
 	$(CAKEMLDIR)/developers/readme_gen $(README_SOURCES)
 
 ifdef POLY
diff --git a/compiler/scheme/README.md b/compiler/scheme/README.md
new file mode 100644
index 0000000000..df12e710e3
--- /dev/null
+++ b/compiler/scheme/README.md
@@ -0,0 +1,22 @@
+A compiler from Scheme to CakeML
+
+[compilation](compilation):
+Compilation scripts for the Scheme-to-CakeML compiler.
+
+[scheme_astScript.sml](scheme_astScript.sml):
+AST of Scheme
+
+[scheme_compilerScript.sml](scheme_compilerScript.sml):
+Definition of a compiler from Scheme to CakeML
+
+[scheme_parsingScript.sml](scheme_parsingScript.sml):
+Parser for Scheme
+
+[scheme_to_cakeScript.sml](scheme_to_cakeScript.sml):
+Code generator for Scheme to CakeML compiler
+
+[scheme_valuesScript.sml](scheme_valuesScript.sml):
+Definition of Scheme values
+
+[translation](translation):
+CakeML translation of Scheme-to-CakeML compiler
diff --git a/compiler/scheme/compilation/Holmakefile b/compiler/scheme/compilation/Holmakefile
new file mode 100644
index 0000000000..c6c50f4406
--- /dev/null
+++ b/compiler/scheme/compilation/Holmakefile
@@ -0,0 +1,34 @@
+INCLUDES = $(CAKEMLDIR)/compiler/scheme/translation $(CAKEMLDIR)/compiler $(CAKEMLDIR)/cv_translator $(CAKEMLDIR)/developers/bin
+
+all: $(DEFAULT_TARGETS) README.md scheme_compiler hi.cake
+.PHONY: all
+README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
+DIRS = $(wildcard */)
+README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+	$(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES)
+
+ifdef POLY
+HOLHEAP = $(CAKEMLDIR)/cv_translator/cake_compile_heap
+endif
+
+scheme_compiler: scheme_compilerCompileTheory.uo
+	gcc -o scheme_compiler scheme_compiler.S $(CAKEMLDIR)/basis/basis_ffi.c -lm
+
+hi.cake.S: cake scheme_compiler
+	echo "(print hi)" | ./scheme_compiler | ./cake --sexp=true > hi.cake.S
+
+hi.cake: hi.cake.S cake
+	make hi.cake
+	./hi.cake
+
+ARCH=x64
+WORD_SIZE=64
+
+cake-$(ARCH)-$(WORD_SIZE).tar.gz:
+	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+
+cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
+	tar -xvzf cake-$(ARCH)-$(WORD_SIZE).tar.gz --strip-components 1
+
+cake: cake.S
+	make -f Makefile
diff --git a/compiler/scheme/compilation/README.md b/compiler/scheme/compilation/README.md
new file mode 100644
index 0000000000..4ca533e13c
--- /dev/null
+++ b/compiler/scheme/compilation/README.md
@@ -0,0 +1,4 @@
+Compilation scripts for the Scheme-to-CakeML compiler.
+
+[scheme_compilerCompileScript.sml](scheme_compilerCompileScript.sml):
+In-logic compilation of the Scheme-to-CakeML compiler
diff --git a/compiler/scheme/compilation/readmePrefix b/compiler/scheme/compilation/readmePrefix
new file mode 100644
index 0000000000..5ef8d1d6d9
--- /dev/null
+++ b/compiler/scheme/compilation/readmePrefix
@@ -0,0 +1 @@
+Compilation scripts for the Scheme-to-CakeML compiler.
diff --git a/compiler/scheme/compilation/scheme_compilerCompileScript.sml b/compiler/scheme/compilation/scheme_compilerCompileScript.sml
new file mode 100644
index 0000000000..d1f46195d5
--- /dev/null
+++ b/compiler/scheme/compilation/scheme_compilerCompileScript.sml
@@ -0,0 +1,13 @@
+(*
+  In-logic compilation of the Scheme-to-CakeML compiler
+*)
+
+open preamble scheme_compilerProgTheory eval_cake_compile_x64Lib;
+
+val _ = new_theory "scheme_compilerCompile";
+
+Theorem scheme_compiler_compiled =
+        eval_cake_compile_x64 "" scheme_compiler_prog_def
+                                "scheme_compiler.S";
+
+val _ = export_theory ();
diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
new file mode 100644
index 0000000000..e6ca596f23
--- /dev/null
+++ b/compiler/scheme/scheme_astScript.sml
@@ -0,0 +1,14 @@
+(*
+  AST of Scheme
+*)
+open preamble;
+open mlstringTheory;
+
+val _ = new_theory "scheme_ast";
+
+(* This needs completing: Var, Lit, ... *)
+Datatype:
+  exp = Print mlstring
+End
+
+val _ = export_theory();
diff --git a/compiler/scheme/scheme_compilerScript.sml b/compiler/scheme/scheme_compilerScript.sml
new file mode 100644
index 0000000000..03cbf1d43f
--- /dev/null
+++ b/compiler/scheme/scheme_compilerScript.sml
@@ -0,0 +1,41 @@
+(*
+  Definition of a compiler from Scheme to CakeML
+*)
+open preamble;
+open fromSexpTheory simpleSexpParseTheory;
+open scheme_astTheory
+     scheme_parsingTheory
+     scheme_to_cakeTheory;
+
+val _ = new_theory "scheme_compiler";
+
+Definition cake_prog_to_string_def:
+  cake_prog_to_string ast =
+    print_sexp (listsexp (MAP decsexp ast))
+End
+
+Definition cake_for_err_def:
+  cake_for_err err_msg =
+    let err_str_ast = Lit (StrLit err_msg) in
+      cake_prog_to_string (cake_print (err_str_ast))
+End
+
+Definition compile_def:
+  compile (s:string) =
+    case parse_to_ast s of
+    | INL err_str => cake_for_err ("PARSE ERROR: " ++ err_str ++ "\n")
+    | INR ast =>
+       (case codegen ast of
+        | INL err_str => cake_for_err ("CODEGEN ERROR: " ++ err_str ++ "\n")
+        | INR cake_prog => cake_prog_to_string cake_prog)
+End
+
+(*
+EVAL “compile "(print hi)"”
+*)
+
+Definition main_function_def:
+  main_function s = implode (compile (explode s))
+End
+
+val _ = export_theory();
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index dd3e5db788..f681087f5e 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -2,8 +2,9 @@
   Parser for Scheme
 *)
 open preamble;
-open arithmeticTheory listTheory pairTheory finite_mapTheory stringTheory;
+open mlstringTheory;
 open scheme_valuesTheory;
+open scheme_astTheory;
 
 val _ = new_theory "scheme_parsing";
 
@@ -83,6 +84,25 @@ Definition parse_def:
   parse (DOT :: rest) x s = parse rest (head x) s
 End
 
+(*
+EVAL “head (parse (lexer "(print hi)") (Num 0) [])”
+*)
+
+
+(* conversion to AST *)
 
+Definition parse_to_ast_def:
+  parse_to_ast s =
+    let e = head (parse (lexer s) (Num 0) []) in
+      if e = Pair (Name "print") (Pair (Name "hi") (Num 0)) then
+        INR (Print (strlit "hi\n"))
+      else
+        INL ("This version can only parse '(print hi)'.")
+End
+
+(*
+EVAL “parse_to_ast "(print hi)"”
+EVAL “parse_to_ast "(print hello)"”
+*)
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
new file mode 100644
index 0000000000..6f0d287e16
--- /dev/null
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -0,0 +1,21 @@
+(*
+  Code generator for Scheme to CakeML compiler
+*)
+open preamble;
+open astTheory;
+open scheme_astTheory;
+
+val _ = new_theory "scheme_to_cake";
+
+Definition cake_print_def:
+  cake_print e =
+    (* val _ = print e; *)
+    [Dlet unknown_loc Pany (App Opapp [Var (Short "print"); e])]
+End
+
+Definition codegen_def:
+  (codegen (Print s)) : string + dec list =
+    INR (cake_print (Lit (StrLit (explode s))))
+End
+
+val _ = export_theory();
diff --git a/compiler/scheme/translation/Holmakefile b/compiler/scheme/translation/Holmakefile
new file mode 100644
index 0000000000..c7b38b26e9
--- /dev/null
+++ b/compiler/scheme/translation/Holmakefile
@@ -0,0 +1,13 @@
+INCLUDES = $(CAKEMLDIR)/compiler/scheme $(CAKEMLDIR)/translator $(CAKEMLDIR)/basis
+
+all: $(DEFAULT_TARGETS) README.md
+.PHONY: all
+
+README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
+DIRS = $(wildcard */)
+README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+	$(CAKEMLDIR)/developers/readme_gen $(README_SOURCES)
+
+ifdef POLY
+HOLHEAP = $(CAKEMLDIR)/basis/basis-heap
+endif
diff --git a/compiler/scheme/translation/README.md b/compiler/scheme/translation/README.md
new file mode 100644
index 0000000000..180d1fda50
--- /dev/null
+++ b/compiler/scheme/translation/README.md
@@ -0,0 +1,7 @@
+CakeML translation of Scheme-to-CakeML compiler
+
+[scheme_compilerProgScript.sml](scheme_compilerProgScript.sml):
+Build a CakeML program implementing Scheme-to-Cake compiler
+
+[to_sexpProgScript.sml](to_sexpProgScript.sml):
+Translation of printing to CakeML sexp
diff --git a/compiler/scheme/translation/readmePrefix b/compiler/scheme/translation/readmePrefix
new file mode 100644
index 0000000000..c191104d69
--- /dev/null
+++ b/compiler/scheme/translation/readmePrefix
@@ -0,0 +1 @@
+CakeML translation of Scheme-to-CakeML compiler
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
new file mode 100644
index 0000000000..6f0579b895
--- /dev/null
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -0,0 +1,62 @@
+(*
+  Build a CakeML program implementing Scheme-to-Cake compiler
+*)
+open preamble basis;
+open to_sexpProgTheory;
+open scheme_parsingTheory;
+open scheme_to_cakeTheory;
+open scheme_compilerTheory;
+
+val _ = new_theory "scheme_compilerProg";
+
+val _ = translation_extends "to_sexpProg";
+
+(* parsing *)
+
+val r = translate read_num_def;
+val r = translate end_line_def;
+val r = translate (lex_def |> SRULE [MEMBER_INTRO]);
+val r = translate lexer_def;
+val r = translate scheme_valuesTheory.list_def;
+val r = translate scheme_valuesTheory.name_def;
+val r = translate scheme_valuesTheory.head_def;
+val r = translate quote_def;
+val r = translate parse_def;
+val r = translate parse_to_ast_def;
+
+(* codegen *)
+
+val r = translate locationTheory.unknown_loc_def;
+val r = translate cake_print_def;
+val r = translate codegen_def;
+
+(* top-level compiler *)
+
+val r = translate cake_prog_to_string_def;
+val r = translate cake_for_err_def;
+val r = translate compile_def;
+val r = translate main_function_def;
+
+(* main function *)
+
+val _ = type_of “main_function” = “:mlstring -> mlstring”
+        orelse failwith "The main_function has the wrong type.";
+
+val main = process_topdecs
+           `print (main_function (TextIO.inputAll TextIO.stdIn));`;
+
+val prog =
+  get_ml_prog_state ()
+  |> ml_progLib.clean_state
+  |> ml_progLib.remove_snocs
+  |> ml_progLib.get_thm
+  |> REWRITE_RULE [ml_progTheory.ML_code_def]
+  |> concl |> rator |> rator |> rand
+  |> (fn tm => “^tm ++ ^main”)
+  |> EVAL |> concl |> rand;
+
+Definition scheme_compiler_prog_def:
+  scheme_compiler_prog = ^prog
+End
+
+val _ = export_theory ();
diff --git a/compiler/scheme/translation/to_sexpProgScript.sml b/compiler/scheme/translation/to_sexpProgScript.sml
new file mode 100644
index 0000000000..af58535bcc
--- /dev/null
+++ b/compiler/scheme/translation/to_sexpProgScript.sml
@@ -0,0 +1,43 @@
+(*
+  Translation of printing to CakeML sexp
+*)
+open preamble basis;
+open astTheory fromSexpTheory simpleSexpParseTheory;
+
+val _ = new_theory "to_sexpProg";
+
+val _ = translation_extends "basisProg";
+
+val _ = register_type “:ast$dec”;
+
+(* TODO: remove all preconditions *)
+
+val r = translate numposrepTheory.n2l_def;
+val r = translate ASCIInumbersTheory.n2s_def;
+val r = translate ASCIInumbersTheory.HEX_def;
+val r = translate ASCIInumbersTheory.num_to_dec_string_def;
+val r = translate simpleSexpParseTheory.print_space_separated_def;
+val r = translate simpleSexpParseTheory.strip_dot_def;
+val r = translate simpleSexpParseTheory.escape_string_def;
+val r = translate listTheory.EL;
+val r = translate simpleSexpParseTheory.print_sexp_def;
+val r = translate fromSexpTheory.listsexp_def;
+val r = translate fromSexpTheory.locnsexp_def;
+val r = translate fromSexpTheory.locssexp_def;
+val r = translate stringTheory.isPrint_def;
+val r = translate ASCIInumbersTheory.num_to_hex_string_def;
+val r = translate fromSexpTheory.encode_control_def;
+val r = translate fromSexpTheory.SEXSTR_def;
+val r = translate fromSexpTheory.litsexp_def;
+val r = translate fromSexpTheory.optsexp_def;
+val r = translate fromSexpTheory.idsexp_def;
+val r = translate fromSexpTheory.typesexp_def;
+val r = translate fromSexpTheory.patsexp_def;
+val r = translate fromSexpTheory.opsexp_def;
+val r = translate fromSexpTheory.lopsexp_def;
+val r = translate fromSexpTheory.scsexp_def;
+val r = translate fromSexpTheory.expsexp_def;
+val r = translate fromSexpTheory.type_defsexp_def;
+val r = translate fromSexpTheory.decsexp_def;
+
+val _ = export_theory ();

From 09079cca1af6ccafc17585f84a711128eb1ae73b Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sun, 29 Dec 2024 02:05:12 +0000
Subject: [PATCH 003/100] Shuffled Makefile configurations

---
 compiler/scheme/compilation/Holmakefile | 24 +-----------
 compiler/scheme/examples/Makefile       | 52 +++++++++++++++++++++++++
 compiler/scheme/examples/hi.scm         |  1 +
 3 files changed, 54 insertions(+), 23 deletions(-)
 create mode 100644 compiler/scheme/examples/Makefile
 create mode 100644 compiler/scheme/examples/hi.scm

diff --git a/compiler/scheme/compilation/Holmakefile b/compiler/scheme/compilation/Holmakefile
index c6c50f4406..5496db4357 100644
--- a/compiler/scheme/compilation/Holmakefile
+++ b/compiler/scheme/compilation/Holmakefile
@@ -1,6 +1,6 @@
 INCLUDES = $(CAKEMLDIR)/compiler/scheme/translation $(CAKEMLDIR)/compiler $(CAKEMLDIR)/cv_translator $(CAKEMLDIR)/developers/bin
 
-all: $(DEFAULT_TARGETS) README.md scheme_compiler hi.cake
+all: $(DEFAULT_TARGETS) README.md
 .PHONY: all
 README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
 DIRS = $(wildcard */)
@@ -10,25 +10,3 @@ README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmeP
 ifdef POLY
 HOLHEAP = $(CAKEMLDIR)/cv_translator/cake_compile_heap
 endif
-
-scheme_compiler: scheme_compilerCompileTheory.uo
-	gcc -o scheme_compiler scheme_compiler.S $(CAKEMLDIR)/basis/basis_ffi.c -lm
-
-hi.cake.S: cake scheme_compiler
-	echo "(print hi)" | ./scheme_compiler | ./cake --sexp=true > hi.cake.S
-
-hi.cake: hi.cake.S cake
-	make hi.cake
-	./hi.cake
-
-ARCH=x64
-WORD_SIZE=64
-
-cake-$(ARCH)-$(WORD_SIZE).tar.gz:
-	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
-
-cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
-	tar -xvzf cake-$(ARCH)-$(WORD_SIZE).tar.gz --strip-components 1
-
-cake: cake.S
-	make -f Makefile
diff --git a/compiler/scheme/examples/Makefile b/compiler/scheme/examples/Makefile
new file mode 100644
index 0000000000..6d721c29e7
--- /dev/null
+++ b/compiler/scheme/examples/Makefile
@@ -0,0 +1,52 @@
+all: hi.cake$(SUFF)
+.PHONY: all clean
+
+OS ?= $(shell uname)
+
+ifeq ($(OS),Windows_NT)
+	PREF =
+	SUFF = .exe
+	EVALFLAG =
+else
+	PREF = ./
+	SUFF =
+	EVALFLAG = -DEVAL
+endif
+
+CAKEOPT = --sexp=true
+
+ifeq ($(OS),Darwin)
+	# These options avoid linker warnings on macOS
+	LDFLAGS += -Wl,-no_pie
+	EVALFLAG =
+endif
+
+CFLAGS+=-O2
+LDLIBS+=-lm
+
+ARCH=x64
+WORD_SIZE=64
+
+%.cake.S: %.scm cake scheme_compiler$(SUFF)
+	cat $< | $(PREF)scheme_compiler$(SUFF) | $(PREF)cake$(SUFF) $(CAKEOPT) > $@
+
+%.cake$(SUFF) : %.cake.S ../../../basis/basis_ffi.c
+	$(CC) $< ../../../basis/basis_ffi.c $(LOADLIBES) $(LDLIBS) -o $@ $(LDFLAGS)
+
+scheme_compiler.S: ../compilation/scheme_compiler.S
+	cp $< $@
+
+scheme_compiler$(SUFF): scheme_compiler.S ../../../basis/basis_ffi.c
+	$(CC) -o $@ scheme_compiler.S ../../../basis/basis_ffi.c $(LDLIBS)
+
+cake-$(ARCH)-$(WORD_SIZE).tar.gz:
+	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+
+cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
+	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz --strip-components 1 cake-x64-64/$@
+
+cake$(SUFF): cake.S ../../../basis/basis_ffi.c
+	$(CC) $(CFLAGS) $< ../../../basis/basis_ffi.c $(LOADLIBES) $(EVALFLAG) -o $@ $(LDFLAGS) $(LDLIBS)
+
+clean:
+	rm cake$(SUFF) cake.S cake-$(ARCH)-$(WORD_SIZE).tar.gz scheme_compiler$(SUFF) scheme_compiler.S *.cake.S *.cake$(SUFF)
diff --git a/compiler/scheme/examples/hi.scm b/compiler/scheme/examples/hi.scm
new file mode 100644
index 0000000000..2641c5e01d
--- /dev/null
+++ b/compiler/scheme/examples/hi.scm
@@ -0,0 +1 @@
+(print hi)

From 3f9f74b55d6939fbc2be36d8f6c89a183f80a08e Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sun, 29 Dec 2024 02:13:01 +0000
Subject: [PATCH 004/100] READMEs

---
 compiler/scheme/README.md             | 6 ++++++
 compiler/scheme/examples/README.md    | 1 +
 compiler/scheme/examples/readmePrefix | 1 +
 3 files changed, 8 insertions(+)
 create mode 100644 compiler/scheme/examples/README.md
 create mode 100644 compiler/scheme/examples/readmePrefix

diff --git a/compiler/scheme/README.md b/compiler/scheme/README.md
index df12e710e3..953a3c0cac 100644
--- a/compiler/scheme/README.md
+++ b/compiler/scheme/README.md
@@ -3,6 +3,9 @@ A compiler from Scheme to CakeML
 [compilation](compilation):
 Compilation scripts for the Scheme-to-CakeML compiler.
 
+[examples](examples):
+Example Scheme programs compiled using the Scheme compiler
+
 [scheme_astScript.sml](scheme_astScript.sml):
 AST of Scheme
 
@@ -20,3 +23,6 @@ Definition of Scheme values
 
 [translation](translation):
 CakeML translation of Scheme-to-CakeML compiler
+
+[unverified](unverified):
+An unverified compiler from Scheme to ML written in Haskell
diff --git a/compiler/scheme/examples/README.md b/compiler/scheme/examples/README.md
new file mode 100644
index 0000000000..3ca08042a5
--- /dev/null
+++ b/compiler/scheme/examples/README.md
@@ -0,0 +1 @@
+Example Scheme programs compiled using the Scheme compiler
diff --git a/compiler/scheme/examples/readmePrefix b/compiler/scheme/examples/readmePrefix
new file mode 100644
index 0000000000..3ca08042a5
--- /dev/null
+++ b/compiler/scheme/examples/readmePrefix
@@ -0,0 +1 @@
+Example Scheme programs compiled using the Scheme compiler

From 0f09423739342d5c7a3e637d20800bd49b45c61b Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sun, 29 Dec 2024 02:16:32 +0000
Subject: [PATCH 005/100] Start on unverified compiler

---
 compiler/scheme/unverified/Compiler.hs    | 21 ++++++++++
 compiler/scheme/unverified/Interpreter.hs | 14 +++++++
 compiler/scheme/unverified/Makefile       | 34 +++++++++++++++
 compiler/scheme/unverified/README.md      |  1 +
 compiler/scheme/unverified/Scheme.hs      | 50 +++++++++++++++++++++++
 compiler/scheme/unverified/readmePrefix   |  1 +
 6 files changed, 121 insertions(+)
 create mode 100644 compiler/scheme/unverified/Compiler.hs
 create mode 100644 compiler/scheme/unverified/Interpreter.hs
 create mode 100644 compiler/scheme/unverified/Makefile
 create mode 100644 compiler/scheme/unverified/README.md
 create mode 100644 compiler/scheme/unverified/Scheme.hs
 create mode 100644 compiler/scheme/unverified/readmePrefix

diff --git a/compiler/scheme/unverified/Compiler.hs b/compiler/scheme/unverified/Compiler.hs
new file mode 100644
index 0000000000..00b9355af8
--- /dev/null
+++ b/compiler/scheme/unverified/Compiler.hs
@@ -0,0 +1,21 @@
+module Compiler where
+import Scheme
+import Prettyprinter (Pretty(pretty), (<+>), lparen, rparen)
+import System.IO (hPutStrLn, stderr)
+import Control.Monad ((<=<))
+
+compile (Apply (AstPrim Plus) [x, y]) = do
+    left <- compile x
+    right <- compile y
+    return $ lparen <> left <+> pretty '+' <+> right <> rparen
+compile (Apply (AstPrim Plus) _) = Left "Invalid arguments to +"
+
+compile (Apply (AstPrim Multiply) [x, y]) = do
+    left <- compile x
+    right <- compile y
+    return $ lparen <> left <+> pretty '*' <+> right <> rparen
+compile (Apply (AstPrim Multiply) _) = Left "Invalid arguments to *"
+
+compile (AstConst (NumE x)) = Right $ pretty x
+
+main = either (hPutStrLn stderr) (print . head) . (mapM compile <=< mapM toAst <=< parse [] [] <=< flip schlex []) =<< getContents
diff --git a/compiler/scheme/unverified/Interpreter.hs b/compiler/scheme/unverified/Interpreter.hs
new file mode 100644
index 0000000000..c852918a9a
--- /dev/null
+++ b/compiler/scheme/unverified/Interpreter.hs
@@ -0,0 +1,14 @@
+module Interpreter where
+import Scheme
+import Control.Monad (liftM2, (<=<))
+import System.IO (hPutStrLn, stderr)
+
+strict (Apply (AstPrim Plus) [AstConst (NumE x), AstConst (NumE y)]) = Right $ AstConst $ NumE $ x + y
+strict (Apply (AstPrim Plus) _) = Left "Invalid arguments to +"
+strict (Apply (AstPrim Multiply) [AstConst (NumE x), AstConst (NumE y)]) = Right $ AstConst $ NumE $ x * y
+strict (Apply (AstPrim Multiply) _) = Left "Invalid arguments to *"
+
+evaluate (Apply fn xs) = strict =<< liftM2 Apply (evaluate fn) (mapM evaluate xs)
+evaluate x = Right x
+
+main = either (hPutStrLn stderr) (print . head) . (mapM evaluate <=< mapM toAst <=< parse [] [] <=< flip schlex []) =<< getContents
diff --git a/compiler/scheme/unverified/Makefile b/compiler/scheme/unverified/Makefile
new file mode 100644
index 0000000000..ef6d4e3289
--- /dev/null
+++ b/compiler/scheme/unverified/Makefile
@@ -0,0 +1,34 @@
+all: lib/scheme_interpreter lib/unverified_scheme_compiler
+.PHONY: all clean
+
+%.cake.S: %.scm lib/cake lib/unverified_scheme_compiler
+	cat $< | ./lib/unverified_scheme_compiler | ./lib/cake $(CAKEOPT) > $@
+
+%.cake: %.cake.S ../../../basis/basis_ffi.c
+	$(CC) $^ $(LOADLIBES) $(LDLIBS) -o $@ $(LDFLAGS)
+
+lib/scheme_interpreter: Interpreter.hs Scheme.hs
+lib/unverified_scheme_compiler: Compiler.hs Scheme.hs
+lib/scheme_interpreter lib/unverified_scheme_compiler:
+	@mkdir -p $(@D)
+	ghc $^ -main-is $(basename $<) -outputdir lib -o $@
+
+CFLAGS+=-O2
+LDLIBS+=-lm
+
+ARCH=x64
+WORD_SIZE=64
+
+cake-$(ARCH)-$(WORD_SIZE).tar.gz:
+	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+
+lib/cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
+	@mkdir -p $(@D)
+	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz --directory $(@D) --strip-components 1 cake-x64-64/$(F@)
+
+lib/cake: lib/cake.S ../../../basis/basis_ffi.c
+	@mkdir -p $(@D)
+	$(CC) $(CFLAGS) $^ $(LOADLIBES) $(EVALFLAG) -o $@ $(LDFLAGS) $(LDLIBS)
+
+clean:
+	rm -rf lib cake-$(ARCH)-$(WORD_SIZE).tar.gz *.cake.S *.cake
diff --git a/compiler/scheme/unverified/README.md b/compiler/scheme/unverified/README.md
new file mode 100644
index 0000000000..76a54b1ed3
--- /dev/null
+++ b/compiler/scheme/unverified/README.md
@@ -0,0 +1 @@
+An unverified compiler from Scheme to ML written in Haskell
diff --git a/compiler/scheme/unverified/Scheme.hs b/compiler/scheme/unverified/Scheme.hs
new file mode 100644
index 0000000000..d69b610c8c
--- /dev/null
+++ b/compiler/scheme/unverified/Scheme.hs
@@ -0,0 +1,50 @@
+module Scheme where
+import Data.Typeable (cast)
+import Data.Char (ord, isSpace)
+import Data.Maybe (fromMaybe)
+import Control.Monad ((<=<), liftM2)
+
+data ArithOp = Plus | Minus | Multiply
+    deriving Show
+data Token = Open | Close | NumT Int | Arith ArithOp
+    deriving Show
+
+data Exp = ExpList [Exp] | Const Value | Prim ArithOp
+    deriving Show
+data Value = NumE Int
+    deriving Show
+
+data AstExp = Apply AstExp [AstExp] | AstConst Value | AstPrim ArithOp
+    deriving Show
+
+lexNum (x:xs) acc = if ord '0' <= ord x && ord x <= ord '9'
+    then let next = acc * 10 + (ord x - ord '0') in Just . fromMaybe next <$> lexNum xs next
+    else (x:xs, Nothing)
+
+schlex [] acc = Right acc
+schlex ls acc = numOrNot $ lexNum ls 0 where
+    numOrNot (rs, Just n) = schlex rs $ NumT n:acc
+    numOrNot (x:xs, Nothing) = if isSpace x
+        then schlex xs acc
+        else symb x >>= schlex xs . (:acc)
+
+    symb '(' = Right Open
+    symb ')' = Right Close
+    symb '+' = Right $ Arith Plus
+    symb '-' = Right $ Arith Minus
+    symb '*' = Right $ Arith Multiply
+    symb c = Left $ "Invalid symbol " <> return c
+
+--parse (Close:xs) q =
+parse [] p [] = Right p
+parse _ _ [] = Left "Too many close brackets"
+parse q p (Close:xs) = parse (ExpList p:q) [] xs
+parse (ExpList q':q) p (Open:xs) = parse q (ExpList p:q') xs
+parse _ _ (Open:_) = Left "Too many open brackets"
+parse q p (NumT i:xs) = parse q (Const (NumE i):p) xs
+parse q p (Arith o:xs) = parse q (Prim o:p) xs
+
+toAst (Const v) = Right $ AstConst v
+toAst (Prim o) = Right $ AstPrim o
+toAst (ExpList []) = Left "Empty S expression"
+toAst (ExpList xs) = liftM2 Apply head tail <$> mapM toAst xs
diff --git a/compiler/scheme/unverified/readmePrefix b/compiler/scheme/unverified/readmePrefix
new file mode 100644
index 0000000000..76a54b1ed3
--- /dev/null
+++ b/compiler/scheme/unverified/readmePrefix
@@ -0,0 +1 @@
+An unverified compiler from Scheme to ML written in Haskell

From 1f576a5e181b1be4dd37c03a2a8edc587c62ee41 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 4 Jan 2025 19:44:15 +0000
Subject: [PATCH 006/100] Use local cake.S if exists

---
 compiler/scheme/examples/Makefile   | 13 ++++++++-----
 compiler/scheme/unverified/Makefile | 15 +++++++++------
 2 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/compiler/scheme/examples/Makefile b/compiler/scheme/examples/Makefile
index 6d721c29e7..a79131339f 100644
--- a/compiler/scheme/examples/Makefile
+++ b/compiler/scheme/examples/Makefile
@@ -39,14 +39,17 @@ scheme_compiler.S: ../compilation/scheme_compiler.S
 scheme_compiler$(SUFF): scheme_compiler.S ../../../basis/basis_ffi.c
 	$(CC) -o $@ scheme_compiler.S ../../../basis/basis_ffi.c $(LDLIBS)
 
-cake-$(ARCH)-$(WORD_SIZE).tar.gz:
-	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+cake.S:
+	@if [ ! -f "../../bootstrap/compilation/x64/64/$(@F)" ] ; then $(MAKE) download ; else cp ../../bootstrap/compilation/x64/64/$(@F) $@ ; fi
 
-cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
-	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz --strip-components 1 cake-x64-64/$@
+download:
+	@echo "$(red)Could not find \`cake.S\`. Downloading the latest version from CakeML's GitHub releases.$(reset)"
+	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz --strip-components 1 cake-$(ARCH)-$(WORD_SIZE)/cake.S
+	@rm cake-$(ARCH)-$(WORD_SIZE).tar.gz
 
 cake$(SUFF): cake.S ../../../basis/basis_ffi.c
 	$(CC) $(CFLAGS) $< ../../../basis/basis_ffi.c $(LOADLIBES) $(EVALFLAG) -o $@ $(LDFLAGS) $(LDLIBS)
 
 clean:
-	rm cake$(SUFF) cake.S cake-$(ARCH)-$(WORD_SIZE).tar.gz scheme_compiler$(SUFF) scheme_compiler.S *.cake.S *.cake$(SUFF)
+	rm cake$(SUFF) cake.S scheme_compiler$(SUFF) scheme_compiler.S *.cake.S *.cake$(SUFF)
diff --git a/compiler/scheme/unverified/Makefile b/compiler/scheme/unverified/Makefile
index ef6d4e3289..96c0645e77 100644
--- a/compiler/scheme/unverified/Makefile
+++ b/compiler/scheme/unverified/Makefile
@@ -19,16 +19,19 @@ LDLIBS+=-lm
 ARCH=x64
 WORD_SIZE=64
 
-cake-$(ARCH)-$(WORD_SIZE).tar.gz:
-	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
-
-lib/cake.S: cake-$(ARCH)-$(WORD_SIZE).tar.gz
+lib/cake.S:
 	@mkdir -p $(@D)
-	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz --directory $(@D) --strip-components 1 cake-x64-64/$(F@)
+	@if [ ! -f "../../bootstrap/compilation/x64/64/$(@F)" ] ; then $(MAKE) download ; else cp ../../bootstrap/compilation/x64/64/$(@F) $@ ; fi
+
+download:
+	@echo "$(red)Could not find \`cake.S\`. Downloading the latest version from CakeML's GitHub releases.$(reset)"
+	curl -LO https://github.com/CakeML/cakeml/releases/latest/download/cake-$(ARCH)-$(WORD_SIZE).tar.gz
+	@tar -zxf cake-$(ARCH)-$(WORD_SIZE).tar.gz -C lib --strip-components 1 cake-$(ARCH)-$(WORD_SIZE)/cake.S
+	@rm cake-$(ARCH)-$(WORD_SIZE).tar.gz
 
 lib/cake: lib/cake.S ../../../basis/basis_ffi.c
 	@mkdir -p $(@D)
 	$(CC) $(CFLAGS) $^ $(LOADLIBES) $(EVALFLAG) -o $@ $(LDFLAGS) $(LDLIBS)
 
 clean:
-	rm -rf lib cake-$(ARCH)-$(WORD_SIZE).tar.gz *.cake.S *.cake
+	rm -rf lib *.cake.S *.cake

From 9ca46d8a079c6e2c803c16e27241cf12bdfe0db8 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 4 Jan 2025 19:46:47 +0000
Subject: [PATCH 007/100] Unverified dynamic typing, conditionals, printing

---
 compiler/scheme/unverified/Compiler.hs    | 50 +++++++++---
 compiler/scheme/unverified/Interpreter.hs | 23 ++++--
 compiler/scheme/unverified/Scheme.hs      | 93 +++++++++++++++--------
 3 files changed, 116 insertions(+), 50 deletions(-)

diff --git a/compiler/scheme/unverified/Compiler.hs b/compiler/scheme/unverified/Compiler.hs
index 00b9355af8..c194dfd246 100644
--- a/compiler/scheme/unverified/Compiler.hs
+++ b/compiler/scheme/unverified/Compiler.hs
@@ -1,21 +1,47 @@
 module Compiler where
 import Scheme
-import Prettyprinter (Pretty(pretty), (<+>), lparen, rparen)
+import Prettyprinter (Pretty(pretty), (<+>), lparen, rparen, parens, line, nest, dquotes, vsep)
 import System.IO (hPutStrLn, stderr)
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), foldM)
 
-compile (Apply (AstPrim Plus) [x, y]) = do
-    left <- compile x
-    right <- compile y
-    return $ lparen <> left <+> pretty '+' <+> right <> rparen
-compile (Apply (AstPrim Plus) _) = Left "Invalid arguments to +"
+compile (ConstExp (SNum x)) = Right $ parens $ pretty "SInt" <+> pretty x
+compile (ConstExp (SBool False)) = Right $ parens $ pretty "SBool" <+> pretty "False"
+compile (ConstExp (SBool True)) = Right $ parens $ pretty "SBool" <+> pretty "True"
+
+compile (Apply (PrimExp Plus) xs) = foldM add (pretty "(SInt 0)") xs where
+    add p x = parens . ((pretty "sadd" <+> p) <+>) <$> compile x
 
-compile (Apply (AstPrim Multiply) [x, y]) = do
+compile (Apply (PrimExp Multiply) xs) = foldM multiply (pretty "(SInt 1)") xs where
+    multiply p x = parens . ((pretty "smul" <+> p) <+>) <$> compile x
+
+compile (Cond c x y) = do
+    cond <- compile c
+    ifTrue <- compile x
+    ifFalse <- compile y
+    return $ parens $ pretty "if" <+> cond <+> pretty "then" <+> ifTrue <+> pretty "else" <+> ifFalse
+
+compile (Equiv x y) = do
     left <- compile x
     right <- compile y
-    return $ lparen <> left <+> pretty '*' <+> right <> rparen
-compile (Apply (AstPrim Multiply) _) = Left "Invalid arguments to *"
+    return $ parens $ left <+> pretty "=" <+> right
+
+compile (Display x) = parens . (pretty "print_sval" <+>) <$> compile x
+compile (Begin (x:xs)) = parens <$> foldl state (compile x) xs where
+    state p y = (<>) . (<> pretty ";") <$> p <*> compile y
 
-compile (AstConst (NumE x)) = Right $ pretty x
+inContext x = vsep [pretty "datatype sval = SInt int | SBool bool;",
+    line <> nest 4 (vsep [pretty "fun print_sval v = case v of",
+        pretty "SInt i => print_int i",
+        pretty "| SBool b => print_pp (pp_bool b);"]),
+    line <> pretty "exception SchemeArith string;",
+    line <> nest 4 (vsep [pretty "fun sadd x y = case (x, y) of",
+        pretty "(SInt a, SInt b) => SInt (a + b)",
+        pretty "| (_, _) => raise SchemeArith" <+> dquotes (pretty "Argument to + must be a number") <> pretty ';']),
+    line <> nest 4 (vsep [pretty "fun smul x y = case (x, y) of",
+        pretty "(SInt a, SInt b) => SInt (a * b)",
+        pretty "| (_, _) => raise SchemeArith" <+> dquotes (pretty "Argument to * must be a number") <> pretty ';']),
+    line <> pretty "val _ =" <+> parens x <+> pretty "handle SchemeArith msg => TextIO.print_err msg;"
+    ]
 
-main = either (hPutStrLn stderr) (print . head) . (mapM compile <=< mapM toAst <=< parse [] [] <=< flip schlex []) =<< getContents
+main = either (hPutStrLn stderr) (print . inContext . head)
+    . (mapM compile <=< mapM toAst <=< parse [] [] <=< schlex []) =<< getContents
diff --git a/compiler/scheme/unverified/Interpreter.hs b/compiler/scheme/unverified/Interpreter.hs
index c852918a9a..963bf617dc 100644
--- a/compiler/scheme/unverified/Interpreter.hs
+++ b/compiler/scheme/unverified/Interpreter.hs
@@ -1,14 +1,23 @@
 module Interpreter where
 import Scheme
-import Control.Monad (liftM2, (<=<))
+import Control.Monad (liftM2, (<=<), foldM, liftM3)
 import System.IO (hPutStrLn, stderr)
+import Data.Bool (bool)
 
-strict (Apply (AstPrim Plus) [AstConst (NumE x), AstConst (NumE y)]) = Right $ AstConst $ NumE $ x + y
-strict (Apply (AstPrim Plus) _) = Left "Invalid arguments to +"
-strict (Apply (AstPrim Multiply) [AstConst (NumE x), AstConst (NumE y)]) = Right $ AstConst $ NumE $ x * y
-strict (Apply (AstPrim Multiply) _) = Left "Invalid arguments to *"
+strict:: Exp -> IO Exp
+strict (Apply (PrimExp Plus) xs) = ConstExp . SNum <$> foldM add 0 xs where
+    add n (ConstExp (SNum x)) = return $ n + x
+    add _ _ = fail "Argument to + must be a number"
+strict (Apply (PrimExp Multiply) xs) = ConstExp . SNum <$> foldM multiply 1 xs where
+    multiply n (ConstExp (SNum x)) = return $ n * x
+    multiply _ _ = fail "Argument to * must be a number"
 
+evaluate :: Exp -> IO Exp
 evaluate (Apply fn xs) = strict =<< liftM2 Apply (evaluate fn) (mapM evaluate xs)
-evaluate x = Right x
+evaluate (Cond c x y) = evaluate . bool y x . (ConstExp (SBool False) /=) =<< evaluate c
+evaluate (Equiv x y) = ConstExp . SBool <$> ((==) <$> evaluate x <*> evaluate y)
+evaluate (Begin xs) = foldM (const evaluate) Unit xs
+evaluate (Display x) = (print =<< evaluate x) >> return Unit
+evaluate x = return x
 
-main = either (hPutStrLn stderr) (print . head) . (mapM evaluate <=< mapM toAst <=< parse [] [] <=< flip schlex []) =<< getContents
+main = (either fail (evaluate . head) . (mapM toAst <=< parse [] [] <=< schlex [])) =<< getContents
diff --git a/compiler/scheme/unverified/Scheme.hs b/compiler/scheme/unverified/Scheme.hs
index d69b610c8c..abf061c2e0 100644
--- a/compiler/scheme/unverified/Scheme.hs
+++ b/compiler/scheme/unverified/Scheme.hs
@@ -1,50 +1,81 @@
 module Scheme where
 import Data.Typeable (cast)
-import Data.Char (ord, isSpace)
+import Data.Char (ord, isSpace, toLower)
 import Data.Maybe (fromMaybe)
-import Control.Monad ((<=<), liftM2)
+import Control.Monad (liftM2, guard)
+import Control.Applicative ((<|>))
+import Data.Either.Extra (maybeToEither)
+import Data.Tuple (swap)
 
 data ArithOp = Plus | Minus | Multiply
-    deriving Show
-data Token = Open | Close | NumT Int | Arith ArithOp
+    deriving (Show, Eq)
+data Token = Open | Close | Value SValue | Arith ArithOp | Identifier String
     deriving Show
 
-data Exp = ExpList [Exp] | Const Value | Prim ArithOp
-    deriving Show
-data Value = NumE Int
+data Datum = ExpList [Datum] | Const SValue | Prim ArithOp | Symbol String
     deriving Show
+data SValue = SNum Int | SBool Bool
+    deriving (Show, Eq)
 
-data AstExp = Apply AstExp [AstExp] | AstConst Value | AstPrim ArithOp
-    deriving Show
+data Exp = Apply Exp [Exp] | Cond Exp Exp Exp | Equiv Exp Exp | Begin [Exp] | ConstExp SValue | PrimExp ArithOp | Display Exp | Unit
+    deriving (Show, Eq)
+
+delimitsNext [] = True
+delimitsNext (x:_) = elem x ['(', ')', '[', ']', '"', ';', '#'] || isSpace x
+
+lexSymb ('(':xs) = Just (xs, Open)
+lexSymb (')':xs) = Just (xs, Close)
+lexSymb ('[':xs) = Nothing
+lexSymb (']':xs) = Nothing
+lexSymb ('"':xs) = Nothing
+lexSymb ('#':xs) = Nothing
+lexSymb (';':xs) = Nothing
+lexSymb ('+':xs) = Just (xs, Arith Plus)
+lexSymb ('-':xs) = Just (xs, Arith Minus)
+lexSymb ('*':xs) = Just (xs, Arith Multiply)
+lexSymb _ = Nothing
+
+lexBool ('#':x:xs)
+    | toLower x == 'f' && delimitsNext xs = Just (xs, Value $ SBool False)
+    | toLower x == 't' && delimitsNext xs = Just (xs, Value $ SBool True)
+    | otherwise = Nothing
+lexBool _ = Nothing
+
+lexIdentifier (x:xs) = if delimitsNext xs then Just (xs, [x])
+    else ((x:) <$>) <$> lexIdentifier xs
+
+lexNum acc (x:xs) = if ord '0' <= ord x && ord x <= ord '9'
+    then (if delimitsNext xs then Just . (xs,) . Value . SNum else flip lexNum xs) $ acc * 10 + (ord x - ord '0')
+    else Nothing
+lexNum _ _ = Nothing
+
+schlex acc [] = Right acc
+schlex acc ls@(x:xs) = if isSpace x then schlex acc xs
+    else uncurry (schlex . (:acc)) . swap =<< maybeToEither ("Failed to parse at character " <> [x]) (foldl (<|>) Nothing $ map ($ ls) [
+        lexSymb,
+        lexBool,
+        lexNum 0,
+        ((Identifier <$>) <$>) . lexIdentifier
+    ])
 
-lexNum (x:xs) acc = if ord '0' <= ord x && ord x <= ord '9'
-    then let next = acc * 10 + (ord x - ord '0') in Just . fromMaybe next <$> lexNum xs next
-    else (x:xs, Nothing)
-
-schlex [] acc = Right acc
-schlex ls acc = numOrNot $ lexNum ls 0 where
-    numOrNot (rs, Just n) = schlex rs $ NumT n:acc
-    numOrNot (x:xs, Nothing) = if isSpace x
-        then schlex xs acc
-        else symb x >>= schlex xs . (:acc)
-
-    symb '(' = Right Open
-    symb ')' = Right Close
-    symb '+' = Right $ Arith Plus
-    symb '-' = Right $ Arith Minus
-    symb '*' = Right $ Arith Multiply
-    symb c = Left $ "Invalid symbol " <> return c
-
---parse (Close:xs) q =
 parse [] p [] = Right p
 parse _ _ [] = Left "Too many close brackets"
 parse q p (Close:xs) = parse (ExpList p:q) [] xs
 parse (ExpList q':q) p (Open:xs) = parse q (ExpList p:q') xs
 parse _ _ (Open:_) = Left "Too many open brackets"
-parse q p (NumT i:xs) = parse q (Const (NumE i):p) xs
+parse q p (Value v:xs) = parse q (Const v:p) xs
 parse q p (Arith o:xs) = parse q (Prim o:p) xs
+parse q p (Identifier i:xs) = parse q (Symbol i:p) xs
 
-toAst (Const v) = Right $ AstConst v
-toAst (Prim o) = Right $ AstPrim o
+toAst (Const v) = Right $ ConstExp v
+toAst (Prim o) = Right $ PrimExp o
+toAst (Symbol x) = Left $ "Unrecognised symbol " <> x
 toAst (ExpList []) = Left "Empty S expression"
+toAst (ExpList [Symbol "if", c, x, y]) = Cond <$> toAst c <*> toAst x <*> toAst y
+toAst (ExpList (Symbol "if":_)) = Left "Wrong number of arguments to if"
+toAst (ExpList [Symbol "eq?", x, y]) = Equiv <$> toAst x <*> toAst y
+toAst (ExpList [Symbol "begin"]) = Left "Wrong number of arguments to begin"
+toAst (ExpList (Symbol "begin":xs)) = Begin <$> mapM toAst xs
+toAst (ExpList [Symbol "display", x]) = Display <$> toAst x
+toAst (ExpList (Symbol "display":_)) = Left "Wrong number of arguments to display"
 toAst (ExpList xs) = liftM2 Apply head tail <$> mapM toAst xs

From 55adac29e919cb0d8e78b89e09d323bf5a956099 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 14 Jan 2025 03:11:44 +0000
Subject: [PATCH 008/100] Scheme arithmetic semantics

---
 compiler/scheme/scheme_astScript.sml       | 16 ++++++++-
 compiler/scheme/scheme_semanticsScript.sml | 38 ++++++++++++++++++++++
 2 files changed, 53 insertions(+), 1 deletion(-)
 create mode 100644 compiler/scheme/scheme_semanticsScript.sml

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index e6ca596f23..ebf598f6bc 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -8,7 +8,21 @@ val _ = new_theory "scheme_ast";
 
 (* This needs completing: Var, Lit, ... *)
 Datatype:
-  exp = Print mlstring
+  prim = SAdd | SMul
+End
+
+Datatype:
+  val = Prim prim | SNum num | Wrong string
+End
+
+Datatype:
+  exp = Print mlstring | Apply exp (exp list) | Val val
+End
+
+Definition exp_size_def:
+  exp_size (Val _) = 0 ∧
+  exp_size (Print _) = 0 ∧
+  exp_size (Apply fn args) = 1
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
new file mode 100644
index 0000000000..3fe7ad3652
--- /dev/null
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -0,0 +1,38 @@
+(*
+  Semantics of Scheme
+*)
+open preamble;
+open mlstringTheory;
+open scheme_astTheory;
+
+val _ = new_theory "scheme_semantics";
+
+Definition sadd_def:
+  sadd [] n = SNum n ∧
+  sadd (SNum m :: xs) n = sadd xs (m + n) ∧
+  sadd (_ :: xs) _ = Wrong "Arguments to + must be numbers"
+End
+
+Definition smul_def:
+  smul [] n = SNum n ∧
+  smul (SNum m :: xs) n = smul xs (m * n) ∧
+  smul (_ :: xs) _ = Wrong "Arguments to * must be numbers"
+End
+
+Definition strict_def:
+  strict (Prim SAdd) xs = sadd xs 0 ∧
+  strict (Prim SMul) xs = smul xs 1
+End
+
+Definition semantics_def:
+  semantics (Val v) = v ∧
+  semantics (Apply fn args) = strict (semantics fn) (MAP semantics args)
+Termination
+  WF_REL_TAC ‘measure exp_size’
+End
+
+(*EVAL “semantics (Val (SNum 3))”*)
+(*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
+(*EVAL “measure”*)
+
+val _ = export_theory();
\ No newline at end of file

From d1cf84430102ed94a2d478b6b0ad07bcdfb10b5c Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 14 Jan 2025 17:48:24 +0000
Subject: [PATCH 009/100] exp_size dup

---
 compiler/scheme/scheme_astScript.sml | 6 ------
 1 file changed, 6 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index ebf598f6bc..20587af8f4 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -19,10 +19,4 @@ Datatype:
   exp = Print mlstring | Apply exp (exp list) | Val val
 End
 
-Definition exp_size_def:
-  exp_size (Val _) = 0 ∧
-  exp_size (Print _) = 0 ∧
-  exp_size (Apply fn args) = 1
-End
-
 val _ = export_theory();

From e4604fc0ece30d1dbe844c98e48246d6e48c140c Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 15 Jan 2025 01:38:21 +0000
Subject: [PATCH 010/100] Unverified lambdas/procedures (no parsing, compiler
 broken)

---
 compiler/scheme/unverified/Interpreter.hs | 32 ++++++++++++++---------
 compiler/scheme/unverified/Scheme.hs      | 21 +++++++--------
 2 files changed, 29 insertions(+), 24 deletions(-)

diff --git a/compiler/scheme/unverified/Interpreter.hs b/compiler/scheme/unverified/Interpreter.hs
index 963bf617dc..910179071e 100644
--- a/compiler/scheme/unverified/Interpreter.hs
+++ b/compiler/scheme/unverified/Interpreter.hs
@@ -3,21 +3,27 @@ import Scheme
 import Control.Monad (liftM2, (<=<), foldM, liftM3)
 import System.IO (hPutStrLn, stderr)
 import Data.Bool (bool)
+import Data.Map.Strict (Map, empty, (!?), singleton, union, fromList)
 
-strict:: Exp -> IO Exp
-strict (Apply (PrimExp Plus) xs) = ConstExp . SNum <$> foldM add 0 xs where
-    add n (ConstExp (SNum x)) = return $ n + x
+strict :: Map String SValue -> SValue -> [SValue] -> IO SValue
+strict store (Proc params exps) xs = if length params == length xs
+    then last <$> mapM (evaluate $ union (fromList $ zip params xs) store) exps
+    else fail "Wrong number of arguments"
+strict _ (SPrim Plus) xs = SNum <$> foldM add 0 xs where
+    add n (SNum x) = return $ n + x
     add _ _ = fail "Argument to + must be a number"
-strict (Apply (PrimExp Multiply) xs) = ConstExp . SNum <$> foldM multiply 1 xs where
-    multiply n (ConstExp (SNum x)) = return $ n * x
+strict _ (SPrim Multiply) xs = SNum <$> foldM multiply 1 xs where
+    multiply n (SNum x) = return $ n * x
     multiply _ _ = fail "Argument to * must be a number"
 
-evaluate :: Exp -> IO Exp
-evaluate (Apply fn xs) = strict =<< liftM2 Apply (evaluate fn) (mapM evaluate xs)
-evaluate (Cond c x y) = evaluate . bool y x . (ConstExp (SBool False) /=) =<< evaluate c
-evaluate (Equiv x y) = ConstExp . SBool <$> ((==) <$> evaluate x <*> evaluate y)
-evaluate (Begin xs) = foldM (const evaluate) Unit xs
-evaluate (Display x) = (print =<< evaluate x) >> return Unit
-evaluate x = return x
+evaluate :: Map String SValue -> Exp -> IO SValue
+evaluate store (Apply fn xs) = (mapM (evaluate store) xs >>=) . strict store =<< evaluate store fn
+evaluate store (Cond c x y) = evaluate store . bool y x . (SBool False /=) =<< evaluate store c
+evaluate store (Equiv x y) = SBool <$> ((==) <$> evaluate store x <*> evaluate store y)
+evaluate store (Begin xs) = foldM (const $ evaluate store) Unit xs
+evaluate store (Display x) = (print =<< evaluate store x) >> return Unit
+evaluate store (SIdentifier i) = maybe (fail $ "Symbol " <> i <> " has no definition") return $ store !? i
+evaluate store (Lambda params xs) = return $ Proc params xs
+evaluate store (Val v) = return v
 
-main = (either fail (evaluate . head) . (mapM toAst <=< parse [] [] <=< schlex [])) =<< getContents
+main = (either fail (mapM $ evaluate $ singleton "x" $ Proc ["y"] [Apply (Val (SPrim Multiply)) [Val (SNum 2), SIdentifier "y"]]) . (mapM toAst <=< parse [] [] <=< schlex [])) =<< getContents
diff --git a/compiler/scheme/unverified/Scheme.hs b/compiler/scheme/unverified/Scheme.hs
index abf061c2e0..6286081968 100644
--- a/compiler/scheme/unverified/Scheme.hs
+++ b/compiler/scheme/unverified/Scheme.hs
@@ -9,15 +9,16 @@ import Data.Tuple (swap)
 
 data ArithOp = Plus | Minus | Multiply
     deriving (Show, Eq)
-data Token = Open | Close | Value SValue | Arith ArithOp | Identifier String
+data Token = Open | Close | Value SValue | Identifier String
     deriving Show
 
-data Datum = ExpList [Datum] | Const SValue | Prim ArithOp | Symbol String
+data Datum = ExpList [Datum] | Const SValue | Symbol String
     deriving Show
-data SValue = SNum Int | SBool Bool
+data SValue = SNum Int | SBool Bool | SPrim ArithOp | Unit | Proc [String] [Exp]
     deriving (Show, Eq)
 
-data Exp = Apply Exp [Exp] | Cond Exp Exp Exp | Equiv Exp Exp | Begin [Exp] | ConstExp SValue | PrimExp ArithOp | Display Exp | Unit
+data Exp = Apply Exp [Exp] | Cond Exp Exp Exp | Equiv Exp Exp | Begin [Exp]
+    | Val SValue | Display Exp | SIdentifier String | Lambda [String] [Exp]
     deriving (Show, Eq)
 
 delimitsNext [] = True
@@ -30,9 +31,9 @@ lexSymb (']':xs) = Nothing
 lexSymb ('"':xs) = Nothing
 lexSymb ('#':xs) = Nothing
 lexSymb (';':xs) = Nothing
-lexSymb ('+':xs) = Just (xs, Arith Plus)
-lexSymb ('-':xs) = Just (xs, Arith Minus)
-lexSymb ('*':xs) = Just (xs, Arith Multiply)
+lexSymb ('+':xs) = Just (xs, Value $ SPrim Plus)
+lexSymb ('-':xs) = Just (xs, Value $ SPrim Minus)
+lexSymb ('*':xs) = Just (xs, Value $ SPrim Multiply)
 lexSymb _ = Nothing
 
 lexBool ('#':x:xs)
@@ -64,12 +65,10 @@ parse q p (Close:xs) = parse (ExpList p:q) [] xs
 parse (ExpList q':q) p (Open:xs) = parse q (ExpList p:q') xs
 parse _ _ (Open:_) = Left "Too many open brackets"
 parse q p (Value v:xs) = parse q (Const v:p) xs
-parse q p (Arith o:xs) = parse q (Prim o:p) xs
 parse q p (Identifier i:xs) = parse q (Symbol i:p) xs
 
-toAst (Const v) = Right $ ConstExp v
-toAst (Prim o) = Right $ PrimExp o
-toAst (Symbol x) = Left $ "Unrecognised symbol " <> x
+toAst (Const v) = Right $ Val v
+toAst (Symbol x) = Right $ SIdentifier x
 toAst (ExpList []) = Left "Empty S expression"
 toAst (ExpList [Symbol "if", c, x, y]) = Cond <$> toAst c <*> toAst x <*> toAst y
 toAst (ExpList (Symbol "if":_)) = Left "Wrong number of arguments to if"

From 3eda629df625b5b150ee828eefc8fface7430758 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 15 Jan 2025 13:40:53 +0000
Subject: [PATCH 011/100] Small-step semantics

---
 compiler/scheme/scheme_semanticsScript.sml | 21 ++++++++++++++++++++-
 1 file changed, 20 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 3fe7ad3652..9126c4ecf6 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -7,6 +7,10 @@ open scheme_astTheory;
 
 val _ = new_theory "scheme_semantics";
 
+Datatype:
+  cont = ApplyK ((val # val list) option) (exp list)
+End
+
 Definition sadd_def:
   sadd [] n = SNum n ∧
   sadd (SNum m :: xs) n = sadd xs (m + n) ∧
@@ -31,8 +35,23 @@ Termination
   WF_REL_TAC ‘measure exp_size’
 End
 
+Definition return_def:
+  return ([], v) = ([], Val v) ∧
+  return (ApplyK NONE eargs :: ks, v) = (case eargs of
+  | [] => (ks, Val $ strict v [])
+  | e::es => (ApplyK (SOME (v, [])) es :: ks, e)) ∧
+  return (ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
+  | [] => (ks, Val $ strict vfn (REVERSE $ v::vargs))
+  | e::es => (ApplyK (SOME (vfn, v::vargs)) es ::ks, e))
+End
+
+Definition step_def:
+  step (ks, Val v) = return (ks, v) ∧
+  step (ks, Apply fn args) = (ApplyK NONE args :: ks, fn)
+End
+
 (*EVAL “semantics (Val (SNum 3))”*)
 (*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
-(*EVAL “measure”*)
+(*EVAL “step (step (step ([], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])))”*)
 
 val _ = export_theory();
\ No newline at end of file

From 8d9ae793ef340c321231bfdf2f6240c702fdb0aa Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 28 Jan 2025 00:13:24 +0000
Subject: [PATCH 012/100] bools, conds, and rough let bindings implementation

---
 compiler/scheme/scheme_astScript.sml       |  9 ++++-
 compiler/scheme/scheme_semanticsScript.sml | 45 +++++++++++++++++-----
 2 files changed, 42 insertions(+), 12 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 20587af8f4..4978a5b911 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -12,11 +12,16 @@ Datatype:
 End
 
 Datatype:
-  val = Prim prim | SNum num | Wrong string
+  val = Prim prim | SNum num | Wrong string | SBool bool
 End
 
 Datatype:
-  exp = Print mlstring | Apply exp (exp list) | Val val
+  exp = Print mlstring
+      | Apply exp (exp list)
+      | Val val
+      | Cond exp exp exp
+      | Ident mlstring
+      | SLet ((mlstring # exp) list) exp
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 9126c4ecf6..751a79021e 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -9,6 +9,8 @@ val _ = new_theory "scheme_semantics";
 
 Datatype:
   cont = ApplyK ((val # val list) option) (exp list)
+       | CondK exp exp
+       | LetK mlstring ((mlstring # exp) list) exp
 End
 
 Definition sadd_def:
@@ -36,22 +38,45 @@ Termination
 End
 
 Definition return_def:
-  return ([], v) = ([], Val v) ∧
-  return (ApplyK NONE eargs :: ks, v) = (case eargs of
-  | [] => (ks, Val $ strict v [])
-  | e::es => (ApplyK (SOME (v, [])) es :: ks, e)) ∧
-  return (ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
-  | [] => (ks, Val $ strict vfn (REVERSE $ v::vargs))
-  | e::es => (ApplyK (SOME (vfn, v::vargs)) es ::ks, e))
+  return (env, [], v) = (env, [], Val v) ∧
+
+  return (env, ApplyK NONE eargs :: ks, v) = (case eargs of
+  | [] => (env, ks, Val $ strict v [])
+  | e::es => (env, ApplyK (SOME (v, [])) es :: ks, e)) ∧
+  return (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
+  | [] => (env, ks, Val $ strict vfn (REVERSE $ v::vargs))
+  | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
+
+  return (env, CondK t f :: ks, cv) = (if cv = (SBool F)
+    then (env, ks, f) else (env, ks, t)) ∧
+
+  return (env, LetK i is e :: ks, v) = let env' = (i, v)::env in case is of
+  | [] => (env', ks, e)
+  | (i', e')::is' => (env', LetK i' is' e :: ks, e')
 End
 
 Definition step_def:
-  step (ks, Val v) = return (ks, v) ∧
-  step (ks, Apply fn args) = (ApplyK NONE args :: ks, fn)
+  step (env, ks, Val v) = return (env, ks, v) ∧
+  step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
+  step (env, ks, Cond c t f) = (env, CondK t f :: ks, c) ∧
+  step (env, ks, Ident s) = (let v' = case FIND ($= s o FST) env of
+    | NONE => Wrong "Unrecognised identifier"
+    | SOME (_, v) => v
+    in return (env, ks, v')) ∧
+  step (env, ks, SLet is e) = case is of
+  | [] => (env, ks, e)
+  | (i, e')::is' => (env, LetK i is' e :: ks, e')
+End
+
+Definition steps_def:
+  steps (n:num) t = if n = 0 then t
+    else steps (n - 1) $ step t
 End
 
 (*EVAL “semantics (Val (SNum 3))”*)
 (*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
-(*EVAL “step (step (step ([], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])))”*)
+(*EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
+(*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
+(*EVAL “steps 3 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
 
 val _ = export_theory();
\ No newline at end of file

From b49db3a1743076bce6ad36542684b9e372faac10 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 28 Jan 2025 00:19:35 +0000
Subject: [PATCH 013/100] README

---
 compiler/scheme/README.md | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/compiler/scheme/README.md b/compiler/scheme/README.md
index 953a3c0cac..1e58de6e84 100644
--- a/compiler/scheme/README.md
+++ b/compiler/scheme/README.md
@@ -15,6 +15,9 @@ Definition of a compiler from Scheme to CakeML
 [scheme_parsingScript.sml](scheme_parsingScript.sml):
 Parser for Scheme
 
+[scheme_semanticsScript.sml](scheme_semanticsScript.sml):
+Semantics of Scheme
+
 [scheme_to_cakeScript.sml](scheme_to_cakeScript.sml):
 Code generator for Scheme to CakeML compiler
 

From 81431ef4f29a70d988056cd9a30a3906165317b2 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 31 Jan 2025 18:14:36 +0000
Subject: [PATCH 014/100] scoped lets

---
 compiler/scheme/scheme_semanticsScript.sml | 19 +++++++++++--------
 1 file changed, 11 insertions(+), 8 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 751a79021e..dfac9a81db 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -10,7 +10,8 @@ val _ = new_theory "scheme_semantics";
 Datatype:
   cont = ApplyK ((val # val list) option) (exp list)
        | CondK exp exp
-       | LetK mlstring ((mlstring # exp) list) exp
+       | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
+       | InLetK ((mlstring # val) list)
 End
 
 Definition sadd_def:
@@ -47,12 +48,14 @@ Definition return_def:
   | [] => (env, ks, Val $ strict vfn (REVERSE $ v::vargs))
   | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
 
-  return (env, CondK t f :: ks, cv) = (if cv = (SBool F)
+  return (env, CondK t f :: ks, v) = (if v = (SBool F)
     then (env, ks, f) else (env, ks, t)) ∧
 
-  return (env, LetK i is e :: ks, v) = let env' = (i, v)::env in case is of
-  | [] => (env', ks, e)
-  | (i', e')::is' => (env', LetK i' is' e :: ks, e')
+  return (env, LetK env' i is e :: ks, v) = (case is of
+  | [] => ((i, v)::env', InLetK env :: ks, e)
+  | (i', e')::is' => (env, LetK ((i, v)::env') i' is' e :: ks, e')) ∧
+
+  return (env, InLetK env' :: ks, v) = (env', ks, Val v)
 End
 
 Definition step_def:
@@ -62,10 +65,10 @@ Definition step_def:
   step (env, ks, Ident s) = (let v' = case FIND ($= s o FST) env of
     | NONE => Wrong "Unrecognised identifier"
     | SOME (_, v) => v
-    in return (env, ks, v')) ∧
+    in (env, ks, Val v')) ∧
   step (env, ks, SLet is e) = case is of
   | [] => (env, ks, e)
-  | (i, e')::is' => (env, LetK i is' e :: ks, e')
+  | (i, e')::is' => (env, LetK env i is' e :: ks, e')
 End
 
 Definition steps_def:
@@ -77,6 +80,6 @@ End
 (*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
 (*EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
 (*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
-(*EVAL “steps 3 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
+(*EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
 
 val _ = export_theory();
\ No newline at end of file

From 4e3412fb1bfd349f719bd1978fe0cf53888253a3 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 31 Jan 2025 23:24:05 +0000
Subject: [PATCH 015/100] lambdas

---
 compiler/scheme/scheme_astScript.sml       |  8 ++++---
 compiler/scheme/scheme_semanticsScript.sml | 25 ++++++++++++++++++----
 2 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 4978a5b911..16ae67a6ff 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -13,15 +13,17 @@ End
 
 Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
-End
-
-Datatype:
+      | SList (val list)
+      | Exception mlstring
+      | Proc ((mlstring # val) list) (mlstring list) (mlstring option) exp
+;
   exp = Print mlstring
       | Apply exp (exp list)
       | Val val
       | Cond exp exp exp
       | Ident mlstring
       | SLet ((mlstring # exp) list) exp
+      | Lambda (mlstring list) (mlstring option) exp
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index dfac9a81db..c22f2e17bc 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -38,14 +38,29 @@ Termination
   WF_REL_TAC ‘measure exp_size’
 End
 
+Definition parameterize_def:
+  parameterize env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
+  parameterize env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
+  parameterize env ks env' (p::ps) lp e (x::xs) = parameterize env ks ((p, x)::env') ps lp e xs ∧
+  parameterize env ks _ _ _ _ _ = (env, ks, Val $ Exception $ strlit "Wrong number of arguments")
+End
+
+Definition application_def:
+  application env ks (Prim p) xs = (case p of
+  | SAdd => (env, ks, Val $ sadd xs 0)
+  | SMul => (env, ks, Val $ smul xs 1)) ∧
+  application env ks (Proc env' ps lp e) xs =
+    parameterize env ks env' ps lp e xs
+End
+
 Definition return_def:
   return (env, [], v) = (env, [], Val v) ∧
 
   return (env, ApplyK NONE eargs :: ks, v) = (case eargs of
-  | [] => (env, ks, Val $ strict v [])
+  | [] => application env ks v []
   | e::es => (env, ApplyK (SOME (v, [])) es :: ks, e)) ∧
   return (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
-  | [] => (env, ks, Val $ strict vfn (REVERSE $ v::vargs))
+  | [] => application env ks vfn (REVERSE $ v::vargs)
   | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
 
   return (env, CondK t f :: ks, v) = (if v = (SBool F)
@@ -66,9 +81,10 @@ Definition step_def:
     | NONE => Wrong "Unrecognised identifier"
     | SOME (_, v) => v
     in (env, ks, Val v')) ∧
-  step (env, ks, SLet is e) = case is of
+  step (env, ks, SLet is e) = (case is of
   | [] => (env, ks, e)
-  | (i, e')::is' => (env, LetK env i is' e :: ks, e')
+  | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
+  step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e)
 End
 
 Definition steps_def:
@@ -81,5 +97,6 @@ End
 (*EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
 (*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
 (*EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
+(*EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”*)
 
 val _ = export_theory();
\ No newline at end of file

From bf895814b82c8304676c558ec80efc478f581d0b Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 31 Jan 2025 23:36:50 +0000
Subject: [PATCH 016/100] propagate exceptions

---
 compiler/scheme/scheme_astScript.sml       |  2 +-
 compiler/scheme/scheme_semanticsScript.sml | 22 ++++++++++++++--------
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 16ae67a6ff..8cd0815c8e 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -14,7 +14,6 @@ End
 Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
-      | Exception mlstring
       | Proc ((mlstring # val) list) (mlstring list) (mlstring option) exp
 ;
   exp = Print mlstring
@@ -24,6 +23,7 @@ Datatype:
       | Ident mlstring
       | SLet ((mlstring # exp) list) exp
       | Lambda (mlstring list) (mlstring option) exp
+      | Exception mlstring
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index c22f2e17bc..86dae98620 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -15,17 +15,18 @@ Datatype:
 End
 
 Definition sadd_def:
-  sadd [] n = SNum n ∧
+  sadd [] n = Val $ SNum n ∧
   sadd (SNum m :: xs) n = sadd xs (m + n) ∧
-  sadd (_ :: xs) _ = Wrong "Arguments to + must be numbers"
+  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
 End
 
 Definition smul_def:
-  smul [] n = SNum n ∧
+  smul [] n = Val $ SNum n ∧
   smul (SNum m :: xs) n = smul xs (m * n) ∧
-  smul (_ :: xs) _ = Wrong "Arguments to * must be numbers"
+  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
 End
 
+(*
 Definition strict_def:
   strict (Prim SAdd) xs = sadd xs 0 ∧
   strict (Prim SMul) xs = smul xs 1
@@ -37,18 +38,19 @@ Definition semantics_def:
 Termination
   WF_REL_TAC ‘measure exp_size’
 End
+*)
 
 Definition parameterize_def:
   parameterize env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
   parameterize env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
   parameterize env ks env' (p::ps) lp e (x::xs) = parameterize env ks ((p, x)::env') ps lp e xs ∧
-  parameterize env ks _ _ _ _ _ = (env, ks, Val $ Exception $ strlit "Wrong number of arguments")
+  parameterize env ks _ _ _ _ _ = (env, ks, Exception $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
   application env ks (Prim p) xs = (case p of
-  | SAdd => (env, ks, Val $ sadd xs 0)
-  | SMul => (env, ks, Val $ smul xs 1)) ∧
+  | SAdd => (env, ks, sadd xs 0)
+  | SMul => (env, ks, smul xs 1)) ∧
   application env ks (Proc env' ps lp e) xs =
     parameterize env ks env' ps lp e xs
 End
@@ -84,7 +86,10 @@ Definition step_def:
   step (env, ks, SLet is e) = (case is of
   | [] => (env, ks, e)
   | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
-  step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e)
+  step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧
+
+  step (env, k::ks, Exception ex) = (env, ks, Exception ex) ∧
+  step t = t
 End
 
 Definition steps_def:
@@ -95,6 +100,7 @@ End
 (*EVAL “semantics (Val (SNum 3))”*)
 (*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
 (*EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
+(*EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”*)
 (*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
 (*EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
 (*EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”*)

From e5030a28374f112db1a2ac8494bee3a7218aeb7f Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Mon, 3 Feb 2025 18:05:44 +0000
Subject: [PATCH 017/100] 1-step stack unwind

---
 compiler/scheme/scheme_semanticsScript.sml | 29 ++++++++++++++--------
 1 file changed, 19 insertions(+), 10 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 86dae98620..37aeae4127 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -8,6 +8,7 @@ open scheme_astTheory;
 val _ = new_theory "scheme_semantics";
 
 Datatype:
+  (*Contexts for small-step operational semantics*)
   cont = ApplyK ((val # val list) option) (exp list)
        | CondK exp exp
        | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
@@ -52,7 +53,8 @@ Definition application_def:
   | SAdd => (env, ks, sadd xs 0)
   | SMul => (env, ks, smul xs 1)) ∧
   application env ks (Proc env' ps lp e) xs =
-    parameterize env ks env' ps lp e xs
+    parameterize env ks env' ps lp e xs ∧
+  application env ks _ _ = (env, ks, Exception $ strlit "Not a procedure")
 End
 
 Definition return_def:
@@ -75,6 +77,11 @@ Definition return_def:
   return (env, InLetK env' :: ks, v) = (env', ks, Val v)
 End
 
+Definition unwind_def:
+  unwind env [] ex = (env, [], Exception ex) ∧
+  unwind env (k::ks) ex = unwind env ks ex
+End
+
 Definition step_def:
   step (env, ks, Val v) = return (env, ks, v) ∧
   step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
@@ -88,8 +95,7 @@ Definition step_def:
   | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
   step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧
 
-  step (env, k::ks, Exception ex) = (env, ks, Exception ex) ∧
-  step t = t
+  step (env, ks, Exception ex) = unwind env ks ex
 End
 
 Definition steps_def:
@@ -97,12 +103,15 @@ Definition steps_def:
     else steps (n - 1) $ step t
 End
 
-(*EVAL “semantics (Val (SNum 3))”*)
-(*EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
-(*EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”*)
-(*EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”*)
-(*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
-(*EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
-(*EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”*)
+(*
+  EVAL “semantics (Val (SNum 3))”
+  EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
+  EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
+  EVAL “steps 4 ([], [], Apply (Val (SNum 7)) [Val (SNum 2); Val (SNum 4)])”
+  EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
+  EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”
+  EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”
+  EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”
+*)
 
 val _ = export_theory();
\ No newline at end of file

From 419e5a5f30a1c4a6de6dbaca703496ad2077bcbd Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Mon, 3 Feb 2025 18:49:40 +0000
Subject: [PATCH 018/100] begin

---
 compiler/scheme/scheme_astScript.sml       | 1 +
 compiler/scheme/scheme_semanticsScript.sml | 8 +++++++-
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 8cd0815c8e..a4639d11a3 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -24,6 +24,7 @@ Datatype:
       | SLet ((mlstring # exp) list) exp
       | Lambda (mlstring list) (mlstring option) exp
       | Exception mlstring
+      | Begin exp (exp list)
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 86dae98620..f35c2cc6ec 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -12,6 +12,7 @@ Datatype:
        | CondK exp exp
        | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
        | InLetK ((mlstring # val) list)
+       | BeginK (exp list)
 End
 
 Definition sadd_def:
@@ -72,7 +73,10 @@ Definition return_def:
   | [] => ((i, v)::env', InLetK env :: ks, e)
   | (i', e')::is' => (env, LetK ((i, v)::env') i' is' e :: ks, e')) ∧
 
-  return (env, InLetK env' :: ks, v) = (env', ks, Val v)
+  return (env, InLetK env' :: ks, v) = (env', ks, Val v) ∧
+  return (env, BeginK es :: ks, v) = case es of
+  | [] => (env, ks, Val v)
+  | e::es' => (env, BeginK es' :: ks, e)
 End
 
 Definition step_def:
@@ -87,6 +91,7 @@ Definition step_def:
   | [] => (env, ks, e)
   | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
   step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧
+  step (env, ks, Begin e es) = (env, BeginK es :: ks, e) ∧
 
   step (env, k::ks, Exception ex) = (env, ks, Exception ex) ∧
   step t = t
@@ -104,5 +109,6 @@ End
 (*EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”*)
 (*EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”*)
 (*EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”*)
+(*EVAL “steps 3 ([], [], Begin (Val $ SNum 1) [Val $ SNum 2])”*)
 
 val _ = export_theory();
\ No newline at end of file

From ea0798a36d95c34c421e5e391156c9863e99229b Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Mon, 3 Feb 2025 20:41:41 +0000
Subject: [PATCH 019/100] correction

---
 compiler/scheme/scheme_semanticsScript.sml | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 3b54d0d6c8..167e1d7d55 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -86,11 +86,6 @@ Definition unwind_def:
   unwind env (k::ks) ex = unwind env ks ex
 End
 
-Definition unwind_def:
-  unwind env [] ex = (env, [], Exception ex) ∧
-  unwind env (k::ks) ex = unwind env ks ex
-End
-
 Definition step_def:
   step (env, ks, Val v) = return (env, ks, v) ∧
   step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧

From 020f81b77ae17bd483538a078fa509d00a4dc286 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 7 Feb 2025 17:09:51 +0000
Subject: [PATCH 020/100] cps transform, prims only

---
 compiler/scheme/cpscheme_astScript.sml       | 17 +++++
 compiler/scheme/cpscheme_semanticsScript.sml | 22 ++++++
 compiler/scheme/scheme_astScript.sml         |  8 ++-
 compiler/scheme/scheme_semanticsScript.sml   | 72 ++++++++++----------
 compiler/scheme/scheme_to_cpschemeScript.sml | 20 ++++++
 5 files changed, 100 insertions(+), 39 deletions(-)
 create mode 100644 compiler/scheme/cpscheme_astScript.sml
 create mode 100644 compiler/scheme/cpscheme_semanticsScript.sml
 create mode 100644 compiler/scheme/scheme_to_cpschemeScript.sml

diff --git a/compiler/scheme/cpscheme_astScript.sml b/compiler/scheme/cpscheme_astScript.sml
new file mode 100644
index 0000000000..87d5aeb4bb
--- /dev/null
+++ b/compiler/scheme/cpscheme_astScript.sml
@@ -0,0 +1,17 @@
+(*
+  AST of CPScheme
+*)
+open preamble;
+open mlstringTheory;
+open scheme_astTheory;
+
+val _ = new_theory "cpscheme_ast";
+
+Datatype:
+  cexp = CVal ((*cexp*) val)             (*λk.k val*)
+       | CException mlstring  (**)
+       | Call cexp (cexp cont)       (*λk.cexp (cont o k)*)
+       (*| CLambda (mlstring list) (mlstring option) cexp*)
+End
+
+val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/cpscheme_semanticsScript.sml b/compiler/scheme/cpscheme_semanticsScript.sml
new file mode 100644
index 0000000000..1d8af4ac87
--- /dev/null
+++ b/compiler/scheme/cpscheme_semanticsScript.sml
@@ -0,0 +1,22 @@
+(*
+  Semantics of CPScheme
+*)
+open preamble;
+open mlstringTheory;
+open scheme_astTheory;
+open cpscheme_astTheory;
+
+Definition reduce_def:
+  reduce (env, ks, (CVal v)) = return CVal CException ([], ks, v) ∧
+  reduce (env, ks, (Call c k)) = (env, (k::ks), c)
+End
+
+Definition many_reduce_def:
+  many_reduce (n:num) c = if n = 0 then c
+    else many_reduce (n - 1) $ reduce c
+End
+
+(*
+  EVAL “many_reduce 4 ([], [], (cps_transform (Cond (Cond (Val $ SBool F) (Val $ SBool T) (Val $ SBool F)) (Val $ SNum 2) (Val $ SNum 4))))”
+  EVAL “many_reduce 2 ([], [], (cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])))”
+*)
\ No newline at end of file
diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index a4639d11a3..e982066bc7 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -14,11 +14,13 @@ End
 Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
-      | Proc ((mlstring # val) list) (mlstring list) (mlstring option) exp
-;
+      (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) 'a*)
+End
+
+Datatype:
   exp = Print mlstring
       | Apply exp (exp list)
-      | Val val
+      | Val ((*exp*) val)
       | Cond exp exp exp
       | Ident mlstring
       | SLet ((mlstring # exp) list) exp
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 167e1d7d55..a5304afcf3 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -9,23 +9,23 @@ val _ = new_theory "scheme_semantics";
 
 Datatype:
   (*Contexts for small-step operational semantics*)
-  cont = ApplyK ((val # val list) option) (exp list)
-       | CondK exp exp
-       | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
-       | InLetK ((mlstring # val) list)
-       | BeginK (exp list)
+  cont = ApplyK (((*'a*) val # (*'a*) val list) option) ('a list)
+       | CondK 'a 'a
+       | LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
+       | InLetK ((mlstring # (*'a*) val) list)
+       | BeginK ('a list)
 End
 
 Definition sadd_def:
-  sadd [] n = Val $ SNum n ∧
-  sadd (SNum m :: xs) n = sadd xs (m + n) ∧
-  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
+  sadd vcons _ [] n = vcons $ SNum n ∧
+  sadd vcons excons (SNum m :: xs) n = sadd vcons excons xs (m + n) ∧
+  sadd _ excons (_ :: xs) _ = excons $ strlit "Arguments to + must be numbers"
 End
 
 Definition smul_def:
-  smul [] n = Val $ SNum n ∧
-  smul (SNum m :: xs) n = smul xs (m * n) ∧
-  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
+  smul vcons _ [] n = vcons $ SNum n ∧
+  smul vcons excons (SNum m :: xs) n = smul vcons excons xs (m * n) ∧
+  smul _ excons (_ :: xs) _ = excons $ strlit "Arguments to * must be numbers"
 End
 
 (*
@@ -43,51 +43,51 @@ End
 *)
 
 Definition parameterize_def:
-  parameterize env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
-  parameterize env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
-  parameterize env ks env' (p::ps) lp e (x::xs) = parameterize env ks ((p, x)::env') ps lp e xs ∧
-  parameterize env ks _ _ _ _ _ = (env, ks, Exception $ strlit "Wrong number of arguments")
+  parameterize _ env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
+  parameterize _ env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
+  parameterize excons env ks env' (p::ps) lp e (x::xs) = parameterize excons env ks ((p, x)::env') ps lp e xs ∧
+  parameterize excons env ks _ _ _ _ _ = (env, ks, excons $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
-  application env ks (Prim p) xs = (case p of
-  | SAdd => (env, ks, sadd xs 0)
-  | SMul => (env, ks, smul xs 1)) ∧
-  application env ks (Proc env' ps lp e) xs =
-    parameterize env ks env' ps lp e xs ∧
-  application env ks _ _ = (env, ks, Exception $ strlit "Not a procedure")
+  application vcons excons env ks (Prim p) xs = (case p of
+  | SAdd => (env, ks, sadd vcons excons xs 0)
+  | SMul => (env, ks, smul vcons excons xs 1)) ∧
+  (*application _ excons env ks (Proc env' ps lp e) xs =
+    parameterize excons env ks env' ps lp e xs ∧*)
+  application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
 End
 
 Definition return_def:
-  return (env, [], v) = (env, [], Val v) ∧
+  return vcons _ (env, [], v) = (env, [], vcons v) ∧
 
-  return (env, ApplyK NONE eargs :: ks, v) = (case eargs of
-  | [] => application env ks v []
+  return vcons excons (env, ApplyK NONE eargs :: ks, v) = (case eargs of
+  | [] => application vcons excons env ks v []
   | e::es => (env, ApplyK (SOME (v, [])) es :: ks, e)) ∧
-  return (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
-  | [] => application env ks vfn (REVERSE $ v::vargs)
+  return vcons excons (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
+  | [] => application vcons excons env ks vfn (REVERSE $ v::vargs)
   | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
 
-  return (env, CondK t f :: ks, v) = (if v = (SBool F)
+  return _ _ (env, CondK t f :: ks, v) = (if v = (SBool F)
     then (env, ks, f) else (env, ks, t)) ∧
 
-  return (env, LetK env' i is e :: ks, v) = (case is of
+  return _ _ (env, LetK env' i is e :: ks, v) = (case is of
   | [] => ((i, v)::env', InLetK env :: ks, e)
   | (i', e')::is' => (env, LetK ((i, v)::env') i' is' e :: ks, e')) ∧
 
-  return (env, InLetK env' :: ks, v) = (env', ks, Val v) ∧
-  return (env, BeginK es :: ks, v) = case es of
-  | [] => (env, ks, Val v)
+  return vcons _ (env, InLetK env' :: ks, v) = (env', ks, vcons v) ∧
+  return vcons _ (env, BeginK es :: ks, v) = case es of
+  | [] => (env, ks, vcons v)
   | e::es' => (env, BeginK es' :: ks, e)
 End
 
 Definition unwind_def:
-  unwind env [] ex = (env, [], Exception ex) ∧
-  unwind env (k::ks) ex = unwind env ks ex
+  unwind excons env [] ex = (env, [], excons ex) ∧
+  unwind excons env (k::ks) ex = unwind excons env ks ex
 End
 
 Definition step_def:
-  step (env, ks, Val v) = return (env, ks, v) ∧
+  step (env, ks, Val v) = return Val Exception (env, ks, v) ∧
   step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
   step (env, ks, Cond c t f) = (env, CondK t f :: ks, c) ∧
   step (env, ks, Ident s) = (let v' = case FIND ($= s o FST) env of
@@ -97,10 +97,10 @@ Definition step_def:
   step (env, ks, SLet is e) = (case is of
   | [] => (env, ks, e)
   | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
-  step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧
+  (*step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧*)
   step (env, ks, Begin e es) = (env, BeginK es :: ks, e) ∧
 
-  step (env, ks, Exception ex) = unwind env ks ex
+  step (env, ks, Exception ex) = unwind Exception env ks ex
 End
 
 Definition steps_def:
diff --git a/compiler/scheme/scheme_to_cpschemeScript.sml b/compiler/scheme/scheme_to_cpschemeScript.sml
new file mode 100644
index 0000000000..ff35a7302b
--- /dev/null
+++ b/compiler/scheme/scheme_to_cpschemeScript.sml
@@ -0,0 +1,20 @@
+(*
+  CPS transform on Scheme
+*)
+open preamble;
+open mlstringTheory;
+open scheme_astTheory;
+open cpscheme_astTheory;
+
+Definition cps_transform_def:
+  cps_transform (Val v) = CVal v ∧
+  cps_transform (Cond c t f) = Call (cps_transform c) (CondK (cps_transform t) (cps_transform f)) ∧
+  cps_transform (Apply fn args) = Call (cps_transform fn) (ApplyK NONE $ MAP cps_transform args)
+Termination
+  WF_REL_TAC ‘measure exp_size’
+End
+
+(*
+  EVAL “cps_transform (Cond (Val $ SBool F) (Val $ SNum 2) (Val $ SNum 4))”
+  EVAL “cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])”
+*)
\ No newline at end of file

From 19966020d856a7026d6fbc7e9a485eb8bad49bf5 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 9 Feb 2025 12:20:55 +0000
Subject: [PATCH 021/100] fix build

---
 compiler/scheme/cpscheme_astScript.sml       | 3 ++-
 compiler/scheme/cpscheme_semanticsScript.sml | 6 +++++-
 compiler/scheme/scheme_to_cpschemeScript.sml | 6 +++++-
 3 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/compiler/scheme/cpscheme_astScript.sml b/compiler/scheme/cpscheme_astScript.sml
index 87d5aeb4bb..57ce6365fe 100644
--- a/compiler/scheme/cpscheme_astScript.sml
+++ b/compiler/scheme/cpscheme_astScript.sml
@@ -4,13 +4,14 @@
 open preamble;
 open mlstringTheory;
 open scheme_astTheory;
+open scheme_semanticsTheory;
 
 val _ = new_theory "cpscheme_ast";
 
 Datatype:
   cexp = CVal ((*cexp*) val)             (*λk.k val*)
        | CException mlstring  (**)
-       | Call cexp (cexp cont)       (*λk.cexp (cont o k)*)
+       | Call cexp (cexp cont)       (*λk.cexp (k o cont)*)
        (*| CLambda (mlstring list) (mlstring option) cexp*)
 End
 
diff --git a/compiler/scheme/cpscheme_semanticsScript.sml b/compiler/scheme/cpscheme_semanticsScript.sml
index 1d8af4ac87..7c471c1696 100644
--- a/compiler/scheme/cpscheme_semanticsScript.sml
+++ b/compiler/scheme/cpscheme_semanticsScript.sml
@@ -6,6 +6,8 @@ open mlstringTheory;
 open scheme_astTheory;
 open cpscheme_astTheory;
 
+val _ = new_theory "cpscheme_semantics";
+
 Definition reduce_def:
   reduce (env, ks, (CVal v)) = return CVal CException ([], ks, v) ∧
   reduce (env, ks, (Call c k)) = (env, (k::ks), c)
@@ -19,4 +21,6 @@ End
 (*
   EVAL “many_reduce 4 ([], [], (cps_transform (Cond (Cond (Val $ SBool F) (Val $ SBool T) (Val $ SBool F)) (Val $ SNum 2) (Val $ SNum 4))))”
   EVAL “many_reduce 2 ([], [], (cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])))”
-*)
\ No newline at end of file
+*)
+
+val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cpschemeScript.sml b/compiler/scheme/scheme_to_cpschemeScript.sml
index ff35a7302b..17440050b6 100644
--- a/compiler/scheme/scheme_to_cpschemeScript.sml
+++ b/compiler/scheme/scheme_to_cpschemeScript.sml
@@ -6,6 +6,8 @@ open mlstringTheory;
 open scheme_astTheory;
 open cpscheme_astTheory;
 
+val _ = new_theory "scheme_to_cpscheme";
+
 Definition cps_transform_def:
   cps_transform (Val v) = CVal v ∧
   cps_transform (Cond c t f) = Call (cps_transform c) (CondK (cps_transform t) (cps_transform f)) ∧
@@ -17,4 +19,6 @@ End
 (*
   EVAL “cps_transform (Cond (Val $ SBool F) (Val $ SNum 2) (Val $ SNum 4))”
   EVAL “cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])”
-*)
\ No newline at end of file
+*)
+
+val _ = export_theory();
\ No newline at end of file

From 2a254c0321a264be8282aaad3cf5e5caf5965a47 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 9 Feb 2025 12:23:38 +0000
Subject: [PATCH 022/100] cpscheme to ml, missing prim defs

---
 compiler/scheme/cpscheme_to_cakeScript.sml | 113 +++++++++++++++++++++
 1 file changed, 113 insertions(+)
 create mode 100644 compiler/scheme/cpscheme_to_cakeScript.sml

diff --git a/compiler/scheme/cpscheme_to_cakeScript.sml b/compiler/scheme/cpscheme_to_cakeScript.sml
new file mode 100644
index 0000000000..bd3c563c74
--- /dev/null
+++ b/compiler/scheme/cpscheme_to_cakeScript.sml
@@ -0,0 +1,113 @@
+(*
+  Translation from CPScheme to CakeML
+*)
+open preamble;
+open astTheory;
+open mlstringTheory;
+open scheme_astTheory;
+open cpscheme_astTheory;
+
+val _ = new_theory "cpscheme_to_cake";
+
+Definition cexp_cont_size_def:
+  cexp_cont_size (ApplyK _ cs) = FOLDL (λ n c . n + cexp_size c) 0 cs ∧
+  cexp_cont_size (CondK c c') = cexp_size c + cexp_size c'
+End
+
+Definition to_ml_vals_def:
+  to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
+  | SAdd => Con (SOME $ Short "SAdd") []
+  | SMul => Con (SOME $ Short "SMul") []] ∧
+  to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit &n] ∧
+  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
+    if b then 1 else 0]
+End
+
+Definition cons_list_def:
+  cons_list [] = Con (SOME $ Short "nil") [] ∧
+  cons_list (x::xs) = Con (SOME $ Short "cons") [Var (Short x); cons_list xs]
+End
+
+Definition app_ml_def:
+  app_ml n = let
+    t = "t" ++ toString n;
+    rfex = Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit"Not a procedure"]
+  in
+    (n+1, Fun t $ Mat (Var (Short t)) [
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []], Var (Short "sadd"));
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []], Var (Short "smul"));
+      (Pany, rfex)
+    ])
+End
+
+Definition refunc_def:
+  refunc n (CVal v) = (let k = "k" ++ toString n in
+    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
+  refunc n (CException s) =
+    (n, Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit $ explode s]) ∧
+  refunc n (Call c k) = (let
+    (m, rfc) = refunc n c;
+    (l, rfk) = refunc_cont m k;
+    k' = "k" ++ toString l;
+    t = "t" ++ toString (l+1)
+  in
+    (*(l+2, Fun k' $ App Opapp [rfc;
+      Fun t $ App Opapp [Var (Short k'); App Opapp [rfk; Var (Short t)]]])) ∧*)
+
+    (*not tail-call?*)
+    (*(l+2, Fun k' $ App Opapp [App Opapp [rfc; rfk]; Var (Short k')])) ∧*)
+    (l+2, Fun k' $ App Opapp [rfc;
+      Fun t $ App Opapp [App Opapp [rfk; Var (Short t)]; Var (Short k')]])) ∧
+
+  refunc_cont n (CondK t f) = (let
+    (m, rft) = refunc n t;
+    (l, rff) = refunc m f;
+    p = "t" ++ toString l
+  in
+    (l+1, Fun p $ Mat (Var (Short p)) [
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], rff);
+      (Pany, rft)
+    ])) ∧
+  refunc_cont n (ApplyK NONE cs) = (let t = "t" ++ toString n in
+    case cs of
+    | [] => (n+1, Fun t (Var (Short t)))
+    | c::cs' => let
+      t = "t" ++ toString n;
+      (m, rfc) = refunc_app (n+1) t [] cs
+    in
+      (m+1, Fun t rfc)
+    ) ∧
+
+  refunc_app n tfn ts (c::cs) = (let
+    (m, rfc) = refunc n c;
+    t = "t" ++ toString m;
+    (l, inner) = refunc_app (m+1) tfn (t::ts) cs
+  in
+    (l, Fun t $ App Opapp [rfc; inner])) ∧
+  refunc_app n tfn ts [] = (let
+    (m, rfapp) = app_ml n;
+  in
+    (m, App Opapp [rfapp;Var (Short tfn);cons_list (REVERSE ts)]))
+Termination
+  WF_REL_TAC ‘measure $ λ x . case x of
+    | INL(_,c) => cexp_size c
+    | INR(INL(_,k)) => cexp_cont_size k
+    | INR(INR(_,_,_,cs)) => SUM (MAP cexp_size cs)’
+  >> rw[cexp_cont_size_def]
+  >>cheat
+End
+
+Definition scheme_program_to_cake_def:
+  scheme_program_to_cake p = App Opapp [SND (refunc 0 p); Fun "t" $ Var (Short "t")]
+End
+
+(*
+  open cpscheme_to_cakeTheory;
+  open scheme_to_cpschemeTheory;
+  open evaluateTheory;
+
+  EVAL “evaluate st env [scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]”
+  EVAL “refunc 0 (cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 2]))”
+*)
+
+val _ = export_theory();
\ No newline at end of file

From e48e630edd5e443dc3e1df4ac2c6df176975ce6f Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 9 Feb 2025 14:17:45 +0000
Subject: [PATCH 023/100] refunc termination proof

---
 compiler/scheme/cpscheme_to_cakeScript.sml | 11 ++---------
 1 file changed, 2 insertions(+), 9 deletions(-)

diff --git a/compiler/scheme/cpscheme_to_cakeScript.sml b/compiler/scheme/cpscheme_to_cakeScript.sml
index bd3c563c74..57e2a23c37 100644
--- a/compiler/scheme/cpscheme_to_cakeScript.sml
+++ b/compiler/scheme/cpscheme_to_cakeScript.sml
@@ -9,11 +9,6 @@ open cpscheme_astTheory;
 
 val _ = new_theory "cpscheme_to_cake";
 
-Definition cexp_cont_size_def:
-  cexp_cont_size (ApplyK _ cs) = FOLDL (λ n c . n + cexp_size c) 0 cs ∧
-  cexp_cont_size (CondK c c') = cexp_size c + cexp_size c'
-End
-
 Definition to_ml_vals_def:
   to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
   | SAdd => Con (SOME $ Short "SAdd") []
@@ -91,10 +86,8 @@ Definition refunc_def:
 Termination
   WF_REL_TAC ‘measure $ λ x . case x of
     | INL(_,c) => cexp_size c
-    | INR(INL(_,k)) => cexp_cont_size k
-    | INR(INR(_,_,_,cs)) => SUM (MAP cexp_size cs)’
-  >> rw[cexp_cont_size_def]
-  >>cheat
+    | INR(INL(_,k)) => cont_size cexp_size k
+    | INR(INR(_,_,_,cs)) => list_size cexp_size cs’
 End
 
 Definition scheme_program_to_cake_def:

From b052b39bd94bf8b5c31c684403e4956e6dd022cc Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 14 Feb 2025 00:52:54 +0000
Subject: [PATCH 024/100] corrections, working translation with custom env

---
 compiler/scheme/cpscheme_to_cakeScript.sml | 119 ++++++++++++++++-----
 1 file changed, 90 insertions(+), 29 deletions(-)

diff --git a/compiler/scheme/cpscheme_to_cakeScript.sml b/compiler/scheme/cpscheme_to_cakeScript.sml
index 57e2a23c37..7272b067ab 100644
--- a/compiler/scheme/cpscheme_to_cakeScript.sml
+++ b/compiler/scheme/cpscheme_to_cakeScript.sml
@@ -6,6 +6,8 @@ open astTheory;
 open mlstringTheory;
 open scheme_astTheory;
 open cpscheme_astTheory;
+open semanticPrimitivesTheory;
+open namespaceTheory;
 
 val _ = new_theory "cpscheme_to_cake";
 
@@ -24,13 +26,15 @@ Definition cons_list_def:
 End
 
 Definition app_ml_def:
-  app_ml n = let
+  app_ml n k = let
     t = "t" ++ toString n;
-    rfex = Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit"Not a procedure"]
+    rfex = Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"]
   in
     (n+1, Fun t $ Mat (Var (Short t)) [
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []], Var (Short "sadd"));
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []], Var (Short "smul"));
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
+        App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
+        App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
       (Pany, rfex)
     ])
 End
@@ -42,65 +46,122 @@ Definition refunc_def:
     (n, Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit $ explode s]) ∧
   refunc n (Call c k) = (let
     (m, rfc) = refunc n c;
-    (l, rfk) = refunc_cont m k;
-    k' = "k" ++ toString l;
-    t = "t" ++ toString (l+1)
+    k' = "k" ++ toString m;
+    (l, rfk) = refunc_cont (m+1) k k';
+    t = "t" ++ toString (l)
   in
-    (*(l+2, Fun k' $ App Opapp [rfc;
-      Fun t $ App Opapp [Var (Short k'); App Opapp [rfk; Var (Short t)]]])) ∧*)
+    (l+1, Fun k' $ App Opapp [rfc; rfk])) ∧
 
-    (*not tail-call?*)
-    (*(l+2, Fun k' $ App Opapp [App Opapp [rfc; rfk]; Var (Short k')])) ∧*)
-    (l+2, Fun k' $ App Opapp [rfc;
-      Fun t $ App Opapp [App Opapp [rfk; Var (Short t)]; Var (Short k')]])) ∧
-
-  refunc_cont n (CondK t f) = (let
+  refunc_cont n (CondK t f) k = (let
     (m, rft) = refunc n t;
     (l, rff) = refunc m f;
     p = "t" ++ toString l
   in
     (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], rff);
-      (Pany, rft)
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [rff; Var (Short k)]);
+      (Pany, App Opapp [rft; Var (Short k)])
     ])) ∧
-  refunc_cont n (ApplyK NONE cs) = (let t = "t" ++ toString n in
+  refunc_cont n (ApplyK NONE cs) k = (let t = "t" ++ toString n in
     case cs of
     | [] => (n+1, Fun t (Var (Short t)))
     | c::cs' => let
       t = "t" ++ toString n;
-      (m, rfc) = refunc_app (n+1) t [] cs
+      (m, rfc) = refunc_app (n+1) t [] cs k
     in
       (m+1, Fun t rfc)
     ) ∧
 
-  refunc_app n tfn ts (c::cs) = (let
+  refunc_app n tfn ts (c::cs) k = (let
     (m, rfc) = refunc n c;
     t = "t" ++ toString m;
-    (l, inner) = refunc_app (m+1) tfn (t::ts) cs
+    (l, inner) = refunc_app (m+1) tfn (t::ts) cs k
   in
-    (l, Fun t $ App Opapp [rfc; inner])) ∧
-  refunc_app n tfn ts [] = (let
-    (m, rfapp) = app_ml n;
+    (l, App Opapp [rfc; Fun t inner])) ∧
+  refunc_app n tfn ts [] k = (let
+    (m, rfapp) = app_ml n k;
   in
-    (m, App Opapp [rfapp;Var (Short tfn);cons_list (REVERSE ts)]))
+    (m, App Opapp [App Opapp [rfapp;Var (Short tfn)];cons_list (REVERSE ts)]))
 Termination
   WF_REL_TAC ‘measure $ λ x . case x of
     | INL(_,c) => cexp_size c
-    | INR(INL(_,k)) => cont_size cexp_size k
-    | INR(INR(_,_,_,cs)) => list_size cexp_size cs’
+    | INR(INL(_,k,_)) => cont_size cexp_size k
+    | INR(INR(_,_,_,cs,_)) => list_size cexp_size cs’
 End
 
 Definition scheme_program_to_cake_def:
   scheme_program_to_cake p = App Opapp [SND (refunc 0 p); Fun "t" $ Var (Short "t")]
 End
 
+Definition myC_def:
+  (myC :('a, string, num # stamp) namespace) = Bind [
+    ("SNum", (1, TypeStamp "SNum" 0));
+    ("SBool", (1, TypeStamp "SBool" 0));
+    ("Prim", (1, TypeStamp "Prim" 0));
+    ("SAdd", (0, TypeStamp "SAdd" 1));
+    ("SMul", (0, TypeStamp "SMul" 1));
+    ("cons", (2, TypeStamp "cons" 2));
+    ("nil", (0, TypeStamp "nil" 2));
+    ("Ex", (1, TypeStamp "Ex" 0));
+  ] []
+End
+
+Definition myEnv_def:
+  myEnv = <| v := Bind [
+    ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
+      ("sadd", "k",
+        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+              App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "sadd"); Var (Short "k")];
+                  App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
+                ];
+                Var (Short "xs'")
+              ]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ])
+    ] "sadd");
+    ("smul", Recclosure <| v := nsEmpty; c := myC |> [
+      ("smul", "k",
+        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+              App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "smul"); Var (Short "k")];
+                  App (Opn Times) [Var (Short "n"); Var (Short "xn")]
+                ];
+                Var (Short "xs'")
+              ]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ])
+    ] "smul")
+  ] []
+; c := myC
+|>
+End
+
 (*
   open cpscheme_to_cakeTheory;
   open scheme_to_cpschemeTheory;
   open evaluateTheory;
 
-  EVAL “evaluate st env [scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]”
-  EVAL “refunc 0 (cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 2]))”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ cps_transform $ Val $ SNum 3]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ cps_transform (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
+  EVAL “scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))”
+  EVAL “scheme_program_to_cake $ cps_transform (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From fb65f4229fe2bba7d7048d8e79909b3f030602f6 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 14 Feb 2025 18:07:29 +0000
Subject: [PATCH 025/100] lambdas properly, scoping with shared store

---
 compiler/scheme/scheme_astScript.sml       |  10 +-
 compiler/scheme/scheme_semanticsScript.sml | 134 +++++++++++++--------
 2 files changed, 91 insertions(+), 53 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index e982066bc7..207c0c9b01 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -6,6 +6,8 @@ open mlstringTheory;
 
 val _ = new_theory "scheme_ast";
 
+Type senv = “:(mlstring |-> num)”
+
 (* This needs completing: Var, Lit, ... *)
 Datatype:
   prim = SAdd | SMul
@@ -14,16 +16,14 @@ End
 Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
-      (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) 'a*)
-End
-
-Datatype:
+      | Proc senv (mlstring list) (mlstring option) exp
+;
   exp = Print mlstring
       | Apply exp (exp list)
       | Val ((*exp*) val)
       | Cond exp exp exp
       | Ident mlstring
-      | SLet ((mlstring # exp) list) exp
+      (*| SLet ((mlstring # exp) list) exp*)
       | Lambda (mlstring list) (mlstring option) exp
       | Exception mlstring
       | Begin exp (exp list)
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index a5304afcf3..41f018b9ae 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -4,6 +4,7 @@
 open preamble;
 open mlstringTheory;
 open scheme_astTheory;
+open finite_mapTheory;
 
 val _ = new_theory "scheme_semantics";
 
@@ -11,8 +12,8 @@ Datatype:
   (*Contexts for small-step operational semantics*)
   cont = ApplyK (((*'a*) val # (*'a*) val list) option) ('a list)
        | CondK 'a 'a
-       | LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
-       | InLetK ((mlstring # (*'a*) val) list)
+       (*| LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
+       | InLetK ((mlstring # (*'a*) val) list)*)
        | BeginK ('a list)
 End
 
@@ -42,65 +43,71 @@ Termination
 End
 *)
 
+Definition fresh_loc_def:
+  fresh_loc store l = (LENGTH store, SNOC l store)
+End
+
 Definition parameterize_def:
-  parameterize _ env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
-  parameterize _ env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
-  parameterize excons env ks env' (p::ps) lp e (x::xs) = parameterize excons env ks ((p, x)::env') ps lp e xs ∧
-  parameterize excons env ks _ _ _ _ _ = (env, ks, excons $ strlit "Wrong number of arguments")
+  parameterize _ store ks env [] NONE e [] = (store, ks, env, e) ∧
+  parameterize _ store ks env [] (SOME l) e xs = (let (n, store') = fresh_loc store (SList xs)
+    in (store', ks, (FUPDATE env (l, n)), e)) ∧
+  parameterize excons store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store x
+    in parameterize excons store' ks (FUPDATE env (p, n)) ps lp e xs) ∧
+  parameterize excons store ks _ _ _ _ _ = (store, ks, FEMPTY, excons $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
-  application vcons excons env ks (Prim p) xs = (case p of
-  | SAdd => (env, ks, sadd vcons excons xs 0)
-  | SMul => (env, ks, smul vcons excons xs 1)) ∧
-  (*application _ excons env ks (Proc env' ps lp e) xs =
-    parameterize excons env ks env' ps lp e xs ∧*)
-  application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
+  application vcons excons store ks (Prim p) xs = (case p of
+  | SAdd => (store, ks, FEMPTY, sadd vcons excons xs 0)
+  | SMul => (store, ks, FEMPTY, smul vcons excons xs 1)) ∧
+  application _ excons store ks (Proc env ps lp e) xs =
+    parameterize excons store ks env ps lp e xs ∧
+  application _ excons store ks _ _ = (store, ks, FEMPTY, excons $ strlit "Not a procedure")
 End
 
 Definition return_def:
-  return vcons _ (env, [], v) = (env, [], vcons v) ∧
-
-  return vcons excons (env, ApplyK NONE eargs :: ks, v) = (case eargs of
-  | [] => application vcons excons env ks v []
-  | e::es => (env, ApplyK (SOME (v, [])) es :: ks, e)) ∧
-  return vcons excons (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
-  | [] => application vcons excons env ks vfn (REVERSE $ v::vargs)
-  | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
-
-  return _ _ (env, CondK t f :: ks, v) = (if v = (SBool F)
-    then (env, ks, f) else (env, ks, t)) ∧
-
-  return _ _ (env, LetK env' i is e :: ks, v) = (case is of
-  | [] => ((i, v)::env', InLetK env :: ks, e)
-  | (i', e')::is' => (env, LetK ((i, v)::env') i' is' e :: ks, e')) ∧
-
-  return vcons _ (env, InLetK env' :: ks, v) = (env', ks, vcons v) ∧
-  return vcons _ (env, BeginK es :: ks, v) = case es of
-  | [] => (env, ks, vcons v)
-  | e::es' => (env, BeginK es' :: ks, e)
+  return vcons _ (store, [], env, v) = (store, [], env, vcons v) ∧
+
+  return vcons excons (store, (env, ApplyK NONE eargs) :: ks, _, v) = (case eargs of
+  | [] => application vcons excons store ks v []
+  | e::es => (store, (env, ApplyK (SOME (v, [])) es) :: ks, env, e)) ∧
+  return vcons excons (store, (env, ApplyK (SOME (vfn, vargs)) eargs) :: ks, _, v) = (case eargs of
+  | [] => application vcons excons store ks vfn (REVERSE $ v::vargs)
+  | e::es => (store, (env, ApplyK (SOME (vfn, v::vargs)) es) :: ks, env, e)) ∧
+
+  return _ _ (store, (env, CondK t f) :: ks, _, v) = (if v = (SBool F)
+    then (store, ks, env, f) else (store, ks, env, t)) ∧
+
+  (*return _ _ (store, LetK store' i is e :: ks, v) = (case is of
+  | [] => ((i, v)::store', InLetK store :: ks, e)
+  | (i', e')::is' => (store, LetK ((i, v)::store') i' is' e :: ks, e')) ∧
+
+  return vcons _ (store, InLetK store' :: ks, v) = (store', ks, vcons v) ∧*)
+  return vcons _ (store, (env, BeginK es) :: ks, _, v) = case es of
+  | [] => (store, ks, env, vcons v)
+  | e::es' => (store, (env, BeginK es') :: ks, env, e)
 End
 
 Definition unwind_def:
-  unwind excons env [] ex = (env, [], excons ex) ∧
-  unwind excons env (k::ks) ex = unwind excons env ks ex
+  unwind excons store [] ex = (store, [], FEMPTY, excons ex) ∧
+  unwind excons store (k::ks) ex = unwind excons store ks ex
 End
 
 Definition step_def:
-  step (env, ks, Val v) = return Val Exception (env, ks, v) ∧
-  step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
-  step (env, ks, Cond c t f) = (env, CondK t f :: ks, c) ∧
-  step (env, ks, Ident s) = (let v' = case FIND ($= s o FST) env of
-    | NONE => Wrong "Unrecognised identifier"
-    | SOME (_, v) => v
-    in (env, ks, Val v')) ∧
-  step (env, ks, SLet is e) = (case is of
-  | [] => (env, ks, e)
-  | (i, e')::is' => (env, LetK env i is' e :: ks, e')) ∧
-  (*step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧*)
-  step (env, ks, Begin e es) = (env, BeginK es :: ks, e) ∧
-
-  step (env, ks, Exception ex) = unwind Exception env ks ex
+  step (store, ks, env, Val v) = return Val Exception (store, ks, env, v) ∧
+  step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
+  step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
+  step (store, ks, env, Ident s) = (let v = case FLOOKUP env s of
+    | NONE => Exception $ strlit "Unrecognised identifier"
+    | SOME n => Val $ EL n store
+    in (store, ks, env, v)) ∧
+  (*step (store, ks, env, SLet is e) = (case is of
+  | [] => (store, ks, e)
+  | (i, e')::is' => (store, LetK store i is' e :: ks, e')) ∧*)
+  step (store, ks, env, Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
+  step (store, ks, env, Begin e es) = (store, (env, BeginK es) :: ks, env, e) ∧
+
+  step (store, ks, env, Exception ex) = unwind Exception store ks ex
 End
 
 Definition steps_def:
@@ -118,6 +125,37 @@ End
   EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”
   EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”
   EVAL “steps 3 ([], [], Begin (Val $ SNum 1) [Val $ SNum 2])”
+
+  EVAL “steps 16 ([], [], FEMPTY,
+    Apply (
+      Lambda [strlit "f"; strlit "x"] NONE (
+        Apply (Ident $ strlit "f") [Val $ SNum 1]
+      )
+    ) [
+      Lambda [strlit "y"] NONE (
+        Apply (Val $ Prim SAdd) [
+          Ident $ strlit "y";
+          Ident $ strlit "x"
+        ]
+      );
+      Val $ SNum 4
+    ]
+  )”
+
+  EVAL “steps 16 ([], [], FEMPTY,
+    Apply (
+      Lambda [strlit "x"] NONE (
+        Apply (
+          Lambda [strlit "y"] NONE (
+            Apply (Val $ Prim SAdd) [
+              Ident $ strlit "y";
+              Ident $ strlit "x"
+            ]
+          )
+        ) [Val $ SNum 1]
+      )
+    ) [Val $ SNum 4]
+  )”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From f970e441e2c7457355cf2c0cdb88621af417548b Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 15 Feb 2025 19:41:54 +0000
Subject: [PATCH 026/100] callcc

---
 compiler/scheme/scheme_astScript.sml       | 16 +++++++++++-----
 compiler/scheme/scheme_semanticsScript.sml | 17 +++++++----------
 2 files changed, 18 insertions(+), 15 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index e982066bc7..3d047941c4 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -8,19 +8,25 @@ val _ = new_theory "scheme_ast";
 
 (* This needs completing: Var, Lit, ... *)
 Datatype:
-  prim = SAdd | SMul
+  prim = SAdd | SMul | CallCC
 End
 
 Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
       (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) 'a*)
-End
-
-Datatype:
+      | Throw (cont list)
+;
+  (*Contexts for small-step operational semantics*)
+  cont = ApplyK (( val # val list) option) (exp list)
+       | CondK exp exp
+       | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
+       | InLetK ((mlstring # val) list)
+       | BeginK (exp list)
+;
   exp = Print mlstring
       | Apply exp (exp list)
-      | Val ((*exp*) val)
+      | Val val
       | Cond exp exp exp
       | Ident mlstring
       | SLet ((mlstring # exp) list) exp
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index a5304afcf3..074eb3c693 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -7,15 +7,6 @@ open scheme_astTheory;
 
 val _ = new_theory "scheme_semantics";
 
-Datatype:
-  (*Contexts for small-step operational semantics*)
-  cont = ApplyK (((*'a*) val # (*'a*) val list) option) ('a list)
-       | CondK 'a 'a
-       | LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
-       | InLetK ((mlstring # (*'a*) val) list)
-       | BeginK ('a list)
-End
-
 Definition sadd_def:
   sadd vcons _ [] n = vcons $ SNum n ∧
   sadd vcons excons (SNum m :: xs) n = sadd vcons excons xs (m + n) ∧
@@ -52,9 +43,15 @@ End
 Definition application_def:
   application vcons excons env ks (Prim p) xs = (case p of
   | SAdd => (env, ks, sadd vcons excons xs 0)
-  | SMul => (env, ks, smul vcons excons xs 1)) ∧
+  | SMul => (env, ks, smul vcons excons xs 1)
+  | CallCC => case xs of
+    | [v] => (env, ApplyK (SOME (v, [])) [] :: ks, vcons $ Throw ks)
+    | _ => (env, ks, excons $ strlit "arity mismatch")) ∧
   (*application _ excons env ks (Proc env' ps lp e) xs =
     parameterize excons env ks env' ps lp e xs ∧*)
+  application vcons excons env ks (Throw ks') xs = (case xs of
+    | [v] => (env, ks', vcons v)
+    | _ => (env, ks, excons $ strlit "arity mismatch")) ∧
   application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
 End
 

From 135396ce7af357856b31a6bb0c1f8ea3d71f1684 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 16 Feb 2025 00:46:10 +0000
Subject: [PATCH 027/100] val

---
 compiler/scheme/scheme_astScript.sml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 89fc68b67a..c148e9dcd8 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -17,7 +17,7 @@ Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
       | Proc senv (mlstring list) (mlstring option) exp
-      | Throw senv (cont list)
+      | Throw 'a (('a # cont) list)
 ;
   (*Contexts for small-step operational semantics*)
   cont = ApplyK (( val # val list) option) (exp list)

From 1ed2d7c1f8bb8d3000bc69a742ca8dff097cf1e8 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 16 Feb 2025 00:55:44 +0000
Subject: [PATCH 028/100] pretty fupdate

---
 compiler/scheme/scheme_semanticsScript.sml | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 41f018b9ae..3e5b380d38 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -50,9 +50,9 @@ End
 Definition parameterize_def:
   parameterize _ store ks env [] NONE e [] = (store, ks, env, e) ∧
   parameterize _ store ks env [] (SOME l) e xs = (let (n, store') = fresh_loc store (SList xs)
-    in (store', ks, (FUPDATE env (l, n)), e)) ∧
+    in (store', ks, (env |+ (l, n)), e)) ∧
   parameterize excons store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store x
-    in parameterize excons store' ks (FUPDATE env (p, n)) ps lp e xs) ∧
+    in parameterize excons store' ks (env |+ (p, n)) ps lp e xs) ∧
   parameterize excons store ks _ _ _ _ _ = (store, ks, FEMPTY, excons $ strlit "Wrong number of arguments")
 End
 
@@ -156,6 +156,20 @@ End
       )
     ) [Val $ SNum 4]
   )”
+
+  EVAL “steps 16 ([], [], FEMPTY,
+    Apply (
+      Lambda [strlit "x"] NONE (
+        Apply (
+          Lambda [strlit "x"] NONE (
+            Apply (Val $ Prim SAdd) [
+              Ident $ strlit "x"
+            ]
+          )
+        ) [Val $ SNum 1]
+      )
+    ) [Val $ SNum 4]
+  )”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From 5333f1d574f9f94aea8e855d295a0165ad1ef1a2 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 16 Feb 2025 16:56:29 +0000
Subject: [PATCH 029/100] set

---
 compiler/scheme/scheme_astScript.sml       |  1 +
 compiler/scheme/scheme_semanticsScript.sml | 30 ++++++++++++++++++++--
 2 files changed, 29 insertions(+), 2 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 207c0c9b01..add9582178 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -27,6 +27,7 @@ Datatype:
       | Lambda (mlstring list) (mlstring option) exp
       | Exception mlstring
       | Begin exp (exp list)
+      | Set mlstring exp
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 3e5b380d38..19483f2a17 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -15,6 +15,7 @@ Datatype:
        (*| LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
        | InLetK ((mlstring # (*'a*) val) list)*)
        | BeginK ('a list)
+       | SetK mlstring
 End
 
 Definition sadd_def:
@@ -83,9 +84,12 @@ Definition return_def:
   | (i', e')::is' => (store, LetK ((i, v)::store') i' is' e :: ks, e')) ∧
 
   return vcons _ (store, InLetK store' :: ks, v) = (store', ks, vcons v) ∧*)
-  return vcons _ (store, (env, BeginK es) :: ks, _, v) = case es of
+  return vcons _ (store, (env, BeginK es) :: ks, _, v) = (case es of
   | [] => (store, ks, env, vcons v)
-  | e::es' => (store, (env, BeginK es') :: ks, env, e)
+  | e::es' => (store, (env, BeginK es') :: ks, env, e)) ∧
+  return vcons excons (store, (env, SetK x) :: ks, _, v) = (case FLOOKUP env x of
+  | NONE => (store, ks, env, excons $ strlit "Unrecognised identifier")
+  | SOME n => (LUPDATE v n store, ks, env, vcons $ Wrong "Unspecified"))
 End
 
 Definition unwind_def:
@@ -98,6 +102,8 @@ Definition step_def:
   step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
   step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
   step (store, ks, env, Ident s) = (let v = case FLOOKUP env s of
+    (*There is a chance that this should be unreachable, because
+    of static scoping determined by the parser*)
     | NONE => Exception $ strlit "Unrecognised identifier"
     | SOME n => Val $ EL n store
     in (store, ks, env, v)) ∧
@@ -106,6 +112,7 @@ Definition step_def:
   | (i, e')::is' => (store, LetK store i is' e :: ks, e')) ∧*)
   step (store, ks, env, Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
   step (store, ks, env, Begin e es) = (store, (env, BeginK es) :: ks, env, e) ∧
+  step (store, ks, env, Set x e) = (store, (env, SetK x) :: ks, env, e) ∧
 
   step (store, ks, env, Exception ex) = unwind Exception store ks ex
 End
@@ -170,6 +177,25 @@ End
       )
     ) [Val $ SNum 4]
   )”
+
+  EVAL “steps 22 ([], [], FEMPTY,
+    Apply (
+      Lambda [strlit "x"] NONE (Begin (
+        Apply (
+          Lambda [strlit "y"] NONE (Begin (
+            Set (strlit "x") (Val $ SNum 5)
+          ) [
+            Apply (Val $ Prim SAdd) [
+              Ident $ strlit "y";
+              Ident $ strlit "x"
+            ]
+          ])
+        ) [Val $ SNum 1]
+      ) [
+        Ident $ strlit "x"
+      ])
+    ) [Val $ SNum 4]
+  )”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From e79d78e2255a1cd8d4059aa4c0c21809b1950481 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 16 Feb 2025 19:30:33 +0000
Subject: [PATCH 030/100] letrec

---
 compiler/scheme/scheme_astScript.sml       |  2 +-
 compiler/scheme/scheme_semanticsScript.sml | 56 +++++++++++++++-------
 2 files changed, 40 insertions(+), 18 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index add9582178..4f810a30e2 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -23,11 +23,11 @@ Datatype:
       | Val ((*exp*) val)
       | Cond exp exp exp
       | Ident mlstring
-      (*| SLet ((mlstring # exp) list) exp*)
       | Lambda (mlstring list) (mlstring option) exp
       | Exception mlstring
       | Begin exp (exp list)
       | Set mlstring exp
+      | Letrec ((mlstring # exp) list) exp
 End
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 19483f2a17..df82e9bbed 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -12,8 +12,6 @@ Datatype:
   (*Contexts for small-step operational semantics*)
   cont = ApplyK (((*'a*) val # (*'a*) val list) option) ('a list)
        | CondK 'a 'a
-       (*| LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
-       | InLetK ((mlstring # (*'a*) val) list)*)
        | BeginK ('a list)
        | SetK mlstring
 End
@@ -45,14 +43,14 @@ End
 *)
 
 Definition fresh_loc_def:
-  fresh_loc store l = (LENGTH store, SNOC l store)
+  fresh_loc store ov = (LENGTH store, SNOC ov store)
 End
 
 Definition parameterize_def:
   parameterize _ store ks env [] NONE e [] = (store, ks, env, e) ∧
-  parameterize _ store ks env [] (SOME l) e xs = (let (n, store') = fresh_loc store (SList xs)
+  parameterize _ store ks env [] (SOME l) e xs = (let (n, store') = fresh_loc store (SOME $ SList xs)
     in (store', ks, (env |+ (l, n)), e)) ∧
-  parameterize excons store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store x
+  parameterize excons store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store (SOME x)
     in parameterize excons store' ks (env |+ (p, n)) ps lp e xs) ∧
   parameterize excons store ks _ _ _ _ _ = (store, ks, FEMPTY, excons $ strlit "Wrong number of arguments")
 End
@@ -79,17 +77,12 @@ Definition return_def:
   return _ _ (store, (env, CondK t f) :: ks, _, v) = (if v = (SBool F)
     then (store, ks, env, f) else (store, ks, env, t)) ∧
 
-  (*return _ _ (store, LetK store' i is e :: ks, v) = (case is of
-  | [] => ((i, v)::store', InLetK store :: ks, e)
-  | (i', e')::is' => (store, LetK ((i, v)::store') i' is' e :: ks, e')) ∧
-
-  return vcons _ (store, InLetK store' :: ks, v) = (store', ks, vcons v) ∧*)
   return vcons _ (store, (env, BeginK es) :: ks, _, v) = (case es of
   | [] => (store, ks, env, vcons v)
   | e::es' => (store, (env, BeginK es') :: ks, env, e)) ∧
   return vcons excons (store, (env, SetK x) :: ks, _, v) = (case FLOOKUP env x of
   | NONE => (store, ks, env, excons $ strlit "Unrecognised identifier")
-  | SOME n => (LUPDATE v n store, ks, env, vcons $ Wrong "Unspecified"))
+  | SOME n => (LUPDATE (SOME v) n store, ks, env, vcons $ Wrong "Unspecified"))
 End
 
 Definition unwind_def:
@@ -97,22 +90,32 @@ Definition unwind_def:
   unwind excons store (k::ks) ex = unwind excons store ks ex
 End
 
+Definition letrec_init_def:
+  letrec_init store env [] = (store, env) ∧
+  letrec_init store env (x::xs) = (let (n, store') = fresh_loc store NONE
+    in letrec_init store' (env |+ (x, n)) xs)
+End
+
 Definition step_def:
   step (store, ks, env, Val v) = return Val Exception (store, ks, env, v) ∧
   step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
   step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
-  step (store, ks, env, Ident s) = (let v = case FLOOKUP env s of
+  step (store, ks, env, Ident s) = (let e = case FLOOKUP env s of
     (*There is a chance that this should be unreachable, because
     of static scoping determined by the parser*)
     | NONE => Exception $ strlit "Unrecognised identifier"
-    | SOME n => Val $ EL n store
-    in (store, ks, env, v)) ∧
-  (*step (store, ks, env, SLet is e) = (case is of
-  | [] => (store, ks, e)
-  | (i, e')::is' => (store, LetK store i is' e :: ks, e')) ∧*)
+    | SOME n => case EL n store of
+      | NONE => Exception $ strlit "letrec variable touched"
+      | SOME v => Val v
+    in (store, ks, env, e)) ∧
   step (store, ks, env, Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
   step (store, ks, env, Begin e es) = (store, (env, BeginK es) :: ks, env, e) ∧
   step (store, ks, env, Set x e) = (store, (env, SetK x) :: ks, env, e) ∧
+  (*There is a missing reinit check, though the spec says it is optional*)
+  step (store, ks, env, Letrec bs e) = (case bs of
+  | [] => (store, ks, env, e)
+  | (x, i)::bs' => let (store', env') = letrec_init store env (MAP FST bs)
+      in (store', (env', BeginK (SNOC e (MAP (UNCURRY Set) bs'))) :: ks, env', Set x i)) ∧
 
   step (store, ks, env, Exception ex) = unwind Exception store ks ex
 End
@@ -196,6 +199,25 @@ End
       ])
     ) [Val $ SNum 4]
   )”
+
+  EVAL “steps 100 ([], [], FEMPTY,
+    Letrec [
+      (strlit $ "to", Lambda [strlit "x"] NONE (
+        Apply (Ident $ strlit "fro") [
+          Apply (Val $ Prim SAdd) [Val $ SNum 1; Ident $ strlit "x"]
+        ]
+      ));
+      (strlit $ "fro", Lambda [strlit "x"] NONE (
+        Apply (Ident $ strlit "to") [
+          Apply (Val $ Prim SMul) [Val $ SNum 2; Ident $ strlit "x"]
+        ]
+      ))
+    ] (Apply (Ident $ strlit "to") [Val $ SNum 0])
+  )”
+  
+  EVAL “steps 3 ([], [], FEMPTY,
+    Letrec [(strlit $ "fail", Ident $ strlit "fail")] (Val $ SBool F)
+  )”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From da6453e46ed3f11af72253cdb1739eca4d0061aa Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Feb 2025 01:29:21 +0000
Subject: [PATCH 031/100] static scoping

---
 compiler/scheme/scheme_astScript.sml       | 56 ++++++++++++++++++++++
 compiler/scheme/scheme_semanticsScript.sml | 17 +++----
 2 files changed, 62 insertions(+), 11 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 4f810a30e2..73376426ab 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -30,4 +30,60 @@ Datatype:
       | Letrec ((mlstring # exp) list) exp
 End
 
+Definition static_scoping_check_def:
+  (static_scoping_check env (Cond c t f) ⇔
+    static_scoping_check env c ∧
+    static_scoping_check env t ∧
+    static_scoping_check env f) ∧
+  (static_scoping_check env (Apply e args) ⇔
+    static_scoping_check env e ∧
+    EVERY (static_scoping_check env) args) ∧
+  (static_scoping_check env (Set _ e) ⇔ static_scoping_check env e) ∧
+  (static_scoping_check env (Begin e es) ⇔
+    static_scoping_check env e ∧
+    EVERY (static_scoping_check env) es) ∧
+  (static_scoping_check env (Lambda xs xp e) ⇔ let xs' = case xp of
+    | NONE => xs
+    | SOME x => x::xs
+    in ALL_DISTINCT xs' ∧ static_scoping_check (env ∪ set xs') e) ∧
+  (static_scoping_check env (Letrec xes e) ⇔ let xs = MAP FST xes
+    in ALL_DISTINCT xs ∧ let env' = env ∪ set xs
+    in static_scoping_check env' e ∧
+       EVERY (static_scoping_check env') (MAP SND xes)) ∧
+  (static_scoping_check env (Ident x) ⇔ env x) ∧
+  (static_scoping_check _ _ ⇔ T)
+Termination
+  WF_REL_TAC ‘measure $ exp_size o SND’
+  >> Induct_on ‘xes’ >- (rw[])
+  >> Cases_on ‘h’
+  >> simp[definition "val_size_def", list_size_def, snd (TypeBase.size_of “:'a # 'b”)]
+  >> rpt strip_tac >- (rw[])
+  >> last_x_assum $ qspecl_then [‘e’, ‘a’] $ imp_res_tac
+  >> first_x_assum $ qspec_then ‘e’ $ assume_tac
+  >> rw[]
+End
+
 val _ = export_theory();
+
+(*
+  EVAL “static_scoping_check {} (
+    Apply (
+      Lambda [strlit "f"; strlit "x"] NONE (Begin (
+        Apply (Ident $ strlit "f"
+        ) [Val $ SNum 1]
+      ) [
+        Ident $ strlit "x"
+      ])
+    ) [
+      Lambda [strlit "y"] NONE (Begin (
+        Set (strlit "x") (Val $ SNum 5)
+      ) [
+        Apply (Val $ Prim SAdd) [
+          Ident $ strlit "y";
+          Ident $ strlit "x"
+        ]
+      ]);
+      Val $ SNum 4
+    ]
+  )”
+*)
\ No newline at end of file
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index df82e9bbed..7da34bc498 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -80,9 +80,7 @@ Definition return_def:
   return vcons _ (store, (env, BeginK es) :: ks, _, v) = (case es of
   | [] => (store, ks, env, vcons v)
   | e::es' => (store, (env, BeginK es') :: ks, env, e)) ∧
-  return vcons excons (store, (env, SetK x) :: ks, _, v) = (case FLOOKUP env x of
-  | NONE => (store, ks, env, excons $ strlit "Unrecognised identifier")
-  | SOME n => (LUPDATE (SOME v) n store, ks, env, vcons $ Wrong "Unspecified"))
+  return vcons excons (store, (env, SetK x) :: ks, _, v) = (LUPDATE (SOME v) (env ' x) store, ks, env, vcons $ Wrong "Unspecified")
 End
 
 Definition unwind_def:
@@ -100,13 +98,10 @@ Definition step_def:
   step (store, ks, env, Val v) = return Val Exception (store, ks, env, v) ∧
   step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
   step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
-  step (store, ks, env, Ident s) = (let e = case FLOOKUP env s of
-    (*There is a chance that this should be unreachable, because
-    of static scoping determined by the parser*)
-    | NONE => Exception $ strlit "Unrecognised identifier"
-    | SOME n => case EL n store of
-      | NONE => Exception $ strlit "letrec variable touched"
-      | SOME v => Val v
+  (*This is undefined if the program doesn't typecheck*)
+  step (store, ks, env, Ident s) = (let e = case EL (env ' s) store of
+    | NONE => Exception $ strlit "letrec variable touched"
+    | SOME v => Val v
     in (store, ks, env, e)) ∧
   step (store, ks, env, Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
   step (store, ks, env, Begin e es) = (store, (env, BeginK es) :: ks, env, e) ∧
@@ -214,7 +209,7 @@ End
       ))
     ] (Apply (Ident $ strlit "to") [Val $ SNum 0])
   )”
-  
+
   EVAL “steps 3 ([], [], FEMPTY,
     Letrec [(strlit $ "fail", Ident $ strlit "fail")] (Val $ SBool F)
   )”

From ffc20fa0e309c558f30a8426fd2479cdaca1c39c Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Feb 2025 12:56:26 +0000
Subject: [PATCH 032/100] removal of intermediate defunc cps compile step

---
 compiler/scheme/cpscheme_astScript.sml       |  18 --
 compiler/scheme/cpscheme_semanticsScript.sml |  26 ---
 compiler/scheme/cpscheme_to_cakeScript.sml   | 167 -------------------
 compiler/scheme/scheme_to_cakeScript.sml     | 144 +++++++++++++++-
 compiler/scheme/scheme_to_cpschemeScript.sml |  24 ---
 5 files changed, 143 insertions(+), 236 deletions(-)
 delete mode 100644 compiler/scheme/cpscheme_astScript.sml
 delete mode 100644 compiler/scheme/cpscheme_semanticsScript.sml
 delete mode 100644 compiler/scheme/cpscheme_to_cakeScript.sml
 delete mode 100644 compiler/scheme/scheme_to_cpschemeScript.sml

diff --git a/compiler/scheme/cpscheme_astScript.sml b/compiler/scheme/cpscheme_astScript.sml
deleted file mode 100644
index 57ce6365fe..0000000000
--- a/compiler/scheme/cpscheme_astScript.sml
+++ /dev/null
@@ -1,18 +0,0 @@
-(*
-  AST of CPScheme
-*)
-open preamble;
-open mlstringTheory;
-open scheme_astTheory;
-open scheme_semanticsTheory;
-
-val _ = new_theory "cpscheme_ast";
-
-Datatype:
-  cexp = CVal ((*cexp*) val)             (*λk.k val*)
-       | CException mlstring  (**)
-       | Call cexp (cexp cont)       (*λk.cexp (k o cont)*)
-       (*| CLambda (mlstring list) (mlstring option) cexp*)
-End
-
-val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/cpscheme_semanticsScript.sml b/compiler/scheme/cpscheme_semanticsScript.sml
deleted file mode 100644
index 7c471c1696..0000000000
--- a/compiler/scheme/cpscheme_semanticsScript.sml
+++ /dev/null
@@ -1,26 +0,0 @@
-(*
-  Semantics of CPScheme
-*)
-open preamble;
-open mlstringTheory;
-open scheme_astTheory;
-open cpscheme_astTheory;
-
-val _ = new_theory "cpscheme_semantics";
-
-Definition reduce_def:
-  reduce (env, ks, (CVal v)) = return CVal CException ([], ks, v) ∧
-  reduce (env, ks, (Call c k)) = (env, (k::ks), c)
-End
-
-Definition many_reduce_def:
-  many_reduce (n:num) c = if n = 0 then c
-    else many_reduce (n - 1) $ reduce c
-End
-
-(*
-  EVAL “many_reduce 4 ([], [], (cps_transform (Cond (Cond (Val $ SBool F) (Val $ SBool T) (Val $ SBool F)) (Val $ SNum 2) (Val $ SNum 4))))”
-  EVAL “many_reduce 2 ([], [], (cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])))”
-*)
-
-val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/cpscheme_to_cakeScript.sml b/compiler/scheme/cpscheme_to_cakeScript.sml
deleted file mode 100644
index 7272b067ab..0000000000
--- a/compiler/scheme/cpscheme_to_cakeScript.sml
+++ /dev/null
@@ -1,167 +0,0 @@
-(*
-  Translation from CPScheme to CakeML
-*)
-open preamble;
-open astTheory;
-open mlstringTheory;
-open scheme_astTheory;
-open cpscheme_astTheory;
-open semanticPrimitivesTheory;
-open namespaceTheory;
-
-val _ = new_theory "cpscheme_to_cake";
-
-Definition to_ml_vals_def:
-  to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
-  | SAdd => Con (SOME $ Short "SAdd") []
-  | SMul => Con (SOME $ Short "SMul") []] ∧
-  to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit &n] ∧
-  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
-    if b then 1 else 0]
-End
-
-Definition cons_list_def:
-  cons_list [] = Con (SOME $ Short "nil") [] ∧
-  cons_list (x::xs) = Con (SOME $ Short "cons") [Var (Short x); cons_list xs]
-End
-
-Definition app_ml_def:
-  app_ml n k = let
-    t = "t" ++ toString n;
-    rfex = Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"]
-  in
-    (n+1, Fun t $ Mat (Var (Short t)) [
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
-        App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
-        App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
-      (Pany, rfex)
-    ])
-End
-
-Definition refunc_def:
-  refunc n (CVal v) = (let k = "k" ++ toString n in
-    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
-  refunc n (CException s) =
-    (n, Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit $ explode s]) ∧
-  refunc n (Call c k) = (let
-    (m, rfc) = refunc n c;
-    k' = "k" ++ toString m;
-    (l, rfk) = refunc_cont (m+1) k k';
-    t = "t" ++ toString (l)
-  in
-    (l+1, Fun k' $ App Opapp [rfc; rfk])) ∧
-
-  refunc_cont n (CondK t f) k = (let
-    (m, rft) = refunc n t;
-    (l, rff) = refunc m f;
-    p = "t" ++ toString l
-  in
-    (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [rff; Var (Short k)]);
-      (Pany, App Opapp [rft; Var (Short k)])
-    ])) ∧
-  refunc_cont n (ApplyK NONE cs) k = (let t = "t" ++ toString n in
-    case cs of
-    | [] => (n+1, Fun t (Var (Short t)))
-    | c::cs' => let
-      t = "t" ++ toString n;
-      (m, rfc) = refunc_app (n+1) t [] cs k
-    in
-      (m+1, Fun t rfc)
-    ) ∧
-
-  refunc_app n tfn ts (c::cs) k = (let
-    (m, rfc) = refunc n c;
-    t = "t" ++ toString m;
-    (l, inner) = refunc_app (m+1) tfn (t::ts) cs k
-  in
-    (l, App Opapp [rfc; Fun t inner])) ∧
-  refunc_app n tfn ts [] k = (let
-    (m, rfapp) = app_ml n k;
-  in
-    (m, App Opapp [App Opapp [rfapp;Var (Short tfn)];cons_list (REVERSE ts)]))
-Termination
-  WF_REL_TAC ‘measure $ λ x . case x of
-    | INL(_,c) => cexp_size c
-    | INR(INL(_,k,_)) => cont_size cexp_size k
-    | INR(INR(_,_,_,cs,_)) => list_size cexp_size cs’
-End
-
-Definition scheme_program_to_cake_def:
-  scheme_program_to_cake p = App Opapp [SND (refunc 0 p); Fun "t" $ Var (Short "t")]
-End
-
-Definition myC_def:
-  (myC :('a, string, num # stamp) namespace) = Bind [
-    ("SNum", (1, TypeStamp "SNum" 0));
-    ("SBool", (1, TypeStamp "SBool" 0));
-    ("Prim", (1, TypeStamp "Prim" 0));
-    ("SAdd", (0, TypeStamp "SAdd" 1));
-    ("SMul", (0, TypeStamp "SMul" 1));
-    ("cons", (2, TypeStamp "cons" 2));
-    ("nil", (0, TypeStamp "nil" 2));
-    ("Ex", (1, TypeStamp "Ex" 0));
-  ] []
-End
-
-Definition myEnv_def:
-  myEnv = <| v := Bind [
-    ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
-      ("sadd", "k",
-        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
-          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
-              App Opapp [
-                App Opapp [
-                  App Opapp [Var (Short "sadd"); Var (Short "k")];
-                  App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
-                ];
-                Var (Short "xs'")
-              ]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ])
-    ] "sadd");
-    ("smul", Recclosure <| v := nsEmpty; c := myC |> [
-      ("smul", "k",
-        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
-          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
-              App Opapp [
-                App Opapp [
-                  App Opapp [Var (Short "smul"); Var (Short "k")];
-                  App (Opn Times) [Var (Short "n"); Var (Short "xn")]
-                ];
-                Var (Short "xs'")
-              ]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ])
-    ] "smul")
-  ] []
-; c := myC
-|>
-End
-
-(*
-  open cpscheme_to_cakeTheory;
-  open scheme_to_cpschemeTheory;
-  open evaluateTheory;
-
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ cps_transform $ Val $ SNum 3]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ cps_transform (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
-  EVAL “scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))”
-  EVAL “scheme_program_to_cake $ cps_transform (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
-*)
-
-val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 6f0d287e16..c8b8f3556d 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -3,10 +3,141 @@
 *)
 open preamble;
 open astTheory;
-open scheme_astTheory;
+open scheme_astTheory
+
+open semanticPrimitivesTheory;
+open namespaceTheory;
 
 val _ = new_theory "scheme_to_cake";
 
+Definition to_ml_vals_def:
+  to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
+  | SAdd => Con (SOME $ Short "SAdd") []
+  | SMul => Con (SOME $ Short "SMul") []] ∧
+  to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit &n] ∧
+  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
+    if b then 1 else 0]
+End
+
+Definition cons_list_def:
+  cons_list [] = Con (SOME $ Short "nil") [] ∧
+  cons_list (x::xs) = Con (SOME $ Short "cons") [Var (Short x); cons_list xs]
+End
+
+Definition app_ml_def:
+  app_ml n k = let
+    t = "t" ++ toString n;
+    cex = Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"]
+  in
+    (n+1, Fun t $ Mat (Var (Short t)) [
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
+        App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
+        App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
+      (Pany, cex)
+    ])
+End
+
+Definition cps_transform_def:
+  cps_transform n (Val v) = (let k = "k" ++ toString n in
+    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
+  cps_transform n (Exception s) =
+    (n, Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit $ explode s]) ∧
+  cps_transform n (Cond c t f) = (let
+    (m, cc) = cps_transform n c;
+    (l, ct) = cps_transform m t;
+    (j, cf) = cps_transform l f;
+    p = "t" ++ toString j;
+    k = "k" ++ toString (j+1)
+  in
+    (j+2, Fun k $ App Opapp [cc;  Fun p $ Mat (Var (Short p)) [
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; Var (Short k)]);
+      (Pany, App Opapp [ct; Var (Short k)])
+    ]])) ∧
+  cps_transform n (Apply fn args) = (let
+    (m, cfn) = cps_transform n fn;
+    k = "k" ++ toString m;
+    t = "t" ++ toString (m+1);
+    (l, ce) = cps_transform_app (m+2) t [] args k
+  in
+    (l+1, Fun k $ App Opapp [cfn; Fun t ce])) ∧
+
+  cps_transform_app n tfn ts (e::es) k = (let
+    (m, ce) = cps_transform n e;
+    t = "t" ++ toString m;
+    (l, inner) = cps_transform_app (m+1) tfn (t::ts) es k
+  in
+    (l, App Opapp [ce; Fun t inner])) ∧
+  cps_transform_app n tfn ts [] k = (let
+    (m, capp) = app_ml n k;
+  in
+    (m, App Opapp [App Opapp [capp;Var (Short tfn)];cons_list (REVERSE ts)]))
+End
+
+Definition scheme_program_to_cake_def:
+  scheme_program_to_cake p = App Opapp [SND (cps_transform 0 p); Fun "t" $ Var (Short "t")]
+End
+
+Definition myC_def:
+  (myC :('a, string, num # stamp) namespace) = Bind [
+    ("SNum", (1, TypeStamp "SNum" 0));
+    ("SBool", (1, TypeStamp "SBool" 0));
+    ("Prim", (1, TypeStamp "Prim" 0));
+    ("SAdd", (0, TypeStamp "SAdd" 1));
+    ("SMul", (0, TypeStamp "SMul" 1));
+    ("cons", (2, TypeStamp "cons" 2));
+    ("nil", (0, TypeStamp "nil" 2));
+    ("Ex", (1, TypeStamp "Ex" 0));
+  ] []
+End
+
+Definition myEnv_def:
+  myEnv = <| v := Bind [
+    ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
+      ("sadd", "k",
+        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+              App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "sadd"); Var (Short "k")];
+                  App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
+                ];
+                Var (Short "xs'")
+              ]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ])
+    ] "sadd");
+    ("smul", Recclosure <| v := nsEmpty; c := myC |> [
+      ("smul", "k",
+        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+              App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "smul"); Var (Short "k")];
+                  App (Opn Times) [Var (Short "n"); Var (Short "xn")]
+                ];
+                Var (Short "xs'")
+              ]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ])
+    ] "smul")
+  ] []
+; c := myC
+|>
+End
+
 Definition cake_print_def:
   cake_print e =
     (* val _ = print e; *)
@@ -16,6 +147,17 @@ End
 Definition codegen_def:
   (codegen (Print s)) : string + dec list =
     INR (cake_print (Lit (StrLit (explode s))))
+  (*codegen _ = INR [Dlet unknown_loc Pany $ scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]*)
 End
 
 val _ = export_theory();
+
+(*
+  open evaluateTheory;
+
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
+  EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
+  EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
+*)
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cpschemeScript.sml b/compiler/scheme/scheme_to_cpschemeScript.sml
deleted file mode 100644
index 17440050b6..0000000000
--- a/compiler/scheme/scheme_to_cpschemeScript.sml
+++ /dev/null
@@ -1,24 +0,0 @@
-(*
-  CPS transform on Scheme
-*)
-open preamble;
-open mlstringTheory;
-open scheme_astTheory;
-open cpscheme_astTheory;
-
-val _ = new_theory "scheme_to_cpscheme";
-
-Definition cps_transform_def:
-  cps_transform (Val v) = CVal v ∧
-  cps_transform (Cond c t f) = Call (cps_transform c) (CondK (cps_transform t) (cps_transform f)) ∧
-  cps_transform (Apply fn args) = Call (cps_transform fn) (ApplyK NONE $ MAP cps_transform args)
-Termination
-  WF_REL_TAC ‘measure exp_size’
-End
-
-(*
-  EVAL “cps_transform (Cond (Val $ SBool F) (Val $ SNum 2) (Val $ SNum 4))”
-  EVAL “cps_transform (Apply (Val $ Prim SAdd) [Val $ SNum 4])”
-*)
-
-val _ = export_theory();
\ No newline at end of file

From 750163fa11bdd8a1dab02af0966e1d53e23efe33 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Feb 2025 16:13:52 +0000
Subject: [PATCH 033/100] fix throw constructor

---
 compiler/scheme/scheme_astScript.sml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 8adaaf6c1e..9539e309c1 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -17,7 +17,8 @@ Datatype:
   val = Prim prim | SNum num | Wrong string | SBool bool
       | SList (val list)
       | Proc senv (mlstring list) (mlstring option) exp
-      | Throw 'a (('a # cont) list)
+      (*requires HOL 94eb753a85c5628f4fd0401deb4b7e2972a8eb25*)
+      | Throw senv ((senv # cont) list)
 ;
   (*Contexts for small-step operational semantics*)
   cont = ApplyK ((val # val list) option) (exp list)

From f62f8784010abbceccc1412311fb3a1fd28a90cc Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Feb 2025 17:25:23 +0000
Subject: [PATCH 034/100] messing

---
 compiler/scheme/scheme_semanticsScript.sml | 22 ++++++++++++++++++++--
 compiler/scheme/scheme_to_cakeScript.sml   |  2 +-
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 60a67264f3..9b7898a7ac 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -119,8 +119,8 @@ Definition steps_def:
 End
 
 (*
-  EVAL “semantics (Val (SNum 3))”
-  EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
+  open scheme_semanticsTheory;
+
   EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 4 ([], [], Apply (Val (SNum 7)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
@@ -226,6 +226,24 @@ End
         ]
       )]
     ]
+  )”
+
+  EVAL “steps 102 ([], [], FEMPTY,
+    Letrec [
+      (strlit $ "double", Val $ SNum 0);
+      (strlit $ "x", Val $ SNum 1)
+    ] (Begin (
+      Apply (Val $ Prim CallCC) [ Lambda [strlit "x"] NONE (
+        Set (strlit "double") (Ident $ strlit "x")
+      )]
+    ) [
+      Set (strlit "x") (Apply (Val $ Prim SMul) [
+        Val $ SNum 2;
+        Ident $ strlit "x"
+      ]);
+      Apply (Ident $ strlit "double") [Val $ SNum 0]
+    ])
+  )”
 *)
 
 val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index c8b8f3556d..2c944f73b4 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -3,7 +3,7 @@
 *)
 open preamble;
 open astTheory;
-open scheme_astTheory
+open scheme_astTheory;
 
 open semanticPrimitivesTheory;
 open namespaceTheory;

From ccb9e9d3d82af402dcde4a5743441805b9b15d38 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 02:44:24 +0000
Subject: [PATCH 035/100] compile lambdas

---
 compiler/scheme/scheme_to_cakeScript.sml | 54 +++++++++++++++++++++---
 1 file changed, 48 insertions(+), 6 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index c8b8f3556d..3ec7a4ec21 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -25,19 +25,45 @@ Definition cons_list_def:
 End
 
 Definition app_ml_def:
-  app_ml n k = let
-    t = "t" ++ toString n;
+  app_ml n k t = let
     cex = Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"]
   in
-    (n+1, Fun t $ Mat (Var (Short t)) [
+    (n, Mat (Var (Short t)) [
       (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
         App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
       (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
         App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
+      (Pcon (SOME $ Short "Proc") [Pvar "e"],
+        App Opapp [Var (Short "e"); Var (Short k)]);
       (Pany, cex)
     ])
 End
 
+Definition proc_ml_def:
+  proc_ml n [] NONE k args ce = (n, Mat (Var (Short args)) [
+        (Pcon (SOME $ Short "nil") [],
+          App Opapp [ce; Var (Short k)]);
+        (Pany,
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"])
+    ]) ∧
+  proc_ml n [] (SOME x) k args ce = (n, Let (SOME $ "s" ++ explode x)
+      (App Opref [Con (SOME $ Short "SList") [Var (Short args)]])
+      (App Opapp [ce; Var (Short k)])) ∧
+  proc_ml n (x::xs) xp k args ce = (let
+    arg = "x" ++ toString n;
+    args' = "xs" ++ toString (n+1);
+    (m, inner) = proc_ml_def (n+2) xs xp k args' ce
+  in
+    (m, Mat (Var (Short args)) [
+        (Pcon (SOME $ Short "nil") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
+        (Pcon (SOME $ Short "cons") [Pvar arg; Pvar args'],
+          Let (SOME $ "s" ++ explode x)
+            (App Opref [Var (Short arg)])
+            inner)
+    ]))
+End
+
 Definition cps_transform_def:
   cps_transform n (Val v) = (let k = "k" ++ toString n in
     (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
@@ -60,7 +86,19 @@ Definition cps_transform_def:
     t = "t" ++ toString (m+1);
     (l, ce) = cps_transform_app (m+2) t [] args k
   in
-    (l+1, Fun k $ App Opapp [cfn; Fun t ce])) ∧
+    (l, Fun k $ App Opapp [cfn; Fun t ce])) ∧
+  cps_transform n (Ident x) = (let k = "k" ++ toString n in
+    (n, Fun k $ App Opapp [
+      Var (Short k); App Opderef [Var (Short $ "s" ++ explode x)]])) ∧
+  cps_transform n (Lambda xs xp e) = (let
+    (m, ce) = cps_transform n e;
+    args = "xs" ++ toString m;
+    k = "k" ++ toString (m+1);
+    (l, inner) = proc_ml (m+2) xs xp k args ce;
+    k' = "k" ++ toString l;
+  in
+    (l+1, Fun k' $ App Opapp [Var (Short k');
+      Con (SOME $ Short "Proc") [Fun k $ Fun args inner]])) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -69,9 +107,9 @@ Definition cps_transform_def:
   in
     (l, App Opapp [ce; Fun t inner])) ∧
   cps_transform_app n tfn ts [] k = (let
-    (m, capp) = app_ml n k;
+    (m, capp) = app_ml n k tfn;
   in
-    (m, App Opapp [App Opapp [capp;Var (Short tfn)];cons_list (REVERSE ts)]))
+    (m, App Opapp [capp;cons_list (REVERSE ts)]))
 End
 
 Definition scheme_program_to_cake_def:
@@ -82,6 +120,8 @@ Definition myC_def:
   (myC :('a, string, num # stamp) namespace) = Bind [
     ("SNum", (1, TypeStamp "SNum" 0));
     ("SBool", (1, TypeStamp "SBool" 0));
+    ("SList", (1, TypeStamp "SList" 0));
+    ("Proc", (1, TypeStamp "Proc" 0));
     ("Prim", (1, TypeStamp "Prim" 0));
     ("SAdd", (0, TypeStamp "SAdd" 1));
     ("SMul", (0, TypeStamp "SMul" 1));
@@ -158,6 +198,8 @@ val _ = export_theory();
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
+  EVAL “evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Lambda [strlit "x"; strlit "y"] NONE (Ident $ strlit "x")) [Val $ SNum 5; Val $ SNum 4])]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
+  EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
 *)
\ No newline at end of file

From bfed75c095d4d201c4a24b942ee9d76c7ad24f1e Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 12:38:41 +0000
Subject: [PATCH 036/100] correction

---
 compiler/scheme/scheme_to_cakeScript.sml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 3ec7a4ec21..d41bf1817b 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -52,7 +52,7 @@ Definition proc_ml_def:
   proc_ml n (x::xs) xp k args ce = (let
     arg = "x" ++ toString n;
     args' = "xs" ++ toString (n+1);
-    (m, inner) = proc_ml_def (n+2) xs xp k args' ce
+    (m, inner) = proc_ml (n+2) xs xp k args' ce
   in
     (m, Mat (Var (Short args)) [
         (Pcon (SOME $ Short "nil") [],
@@ -193,6 +193,7 @@ End
 val _ = export_theory();
 
 (*
+  open scheme_to_cakeTheory;
   open evaluateTheory;
 
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”

From 7ee20a505c6cfd0b206c8f8aae2e506de294e277 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 12:56:13 +0000
Subject: [PATCH 037/100] sequencing

---
 compiler/scheme/scheme_to_cakeScript.sml | 21 ++++++++++++++++++++-
 1 file changed, 20 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index d41bf1817b..16fa1e1003 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -99,6 +99,12 @@ Definition cps_transform_def:
   in
     (l+1, Fun k' $ App Opapp [Var (Short k');
       Con (SOME $ Short "Proc") [Fun k $ Fun args inner]])) ∧
+  cps_transform n (Begin e es) = (let
+    (m, ce) = cps_transform n e;
+    k = "k" ++ toString m;
+    (l, seqk) = cps_transform_seq (m+1) k es
+  in
+    (l, Fun k $ App Opapp [ce; seqk])) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -109,7 +115,19 @@ Definition cps_transform_def:
   cps_transform_app n tfn ts [] k = (let
     (m, capp) = app_ml n k tfn;
   in
-    (m, App Opapp [capp;cons_list (REVERSE ts)]))
+    (m, App Opapp [capp;cons_list (REVERSE ts)])) ∧
+
+  cps_transform_seq n k [] = (n, Var (Short k)) ∧
+  cps_transform_seq n k (e::es) = (let
+    (m, ce) = cps_transform n e;
+    (l, inner) = cps_transform_seq m k es
+  in
+    (l, Fun "_" $ App Opapp [ce; inner]))
+Termination
+  WF_REL_TAC ‘measure (λ x . case x of
+    | INL(_,e) => exp_size e
+    | INR(INL(_,_,_,es,_)) => list_size exp_size es
+    | INR(INR(_,_,es)) => list_size exp_size es)’
 End
 
 Definition scheme_program_to_cake_def:
@@ -203,4 +221,5 @@ val _ = export_theory();
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
+  EVAL “scheme_program_to_cake (Begin (Val $ SNum 0) [Val $ SNum 1; Val $ SNum 2])”
 *)
\ No newline at end of file

From c8bcaab188dbd1b2f4cab8429abc5a83c01b521b Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 13:19:57 +0000
Subject: [PATCH 038/100] compile set, correct exception

---
 compiler/scheme/scheme_to_cakeScript.sml | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 16fa1e1003..29f8c0c3e4 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -68,7 +68,7 @@ Definition cps_transform_def:
   cps_transform n (Val v) = (let k = "k" ++ toString n in
     (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
   cps_transform n (Exception s) =
-    (n, Fun "_" $ App Opapp [Var (Short "print"); Lit $ StrLit $ explode s]) ∧
+    (n, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]) ∧
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
     (l, ct) = cps_transform m t;
@@ -105,6 +105,14 @@ Definition cps_transform_def:
     (l, seqk) = cps_transform_seq (m+1) k es
   in
     (l, Fun k $ App Opapp [ce; seqk])) ∧
+  cps_transform n (Set x e) = (let
+    (m, ce) = cps_transform n e;
+    k = "k" ++ toString m;
+    t = "t" ++ toString (m+1);
+  in
+    (m+2, Fun k $ (App Opapp [ce;
+      Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x); Var (Short t)])
+        (App Opapp [Var (Short k); Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"]])]))) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -141,6 +149,7 @@ Definition myC_def:
     ("SList", (1, TypeStamp "SList" 0));
     ("Proc", (1, TypeStamp "Proc" 0));
     ("Prim", (1, TypeStamp "Prim" 0));
+    ("Wrong", (1, TypeStamp "Wrong" 0));
     ("SAdd", (0, TypeStamp "SAdd" 1));
     ("SMul", (0, TypeStamp "SMul" 1));
     ("cons", (2, TypeStamp "cons" 2));
@@ -217,7 +226,7 @@ val _ = export_theory();
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
-  EVAL “evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Lambda [strlit "x"; strlit "y"] NONE (Ident $ strlit "x")) [Val $ SNum 5; Val $ SNum 4])]”
+  EVAL “evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Lambda [strlit "x"] NONE (Begin (Set (strlit "x") (Val $ SNum 7)) [Ident $ strlit "x"])) [Val $ SNum 5])]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”

From 87084923e8d2667b84a1707e3102c0aefd961355 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 19:06:29 +0000
Subject: [PATCH 039/100] compile letrec

---
 compiler/scheme/scheme_to_cakeScript.sml | 59 +++++++++++++++++++++---
 1 file changed, 53 insertions(+), 6 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 29f8c0c3e4..b471ecb035 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -59,11 +59,17 @@ Definition proc_ml_def:
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
         (Pcon (SOME $ Short "cons") [Pvar arg; Pvar args'],
           Let (SOME $ "s" ++ explode x)
-            (App Opref [Var (Short arg)])
+            (App Opref [Con (SOME $ Short "Some") [Var (Short arg)]])
             inner)
     ]))
 End
 
+Definition letinit_ml_def:
+  letinit_ml [] inner = inner ∧
+  letinit_ml ((x,_)::bs) inner = Let (SOME $ "s" ++ explode x)
+      (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
+End
+
 Definition cps_transform_def:
   cps_transform n (Val v) = (let k = "k" ++ toString n in
     (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
@@ -88,8 +94,11 @@ Definition cps_transform_def:
   in
     (l, Fun k $ App Opapp [cfn; Fun t ce])) ∧
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
-    (n, Fun k $ App Opapp [
-      Var (Short k); App Opderef [Var (Short $ "s" ++ explode x)]])) ∧
+    (n, Fun k $ Mat (App Opderef [Var (Short $ "s" ++ explode x)]) [
+      (Pcon (SOME $ Short "None") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Letrec variable touched"]);
+      (Pcon (SOME $ Short "Some") [Pvar $ "s'" ++ explode x],
+        App Opapp [Var (Short k); Var (Short $ "s'" ++ explode x)])])) ∧
   cps_transform n (Lambda xs xp e) = (let
     (m, ce) = cps_transform n e;
     args = "xs" ++ toString m;
@@ -111,8 +120,15 @@ Definition cps_transform_def:
     t = "t" ++ toString (m+1);
   in
     (m+2, Fun k $ (App Opapp [ce;
-      Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x); Var (Short t)])
+      Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
+          Con (SOME $ Short "Some") [Var (Short t)]])
         (App Opapp [Var (Short k); Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"]])]))) ∧
+  cps_transform n (Letrec bs e) = (let
+    (m, ce) = cps_transform n e;
+    k = "k" ++ toString m;
+    (l, inner) = cps_transform_letreinit (m+1) k bs ce
+  in
+    (l, Fun k $ letinit_ml bs inner)) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -130,12 +146,30 @@ Definition cps_transform_def:
     (m, ce) = cps_transform n e;
     (l, inner) = cps_transform_seq m k es
   in
-    (l, Fun "_" $ App Opapp [ce; inner]))
+    (l, Fun "_" $ App Opapp [ce; inner])) ∧
+
+  cps_transform_letreinit n k [] ce = (n,
+    App Opapp [ce; Var (Short k)]) ∧
+  cps_transform_letreinit n k ((x,e)::bs) ce = (let
+    (m, ce') = cps_transform n e;
+    (l, inner) = cps_transform_letreinit m k bs ce;
+    t = "t" ++ toString l
+  in
+    (l+1, App Opapp [ce'; Fun t $ Let NONE
+      (App Opassign [Var (Short $ "s" ++ explode x);
+        Con (SOME $ Short "Some") [Var (Short t)]])
+      inner]))
 Termination
   WF_REL_TAC ‘measure (λ x . case x of
     | INL(_,e) => exp_size e
     | INR(INL(_,_,_,es,_)) => list_size exp_size es
-    | INR(INR(_,_,es)) => list_size exp_size es)’
+    | INR(INR(INL(_,_,es))) => list_size exp_size es
+    | INR(INR(INR(_,_,es,_))) => list_size (exp_size o SND) es)’
+  >> Induct >- (rw[val_size_def, list_size_def])
+  >> Cases
+  >> rw[val_size_def, list_size_def]
+  >> last_x_assum $ qspecl_then [‘e’,‘n’,‘m’,‘ce’] $ mp_tac
+  >> rw[]
 End
 
 Definition scheme_program_to_cake_def:
@@ -155,6 +189,8 @@ Definition myC_def:
     ("cons", (2, TypeStamp "cons" 2));
     ("nil", (0, TypeStamp "nil" 2));
     ("Ex", (1, TypeStamp "Ex" 0));
+    ("Some", (1, TypeStamp "Some" 3));
+    ("None", (0, TypeStamp "None" 3));
   ] []
 End
 
@@ -227,8 +263,19 @@ val _ = export_theory();
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
   EVAL “evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Lambda [strlit "x"] NONE (Begin (Set (strlit "x") (Val $ SNum 7)) [Ident $ strlit "x"])) [Val $ SNum 5])]”
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
+    Letrec [(strlit "f", Lambda [strlit "b"; strlit "x"] NONE (
+      Cond (Ident $ strlit "b")
+        (Apply (Val $ Prim SMul) [Val $ SNum 2; Ident $ strlit "x"])
+        (Apply (Ident $ strlit "f") [Val $ SBool T; Apply
+          (Val $ Prim SAdd) [Val $ SNum 1; Ident $ strlit "x"]])
+    ))] (
+      Apply (Ident $ strlit "f") [Val $ SBool F; Val $ SNum 7]
+    )
+  )]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
   EVAL “scheme_program_to_cake (Begin (Val $ SNum 0) [Val $ SNum 1; Val $ SNum 2])”
+  EVAL “scheme_program_to_cake (Letrec [(strlit "x", Val $ SNum 1)] (Ident $ strlit "x"))”
 *)
\ No newline at end of file

From 9bbaeca99e85a8669b876410820a5151e706dc8f Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 20:43:44 +0000
Subject: [PATCH 040/100] minus and signed ints

---
 compiler/scheme/scheme_astScript.sml       |  4 +--
 compiler/scheme/scheme_semanticsScript.sml | 13 ++++++--
 compiler/scheme/scheme_to_cakeScript.sml   | 38 +++++++++++++++++++---
 3 files changed, 46 insertions(+), 9 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index e982066bc7..b2fa46c7dc 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -8,11 +8,11 @@ val _ = new_theory "scheme_ast";
 
 (* This needs completing: Var, Lit, ... *)
 Datatype:
-  prim = SAdd | SMul
+  prim = SAdd | SMul | SMinus
 End
 
 Datatype:
-  val = Prim prim | SNum num | Wrong string | SBool bool
+  val = Prim prim | SNum int | Wrong string | SBool bool
       | SList (val list)
       (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) 'a*)
 End
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index a5304afcf3..002fc0eea4 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -28,6 +28,14 @@ Definition smul_def:
   smul _ excons (_ :: xs) _ = excons $ strlit "Arguments to * must be numbers"
 End
 
+Definition sminus_def:
+  sminus [] = Exception $ strlit "Arity mismatch" ∧
+  sminus (SNum n :: xs) = (case sadd Val Exception xs 0 of
+  | Val (SNum m) => Val (SNum (n - m))
+  | e => e) ∧
+  sminus _ = Exception $ strlit "Arguments to - must be numbers"
+End
+
 (*
 Definition strict_def:
   strict (Prim SAdd) xs = sadd xs 0 ∧
@@ -52,7 +60,8 @@ End
 Definition application_def:
   application vcons excons env ks (Prim p) xs = (case p of
   | SAdd => (env, ks, sadd vcons excons xs 0)
-  | SMul => (env, ks, smul vcons excons xs 1)) ∧
+  | SMul => (env, ks, smul vcons excons xs 1)
+  | SMinus => (env, ks, sminus xs)) ∧
   (*application _ excons env ks (Proc env' ps lp e) xs =
     parameterize excons env ks env' ps lp e xs ∧*)
   application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
@@ -111,7 +120,7 @@ End
 (*
   EVAL “semantics (Val (SNum 3))”
   EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
-  EVAL “steps 4 ([], [], Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
+  EVAL “steps 4 ([], [], Apply (Val (Prim SMinus)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 4 ([], [], Apply (Val (SNum 7)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
   EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index c8b8f3556d..c59677dab2 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -13,8 +13,9 @@ val _ = new_theory "scheme_to_cake";
 Definition to_ml_vals_def:
   to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
   | SAdd => Con (SOME $ Short "SAdd") []
-  | SMul => Con (SOME $ Short "SMul") []] ∧
-  to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit &n] ∧
+  | SMul => Con (SOME $ Short "SMul") []
+  | SMinus => Con (SOME $ Short "SMinus") []] ∧
+  to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
   to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
     if b then 1 else 0]
 End
@@ -34,6 +35,8 @@ Definition app_ml_def:
         App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
       (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
         App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
+        App Opapp [Var (Short "sminus"); Var (Short k)]);
       (Pany, cex)
     ])
 End
@@ -85,6 +88,7 @@ Definition myC_def:
     ("Prim", (1, TypeStamp "Prim" 0));
     ("SAdd", (0, TypeStamp "SAdd" 1));
     ("SMul", (0, TypeStamp "SMul" 1));
+    ("SMinus", (0, TypeStamp "SMinus" 1));
     ("cons", (2, TypeStamp "cons" 2));
     ("nil", (0, TypeStamp "nil" 2));
     ("Ex", (1, TypeStamp "Ex" 0));
@@ -92,7 +96,7 @@ Definition myC_def:
 End
 
 Definition myEnv_def:
-  myEnv = <| v := Bind [
+  myEnv = <| v := let first = Bind [
     ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
       ("sadd", "k",
         Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
@@ -134,6 +138,29 @@ Definition myEnv_def:
       ])
     ] "smul")
   ] []
+  in nsAppend first $ Bind [
+    ("sminus", Closure <| v := first; c := myC |> "k" (Fun "xs" $
+      Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "n"],
+              App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+                Fun "t" $ Mat (Var (Short "t")) [
+                  (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                    App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [
+                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]]);
+                  (Pany,
+                    App Opapp [Var (Short "k"); Var (Short "t")])
+                ]];
+                Lit $ IntLit 0]; Var (Short "xs'")]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ]
+    ))
+  ] []
 ; c := myC
 |>
 End
@@ -153,11 +180,12 @@ End
 val _ = export_theory();
 
 (*
+  open scheme_to_cakeTheory;
   open evaluateTheory;
 
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMinus) [Val $ SNum 2; Val $ SNum 3])]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
-  EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
+  EVAL “scheme_program_to_cake (Apply (Val $ Prim SMinus) [Val $ SNum 2; Val $ SNum 3])”
 *)
\ No newline at end of file

From 4851bef9e49959ccb7beaacb551b1275f2cc4d02 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 22 Feb 2025 21:10:50 +0000
Subject: [PATCH 041/100] eqv

---
 compiler/scheme/scheme_astScript.sml       |  2 +-
 compiler/scheme/scheme_semanticsScript.sml |  9 ++++++-
 compiler/scheme/scheme_to_cakeScript.sml   | 29 ++++++++++++++++++++--
 3 files changed, 36 insertions(+), 4 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index b2fa46c7dc..04e4416405 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -8,7 +8,7 @@ val _ = new_theory "scheme_ast";
 
 (* This needs completing: Var, Lit, ... *)
 Datatype:
-  prim = SAdd | SMul | SMinus
+  prim = SAdd | SMul | SMinus | SEqv
 End
 
 Datatype:
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 002fc0eea4..b0b8b5e43c 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -36,6 +36,11 @@ Definition sminus_def:
   sminus _ = Exception $ strlit "Arguments to - must be numbers"
 End
 
+Definition seqv_def:
+  seqv [v1; v2] = (if v1 = v2 then Val $ SBool T else Val $ SBool F) ∧
+  seqv _ = Exception $ strlit "Arity mismatch"
+End
+
 (*
 Definition strict_def:
   strict (Prim SAdd) xs = sadd xs 0 ∧
@@ -61,7 +66,8 @@ Definition application_def:
   application vcons excons env ks (Prim p) xs = (case p of
   | SAdd => (env, ks, sadd vcons excons xs 0)
   | SMul => (env, ks, smul vcons excons xs 1)
-  | SMinus => (env, ks, sminus xs)) ∧
+  | SMinus => (env, ks, sminus xs)
+  | SEqv => (env, ks, seqv xs)) ∧
   (*application _ excons env ks (Proc env' ps lp e) xs =
     parameterize excons env ks env' ps lp e xs ∧*)
   application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
@@ -127,6 +133,7 @@ End
   EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”
   EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”
   EVAL “steps 3 ([], [], Begin (Val $ SNum 1) [Val $ SNum 2])”
+  EVAL “steps 10 ([], [], Apply (Val $ Prim SEqv) [Val $ SNum 3; Val $ SNum 2])”
 *)
 
 val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index c59677dab2..8944425e9b 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -14,7 +14,8 @@ Definition to_ml_vals_def:
   to_ml_vals (Prim p) = Con (SOME $ Short "Prim") [case p of
   | SAdd => Con (SOME $ Short "SAdd") []
   | SMul => Con (SOME $ Short "SMul") []
-  | SMinus => Con (SOME $ Short "SMinus") []] ∧
+  | SMinus => Con (SOME $ Short "SMinus") []
+  | SEqv => Con (SOME $ Short "SEqv") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
   to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
     if b then 1 else 0]
@@ -37,6 +38,8 @@ Definition app_ml_def:
         App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
       (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
         App Opapp [Var (Short "sminus"); Var (Short k)]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
+        App Opapp [Var (Short "seqv"); Var (Short k)]);
       (Pany, cex)
     ])
 End
@@ -89,6 +92,7 @@ Definition myC_def:
     ("SAdd", (0, TypeStamp "SAdd" 1));
     ("SMul", (0, TypeStamp "SMul" 1));
     ("SMinus", (0, TypeStamp "SMinus" 1));
+    ("SEqv", (0, TypeStamp "SEqv" 1));
     ("cons", (2, TypeStamp "cons" 2));
     ("nil", (0, TypeStamp "nil" 2));
     ("Ex", (1, TypeStamp "Ex" 0));
@@ -136,7 +140,27 @@ Definition myEnv_def:
               Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
           ])
       ])
-    ] "smul")
+    ] "smul");
+    ("seqv", Closure <| v := nsEmpty; c := myC |> "k" (Fun "xs" $
+      Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        (Pcon (SOME $ Short "cons") [Pvar "x1"; Pvar "xs'"],
+          Mat (Var (Short "xs'")) [
+            (Pcon (SOME $ Short "nil") [],
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+            (Pcon (SOME $ Short "cons") [Pvar "x2"; Pvar "xs''"],
+              Mat (Var (Short "xs''")) [
+                (Pcon (SOME $ Short "nil") [],
+                  If (App Equality [Var (Short "x1"); Var (Short "x2")])
+                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Lit $ IntLit 1]])
+                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Lit $ IntLit 0]]));
+                (Pany,
+                  Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+              ])
+          ])
+      ]
+    ))
   ] []
   in nsAppend first $ Bind [
     ("sminus", Closure <| v := first; c := myC |> "k" (Fun "xs" $
@@ -186,6 +210,7 @@ val _ = export_theory();
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
   EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMinus) [Val $ SNum 2; Val $ SNum 3])]”
+  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SEqv) [Val $ SNum 2; Val $ SNum 2])]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMinus) [Val $ SNum 2; Val $ SNum 3])”
 *)
\ No newline at end of file

From ff623c6fb014558ef3bd5e5aea30c3a3c7b4af21 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 23 Feb 2025 14:28:36 +0000
Subject: [PATCH 042/100] cleanup after removal of intermediate step

---
 compiler/scheme/scheme_astScript.sml       |  4 +-
 compiler/scheme/scheme_semanticsScript.sml | 72 +++++++++++-----------
 2 files changed, 38 insertions(+), 38 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 04e4416405..019cf5aee0 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -14,13 +14,13 @@ End
 Datatype:
   val = Prim prim | SNum int | Wrong string | SBool bool
       | SList (val list)
-      (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) 'a*)
+      (*| Proc ((mlstring # val) list) (mlstring list) (mlstring option) exp*)
 End
 
 Datatype:
   exp = Print mlstring
       | Apply exp (exp list)
-      | Val ((*exp*) val)
+      | Val (val)
       | Cond exp exp exp
       | Ident mlstring
       | SLet ((mlstring # exp) list) exp
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index b0b8b5e43c..638895fe2b 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -9,28 +9,28 @@ val _ = new_theory "scheme_semantics";
 
 Datatype:
   (*Contexts for small-step operational semantics*)
-  cont = ApplyK (((*'a*) val # (*'a*) val list) option) ('a list)
-       | CondK 'a 'a
-       | LetK ((mlstring # (*'a*) val) list) mlstring ((mlstring # 'a) list) 'a
-       | InLetK ((mlstring # (*'a*) val) list)
-       | BeginK ('a list)
+  cont = ApplyK ((val # val list) option) (exp list)
+       | CondK exp exp
+       | LetK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
+       | InLetK ((mlstring # val) list)
+       | BeginK (exp list)
 End
 
 Definition sadd_def:
-  sadd vcons _ [] n = vcons $ SNum n ∧
-  sadd vcons excons (SNum m :: xs) n = sadd vcons excons xs (m + n) ∧
-  sadd _ excons (_ :: xs) _ = excons $ strlit "Arguments to + must be numbers"
+  sadd [] n = Val $ SNum n ∧
+  sadd (SNum m :: xs) n = sadd xs (m + n) ∧
+  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
 End
 
 Definition smul_def:
-  smul vcons _ [] n = vcons $ SNum n ∧
-  smul vcons excons (SNum m :: xs) n = smul vcons excons xs (m * n) ∧
-  smul _ excons (_ :: xs) _ = excons $ strlit "Arguments to * must be numbers"
+  smul [] n = Val $ SNum n ∧
+  smul (SNum m :: xs) n = smul xs (m * n) ∧
+  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
 End
 
 Definition sminus_def:
   sminus [] = Exception $ strlit "Arity mismatch" ∧
-  sminus (SNum n :: xs) = (case sadd Val Exception xs 0 of
+  sminus (SNum n :: xs) = (case sadd xs 0 of
   | Val (SNum m) => Val (SNum (n - m))
   | e => e) ∧
   sminus _ = Exception $ strlit "Arguments to - must be numbers"
@@ -56,53 +56,53 @@ End
 *)
 
 Definition parameterize_def:
-  parameterize _ env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
-  parameterize _ env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
-  parameterize excons env ks env' (p::ps) lp e (x::xs) = parameterize excons env ks ((p, x)::env') ps lp e xs ∧
-  parameterize excons env ks _ _ _ _ _ = (env, ks, excons $ strlit "Wrong number of arguments")
+  parameterize env ks env' [] NONE e [] = (env', InLetK env :: ks, e) ∧
+  parameterize env ks env' [] (SOME l) e xs = ((l, SList xs)::env', InLetK env :: ks, e) ∧
+  parameterize env ks env' (p::ps) lp e (x::xs) = parameterize env ks ((p, x)::env') ps lp e xs ∧
+  parameterize env ks _ _ _ _ _ = (env, ks, Exception $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
-  application vcons excons env ks (Prim p) xs = (case p of
-  | SAdd => (env, ks, sadd vcons excons xs 0)
-  | SMul => (env, ks, smul vcons excons xs 1)
+  application env ks (Prim p) xs = (case p of
+  | SAdd => (env, ks, sadd xs 0)
+  | SMul => (env, ks, smul xs 1)
   | SMinus => (env, ks, sminus xs)
   | SEqv => (env, ks, seqv xs)) ∧
-  (*application _ excons env ks (Proc env' ps lp e) xs =
-    parameterize excons env ks env' ps lp e xs ∧*)
-  application _ excons env ks _ _ = (env, ks, excons $ strlit "Not a procedure")
+  (*application env ks (Proc env' ps lp e) xs =
+    parameterize env ks env' ps lp e xs ∧*)
+  application env ks _ _ = (env, ks, Exception $ strlit "Not a procedure")
 End
 
 Definition return_def:
-  return vcons _ (env, [], v) = (env, [], vcons v) ∧
+  return (env, [], v) = (env, [], Val v) ∧
 
-  return vcons excons (env, ApplyK NONE eargs :: ks, v) = (case eargs of
-  | [] => application vcons excons env ks v []
+  return (env, ApplyK NONE eargs :: ks, v) = (case eargs of
+  | [] => application env ks v []
   | e::es => (env, ApplyK (SOME (v, [])) es :: ks, e)) ∧
-  return vcons excons (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
-  | [] => application vcons excons env ks vfn (REVERSE $ v::vargs)
+  return (env, ApplyK (SOME (vfn, vargs)) eargs :: ks, v) = (case eargs of
+  | [] => application env ks vfn (REVERSE $ v::vargs)
   | e::es => (env, ApplyK (SOME (vfn, v::vargs)) es :: ks, e)) ∧
 
-  return _ _ (env, CondK t f :: ks, v) = (if v = (SBool F)
+  return (env, CondK t f :: ks, v) = (if v = (SBool F)
     then (env, ks, f) else (env, ks, t)) ∧
 
-  return _ _ (env, LetK env' i is e :: ks, v) = (case is of
+  return (env, LetK env' i is e :: ks, v) = (case is of
   | [] => ((i, v)::env', InLetK env :: ks, e)
   | (i', e')::is' => (env, LetK ((i, v)::env') i' is' e :: ks, e')) ∧
 
-  return vcons _ (env, InLetK env' :: ks, v) = (env', ks, vcons v) ∧
-  return vcons _ (env, BeginK es :: ks, v) = case es of
-  | [] => (env, ks, vcons v)
+  return (env, InLetK env' :: ks, v) = (env', ks, Val v) ∧
+  return (env, BeginK es :: ks, v) = case es of
+  | [] => (env, ks, Val v)
   | e::es' => (env, BeginK es' :: ks, e)
 End
 
 Definition unwind_def:
-  unwind excons env [] ex = (env, [], excons ex) ∧
-  unwind excons env (k::ks) ex = unwind excons env ks ex
+  unwind env [] ex = (env, [], Exception ex) ∧
+  unwind env (k::ks) ex = unwind env ks ex
 End
 
 Definition step_def:
-  step (env, ks, Val v) = return Val Exception (env, ks, v) ∧
+  step (env, ks, Val v) = return (env, ks, v) ∧
   step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
   step (env, ks, Cond c t f) = (env, CondK t f :: ks, c) ∧
   step (env, ks, Ident s) = (let v' = case FIND ($= s o FST) env of
@@ -115,7 +115,7 @@ Definition step_def:
   (*step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧*)
   step (env, ks, Begin e es) = (env, BeginK es :: ks, e) ∧
 
-  step (env, ks, Exception ex) = unwind Exception env ks ex
+  step (env, ks, Exception ex) = unwind env ks ex
 End
 
 Definition steps_def:

From 435804a9ae9229fa74555705ccec11bee1b2fcb0 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 23 Feb 2025 14:31:07 +0000
Subject: [PATCH 043/100] exceptions ditch continuation

---
 compiler/scheme/scheme_semanticsScript.sml | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 638895fe2b..9a2fa07fae 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -96,11 +96,6 @@ Definition return_def:
   | e::es' => (env, BeginK es' :: ks, e)
 End
 
-Definition unwind_def:
-  unwind env [] ex = (env, [], Exception ex) ∧
-  unwind env (k::ks) ex = unwind env ks ex
-End
-
 Definition step_def:
   step (env, ks, Val v) = return (env, ks, v) ∧
   step (env, ks, Apply fn args) = (env, ApplyK NONE args :: ks, fn) ∧
@@ -115,7 +110,7 @@ Definition step_def:
   (*step (env, ks, Lambda ps lp e) = (env, ks, Val $ Proc env ps lp e) ∧*)
   step (env, ks, Begin e es) = (env, BeginK es :: ks, e) ∧
 
-  step (env, ks, Exception ex) = unwind env ks ex
+  step (env, ks, Exception ex) = (env, [], Exception ex)
 End
 
 Definition steps_def:
@@ -124,6 +119,8 @@ Definition steps_def:
 End
 
 (*
+  open scheme_semanticsTheory;
+
   EVAL “semantics (Val (SNum 3))”
   EVAL “semantics (Apply (Val (Prim SMul)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 4 ([], [], Apply (Val (Prim SMinus)) [Val (SNum 2); Val (SNum 4)])”
@@ -131,7 +128,7 @@ End
   EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
   EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”
   EVAL “steps 4 ([], [], SLet [(strlit "x", Val $ SNum 42)] (Ident $ strlit "x"))”
-  EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 4])”
+  EVAL “steps 6 ([], [], Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "y")) [Val $ SNum 4])”
   EVAL “steps 3 ([], [], Begin (Val $ SNum 1) [Val $ SNum 2])”
   EVAL “steps 10 ([], [], Apply (Val $ Prim SEqv) [Val $ SNum 3; Val $ SNum 2])”
 *)

From 5966708d7d9f212ab99c210499e4e87dbe4811c4 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 23 Feb 2025 15:14:40 +0000
Subject: [PATCH 044/100] factorial example

---
 compiler/scheme/scheme_semanticsScript.sml | 12 +++++++++++-
 compiler/scheme/scheme_to_cakeScript.sml   | 10 ++++++++++
 2 files changed, 21 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index a117710368..73570b6b2f 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -226,7 +226,17 @@ End
     Letrec [(strlit $ "fail", Ident $ strlit "fail")] (Val $ SBool F)
   )”
 
-  EVAL “steps 10 ([], [], Apply (Val $ Prim SEqv) [Val $ SNum 3; Val $ SNum 2])”
+  EVAL “steps 10 ([], [], FEMPTY, Apply (Val $ Prim SMinus) [Val $ SNum 3; Val $ SNum 2])”
+
+  EVAL “steps 1000 ([], [], FEMPTY, Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+    Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0]) (
+      Val $ SNum 1
+    ) (
+      Apply (Val $ Prim SMul) [Ident $ strlit "x"; Apply (Ident $ strlit "fac") [
+        Apply (Val $ Prim SMinus) [Ident $ strlit "x"; Val $ SNum 1]
+      ]]
+    )
+  ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
 *)
 
 val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index fc8a022caa..87482b33d0 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -325,6 +325,16 @@ val _ = export_theory();
       Apply (Ident $ strlit "f") [Val $ SBool F; Val $ SNum 7]
     )
   )]”
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
+    Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+      Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0]) (
+        Val $ SNum 1
+      ) (
+        Apply (Val $ Prim SMul) [Ident $ strlit "x"; Apply (Ident $ strlit "fac") [
+          Apply (Val $ Prim SMinus) [Ident $ strlit "x"; Val $ SNum 1]
+        ]]
+      )
+    ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”

From 31a4bf89a451457e7b518683c8429008cdf6a0fa Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 23 Feb 2025 15:37:51 +0000
Subject: [PATCH 045/100] redundant envs

---
 compiler/scheme/scheme_astScript.sml       |  2 +-
 compiler/scheme/scheme_semanticsScript.sml | 24 +++++++++++-----------
 2 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index bd534637f0..6703aa55dd 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -18,7 +18,7 @@ Datatype:
       | SList (val list)
       | Proc senv (mlstring list) (mlstring option) exp
       (*requires HOL 94eb753a85c5628f4fd0401deb4b7e2972a8eb25*)
-      | Throw senv ((senv # cont) list)
+      | Throw ((senv # cont) list)
 ;
   (*Contexts for small-step operational semantics*)
   cont = ApplyK ((val # val list) option) (exp list)
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index ac643bdaaf..3fbd7758ef 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -67,33 +67,33 @@ Definition application_def:
   | SMinus => (store, ks, FEMPTY, sminus xs)
   | SEqv => (store, ks, FEMPTY, seqv xs)
   | CallCC => case xs of
-    | [v] => (store, (env, ApplyK (SOME (v, [])) []) :: ks, env, Val $ Throw env ks)
-    | _ => (store, ks, env, Exception $ strlit "arity mismatch")) ∧
+    | [v] => (store, (FEMPTY, ApplyK (SOME (v, [])) []) :: ks, FEMPTY, Val $ Throw ks)
+    | _ => (store, ks, FEMPTY, Exception $ strlit "arity mismatch")) ∧
   application store ks (Proc env ps lp e) xs =
     parameterize store ks env ps lp e xs ∧
-  application store ks (Throw env' ks') xs = (case xs of
-    | [v] => (store, ks', env', Val v)
-    | _ => (store, ks, env, Exception $ strlit "arity mismatch")) ∧
+  application store ks (Throw ks') xs = (case xs of
+    | [v] => (store, ks', FEMPTY, Val v)
+    | _ => (store, ks, FEMPTY, Exception $ strlit "arity mismatch")) ∧
   application store ks _ _ = (store, ks, FEMPTY, Exception $ strlit "Not a procedure")
 End
 
 Definition return_def:
-  return (store, [], env, v) = (store, [], env, Val v) ∧
+  return store [] v = (store, [], FEMPTY, Val v) ∧
 
-  return (store, (env, ApplyK NONE eargs) :: ks, _, v) = (case eargs of
+  return store ((env, ApplyK NONE eargs) :: ks) v = (case eargs of
   | [] => application store ks v []
   | e::es => (store, (env, ApplyK (SOME (v, [])) es) :: ks, env, e)) ∧
-  return (store, (env, ApplyK (SOME (vfn, vargs)) eargs) :: ks, _, v) = (case eargs of
+  return store ((env, ApplyK (SOME (vfn, vargs)) eargs) :: ks) v = (case eargs of
   | [] => application store ks vfn (REVERSE $ v::vargs)
   | e::es => (store, (env, ApplyK (SOME (vfn, v::vargs)) es) :: ks, env, e)) ∧
 
-  return (store, (env, CondK t f) :: ks, _, v) = (if v = (SBool F)
+  return store ((env, CondK t f) :: ks) v = (if v = (SBool F)
     then (store, ks, env, f) else (store, ks, env, t)) ∧
 
-  return (store, (env, BeginK es) :: ks, _, v) = (case es of
+  return store ((env, BeginK es) :: ks) v = (case es of
   | [] => (store, ks, env, Val v)
   | e::es' => (store, (env, BeginK es') :: ks, env, e)) ∧
-  return (store, (env, SetK x) :: ks, _, v) = (LUPDATE (SOME v) (env ' x) store, ks, env, Val $ Wrong "Unspecified")
+  return store ((env, SetK x) :: ks) v = (LUPDATE (SOME v) (env ' x) store, ks, env, Val $ Wrong "Unspecified")
 End
 
 Definition letrec_init_def:
@@ -103,7 +103,7 @@ Definition letrec_init_def:
 End
 
 Definition step_def:
-  step (store, ks, env, Val v) = return (store, ks, env, v) ∧
+  step (store, ks, env, Val v) = return store ks v ∧
   step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
   step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
   (*This is undefined if the program doesn't typecheck*)

From a5df19ca3d1588e5d5c546d413edf5561a8cb313 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 23 Feb 2025 20:47:38 +0000
Subject: [PATCH 046/100] compile callcc

---
 compiler/scheme/scheme_semanticsScript.sml | 22 ++++++
 compiler/scheme/scheme_to_cakeScript.sml   | 91 ++++++++++++++++++++--
 2 files changed, 105 insertions(+), 8 deletions(-)

diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 3fbd7758ef..d05021bdd6 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -266,6 +266,28 @@ End
       ]]
     )
   ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
+
+  EVAL “steps 500 ([], [], FEMPTY, Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+    Letrec [(strlit "st", Val $ SNum 0); (strlit "acc", Val $ SNum 1)] (
+      Begin ( Apply (Val $ Prim CallCC) [ Lambda [strlit "k"] NONE (
+        Set (strlit "st") (Ident $ strlit "k")
+      )]) [
+        Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0])
+          (Ident $ strlit "acc")
+          (Apply (Ident $ strlit "st") [ Begin (
+            Set (strlit "acc") (Apply (Val $ Prim SMul) [
+              Ident $ strlit "acc";
+              Ident $ strlit "x"
+            ])
+          ) [
+            Set (strlit "x") (Apply (Val $ Prim SMinus) [
+              Ident $ strlit "x";
+              Val $ SNum 1
+            ])
+          ]])
+      ]
+    )
+  ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
 *)
 
 val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 99e661af03..87a2c65aa8 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -15,7 +15,8 @@ Definition to_ml_vals_def:
   | SAdd => Con (SOME $ Short "SAdd") []
   | SMul => Con (SOME $ Short "SMul") []
   | SMinus => Con (SOME $ Short "SMinus") []
-  | SEqv => Con (SOME $ Short "SEqv") []] ∧
+  | SEqv => Con (SOME $ Short "SEqv") []
+  | CallCC => Con (SOME $ Short "CallCC") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
   to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
     if b then 1 else 0]
@@ -39,8 +40,12 @@ Definition app_ml_def:
         App Opapp [Var (Short "sminus"); Var (Short k)]);
       (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
         App Opapp [Var (Short "seqv"); Var (Short k)]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
+        App Opapp [Var (Short "callcc"); Var (Short k)]);
       (Pcon (SOME $ Short "Proc") [Pvar "e"],
         App Opapp [Var (Short "e"); Var (Short k)]);
+      (Pcon (SOME $ Short "Throw") [Pvar "k'"],
+        App Opapp [Var (Short "throw"); Var (Short "k'")]);
       (Pany, cex)
     ])
 End
@@ -188,12 +193,14 @@ Definition myC_def:
     ("SBool", (1, TypeStamp "SBool" 0));
     ("SList", (1, TypeStamp "SList" 0));
     ("Proc", (1, TypeStamp "Proc" 0));
+    ("Throw", (1, TypeStamp "Throw" 0));
     ("Prim", (1, TypeStamp "Prim" 0));
     ("Wrong", (1, TypeStamp "Wrong" 0));
     ("SAdd", (0, TypeStamp "SAdd" 1));
     ("SMul", (0, TypeStamp "SMul" 1));
     ("SMinus", (0, TypeStamp "SMinus" 1));
     ("SEqv", (0, TypeStamp "SEqv" 1));
+    ("CallCC", (0, TypeStamp "CallCC" 1));
     ("cons", (2, TypeStamp "cons" 2));
     ("nil", (0, TypeStamp "nil" 2));
     ("Ex", (1, TypeStamp "Ex" 0));
@@ -205,8 +212,7 @@ End
 Definition myEnv_def:
   myEnv = <| v := let first = Bind [
     ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
-      ("sadd", "k",
-        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "nil") [],
           App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
         (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
@@ -225,8 +231,7 @@ Definition myEnv_def:
       ])
     ] "sadd");
     ("smul", Recclosure <| v := nsEmpty; c := myC |> [
-      ("smul", "k",
-        Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "nil") [],
           App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
         (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
@@ -263,9 +268,22 @@ Definition myEnv_def:
               ])
           ])
       ]
-    ))
-  ] []
-  in nsAppend first $ Bind [
+    ));
+    ("throw", Closure <| v := nsEmpty; c := myC |> "k" (Fun "xs" $
+      Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "xs'")) [
+            (Pcon (SOME $ Short "nil") [],
+              App Opapp [Var (Short "k"); Var (Short "x")]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+          ])
+      ]
+    ));
+  ] [];
+  second = nsAppend first $ Bind [
     ("sminus", Closure <| v := first; c := myC |> "k" (Fun "xs" $
       Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "nil") [],
@@ -288,6 +306,24 @@ Definition myEnv_def:
       ]
     ))
   ] []
+  in nsAppend second $ Bind [
+    ("callcc", Recclosure <| v := second; c := myC |> [
+      ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "nil") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "xs'")) [
+            (Pcon (SOME $ Short "nil") [],
+              App Opapp [SND $ app_ml 0 "k" "x";
+                Con (SOME $ Short "cons") [Con (SOME $ Short "Throw")
+                  [Var (Short "k")];
+                  Con (SOME $ Short "nil") []]]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
+          ])
+      ])
+    ] "callcc");
+  ] []
 ; c := myC
 |>
 End
@@ -335,9 +371,48 @@ val _ = export_theory();
         ]]
       )
     ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))]”
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
+    Apply (Val $ Prim SMul) [
+      Val $ SNum 2;
+      Apply (Val $ Prim CallCC) [ Lambda [strlit "x"] NONE (
+        Apply (Val $ Prim SAdd) [
+          Val $ SNum 4;
+          Cond (Val $ SBool T) (
+            Val $ SNum 3
+          ) (
+            Apply (Ident $ strlit "x") [Val $ SNum 5]
+          )
+        ]
+      )]
+    ]
+  )]”
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
+    Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+      Letrec [(strlit "st", Val $ SNum 0); (strlit "acc", Val $ SNum 1)] (
+        Begin ( Apply (Val $ Prim CallCC) [ Lambda [strlit "k"] NONE (
+          Set (strlit "st") (Ident $ strlit "k")
+        )]) [
+          Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0])
+            (Ident $ strlit "acc")
+            (Apply (Ident $ strlit "st") [ Begin (
+              Set (strlit "acc") (Apply (Val $ Prim SMul) [
+                Ident $ strlit "acc";
+                Ident $ strlit "x"
+              ])
+            ) [
+              Set (strlit "x") (Apply (Val $ Prim SMinus) [
+                Ident $ strlit "x";
+                Val $ SNum 1
+              ])
+            ]])
+        ]
+      )
+    ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6])
+  )]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
   EVAL “scheme_program_to_cake (Begin (Val $ SNum 0) [Val $ SNum 1; Val $ SNum 2])”
   EVAL “scheme_program_to_cake (Letrec [(strlit "x", Val $ SNum 1)] (Ident $ strlit "x"))”
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Val $ Prim CallCC) [Lambda [strlit "x"] NONE $ Apply (Ident $ strlit "x") [Val $ SNum 5]])]”
 *)
\ No newline at end of file

From ae6e72667949f2fdc6b3f57c38aa2c65610e75f1 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 1 Mar 2025 00:38:11 +0000
Subject: [PATCH 047/100] factored out app ML-side

---
 compiler/scheme/scheme_to_cakeScript.sml | 61 ++++++++++++------------
 1 file changed, 30 insertions(+), 31 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 87a2c65aa8..48298e6d8d 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -27,29 +27,6 @@ Definition cons_list_def:
   cons_list (x::xs) = Con (SOME $ Short "cons") [Var (Short x); cons_list xs]
 End
 
-Definition app_ml_def:
-  app_ml n k t = let
-    cex = Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"]
-  in
-    (n, Mat (Var (Short t)) [
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
-        App Opapp [App Opapp [Var (Short "sadd"); Var (Short k)]; Lit $ IntLit 0]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
-        App Opapp [App Opapp [Var (Short "smul"); Var (Short k)]; Lit $ IntLit 1]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
-        App Opapp [Var (Short "sminus"); Var (Short k)]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
-        App Opapp [Var (Short "seqv"); Var (Short k)]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
-        App Opapp [Var (Short "callcc"); Var (Short k)]);
-      (Pcon (SOME $ Short "Proc") [Pvar "e"],
-        App Opapp [Var (Short "e"); Var (Short k)]);
-      (Pcon (SOME $ Short "Throw") [Pvar "k'"],
-        App Opapp [Var (Short "throw"); Var (Short "k'")]);
-      (Pany, cex)
-    ])
-End
-
 Definition proc_ml_def:
   proc_ml n [] NONE k args ce = (n, Mat (Var (Short args)) [
         (Pcon (SOME $ Short "nil") [],
@@ -147,10 +124,12 @@ Definition cps_transform_def:
     (l, inner) = cps_transform_app (m+1) tfn (t::ts) es k
   in
     (l, App Opapp [ce; Fun t inner])) ∧
-  cps_transform_app n tfn ts [] k = (let
-    (m, capp) = app_ml n k tfn;
-  in
-    (m, App Opapp [capp;cons_list (REVERSE ts)])) ∧
+  cps_transform_app n tfn ts [] k = (n,
+    App Opapp [
+      App Opapp [
+        App Opapp [Var (Short "app"); Var (Short k)];
+        Var (Short tfn)];
+      cons_list (REVERSE ts)]) ∧
 
   cps_transform_seq n k [] = (n, Var (Short k)) ∧
   cps_transform_seq n k (e::es) = (let
@@ -307,22 +286,42 @@ Definition myEnv_def:
     ))
   ] []
   in nsAppend second $ Bind [
-    ("callcc", Recclosure <| v := second; c := myC |> [
+    ("app", Recclosure <| v := second; c := myC |> [
       ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "nil") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
         (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "xs'")) [
             (Pcon (SOME $ Short "nil") [],
-              App Opapp [SND $ app_ml 0 "k" "x";
+              App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "app");Var (Short "k")];
+                  Var (Short "x")];
                 Con (SOME $ Short "cons") [Con (SOME $ Short "Throw")
                   [Var (Short "k")];
                   Con (SOME $ Short "nil") []]]);
             (Pany,
               Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
           ])
-      ])
-    ] "callcc");
+      ]);
+      ("app", "k", Fun "fn" $ Mat (Var (Short "fn")) [
+        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
+          App Opapp [App Opapp [Var (Short "sadd"); Var (Short "k")]; Lit $ IntLit 0]);
+        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
+          App Opapp [App Opapp [Var (Short "smul"); Var (Short "k")]; Lit $ IntLit 1]);
+        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
+          App Opapp [Var (Short "sminus"); Var (Short "k")]);
+        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
+          App Opapp [Var (Short "seqv"); Var (Short "k")]);
+        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
+          App Opapp [Var (Short "callcc"); Var (Short "k")]);
+        (Pcon (SOME $ Short "Proc") [Pvar "e"],
+          App Opapp [Var (Short "e"); Var (Short "k")]);
+        (Pcon (SOME $ Short "Throw") [Pvar "k'"],
+          App Opapp [Var (Short "throw"); Var (Short "k'")]);
+        (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
+    ])
+    ] "app");
   ] []
 ; c := myC
 |>

From 8555aef24f034e446dba9debaa6308b8cd69472f Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sun, 2 Mar 2025 02:03:07 +0000
Subject: [PATCH 048/100] factor out cps transform for contexts, cond and app

---
 compiler/scheme/scheme_to_cakeScript.sml | 53 +++++++++++++++---------
 1 file changed, 33 insertions(+), 20 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 48298e6d8d..f5e7004cdc 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -24,7 +24,7 @@ End
 
 Definition cons_list_def:
   cons_list [] = Con (SOME $ Short "nil") [] ∧
-  cons_list (x::xs) = Con (SOME $ Short "cons") [Var (Short x); cons_list xs]
+  cons_list (x::xs) = Con (SOME $ Short "cons") [x; cons_list xs]
 End
 
 Definition proc_ml_def:
@@ -65,22 +65,16 @@ Definition cps_transform_def:
     (n, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]) ∧
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
-    (l, ct) = cps_transform m t;
-    (j, cf) = cps_transform l f;
-    p = "t" ++ toString j;
-    k = "k" ++ toString (j+1)
+    k = "k" ++ toString m;
+    (l, ck) = cps_transform_cont (m+1) (CondK t f) k
   in
-    (j+2, Fun k $ App Opapp [cc;  Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; Var (Short k)]);
-      (Pany, App Opapp [ct; Var (Short k)])
-    ]])) ∧
+    (l, Fun k $ App Opapp [cc; ck])) ∧
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;
-    t = "t" ++ toString (m+1);
-    (l, ce) = cps_transform_app (m+2) t [] args k
+    (l, ck) = cps_transform_cont (m+1) (ApplyK NONE args) k
   in
-    (l, Fun k $ App Opapp [cfn; Fun t ce])) ∧
+    (l, Fun k $ App Opapp [cfn; ck])) ∧
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
     (n, Fun k $ Mat (App Opderef [Var (Short $ "s" ++ explode x)]) [
       (Pcon (SOME $ Short "None") [],
@@ -118,17 +112,33 @@ Definition cps_transform_def:
   in
     (l, Fun k $ letinit_ml bs inner)) ∧
 
+  cps_transform_cont n (CondK t f) k = (let
+    (m, ct) = cps_transform n t;
+    (l, cf) = cps_transform m f;
+    p = "t" ++ toString l;
+  in
+    (l+1, Fun p $ Mat (Var (Short p)) [
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; Var (Short k)]);
+      (Pany, App Opapp [ct; Var (Short k)])
+    ])) ∧
+  cps_transform_cont n (ApplyK NONE es) k = (let
+    t = "t" ++ toString n;
+    (m, ce) = cps_transform_app (n+1) (Var (Short t)) [] es k
+  in
+    (m, Fun t ce)
+  ) ∧
+  cps_transform_cont n (ApplyK (SOME (f, vs)) es) k =
+    cps_transform_app n (to_ml_vals f) (MAP to_ml_vals vs) es k ∧
+
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
     t = "t" ++ toString m;
-    (l, inner) = cps_transform_app (m+1) tfn (t::ts) es k
+    (l, inner) = cps_transform_app (m+1) tfn (Var (Short t)::ts) es k
   in
     (l, App Opapp [ce; Fun t inner])) ∧
   cps_transform_app n tfn ts [] k = (n,
     App Opapp [
-      App Opapp [
-        App Opapp [Var (Short "app"); Var (Short k)];
-        Var (Short tfn)];
+      App Opapp [App Opapp [Var (Short "app"); Var (Short k)]; tfn];
       cons_list (REVERSE ts)]) ∧
 
   cps_transform_seq n k [] = (n, Var (Short k)) ∧
@@ -152,10 +162,13 @@ Definition cps_transform_def:
 Termination
   WF_REL_TAC ‘measure (λ x . case x of
     | INL(_,e) => exp_size e
-    | INR(INL(_,_,_,es,_)) => list_size exp_size es
-    | INR(INR(INL(_,_,es))) => list_size exp_size es
-    | INR(INR(INR(_,_,es,_))) => list_size (exp_size o SND) es)’
-  >> Induct >- (rw[val_size_def, list_size_def])
+    | INR(INL(_,k,_)) => cont_size k
+    | INR(INR(INL(_,_,_,es,_))) => list_size exp_size es
+    | INR(INR(INR(INL(_,_,es)))) => list_size exp_size es
+    | INR(INR(INR(INR(_,_,es,_)))) => list_size (exp_size o SND) es)’
+  >> strip_tac >- (Cases >> rw[val_size_def, list_size_def])
+  >> strip_tac >- (Cases >> rw[val_size_def, list_size_def])
+  >> Induct_on ‘bs’ >- (rw[val_size_def, list_size_def])
   >> Cases
   >> rw[val_size_def, list_size_def]
   >> last_x_assum $ qspecl_then [‘e’,‘n’,‘m’,‘ce’] $ mp_tac

From ce5e4892df9f5a4b69a6cd940387ba7c54d028e2 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 7 Mar 2025 00:16:04 +0000
Subject: [PATCH 049/100] cps transform arbitrary continuations

---
 compiler/scheme/scheme_to_cakeScript.sml | 32 ++++++++++++++----------
 1 file changed, 19 insertions(+), 13 deletions(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index f5e7004cdc..1913ea8a03 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -66,13 +66,13 @@ Definition cps_transform_def:
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
     k = "k" ++ toString m;
-    (l, ck) = cps_transform_cont (m+1) (CondK t f) k
+    (l, ck) = cps_transform_cont (m+1) (CondK t f) (Var (Short k))
   in
     (l, Fun k $ App Opapp [cc; ck])) ∧
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;
-    (l, ck) = cps_transform_cont (m+1) (ApplyK NONE args) k
+    (l, ck) = cps_transform_cont (m+1) (ApplyK NONE args) (Var (Short k))
   in
     (l, Fun k $ App Opapp [cfn; ck])) ∧
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
@@ -93,7 +93,7 @@ Definition cps_transform_def:
   cps_transform n (Begin e es) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
-    (l, seqk) = cps_transform_seq (m+1) k es
+    (l, seqk) = cps_transform_seq (m+1) (Var (Short k)) es
   in
     (l, Fun k $ App Opapp [ce; seqk])) ∧
   cps_transform n (Set x e) = (let
@@ -108,7 +108,7 @@ Definition cps_transform_def:
   cps_transform n (Letrec bs e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
-    (l, inner) = cps_transform_letreinit (m+1) k bs ce
+    (l, inner) = cps_transform_letreinit (m+1) (Var (Short k)) bs ce
   in
     (l, Fun k $ letinit_ml bs inner)) ∧
 
@@ -118,8 +118,8 @@ Definition cps_transform_def:
     p = "t" ++ toString l;
   in
     (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; Var (Short k)]);
-      (Pany, App Opapp [ct; Var (Short k)])
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; k]);
+      (Pany, App Opapp [ct; k])
     ])) ∧
   cps_transform_cont n (ApplyK NONE es) k = (let
     t = "t" ++ toString n;
@@ -138,18 +138,17 @@ Definition cps_transform_def:
     (l, App Opapp [ce; Fun t inner])) ∧
   cps_transform_app n tfn ts [] k = (n,
     App Opapp [
-      App Opapp [App Opapp [Var (Short "app"); Var (Short k)]; tfn];
+      App Opapp [App Opapp [Var (Short "app"); k]; tfn];
       cons_list (REVERSE ts)]) ∧
 
-  cps_transform_seq n k [] = (n, Var (Short k)) ∧
+  cps_transform_seq n k [] = (n, k) ∧
   cps_transform_seq n k (e::es) = (let
     (m, ce) = cps_transform n e;
     (l, inner) = cps_transform_seq m k es
   in
     (l, Fun "_" $ App Opapp [ce; inner])) ∧
 
-  cps_transform_letreinit n k [] ce = (n,
-    App Opapp [ce; Var (Short k)]) ∧
+  cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧
   cps_transform_letreinit n k ((x,e)::bs) ce = (let
     (m, ce') = cps_transform n e;
     (l, inner) = cps_transform_letreinit m k bs ce;
@@ -175,6 +174,15 @@ Termination
   >> rw[]
 End
 
+Definition scheme_cont_def:
+  scheme_cont [] = Fun "t" $ Var (Short "t") ∧
+  scheme_cont (k:: ks) = SND $ cps_transform_cont 0 k (scheme_cont ks)
+End
+
+Definition exp_with_cont_def:
+  exp_with_cont k e = App Opapp [SND $ cps_transform 0 e; scheme_cont k]
+End
+
 Definition scheme_program_to_cake_def:
   scheme_program_to_cake p = App Opapp [SND (cps_transform 0 p); Fun "t" $ Var (Short "t")]
 End
@@ -310,9 +318,7 @@ Definition myEnv_def:
                 App Opapp [
                   App Opapp [Var (Short "app");Var (Short "k")];
                   Var (Short "x")];
-                Con (SOME $ Short "cons") [Con (SOME $ Short "Throw")
-                  [Var (Short "k")];
-                  Con (SOME $ Short "nil") []]]);
+                cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
             (Pany,
               Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
           ])

From 5b689f1ce502f9e0cc54100d87f80b9d9a1f660e Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 7 Mar 2025 00:16:17 +0000
Subject: [PATCH 050/100] start at small subset proofs

---
 compiler/scheme/scheme_proofsScript.sml | 158 ++++++++++++++++++++++++
 1 file changed, 158 insertions(+)
 create mode 100644 compiler/scheme/scheme_proofsScript.sml

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
new file mode 100644
index 0000000000..be973be2bd
--- /dev/null
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -0,0 +1,158 @@
+(*
+  Proofs for Scheme to CakeML compilation
+*)
+open preamble;
+open scheme_astTheory;
+open scheme_semanticsTheory;
+open scheme_to_cakeTheory;
+open astTheory;
+
+open evaluateTheory;
+open semanticPrimitivesTheory;
+open namespaceTheory;
+
+val _ = new_theory "scheme_proofs";
+
+(*
+Definition subset1_def:
+  (subset1 (Apply fn args) ⇔ subset1 fn ∧ EVERY subset1 args) ∧
+  (subset1 (Cond c t f) ⇔ subset1 c ∧ subset1 t ∧ subset1 f) ∧
+  (subset1 (Exception _) ⇔ T) ∧
+  (subset1 (Val v) ⇔ case v of
+  | Prim _ => T
+  | SNum _ => T
+  | SBool _ => T
+  | _ => F) ∧
+  (subset1 _ ⇔ F)
+Termination
+  WF_REL_TAC ‘measure exp_size’
+End
+*)
+
+Inductive subset1:
+[~Prim:]
+  vsubset1 (Prim p)
+[~SNum:]
+  vsubset1 (SNum n)
+[~SBool:]
+  vsubset1 (SBool b)
+[~Apply:]
+  subset1 fn ∧ EVERY subset1 args ⇒ subset1 (Apply fn args)
+[~Cond:]
+  subset1 c ∧ subset1 t ∧ subset1 f ⇒ subset1 (Cond c t f)
+[~Val:]
+  vsubset1 v ⇒ subset1 (Val v)
+[~CondK:]
+  subset1 t ∧ subset1 f ⇒ ksubset1 (CondK t f)
+[~ApplyKNONE:]
+  EVERY subset1 args ⇒ ksubset1 (ApplyK NONE args)
+[~ApplyKSOME:]
+  vsubset1 fv ∧ EVERY vsubset1 vs ∧ EVERY subset1 args
+    ⇒ ksubset1 (ApplyK (SOME (fv, vs)) args)
+[~Cont:]
+  EVERY ksubset1 ks ⇒ kssubset1 ks
+End
+
+Theorem subset1_rewrite[simp] = LIST_CONJ[
+  “vsubset1 (Prim p)” |> SCONV [Once subset1_cases],
+  “vsubset1 (SNum n)” |> SCONV [Once subset1_cases],
+  “vsubset1 (SBool b)” |> SCONV [Once subset1_cases],
+  “vsubset1 (Wrong w)” |> SCONV [Once subset1_cases],
+  “vsubset1 (SList l)” |> SCONV [Once subset1_cases],
+  “vsubset1 (Proc r xs xp e)” |> SCONV [Once subset1_cases],
+  “vsubset1 (Throw k)” |> SCONV [Once subset1_cases],
+
+  “subset1 (Apply fn args)” |> SCONV [Once subset1_cases],
+  “subset1 (Cond c t f)” |> SCONV [Once subset1_cases],
+  “subset1 (Val v)” |> SCONV [Once subset1_cases],
+  “subset1 (Print m)” |> SCONV [Once subset1_cases],
+  “subset1 (Exception m)” |> SCONV [Once subset1_cases],
+  “subset1 (Ident x)” |> SCONV [Once subset1_cases],
+  “subset1 (Lambda xs xp e)” |> SCONV [Once subset1_cases],
+  “subset1 (Begin e es)” |> SCONV [Once subset1_cases],
+  “subset1 (Set x e)” |> SCONV [Once subset1_cases],
+  “subset1 (Letrec bs e)” |> SCONV [Once subset1_cases],
+
+  “ksubset1 (CondK t f)” |> SCONV [Once subset1_cases],
+  “ksubset1 (ApplyK ps args)” |> SCONV [Once subset1_cases],
+  “ksubset1 (SetK x)” |> SCONV [Once subset1_cases],
+  “ksubset1 (BeginK es)” |> SCONV [Once subset1_cases],
+  “kssubset1 ks” |> SCONV [Once subset1_cases]
+];
+
+Theorem eval_expand = LIST_CONJ[
+  myEnv_def, myC_def, do_opapp_def, dec_clock_def,
+  nsLookup_def, nsBind_def, do_con_check_def, build_conv_def
+];
+
+Theorem e_vals_subset1:
+  ∀ n e . subset1 e ⇒  ∃ st ck v .
+    evaluate <|clock := ck|> myEnv [SND $ cps_transform n e] = (st, Rval v)
+Proof
+  strip_tac >> Cases >> simp[]
+  >~ [‘Val v’] >- (
+    strip_tac >> simp[cps_transform_def, to_ml_vals_def, evaluate_def]
+  )
+  >~ [‘Cond c t f’] >- (
+    simp[cps_transform_def]
+    >> rpt (pairarg_tac >> gvs[step_def])
+    >> simp[evaluate_def]
+  )
+  >~ [‘Apply e as’] >- (
+    simp[cps_transform_def]
+    >> rpt (pairarg_tac >> gvs[step_def])
+    >> simp[evaluate_def]
+  )
+QED
+
+Theorem k_vals_subset1:
+  ∀ ks . kssubset1 ks ⇒ ∃ st ck v .
+    evaluate <|clock := ck|> myEnv [scheme_cont ks] = (st, Rval v)
+Proof
+  Cases >> simp[] >- simp[scheme_cont_def, evaluate_def]
+  >> Cases_on ‘h’ >> simp[] >> rpt strip_tac >> simp[]
+  >~ [‘CondK t f’] >- (
+    simp[scheme_cont_def, cps_transform_def]
+    >> rpt (pairarg_tac >> gvs[step_def])
+    >> simp[evaluate_def]
+  )
+  >~ [‘ApplyK NONE es’] >- (
+    simp[scheme_cont_def, cps_transform_def]
+    >> rpt (pairarg_tac >> gvs[step_def])
+    >> simp[evaluate_def]
+  )
+QED
+
+Theorem myproof:
+  ∀ e e' n k k' . subset1 e ⇒ step  ([], k, FEMPTY, e) = ([], k', FEMPTY, e') ⇒
+      ∃ ck ck' t1 . evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k) e] =
+        evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k') e']
+Proof
+  Cases >> simp[]
+  >> rpt strip_tac
+  >> simp[exp_with_cont_def, cps_transform_def]
+  >~ [‘Cond c t f’] >- (
+    gvs[step_def, scheme_cont_def, cps_transform_def]
+    >> rpt (pairarg_tac >> gvs[step_def])
+    >> simp[evaluate_def]
+    >> qexists_tac ‘ck'’
+    >> Cases_on ‘evaluate <|clock := ck'|> myEnv [scheme_cont (MAP SND k)]’
+    >> Cases_on ‘r’
+    >> simp[]
+    >> simp[eval_expand]
+  )
+QED
+
+(*Theorem val_correct:
+  ∀ n . ∃ k . SND (evaluate <| clock := k |> myEnv [scheme_program_to_cake (Val (SNum n))])
+    = Rval [Conv (SOME $ TypeStamp "SNum" 0) [Litv $ IntLit n]]
+Proof
+  strip_tac
+  >> qexists_tac ‘99’
+  >> rw[scheme_program_to_cake_def, cps_transform_def, myEnv_def, myC_def,
+    to_ml_vals_def,
+    Once evaluate_def, do_opapp_def, dec_clock_def,
+    nsLookup_def, nsBind_def, do_con_check_def, build_conv_def]
+QED*)
+
+val _ = export_theory();
\ No newline at end of file

From 8b5dbe92eb60597f45ad02428ae5f207214ca5a5 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Mon, 10 Mar 2025 18:07:13 +0000
Subject: [PATCH 051/100] correction, more proving

---
 compiler/scheme/scheme_proofsScript.sml  | 40 ++++++++----------------
 compiler/scheme/scheme_to_cakeScript.sml |  8 +++--
 2 files changed, 19 insertions(+), 29 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index be973be2bd..88bf65e46b 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -93,16 +93,9 @@ Proof
   >~ [‘Val v’] >- (
     strip_tac >> simp[cps_transform_def, to_ml_vals_def, evaluate_def]
   )
-  >~ [‘Cond c t f’] >- (
-    simp[cps_transform_def]
-    >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[evaluate_def]
-  )
-  >~ [‘Apply e as’] >- (
-    simp[cps_transform_def]
-    >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[evaluate_def]
-  )
+  >> simp[cps_transform_def]
+  >> rpt (pairarg_tac >> gvs[step_def])
+  >> simp[evaluate_def]
 QED
 
 Theorem k_vals_subset1:
@@ -111,20 +104,14 @@ Theorem k_vals_subset1:
 Proof
   Cases >> simp[] >- simp[scheme_cont_def, evaluate_def]
   >> Cases_on ‘h’ >> simp[] >> rpt strip_tac >> simp[]
-  >~ [‘CondK t f’] >- (
-    simp[scheme_cont_def, cps_transform_def]
-    >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[evaluate_def]
-  )
-  >~ [‘ApplyK NONE es’] >- (
-    simp[scheme_cont_def, cps_transform_def]
-    >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[evaluate_def]
-  )
+  >> simp[scheme_cont_def, cps_transform_def]
+  >> rpt (pairarg_tac >> gvs[step_def])
+  >> simp[evaluate_def]
 QED
 
+
 Theorem myproof:
-  ∀ e e' n k k' . subset1 e ⇒ step  ([], k, FEMPTY, e) = ([], k', FEMPTY, e') ⇒
+  ∀ e e' n k k' . kssubset1 (MAP SND k) ∧ subset1 e ⇒ step  ([], k, FEMPTY, e) = ([], k', FEMPTY, e') ⇒
       ∃ ck ck' t1 . evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k) e] =
         evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k') e']
 Proof
@@ -135,12 +122,11 @@ Proof
     gvs[step_def, scheme_cont_def, cps_transform_def]
     >> rpt (pairarg_tac >> gvs[step_def])
     >> simp[evaluate_def]
-    >> qexists_tac ‘ck'’
-    >> Cases_on ‘evaluate <|clock := ck'|> myEnv [scheme_cont (MAP SND k)]’
-    >> Cases_on ‘r’
-    >> simp[]
-    >> simp[eval_expand]
-  )
+    >> dxrule_then mp_tac (SRULE [] k_vals_subset1)
+    >> strip_tac
+    >> qexists_tac ‘ck’
+    >> simp[] >> cheat
+  ) >> cheat
 QED
 
 (*Theorem val_correct:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 1913ea8a03..ee6afab711 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -127,8 +127,12 @@ Definition cps_transform_def:
   in
     (m, Fun t ce)
   ) ∧
-  cps_transform_cont n (ApplyK (SOME (f, vs)) es) k =
-    cps_transform_app n (to_ml_vals f) (MAP to_ml_vals vs) es k ∧
+  cps_transform_cont n (ApplyK (SOME (f, vs)) es) k = (let
+    t = "t" ++ toString n;
+    (m, ce) = cps_transform_app (n+1) (to_ml_vals f)
+                (Var (Short t) :: MAP to_ml_vals vs) es k
+  in
+    (m, Fun t ce)) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;

From dac8cf30f1837f5dd4d62756b46704c29594fe1c Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 11 Mar 2025 01:40:41 +0000
Subject: [PATCH 052/100] stuff

---
 compiler/scheme/scheme_proofsScript.sml | 74 ++++++++++++++++++++++---
 1 file changed, 66 insertions(+), 8 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 88bf65e46b..7c1268f7a0 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -85,6 +85,56 @@ Theorem eval_expand = LIST_CONJ[
   nsLookup_def, nsBind_def, do_con_check_def, build_conv_def
 ];
 
+Inductive ml_subset:
+[~Fun:]
+  ml_subset e ⇒ ml_subset (Fun t e)
+[~App:]
+  EVERY ml_subset es ⇒ ml_subset (App op es)
+[~Var:]
+  ml_subset (Var (Short t))
+[~Con:]
+  EVERY ml_subset es ⇒ ml_subset (Con x es)
+[~Lit:]
+  ml_subset (Lit x')
+[~Let:]
+  ml_subset e1 ∧ ml_subset e2 ⇒ ml_subset (Let p e1 e2)
+[~Mat:]
+  ml_subset e ∧ EVERY ml_subset (MAP SND bs) ⇒ ml_subset (Mat e bs)
+End
+
+Definition rec_scheme_def:
+  rec_scheme (Cond c t f) = rec_scheme c + rec_scheme t + rec_scheme f ∧
+  rec_scheme (Apply fn es) = rec_scheme fn + SUM (MAP rec_scheme es) ∧
+  rec_scheme (Val v) = 0
+Termination
+  WF_REL_TAC ‘measure exp_size’
+End
+
+Theorem ml_subset_rewrite[simp] = LIST_CONJ [
+  “ml_subset (Fun t e)” |> SCONV [Once ml_subset_cases],
+  “ml_subset (App op es)” |> SCONV [Once ml_subset_cases],
+  “ml_subset (Var (Short t))” |> SCONV [Once ml_subset_cases],
+  “ml_subset (Con x es)” |> SCONV [Once ml_subset_cases],
+  “ml_subset (Lit x')” |> SCONV [Once ml_subset_cases],
+  “ml_subset (Let p e1 e2)” |> SCONV [Once ml_subset_cases],
+  “ml_subset (Mat e bs)” |> SCONV [Once ml_subset_cases]
+];
+
+Theorem small_ml:
+  ∀ e n m ce . cps_transform n e = (m, ce) ∧ subset1 e
+    ⇒ ml_subset ce
+Proof
+  ho_match_mp_tac rec_scheme_ind
+  >> simp[cps_transform_def] >> rpt strip_tac
+  >~ [‘vsubset1 v’] >- (
+    Cases_on ‘v’ >> gvs[to_ml_vals_def]
+    >> Cases_on ‘p’ >> simp[]
+  )
+  >> rpt strip_tac >> rpt (pairarg_tac >> gvs[step_def])
+  >> rpt $ last_x_assum dxrule >> simp[] >> disch_then kall_tac
+  >> cheat
+QED
+
 Theorem e_vals_subset1:
   ∀ n e . subset1 e ⇒  ∃ st ck v .
     evaluate <|clock := ck|> myEnv [SND $ cps_transform n e] = (st, Rval v)
@@ -99,7 +149,7 @@ Proof
 QED
 
 Theorem k_vals_subset1:
-  ∀ ks . kssubset1 ks ⇒ ∃ st ck v .
+  ∀ ks . kssubset1 ks ⇒ ∃ (st : 'ffi state) ck v .
     evaluate <|clock := ck|> myEnv [scheme_cont ks] = (st, Rval v)
 Proof
   Cases >> simp[] >- simp[scheme_cont_def, evaluate_def]
@@ -109,11 +159,20 @@ Proof
   >> simp[evaluate_def]
 QED
 
+Theorem clock_preserve_val:
+  ∀ e ck (st:'ffi state) env v .
+    evaluate <|clock := ck|> env [e] = (st, Rval v)
+    ⇒ evaluate <|clock := ck + 1|> env [e] = (st, Rval v)
+Proof
+  Cases
+  >> simp[Once evaluate_def]
+  >> cheat
+QED
 
 Theorem myproof:
   ∀ e e' n k k' . kssubset1 (MAP SND k) ∧ subset1 e ⇒ step  ([], k, FEMPTY, e) = ([], k', FEMPTY, e') ⇒
-      ∃ ck ck' t1 . evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k) e] =
-        evaluate <| clock := ck |> myEnv [exp_with_cont (MAP SND k') e']
+      ∃ ck ck' t1 . evaluate (<| clock := ck |> : 'ffi state) myEnv [exp_with_cont (MAP SND k) e] =
+        evaluate <| clock := ck' |> myEnv [exp_with_cont (MAP SND k') e']
 Proof
   Cases >> simp[]
   >> rpt strip_tac
@@ -121,11 +180,10 @@ Proof
   >~ [‘Cond c t f’] >- (
     gvs[step_def, scheme_cont_def, cps_transform_def]
     >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[evaluate_def]
-    >> dxrule_then mp_tac (SRULE [] k_vals_subset1)
-    >> strip_tac
-    >> qexists_tac ‘ck’
-    >> simp[] >> cheat
+    >> simp[SimpLHS, evaluate_def]
+    >> qexistsl_tac [‘ck+1’,‘ck’]
+    >> dxrule_then assume_tac (SRULE [] k_vals_subset1)
+    >> cheat
   ) >> cheat
 QED
 

From 567499eba0b90b654c5275ad4654f59f662d0c04 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 11 Mar 2025 14:08:37 +0000
Subject: [PATCH 053/100] more stuff

---
 compiler/scheme/scheme_proofsScript.sml | 33 +++++++++++++++++--------
 1 file changed, 23 insertions(+), 10 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 7c1268f7a0..b4b7fe48eb 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -149,8 +149,9 @@ Proof
 QED
 
 Theorem k_vals_subset1:
-  ∀ ks . kssubset1 ks ⇒ ∃ (st : 'ffi state) ck v .
-    evaluate <|clock := ck|> myEnv [scheme_cont ks] = (st, Rval v)
+  ∀ ks ck . kssubset1 ks ⇒ ∃ v .
+    evaluate <|clock := ck|> myEnv [scheme_cont ks]
+      = (<|clock := ck|> : 'ffi state, Rval [v])
 Proof
   Cases >> simp[] >- simp[scheme_cont_def, evaluate_def]
   >> Cases_on ‘h’ >> simp[] >> rpt strip_tac >> simp[]
@@ -159,14 +160,25 @@ Proof
   >> simp[evaluate_def]
 QED
 
-Theorem clock_preserve_val:
-  ∀ e ck (st:'ffi state) env v .
-    evaluate <|clock := ck|> env [e] = (st, Rval v)
-    ⇒ evaluate <|clock := ck + 1|> env [e] = (st, Rval v)
+Theorem cps_equiv:
+  ∀ e n n' m m' ce ce' ck v v' c c' k k' t t'. subset1 e
+    ∧ nsSub (λ id . $=) myEnv.c c ∧ nsSub (λ id . $=) myEnv.c c'
+    ∧ nsSub (λ id . $=) myEnv.v v ∧ nsSub (λ id . $=) myEnv.v v'
+    ∧ cps_transform n e = (n',ce) ∧ cps_transform m e = (m', ce')
+    ∧ evaluate <|clock := ck+1|> <|v:=v;c:=c|> [App Opapp [ce;Fun t k]]
+      = evaluate <|clock := ck+1|> <|v:=v';c:=c'|> [App Opapp [ce';Fun t' k']]
+    ⇒ ∀ vl . evaluate <|clock := ck|> <|v:=nsBind t vl v;c:=c|> [k]
+      = evaluate <|clock := ck|> <|v:=nsBind t vl v';c:=c'|> [k']
 Proof
-  Cases
-  >> simp[Once evaluate_def]
-  >> cheat
+  ho_match_mp_tac rec_scheme_ind
+  >> simp[cps_transform_def] >> rpt strip_tac
+  >~ [‘vsubset1 v’] >- (
+    Cases_on ‘v’ >> gvs[evaluate_def, to_ml_vals_def, do_opapp_def]
+    >> gs[myEnv_def, nsSub_def]
+    >> Cases_on ‘p’ >> simp[]
+  )
+  Induct_on ‘e’
+  rpt strip_tac
 QED
 
 Theorem myproof:
@@ -182,7 +194,8 @@ Proof
     >> rpt (pairarg_tac >> gvs[step_def])
     >> simp[SimpLHS, evaluate_def]
     >> qexistsl_tac [‘ck+1’,‘ck’]
-    >> dxrule_then assume_tac (SRULE [] k_vals_subset1)
+    >> dxrule_then (qspec_then ‘ck+1’ mp_tac) (SRULE [] k_vals_subset1)
+    >> strip_tac >> simp[do_opapp_def, dec_clock_def]
     >> cheat
   ) >> cheat
 QED

From d33ddf08a557cfa806cbc743229df43d759e1fa4 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 11 Mar 2025 19:49:17 +0000
Subject: [PATCH 054/100] testing translate

---
 compiler/scheme/scheme_to_cakeScript.sml      | 26 +++++++++++++++++++
 .../translation/scheme_compilerProgScript.sml |  2 ++
 2 files changed, 28 insertions(+)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index ee6afab711..84f1fda2bb 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -58,6 +58,32 @@ Definition letinit_ml_def:
       (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
 End
 
+Definition small_cps_def:
+  small_cps n (Val v) = (let k = "k" ++ toString n in
+    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
+  small_cps n (Cond c t f) = (let
+    (m, cc) = small_cps n c;
+    k = "k" ++ toString m;
+    (l, ck) = small_cps_cont (m+1) (CondK t f) (Var (Short k))
+  in
+    (l, Fun k $ App Opapp [cc; ck])) ∧
+
+  small_cps_cont n (CondK t f) k = (let
+    (m, ct) = small_cps n t;
+    (l, cf) = small_cps m f;
+    p = "t" ++ toString l;
+  in
+    (l+1, Fun p $ Mat (Var (Short p)) [
+      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; k]);
+      (Pany, App Opapp [ct; k])
+    ]))
+Termination
+  WF_REL_TAC ‘measure (λ x . case x of
+    | INL(_,e) => exp_size e
+    | INR(_,k,_) => cont_size k)’
+  >> Cases >> rw[val_size_def]
+End
+
 Definition cps_transform_def:
   cps_transform n (Val v) = (let k = "k" ++ toString n in
     (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 6f0579b895..4c3fdf6380 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -28,6 +28,8 @@ val r = translate parse_to_ast_def;
 
 val r = translate locationTheory.unknown_loc_def;
 val r = translate cake_print_def;
+val r = translate to_ml_vals_def;
+val r = translate small_cps_def;
 val r = translate codegen_def;
 
 (* top-level compiler *)

From 3cf1c23d39a5c114e3db4aed5070896dd0509626 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Tue, 18 Mar 2025 23:23:38 +0000
Subject: [PATCH 055/100] parser

---
 compiler/scheme/scheme_parsingScript.sml | 278 +++++++++++++++++++----
 compiler/scheme/scheme_to_cakeScript.sml |   4 +
 compiler/scheme/scheme_valuesScript.sml  |  13 +-
 3 files changed, 250 insertions(+), 45 deletions(-)

diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index f681087f5e..0e2f7a288d 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -9,27 +9,95 @@ open scheme_astTheory;
 val _ = new_theory "scheme_parsing";
 
 
+val _ = monadsyntax.declare_monad("sum", {
+  unit = “INR”,
+  bind = “λ s f . case s of
+    | INL l => INL l
+    | INR r => f r”,
+  ignorebind = NONE,
+  fail = NONE,
+  guard = NONE,
+  choice = SOME “λ x y . case x of
+    | INL l => y
+    | INR r => INR r”
+});
+
+val _ = monadsyntax.enable_monadsyntax();
+val _ = monadsyntax.enable_monad "sum";
+
+Definition mapM_def:
+  mapM f [] = return [] ∧
+  mapM f (x::xs) = do
+      e <- f x;
+      es <- mapM f xs;
+      return (e::es)
+    od
+End
+
 (* lexing *)
 
 Datatype:
   token = OPEN | CLOSE | DOT | NUM num | QUOTE num
+    | PLUS | MINUS | TIMES | BOOL bool | WORD string
+End
+
+Definition delimits_next_def:
+  delimits_next [] = T ∧
+  delimits_next (c::cs) = MEM c " \t\n()#;"
+End
+
+Definition read_bool_def:
+  read_bool (#"#"::c::cs) = (
+    if delimits_next cs then
+      if MEM c "tT" then SOME (T, cs) else
+      if MEM c "fF" then SOME (F, cs) else
+        NONE
+    else NONE) ∧
+  read_bool (_::cs) = NONE
 End
 
+Theorem read_bool_length:
+  ∀ b c cs ys .
+    read_bool (c::cs) = SOME (b,ys) ⇒
+    LENGTH ys ≤ LENGTH cs
+Proof
+  Cases_on ‘cs’ >> rw [read_bool_def, delimits_next_def]
+QED
+
 Definition read_num_def:
-  read_num l h f x acc [] = (acc,[]) ∧
   read_num l h f x acc (c::cs) =
     if ORD l ≤ ORD c ∧ ORD c ≤ ORD h then
-      read_num l h f x (f * acc + (ORD c - x)) cs
-    else (acc,c::cs)
+      let newacc = (f * acc + (ORD c - x)) in
+        if delimits_next cs then SOME (newacc, cs) else
+          read_num l h f x newacc cs
+    else NONE
 End
 
 Theorem read_num_length:
-  ∀l h xs n ys f acc x.
-    read_num l h f x acc xs = (n,ys) ⇒
-    LENGTH ys ≤ LENGTH xs ∧ (xs ≠ ys ⇒ LENGTH ys < LENGTH xs)
+  ∀l h c cs n ys f acc x.
+    read_num l h f x acc (c::cs) = SOME (n,ys) ⇒
+    LENGTH ys ≤ LENGTH cs
 Proof
-  Induct_on ‘xs’ \\ rw [read_num_def]
-  \\ TRY pairarg_tac \\ fs [] \\ rw [] \\ res_tac \\ fs []
+  Induct_on ‘cs’ >> rw [Once read_num_def, delimits_next_def] >> rw[]
+  >> last_assum $ drule >> rw[]
+QED
+
+Definition read_word_def:
+  read_word (c::cs) = if delimits_next cs then SOME ([c], cs) else
+    case read_word cs of
+    | NONE => NONE
+    | SOME (ws, cs') => SOME (c::ws, cs')
+End
+
+Theorem read_word_length:
+  ∀ w c cs ys .
+    read_word (c::cs) = SOME (w,ys) ⇒
+    LENGTH ys ≤ LENGTH cs
+Proof
+  Induct_on ‘cs’ >> rw [Once read_word_def, delimits_next_def] >> gvs[]
+  >> Cases_on ‘read_word (STRING h cs)’ >> gvs[]
+  >> PairCases_on ‘x’ >> gvs[]
+  >> last_assum $ drule >> rw[]
 QED
 
 Definition end_line_def:
@@ -44,65 +112,195 @@ Proof
 QED
 
 Definition lex_def:
-  lex q [] acc = acc ∧
-  lex q (c::cs) acc =
-      if MEM c " \t\n" then lex NUM cs acc else
-      if c = #"#" then lex NUM (end_line cs) acc else
-      if c = #"." then lex NUM cs (DOT::acc) else
-      if c = #"(" then lex NUM cs (OPEN::acc) else
-      if c = #")" then lex NUM cs (CLOSE::acc) else
-      if c = #"'" then lex QUOTE cs acc else
-        let (n,rest) = read_num #"0" #"9" 10 (ORD #"0") 0 (c::cs) in
-          if rest ≠ c::cs then lex NUM rest (q n::acc) else
-            let (n,rest) = read_num #"*" #"z" 256 0 0 (c::cs) in
-              if rest ≠ c::cs then lex NUM rest (q n::acc) else
-                lex NUM cs acc
+  lex [] acc = INR acc ∧
+  lex (c::cs) acc =
+      if MEM c " \t\n" then lex cs acc else
+      if c = #";" then lex (end_line cs) acc else
+      if c = #"." then lex cs (DOT::acc) else
+      if c = #"(" then lex cs (OPEN::acc) else
+      if c = #")" then lex cs (CLOSE::acc) else
+      if c = #"+" then lex cs (PLUS::acc) else
+      if c = #"-" then lex cs (MINUS::acc) else
+      if c = #"*" then lex cs (TIMES::acc) else
+      (*if c = #"'" then lex QUOTE cs acc else*)
+        case read_bool (c::cs) of
+        | SOME (b, rest) => lex rest (BOOL b::acc)
+        | NONE => case read_num #"0" #"9" 10 (ORD #"0") 0 (c::cs) of
+          | SOME (n, rest) => lex rest (NUM n::acc)
+          | NONE => case read_word (c::cs) of
+            | SOME (w, rest) => lex rest (WORD w::acc)
+            | NONE => INL ("Failed to parse at character " ++ [c])
 Termination
-  WF_REL_TAC ‘measure (LENGTH o FST o SND)’ \\ rw []
-  \\ imp_res_tac (GSYM read_num_length) \\ fs [end_line_length]
+  WF_REL_TAC ‘measure (LENGTH o FST)’ >> rw []
+  >- (dxrule read_bool_length >> rw[])
+  >- (dxrule read_word_length >> rw[])
+  >- (dxrule read_num_length >> rw[])
+  >> simp [end_line_length]
 End
 
 Definition lexer_def:
-  lexer input = lex NUM input []
+  lexer input = lex input []
 End
 
 
 (* parsing *)
 
-Definition quote_def:
+(*Definition quote_def:
   quote n = list [Num (name "'"); Num n]
-End
+End*)
 
 Definition parse_def:
-  parse [] x s = x ∧
-  parse (CLOSE :: rest) x s = parse rest (Num 0) (x::s) ∧
+  parse [] x [] = INR x ∧
+  parse [] x s = INL "Too many close brackets" ∧
+  parse (CLOSE :: rest) x s = parse rest Nil (x::s) ∧
   parse (OPEN :: rest) x s =
-    (case s of [] => parse rest x s
+    (case s of [] => INL "Too many open brackets"
      | (y::ys) => parse rest (Pair x y) ys) ∧
-  parse (NUM n :: rest) x s = parse rest (Pair (Num n) x) s ∧
-  parse (QUOTE n :: rest) x s = parse rest (Pair (quote n) x) s ∧
+  parse (NUM n :: rest) x s = parse rest (Pair (Num &n) x) s ∧
+  parse (BOOL b :: rest) x s = parse rest (Pair (Bool b) x) s ∧
+  parse (WORD w :: rest) x s = parse rest (Pair (Word w) x) s ∧
+  parse (PLUS :: rest) x s = parse rest (Pair (Word "+") x) s ∧
+  parse (MINUS :: rest) x s = parse rest (Pair (Word "-") x) s ∧
+  parse (TIMES :: rest) x s = parse rest (Pair (Word "*") x) s ∧
+  (*parse (QUOTE n :: rest) x s = parse rest (Pair (quote n) x) s ∧*)
   parse (DOT :: rest) x s = parse rest (head x) s
 End
 
 (*
-EVAL “head (parse (lexer "(print hi)") (Num 0) [])”
+EVAL “case lexer "(print hi)" of
+| INL x => INL x
+| INR y => case parse y Nil [] of
+  | INL x => INL x
+  | INR y => INR (head y)”
 *)
 
 
 (* conversion to AST *)
 
+Definition pair_to_list_def:
+  pair_to_list Nil = SOME [] ∧
+  pair_to_list (Pair x y) = (case pair_to_list y of
+  | NONE => NONE
+  | SOME xs => SOME (x::xs)) ∧
+  pair_to_list v = NONE
+End
+
+Theorem pair_to_list_size:
+  ∀ p ls . pair_to_list p = SOME ls ⇒ v_size p = list_size v_size ls
+Proof
+  ho_match_mp_tac pair_to_list_ind
+  >> simp[pair_to_list_def, list_size_def]
+  >> rpt strip_tac
+  >> Cases_on ‘pair_to_list p’ >> gvs[list_size_def]
+QED
+
+Definition cons_formals_def:
+  cons_formals ps Nil = INR (REVERSE ps, NONE) ∧
+  cons_formals ps (Word w) = INR (REVERSE ps, SOME (strlit w)) ∧
+  cons_formals ps (Pair (Word x) y) = cons_formals (strlit x::ps) y ∧
+  cons_formals ps _ = INL "Invalid lambda formals"
+End
+
+Definition cons_ast_def:
+  cons_ast (Num n) = INR (Val (SNum n)) ∧
+  cons_ast (Bool b) = INR (Val (SBool b)) ∧
+  cons_ast (Word w) = (
+    if w = "+" then INR (Val (Prim SAdd)) else
+    if w = "-" then INR (Val (Prim SMinus)) else
+    if w = "*" then INR (Val (Prim SMul)) else
+    if w = "eqv?" then INR (Val (Prim SEqv)) else
+    if w = "callcc" then INR (Val (Prim CallCC)) else
+      INR (Ident (strlit w))) ∧
+  cons_ast Nil = INL "Empty S expression" ∧
+  cons_ast (Pair x y) = (case pair_to_list y of
+  | NONE => INL "Invalid S expression"
+  | SOME ys => (case x of
+    | Word "if" => (case ys of
+      | [c;t;f] => do
+          ce <- cons_ast c;
+          te <- cons_ast t;
+          fe <- cons_ast f;
+          return (Cond ce te fe)
+        od
+      | _ => INL "Wrong number of expressions in if statement")
+    | Word "begin" => (case ys of
+      | [] => INL "Wrong number of expressions to begin"
+      | y'::ys' => do
+          e <- cons_ast y';
+          es <- cons_ast_list ys';
+          return (Begin e es)
+        od)
+    | Word "lambda" => (case ys of
+      | [xs;y'] => do
+          (ps,lp) <- cons_formals [] xs;
+          e <- cons_ast y';
+          return (Lambda ps lp e)
+        od
+      | _ => INL "Wrong number of expressions in lambda statement")
+    | Word "letrec" => (case ys of
+      | [xs;y'] => (case pair_to_list xs of
+        | NONE => INL "Invalid S expression"
+        | SOME xs' => do
+            bs <- cons_ast_bindings xs';
+            e <- cons_ast y';
+            return (Letrec bs e)
+          od)
+      | _ => INL "Wrong number of expressions in letrec statement")
+    | Word "set!" => (case ys of
+      | [Word w;y'] => do
+          e <- cons_ast y';
+          return (Set (strlit w) e)
+        od
+      | _ => INL "Invalid set expression")
+    | fn => do
+        e <- cons_ast fn;
+        es <- cons_ast_list ys;
+        return (Apply e es)
+      od)) ∧
+
+  cons_ast_list [] = INR [] ∧
+  cons_ast_list (x::xs) = (do
+      e <- cons_ast x;
+      es <- cons_ast_list xs;
+      return (e::es)
+    od) ∧
+
+  cons_ast_bindings [] = INR [] ∧
+  cons_ast_bindings (x::xs) = (case pair_to_list x of
+  | NONE => INL "Invalid S expression"
+  | SOME ys => (case ys of
+    | [Word w;b] => do
+        e <- cons_ast b;
+        es <- cons_ast_bindings xs;
+        return ((strlit w, e)::es)
+      od
+    | _ => INL "Invalid letrec binding"))
+Termination
+  WF_REL_TAC ‘measure $ λ x . case x of
+    | INL v => v_size v
+    | INR (INL vs) => list_size v_size vs
+    | INR (INR vs') => list_size v_size vs'’
+  >> rpt strip_tac
+  >> rpt (
+    dxrule_then (assume_tac o GSYM) pair_to_list_size
+    >> gvs[list_size_def]
+  )
+End
+
 Definition parse_to_ast_def:
-  parse_to_ast s =
-    let e = head (parse (lexer s) (Num 0) []) in
-      if e = Pair (Name "print") (Pair (Name "hi") (Num 0)) then
-        INR (Print (strlit "hi\n"))
-      else
-        INL ("This version can only parse '(print hi)'.")
+  parse_to_ast s = do
+      lxs <- lexer s;
+      e <- parse lxs Nil [];
+      cons_ast (head e)
+    od
 End
 
 (*
-EVAL “parse_to_ast "(print hi)"”
-EVAL “parse_to_ast "(print hello)"”
+EVAL “cons_ast (Pair (Word "print") (Pair (Word "hi") Nil))”
+EVAL “do e <- do es' <- mapM cons_ast [Word "t"; Word "h"]; return (Apply (Val (SNum 0)) es') od; es <- mapM cons_ast [Pair (Word "+") Nil; Word "-"]; return (Apply e es) od”
+EVAL “parse_to_ast "((if #t + * ) 2 3)"”
+EVAL “parse_to_ast "(lambda (x y . l) 2)"”
+EVAL “parse_to_ast "(letrec ((x 3) (y x)) 2)"”
 *)
 
 val _ = export_theory();
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 84f1fda2bb..03e88a6ed7 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -457,6 +457,10 @@ val _ = export_theory();
       )
     ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6])
   )]”
+
+  open scheme_parsingTheory;
+  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake $ OUTR $ parse_to_ast
+    "(letrec ((fac (lambda (x) (letrec ((st 0) (acc 1)) (begin (callcc (lambda (k) (set! st k))) (if (eqv? x 0) acc (st (begin (set! acc ( * acc x)) (set! x (- x 1)))))))))) (fac 6))"]”
   EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
   EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
   EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
diff --git a/compiler/scheme/scheme_valuesScript.sml b/compiler/scheme/scheme_valuesScript.sml
index 51296b284c..91ae996820 100644
--- a/compiler/scheme/scheme_valuesScript.sml
+++ b/compiler/scheme/scheme_valuesScript.sml
@@ -6,12 +6,11 @@ open arithmeticTheory listTheory stringTheory;
 
 val _ = new_theory "scheme_values";
 
-(* Values in the source semantics are binary trees where the
-   leaves are natural numbers (num) *)
+(* Values in the source semantics are binary trees *)
 Datatype:
-  v = Pair v v | Num num
+  v = Pair v v | Num int | Bool bool | Word string | Nil
 End
-
+(*
 (* Since strings are not in the representation, we have a function that
    coverts strings into numbers. Note that parsing and pretty printing
    is set up so that printing reproduces these strings when possible. *)
@@ -45,6 +44,7 @@ End
 Definition div_def[simp]:
   div (Num n) (Num m) = Num (n DIV m)
 End
+*)
 
 Definition head_def[simp]:
   head (Pair x y) = x ∧
@@ -60,6 +60,7 @@ Definition cons_def[simp]:
   cons x y = Pair x y
 End
 
+(*
 Definition bool_def[simp]:
   bool T = Num 1 ∧
   bool F = Num 0
@@ -113,10 +114,11 @@ Theorem isNum_bool[simp]:
 Proof
   Cases_on ‘b’ \\ EVAL_TAC
 QED
+*)
 
 Theorem v_size_def[simp,allow_rebind] = fetch "-" "v_size_def";
 
-Theorem all_macro_defs = LIST_CONJ [list_def, cons_def, bool_def,
+(*Theorem all_macro_defs = LIST_CONJ [list_def, cons_def, bool_def,
    map_def, pair_def, option_def];
 
 Definition is_upper_def:
@@ -131,5 +133,6 @@ End
 Definition otherwise_def[simp]:
   otherwise x = x
 End
+*)
 
 val _ = export_theory();

From 4d8de7ffe8b1c7fe0cb62297de93813ed224024a Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 19 Mar 2025 11:26:31 +0000
Subject: [PATCH 056/100] translate parse

---
 compiler/scheme/scheme_parsingScript.sml             | 10 +++++-----
 .../scheme/translation/scheme_compilerProgScript.sml | 12 +++++++++---
 2 files changed, 14 insertions(+), 8 deletions(-)

diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index 0e2f7a288d..b3dbaf0835 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -53,7 +53,7 @@ Definition read_bool_def:
       if MEM c "fF" then SOME (F, cs) else
         NONE
     else NONE) ∧
-  read_bool (_::cs) = NONE
+  read_bool _ = NONE
 End
 
 Theorem read_bool_length:
@@ -196,8 +196,8 @@ QED
 
 Definition cons_formals_def:
   cons_formals ps Nil = INR (REVERSE ps, NONE) ∧
-  cons_formals ps (Word w) = INR (REVERSE ps, SOME (strlit w)) ∧
-  cons_formals ps (Pair (Word x) y) = cons_formals (strlit x::ps) y ∧
+  cons_formals ps (Word w) = INR (REVERSE ps, SOME (implode w)) ∧
+  cons_formals ps (Pair (Word x) y) = cons_formals (implode x::ps) y ∧
   cons_formals ps _ = INL "Invalid lambda formals"
 End
 
@@ -249,7 +249,7 @@ Definition cons_ast_def:
     | Word "set!" => (case ys of
       | [Word w;y'] => do
           e <- cons_ast y';
-          return (Set (strlit w) e)
+          return (Set (implode w) e)
         od
       | _ => INL "Invalid set expression")
     | fn => do
@@ -272,7 +272,7 @@ Definition cons_ast_def:
     | [Word w;b] => do
         e <- cons_ast b;
         es <- cons_ast_bindings xs;
-        return ((strlit w, e)::es)
+        return ((implode w, e)::es)
       od
     | _ => INL "Invalid letrec binding"))
 Termination
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 4c3fdf6380..bfc6155e49 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -13,15 +13,21 @@ val _ = translation_extends "to_sexpProg";
 
 (* parsing *)
 
+val r = translate (delimits_next_def |> SRULE [MEMBER_INTRO]);
+val r = translate (read_bool_def |> SRULE [MEMBER_INTRO]);
 val r = translate read_num_def;
+val r = translate read_word_def;
 val r = translate end_line_def;
 val r = translate (lex_def |> SRULE [MEMBER_INTRO]);
 val r = translate lexer_def;
-val r = translate scheme_valuesTheory.list_def;
-val r = translate scheme_valuesTheory.name_def;
+(*val r = translate scheme_valuesTheory.list_def;*)
+(*val r = translate scheme_valuesTheory.name_def;*)
 val r = translate scheme_valuesTheory.head_def;
-val r = translate quote_def;
+(*val r = translate quote_def;*)
 val r = translate parse_def;
+val r = translate pair_to_list_def;
+val r = translate cons_formals_def;
+val r = translate cons_ast_def;
 val r = translate parse_to_ast_def;
 
 (* codegen *)

From 36c0ad0675207e4caf215dbe1f4c0e3bbb4c7de5 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 19 Mar 2025 11:28:19 +0000
Subject: [PATCH 057/100] implode one more

---
 compiler/scheme/scheme_parsingScript.sml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index b3dbaf0835..d8081a1137 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -210,7 +210,7 @@ Definition cons_ast_def:
     if w = "*" then INR (Val (Prim SMul)) else
     if w = "eqv?" then INR (Val (Prim SEqv)) else
     if w = "callcc" then INR (Val (Prim CallCC)) else
-      INR (Ident (strlit w))) ∧
+      INR (Ident (implode w))) ∧
   cons_ast Nil = INL "Empty S expression" ∧
   cons_ast (Pair x y) = (case pair_to_list y of
   | NONE => INL "Invalid S expression"

From c5fa855b00907bd64c9ed2d9ed793a07e2f94078 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Thu, 20 Mar 2025 00:12:23 +0000
Subject: [PATCH 058/100] translates!

---
 compiler/scheme/examples/facimp.scm           |   4 +
 compiler/scheme/examples/hi.scm               |   1 -
 compiler/scheme/scheme_astScript.sml          |   4 +-
 compiler/scheme/scheme_to_cakeScript.sml      | 358 ++++++------------
 .../translation/scheme_compilerProgScript.sml |   7 +-
 5 files changed, 135 insertions(+), 239 deletions(-)
 create mode 100644 compiler/scheme/examples/facimp.scm
 delete mode 100644 compiler/scheme/examples/hi.scm

diff --git a/compiler/scheme/examples/facimp.scm b/compiler/scheme/examples/facimp.scm
new file mode 100644
index 0000000000..859499b8b2
--- /dev/null
+++ b/compiler/scheme/examples/facimp.scm
@@ -0,0 +1,4 @@
+(letrec ((fac (lambda (x)
+  (letrec ((st 0) (acc 1)) (begin
+    (callcc (lambda (k) (set! st k)))
+    (if (eqv? x 0) acc (st (begin (set! acc ( * acc x)) (set! x (- x 1)))))))))) (fac 6))
diff --git a/compiler/scheme/examples/hi.scm b/compiler/scheme/examples/hi.scm
deleted file mode 100644
index 2641c5e01d..0000000000
--- a/compiler/scheme/examples/hi.scm
+++ /dev/null
@@ -1 +0,0 @@
-(print hi)
diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 6703aa55dd..7f9a6273c4 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -26,8 +26,8 @@ Datatype:
        | BeginK (exp list)
        | SetK mlstring
 ;
-  exp = Print mlstring
-      | Apply exp (exp list)
+  exp = (*Print mlstring
+      |*) Apply exp (exp list)
       | Val val
       | Cond exp exp exp
       | Ident mlstring
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 03e88a6ed7..6f49664b47 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -18,18 +18,18 @@ Definition to_ml_vals_def:
   | SEqv => Con (SOME $ Short "SEqv") []
   | CallCC => Con (SOME $ Short "CallCC") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
-  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Lit $ IntLit
-    if b then 1 else 0]
+  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Con (SOME $ Short 
+    if b then "False" else "True") []]
 End
 
 Definition cons_list_def:
-  cons_list [] = Con (SOME $ Short "nil") [] ∧
-  cons_list (x::xs) = Con (SOME $ Short "cons") [x; cons_list xs]
+  cons_list [] = Con (SOME $ Short "[]") [] ∧
+  cons_list (x::xs) = Con (SOME $ Short "::") [x; cons_list xs]
 End
 
 Definition proc_ml_def:
   proc_ml n [] NONE k args ce = (n, Mat (Var (Short args)) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           App Opapp [ce; Var (Short k)]);
         (Pany,
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"])
@@ -43,9 +43,9 @@ Definition proc_ml_def:
     (m, inner) = proc_ml (n+2) xs xp k args' ce
   in
     (m, Mat (Var (Short args)) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
-        (Pcon (SOME $ Short "cons") [Pvar arg; Pvar args'],
+        (Pcon (SOME $ Short "::") [Pvar arg; Pvar args'],
           Let (SOME $ "s" ++ explode x)
             (App Opref [Con (SOME $ Short "Some") [Var (Short arg)]])
             inner)
@@ -58,32 +58,6 @@ Definition letinit_ml_def:
       (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
 End
 
-Definition small_cps_def:
-  small_cps n (Val v) = (let k = "k" ++ toString n in
-    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
-  small_cps n (Cond c t f) = (let
-    (m, cc) = small_cps n c;
-    k = "k" ++ toString m;
-    (l, ck) = small_cps_cont (m+1) (CondK t f) (Var (Short k))
-  in
-    (l, Fun k $ App Opapp [cc; ck])) ∧
-
-  small_cps_cont n (CondK t f) k = (let
-    (m, ct) = small_cps n t;
-    (l, cf) = small_cps m f;
-    p = "t" ++ toString l;
-  in
-    (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; k]);
-      (Pany, App Opapp [ct; k])
-    ]))
-Termination
-  WF_REL_TAC ‘measure (λ x . case x of
-    | INL(_,e) => exp_size e
-    | INR(_,k,_) => cont_size k)’
-  >> Cases >> rw[val_size_def]
-End
-
 Definition cps_transform_def:
   cps_transform n (Val v) = (let k = "k" ++ toString n in
     (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
@@ -92,13 +66,13 @@ Definition cps_transform_def:
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
     k = "k" ++ toString m;
-    (l, ck) = cps_transform_cont (m+1) (CondK t f) (Var (Short k))
+    (l, ck) = refunc_cont (m+1) (CondK t f) (Var (Short k))
   in
     (l, Fun k $ App Opapp [cc; ck])) ∧
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;
-    (l, ck) = cps_transform_cont (m+1) (ApplyK NONE args) (Var (Short k))
+    (l, ck) = refunc_cont (m+1) (ApplyK NONE args) (Var (Short k))
   in
     (l, Fun k $ App Opapp [cfn; ck])) ∧
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
@@ -119,18 +93,15 @@ Definition cps_transform_def:
   cps_transform n (Begin e es) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
-    (l, seqk) = cps_transform_seq (m+1) (Var (Short k)) es
+    (l, seqk) = refunc_cont (m+1) (BeginK es) (Var (Short k))
   in
     (l, Fun k $ App Opapp [ce; seqk])) ∧
   cps_transform n (Set x e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
-    t = "t" ++ toString (m+1);
+    (l, setk) = refunc_cont (m+1) (SetK x) (Var (Short k))
   in
-    (m+2, Fun k $ (App Opapp [ce;
-      Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
-          Con (SOME $ Short "Some") [Var (Short t)]])
-        (App Opapp [Var (Short k); Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"]])]))) ∧
+    (l, Fun k $ (App Opapp [ce;setk]))) ∧
   cps_transform n (Letrec bs e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
@@ -138,27 +109,30 @@ Definition cps_transform_def:
   in
     (l, Fun k $ letinit_ml bs inner)) ∧
 
-  cps_transform_cont n (CondK t f) k = (let
+  refunc_cont n (CondK t f) k = (let
     (m, ct) = cps_transform n t;
     (l, cf) = cps_transform m f;
     p = "t" ++ toString l;
   in
     (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Plit $ IntLit 0], App Opapp [cf; k]);
+      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []], App Opapp [cf; k]);
       (Pany, App Opapp [ct; k])
     ])) ∧
-  cps_transform_cont n (ApplyK NONE es) k = (let
+  refunc_cont n (ApplyK fnp es) k = (let
     t = "t" ++ toString n;
-    (m, ce) = cps_transform_app (n+1) (Var (Short t)) [] es k
+    (m, ce) = (case fnp of
+      | NONE => cps_transform_app (n+1) (Var (Short t)) [] es k
+      | SOME (fn, vs) => cps_transform_app (n+1) (to_ml_vals fn)
+                           (Var (Short t) :: MAP to_ml_vals vs) es k)
   in
-    (m, Fun t ce)
-  ) ∧
-  cps_transform_cont n (ApplyK (SOME (f, vs)) es) k = (let
+    (m, Fun t ce)) ∧
+  refunc_cont n (BeginK es) k = cps_transform_seq n k es ∧
+  refunc_cont n (SetK x) k = (let
     t = "t" ++ toString n;
-    (m, ce) = cps_transform_app (n+1) (to_ml_vals f)
-                (Var (Short t) :: MAP to_ml_vals vs) es k
   in
-    (m, Fun t ce)) ∧
+    (n+1, Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
+            Con (SOME $ Short "Some") [Var (Short t)]])
+          (App Opapp [k; Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"]]))) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -195,57 +169,65 @@ Termination
     | INR(INR(INL(_,_,_,es,_))) => list_size exp_size es
     | INR(INR(INR(INL(_,_,es)))) => list_size exp_size es
     | INR(INR(INR(INR(_,_,es,_)))) => list_size (exp_size o SND) es)’
-  >> strip_tac >- (Cases >> rw[val_size_def, list_size_def])
-  >> strip_tac >- (Cases >> rw[val_size_def, list_size_def])
-  >> Induct_on ‘bs’ >- (rw[val_size_def, list_size_def])
-  >> Cases
-  >> rw[val_size_def, list_size_def]
-  >> last_x_assum $ qspecl_then [‘e’,‘n’,‘m’,‘ce’] $ mp_tac
-  >> rw[]
+  >> rpt (strip_tac >- (Cases >> rw[val_size_def]))
+  >> strip_tac >- (
+    Induct_on ‘bs’ >> Cases
+    >> rw[val_size_def, list_size_def]
+    >> last_x_assum $ qspecl_then [‘e’,‘n’,‘m’,‘ce’] $ mp_tac
+    >> rw[]
+  )
+  >> Cases >> rw[val_size_def]
 End
 
 Definition scheme_cont_def:
   scheme_cont [] = Fun "t" $ Var (Short "t") ∧
-  scheme_cont (k:: ks) = SND $ cps_transform_cont 0 k (scheme_cont ks)
+  scheme_cont (k:: ks) = SND $ refunc_cont 0 k (scheme_cont ks)
 End
 
 Definition exp_with_cont_def:
   exp_with_cont k e = App Opapp [SND $ cps_transform 0 e; scheme_cont k]
 End
 
-Definition scheme_program_to_cake_def:
-  scheme_program_to_cake p = App Opapp [SND (cps_transform 0 p); Fun "t" $ Var (Short "t")]
-End
-
-Definition myC_def:
-  (myC :('a, string, num # stamp) namespace) = Bind [
-    ("SNum", (1, TypeStamp "SNum" 0));
-    ("SBool", (1, TypeStamp "SBool" 0));
-    ("SList", (1, TypeStamp "SList" 0));
-    ("Proc", (1, TypeStamp "Proc" 0));
-    ("Throw", (1, TypeStamp "Throw" 0));
-    ("Prim", (1, TypeStamp "Prim" 0));
-    ("Wrong", (1, TypeStamp "Wrong" 0));
-    ("SAdd", (0, TypeStamp "SAdd" 1));
-    ("SMul", (0, TypeStamp "SMul" 1));
-    ("SMinus", (0, TypeStamp "SMinus" 1));
-    ("SEqv", (0, TypeStamp "SEqv" 1));
-    ("CallCC", (0, TypeStamp "CallCC" 1));
-    ("cons", (2, TypeStamp "cons" 2));
-    ("nil", (0, TypeStamp "nil" 2));
-    ("Ex", (1, TypeStamp "Ex" 0));
-    ("Some", (1, TypeStamp "Some" 3));
-    ("None", (0, TypeStamp "None" 3));
-  ] []
+Definition cake_print_def:
+  cake_print e =
+    (* val _ = print e; *)
+    [Dlet unknown_loc Pany (App Opapp [Var (Short "print"); e])]
 End
 
-Definition myEnv_def:
-  myEnv = <| v := let first = Bind [
-    ("sadd", Recclosure <| v := nsEmpty; c := myC |> [
+Definition codegen_def:
+  codegen p = INR [
+    Dtype unknown_loc [
+      ([], "sprim", [
+        ("SAdd", []);
+        ("SMul", []);
+        ("SMinus", []);
+        ("SEqv", []);
+        ("CallCC", [])
+      ]);
+      ([], "sval", [
+        ("SNum", [Atapp [] (Short "int")]);
+        ("SBool", [Atapp [] (Short "bool")]);
+        ("Prim", [Atapp [] (Short "sprim")]);
+        ("SList", [Atapp [Atapp [] (Short "sval")] (Short "list")]);
+        ("Wrong", [Atapp [] (Short "string")]);
+        ("Ex", [Atapp [] (Short "string")]);
+        ("Proc", [Atfun
+                   (Atfun
+                     (Atapp [] (Short "sval"))
+                     (Atapp [] (Short "sval")))
+                   (Atfun
+                     (Atapp [Atapp [] (Short "sval")] (Short "list"))
+                     (Atapp [] (Short "sval")))]);
+        ("Throw", [Atfun
+                    (Atapp [] (Short "sval"))
+                    (Atapp [] (Short "sval"))]);
+      ])
+    ];
+    Dletrec unknown_loc [
       ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "x")) [
             (Pcon (SOME $ Short "SNum") [Pvar "xn"],
               App Opapp [
@@ -259,12 +241,12 @@ Definition myEnv_def:
               Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
           ])
       ])
-    ] "sadd");
-    ("smul", Recclosure <| v := nsEmpty; c := myC |> [
+    ];
+    Dletrec unknown_loc [
       ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "x")) [
             (Pcon (SOME $ Short "SNum") [Pvar "xn"],
               App Opapp [
@@ -278,72 +260,65 @@ Definition myEnv_def:
               Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
           ])
       ])
-    ] "smul");
-    ("seqv", Closure <| v := nsEmpty; c := myC |> "k" (Fun "xs" $
+    ];
+    Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
+      Mat (Var (Short "xs")) [
+        (Pcon (SOME $ Short "[]") [],
+          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+          Mat (Var (Short "x")) [
+            (Pcon (SOME $ Short "SNum") [Pvar "n"],
+              App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+                Fun "t" $ Mat (Var (Short "t")) [
+                  (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                    App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [
+                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]]);
+                  (Pany,
+                    App Opapp [Var (Short "k"); Var (Short "t")])
+                ]];
+                Lit $ IntLit 0]; Var (Short "xs'")]);
+            (Pany,
+              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+          ])
+      ];
+    Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
       Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "cons") [Pvar "x1"; Pvar "xs'"],
+        (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
           Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "nil") [],
+            (Pcon (SOME $ Short "[]") [],
               Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-            (Pcon (SOME $ Short "cons") [Pvar "x2"; Pvar "xs''"],
+            (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
               Mat (Var (Short "xs''")) [
-                (Pcon (SOME $ Short "nil") [],
+                (Pcon (SOME $ Short "[]") [],
                   If (App Equality [Var (Short "x1"); Var (Short "x2")])
-                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Lit $ IntLit 1]])
-                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Lit $ IntLit 0]]));
+                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]])
+                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]]));
                 (Pany,
                   Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
               ])
           ])
-      ]
-    ));
-    ("throw", Closure <| v := nsEmpty; c := myC |> "k" (Fun "xs" $
+      ];
+    Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
       Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "nil") [],
+            (Pcon (SOME $ Short "[]") [],
               App Opapp [Var (Short "k"); Var (Short "x")]);
             (Pany,
               Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
           ])
-      ]
-    ));
-  ] [];
-  second = nsAppend first $ Bind [
-    ("sminus", Closure <| v := first; c := myC |> "k" (Fun "xs" $
-      Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
-          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "n"],
-              App Opapp [App Opapp [App Opapp [Var (Short "sadd");
-                Fun "t" $ Mat (Var (Short "t")) [
-                  (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                    App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [
-                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]]);
-                  (Pany,
-                    App Opapp [Var (Short "k"); Var (Short "t")])
-                ]];
-                Lit $ IntLit 0]; Var (Short "xs'")]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ]
-    ))
-  ] []
-  in nsAppend second $ Bind [
-    ("app", Recclosure <| v := second; c := myC |> [
+      ];
+    Dletrec unknown_loc [
       ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "nil") [],
+        (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "cons") [Pvar "x"; Pvar "xs'"],
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "nil") [],
+            (Pcon (SOME $ Short "[]") [],
               App Opapp [
                 App Opapp [
                   App Opapp [Var (Short "app");Var (Short "k")];
@@ -369,102 +344,15 @@ Definition myEnv_def:
         (Pcon (SOME $ Short "Throw") [Pvar "k'"],
           App Opapp [Var (Short "throw"); Var (Short "k'")]);
         (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
-    ])
-    ] "app");
-  ] []
-; c := myC
-|>
-End
-
-Definition cake_print_def:
-  cake_print e =
-    (* val _ = print e; *)
-    [Dlet unknown_loc Pany (App Opapp [Var (Short "print"); e])]
-End
-
-Definition codegen_def:
-  (codegen (Print s)) : string + dec list =
-    INR (cake_print (Lit (StrLit (explode s))))
-  (*codegen _ = INR [Dlet unknown_loc Pany $ scheme_program_to_cake (cps_transform (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69)))]*)
-End
-
-val _ = export_theory();
-
-(*
-  open scheme_to_cakeTheory;
-  open evaluateTheory;
-
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake $ Val $ SNum 3]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SMinus) [Val $ SNum 2; Val $ SNum 3])]”
-  EVAL “evaluate <| clock := 999 |> myEnv [scheme_program_to_cake (Apply (Val $ Prim SEqv) [Val $ SNum 2; Val $ SNum 2])]”
-  EVAL “evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Lambda [strlit "x"] NONE (Begin (Set (strlit "x") (Val $ SNum 7)) [Ident $ strlit "x"])) [Val $ SNum 5])]”
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
-    Letrec [(strlit "f", Lambda [strlit "b"; strlit "x"] NONE (
-      Cond (Ident $ strlit "b")
-        (Apply (Val $ Prim SMul) [Val $ SNum 2; Ident $ strlit "x"])
-        (Apply (Ident $ strlit "f") [Val $ SBool T; Apply
-          (Val $ Prim SAdd) [Val $ SNum 1; Ident $ strlit "x"]])
-    ))] (
-      Apply (Ident $ strlit "f") [Val $ SBool F; Val $ SNum 7]
-    )
-  )]”
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
-    Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
-      Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0]) (
-        Val $ SNum 1
-      ) (
-        Apply (Val $ Prim SMul) [Ident $ strlit "x"; Apply (Ident $ strlit "fac") [
-          Apply (Val $ Prim SMinus) [Ident $ strlit "x"; Val $ SNum 1]
-        ]]
-      )
-    ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))]”
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
-    Apply (Val $ Prim SMul) [
-      Val $ SNum 2;
-      Apply (Val $ Prim CallCC) [ Lambda [strlit "x"] NONE (
-        Apply (Val $ Prim SAdd) [
-          Val $ SNum 4;
-          Cond (Val $ SBool T) (
-            Val $ SNum 3
-          ) (
-            Apply (Ident $ strlit "x") [Val $ SNum 5]
-          )
-        ]
-      )]
+      ])
+    ];
+    Dlet unknown_loc (Pvar "res") $ exp_with_cont [] p;
+    Dlet unknown_loc Pany $ Mat (Var (Short "res")) [
+      (Pcon (SOME $ Short "SNum") [Pvar "n"],
+        App Opapp [Var (Short "print_int"); Var (Short "n")]);
+      (Pany, App Opapp [Var (Short "print"); Lit $ StrLit "NaN"])
     ]
-  )]”
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (
-    Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
-      Letrec [(strlit "st", Val $ SNum 0); (strlit "acc", Val $ SNum 1)] (
-        Begin ( Apply (Val $ Prim CallCC) [ Lambda [strlit "k"] NONE (
-          Set (strlit "st") (Ident $ strlit "k")
-        )]) [
-          Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0])
-            (Ident $ strlit "acc")
-            (Apply (Ident $ strlit "st") [ Begin (
-              Set (strlit "acc") (Apply (Val $ Prim SMul) [
-                Ident $ strlit "acc";
-                Ident $ strlit "x"
-              ])
-            ) [
-              Set (strlit "x") (Apply (Val $ Prim SMinus) [
-                Ident $ strlit "x";
-                Val $ SNum 1
-              ])
-            ]])
-        ]
-      )
-    ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6])
-  )]”
+  ]
+End
 
-  open scheme_parsingTheory;
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake $ OUTR $ parse_to_ast
-    "(letrec ((fac (lambda (x) (letrec ((st 0) (acc 1)) (begin (callcc (lambda (k) (set! st k))) (if (eqv? x 0) acc (st (begin (set! acc ( * acc x)) (set! x (- x 1)))))))))) (fac 6))"]”
-  EVAL “scheme_program_to_cake (Cond (Val $ SBool F) (Val $ SNum 420) (Val $ SNum 69))”
-  EVAL “scheme_program_to_cake (Apply (Val $ Prim SMul) [Val $ SNum 2; Val $ SNum 3])”
-  EVAL “scheme_program_to_cake (Apply (Lambda [] (SOME $ strlit "x") (Ident $ strlit "x")) [Val $ SNum 5])”
-  EVAL “scheme_program_to_cake (Begin (Val $ SNum 0) [Val $ SNum 1; Val $ SNum 2])”
-  EVAL “scheme_program_to_cake (Letrec [(strlit "x", Val $ SNum 1)] (Ident $ strlit "x"))”
-  EVAL “SND $ evaluate <| clock := 999; refs := [] |> myEnv [scheme_program_to_cake (Apply (Val $ Prim CallCC) [Lambda [strlit "x"] NONE $ Apply (Ident $ strlit "x") [Val $ SNum 5]])]”
-*)
\ No newline at end of file
+val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index bfc6155e49..3c0776fc33 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -35,7 +35,12 @@ val r = translate parse_to_ast_def;
 val r = translate locationTheory.unknown_loc_def;
 val r = translate cake_print_def;
 val r = translate to_ml_vals_def;
-val r = translate small_cps_def;
+val r = translate cons_list_def;
+val r = translate proc_ml_def;
+val r = translate letinit_ml_def;
+val r = translate cps_transform_def;
+val r = translate scheme_cont_def;
+val r = translate exp_with_cont_def;
 val r = translate codegen_def;
 
 (* top-level compiler *)

From 03b1a40f961973fa99dd3953df2557cdd985088d Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Thu, 20 Mar 2025 14:38:35 +0000
Subject: [PATCH 059/100] bool bug fix

---
 compiler/scheme/scheme_to_cakeScript.sml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 6f49664b47..910fe298dd 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -19,7 +19,7 @@ Definition to_ml_vals_def:
   | CallCC => Con (SOME $ Short "CallCC") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
   to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Con (SOME $ Short 
-    if b then "False" else "True") []]
+    if b then "True" else "False") []]
 End
 
 Definition cons_list_def:

From 374a753980ccd76eb45be8490e32dacbe5f36531 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Mar 2025 18:25:01 +0000
Subject: [PATCH 060/100] better printing

---
 compiler/scheme/scheme_to_cakeScript.sml | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 910fe298dd..121b0e1893 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -350,7 +350,15 @@ Definition codegen_def:
     Dlet unknown_loc Pany $ Mat (Var (Short "res")) [
       (Pcon (SOME $ Short "SNum") [Pvar "n"],
         App Opapp [Var (Short "print_int"); Var (Short "n")]);
-      (Pany, App Opapp [Var (Short "print"); Lit $ StrLit "NaN"])
+      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "True") []],
+        App Opapp [Var (Short "print"); Lit $ StrLit "#t"]);
+      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
+        App Opapp [Var (Short "print"); Lit $ StrLit "#f"]);
+      (Pcon (SOME $ Short "Ex") [Pvar "ex"],
+        App Opapp [Var (Short "print"); Var (Short "ex")]);
+      (Pcon (SOME $ Short "Wrong") [Pany],
+        App Opapp [Var (Short "print"); Lit $ StrLit "unspecified"]);
+      (Pany, App Opapp [Var (Short "print"); Lit $ StrLit "proc"])
     ]
   ]
 End

From 5fb682c5bb9d4633a697aad28180bb9a5cccd5e4 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 21 Mar 2025 18:25:17 +0000
Subject: [PATCH 061/100] examples

---
 compiler/scheme/examples/list.scm  | 9 +++++++++
 compiler/scheme/examples/print.scm | 1 +
 2 files changed, 10 insertions(+)
 create mode 100644 compiler/scheme/examples/list.scm
 create mode 100644 compiler/scheme/examples/print.scm

diff --git a/compiler/scheme/examples/list.scm b/compiler/scheme/examples/list.scm
new file mode 100644
index 0000000000..28ee6d5bef
--- /dev/null
+++ b/compiler/scheme/examples/list.scm
@@ -0,0 +1,9 @@
+(letrec (
+  (cons (lambda (car cdr) (lambda (b) (if b car cdr))))
+  (car (lambda (cons) (cons #t)))
+  (cdr (lambda (cons) (cons #f)))
+  (nil 999)
+  (nil? (lambda (l) (eqv? l nil)))
+  (length (lambda (l) (if (nil? l) 0 (+ 1 (length (cdr l))))))
+  (index (lambda (n l) (if (eqv? n 0) (car l) (index (- n 1) (cdr l)))))
+) (index 1 (cons 10 (cons 20 (cons 30 nil)))))
diff --git a/compiler/scheme/examples/print.scm b/compiler/scheme/examples/print.scm
new file mode 100644
index 0000000000..7371dc8d72
--- /dev/null
+++ b/compiler/scheme/examples/print.scm
@@ -0,0 +1 @@
+(letrec ((touch 0)) (begin (set! touch 1) touch))

From 263ae949cbef4b282ba0140dc61f6431b07080d2 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 28 Mar 2025 15:37:09 +0000
Subject: [PATCH 062/100] separation of vals and lits

---
 compiler/scheme/scheme_astScript.sml       | 40 ++++++++----
 compiler/scheme/scheme_parsingScript.sml   | 14 ++--
 compiler/scheme/scheme_proofsScript.sml    | 76 +++++++++++++++++-----
 compiler/scheme/scheme_semanticsScript.sml | 69 +++++++++++---------
 compiler/scheme/scheme_to_cakeScript.sml   | 21 +++---
 5 files changed, 141 insertions(+), 79 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 7f9a6273c4..1c0e3fa895 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -14,21 +14,13 @@ Datatype:
 End
 
 Datatype:
-  val = Prim prim | SNum int | Wrong string | SBool bool
-      | SList (val list)
-      | Proc senv (mlstring list) (mlstring option) exp
-      (*requires HOL 94eb753a85c5628f4fd0401deb4b7e2972a8eb25*)
-      | Throw ((senv # cont) list)
-;
-  (*Contexts for small-step operational semantics*)
-  cont = ApplyK ((val # val list) option) (exp list)
-       | CondK exp exp
-       | BeginK (exp list)
-       | SetK mlstring
-;
+  lit = LitPrim prim | LitNum int | LitBool bool
+End
+
+Datatype:
   exp = (*Print mlstring
       |*) Apply exp (exp list)
-      | Val val
+      | Lit lit
       | Cond exp exp exp
       | Ident mlstring
       | Lambda (mlstring list) (mlstring option) exp
@@ -38,6 +30,26 @@ Datatype:
       | Letrec ((mlstring # exp) list) exp
 End
 
+Datatype:
+  (*Contexts for small-step operational semantics*)
+  cont = ApplyK ((val # val list) option) (exp list)
+       | CondK exp exp
+       | BeginK (exp list)
+       | SetK mlstring
+;
+  val = Prim prim | SNum int | Wrong string | SBool bool
+      | SList (val list)
+      | Proc senv (mlstring list) (mlstring option) exp
+      (*requires HOL 94eb753a85c5628f4fd0401deb4b7e2972a8eb25*)
+      | Throw ((senv # cont) list)
+End
+
+Definition lit_to_val_def:
+  lit_to_val (LitPrim p) = Prim p ∧
+  lit_to_val (LitNum n) = SNum n ∧
+  lit_to_val (LitBool b) = SBool b
+End
+
 Definition static_scoping_check_def:
   (static_scoping_check env (Cond c t f) ⇔
     static_scoping_check env c ∧
@@ -64,7 +76,7 @@ Termination
   WF_REL_TAC ‘measure $ exp_size o SND’
   >> Induct_on ‘xes’ >- (rw[])
   >> Cases_on ‘h’
-  >> simp[definition "val_size_def", list_size_def, snd (TypeBase.size_of “:'a # 'b”)]
+  >> simp[snd (TypeBase.size_of “:exp”), list_size_def, snd (TypeBase.size_of “:'a # 'b”)]
   >> rpt strip_tac >- (rw[])
   >> last_x_assum $ qspecl_then [‘e’, ‘a’] $ imp_res_tac
   >> first_x_assum $ qspec_then ‘e’ $ assume_tac
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index d8081a1137..10f7814654 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -202,14 +202,14 @@ Definition cons_formals_def:
 End
 
 Definition cons_ast_def:
-  cons_ast (Num n) = INR (Val (SNum n)) ∧
-  cons_ast (Bool b) = INR (Val (SBool b)) ∧
+  cons_ast (Num n) = INR (Lit (LitNum n)) ∧
+  cons_ast (Bool b) = INR (Lit (LitBool b)) ∧
   cons_ast (Word w) = (
-    if w = "+" then INR (Val (Prim SAdd)) else
-    if w = "-" then INR (Val (Prim SMinus)) else
-    if w = "*" then INR (Val (Prim SMul)) else
-    if w = "eqv?" then INR (Val (Prim SEqv)) else
-    if w = "callcc" then INR (Val (Prim CallCC)) else
+    if w = "+" then INR (Lit (LitPrim SAdd)) else
+    if w = "-" then INR (Lit (LitPrim SMinus)) else
+    if w = "*" then INR (Lit (LitPrim SMul)) else
+    if w = "eqv?" then INR (Lit (LitPrim SEqv)) else
+    if w = "callcc" then INR (Lit (LitPrim CallCC)) else
       INR (Ident (implode w))) ∧
   cons_ast Nil = INL "Empty S expression" ∧
   cons_ast (Pair x y) = (case pair_to_list y of
diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index b4b7fe48eb..f38fcd9982 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -29,6 +29,7 @@ Termination
 End
 *)
 
+(*
 Inductive subset1:
 [~Prim:]
   vsubset1 (Prim p)
@@ -53,6 +54,7 @@ Inductive subset1:
   EVERY ksubset1 ks ⇒ kssubset1 ks
 End
 
+
 Theorem subset1_rewrite[simp] = LIST_CONJ[
   “vsubset1 (Prim p)” |> SCONV [Once subset1_cases],
   “vsubset1 (SNum n)” |> SCONV [Once subset1_cases],
@@ -180,24 +182,68 @@ Proof
   Induct_on ‘e’
   rpt strip_tac
 QED
+*)
+
+(*
+Example lambda calculus code of conditional expression,
+before and after step in CEK machine
+
+(\k0 -> (\k1 -> k1 $ SBool T)
+  (\t0 -> match t0
+          | SBool F => (\k2 -> k2 (SNum 1)) k0
+          | _ => (\k2 -> k2 (SNum 2)) k0))
+(\t -> t)
+
+-->
+
+(\k1 -> k1 $ SBool T)
+(\t0 -> match t0
+        | SBool F => (\k2 -> k2 (SNum 1)) (\t -> t)
+        | _ => (\k2 -> k2 (SNum 2)) (\t -> t)))
+*)
+
+Definition e_or_v_to_exp_def:
+  e_or_v_to_exp (Val v) var = App Opapp [Var (Short var); to_ml_vals v] ∧
+  e_or_v_to_exp (Exp e) var = (let
+    (n, ce) = cps_transform 0 e
+  in
+    App Opapp [ce; Var (Short var)])
+End
+
+Inductive cont_rel:
+[~Id:]
+  cont_rel []
+    (Closure env t (Var (Short t)))
+[~CondK:]
+  cont_rel ks kv ∧
+  nsLookup (env . v) (Short var) = SOME kv ∧
+  (n', ct) = cps_transform n te ∧
+  (m', cf) = cps_transform m fe
+  ⇒
+  (*Likely needs condition on se i.e. Scheme env*)
+  cont_rel ((se, CondK te fe) :: ks)
+    (Closure env t $ Mat (Var (Short t)) [
+      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
+        App Opapp [cf; Var (Short var)]);
+      (Pany, App Opapp [ct;  Var (Short var)])
+    ])
+End
 
 Theorem myproof:
-  ∀ e e' n k k' . kssubset1 (MAP SND k) ∧ subset1 e ⇒ step  ([], k, FEMPTY, e) = ([], k', FEMPTY, e') ⇒
-      ∃ ck ck' t1 . evaluate (<| clock := ck |> : 'ffi state) myEnv [exp_with_cont (MAP SND k) e] =
-        evaluate <| clock := ck' |> myEnv [exp_with_cont (MAP SND k') e']
+  ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
+  step  (store, k, env, e) = (store', k', env', e') ∧
+  st.clock > 0 ∧
+  cont_rel k kv ∧
+  nsLookup mlenv.v (Short var) = SOME kv
+  ⇒
+  ∃ st' mlenv' var' kv' mle'.
+    evaluate st mlenv [e_or_v_to_exp e var]
+    =
+    evaluate st' mlenv' [e_or_v_to_exp e' var'] ∧
+    cont_rel k' kv' ∧
+    nsLookup mlenv'.v (Short var') = SOME kv'
 Proof
-  Cases >> simp[]
-  >> rpt strip_tac
-  >> simp[exp_with_cont_def, cps_transform_def]
-  >~ [‘Cond c t f’] >- (
-    gvs[step_def, scheme_cont_def, cps_transform_def]
-    >> rpt (pairarg_tac >> gvs[step_def])
-    >> simp[SimpLHS, evaluate_def]
-    >> qexistsl_tac [‘ck+1’,‘ck’]
-    >> dxrule_then (qspec_then ‘ck+1’ mp_tac) (SRULE [] k_vals_subset1)
-    >> strip_tac >> simp[do_opapp_def, dec_clock_def]
-    >> cheat
-  ) >> cheat
+  cheat
 QED
 
 (*Theorem val_correct:
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index d05021bdd6..d749f90ebd 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -8,29 +8,33 @@ open finite_mapTheory;
 
 val _ = new_theory "scheme_semantics";
 
+Datatype:
+  e_or_v = Exp exp | Val val
+End
+
 Definition sadd_def:
   sadd [] n = Val $ SNum n ∧
   sadd (SNum m :: xs) n = sadd xs (m + n) ∧
-  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
+  sadd (_ :: xs) _ = Exp $ Exception $ strlit "Arguments to + must be numbers"
 End
 
 Definition smul_def:
   smul [] n = Val $ SNum n ∧
   smul (SNum m :: xs) n = smul xs (m * n) ∧
-  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
+  smul (_ :: xs) _ = Exp $ Exception $ strlit "Arguments to * must be numbers"
 End
 
 Definition sminus_def:
-  sminus [] = Exception $ strlit "Arity mismatch" ∧
+  sminus [] = Exp $ Exception $ strlit "Arity mismatch" ∧
   sminus (SNum n :: xs) = (case sadd xs 0 of
   | Val (SNum m) => Val (SNum (n - m))
   | e => e) ∧
-  sminus _ = Exception $ strlit "Arguments to - must be numbers"
+  sminus _ = Exp $ Exception $ strlit "Arguments to - must be numbers"
 End
 
 Definition seqv_def:
   seqv [v1; v2] = (if v1 = v2 then Val $ SBool T else Val $ SBool F) ∧
-  seqv _ = Exception $ strlit "Arity mismatch"
+  seqv _ = Exp $ Exception $ strlit "Arity mismatch"
 End
 
 (*
@@ -52,12 +56,12 @@ Definition fresh_loc_def:
 End
 
 Definition parameterize_def:
-  parameterize store ks env [] NONE e [] = (store, ks, env, e) ∧
-  parameterize store ks env [] (SOME l) e xs = (let (n, store') = fresh_loc store (SOME $ SList xs)
-    in (store', ks, (env |+ (l, n)), e)) ∧
+  parameterize store ks env [] NONE e [] = (store, ks, env, Exp e) ∧
+  parameterize store ks env [] (SOME (l:mlstring)) e xs = (let (n, store') = fresh_loc store (SOME $ SList xs)
+    in (store', ks, (env |+ (l, n)), Exp e)) ∧
   parameterize store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store (SOME x)
     in parameterize store' ks (env |+ (p, n)) ps lp e xs) ∧
-  parameterize store ks _ _ _ _ _ = (store, ks, FEMPTY, Exception $ strlit "Wrong number of arguments")
+  parameterize store ks _ _ _ _ _ = (store, ks, FEMPTY, Exp $ Exception $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
@@ -68,13 +72,13 @@ Definition application_def:
   | SEqv => (store, ks, FEMPTY, seqv xs)
   | CallCC => case xs of
     | [v] => (store, (FEMPTY, ApplyK (SOME (v, [])) []) :: ks, FEMPTY, Val $ Throw ks)
-    | _ => (store, ks, FEMPTY, Exception $ strlit "arity mismatch")) ∧
+    | _ => (store, ks, FEMPTY, Exp $ Exception $ strlit "arity mismatch")) ∧
   application store ks (Proc env ps lp e) xs =
     parameterize store ks env ps lp e xs ∧
   application store ks (Throw ks') xs = (case xs of
     | [v] => (store, ks', FEMPTY, Val v)
-    | _ => (store, ks, FEMPTY, Exception $ strlit "arity mismatch")) ∧
-  application store ks _ _ = (store, ks, FEMPTY, Exception $ strlit "Not a procedure")
+    | _ => (store, ks, FEMPTY, Exp $ Exception $ strlit "arity mismatch")) ∧
+  application store ks _ _ = (store, ks, FEMPTY, Exp $ Exception $ strlit "Not a procedure")
 End
 
 Definition return_def:
@@ -82,17 +86,17 @@ Definition return_def:
 
   return store ((env, ApplyK NONE eargs) :: ks) v = (case eargs of
   | [] => application store ks v []
-  | e::es => (store, (env, ApplyK (SOME (v, [])) es) :: ks, env, e)) ∧
+  | e::es => (store, (env, ApplyK (SOME (v, [])) es) :: ks, env, Exp e)) ∧
   return store ((env, ApplyK (SOME (vfn, vargs)) eargs) :: ks) v = (case eargs of
   | [] => application store ks vfn (REVERSE $ v::vargs)
-  | e::es => (store, (env, ApplyK (SOME (vfn, v::vargs)) es) :: ks, env, e)) ∧
+  | e::es => (store, (env, ApplyK (SOME (vfn, v::vargs)) es) :: ks, env, Exp e)) ∧
 
   return store ((env, CondK t f) :: ks) v = (if v = (SBool F)
-    then (store, ks, env, f) else (store, ks, env, t)) ∧
+    then (store, ks, env, Exp f) else (store, ks, env, Exp t)) ∧
 
   return store ((env, BeginK es) :: ks) v = (case es of
   | [] => (store, ks, env, Val v)
-  | e::es' => (store, (env, BeginK es') :: ks, env, e)) ∧
+  | e::es' => (store, (env, BeginK es') :: ks, env, Exp e)) ∧
   return store ((env, SetK x) :: ks) v = (LUPDATE (SOME v) (env ' x) store, ks, env, Val $ Wrong "Unspecified")
 End
 
@@ -104,23 +108,24 @@ End
 
 Definition step_def:
   step (store, ks, env, Val v) = return store ks v ∧
-  step (store, ks, env, Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, fn) ∧
-  step (store, ks, env, Cond c t f) = (store, (env, CondK t f) :: ks, env, c) ∧
+  step (store, ks, env, Exp $ Lit lit) = (store, ks, env, Val $ lit_to_val lit) ∧
+  step (store, ks, env, Exp $ Apply fn args) = (store, (env, ApplyK NONE args) :: ks, env, Exp fn) ∧
+  step (store, ks, env, Exp $ Cond c t f) = (store, (env, CondK t f) :: ks, env, Exp c) ∧
   (*This is undefined if the program doesn't typecheck*)
-  step (store, ks, env, Ident s) = (let e = case EL (env ' s) store of
-    | NONE => Exception $ strlit "letrec variable touched"
+  step (store, ks, env, Exp $ Ident s) = (let ev = case EL (env ' s) store of
+    | NONE => Exp $ Exception $ strlit "letrec variable touched"
     | SOME v => Val v
-    in (store, ks, env, e)) ∧
-  step (store, ks, env, Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
-  step (store, ks, env, Begin e es) = (store, (env, BeginK es) :: ks, env, e) ∧
-  step (store, ks, env, Set x e) = (store, (env, SetK x) :: ks, env, e) ∧
+    in (store, ks, env, ev)) ∧
+  step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
+  step (store, ks, env, Exp $ Begin e es) = (store, (env, BeginK es) :: ks, env, Exp e) ∧
+  step (store, ks, env, Exp $ Set x e) = (store, (env, SetK x) :: ks, env, Exp e) ∧
   (*There is a missing reinit check, though the spec says it is optional*)
-  step (store, ks, env, Letrec bs e) = (case bs of
-  | [] => (store, ks, env, e)
+  step (store, ks, env, Exp $ Letrec bs e) = (case bs of
+  | [] => (store, ks, env, Exp e)
   | (x, i)::bs' => let (store', env') = letrec_init store env (MAP FST bs)
-      in (store', (env', BeginK (SNOC e (MAP (UNCURRY Set) bs'))) :: ks, env', Set x i)) ∧
+      in (store', (env', BeginK (SNOC e (MAP (UNCURRY Set) bs'))) :: ks, env', Exp $ Set x i)) ∧
 
-  step (store, ks, env, Exception ex) = (store, [], env, Exception ex)
+  step (store, ks, env, Exp $ Exception ex) = (store, [], env, Exp $ Exception ex)
 End
 
 Definition steps_def:
@@ -155,19 +160,19 @@ End
     ]
   )”
 
-  EVAL “steps 16 ([], [], FEMPTY,
+  EVAL “steps 99 ([], [], FEMPTY,Exp $
     Apply (
       Lambda [strlit "x"] NONE (
         Apply (
           Lambda [strlit "y"] NONE (
-            Apply (Val $ Prim SAdd) [
+            Apply (Lit $ LitPrim SAdd) [
               Ident $ strlit "y";
               Ident $ strlit "x"
             ]
           )
-        ) [Val $ SNum 1]
+        ) [Lit $ LitNum 1]
       )
-    ) [Val $ SNum 4]
+    ) [Lit $ LitNum 4]
   )”
 
   EVAL “steps 16 ([], [], FEMPTY,
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 121b0e1893..7c7c149924 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -18,7 +18,7 @@ Definition to_ml_vals_def:
   | SEqv => Con (SOME $ Short "SEqv") []
   | CallCC => Con (SOME $ Short "CallCC") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
-  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Con (SOME $ Short 
+  to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Con (SOME $ Short
     if b then "True" else "False") []]
 End
 
@@ -59,8 +59,8 @@ Definition letinit_ml_def:
 End
 
 Definition cps_transform_def:
-  cps_transform n (Val v) = (let k = "k" ++ toString n in
-    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals v])) ∧
+  cps_transform n (Lit v) = (let k = "k" ++ toString n in
+    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals $ lit_to_val v])) ∧
   cps_transform n (Exception s) =
     (n, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]) ∧
   cps_transform n (Cond c t f) = (let
@@ -169,14 +169,13 @@ Termination
     | INR(INR(INL(_,_,_,es,_))) => list_size exp_size es
     | INR(INR(INR(INL(_,_,es)))) => list_size exp_size es
     | INR(INR(INR(INR(_,_,es,_)))) => list_size (exp_size o SND) es)’
-  >> rpt (strip_tac >- (Cases >> rw[val_size_def]))
-  >> strip_tac >- (
-    Induct_on ‘bs’ >> Cases
-    >> rw[val_size_def, list_size_def]
-    >> last_x_assum $ qspecl_then [‘e’,‘n’,‘m’,‘ce’] $ mp_tac
-    >> rw[]
-  )
-  >> Cases >> rw[val_size_def]
+  >> rpt (strip_tac >- (Cases >> rw[scheme_astTheory.exp_size_def]))
+  >> rpt (strip_tac >- (
+      Induct >- (Cases >> simp[scheme_astTheory.exp_size_def, list_size_def])
+      >> Cases >> rw[scheme_astTheory.exp_size_def, list_size_def]
+      >> last_x_assum dxrule >> simp[]
+  ))
+  >> Cases >> rw[scheme_astTheory.exp_size_def]
 End
 
 Definition scheme_cont_def:

From 28772f316c78e4922338a158ab6e9dc5423b9249 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 28 Mar 2025 16:06:10 +0000
Subject: [PATCH 063/100] translate lits

---
 compiler/scheme/translation/scheme_compilerProgScript.sml | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 3c0776fc33..b35d154f71 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -3,6 +3,7 @@
 *)
 open preamble basis;
 open to_sexpProgTheory;
+open scheme_astTheory;
 open scheme_parsingTheory;
 open scheme_to_cakeTheory;
 open scheme_compilerTheory;
@@ -33,6 +34,7 @@ val r = translate parse_to_ast_def;
 (* codegen *)
 
 val r = translate locationTheory.unknown_loc_def;
+val r = translate lit_to_val_def;
 val r = translate cake_print_def;
 val r = translate to_ml_vals_def;
 val r = translate cons_list_def;

From 6e240028744ae2e785a58cd0a49d258fbf38af90 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Tue, 1 Apr 2025 17:23:28 +0100
Subject: [PATCH 064/100] semantic preservation of cond

---
 compiler/scheme/scheme_proofsScript.sml       | 92 ++++++++++++++++++-
 compiler/scheme/scheme_to_cakeScript.sml      | 11 ++-
 .../translation/scheme_compilerProgScript.sml |  1 +
 3 files changed, 97 insertions(+), 7 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index f38fcd9982..7d39fabd74 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -8,8 +8,10 @@ open scheme_to_cakeTheory;
 open astTheory;
 
 open evaluateTheory;
+open evaluatePropsTheory;
 open semanticPrimitivesTheory;
 open namespaceTheory;
+open primTypesTheory;
 
 val _ = new_theory "scheme_proofs";
 
@@ -229,21 +231,103 @@ Inductive cont_rel:
     ])
 End
 
+(*
+EVAL “case (SND $ evaluate_decs <|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>
+<|v:=nsEmpty;c:=nsEmpty|> $ prim_types_program
+++ (scheme_basis)) of
+  | Rval env => evaluate <|clock:=999|> env $ [exp_with_cont [] (Lit $ LitBool T)]
+  | _ => (st, v)”
+*)
+
+Definition scheme_env_def:
+  scheme_env env
+  ⇔
+  (*not sure what to do with the state type variable,
+  it doesn't work without a concrete type*)
+  ∀ (st:num state) .
+  evaluate st env [Con (SOME (Short "SBool")) [
+    Con (SOME (Short "False")) []]]
+  = (st, Rval [Conv (SOME (TypeStamp "SBool" 3)) [
+    Conv (SOME (TypeStamp "False" 0)) []]]) ∧
+  evaluate st env [Con (SOME (Short "SBool")) [
+    Con (SOME (Short "True")) []]]
+  = (st, Rval [Conv (SOME (TypeStamp "SBool" 3)) [
+    Conv (SOME (TypeStamp "True" 0)) []]])
+End
+
+Theorem basis_scheme_env:
+  ∃ st st' env .
+    evaluate_decs st <|v:=nsEmpty;c:=nsEmpty|>
+      (prim_types_program ++ scheme_basis) = (st', Rval env) ∧
+    scheme_env env
+Proof
+  qexists ‘<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>’
+  >> simp[evaluate_decs_def, prim_types_program_def, scheme_basis_def,
+  check_dup_ctors_def, build_tdefs_def, do_con_check_def,
+  nsAppend_def, build_constrs_def, alist_to_ns_def,
+  nsLookup_def, build_rec_env_def, extend_dec_env_def,
+  nsSing_def, nsEmpty_def, nsBind_def, pat_bindings_def,
+  evaluate_def, pmatch_def, combine_dec_result_def,
+  every_exp_def, one_con_check_def, cons_list_def,
+  scheme_env_def, build_conv_def]
+QED
+
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
   st.clock > 0 ∧
   cont_rel k kv ∧
-  nsLookup mlenv.v (Short var) = SOME kv
+  nsLookup mlenv.v (Short var) = SOME kv ∧
+  scheme_env mlenv
   ⇒
   ∃ st' mlenv' var' kv' mle'.
+    nsLookup mlenv'.v (Short var') = SOME kv'
+    ⇒
     evaluate st mlenv [e_or_v_to_exp e var]
     =
     evaluate st' mlenv' [e_or_v_to_exp e' var'] ∧
-    cont_rel k' kv' ∧
-    nsLookup mlenv'.v (Short var') = SOME kv'
+    cont_rel k' kv'
 Proof
-  cheat
+  Cases_on ‘e’
+  >~ [‘Val v’] >- (
+    Cases_on ‘k’
+    >- (simp[step_def, return_def] >> metis_tac[])
+    >> cheat
+  )
+  >~ [‘Exp e’] >- (
+    Cases_on ‘e’
+    >> simp[step_def, e_or_v_to_exp_def]
+    >~ [‘Cond c te fe’] >- (
+      rpt strip_tac
+      >> simp[cps_transform_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> qexistsl [
+        ‘dec_clock st’,
+        ‘mlenv with v := nsBind (STRING #"k" (toString n')) kv mlenv.v’,
+        ‘var'’,
+        ‘Closure
+           (mlenv with
+            v := nsBind (STRING #"k" (toString n')) kv mlenv.v)
+           (STRING #"t" (toString l'))
+           (Mat (Var (Short (STRING #"t" (toString l'))))
+              [(Pcon (SOME (Short "SBool"))
+                  [Pcon (SOME (Short "False")) []],
+                App Opapp
+                  [cf; Var (Short (STRING #"k" (toString n')))]);
+               (Pany,
+                App Opapp
+                    [ct; Var (Short (STRING #"k" (toString n')))])])’]
+      >> rpt strip_tac >- simp[evaluate_def, do_opapp_def]
+      >> qspecl_then [‘cf’, ‘ct’,
+        ‘mlenv with v := nsBind (STRING #"k" (toString n')) kv mlenv.v’,
+        ‘fe’,‘k’,‘kv’,‘m'’,‘l'’,‘n'+1’,‘m'’,‘env’,
+        ‘STRING #"t" (toString l')’,‘te’,‘STRING #"k" (toString n')’
+      ] assume_tac cont_rel_CondK
+      >> simp[]
+    )
+    >> cheat
+  )
+  >> cheat
 QED
 
 (*Theorem val_correct:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 7c7c149924..c425c4db2f 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -193,8 +193,8 @@ Definition cake_print_def:
     [Dlet unknown_loc Pany (App Opapp [Var (Short "print"); e])]
 End
 
-Definition codegen_def:
-  codegen p = INR [
+Definition scheme_basis_def:
+  scheme_basis = [
     Dtype unknown_loc [
       ([], "sprim", [
         ("SAdd", []);
@@ -344,7 +344,12 @@ Definition codegen_def:
           App Opapp [Var (Short "throw"); Var (Short "k'")]);
         (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
       ])
-    ];
+    ]
+  ]
+End
+
+Definition codegen_def:
+  codegen p = INR $ scheme_basis ++ [
     Dlet unknown_loc (Pvar "res") $ exp_with_cont [] p;
     Dlet unknown_loc Pany $ Mat (Var (Short "res")) [
       (Pcon (SOME $ Short "SNum") [Pvar "n"],
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index b35d154f71..61345d9f8a 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -43,6 +43,7 @@ val r = translate letinit_ml_def;
 val r = translate cps_transform_def;
 val r = translate scheme_cont_def;
 val r = translate exp_with_cont_def;
+val r = translate scheme_basis_def;
 val r = translate codegen_def;
 
 (* top-level compiler *)

From b174a2bab53cc1e4286e156894dabfef2e090bd0 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 2 Apr 2025 12:11:19 +0100
Subject: [PATCH 065/100] adjust cps def for proof

---
 compiler/scheme/scheme_proofsScript.sml  | 39 ++++++++----------------
 compiler/scheme/scheme_to_cakeScript.sml |  2 +-
 2 files changed, 14 insertions(+), 27 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 7d39fabd74..31063932c3 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -281,17 +281,22 @@ Theorem myproof:
   scheme_env mlenv
   ⇒
   ∃ st' mlenv' var' kv' mle'.
-    nsLookup mlenv'.v (Short var') = SOME kv'
-    ⇒
     evaluate st mlenv [e_or_v_to_exp e var]
     =
     evaluate st' mlenv' [e_or_v_to_exp e' var'] ∧
-    cont_rel k' kv'
+    cont_rel k' kv' ∧
+    nsLookup mlenv'.v (Short var') = SOME kv'
 Proof
   Cases_on ‘e’
   >~ [‘Val v’] >- (
     Cases_on ‘k’
     >- (simp[step_def, return_def] >> metis_tac[])
+    >> PairCases_on ‘h’
+    >> Cases_on ‘∃ te fe . h1 = CondK te fe’
+    >- (
+      gvs[]
+      >> cheat
+    )
     >> cheat
   )
   >~ [‘Exp e’] >- (
@@ -301,29 +306,11 @@ Proof
       rpt strip_tac
       >> simp[cps_transform_def]
       >> rpt (pairarg_tac >> gvs[])
-      >> qexistsl [
-        ‘dec_clock st’,
-        ‘mlenv with v := nsBind (STRING #"k" (toString n')) kv mlenv.v’,
-        ‘var'’,
-        ‘Closure
-           (mlenv with
-            v := nsBind (STRING #"k" (toString n')) kv mlenv.v)
-           (STRING #"t" (toString l'))
-           (Mat (Var (Short (STRING #"t" (toString l'))))
-              [(Pcon (SOME (Short "SBool"))
-                  [Pcon (SOME (Short "False")) []],
-                App Opapp
-                  [cf; Var (Short (STRING #"k" (toString n')))]);
-               (Pany,
-                App Opapp
-                    [ct; Var (Short (STRING #"k" (toString n')))])])’]
-      >> rpt strip_tac >- simp[evaluate_def, do_opapp_def]
-      >> qspecl_then [‘cf’, ‘ct’,
-        ‘mlenv with v := nsBind (STRING #"k" (toString n')) kv mlenv.v’,
-        ‘fe’,‘k’,‘kv’,‘m'’,‘l'’,‘n'+1’,‘m'’,‘env’,
-        ‘STRING #"t" (toString l')’,‘te’,‘STRING #"k" (toString n')’
-      ] assume_tac cont_rel_CondK
-      >> simp[]
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[nsLookup_def]
+      >> simp[Once cont_rel_cases]
+      >> metis_tac[]
     )
     >> cheat
   )
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index c425c4db2f..342075045d 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -68,7 +68,7 @@ Definition cps_transform_def:
     k = "k" ++ toString m;
     (l, ck) = refunc_cont (m+1) (CondK t f) (Var (Short k))
   in
-    (l, Fun k $ App Opapp [cc; ck])) ∧
+    (l, Fun k $ Let (SOME $ "cont") ck $ App Opapp [cc; Var (Short "cont")])) ∧
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;

From 462eeb82c109080cf23d1123f86b1714c6fbe74f Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 2 Apr 2025 22:15:50 +0100
Subject: [PATCH 066/100] semantic preservation of return to cond cont

---
 compiler/scheme/scheme_proofsScript.sml | 100 ++++++++++++++++++------
 1 file changed, 75 insertions(+), 25 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 31063932c3..7cbf334563 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -212,15 +212,55 @@ Definition e_or_v_to_exp_def:
     App Opapp [ce; Var (Short var)])
 End
 
+Inductive e_ce_rel:
+[~Val:]
+  mlv = to_ml_vals v
+  ⇒
+  e_ce_rel (Val v) var $ App Opapp [Var (Short var); mlv]
+[~Exp:]
+  (m, ce) = cps_transform n e
+  ⇒
+  e_ce_rel (Exp e) var $ App Opapp [ce; Var (Short var)]
+End
+
+Definition scheme_env'_def:
+  scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ scheme_basis) of
+    | (st', Rval env) => env
+    | _ => <|v:=nsEmpty;c:=nsEmpty|>
+End
+
+Theorem scheme_env'_def[allow_rebind] = EVAL “scheme_env'”;
+
+EVAL “nsLookup scheme_env'.c (Short "SMul")”;
+
+Definition scheme_env_def:
+  scheme_env env
+  ⇔
+  (nsLookup env.c (Short "SNum") = SOME (1, TypeStamp "SNum" 3)) ∧
+  (nsLookup env.c (Short "SBool") = SOME (1, TypeStamp "SBool" 3)) ∧
+  (nsLookup env.c (Short "True") = SOME (0, TypeStamp "True" 0)) ∧
+  (nsLookup env.c (Short "False") = SOME (0, TypeStamp "False" 0)) ∧
+  (nsLookup env.c (Short "Prim") = SOME (1, TypeStamp "Prim" 3)) ∧
+  (nsLookup env.c (Short "SAdd") = SOME (0, TypeStamp "SAdd" 2)) ∧
+  (nsLookup env.c (Short "SMul") = SOME (0, TypeStamp "SMul" 2)) ∧
+  (nsLookup env.c (Short "SMinus") = SOME (0, TypeStamp "SMinus" 2)) ∧
+  (nsLookup env.c (Short "SEqv") = SOME (0, TypeStamp "SEqv" 2)) ∧
+  (nsLookup env.c (Short "CallCC") = SOME (0, TypeStamp "CallCC" 2))
+End
+
 Inductive cont_rel:
 [~Id:]
+  scheme_env env
+  ⇒
   cont_rel []
     (Closure env t (Var (Short t)))
 [~CondK:]
   cont_rel ks kv ∧
   nsLookup (env . v) (Short var) = SOME kv ∧
   (n', ct) = cps_transform n te ∧
-  (m', cf) = cps_transform m fe
+  (m', cf) = cps_transform m fe ∧
+  scheme_env env ∧
+  var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
   cont_rel ((se, CondK te fe) :: ks)
@@ -239,22 +279,6 @@ EVAL “case (SND $ evaluate_decs <|clock:=999;next_type_stamp:=0;next_exn_stamp
   | _ => (st, v)”
 *)
 
-Definition scheme_env_def:
-  scheme_env env
-  ⇔
-  (*not sure what to do with the state type variable,
-  it doesn't work without a concrete type*)
-  ∀ (st:num state) .
-  evaluate st env [Con (SOME (Short "SBool")) [
-    Con (SOME (Short "False")) []]]
-  = (st, Rval [Conv (SOME (TypeStamp "SBool" 3)) [
-    Conv (SOME (TypeStamp "False" 0)) []]]) ∧
-  evaluate st env [Con (SOME (Short "SBool")) [
-    Con (SOME (Short "True")) []]]
-  = (st, Rval [Conv (SOME (TypeStamp "SBool" 3)) [
-    Conv (SOME (TypeStamp "True" 0)) []]])
-End
-
 Theorem basis_scheme_env:
   ∃ st st' env .
     evaluate_decs st <|v:=nsEmpty;c:=nsEmpty|>
@@ -277,14 +301,16 @@ Theorem myproof:
   step  (store, k, env, e) = (store', k', env', e') ∧
   st.clock > 0 ∧
   cont_rel k kv ∧
+  e_ce_rel e var mle ∧
   nsLookup mlenv.v (Short var) = SOME kv ∧
   scheme_env mlenv
   ⇒
-  ∃ st' mlenv' var' kv' mle'.
-    evaluate st mlenv [e_or_v_to_exp e var]
+  ∃ st' mlenv' var' kv' mle' .
+    evaluate st mlenv [mle]
     =
-    evaluate st' mlenv' [e_or_v_to_exp e' var'] ∧
+    evaluate st' mlenv' [mle'] ∧
     cont_rel k' kv' ∧
+    e_ce_rel e' var' mle' ∧
     nsLookup mlenv'.v (Short var') = SOME kv'
 Proof
   Cases_on ‘e’
@@ -295,21 +321,45 @@ Proof
     >> Cases_on ‘∃ te fe . h1 = CondK te fe’
     >- (
       gvs[]
+      >> simp[step_def, return_def]
+      >> Cases_on ‘(∃p. v = Prim p) ∨ (∃n. v = SNum n) ∨ ∃b. v = SBool b’
+      (*Only covering cases supported by to_ml_vals,
+      but in theory should work for any vals*)
+      >- (
+        simp[Once e_ce_rel_cases, Once cont_rel_cases]
+        >> simp[oneline to_ml_vals_def]
+        >> every_case_tac
+        >> rpt strip_tac
+        >> gvs[]
+        >> simp[SimpLHS, evaluate_def, do_con_check_def,
+          build_conv_def, scheme_env_def, do_opapp_def]
+        >> qpat_assum ‘scheme_env mlenv’ $ simp o single o SRULE [scheme_env_def]
+        >> simp[SimpLHS, Ntimes evaluate_def 3, can_pmatch_all_def, pmatch_def]
+        >> qpat_assum ‘scheme_env env’ $ simp o single o SRULE [scheme_env_def]
+        >> simp[same_type_def, same_ctor_def, do_opapp_def,
+          evaluate_match_def, pmatch_def, pat_bindings_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> qexistsl [‘var'’, ‘kv'’]
+        >> simp[Once e_ce_rel_cases]
+        >> metis_tac[]
+      )
       >> cheat
     )
     >> cheat
   )
   >~ [‘Exp e’] >- (
     Cases_on ‘e’
-    >> simp[step_def, e_or_v_to_exp_def]
+    >> simp[step_def, Once e_ce_rel_cases]
     >~ [‘Cond c te fe’] >- (
-      rpt strip_tac
-      >> simp[cps_transform_def]
+      simp[cps_transform_def]
+      >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[nsLookup_def]
-      >> simp[Once cont_rel_cases]
+      >> qexists ‘"cont"’
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> gvs[scheme_env_def]
+      >> rpt strip_tac
       >> metis_tac[]
     )
     >> cheat

From 18ee71a2962536a53f15cf5e979bb4d220206abf Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Fri, 4 Apr 2025 17:37:40 +0100
Subject: [PATCH 067/100] prove base case for compiled program

---
 compiler/scheme/scheme_proofsScript.sml       | 29 ++++++++++++++-----
 compiler/scheme/scheme_to_cakeScript.sml      | 10 ++++++-
 .../translation/scheme_compilerProgScript.sml |  1 +
 3 files changed, 31 insertions(+), 9 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 7cbf334563..ab31c90c1e 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -271,6 +271,26 @@ Inductive cont_rel:
     ])
 End
 
+Theorem compile_in_rel:
+  ∀ p st env .
+    scheme_env env
+    ⇒
+    ∃ st' env' var mle k kv .
+      e_ce_rel (Exp p) var mle ∧
+      cont_rel k kv ∧
+      nsLookup env'.v (Short var) = SOME kv ∧
+      evaluate st env [compile_scheme_prog p] = evaluate st' env' [mle]
+Proof
+  simp[Once e_ce_rel_cases, compile_scheme_prog_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> simp[Ntimes evaluate_def 2, nsOptBind_def]
+  >> irule_at (Pos hd) EQ_REFL
+  >> irule_at Any EQ_REFL
+  >> simp[nsLookup_def, Once cont_rel_cases]
+  >> metis_tac[]
+QED
+
 (*
 EVAL “case (SND $ evaluate_decs <|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>
 <|v:=nsEmpty;c:=nsEmpty|> $ prim_types_program
@@ -286,14 +306,7 @@ Theorem basis_scheme_env:
     scheme_env env
 Proof
   qexists ‘<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>’
-  >> simp[evaluate_decs_def, prim_types_program_def, scheme_basis_def,
-  check_dup_ctors_def, build_tdefs_def, do_con_check_def,
-  nsAppend_def, build_constrs_def, alist_to_ns_def,
-  nsLookup_def, build_rec_env_def, extend_dec_env_def,
-  nsSing_def, nsEmpty_def, nsBind_def, pat_bindings_def,
-  evaluate_def, pmatch_def, combine_dec_result_def,
-  every_exp_def, one_con_check_def, cons_list_def,
-  scheme_env_def, build_conv_def]
+  >> EVAL_TAC >> simp[nsLookup_def]
 QED
 
 Theorem myproof:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 342075045d..de43f28461 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -187,6 +187,14 @@ Definition exp_with_cont_def:
   exp_with_cont k e = App Opapp [SND $ cps_transform 0 e; scheme_cont k]
 End
 
+Definition compile_scheme_prog_def:
+  compile_scheme_prog p = let
+    (n, cp) = cps_transform 0 p
+  in
+    Let (SOME $ "k") (Fun "t" $ Var (Short "t")) $
+      App Opapp [cp; Var (Short "k")]
+End
+
 Definition cake_print_def:
   cake_print e =
     (* val _ = print e; *)
@@ -350,7 +358,7 @@ End
 
 Definition codegen_def:
   codegen p = INR $ scheme_basis ++ [
-    Dlet unknown_loc (Pvar "res") $ exp_with_cont [] p;
+    Dlet unknown_loc (Pvar "res") $ compile_scheme_prog p;
     Dlet unknown_loc Pany $ Mat (Var (Short "res")) [
       (Pcon (SOME $ Short "SNum") [Pvar "n"],
         App Opapp [Var (Short "print_int"); Var (Short "n")]);
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 61345d9f8a..c65126d4be 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -43,6 +43,7 @@ val r = translate letinit_ml_def;
 val r = translate cps_transform_def;
 val r = translate scheme_cont_def;
 val r = translate exp_with_cont_def;
+val r = translate compile_scheme_prog_def;
 val r = translate scheme_basis_def;
 val r = translate codegen_def;
 

From bf2ac03aaec0c04515857222efc2c006e84f2178 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sun, 6 Apr 2025 03:22:39 +0100
Subject: [PATCH 068/100] some more proving, bit of env theorem mess

---
 compiler/scheme/scheme_astScript.sml       |   1 -
 compiler/scheme/scheme_proofsScript.sml    | 817 ++++++++++++++++-----
 compiler/scheme/scheme_semanticsScript.sml |  24 +-
 compiler/scheme/scheme_to_cakeScript.sml   |  48 +-
 4 files changed, 666 insertions(+), 224 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 1c0e3fa895..09c988904e 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -24,7 +24,6 @@ Datatype:
       | Cond exp exp exp
       | Ident mlstring
       | Lambda (mlstring list) (mlstring option) exp
-      | Exception mlstring
       | Begin exp (exp list)
       | Set mlstring exp
       | Letrec ((mlstring # exp) list) exp
diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index ab31c90c1e..ba8d97c97f 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -2,6 +2,7 @@
   Proofs for Scheme to CakeML compilation
 *)
 open preamble;
+open computeLib;
 open scheme_astTheory;
 open scheme_semanticsTheory;
 open scheme_to_cakeTheory;
@@ -12,179 +13,439 @@ open evaluatePropsTheory;
 open semanticPrimitivesTheory;
 open namespaceTheory;
 open primTypesTheory;
+open namespacePropsTheory;
 
 val _ = new_theory "scheme_proofs";
 
-(*
-Definition subset1_def:
-  (subset1 (Apply fn args) ⇔ subset1 fn ∧ EVERY subset1 args) ∧
-  (subset1 (Cond c t f) ⇔ subset1 c ∧ subset1 t ∧ subset1 f) ∧
-  (subset1 (Exception _) ⇔ T) ∧
-  (subset1 (Val v) ⇔ case v of
-  | Prim _ => T
-  | SNum _ => T
-  | SBool _ => T
-  | _ => F) ∧
-  (subset1 _ ⇔ F)
-Termination
-  WF_REL_TAC ‘measure exp_size’
+Definition scheme_basis1_def:
+  scheme_basis1 = Dtype unknown_loc [
+    ([], "sprim", [
+      ("SAdd", []);
+      ("SMul", []);
+      ("SMinus", []);
+      ("SEqv", []);
+      ("CallCC", [])
+    ]);
+    ([], "sval", [
+      ("SNum", [Atapp [] (Short "int")]);
+      ("SBool", [Atapp [] (Short "bool")]);
+      ("Prim", [Atapp [] (Short "sprim")]);
+      ("SList", [Atapp [Atapp [] (Short "sval")] (Short "list")]);
+      ("Wrong", [Atapp [] (Short "string")]);
+      ("Ex", [Atapp [] (Short "string")]);
+      ("Proc", [Atfun
+                 (Atfun
+                   (Atapp [] (Short "sval"))
+                   (Atapp [] (Short "sval")))
+                 (Atfun
+                   (Atapp [Atapp [] (Short "sval")] (Short "list"))
+                   (Atapp [] (Short "sval")))]);
+      ("Throw", [Atfun
+                  (Atapp [] (Short "sval"))
+                  (Atapp [] (Short "sval"))]);
+    ])
+  ]
 End
-*)
 
-(*
-Inductive subset1:
-[~Prim:]
-  vsubset1 (Prim p)
-[~SNum:]
-  vsubset1 (SNum n)
-[~SBool:]
-  vsubset1 (SBool b)
-[~Apply:]
-  subset1 fn ∧ EVERY subset1 args ⇒ subset1 (Apply fn args)
-[~Cond:]
-  subset1 c ∧ subset1 t ∧ subset1 f ⇒ subset1 (Cond c t f)
-[~Val:]
-  vsubset1 v ⇒ subset1 (Val v)
-[~CondK:]
-  subset1 t ∧ subset1 f ⇒ ksubset1 (CondK t f)
-[~ApplyKNONE:]
-  EVERY subset1 args ⇒ ksubset1 (ApplyK NONE args)
-[~ApplyKSOME:]
-  vsubset1 fv ∧ EVERY vsubset1 vs ∧ EVERY subset1 args
-    ⇒ ksubset1 (ApplyK (SOME (fv, vs)) args)
-[~Cont:]
-  EVERY ksubset1 ks ⇒ kssubset1 ks
-End
+Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
+  scheme_env1 = case evaluate_decs
+      (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+      <|v:=nsEmpty;c:=nsEmpty|>
+      (prim_types_program ++ [scheme_basis1]) of
+    | (st', Rval env) => env
+    | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env1_rw[simp] = LIST_CONJ $ map EVAL [
+  “nsLookup scheme_env1.c (Short "SNum")”,
+  “nsLookup scheme_env1.c (Short "SBool")”,
+  “nsLookup scheme_env1.c (Short "True")”,
+  “nsLookup scheme_env1.c (Short "False")”,
+  “nsLookup scheme_env1.c (Short "Prim")”,
+  “nsLookup scheme_env1.c (Short "SAdd")”,
+  “nsLookup scheme_env1.c (Short "SMul")”,
+  “nsLookup scheme_env1.c (Short "SMinus")”,
+  “nsLookup scheme_env1.c (Short "SEqv")”,
+  “nsLookup scheme_env1.c (Short "CallCC")”,
+  “nsLookup scheme_env1.c (Short "[]")”,
+  “nsLookup scheme_env1.c (Short "::")”,
+  “nsLookup scheme_env1.c (Short "Ex")”,
+  “nsLookup scheme_env1.c (Short "Proc")”,
+  “nsLookup scheme_env1.c (Short "Throw")”
+];
 
+Definition scheme_basis2_def:
+  scheme_basis2 = Dletrec unknown_loc [
+    ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "v")]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+            App Opapp [
+              App Opapp [
+                App Opapp [Var (Short "sadd"); Var (Short "k")];
+                App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
+              ];
+              Var (Short "xs'")
+            ]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+        ])
+    ])
+  ]
+End
 
-Theorem subset1_rewrite[simp] = LIST_CONJ[
-  “vsubset1 (Prim p)” |> SCONV [Once subset1_cases],
-  “vsubset1 (SNum n)” |> SCONV [Once subset1_cases],
-  “vsubset1 (SBool b)” |> SCONV [Once subset1_cases],
-  “vsubset1 (Wrong w)” |> SCONV [Once subset1_cases],
-  “vsubset1 (SList l)” |> SCONV [Once subset1_cases],
-  “vsubset1 (Proc r xs xp e)” |> SCONV [Once subset1_cases],
-  “vsubset1 (Throw k)” |> SCONV [Once subset1_cases],
-
-  “subset1 (Apply fn args)” |> SCONV [Once subset1_cases],
-  “subset1 (Cond c t f)” |> SCONV [Once subset1_cases],
-  “subset1 (Val v)” |> SCONV [Once subset1_cases],
-  “subset1 (Print m)” |> SCONV [Once subset1_cases],
-  “subset1 (Exception m)” |> SCONV [Once subset1_cases],
-  “subset1 (Ident x)” |> SCONV [Once subset1_cases],
-  “subset1 (Lambda xs xp e)” |> SCONV [Once subset1_cases],
-  “subset1 (Begin e es)” |> SCONV [Once subset1_cases],
-  “subset1 (Set x e)” |> SCONV [Once subset1_cases],
-  “subset1 (Letrec bs e)” |> SCONV [Once subset1_cases],
-
-  “ksubset1 (CondK t f)” |> SCONV [Once subset1_cases],
-  “ksubset1 (ApplyK ps args)” |> SCONV [Once subset1_cases],
-  “ksubset1 (SetK x)” |> SCONV [Once subset1_cases],
-  “ksubset1 (BeginK es)” |> SCONV [Once subset1_cases],
-  “kssubset1 ks” |> SCONV [Once subset1_cases]
+Theorem scheme_env2_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env1”] $ zDefine ‘
+    scheme_env2 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env1
+        [scheme_basis2] of
+      | (st', Rval env) => extend_dec_env env scheme_env1
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env2_rw[simp] = LIST_CONJ $ map
+  (SRULE [GSYM scheme_env1_def] o EVAL) [
+  “nsLookup scheme_env2.c (Short "SNum")”,
+  “nsLookup scheme_env2.c (Short "SBool")”,
+  “nsLookup scheme_env2.c (Short "True")”,
+  “nsLookup scheme_env2.c (Short "False")”,
+  “nsLookup scheme_env2.c (Short "Prim")”,
+  “nsLookup scheme_env2.c (Short "SAdd")”,
+  “nsLookup scheme_env2.c (Short "SMul")”,
+  “nsLookup scheme_env2.c (Short "SMinus")”,
+  “nsLookup scheme_env2.c (Short "SEqv")”,
+  “nsLookup scheme_env2.c (Short "CallCC")”,
+  “nsLookup scheme_env2.c (Short "[]")”,
+  “nsLookup scheme_env2.c (Short "::")”,
+  “nsLookup scheme_env2.c (Short "Ex")”,
+  “nsLookup scheme_env2.c (Short "Proc")”,
+  “nsLookup scheme_env2.c (Short "Throw")”,
+
+  “nsLookup scheme_env2.v (Short "sadd")”
 ];
 
-Theorem eval_expand = LIST_CONJ[
-  myEnv_def, myC_def, do_opapp_def, dec_clock_def,
-  nsLookup_def, nsBind_def, do_con_check_def, build_conv_def
+Definition scheme_basis3_def:
+  scheme_basis3 = Dletrec unknown_loc [
+    ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "v")]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+            App Opapp [
+              App Opapp [
+                App Opapp [Var (Short "smul"); Var (Short "k")];
+                App (Opn Times) [Var (Short "n"); Var (Short "xn")]
+              ];
+              Var (Short "xs'")
+            ]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+        ])
+    ])
+  ]
+End
+
+Theorem scheme_env3_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env2”] $ zDefine ‘
+    scheme_env3 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env2
+        [scheme_basis3] of
+      | (st', Rval env) => extend_dec_env env scheme_env2
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env3_rw[simp] = LIST_CONJ $ map
+  (SRULE [
+    GSYM $ EVAL “scheme_env1”,
+    GSYM $ EVAL “scheme_env2”
+  ] o EVAL) [
+  “nsLookup scheme_env3.c (Short "SNum")”,
+  “nsLookup scheme_env3.c (Short "SBool")”,
+  “nsLookup scheme_env3.c (Short "True")”,
+  “nsLookup scheme_env3.c (Short "False")”,
+  “nsLookup scheme_env3.c (Short "Prim")”,
+  “nsLookup scheme_env3.c (Short "SAdd")”,
+  “nsLookup scheme_env3.c (Short "SMul")”,
+  “nsLookup scheme_env3.c (Short "SMinus")”,
+  “nsLookup scheme_env3.c (Short "SEqv")”,
+  “nsLookup scheme_env3.c (Short "CallCC")”,
+  “nsLookup scheme_env3.c (Short "[]")”,
+  “nsLookup scheme_env3.c (Short "::")”,
+  “nsLookup scheme_env3.c (Short "Ex")”,
+  “nsLookup scheme_env3.c (Short "Proc")”,
+  “nsLookup scheme_env3.c (Short "Throw")”,
+
+  “nsLookup scheme_env3.v (Short "sadd")”,
+  “nsLookup scheme_env3.v (Short "smul")”
 ];
 
-Inductive ml_subset:
-[~Fun:]
-  ml_subset e ⇒ ml_subset (Fun t e)
-[~App:]
-  EVERY ml_subset es ⇒ ml_subset (App op es)
-[~Var:]
-  ml_subset (Var (Short t))
-[~Con:]
-  EVERY ml_subset es ⇒ ml_subset (Con x es)
-[~Lit:]
-  ml_subset (Lit x')
-[~Let:]
-  ml_subset e1 ∧ ml_subset e2 ⇒ ml_subset (Let p e1 e2)
-[~Mat:]
-  ml_subset e ∧ EVERY ml_subset (MAP SND bs) ⇒ ml_subset (Mat e bs)
+Definition scheme_basis4_def:
+  scheme_basis4 = Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "n"],
+            App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+              Fun "t" $ Mat (Var (Short "t")) [
+                (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                  Let (SOME "v") (Con (SOME $ Short "SNum") [
+                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")]);
+                (Pany,
+                  App Opapp [Var (Short "k"); Var (Short "t")])
+              ]];
+              Lit $ IntLit 0]; Var (Short "xs'")]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
+        ])
+    ]
 End
 
-Definition rec_scheme_def:
-  rec_scheme (Cond c t f) = rec_scheme c + rec_scheme t + rec_scheme f ∧
-  rec_scheme (Apply fn es) = rec_scheme fn + SUM (MAP rec_scheme es) ∧
-  rec_scheme (Val v) = 0
-Termination
-  WF_REL_TAC ‘measure exp_size’
+Theorem scheme_env4_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env3”] $ zDefine ‘
+    scheme_env4 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env3
+        [scheme_basis4] of
+      | (st', Rval env) => extend_dec_env env scheme_env3
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env4_rw[simp] = LIST_CONJ $ map
+  (SRULE [
+    GSYM $ EVAL “scheme_env1”,
+    GSYM $ EVAL “scheme_env2”,
+    GSYM $ EVAL “scheme_env3”
+  ] o EVAL) [
+  “nsLookup scheme_env4.c (Short "SNum")”,
+  “nsLookup scheme_env4.c (Short "SBool")”,
+  “nsLookup scheme_env4.c (Short "True")”,
+  “nsLookup scheme_env4.c (Short "False")”,
+  “nsLookup scheme_env4.c (Short "Prim")”,
+  “nsLookup scheme_env4.c (Short "SAdd")”,
+  “nsLookup scheme_env4.c (Short "SMul")”,
+  “nsLookup scheme_env4.c (Short "SMinus")”,
+  “nsLookup scheme_env4.c (Short "SEqv")”,
+  “nsLookup scheme_env4.c (Short "CallCC")”,
+  “nsLookup scheme_env4.c (Short "[]")”,
+  “nsLookup scheme_env4.c (Short "::")”,
+  “nsLookup scheme_env4.c (Short "Ex")”,
+  “nsLookup scheme_env4.c (Short "Proc")”,
+  “nsLookup scheme_env4.c (Short "Throw")”,
+
+  “nsLookup scheme_env4.v (Short "sadd")”,
+  “nsLookup scheme_env4.v (Short "smul")”,
+  “nsLookup scheme_env4.v (Short "sminus")”
+];
+
+Definition scheme_basis5_def:
+  scheme_basis5 = Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+          (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
+            Mat (Var (Short "xs''")) [
+              (Pcon (SOME $ Short "[]") [],
+                If (App Equality [Var (Short "x1"); Var (Short "x2")])
+                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")])
+                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")]));
+              (Pany,
+                Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+            ])
+        ])
+    ]
 End
 
-Theorem ml_subset_rewrite[simp] = LIST_CONJ [
-  “ml_subset (Fun t e)” |> SCONV [Once ml_subset_cases],
-  “ml_subset (App op es)” |> SCONV [Once ml_subset_cases],
-  “ml_subset (Var (Short t))” |> SCONV [Once ml_subset_cases],
-  “ml_subset (Con x es)” |> SCONV [Once ml_subset_cases],
-  “ml_subset (Lit x')” |> SCONV [Once ml_subset_cases],
-  “ml_subset (Let p e1 e2)” |> SCONV [Once ml_subset_cases],
-  “ml_subset (Mat e bs)” |> SCONV [Once ml_subset_cases]
+Theorem scheme_env5_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env4”] $ zDefine ‘
+    scheme_env5 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env4
+        [scheme_basis5] of
+      | (st', Rval env) => extend_dec_env env scheme_env4
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env5_rw[simp] = LIST_CONJ $ map
+  (SRULE [
+    GSYM $ EVAL “scheme_env1”,
+    GSYM $ EVAL “scheme_env2”,
+    GSYM $ EVAL “scheme_env3”,
+    GSYM $ EVAL “scheme_env4”
+  ] o EVAL) [
+  “nsLookup scheme_env5.c (Short "SNum")”,
+  “nsLookup scheme_env5.c (Short "SBool")”,
+  “nsLookup scheme_env5.c (Short "True")”,
+  “nsLookup scheme_env5.c (Short "False")”,
+  “nsLookup scheme_env5.c (Short "Prim")”,
+  “nsLookup scheme_env5.c (Short "SAdd")”,
+  “nsLookup scheme_env5.c (Short "SMul")”,
+  “nsLookup scheme_env5.c (Short "SMinus")”,
+  “nsLookup scheme_env5.c (Short "SEqv")”,
+  “nsLookup scheme_env5.c (Short "CallCC")”,
+  “nsLookup scheme_env5.c (Short "[]")”,
+  “nsLookup scheme_env5.c (Short "::")”,
+  “nsLookup scheme_env5.c (Short "Ex")”,
+  “nsLookup scheme_env5.c (Short "Proc")”,
+  “nsLookup scheme_env5.c (Short "Throw")”,
+
+  “nsLookup scheme_env5.v (Short "sadd")”,
+  “nsLookup scheme_env5.v (Short "smul")”,
+  “nsLookup scheme_env5.v (Short "sminus")”,
+  “nsLookup scheme_env5.v (Short "seqv")”
 ];
 
-Theorem small_ml:
-  ∀ e n m ce . cps_transform n e = (m, ce) ∧ subset1 e
-    ⇒ ml_subset ce
-Proof
-  ho_match_mp_tac rec_scheme_ind
-  >> simp[cps_transform_def] >> rpt strip_tac
-  >~ [‘vsubset1 v’] >- (
-    Cases_on ‘v’ >> gvs[to_ml_vals_def]
-    >> Cases_on ‘p’ >> simp[]
-  )
-  >> rpt strip_tac >> rpt (pairarg_tac >> gvs[step_def])
-  >> rpt $ last_x_assum dxrule >> simp[] >> disch_then kall_tac
-  >> cheat
-QED
+Definition scheme_basis6_def:
+  scheme_basis6 = Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            App Opapp [Var (Short "k"); Var (Short "x")]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        ])
+    ]
+End
 
-Theorem e_vals_subset1:
-  ∀ n e . subset1 e ⇒  ∃ st ck v .
-    evaluate <|clock := ck|> myEnv [SND $ cps_transform n e] = (st, Rval v)
-Proof
-  strip_tac >> Cases >> simp[]
-  >~ [‘Val v’] >- (
-    strip_tac >> simp[cps_transform_def, to_ml_vals_def, evaluate_def]
-  )
-  >> simp[cps_transform_def]
-  >> rpt (pairarg_tac >> gvs[step_def])
-  >> simp[evaluate_def]
-QED
+Theorem scheme_env6_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env5”] $ zDefine ‘
+    scheme_env6 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env5
+        [scheme_basis6] of
+      | (st', Rval env) => extend_dec_env env scheme_env5
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env6_rw[simp] = LIST_CONJ $ map
+  (SRULE [
+    GSYM $ EVAL “scheme_env1”,
+    GSYM $ EVAL “scheme_env2”,
+    GSYM $ EVAL “scheme_env3”,
+    GSYM $ EVAL “scheme_env4”,
+    GSYM $ EVAL “scheme_env5”
+  ] o EVAL) [
+  “nsLookup scheme_env6.c (Short "SNum")”,
+  “nsLookup scheme_env6.c (Short "SBool")”,
+  “nsLookup scheme_env6.c (Short "True")”,
+  “nsLookup scheme_env6.c (Short "False")”,
+  “nsLookup scheme_env6.c (Short "Prim")”,
+  “nsLookup scheme_env6.c (Short "SAdd")”,
+  “nsLookup scheme_env6.c (Short "SMul")”,
+  “nsLookup scheme_env6.c (Short "SMinus")”,
+  “nsLookup scheme_env6.c (Short "SEqv")”,
+  “nsLookup scheme_env6.c (Short "CallCC")”,
+  “nsLookup scheme_env6.c (Short "[]")”,
+  “nsLookup scheme_env6.c (Short "::")”,
+  “nsLookup scheme_env6.c (Short "Ex")”,
+  “nsLookup scheme_env6.c (Short "Proc")”,
+  “nsLookup scheme_env6.c (Short "Throw")”,
+
+  “nsLookup scheme_env6.v (Short "sadd")”,
+  “nsLookup scheme_env6.v (Short "smul")”,
+  “nsLookup scheme_env6.v (Short "sminus")”,
+  “nsLookup scheme_env6.v (Short "seqv")”,
+  “nsLookup scheme_env6.v (Short "throw")”
+];
 
-Theorem k_vals_subset1:
-  ∀ ks ck . kssubset1 ks ⇒ ∃ v .
-    evaluate <|clock := ck|> myEnv [scheme_cont ks]
-      = (<|clock := ck|> : 'ffi state, Rval [v])
-Proof
-  Cases >> simp[] >- simp[scheme_cont_def, evaluate_def]
-  >> Cases_on ‘h’ >> simp[] >> rpt strip_tac >> simp[]
-  >> simp[scheme_cont_def, cps_transform_def]
-  >> rpt (pairarg_tac >> gvs[step_def])
-  >> simp[evaluate_def]
-QED
+Definition scheme_basis7_def:
+  scheme_basis7 = Dletrec unknown_loc [
+    ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            App Opapp [
+              App Opapp [
+                App Opapp [Var (Short "app");Var (Short "k")];
+                Var (Short "x")];
+              cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
+        ])
+    ]);
+    ("app", "k", Fun "fn" $ Mat (Var (Short "fn")) [
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
+        App Opapp [App Opapp [Var (Short "sadd"); Var (Short "k")]; Lit $ IntLit 0]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
+        App Opapp [App Opapp [Var (Short "smul"); Var (Short "k")]; Lit $ IntLit 1]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
+        App Opapp [Var (Short "sminus"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
+        App Opapp [Var (Short "seqv"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
+        App Opapp [Var (Short "callcc"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Proc") [Pvar "e"],
+        App Opapp [Var (Short "e"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Throw") [Pvar "k'"],
+        App Opapp [Var (Short "throw"); Var (Short "k'")]);
+      (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
+    ])
+  ]
+End
 
-Theorem cps_equiv:
-  ∀ e n n' m m' ce ce' ck v v' c c' k k' t t'. subset1 e
-    ∧ nsSub (λ id . $=) myEnv.c c ∧ nsSub (λ id . $=) myEnv.c c'
-    ∧ nsSub (λ id . $=) myEnv.v v ∧ nsSub (λ id . $=) myEnv.v v'
-    ∧ cps_transform n e = (n',ce) ∧ cps_transform m e = (m', ce')
-    ∧ evaluate <|clock := ck+1|> <|v:=v;c:=c|> [App Opapp [ce;Fun t k]]
-      = evaluate <|clock := ck+1|> <|v:=v';c:=c'|> [App Opapp [ce';Fun t' k']]
-    ⇒ ∀ vl . evaluate <|clock := ck|> <|v:=nsBind t vl v;c:=c|> [k]
-      = evaluate <|clock := ck|> <|v:=nsBind t vl v';c:=c'|> [k']
-Proof
-  ho_match_mp_tac rec_scheme_ind
-  >> simp[cps_transform_def] >> rpt strip_tac
-  >~ [‘vsubset1 v’] >- (
-    Cases_on ‘v’ >> gvs[evaluate_def, to_ml_vals_def, do_opapp_def]
-    >> gs[myEnv_def, nsSub_def]
-    >> Cases_on ‘p’ >> simp[]
-  )
-  Induct_on ‘e’
-  rpt strip_tac
-QED
-*)
+Theorem scheme_env7_def[allow_rebind, compute] = SRULE [] $
+  RESTR_EVAL_RULE [“scheme_env6”] $ zDefine ‘
+    scheme_env7 = case evaluate_decs
+        (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
+        scheme_env6
+        [scheme_basis7] of
+      | (st', Rval env) => extend_dec_env env scheme_env6
+      | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env7_rw[simp] = LIST_CONJ $ map
+  (SRULE [
+    GSYM $ EVAL “scheme_env1”,
+    GSYM $ EVAL “scheme_env2”,
+    GSYM $ EVAL “scheme_env3”,
+    GSYM $ EVAL “scheme_env4”,
+    GSYM $ EVAL “scheme_env5”,
+    GSYM $ EVAL “scheme_env6”
+  ] o EVAL) [
+  “nsLookup scheme_env7.c (Short "SNum")”,
+  “nsLookup scheme_env7.c (Short "SBool")”,
+  “nsLookup scheme_env7.c (Short "True")”,
+  “nsLookup scheme_env7.c (Short "False")”,
+  “nsLookup scheme_env7.c (Short "Prim")”,
+  “nsLookup scheme_env7.c (Short "SAdd")”,
+  “nsLookup scheme_env7.c (Short "SMul")”,
+  “nsLookup scheme_env7.c (Short "SMinus")”,
+  “nsLookup scheme_env7.c (Short "SEqv")”,
+  “nsLookup scheme_env7.c (Short "CallCC")”,
+  “nsLookup scheme_env7.c (Short "[]")”,
+  “nsLookup scheme_env7.c (Short "::")”,
+  “nsLookup scheme_env7.c (Short "Ex")”,
+  “nsLookup scheme_env7.c (Short "Proc")”,
+  “nsLookup scheme_env7.c (Short "Throw")”,
+
+  “nsLookup scheme_env7.v (Short "sadd")”,
+  “nsLookup scheme_env7.v (Short "smul")”,
+  “nsLookup scheme_env7.v (Short "sminus")”,
+  “nsLookup scheme_env7.v (Short "seqv")”,
+  “nsLookup scheme_env7.v (Short "throw")”,
+  “nsLookup scheme_env7.v (Short "callcc")”,
+  “nsLookup scheme_env7.v (Short "app")”
+];
 
 (*
 Example lambda calculus code of conditional expression,
@@ -204,36 +465,62 @@ before and after step in CEK machine
         | _ => (\k2 -> k2 (SNum 2)) (\t -> t)))
 *)
 
-Definition e_or_v_to_exp_def:
-  e_or_v_to_exp (Val v) var = App Opapp [Var (Short var); to_ml_vals v] ∧
-  e_or_v_to_exp (Exp e) var = (let
-    (n, ce) = cps_transform 0 e
-  in
-    App Opapp [ce; Var (Short var)])
+Definition ml_v_vals_def[nocompute]:
+  ml_v_vals v = case evaluate (<|clock:=0|> :num state)
+      scheme_env7 [to_ml_vals v] of
+    | (st, Rval [mlv]) => mlv
+    | _ => ARB
 End
 
+fun mydisch x = DISCH (hd $ hyp x) x;
+
+Theorem ml_v_vals_def[allow_rebind, compute] = SRULE [] $ mydisch $
+  LIST_CONJ $ map
+    (EVAL_RULE o SIMP_RULE pure_ss [SimpRHS, ml_v_vals_def]) [
+    REFL “ml_v_vals (Prim SAdd)”,
+    REFL “ml_v_vals (Prim SMul)”,
+    REFL “ml_v_vals (Prim SMinus)”,
+    REFL “ml_v_vals (Prim SEqv)”,
+    REFL “ml_v_vals (Prim CallCC)”,
+    ASSUME “∀ n . ml_v_vals (SNum n) = ml_v_vals (SNum n)”,
+    REFL “ml_v_vals (SBool T)”,
+    REFL “ml_v_vals (SBool F)”
+  ];
+
 Inductive e_ce_rel:
 [~Val:]
-  mlv = to_ml_vals v
+  nsLookup env.v (Short valv) = SOME (ml_v_vals v) ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  valv ≠ var
   ⇒
-  e_ce_rel (Val v) var $ App Opapp [Var (Short var); mlv]
+  e_ce_rel (Val v) var env kv $ App Opapp [Var (Short var); Var (Short valv)]
 [~Exp:]
-  (m, ce) = cps_transform n e
+  (m, ce) = cps_transform n e ∧
+  nsLookup env.v (Short var) = SOME kv
   ⇒
-  e_ce_rel (Exp e) var $ App Opapp [ce; Var (Short var)]
+  e_ce_rel (Exp e) var env kv $ App Opapp [ce; Var (Short var)]
+[~Exception:]
+  e_ce_rel (Exception s) var env kv $
+    Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]
 End
 
-Definition scheme_env'_def:
+Theorem scheme_env'_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
   scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ scheme_basis) of
     | (st', Rval env) => env
     | _ => <|v:=nsEmpty;c:=nsEmpty|>
-End
+’;
 
-Theorem scheme_env'_def[allow_rebind] = EVAL “scheme_env'”;
+Definition cconses_def[simp]:
+  cconses = ["SNum"; "SBool"; "True"; "False";
+    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
+    "[]"]
+End
 
-EVAL “nsLookup scheme_env'.c (Short "SMul")”;
+Definition vconses_def[simp]:
+  vconses = ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
+End
 
-Definition scheme_env_def:
+(*Definition scheme_env_def:
   scheme_env env
   ⇔
   (nsLookup env.c (Short "SNum") = SOME (1, TypeStamp "SNum" 3)) ∧
@@ -245,18 +532,42 @@ Definition scheme_env_def:
   (nsLookup env.c (Short "SMul") = SOME (0, TypeStamp "SMul" 2)) ∧
   (nsLookup env.c (Short "SMinus") = SOME (0, TypeStamp "SMinus" 2)) ∧
   (nsLookup env.c (Short "SEqv") = SOME (0, TypeStamp "SEqv" 2)) ∧
-  (nsLookup env.c (Short "CallCC") = SOME (0, TypeStamp "CallCC" 2))
-End
+  (nsLookup env.c (Short "CallCC") = SOME (0, TypeStamp "CallCC" 2)) ∧
+
+  (nsLookup env.c (Short "[]") = SOME (0, TypeStamp "[]" 1))
+  (nsLookup env.c (Short "::") = SOME (0, TypeStamp "::" 1))
+End*)
+
+(*Theorem scheme_env_def[compute] = EVAL_RULE $ zDefine ‘
+  scheme_env env
+  ⇔
+  EVERY (λ x . nsLookup env.c x = nsLookup scheme_env'.c x) $
+    MAP Short cconses ∧
+  EVERY (λ x . nsLookup env.v x = nsLookup scheme_env'.v x) $
+    MAP Short vconses
+’;*)
+
+Theorem scheme_env_def[allow_rebind, compute] = SRULE [] $ zDefine ‘
+  scheme_env env
+  ⇔
+  EVERY (λ x . nsLookup env.c x = nsLookup scheme_env7.c x) $
+    MAP Short ["SNum"; "SBool"; "True"; "False";
+    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
+    "[]"; "::"; "Ex"; "Throw"] ∧
+  EVERY (λ x . nsLookup env.v x = nsLookup scheme_env7.v x) $
+    MAP Short ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
+’
 
 Inductive cont_rel:
 [~Id:]
-  scheme_env env
+  scheme_env env ∧
+  ¬ MEM t vconses
   ⇒
   cont_rel []
     (Closure env t (Var (Short t)))
 [~CondK:]
   cont_rel ks kv ∧
-  nsLookup (env . v) (Short var) = SOME kv ∧
+  nsLookup env.v (Short var) = SOME kv ∧
   (n', ct) = cps_transform n te ∧
   (m', cf) = cps_transform m fe ∧
   scheme_env env ∧
@@ -269,6 +580,18 @@ Inductive cont_rel:
         App Opapp [cf; Var (Short var)]);
       (Pany, App Opapp [ct;  Var (Short var)])
     ])
+[~ApplyK_NONE:]
+  cont_rel ks kv ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  (m, ce) = cps_transform_app n (Var (Short t)) [] es (Var (Short var)) ∧
+  scheme_env env ∧
+  ¬ MEM var vconses ∧
+  ¬ MEM t vconses ∧
+  var ≠ t
+  ⇒
+  (*Likely needs condition on se i.e. Scheme env*)
+  cont_rel ((se, ApplyK NONE es) :: ks)
+    (Closure env t $ ce)
 End
 
 Theorem compile_in_rel:
@@ -276,9 +599,8 @@ Theorem compile_in_rel:
     scheme_env env
     ⇒
     ∃ st' env' var mle k kv .
-      e_ce_rel (Exp p) var mle ∧
+      e_ce_rel (Exp p) var env' kv mle ∧
       cont_rel k kv ∧
-      nsLookup env'.v (Short var) = SOME kv ∧
       evaluate st env [compile_scheme_prog p] = evaluate st' env' [mle]
 Proof
   simp[Once e_ce_rel_cases, compile_scheme_prog_def]
@@ -300,13 +622,9 @@ EVAL “case (SND $ evaluate_decs <|clock:=999;next_type_stamp:=0;next_exn_stamp
 *)
 
 Theorem basis_scheme_env:
-  ∃ st st' env .
-    evaluate_decs st <|v:=nsEmpty;c:=nsEmpty|>
-      (prim_types_program ++ scheme_basis) = (st', Rval env) ∧
-    scheme_env env
+    scheme_env scheme_env'
 Proof
-  qexists ‘<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>’
-  >> EVAL_TAC >> simp[nsLookup_def]
+  EVAL_TAC
 QED
 
 Theorem myproof:
@@ -314,8 +632,7 @@ Theorem myproof:
   step  (store, k, env, e) = (store', k', env', e') ∧
   st.clock > 0 ∧
   cont_rel k kv ∧
-  e_ce_rel e var mle ∧
-  nsLookup mlenv.v (Short var) = SOME kv ∧
+  e_ce_rel e var mlenv kv mle ∧
   scheme_env mlenv
   ⇒
   ∃ st' mlenv' var' kv' mle' .
@@ -323,56 +640,160 @@ Theorem myproof:
     =
     evaluate st' mlenv' [mle'] ∧
     cont_rel k' kv' ∧
-    e_ce_rel e' var' mle' ∧
-    nsLookup mlenv'.v (Short var') = SOME kv'
+    e_ce_rel e' var' mlenv' kv' mle'
 Proof
   Cases_on ‘e’
   >~ [‘Val v’] >- (
     Cases_on ‘k’
     >- (simp[step_def, return_def] >> metis_tac[])
     >> PairCases_on ‘h’
-    >> Cases_on ‘∃ te fe . h1 = CondK te fe’
-    >- (
+    >> Cases_on ‘∃ te fe . h1 = CondK te fe’ >- (
       gvs[]
       >> simp[step_def, return_def]
-      >> Cases_on ‘(∃p. v = Prim p) ∨ (∃n. v = SNum n) ∨ ∃b. v = SBool b’
+      >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
+        v = Prim SEqv ∨ v = Prim CallCC ∨
+        (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’
       (*Only covering cases supported by to_ml_vals,
       but in theory should work for any vals*)
       >- (
         simp[Once e_ce_rel_cases, Once cont_rel_cases]
-        >> simp[oneline to_ml_vals_def]
+        >> simp[oneline ml_v_vals_def]
         >> every_case_tac
-        >> rpt strip_tac
         >> gvs[]
-        >> simp[SimpLHS, evaluate_def, do_con_check_def,
-          build_conv_def, scheme_env_def, do_opapp_def]
-        >> qpat_assum ‘scheme_env mlenv’ $ simp o single o SRULE [scheme_env_def]
-        >> simp[SimpLHS, Ntimes evaluate_def 3, can_pmatch_all_def, pmatch_def]
-        >> qpat_assum ‘scheme_env env’ $ simp o single o SRULE [scheme_env_def]
-        >> simp[same_type_def, same_ctor_def, do_opapp_def,
-          evaluate_match_def, pmatch_def, pat_bindings_def]
+        >> rpt strip_tac
+        >> simp[SimpLHS, Ntimes evaluate_def 6, do_con_check_def,
+          build_conv_def, scheme_env_def, do_opapp_def,
+        can_pmatch_all_def, pmatch_def]
+        >> qpat_assum ‘scheme_env env’ $ simp o curry ((::) o swap) [
+            same_type_def, same_ctor_def, do_opapp_def,
+            evaluate_match_def, pmatch_def, pat_bindings_def]
+          o SRULE [scheme_env_def]
         >> irule_at (Pos hd) EQ_REFL
-        >> qexistsl [‘var'’, ‘kv'’]
         >> simp[Once e_ce_rel_cases]
+        >> irule_at Any EQ_REFL
+        >> simp[nsLookup_def]
         >> metis_tac[]
       )
       >> cheat
     )
+    >> Cases_on ‘h1 = ApplyK NONE []’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases, Once cont_rel_cases]
+      >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
+        v = Prim SEqv ∨ v = Prim CallCC ∨
+        (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’
+      >- (
+        simp[oneline ml_v_vals_def]
+        >> rpt strip_tac
+        >> Cases_on ‘st.clock > 6’ >- (
+          every_case_tac
+          >> gvs[application_def, sadd_def, smul_def, sminus_def,
+            seqv_def, cps_transform_def, cons_list_def]
+          >> simp[SimpLHS, evaluate_def, do_con_check_def,
+            build_conv_def, do_opapp_def]
+          >> qpat_assum ‘scheme_env env’ $ simp o single
+            o SRULE [scheme_env_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 3, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >~ [‘Litv (IntLit i)’] >- (
+            simp[Once evaluate_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[Once e_ce_rel_cases]
+            >> metis_tac[]
+          )
+          >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+            Conv (Some (TypeStamp "True" _)) []
+          ])’] >- (
+            simp[Once evaluate_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[Once e_ce_rel_cases]
+            >> metis_tac[]
+          )
+          >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+            Conv (Some (TypeStamp "False" _)) []
+          ])’] >- (
+            simp[Once evaluate_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[Once e_ce_rel_cases]
+            >> metis_tac[]
+          )
+          >> simp[evaluate_def]
+          >> simp[do_opapp_def,
+          Once find_recfun_def, Once build_rec_env_def]
+          >> simp[Ntimes evaluate_def 4, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >~ [‘"SAdd"’] >- (
+            simp[Ntimes evaluate_def 3, nsOptBind_def,
+              do_con_check_def, build_conv_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[Once e_ce_rel_cases]
+            >> simp[ml_v_vals_def]
+          )
+          >~ [‘"SMul"’] >- (
+            simp[Ntimes evaluate_def 3, nsOptBind_def,
+              do_con_check_def, build_conv_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[Once e_ce_rel_cases]
+            >> simp[ml_v_vals_def]
+          )
+          >> irule_at (Pos hd) EQ_REFL
+          >> simp[Once e_ce_rel_cases]
+          >> metis_tac[]
+        )
+        (*timeout case, I feel like this can be ignored for now*)
+        >> cheat
+      )
+      >> cheat
+    )
     >> cheat
   )
   >~ [‘Exp e’] >- (
     Cases_on ‘e’
     >> simp[step_def, Once e_ce_rel_cases]
+    >~ [‘Lit l’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> Cases_on ‘l’
+      >> simp[lit_to_val_def, to_ml_vals_def]
+      >> TRY CASE_TAC (*for Prim cases*)
+      >> gvs[lit_to_val_def, to_ml_vals_def]
+      >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
+        do_con_check_def, build_conv_def, nsOptBind_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases, ml_v_vals_def]
+    )
     >~ [‘Cond c te fe’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> qexists ‘"cont"’
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> rpt $ irule_at Any EQ_REFL
       >> gvs[scheme_env_def]
+      >> metis_tac[]
+    )
+    >~ [‘Apply fn es’] >- (
+      simp[cps_transform_def]
       >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> rpt $ irule_at Any EQ_REFL
+      >> pop_assum $ irule_at Any o GSYM
+      >> gvs[scheme_env_def]
+      >> ‘∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str’ by
+        simp[EVERY_isDigit_num_to_dec_string]
+      >> pop_assum $ irule_at $ Pos hd
+      >> simp[isDigit_def]
       >> metis_tac[]
     )
     >> cheat
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index d749f90ebd..c7b953e72e 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -9,32 +9,32 @@ open finite_mapTheory;
 val _ = new_theory "scheme_semantics";
 
 Datatype:
-  e_or_v = Exp exp | Val val
+  e_or_v = Exp exp | Val val | Exception mlstring
 End
 
 Definition sadd_def:
   sadd [] n = Val $ SNum n ∧
   sadd (SNum m :: xs) n = sadd xs (m + n) ∧
-  sadd (_ :: xs) _ = Exp $ Exception $ strlit "Arguments to + must be numbers"
+  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
 End
 
 Definition smul_def:
   smul [] n = Val $ SNum n ∧
   smul (SNum m :: xs) n = smul xs (m * n) ∧
-  smul (_ :: xs) _ = Exp $ Exception $ strlit "Arguments to * must be numbers"
+  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
 End
 
 Definition sminus_def:
-  sminus [] = Exp $ Exception $ strlit "Arity mismatch" ∧
+  sminus [] = Exception $ strlit "Arity mismatch" ∧
   sminus (SNum n :: xs) = (case sadd xs 0 of
   | Val (SNum m) => Val (SNum (n - m))
   | e => e) ∧
-  sminus _ = Exp $ Exception $ strlit "Arguments to - must be numbers"
+  sminus _ = Exception $ strlit "Arguments to - must be numbers"
 End
 
 Definition seqv_def:
   seqv [v1; v2] = (if v1 = v2 then Val $ SBool T else Val $ SBool F) ∧
-  seqv _ = Exp $ Exception $ strlit "Arity mismatch"
+  seqv _ = Exception $ strlit "Arity mismatch"
 End
 
 (*
@@ -61,7 +61,7 @@ Definition parameterize_def:
     in (store', ks, (env |+ (l, n)), Exp e)) ∧
   parameterize store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store (SOME x)
     in parameterize store' ks (env |+ (p, n)) ps lp e xs) ∧
-  parameterize store ks _ _ _ _ _ = (store, ks, FEMPTY, Exp $ Exception $ strlit "Wrong number of arguments")
+  parameterize store ks _ _ _ _ _ = (store, ks, FEMPTY, Exception $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
@@ -72,13 +72,13 @@ Definition application_def:
   | SEqv => (store, ks, FEMPTY, seqv xs)
   | CallCC => case xs of
     | [v] => (store, (FEMPTY, ApplyK (SOME (v, [])) []) :: ks, FEMPTY, Val $ Throw ks)
-    | _ => (store, ks, FEMPTY, Exp $ Exception $ strlit "arity mismatch")) ∧
+    | _ => (store, ks, FEMPTY, Exception $ strlit "Arity mismatch")) ∧
   application store ks (Proc env ps lp e) xs =
     parameterize store ks env ps lp e xs ∧
   application store ks (Throw ks') xs = (case xs of
     | [v] => (store, ks', FEMPTY, Val v)
-    | _ => (store, ks, FEMPTY, Exp $ Exception $ strlit "arity mismatch")) ∧
-  application store ks _ _ = (store, ks, FEMPTY, Exp $ Exception $ strlit "Not a procedure")
+    | _ => (store, ks, FEMPTY, Exception $ strlit "Arity mismatch")) ∧
+  application store ks _ _ = (store, ks, FEMPTY, Exception $ strlit "Not a procedure")
 End
 
 Definition return_def:
@@ -113,7 +113,7 @@ Definition step_def:
   step (store, ks, env, Exp $ Cond c t f) = (store, (env, CondK t f) :: ks, env, Exp c) ∧
   (*This is undefined if the program doesn't typecheck*)
   step (store, ks, env, Exp $ Ident s) = (let ev = case EL (env ' s) store of
-    | NONE => Exp $ Exception $ strlit "letrec variable touched"
+    | NONE => Exception $ strlit "letrec variable touched"
     | SOME v => Val v
     in (store, ks, env, ev)) ∧
   step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
@@ -125,7 +125,7 @@ Definition step_def:
   | (x, i)::bs' => let (store', env') = letrec_init store env (MAP FST bs)
       in (store', (env', BeginK (SNOC e (MAP (UNCURRY Set) bs'))) :: ks, env', Exp $ Set x i)) ∧
 
-  step (store, ks, env, Exp $ Exception ex) = (store, [], env, Exp $ Exception ex)
+  step (store, ks, env, Exception ex) = (store, [], env, Exception ex)
 End
 
 Definition steps_def:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index de43f28461..507e8db232 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -19,7 +19,9 @@ Definition to_ml_vals_def:
   | CallCC => Con (SOME $ Short "CallCC") []] ∧
   to_ml_vals (SNum n) = Con (SOME $ Short "SNum") [Lit $ IntLit n] ∧
   to_ml_vals (SBool b) = Con (SOME $ Short "SBool") [Con (SOME $ Short
-    if b then "True" else "False") []]
+    if b then "True" else "False") []] ∧
+  (*following temporary, needed for proofs*)
+  to_ml_vals _ = Con (SOME $ Short "Ex") [Lit $ StrLit "Not supported"]
 End
 
 Definition cons_list_def:
@@ -59,28 +61,34 @@ Definition letinit_ml_def:
 End
 
 Definition cps_transform_def:
-  cps_transform n (Lit v) = (let k = "k" ++ toString n in
-    (n+1, Fun k $ App Opapp [Var (Short k); to_ml_vals $ lit_to_val v])) ∧
-  cps_transform n (Exception s) =
-    (n, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]) ∧
+  cps_transform n (Lit v) = (let
+    k = "k" ++ toString n;
+    mlv = to_ml_vals $ lit_to_val v
+  in
+    (n+1, Fun k $ Let (SOME "v") mlv $
+      App Opapp [Var (Short k); Var (Short "v")])) ∧
+
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
     k = "k" ++ toString m;
     (l, ck) = refunc_cont (m+1) (CondK t f) (Var (Short k))
   in
-    (l, Fun k $ Let (SOME $ "cont") ck $ App Opapp [cc; Var (Short "cont")])) ∧
+    (l, Fun k $ Let (SOME "k") ck $ App Opapp [cc; Var (Short "k")])) ∧
+
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;
     (l, ck) = refunc_cont (m+1) (ApplyK NONE args) (Var (Short k))
   in
-    (l, Fun k $ App Opapp [cfn; ck])) ∧
+    (l, Fun k $ Let (SOME "k") ck $ App Opapp [cfn; Var (Short "k")])) ∧
+
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
     (n, Fun k $ Mat (App Opderef [Var (Short $ "s" ++ explode x)]) [
       (Pcon (SOME $ Short "None") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Letrec variable touched"]);
       (Pcon (SOME $ Short "Some") [Pvar $ "s'" ++ explode x],
         App Opapp [Var (Short k); Var (Short $ "s'" ++ explode x)])])) ∧
+
   cps_transform n (Lambda xs xp e) = (let
     (m, ce) = cps_transform n e;
     args = "xs" ++ toString m;
@@ -90,18 +98,21 @@ Definition cps_transform_def:
   in
     (l+1, Fun k' $ App Opapp [Var (Short k');
       Con (SOME $ Short "Proc") [Fun k $ Fun args inner]])) ∧
+
   cps_transform n (Begin e es) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
     (l, seqk) = refunc_cont (m+1) (BeginK es) (Var (Short k))
   in
     (l, Fun k $ App Opapp [ce; seqk])) ∧
+
   cps_transform n (Set x e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
     (l, setk) = refunc_cont (m+1) (SetK x) (Var (Short k))
   in
     (l, Fun k $ (App Opapp [ce;setk]))) ∧
+
   cps_transform n (Letrec bs e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
@@ -118,6 +129,7 @@ Definition cps_transform_def:
       (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []], App Opapp [cf; k]);
       (Pany, App Opapp [ct; k])
     ])) ∧
+
   refunc_cont n (ApplyK fnp es) k = (let
     t = "t" ++ toString n;
     (m, ce) = (case fnp of
@@ -126,7 +138,9 @@ Definition cps_transform_def:
                            (Var (Short t) :: MAP to_ml_vals vs) es k)
   in
     (m, Fun t ce)) ∧
+
   refunc_cont n (BeginK es) k = cps_transform_seq n k es ∧
+
   refunc_cont n (SetK x) k = (let
     t = "t" ++ toString n;
   in
@@ -140,12 +154,14 @@ Definition cps_transform_def:
     (l, inner) = cps_transform_app (m+1) tfn (Var (Short t)::ts) es k
   in
     (l, App Opapp [ce; Fun t inner])) ∧
+
   cps_transform_app n tfn ts [] k = (n,
     App Opapp [
       App Opapp [App Opapp [Var (Short "app"); k]; tfn];
       cons_list (REVERSE ts)]) ∧
 
   cps_transform_seq n k [] = (n, k) ∧
+
   cps_transform_seq n k (e::es) = (let
     (m, ce) = cps_transform n e;
     (l, inner) = cps_transform_seq m k es
@@ -153,6 +169,7 @@ Definition cps_transform_def:
     (l, Fun "_" $ App Opapp [ce; inner])) ∧
 
   cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧
+
   cps_transform_letreinit n k ((x,e)::bs) ce = (let
     (m, ce') = cps_transform n e;
     (l, inner) = cps_transform_letreinit m k bs ce;
@@ -233,7 +250,8 @@ Definition scheme_basis_def:
     Dletrec unknown_loc [
       ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "[]") [],
-          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+          Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+            App Opapp [Var (Short "k"); Var (Short "v")]);
         (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "x")) [
             (Pcon (SOME $ Short "SNum") [Pvar "xn"],
@@ -252,7 +270,8 @@ Definition scheme_basis_def:
     Dletrec unknown_loc [
       ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "[]") [],
-          App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [Var (Short "n")]]);
+          Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+            App Opapp [Var (Short "k"); Var (Short "v")]);
         (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
           Mat (Var (Short "x")) [
             (Pcon (SOME $ Short "SNum") [Pvar "xn"],
@@ -278,8 +297,9 @@ Definition scheme_basis_def:
               App Opapp [App Opapp [App Opapp [Var (Short "sadd");
                 Fun "t" $ Mat (Var (Short "t")) [
                   (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                    App Opapp [Var (Short "k"); Con (SOME $ Short "SNum") [
-                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]]);
+                    Let (SOME "v") (Con (SOME $ Short "SNum") [
+                        App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
+                      App Opapp [Var (Short "k"); Var (Short "v")]);
                   (Pany,
                     App Opapp [Var (Short "k"); Var (Short "t")])
                 ]];
@@ -300,8 +320,10 @@ Definition scheme_basis_def:
               Mat (Var (Short "xs''")) [
                 (Pcon (SOME $ Short "[]") [],
                   If (App Equality [Var (Short "x1"); Var (Short "x2")])
-                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]])
-                    (App Opapp [Var (Short "k"); Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]]));
+                    (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
+                      App Opapp [Var (Short "k"); Var (Short "v")])
+                    (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
+                      App Opapp [Var (Short "k"); Var (Short "v")]));
                 (Pany,
                   Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
               ])

From 7545813e7a7a5149c7dd48d5933213c2cfa3f4c1 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Mon, 7 Apr 2025 00:56:32 +0100
Subject: [PATCH 069/100] partial application step cases proven, some
 definition adjustment

---
 compiler/scheme/scheme_proofsScript.sml  | 170 ++++++++++++++++++++++-
 compiler/scheme/scheme_to_cakeScript.sml |   2 +-
 2 files changed, 166 insertions(+), 6 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index ba8d97c97f..4feb21e9c9 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -558,6 +558,16 @@ Theorem scheme_env_def[allow_rebind, compute] = SRULE [] $ zDefine ‘
     MAP Short ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
 ’
 
+Definition cps_app_ts_def:
+  cps_app_ts n (e::es) = (let
+    (m, ce) = cps_transform n e;
+    t = "t" ++ toString m
+  in
+    t :: cps_app_ts (m+1) es) ∧
+
+  cps_app_ts n [] = []
+End
+
 Inductive cont_rel:
 [~Id:]
   scheme_env env ∧
@@ -587,11 +597,42 @@ Inductive cont_rel:
   scheme_env env ∧
   ¬ MEM var vconses ∧
   ¬ MEM t vconses ∧
+  ts = cps_app_ts n es ∧
+  ¬ MEM var ts ∧
+  ¬ MEM t ts ∧
   var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
   cont_rel ((se, ApplyK NONE es) :: ks)
     (Closure env t $ ce)
+[~ApplyK_SOME:]
+  cont_rel ks kv ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  (m, ce) = cps_transform_app n (Var (Short fnt))
+    (Var (Short t) :: MAP (Var o Short) ts) es (Var (Short var)) ∧
+  nsLookup env.v (Short fnt) = SOME (ml_v_vals fn) ∧
+  LIST_REL (λ x v . nsLookup env.v (Short x) = SOME (ml_v_vals v)) ts vs ∧
+  scheme_env env ∧
+  ALL_DISTINCT ts ∧
+  ¬ MEM var vconses ∧
+  ¬ MEM fnt vconses ∧
+  ¬ MEM t vconses ∧
+  EVERY (λ x . ¬ MEM x vconses) ts ∧
+  ¬ MEM var ts ∧
+  ¬ MEM fnt ts ∧
+  ¬ MEM t ts ∧
+  ts' = cps_app_ts n es ∧
+  EVERY (λ x . ¬ MEM x ts') ts ∧
+  ¬ MEM var ts' ∧
+  ¬ MEM fnt ts' ∧
+  ¬ MEM t ts' ∧
+  var ≠ fnt ∧
+  var ≠ t ∧
+  fnt ≠ t
+  ⇒
+  (*Likely needs condition on se i.e. Scheme env*)
+  cont_rel ((se, ApplyK (SOME (fn, vs)) es) :: ks)
+    (Closure env t $ ce)
 End
 
 Theorem compile_in_rel:
@@ -627,6 +668,69 @@ Proof
   EVAL_TAC
 QED
 
+(*
+open scheme_proofsTheory;
+*)
+
+Theorem str_not_num:
+  ∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str
+Proof
+  simp[EVERY_isDigit_num_to_dec_string]
+QED
+
+Theorem k_in_ts:
+  ∀ es (n:num) m . ¬ MEM (STRING #"k" (toString n)) (cps_app_ts m es)
+Proof
+  Induct
+  >> simp[cps_app_ts_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+QED
+
+Theorem mono_proc_ml_on_n:
+  ∀ xs xp n k args ce m ce' .
+    (m, ce') = proc_ml n xs xp k args ce ⇒ m ≥ n
+Proof
+  Induct >> Cases
+  >> simp[proc_ml_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ dxrule o GSYM
+  >> simp[]
+QED
+
+Theorem mono_cps_on_n:
+  (∀ n e m ce . (m, ce) = cps_transform n e ⇒ m ≥ n) ∧
+  (∀ n k k' m ce . (m, ce) = refunc_cont n k k' ⇒ m ≥ n) ∧
+  (∀ n fn ts es k m ce . (m, ce) = cps_transform_app n fn ts es k ⇒ m ≥ n) ∧
+  (∀ n k es m ce . (m, ce) = cps_transform_seq n k es ⇒ m ≥ n) ∧
+  (∀ n k bs ce' m ce . (m, ce) = cps_transform_letreinit n k bs ce' ⇒ m ≥ n)
+Proof
+  ho_match_mp_tac $ cps_transform_ind
+  >> simp[cps_transform_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[]) >- (
+    dxrule $ GSYM mono_proc_ml_on_n
+    >> simp[]
+  )
+  >> pop_assum mp_tac
+  >> every_case_tac
+  >> strip_tac
+  >> gvs[]
+QED
+
+Theorem t_in_ts:
+  ∀ es n m . m > n ⇒ ¬ MEM (STRING #"t" (toString n)) (cps_app_ts m es)
+Proof
+  Induct >> rpt strip_tac
+  >> gvs[cps_app_ts_def]
+  >> rpt (pairarg_tac >> gvs[])
+  >> dxrule $ GSYM $ cj 1 mono_cps_on_n
+  >> simp[]
+  >> last_x_assum $ qspecl_then [‘n’, ‘m'+1’] mp_tac
+  >> simp[]
+QED
+
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
@@ -750,6 +854,63 @@ Proof
       )
       >> cheat
     )
+    >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases,
+        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> simp[Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $
+        irule_at (Pos $ el 2) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+      >> qpat_assum ‘scheme_env env’ $ simp
+        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def, t_in_ts]
+    )
+    >> Cases_on ‘∃ e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases,
+        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> simp[Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $ irule_at
+        (Pos $ hd o tl) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> SIMP_TAC std_ss [MAP_o]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+        o SIMP_RULE std_ss [Ntimes (GSYM MAP) 2, MAP_o]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> qpat_assum ‘scheme_env env’ $ simp
+        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def, t_in_ts]
+      >> gvs[EVERY_CONJ]
+      >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
+        o SRULE [EVERY_MEM]
+      >> irule EVERY2_MEM_MONO
+      >> qpat_assum ‘LIST_REL _ _ _’ $ irule_at (Pos last)
+      >> qpat_assum ‘LIST_REL _ _ _’ $ assume_tac o cj 1
+        o SRULE [EVERY2_EVERY]
+      >> PairCases >> simp[]
+      >> strip_tac
+      >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
+      >> simp[]
+      >> strip_tac
+      >> qsuff_tac ‘x0 ≠ t'’
+      >> strip_tac
+      >> gvs[]
+    )
     >> cheat
   )
   >~ [‘Exp e’] >- (
@@ -789,11 +950,10 @@ Proof
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> rpt $ irule_at Any EQ_REFL
       >> pop_assum $ irule_at Any o GSYM
-      >> gvs[scheme_env_def]
-      >> ‘∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str’ by
-        simp[EVERY_isDigit_num_to_dec_string]
-      >> pop_assum $ irule_at $ Pos hd
-      >> simp[isDigit_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp
+        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) str_not_num
+      >> simp[isDigit_def, k_in_ts, t_in_ts]
       >> metis_tac[]
     )
     >> cheat
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 507e8db232..51aecba667 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -153,7 +153,7 @@ Definition cps_transform_def:
     t = "t" ++ toString m;
     (l, inner) = cps_transform_app (m+1) tfn (Var (Short t)::ts) es k
   in
-    (l, App Opapp [ce; Fun t inner])) ∧
+    (l, Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")])) ∧
 
   cps_transform_app n tfn ts [] k = (n,
     App Opapp [

From 02bab82463396ed8a4eb321fe2180f7933d33ac1 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Mon, 7 Apr 2025 13:01:28 +0100
Subject: [PATCH 070/100] messing

---
 compiler/scheme/scheme_proofsScript.sml | 53 +++++++++++++++----------
 1 file changed, 33 insertions(+), 20 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 4feb21e9c9..79f48633e5 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -17,6 +17,8 @@ open namespacePropsTheory;
 
 val _ = new_theory "scheme_proofs";
 
+val _ = (max_print_depth := 20);
+
 Definition scheme_basis1_def:
   scheme_basis1 = Dtype unknown_loc [
     ([], "sprim", [
@@ -472,20 +474,17 @@ Definition ml_v_vals_def[nocompute]:
     | _ => ARB
 End
 
-fun mydisch x = DISCH (hd $ hyp x) x;
-
-Theorem ml_v_vals_def[allow_rebind, compute] = SRULE [] $ mydisch $
-  LIST_CONJ $ map
-    (EVAL_RULE o SIMP_RULE pure_ss [SimpRHS, ml_v_vals_def]) [
-    REFL “ml_v_vals (Prim SAdd)”,
-    REFL “ml_v_vals (Prim SMul)”,
-    REFL “ml_v_vals (Prim SMinus)”,
-    REFL “ml_v_vals (Prim SEqv)”,
-    REFL “ml_v_vals (Prim CallCC)”,
-    ASSUME “∀ n . ml_v_vals (SNum n) = ml_v_vals (SNum n)”,
-    REFL “ml_v_vals (SBool T)”,
-    REFL “ml_v_vals (SBool F)”
-  ];
+Theorem ml_v_vals_def[allow_rebind, compute] = LIST_CONJ $
+  map (GEN_ALL o (REWR_CONV ml_v_vals_def THENC EVAL)) [
+    “ml_v_vals (Prim SAdd)”,
+    “ml_v_vals (Prim SMul)”,
+    “ml_v_vals (Prim SMinus)”,
+    “ml_v_vals (Prim SEqv)”,
+    “ml_v_vals (Prim CallCC)”,
+    “ml_v_vals (SNum n)”,
+    “ml_v_vals (SBool T)”,
+    “ml_v_vals (SBool F)”
+];
 
 Inductive e_ce_rel:
 [~Val:]
@@ -734,22 +733,29 @@ QED
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
-  st.clock > 0 ∧
   cont_rel k kv ∧
   e_ce_rel e var mlenv kv mle ∧
   scheme_env mlenv
   ⇒
-  ∃ st' mlenv' var' kv' mle' .
-    evaluate st mlenv [mle]
+  ∃ ck st' mlenv' var' kv' mle' .
+    evaluate (st with clock:=ck) mlenv [mle]
     =
     evaluate st' mlenv' [mle'] ∧
     cont_rel k' kv' ∧
-    e_ce_rel e' var' mlenv' kv' mle'
+    e_ce_rel e' var' mlenv' kv' mle' ∧
+    st'.clock ≤ ck ∧
+    (k ≠ [] ⇒ st'.clock < ck)
 Proof
   Cases_on ‘e’
   >~ [‘Val v’] >- (
     Cases_on ‘k’
-    >- (simp[step_def, return_def] >> metis_tac[])
+    >- (
+      simp[step_def, return_def]
+      >> rw[]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[]
+      >> metis_tac[]
+    )
     >> PairCases_on ‘h’
     >> Cases_on ‘∃ te fe . h1 = CondK te fe’ >- (
       gvs[]
@@ -761,13 +767,20 @@ Proof
       but in theory should work for any vals*)
       >- (
         simp[Once e_ce_rel_cases, Once cont_rel_cases]
+        >> rpt gen_tac
+        >> IF_CASES_TAC
         >> simp[oneline ml_v_vals_def]
+        >> gvs[ml_v_vals_def]
+        >> rpt strip_tac
+
         >> every_case_tac
         >> gvs[]
         >> rpt strip_tac
+        
+        >> qrefine ‘ck+1’
         >> simp[SimpLHS, Ntimes evaluate_def 6, do_con_check_def,
           build_conv_def, scheme_env_def, do_opapp_def,
-        can_pmatch_all_def, pmatch_def]
+        can_pmatch_all_def, pmatch_def, dec_clock_def]
         >> qpat_assum ‘scheme_env env’ $ simp o curry ((::) o swap) [
             same_type_def, same_ctor_def, do_opapp_def,
             evaluate_match_def, pmatch_def, pat_bindings_def]

From 27879c1552e9e45ccdd455ff7d14d7de6313dc68 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Tue, 8 Apr 2025 15:39:28 +0100
Subject: [PATCH 071/100] proven addition

---
 compiler/scheme/scheme_proofsScript.sml       | 607 +++++++++---------
 compiler/scheme/scheme_semanticsScript.sml    |   6 +-
 compiler/scheme/scheme_to_cakeScript.sml      | 334 +++++-----
 .../translation/scheme_compilerProgScript.sml |   9 +-
 4 files changed, 486 insertions(+), 470 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 79f48633e5..655c65acfb 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -14,41 +14,12 @@ open semanticPrimitivesTheory;
 open namespaceTheory;
 open primTypesTheory;
 open namespacePropsTheory;
+open integerTheory;
 
 val _ = new_theory "scheme_proofs";
 
 val _ = (max_print_depth := 20);
 
-Definition scheme_basis1_def:
-  scheme_basis1 = Dtype unknown_loc [
-    ([], "sprim", [
-      ("SAdd", []);
-      ("SMul", []);
-      ("SMinus", []);
-      ("SEqv", []);
-      ("CallCC", [])
-    ]);
-    ([], "sval", [
-      ("SNum", [Atapp [] (Short "int")]);
-      ("SBool", [Atapp [] (Short "bool")]);
-      ("Prim", [Atapp [] (Short "sprim")]);
-      ("SList", [Atapp [Atapp [] (Short "sval")] (Short "list")]);
-      ("Wrong", [Atapp [] (Short "string")]);
-      ("Ex", [Atapp [] (Short "string")]);
-      ("Proc", [Atfun
-                 (Atfun
-                   (Atapp [] (Short "sval"))
-                   (Atapp [] (Short "sval")))
-                 (Atfun
-                   (Atapp [Atapp [] (Short "sval")] (Short "list"))
-                   (Atapp [] (Short "sval")))]);
-      ("Throw", [Atfun
-                  (Atapp [] (Short "sval"))
-                  (Atapp [] (Short "sval"))]);
-    ])
-  ]
-End
-
 Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
   scheme_env1 = case evaluate_decs
       (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
@@ -76,29 +47,6 @@ Theorem scheme_env1_rw[simp] = LIST_CONJ $ map EVAL [
   “nsLookup scheme_env1.c (Short "Throw")”
 ];
 
-Definition scheme_basis2_def:
-  scheme_basis2 = Dletrec unknown_loc [
-    ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-          App Opapp [Var (Short "k"); Var (Short "v")]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
-          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
-            App Opapp [
-              App Opapp [
-                App Opapp [Var (Short "sadd"); Var (Short "k")];
-                App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
-              ];
-              Var (Short "xs'")
-            ]);
-          (Pany,
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-        ])
-    ])
-  ]
-End
-
 Theorem scheme_env2_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env1”] $ zDefine ‘
     scheme_env2 = case evaluate_decs
@@ -130,29 +78,6 @@ Theorem scheme_env2_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env2.v (Short "sadd")”
 ];
 
-Definition scheme_basis3_def:
-  scheme_basis3 = Dletrec unknown_loc [
-    ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-          App Opapp [Var (Short "k"); Var (Short "v")]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
-          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
-            App Opapp [
-              App Opapp [
-                App Opapp [Var (Short "smul"); Var (Short "k")];
-                App (Opn Times) [Var (Short "n"); Var (Short "xn")]
-              ];
-              Var (Short "xs'")
-            ]);
-          (Pany,
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-        ])
-    ])
-  ]
-End
-
 Theorem scheme_env3_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env2”] $ zDefine ‘
     scheme_env3 = case evaluate_decs
@@ -188,30 +113,6 @@ Theorem scheme_env3_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env3.v (Short "smul")”
 ];
 
-Definition scheme_basis4_def:
-  scheme_basis4 = Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
-          (Pcon (SOME $ Short "SNum") [Pvar "n"],
-            App Opapp [App Opapp [App Opapp [Var (Short "sadd");
-              Fun "t" $ Mat (Var (Short "t")) [
-                (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                  Let (SOME "v") (Con (SOME $ Short "SNum") [
-                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")]);
-                (Pany,
-                  App Opapp [Var (Short "k"); Var (Short "t")])
-              ]];
-              Lit $ IntLit 0]; Var (Short "xs'")]);
-          (Pany,
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-        ])
-    ]
-End
-
 Theorem scheme_env4_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env3”] $ zDefine ‘
     scheme_env4 = case evaluate_decs
@@ -249,30 +150,6 @@ Theorem scheme_env4_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env4.v (Short "sminus")”
 ];
 
-Definition scheme_basis5_def:
-  scheme_basis5 = Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
-          (Pcon (SOME $ Short "[]") [],
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-          (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
-            Mat (Var (Short "xs''")) [
-              (Pcon (SOME $ Short "[]") [],
-                If (App Equality [Var (Short "x1"); Var (Short "x2")])
-                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")])
-                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")]));
-              (Pany,
-                Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-            ])
-        ])
-    ]
-End
-
 Theorem scheme_env5_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env4”] $ zDefine ‘
     scheme_env5 = case evaluate_decs
@@ -312,21 +189,6 @@ Theorem scheme_env5_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env5.v (Short "seqv")”
 ];
 
-Definition scheme_basis6_def:
-  scheme_basis6 = Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
-          (Pcon (SOME $ Short "[]") [],
-            App Opapp [Var (Short "k"); Var (Short "x")]);
-          (Pany,
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        ])
-    ]
-End
-
 Theorem scheme_env6_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env5”] $ zDefine ‘
     scheme_env6 = case evaluate_decs
@@ -368,43 +230,6 @@ Theorem scheme_env6_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env6.v (Short "throw")”
 ];
 
-Definition scheme_basis7_def:
-  scheme_basis7 = Dletrec unknown_loc [
-    ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
-      (Pcon (SOME $ Short "[]") [],
-        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
-          (Pcon (SOME $ Short "[]") [],
-            App Opapp [
-              App Opapp [
-                App Opapp [Var (Short "app");Var (Short "k")];
-                Var (Short "x")];
-              cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
-          (Pany,
-            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
-        ])
-    ]);
-    ("app", "k", Fun "fn" $ Mat (Var (Short "fn")) [
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
-        App Opapp [App Opapp [Var (Short "sadd"); Var (Short "k")]; Lit $ IntLit 0]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
-        App Opapp [App Opapp [Var (Short "smul"); Var (Short "k")]; Lit $ IntLit 1]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
-        App Opapp [Var (Short "sminus"); Var (Short "k")]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
-        App Opapp [Var (Short "seqv"); Var (Short "k")]);
-      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
-        App Opapp [Var (Short "callcc"); Var (Short "k")]);
-      (Pcon (SOME $ Short "Proc") [Pvar "e"],
-        App Opapp [Var (Short "e"); Var (Short "k")]);
-      (Pcon (SOME $ Short "Throw") [Pvar "k'"],
-        App Opapp [Var (Short "throw"); Var (Short "k'")]);
-      (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
-    ])
-  ]
-End
-
 Theorem scheme_env7_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env6”] $ zDefine ‘
     scheme_env7 = case evaluate_decs
@@ -449,6 +274,29 @@ Theorem scheme_env7_rw[simp] = LIST_CONJ $ map
   “nsLookup scheme_env7.v (Short "app")”
 ];
 
+Theorem scheme_env'_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
+  scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ scheme_basis) of
+    | (st', Rval env) => env
+    | _ => <|v:=nsEmpty;c:=nsEmpty|>
+’;
+
+Theorem scheme_env_def[allow_rebind, compute] = SRULE [] $ zDefine ‘
+  scheme_env env
+  ⇔
+  EVERY (λ x . nsLookup env.c x = nsLookup scheme_env7.c x) $
+    MAP Short ["SNum"; "SBool"; "True"; "False";
+    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
+    "[]"; "::"; "Ex"; "Throw"] ∧
+  EVERY (λ x . nsLookup env.v x = nsLookup scheme_env7.v x) $
+    MAP Short ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
+’
+
+Theorem basis_scheme_env:
+    scheme_env scheme_env'
+Proof
+  EVAL_TAC
+QED
+
 (*
 Example lambda calculus code of conditional expression,
 before and after step in CEK machine
@@ -469,7 +317,7 @@ before and after step in CEK machine
 
 Definition ml_v_vals_def[nocompute]:
   ml_v_vals v = case evaluate (<|clock:=0|> :num state)
-      scheme_env7 [to_ml_vals v] of
+      scheme_env' [to_ml_vals v] of
     | (st, Rval [mlv]) => mlv
     | _ => ARB
 End
@@ -503,12 +351,6 @@ Inductive e_ce_rel:
     Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]
 End
 
-Theorem scheme_env'_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
-  scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ scheme_basis) of
-    | (st', Rval env) => env
-    | _ => <|v:=nsEmpty;c:=nsEmpty|>
-’;
-
 Definition cconses_def[simp]:
   cconses = ["SNum"; "SBool"; "True"; "False";
     "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
@@ -519,44 +361,6 @@ Definition vconses_def[simp]:
   vconses = ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
 End
 
-(*Definition scheme_env_def:
-  scheme_env env
-  ⇔
-  (nsLookup env.c (Short "SNum") = SOME (1, TypeStamp "SNum" 3)) ∧
-  (nsLookup env.c (Short "SBool") = SOME (1, TypeStamp "SBool" 3)) ∧
-  (nsLookup env.c (Short "True") = SOME (0, TypeStamp "True" 0)) ∧
-  (nsLookup env.c (Short "False") = SOME (0, TypeStamp "False" 0)) ∧
-  (nsLookup env.c (Short "Prim") = SOME (1, TypeStamp "Prim" 3)) ∧
-  (nsLookup env.c (Short "SAdd") = SOME (0, TypeStamp "SAdd" 2)) ∧
-  (nsLookup env.c (Short "SMul") = SOME (0, TypeStamp "SMul" 2)) ∧
-  (nsLookup env.c (Short "SMinus") = SOME (0, TypeStamp "SMinus" 2)) ∧
-  (nsLookup env.c (Short "SEqv") = SOME (0, TypeStamp "SEqv" 2)) ∧
-  (nsLookup env.c (Short "CallCC") = SOME (0, TypeStamp "CallCC" 2)) ∧
-
-  (nsLookup env.c (Short "[]") = SOME (0, TypeStamp "[]" 1))
-  (nsLookup env.c (Short "::") = SOME (0, TypeStamp "::" 1))
-End*)
-
-(*Theorem scheme_env_def[compute] = EVAL_RULE $ zDefine ‘
-  scheme_env env
-  ⇔
-  EVERY (λ x . nsLookup env.c x = nsLookup scheme_env'.c x) $
-    MAP Short cconses ∧
-  EVERY (λ x . nsLookup env.v x = nsLookup scheme_env'.v x) $
-    MAP Short vconses
-’;*)
-
-Theorem scheme_env_def[allow_rebind, compute] = SRULE [] $ zDefine ‘
-  scheme_env env
-  ⇔
-  EVERY (λ x . nsLookup env.c x = nsLookup scheme_env7.c x) $
-    MAP Short ["SNum"; "SBool"; "True"; "False";
-    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
-    "[]"; "::"; "Ex"; "Throw"] ∧
-  EVERY (λ x . nsLookup env.v x = nsLookup scheme_env7.v x) $
-    MAP Short ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
-’
-
 Definition cps_app_ts_def:
   cps_app_ts n (e::es) = (let
     (m, ce) = cps_transform n e;
@@ -653,20 +457,6 @@ Proof
   >> metis_tac[]
 QED
 
-(*
-EVAL “case (SND $ evaluate_decs <|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|>
-<|v:=nsEmpty;c:=nsEmpty|> $ prim_types_program
-++ (scheme_basis)) of
-  | Rval env => evaluate <|clock:=999|> env $ [exp_with_cont [] (Lit $ LitBool T)]
-  | _ => (st, v)”
-*)
-
-Theorem basis_scheme_env:
-    scheme_env scheme_env'
-Proof
-  EVAL_TAC
-QED
-
 (*
 open scheme_proofsTheory;
 *)
@@ -730,6 +520,35 @@ Proof
   >> simp[]
 QED
 
+Definition vcons_list_def:
+  vcons_list [] = Conv (SOME (TypeStamp "[]" 1)) [] ∧
+  vcons_list (v::vs) = Conv (SOME (TypeStamp "::" 1)) [v; vcons_list vs]
+End
+
+Theorem cons_list_val:
+  ∀ st env ts vs .
+    scheme_env env ∧
+    LIST_REL (λ x v . nsLookup env.v (Short x) = SOME v) ts vs
+    ⇒
+    evaluate (st:'ffi state) env [cons_list (MAP (Var o Short) ts)]
+      = (st, Rval [vcons_list vs])
+Proof
+  rpt strip_tac
+  >> pop_assum mp_tac
+  >> qid_spec_tac ‘vs’
+  >> qid_spec_tac ‘ts’
+  >> ho_match_mp_tac LIST_REL_ind
+  >> simp[evaluate_def, cons_list_def, vcons_list_def,
+    do_con_check_def, build_conv_def]
+  >> gvs[scheme_env_def]
+QED
+
+Theorem map_reverse[simp]:
+  ∀ xs f . MAP f (REVERSE xs) = REVERSE (MAP f xs)
+Proof
+  Induct >> simp[]
+QED
+
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
@@ -767,16 +586,10 @@ Proof
       but in theory should work for any vals*)
       >- (
         simp[Once e_ce_rel_cases, Once cont_rel_cases]
-        >> rpt gen_tac
-        >> IF_CASES_TAC
         >> simp[oneline ml_v_vals_def]
-        >> gvs[ml_v_vals_def]
-        >> rpt strip_tac
-
         >> every_case_tac
         >> gvs[]
         >> rpt strip_tac
-        
         >> qrefine ‘ck+1’
         >> simp[SimpLHS, Ntimes evaluate_def 6, do_con_check_def,
           build_conv_def, scheme_env_def, do_opapp_def,
@@ -786,9 +599,9 @@ Proof
             evaluate_match_def, pmatch_def, pat_bindings_def]
           o SRULE [scheme_env_def]
         >> irule_at (Pos hd) EQ_REFL
+        >> gvs[]
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
-        >> irule_at Any EQ_REFL
-        >> simp[nsLookup_def]
         >> metis_tac[]
       )
       >> cheat
@@ -802,78 +615,237 @@ Proof
       >- (
         simp[oneline ml_v_vals_def]
         >> rpt strip_tac
-        >> Cases_on ‘st.clock > 6’ >- (
-          every_case_tac
-          >> gvs[application_def, sadd_def, smul_def, sminus_def,
-            seqv_def, cps_transform_def, cons_list_def]
-          >> simp[SimpLHS, evaluate_def, do_con_check_def,
-            build_conv_def, do_opapp_def]
-          >> qpat_assum ‘scheme_env env’ $ simp o single
-            o SRULE [scheme_env_def]
-          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-          >> simp[Ntimes evaluate_def 3, dec_clock_def]
-          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-            same_type_def, same_ctor_def, evaluate_match_def,
-            pat_bindings_def]
-          >~ [‘Litv (IntLit i)’] >- (
-            simp[Once evaluate_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> simp[Once e_ce_rel_cases]
-            >> metis_tac[]
-          )
-          >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
-            Conv (Some (TypeStamp "True" _)) []
-          ])’] >- (
-            simp[Once evaluate_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> simp[Once e_ce_rel_cases]
-            >> metis_tac[]
-          )
-          >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
-            Conv (Some (TypeStamp "False" _)) []
-          ])’] >- (
-            simp[Once evaluate_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> simp[Once e_ce_rel_cases]
-            >> metis_tac[]
-          )
-          >> simp[evaluate_def]
-          >> simp[do_opapp_def,
-          Once find_recfun_def, Once build_rec_env_def]
-          >> simp[Ntimes evaluate_def 4, dec_clock_def]
-          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-            same_type_def, same_ctor_def, evaluate_match_def,
-            pat_bindings_def]
-          >~ [‘"SAdd"’] >- (
-            simp[Ntimes evaluate_def 3, nsOptBind_def,
-              do_con_check_def, build_conv_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> simp[Once e_ce_rel_cases]
-            >> simp[ml_v_vals_def]
-          )
-          >~ [‘"SMul"’] >- (
-            simp[Ntimes evaluate_def 3, nsOptBind_def,
-              do_con_check_def, build_conv_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> simp[Once e_ce_rel_cases]
-            >> simp[ml_v_vals_def]
-          )
+        >> every_case_tac
+        >> gvs[application_def, sadd_def, smul_def, sminus_def,
+          seqv_def, cps_transform_def, cons_list_def]
+        >> qrefine ‘ck+2’
+        >> simp[SimpLHS, evaluate_def, do_con_check_def,
+          build_conv_def, do_opapp_def, dec_clock_def]
+        >> qpat_assum ‘scheme_env env’ $ simp o single
+          o SRULE [scheme_env_def]
+        >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+        >> qrefine ‘ck+1’
+        >> simp[Ntimes evaluate_def 3, dec_clock_def]
+        >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+          same_type_def, same_ctor_def, evaluate_match_def,
+          pat_bindings_def]
+        >~ [‘Litv (IntLit i)’] >- (
+          qrefine ‘ck+1’
+          >> simp[Once evaluate_def]
           >> irule_at (Pos hd) EQ_REFL
           >> simp[Once e_ce_rel_cases]
           >> metis_tac[]
         )
-        (*timeout case, I feel like this can be ignored for now*)
-        >> cheat
+        >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+          Conv (Some (TypeStamp "True" _)) []
+        ])’] >- (
+          qrefine ‘ck+1’
+          >> simp[Once evaluate_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> simp[Once e_ce_rel_cases]
+          >> metis_tac[]
+        )
+        >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+          Conv (Some (TypeStamp "False" _)) []
+        ])’] >- (
+          qrefine ‘ck+1’
+          >> simp[Once evaluate_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> simp[Once e_ce_rel_cases]
+          >> metis_tac[]
+        )
+        >> qrefine ‘ck+2’
+        >> simp[evaluate_def]
+        >> simp[do_opapp_def,
+        Once find_recfun_def, Once build_rec_env_def]
+        >> simp[Ntimes evaluate_def 4, dec_clock_def]
+        >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+          same_type_def, same_ctor_def, evaluate_match_def,
+          pat_bindings_def]
+        >~ [‘"SAdd"’] >- (
+          qrefine ‘ck+1’
+          >> simp[Ntimes evaluate_def 3, nsOptBind_def,
+            do_con_check_def, build_conv_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> simp[Once e_ce_rel_cases]
+          >> simp[ml_v_vals_def]
+        )
+        >~ [‘"SMul"’] >- (
+          qrefine ‘ck+1’
+          >> simp[Ntimes evaluate_def 3, nsOptBind_def,
+            do_con_check_def, build_conv_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> simp[Once e_ce_rel_cases]
+          >> simp[ml_v_vals_def]
+        )
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> metis_tac[]
       )
       >> cheat
     )
+    >> Cases_on ‘h1 = ApplyK (SOME (fn, vs)) []’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases,
+        Once cont_rel_cases]
+      >> Cases_on ‘fn = Prim SAdd ∨ fn = Prim SMul ∨ fn = Prim SMinus ∨
+        fn = Prim SEqv ∨ fn = Prim CallCC ∨
+        (∃n. fn = SNum n) ∨ fn = SBool T ∨ fn = SBool F’
+      >- (
+        drule_then (simp o single) $
+          DISCH (hd $ hyp $ oneline ml_v_vals_def) $ oneline ml_v_vals_def
+        >> rpt strip_tac
+        >> every_case_tac
+        >> gvs[application_def, sadd_def, smul_def, sminus_def,
+          seqv_def, cps_transform_def, cons_list_def]
+        (*SAdd cas*)
+        >- (
+          qrefine ‘ck+1’
+          >> simp[evaluate_def, do_con_check_def,
+            build_conv_def, do_opapp_def, dec_clock_def]
+          >> qsuff_tac ‘scheme_env env ∧ ¬ MEM t' vconses ⇒ scheme_env (env with v:= nsBind t'
+            (ml_v_vals v) env.v)’
+          >- (
+            simp[] >> strip_tac
+            >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env with v:= nsBind t' (ml_v_vals v)
+            env.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (MAP ml_v_vals (v::vs)))’ >- (
+              strip_tac
+              >> drule_all_then assume_tac cons_list_val
+              >> gvs[]
+              >> qpat_assum ‘scheme_env env’ $ simp o single o SRULE [scheme_env_def]
+              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+              >> qrefine ‘ck+3’
+              >> simp[Ntimes evaluate_def 3]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+              >> simp[Ntimes evaluate_def 3]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> simp[Ntimes evaluate_def 7, do_opapp_def]
+              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+              >> qrefine ‘ck+2’
+              >> simp[Ntimes evaluate_def 2, dec_clock_def]
+              >> Cases_on ‘∃ (n:int) . n = 0’ >~ [‘¬∃n.n=0’] >- gvs[]
+              >> pop_assum mp_tac
+              >> strip_tac
+              >> pop_assum $ simp o single o GSYM
+              >> qid_spec_tac ‘n’
+              >> pop_assum kall_tac
+              >> rpt $ qpat_x_assum ‘LIST_REL _ _ _’ kall_tac
+              >> Induct_on ‘vs’ using SNOC_INDUCT >- (
+                rpt strip_tac
+                >> simp[ml_v_vals_def, vcons_list_def]
+                >> qrefine ‘ck+1’
+                >> simp[Ntimes evaluate_def 2]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def]
+                >> Cases_on ‘∃ m . v = SNum m’ >- (
+                  gvs[ml_v_vals_def]
+                  >> qrefine ‘ck+3’
+                  >> simp[evaluate_def, do_app_def, do_opapp_def, dec_clock_def]
+                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                    same_type_def, same_ctor_def, evaluate_match_def,
+                    pat_bindings_def]
+                  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+                  >> simp[Ntimes evaluate_def 4]
+                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                    same_type_def, same_ctor_def, evaluate_match_def,
+                    pat_bindings_def]
+                  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+                  >> simp[Ntimes evaluate_def 3, do_con_check_def,
+                  build_conv_def, nsOptBind_def]
+                  >> simp[sadd_def]
+                  >> irule_at (Pos hd) EQ_REFL
+                  >> last_assum $ irule_at (Pos hd)
+                  >> simp[Once e_ce_rel_cases, ml_v_vals_def, opn_lookup_def]
+                  >> simp[INT_ADD_COMM]
+                )
+                >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
+                  v = Prim SEqv ∨ v = Prim CallCC ∨
+                  (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’ >- (
+                  simp[oneline ml_v_vals_def]
+                  >> every_case_tac
+                  >> gvs[]
+                  >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
+                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                    same_type_def, same_ctor_def, evaluate_match_def,
+                    pat_bindings_def, do_con_check_def, build_conv_def]
+                  >> irule_at (Pos hd) EQ_REFL
+                  >> last_assum $ irule_at (Pos hd)
+                  >> simp[Once e_ce_rel_cases, sadd_def]
+                ) >> cheat
+              )
+              >> rpt strip_tac
+              >> gvs[MAP_SNOC, REVERSE_SNOC, vcons_list_def]
+              >> Cases_on ‘∃ m . x = SNum m’ >- (
+                gvs[ml_v_vals_def]
+                >> simp[evaluate_def, do_opapp_def, do_app_def,
+                  opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+                >> qrefine ‘ck+3’
+                >> simp[Ntimes evaluate_def 2]
+                >> simp[sadd_def]
+                >> ‘∀ ck . st with <|clock:=ck;refs:=st.refs;ffi:=st.ffi|> = st with clock:=ck’
+                  by (simp[state_component_equality])
+                >> simp[]
+                >> pop_assum kall_tac
+                >> pop_assum $ qspec_then ‘n + m'’ mp_tac
+                >> strip_tac
+                >> qpat_assum ‘evaluate _ _ _ = evaluate _ _ _’ $ irule_at (Pos hd)
+                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                >> simp[Once INT_ADD_COMM]
+                >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
+              )
+              >> Cases_on ‘x = Prim SAdd ∨ x = Prim SMul ∨ x = Prim SMinus ∨
+                x = Prim SEqv ∨ x = Prim CallCC ∨
+                (∃n. x = SNum n) ∨ x = SBool T ∨ x = SBool F’ >- (
+                drule_then (simp o single) $
+                  DISCH (hd $ hyp $ oneline ml_v_vals_def) $ oneline ml_v_vals_def
+                >> every_case_tac
+                >> gvs[]
+                >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+                  opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+                >> simp[sadd_def, Once e_ce_rel_cases]
+                >> irule_at (Pos hd) EQ_REFL
+                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                >> simp[]
+              ) >> cheat
+            )
+            >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,vs))’ >- (
+              simp[ml_v_vals_def, LIST_REL_MAP2]
+              >> strip_tac
+              >> drule_then assume_tac EVERY2_LENGTH
+              >> drule_all $ iffRL EVERY2_EVERY
+              >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
+              >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
+              >> ho_match_mp_tac EVERY2_mono
+              >> simp[]
+            ) >> simp[EVERY_MEM] >> PairCases >> simp[]
+            >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
+            >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
+            >> strip_tac >> gvs[]
+          ) >> gvs[scheme_env_def]
+        ) >> cheat
+      ) >> cheat
+    )
     >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
-      >> simp[Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
       >> simp[Once e_ce_rel_cases]
       >> irule_at Any EQ_REFL
@@ -892,7 +864,9 @@ Proof
         Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
-      >> simp[Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
       >> simp[Once e_ce_rel_cases]
       >> irule_at Any EQ_REFL
@@ -936,8 +910,9 @@ Proof
       >> simp[lit_to_val_def, to_ml_vals_def]
       >> TRY CASE_TAC (*for Prim cases*)
       >> gvs[lit_to_val_def, to_ml_vals_def]
+      >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
-        do_con_check_def, build_conv_def, nsOptBind_def]
+        do_con_check_def, build_conv_def, nsOptBind_def, dec_clock_def]
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
       >> irule_at (Pos hd) EQ_REFL
@@ -947,10 +922,13 @@ Proof
       simp[cps_transform_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
-      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
-      >> rpt $ irule_at Any EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> simp[Once cont_rel_cases]
       >> gvs[scheme_env_def]
       >> metis_tac[]
     )
@@ -958,16 +936,21 @@ Proof
       simp[cps_transform_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
-      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
-      >> rpt $ irule_at Any EQ_REFL
-      >> pop_assum $ irule_at Any o GSYM
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = _’ $
+        irule_at (Pos $ hd o tl) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+      >> last_assum $ irule_at (Pos hd)
       >> qpat_assum ‘scheme_env mlenv’ $ simp
         o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
       >> irule_at (Pos hd) str_not_num
       >> simp[isDigit_def, k_in_ts, t_in_ts]
-      >> metis_tac[]
     )
     >> cheat
   )
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index c7b953e72e..263a9d5ebd 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -15,13 +15,13 @@ End
 Definition sadd_def:
   sadd [] n = Val $ SNum n ∧
   sadd (SNum m :: xs) n = sadd xs (m + n) ∧
-  sadd (_ :: xs) _ = Exception $ strlit "Arguments to + must be numbers"
+  sadd (_ :: xs) _ = Exception $ strlit "Arith-op applied to non-number"
 End
 
 Definition smul_def:
   smul [] n = Val $ SNum n ∧
   smul (SNum m :: xs) n = smul xs (m * n) ∧
-  smul (_ :: xs) _ = Exception $ strlit "Arguments to * must be numbers"
+  smul (_ :: xs) _ = Exception $ strlit "Arith-op applied to non-number"
 End
 
 Definition sminus_def:
@@ -29,7 +29,7 @@ Definition sminus_def:
   sminus (SNum n :: xs) = (case sadd xs 0 of
   | Val (SNum m) => Val (SNum (n - m))
   | e => e) ∧
-  sminus _ = Exception $ strlit "Arguments to - must be numbers"
+  sminus _ = Exception $ strlit "Arith-op applied to non-number"
 End
 
 Definition seqv_def:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 51aecba667..8c0a8b7a25 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -218,163 +218,191 @@ Definition cake_print_def:
     [Dlet unknown_loc Pany (App Opapp [Var (Short "print"); e])]
 End
 
-Definition scheme_basis_def:
-  scheme_basis = [
-    Dtype unknown_loc [
-      ([], "sprim", [
-        ("SAdd", []);
-        ("SMul", []);
-        ("SMinus", []);
-        ("SEqv", []);
-        ("CallCC", [])
-      ]);
-      ([], "sval", [
-        ("SNum", [Atapp [] (Short "int")]);
-        ("SBool", [Atapp [] (Short "bool")]);
-        ("Prim", [Atapp [] (Short "sprim")]);
-        ("SList", [Atapp [Atapp [] (Short "sval")] (Short "list")]);
-        ("Wrong", [Atapp [] (Short "string")]);
-        ("Ex", [Atapp [] (Short "string")]);
-        ("Proc", [Atfun
-                   (Atfun
-                     (Atapp [] (Short "sval"))
-                     (Atapp [] (Short "sval")))
-                   (Atfun
-                     (Atapp [Atapp [] (Short "sval")] (Short "list"))
-                     (Atapp [] (Short "sval")))]);
-        ("Throw", [Atfun
-                    (Atapp [] (Short "sval"))
-                    (Atapp [] (Short "sval"))]);
-      ])
-    ];
-    Dletrec unknown_loc [
-      ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-            App Opapp [Var (Short "k"); Var (Short "v")]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+Definition scheme_basis1_def:
+  scheme_basis1 = Dtype unknown_loc [
+    ([], "sprim", [
+      ("SAdd", []);
+      ("SMul", []);
+      ("SMinus", []);
+      ("SEqv", []);
+      ("CallCC", [])
+    ]);
+    ([], "sval", [
+      ("SNum", [Atapp [] (Short "int")]);
+      ("SBool", [Atapp [] (Short "bool")]);
+      ("Prim", [Atapp [] (Short "sprim")]);
+      ("SList", [Atapp [Atapp [] (Short "sval")] (Short "list")]);
+      ("Wrong", [Atapp [] (Short "string")]);
+      ("Ex", [Atapp [] (Short "string")]);
+      ("Proc", [Atfun
+                 (Atfun
+                   (Atapp [] (Short "sval"))
+                   (Atapp [] (Short "sval")))
+                 (Atfun
+                   (Atapp [Atapp [] (Short "sval")] (Short "list"))
+                   (Atapp [] (Short "sval")))]);
+      ("Throw", [Atfun
+                  (Atapp [] (Short "sval"))
+                  (Atapp [] (Short "sval"))]);
+    ])
+  ]
+End
+
+Definition scheme_basis2_def:
+  scheme_basis2 = Dletrec unknown_loc [
+    ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "v")]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+            App Opapp [
               App Opapp [
-                App Opapp [
-                  App Opapp [Var (Short "sadd"); Var (Short "k")];
-                  App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
-                ];
-                Var (Short "xs'")
-              ]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ])
-    ];
-    Dletrec unknown_loc [
-      ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-            App Opapp [Var (Short "k"); Var (Short "v")]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+                App Opapp [Var (Short "sadd"); Var (Short "k")];
+                App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
+              ];
+              Var (Short "xs'")
+            ]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
+        ])
+    ])
+  ]
+End
+
+Definition scheme_basis3_def:
+  scheme_basis3 = Dletrec unknown_loc [
+    ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "v")]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+            App Opapp [
               App Opapp [
-                App Opapp [
-                  App Opapp [Var (Short "smul"); Var (Short "k")];
-                  App (Opn Times) [Var (Short "n"); Var (Short "xn")]
-                ];
-                Var (Short "xs'")
-              ]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ])
-    ];
-    Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
-      Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "x")) [
-            (Pcon (SOME $ Short "SNum") [Pvar "n"],
-              App Opapp [App Opapp [App Opapp [Var (Short "sadd");
-                Fun "t" $ Mat (Var (Short "t")) [
-                  (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                    Let (SOME "v") (Con (SOME $ Short "SNum") [
-                        App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
-                      App Opapp [Var (Short "k"); Var (Short "v")]);
-                  (Pany,
-                    App Opapp [Var (Short "k"); Var (Short "t")])
-                ]];
-                Lit $ IntLit 0]; Var (Short "xs'")]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Not a number"])
-          ])
-      ];
-    Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
-      Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
-          Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "[]") [],
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-            (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
-              Mat (Var (Short "xs''")) [
-                (Pcon (SOME $ Short "[]") [],
-                  If (App Equality [Var (Short "x1"); Var (Short "x2")])
-                    (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
-                      App Opapp [Var (Short "k"); Var (Short "v")])
-                    (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
-                      App Opapp [Var (Short "k"); Var (Short "v")]));
+                App Opapp [Var (Short "smul"); Var (Short "k")];
+                App (Opn Times) [Var (Short "n"); Var (Short "xn")]
+              ];
+              Var (Short "xs'")
+            ]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
+        ])
+    ])
+  ]
+End
+
+Definition scheme_basis4_def:
+  scheme_basis4 = Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "x")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "n"],
+            App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+              Fun "t" $ Mat (Var (Short "t")) [
+                (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                  Let (SOME "v") (Con (SOME $ Short "SNum") [
+                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")]);
                 (Pany,
-                  Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-              ])
-          ])
-      ];
-    Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
-      Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "[]") [],
-              App Opapp [Var (Short "k"); Var (Short "x")]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-          ])
-      ];
-    Dletrec unknown_loc [
-      ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
-        (Pcon (SOME $ Short "[]") [],
-          Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-          Mat (Var (Short "xs'")) [
-            (Pcon (SOME $ Short "[]") [],
-              App Opapp [
-                App Opapp [
-                  App Opapp [Var (Short "app");Var (Short "k")];
-                  Var (Short "x")];
-                cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
-            (Pany,
-              Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
-          ])
-      ]);
-      ("app", "k", Fun "fn" $ Mat (Var (Short "fn")) [
-        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
-          App Opapp [App Opapp [Var (Short "sadd"); Var (Short "k")]; Lit $ IntLit 0]);
-        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
-          App Opapp [App Opapp [Var (Short "smul"); Var (Short "k")]; Lit $ IntLit 1]);
-        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
-          App Opapp [Var (Short "sminus"); Var (Short "k")]);
-        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
-          App Opapp [Var (Short "seqv"); Var (Short "k")]);
-        (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
-          App Opapp [Var (Short "callcc"); Var (Short "k")]);
-        (Pcon (SOME $ Short "Proc") [Pvar "e"],
-          App Opapp [Var (Short "e"); Var (Short "k")]);
-        (Pcon (SOME $ Short "Throw") [Pvar "k'"],
-          App Opapp [Var (Short "throw"); Var (Short "k'")]);
-        (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
-      ])
+                  App Opapp [Var (Short "k"); Var (Short "t")])
+              ]];
+              Lit $ IntLit 0]; Var (Short "xs'")]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
+        ])
+    ]
+End
+
+Definition scheme_basis5_def:
+  scheme_basis5 = Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+          (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
+            Mat (Var (Short "xs''")) [
+              (Pcon (SOME $ Short "[]") [],
+                If (App Equality [Var (Short "x1"); Var (Short "x2")])
+                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")])
+                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
+                    App Opapp [Var (Short "k"); Var (Short "v")]));
+              (Pany,
+                Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+            ])
+        ])
+    ]
+End
+
+Definition scheme_basis6_def:
+  scheme_basis6 = Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
+    Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            App Opapp [Var (Short "k"); Var (Short "x")]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+        ])
     ]
+End
+
+Definition scheme_basis7_def:
+  scheme_basis7 = Dletrec unknown_loc [
+    ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "[]") [],
+        Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
+        Mat (Var (Short "xs'")) [
+          (Pcon (SOME $ Short "[]") [],
+            App Opapp [
+              App Opapp [
+                App Opapp [Var (Short "app");Var (Short "k")];
+                Var (Short "x")];
+              cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
+          (Pany,
+            Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
+        ])
+    ]);
+    ("app", "k", Fun "fn" $ Mat (Var (Short "fn")) [
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SAdd") []],
+        App Opapp [App Opapp [Var (Short "sadd"); Var (Short "k")]; Lit $ IntLit 0]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMul") []],
+        App Opapp [App Opapp [Var (Short "smul"); Var (Short "k")]; Lit $ IntLit 1]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SMinus") []],
+        App Opapp [Var (Short "sminus"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "SEqv") []],
+        App Opapp [Var (Short "seqv"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Prim") [Pcon (SOME $ Short "CallCC") []],
+        App Opapp [Var (Short "callcc"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Proc") [Pvar "e"],
+        App Opapp [Var (Short "e"); Var (Short "k")]);
+      (Pcon (SOME $ Short "Throw") [Pvar "k'"],
+        App Opapp [Var (Short "throw"); Var (Short "k'")]);
+      (Pany, Fun "_" $ Con (SOME $ Short "Ex") [Lit $ StrLit"Not a procedure"])
+    ])
+  ]
+End
+
+Definition scheme_basis_def:
+  scheme_basis = [
+    scheme_basis1;
+    scheme_basis2;
+    scheme_basis3;
+    scheme_basis4;
+    scheme_basis5;
+    scheme_basis6;
+    scheme_basis7
   ]
 End
 
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index c65126d4be..9760a1fbde 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -41,9 +41,14 @@ val r = translate cons_list_def;
 val r = translate proc_ml_def;
 val r = translate letinit_ml_def;
 val r = translate cps_transform_def;
-val r = translate scheme_cont_def;
-val r = translate exp_with_cont_def;
 val r = translate compile_scheme_prog_def;
+val r = translate scheme_basis1_def;
+val r = translate scheme_basis2_def;
+val r = translate scheme_basis3_def;
+val r = translate scheme_basis4_def;
+val r = translate scheme_basis5_def;
+val r = translate scheme_basis6_def;
+val r = translate scheme_basis7_def;
 val r = translate scheme_basis_def;
 val r = translate codegen_def;
 

From 8a8b65a6fd049156a1d3105d4ea8be5a30bb683e Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 9 Apr 2025 02:03:32 +0100
Subject: [PATCH 072/100] env relation, some adjustments

---
 compiler/scheme/scheme_proofsScript.sml  | 670 ++++++++++++-----------
 compiler/scheme/scheme_to_cakeScript.sml |  14 +-
 2 files changed, 359 insertions(+), 325 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index 655c65acfb..dd75b35ac5 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -24,28 +24,25 @@ Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
   scheme_env1 = case evaluate_decs
       (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
       <|v:=nsEmpty;c:=nsEmpty|>
-      (prim_types_program ++ [scheme_basis1]) of
+      (prim_types_program ++ [Dtype unknown_loc [(["'a"],"option",
+            [("None",[]); ("Some",[Atvar "'a"])])]] ++ [scheme_basis1]) of
     | (st', Rval env) => env
     | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env1_rw[simp] = LIST_CONJ $ map EVAL [
-  “nsLookup scheme_env1.c (Short "SNum")”,
-  “nsLookup scheme_env1.c (Short "SBool")”,
-  “nsLookup scheme_env1.c (Short "True")”,
-  “nsLookup scheme_env1.c (Short "False")”,
-  “nsLookup scheme_env1.c (Short "Prim")”,
-  “nsLookup scheme_env1.c (Short "SAdd")”,
-  “nsLookup scheme_env1.c (Short "SMul")”,
-  “nsLookup scheme_env1.c (Short "SMinus")”,
-  “nsLookup scheme_env1.c (Short "SEqv")”,
-  “nsLookup scheme_env1.c (Short "CallCC")”,
-  “nsLookup scheme_env1.c (Short "[]")”,
-  “nsLookup scheme_env1.c (Short "::")”,
-  “nsLookup scheme_env1.c (Short "Ex")”,
-  “nsLookup scheme_env1.c (Short "Proc")”,
-  “nsLookup scheme_env1.c (Short "Throw")”
-];
+Definition cconses_def[simp]:
+  cconses = ["SNum"; "SBool"; "True"; "False";
+    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
+    "[]"; "::"; "Some"; "None"; "Ex"; "Proc"; "Throw"]
+End
+
+Theorem scheme_env1_rw[simp] = SRULE [nsLookup_def] $ SIMP_CONV pure_ss [
+  SimpRHS, scheme_env1_def,
+  EVERY_DEF, cconses_def, MAP
+] “
+  EVERY (λ x . nsLookup scheme_env1.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”;
 
 Theorem scheme_env2_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env1”] $ zDefine ‘
@@ -53,30 +50,15 @@ Theorem scheme_env2_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env1
         [scheme_basis2] of
-      | (st', Rval env) => extend_dec_env env scheme_env1
+      | (st', Rval env) => <|c:=scheme_env1.c;v:=nsAppend env.v scheme_env1.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env2_rw[simp] = LIST_CONJ $ map
-  (SRULE [GSYM scheme_env1_def] o EVAL) [
-  “nsLookup scheme_env2.c (Short "SNum")”,
-  “nsLookup scheme_env2.c (Short "SBool")”,
-  “nsLookup scheme_env2.c (Short "True")”,
-  “nsLookup scheme_env2.c (Short "False")”,
-  “nsLookup scheme_env2.c (Short "Prim")”,
-  “nsLookup scheme_env2.c (Short "SAdd")”,
-  “nsLookup scheme_env2.c (Short "SMul")”,
-  “nsLookup scheme_env2.c (Short "SMinus")”,
-  “nsLookup scheme_env2.c (Short "SEqv")”,
-  “nsLookup scheme_env2.c (Short "CallCC")”,
-  “nsLookup scheme_env2.c (Short "[]")”,
-  “nsLookup scheme_env2.c (Short "::")”,
-  “nsLookup scheme_env2.c (Short "Ex")”,
-  “nsLookup scheme_env2.c (Short "Proc")”,
-  “nsLookup scheme_env2.c (Short "Throw")”,
-
-  “nsLookup scheme_env2.v (Short "sadd")”
-];
+Theorem scheme_env2_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env2_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env2.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ SRULE [GSYM scheme_env1_def] $ EVAL “nsLookup scheme_env2.v (Short "sadd")”;
 
 Theorem scheme_env3_def[allow_rebind, compute] = SRULE [] $
   RESTR_EVAL_RULE [“scheme_env2”] $ zDefine ‘
@@ -84,31 +66,19 @@ Theorem scheme_env3_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env2
         [scheme_basis3] of
-      | (st', Rval env) => extend_dec_env env scheme_env2
+      | (st', Rval env) => <|c:=scheme_env2.c;v:=nsAppend env.v scheme_env2.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env3_rw[simp] = LIST_CONJ $ map
+Theorem scheme_env3_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env3_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env3.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ LIST_CONJ $ map
   (SRULE [
     GSYM $ EVAL “scheme_env1”,
     GSYM $ EVAL “scheme_env2”
   ] o EVAL) [
-  “nsLookup scheme_env3.c (Short "SNum")”,
-  “nsLookup scheme_env3.c (Short "SBool")”,
-  “nsLookup scheme_env3.c (Short "True")”,
-  “nsLookup scheme_env3.c (Short "False")”,
-  “nsLookup scheme_env3.c (Short "Prim")”,
-  “nsLookup scheme_env3.c (Short "SAdd")”,
-  “nsLookup scheme_env3.c (Short "SMul")”,
-  “nsLookup scheme_env3.c (Short "SMinus")”,
-  “nsLookup scheme_env3.c (Short "SEqv")”,
-  “nsLookup scheme_env3.c (Short "CallCC")”,
-  “nsLookup scheme_env3.c (Short "[]")”,
-  “nsLookup scheme_env3.c (Short "::")”,
-  “nsLookup scheme_env3.c (Short "Ex")”,
-  “nsLookup scheme_env3.c (Short "Proc")”,
-  “nsLookup scheme_env3.c (Short "Throw")”,
-
   “nsLookup scheme_env3.v (Short "sadd")”,
   “nsLookup scheme_env3.v (Short "smul")”
 ];
@@ -119,32 +89,20 @@ Theorem scheme_env4_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env3
         [scheme_basis4] of
-      | (st', Rval env) => extend_dec_env env scheme_env3
+      | (st', Rval env) => <|c:=scheme_env3.c;v:=nsAppend env.v scheme_env3.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env4_rw[simp] = LIST_CONJ $ map
+Theorem scheme_env4_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env4_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env4.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ LIST_CONJ $ map
   (SRULE [
     GSYM $ EVAL “scheme_env1”,
     GSYM $ EVAL “scheme_env2”,
     GSYM $ EVAL “scheme_env3”
   ] o EVAL) [
-  “nsLookup scheme_env4.c (Short "SNum")”,
-  “nsLookup scheme_env4.c (Short "SBool")”,
-  “nsLookup scheme_env4.c (Short "True")”,
-  “nsLookup scheme_env4.c (Short "False")”,
-  “nsLookup scheme_env4.c (Short "Prim")”,
-  “nsLookup scheme_env4.c (Short "SAdd")”,
-  “nsLookup scheme_env4.c (Short "SMul")”,
-  “nsLookup scheme_env4.c (Short "SMinus")”,
-  “nsLookup scheme_env4.c (Short "SEqv")”,
-  “nsLookup scheme_env4.c (Short "CallCC")”,
-  “nsLookup scheme_env4.c (Short "[]")”,
-  “nsLookup scheme_env4.c (Short "::")”,
-  “nsLookup scheme_env4.c (Short "Ex")”,
-  “nsLookup scheme_env4.c (Short "Proc")”,
-  “nsLookup scheme_env4.c (Short "Throw")”,
-
   “nsLookup scheme_env4.v (Short "sadd")”,
   “nsLookup scheme_env4.v (Short "smul")”,
   “nsLookup scheme_env4.v (Short "sminus")”
@@ -156,33 +114,21 @@ Theorem scheme_env5_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env4
         [scheme_basis5] of
-      | (st', Rval env) => extend_dec_env env scheme_env4
+      | (st', Rval env) => <|c:=scheme_env4.c;v:=nsAppend env.v scheme_env4.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env5_rw[simp] = LIST_CONJ $ map
+Theorem scheme_env5_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env5_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env5.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ LIST_CONJ $ map
   (SRULE [
     GSYM $ EVAL “scheme_env1”,
     GSYM $ EVAL “scheme_env2”,
     GSYM $ EVAL “scheme_env3”,
     GSYM $ EVAL “scheme_env4”
   ] o EVAL) [
-  “nsLookup scheme_env5.c (Short "SNum")”,
-  “nsLookup scheme_env5.c (Short "SBool")”,
-  “nsLookup scheme_env5.c (Short "True")”,
-  “nsLookup scheme_env5.c (Short "False")”,
-  “nsLookup scheme_env5.c (Short "Prim")”,
-  “nsLookup scheme_env5.c (Short "SAdd")”,
-  “nsLookup scheme_env5.c (Short "SMul")”,
-  “nsLookup scheme_env5.c (Short "SMinus")”,
-  “nsLookup scheme_env5.c (Short "SEqv")”,
-  “nsLookup scheme_env5.c (Short "CallCC")”,
-  “nsLookup scheme_env5.c (Short "[]")”,
-  “nsLookup scheme_env5.c (Short "::")”,
-  “nsLookup scheme_env5.c (Short "Ex")”,
-  “nsLookup scheme_env5.c (Short "Proc")”,
-  “nsLookup scheme_env5.c (Short "Throw")”,
-
   “nsLookup scheme_env5.v (Short "sadd")”,
   “nsLookup scheme_env5.v (Short "smul")”,
   “nsLookup scheme_env5.v (Short "sminus")”,
@@ -195,11 +141,15 @@ Theorem scheme_env6_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env5
         [scheme_basis6] of
-      | (st', Rval env) => extend_dec_env env scheme_env5
+      | (st', Rval env) => <|c:=scheme_env5.c;v:=nsAppend env.v scheme_env5.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env6_rw[simp] = LIST_CONJ $ map
+Theorem scheme_env6_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env6_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env6.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ LIST_CONJ $ map
   (SRULE [
     GSYM $ EVAL “scheme_env1”,
     GSYM $ EVAL “scheme_env2”,
@@ -207,22 +157,6 @@ Theorem scheme_env6_rw[simp] = LIST_CONJ $ map
     GSYM $ EVAL “scheme_env4”,
     GSYM $ EVAL “scheme_env5”
   ] o EVAL) [
-  “nsLookup scheme_env6.c (Short "SNum")”,
-  “nsLookup scheme_env6.c (Short "SBool")”,
-  “nsLookup scheme_env6.c (Short "True")”,
-  “nsLookup scheme_env6.c (Short "False")”,
-  “nsLookup scheme_env6.c (Short "Prim")”,
-  “nsLookup scheme_env6.c (Short "SAdd")”,
-  “nsLookup scheme_env6.c (Short "SMul")”,
-  “nsLookup scheme_env6.c (Short "SMinus")”,
-  “nsLookup scheme_env6.c (Short "SEqv")”,
-  “nsLookup scheme_env6.c (Short "CallCC")”,
-  “nsLookup scheme_env6.c (Short "[]")”,
-  “nsLookup scheme_env6.c (Short "::")”,
-  “nsLookup scheme_env6.c (Short "Ex")”,
-  “nsLookup scheme_env6.c (Short "Proc")”,
-  “nsLookup scheme_env6.c (Short "Throw")”,
-
   “nsLookup scheme_env6.v (Short "sadd")”,
   “nsLookup scheme_env6.v (Short "smul")”,
   “nsLookup scheme_env6.v (Short "sminus")”,
@@ -236,11 +170,15 @@ Theorem scheme_env7_def[allow_rebind, compute] = SRULE [] $
         (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state)
         scheme_env6
         [scheme_basis7] of
-      | (st', Rval env) => extend_dec_env env scheme_env6
+      | (st', Rval env) => <|c:=scheme_env6.c;v:=nsAppend env.v scheme_env6.v|>
       | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env7_rw[simp] = LIST_CONJ $ map
+Theorem scheme_env7_rw[simp] = SRULE [GSYM CONJ_ASSOC] $
+CONJ (SRULE [Once scheme_env7_def] $ SCONV [] “
+  EVERY (λ x . nsLookup scheme_env7.c x = nsLookup scheme_env1.c x) $
+    MAP Short cconses
+”) $ LIST_CONJ $ map
   (SRULE [
     GSYM $ EVAL “scheme_env1”,
     GSYM $ EVAL “scheme_env2”,
@@ -249,22 +187,6 @@ Theorem scheme_env7_rw[simp] = LIST_CONJ $ map
     GSYM $ EVAL “scheme_env5”,
     GSYM $ EVAL “scheme_env6”
   ] o EVAL) [
-  “nsLookup scheme_env7.c (Short "SNum")”,
-  “nsLookup scheme_env7.c (Short "SBool")”,
-  “nsLookup scheme_env7.c (Short "True")”,
-  “nsLookup scheme_env7.c (Short "False")”,
-  “nsLookup scheme_env7.c (Short "Prim")”,
-  “nsLookup scheme_env7.c (Short "SAdd")”,
-  “nsLookup scheme_env7.c (Short "SMul")”,
-  “nsLookup scheme_env7.c (Short "SMinus")”,
-  “nsLookup scheme_env7.c (Short "SEqv")”,
-  “nsLookup scheme_env7.c (Short "CallCC")”,
-  “nsLookup scheme_env7.c (Short "[]")”,
-  “nsLookup scheme_env7.c (Short "::")”,
-  “nsLookup scheme_env7.c (Short "Ex")”,
-  “nsLookup scheme_env7.c (Short "Proc")”,
-  “nsLookup scheme_env7.c (Short "Throw")”,
-
   “nsLookup scheme_env7.v (Short "sadd")”,
   “nsLookup scheme_env7.v (Short "smul")”,
   “nsLookup scheme_env7.v (Short "sminus")”,
@@ -275,20 +197,23 @@ Theorem scheme_env7_rw[simp] = LIST_CONJ $ map
 ];
 
 Theorem scheme_env'_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
-  scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ scheme_basis) of
+  scheme_env' = case evaluate_decs (<|clock:=999;next_type_stamp:=0;next_exn_stamp:=0|> :num state) <|v:=nsEmpty;c:=nsEmpty|> (prim_types_program ++ [Dtype unknown_loc [(["'a"],"option",
+            [("None",[]); ("Some",[Atvar "'a"])])]] ++ scheme_basis) of
     | (st', Rval env) => env
     | _ => <|v:=nsEmpty;c:=nsEmpty|>
 ’;
 
-Theorem scheme_env_def[allow_rebind, compute] = SRULE [] $ zDefine ‘
+Definition vconses_def[simp]:
+  vconses = ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
+End
+
+Theorem scheme_env_def[allow_rebind, compute] = SRULE [GSYM CONJ_ASSOC] $ zDefine ‘
   scheme_env env
   ⇔
   EVERY (λ x . nsLookup env.c x = nsLookup scheme_env7.c x) $
-    MAP Short ["SNum"; "SBool"; "True"; "False";
-    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
-    "[]"; "::"; "Ex"; "Throw"] ∧
+    MAP Short cconses ∧
   EVERY (λ x . nsLookup env.v x = nsLookup scheme_env7.v x) $
-    MAP Short ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
+    MAP Short vconses
 ’
 
 Theorem basis_scheme_env:
@@ -315,6 +240,14 @@ before and after step in CEK machine
         | _ => (\k2 -> k2 (SNum 2)) (\t -> t)))
 *)
 
+Definition scheme_typestamp_def:
+  scheme_typestamp con = SND $ THE $ nsLookup scheme_env1.c (Short con)
+End
+
+Theorem scheme_typestamp_def[allow_rebind, simp] = SRULE [] $
+  SIMP_CONV pure_ss [SimpRHS, scheme_typestamp_def, EVERY_DEF, cconses_def]
+  “EVERY (λ x . scheme_typestamp x = scheme_typestamp x) cconses”;
+
 Definition ml_v_vals_def[nocompute]:
   ml_v_vals v = case evaluate (<|clock:=0|> :num state)
       scheme_env' [to_ml_vals v] of
@@ -334,16 +267,70 @@ Theorem ml_v_vals_def[allow_rebind, compute] = LIST_CONJ $
     “ml_v_vals (SBool F)”
 ];
 
+Inductive env_rel:
+  FEVERY (λ (x, n). ∃ v.
+    nsLookup env.v (Short ("s" ++ explode x)) = SOME v) se
+  ⇒
+  env_rel se (env :v sem_env)
+End
+
+Inductive ml_v_vals':
+[~Proc:]
+  env_rel se env ∧
+  (m, ce) = cps_transform n e ∧
+  args = "xs" ++ toString m ∧
+  k = "k" ++ toString (m+1) ∧
+  (l, inner) = proc_ml (m+2) xs xp k args ce
+  ⇒
+  ml_v_vals' (Proc se xs xp e) $
+    Conv (SOME (TypeStamp "Proc" 4)) [
+      Closure env k $ Fun args inner
+    ]
+End
+
+val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
+(fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
+  (ml_v_vals' (SBool T) $
+    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "True")) []]) ∧
+  (ml_v_vals' (SBool F) $
+    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "False")) []]) ∧
+  (ml_v_vals' (SNum n') $
+    Conv (SOME (scheme_typestamp "SNum")) [Litv (IntLit n')]) ∧
+  (ml_v_vals' (Prim SAdd) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SAdd")) []]) ∧
+  (ml_v_vals' (Prim SMul) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMul")) []]) ∧
+  (ml_v_vals' (Prim SMinus) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMinus")) []]) ∧
+  (ml_v_vals' (Prim SEqv) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SEqv")) []]) ∧
+  (ml_v_vals' (Prim CallCC) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "CallCC")) []]) ∧
+
+  (env_rel se env ∧
+  (m, ce) = cps_transform n e ∧
+  args = "xs" ++ toString m ∧
+  k = "k" ++ toString (m+1) ∧
+  (l, inner) = proc_ml (m+2) xs xp k args ce
+  ⇒
+  ml_v_vals' (Proc se xs xp e) $
+    Conv (SOME (scheme_typestamp "Proc")) [
+      Closure env k $ Fun args inner
+    ])
+’;
+
 Inductive e_ce_rel:
 [~Val:]
-  nsLookup env.v (Short valv) = SOME (ml_v_vals v) ∧
+  ml_v_vals' v mlv ∧
+  nsLookup env.v (Short valv) = SOME (mlv) ∧
   nsLookup env.v (Short var) = SOME kv ∧
   valv ≠ var
   ⇒
   e_ce_rel (Val v) var env kv $ App Opapp [Var (Short var); Var (Short valv)]
 [~Exp:]
   (m, ce) = cps_transform n e ∧
-  nsLookup env.v (Short var) = SOME kv
+  nsLookup env.v (Short var) = SOME kv ∧
+  scheme_env env
   ⇒
   e_ce_rel (Exp e) var env kv $ App Opapp [ce; Var (Short var)]
 [~Exception:]
@@ -351,16 +338,6 @@ Inductive e_ce_rel:
     Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]
 End
 
-Definition cconses_def[simp]:
-  cconses = ["SNum"; "SBool"; "True"; "False";
-    "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
-    "[]"]
-End
-
-Definition vconses_def[simp]:
-  vconses = ["sadd"; "smul"; "sminus"; "seqv"; "throw"; "callcc"; "app"]
-End
-
 Definition cps_app_ts_def:
   cps_app_ts n (e::es) = (let
     (m, ce) = cps_transform n e;
@@ -384,6 +361,10 @@ Inductive cont_rel:
   (n', ct) = cps_transform n te ∧
   (m', cf) = cps_transform m fe ∧
   scheme_env env ∧
+  env_rel se env ∧
+  ¬ MEM var vconses ∧
+  ¬ MEM t vconses ∧
+  (∀ x . t ≠ "s" ++ x) ∧
   var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
@@ -398,11 +379,13 @@ Inductive cont_rel:
   nsLookup env.v (Short var) = SOME kv ∧
   (m, ce) = cps_transform_app n (Var (Short t)) [] es (Var (Short var)) ∧
   scheme_env env ∧
+  env_rel se env ∧
   ¬ MEM var vconses ∧
   ¬ MEM t vconses ∧
   ts = cps_app_ts n es ∧
   ¬ MEM var ts ∧
   ¬ MEM t ts ∧
+  (∀ x . t ≠ "s" ++ x) ∧
   var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
@@ -413,9 +396,12 @@ Inductive cont_rel:
   nsLookup env.v (Short var) = SOME kv ∧
   (m, ce) = cps_transform_app n (Var (Short fnt))
     (Var (Short t) :: MAP (Var o Short) ts) es (Var (Short var)) ∧
-  nsLookup env.v (Short fnt) = SOME (ml_v_vals fn) ∧
-  LIST_REL (λ x v . nsLookup env.v (Short x) = SOME (ml_v_vals v)) ts vs ∧
+  ml_v_vals' fn mlfn ∧
+  nsLookup env.v (Short fnt) = SOME mlfn ∧
+  LIST_REL ml_v_vals' vs mlvs ∧
+  LIST_REL (λ x mlv . nsLookup env.v (Short x) = SOME mlv) ts mlvs ∧
   scheme_env env ∧
+  env_rel se env ∧
   ALL_DISTINCT ts ∧
   ¬ MEM var vconses ∧
   ¬ MEM fnt vconses ∧
@@ -429,6 +415,7 @@ Inductive cont_rel:
   ¬ MEM var ts' ∧
   ¬ MEM fnt ts' ∧
   ¬ MEM t ts' ∧
+  (∀ x . t ≠ "s" ++ x) ∧
   var ≠ fnt ∧
   var ≠ t ∧
   fnt ≠ t
@@ -453,14 +440,48 @@ Proof
   >> simp[Ntimes evaluate_def 2, nsOptBind_def]
   >> irule_at (Pos hd) EQ_REFL
   >> irule_at Any EQ_REFL
+  >> pop_assum $ irule_at (Pos hd) o GSYM
   >> simp[nsLookup_def, Once cont_rel_cases]
+  >> gvs[scheme_env_def]
   >> metis_tac[]
 QED
 
 (*
 open scheme_proofsTheory;
+open scheme_parsingTheory;
 *)
 
+Theorem app = SRULE [Ntimes evaluate_def 45, do_opapp_def, nsOptBind_def, dec_clock_def,
+  do_con_check_def, build_conv_def] $
+  RESTR_EVAL_CONV [“evaluate”, “scheme_env7”]
+    “evaluate <|clock:=999;refs:=[]|> scheme_env7 [
+      compile_scheme_prog $ OUTR $ parse_to_ast
+      "((lambda (x y) (lambda (z) y)) 1 2)"
+    ]”;
+
+Theorem stuck = SRULE [Ntimes evaluate_def 45, do_opapp_def, nsOptBind_def, dec_clock_def,
+  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
+  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
+  same_type_def, same_ctor_def, pat_bindings_def] app;
+
+Theorem stuck_again = SRULE [Ntimes evaluate_def 12, do_opapp_def, nsOptBind_def, dec_clock_def,
+  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
+  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
+  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
+  Once LET_DEF] stuck;
+
+Theorem more = SRULE [Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def, dec_clock_def,
+  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
+  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
+  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
+  Once LET_DEF] stuck_again;
+  
+SRULE [evaluate_def, do_opapp_def, nsOptBind_def, dec_clock_def,
+  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
+  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
+  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
+  Once LET_DEF] more;
+
 Theorem str_not_num:
   ∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str
 Proof
@@ -520,10 +541,10 @@ Proof
   >> simp[]
 QED
 
-Definition vcons_list_def:
-  vcons_list [] = Conv (SOME (TypeStamp "[]" 1)) [] ∧
-  vcons_list (v::vs) = Conv (SOME (TypeStamp "::" 1)) [v; vcons_list vs]
-End
+Theorem vcons_list_def[allow_rebind] = SRULE [] $ Define ‘
+  vcons_list [] = Conv (SOME (scheme_typestamp "[]")) [] ∧
+  vcons_list (v::vs) = Conv (SOME (scheme_typestamp "::")) [v; vcons_list vs]
+’;
 
 Theorem cons_list_val:
   ∀ st env ts vs .
@@ -549,12 +570,29 @@ Proof
   Induct >> simp[]
 QED
 
+Theorem LIST_REL_SNOC_ind:
+  ∀R LIST_REL'.
+    LIST_REL' [] [] ∧
+    (∀h1 h2 t1 t2.
+      R h1 h2 ∧ LIST_REL' t1 t2 ⇒ LIST_REL' (SNOC h1 t1) (SNOC h2 t2)) ⇒
+    ∀a0 a1. LIST_REL R a0 a1 ⇒ LIST_REL' a0 a1
+Proof
+  strip_tac >> strip_tac >> strip_tac
+  >> Induct_on ‘a0’ using SNOC_INDUCT
+  >> Induct_on ‘a1’ using SNOC_INDUCT
+  >- simp[]
+  >- simp[EVERY2_LENGTH]
+  >- simp[EVERY2_LENGTH]
+  >> pop_assum kall_tac
+  >> simp[LIST_REL_SNOC]
+QED
+
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
   cont_rel k kv ∧
   e_ce_rel e var mlenv kv mle ∧
-  scheme_env mlenv
+  env_rel env mlenv
   ⇒
   ∃ ck st' mlenv' var' kv' mle' .
     evaluate (st with clock:=ck) mlenv [mle]
@@ -562,6 +600,7 @@ Theorem myproof:
     evaluate st' mlenv' [mle'] ∧
     cont_rel k' kv' ∧
     e_ce_rel e' var' mlenv' kv' mle' ∧
+    env_rel env' mlenv' ∧
     st'.clock ≤ ck ∧
     (k ≠ [] ⇒ st'.clock < ck)
 Proof
@@ -572,117 +611,109 @@ Proof
       simp[step_def, return_def]
       >> rw[]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[]
+      >> simp[env_rel_cases, FEVERY_FEMPTY]
       >> metis_tac[]
     )
     >> PairCases_on ‘h’
     >> Cases_on ‘∃ te fe . h1 = CondK te fe’ >- (
       gvs[]
       >> simp[step_def, return_def]
-      >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
-        v = Prim SEqv ∨ v = Prim CallCC ∨
-        (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’
-      (*Only covering cases supported by to_ml_vals,
-      but in theory should work for any vals*)
-      >- (
-        simp[Once e_ce_rel_cases, Once cont_rel_cases]
-        >> simp[oneline ml_v_vals_def]
-        >> every_case_tac
-        >> gvs[]
-        >> rpt strip_tac
-        >> qrefine ‘ck+1’
-        >> simp[SimpLHS, Ntimes evaluate_def 6, do_con_check_def,
-          build_conv_def, scheme_env_def, do_opapp_def,
-        can_pmatch_all_def, pmatch_def, dec_clock_def]
-        >> qpat_assum ‘scheme_env env’ $ simp o curry ((::) o swap) [
-            same_type_def, same_ctor_def, do_opapp_def,
-            evaluate_match_def, pmatch_def, pat_bindings_def]
-          o SRULE [scheme_env_def]
-        >> irule_at (Pos hd) EQ_REFL
-        >> gvs[]
-        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-        >> simp[Once e_ce_rel_cases]
-        >> metis_tac[]
-      )
-      >> cheat
+      >>simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> simp[Once ml_v_vals'_cases]
+      >> rpt strip_tac
+      >> gvs[]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_con_check_def,
+        build_conv_def, scheme_env_def, do_opapp_def,
+      can_pmatch_all_def, pmatch_def, dec_clock_def]
+      >> qpat_assum ‘scheme_env env''’ $ simp o curry ((::) o swap) [
+          same_type_def, same_ctor_def, do_opapp_def,
+          evaluate_match_def, pmatch_def, pat_bindings_def]
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> gvs[]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases]
+      >> gvs[scheme_env_def, env_rel_cases]
+      >> metis_tac[]
     )
     >> Cases_on ‘h1 = ApplyK NONE []’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases, Once cont_rel_cases]
-      >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
-        v = Prim SEqv ∨ v = Prim CallCC ∨
-        (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’
-      >- (
-        simp[oneline ml_v_vals_def]
-        >> rpt strip_tac
-        >> every_case_tac
-        >> gvs[application_def, sadd_def, smul_def, sminus_def,
-          seqv_def, cps_transform_def, cons_list_def]
-        >> qrefine ‘ck+2’
-        >> simp[SimpLHS, evaluate_def, do_con_check_def,
-          build_conv_def, do_opapp_def, dec_clock_def]
-        >> qpat_assum ‘scheme_env env’ $ simp o single
-          o SRULE [scheme_env_def]
-        >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-        >> qrefine ‘ck+1’
-        >> simp[Ntimes evaluate_def 3, dec_clock_def]
-        >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-          same_type_def, same_ctor_def, evaluate_match_def,
-          pat_bindings_def]
-        >~ [‘Litv (IntLit i)’] >- (
-          qrefine ‘ck+1’
-          >> simp[Once evaluate_def]
-          >> irule_at (Pos hd) EQ_REFL
-          >> simp[Once e_ce_rel_cases]
-          >> metis_tac[]
-        )
-        >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
-          Conv (Some (TypeStamp "True" _)) []
-        ])’] >- (
-          qrefine ‘ck+1’
-          >> simp[Once evaluate_def]
-          >> irule_at (Pos hd) EQ_REFL
-          >> simp[Once e_ce_rel_cases]
-          >> metis_tac[]
-        )
-        >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
-          Conv (Some (TypeStamp "False" _)) []
-        ])’] >- (
-          qrefine ‘ck+1’
-          >> simp[Once evaluate_def]
-          >> irule_at (Pos hd) EQ_REFL
-          >> simp[Once e_ce_rel_cases]
-          >> metis_tac[]
-        )
-        >> qrefine ‘ck+2’
-        >> simp[evaluate_def]
-        >> simp[do_opapp_def,
-        Once find_recfun_def, Once build_rec_env_def]
-        >> simp[Ntimes evaluate_def 4, dec_clock_def]
-        >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-          same_type_def, same_ctor_def, evaluate_match_def,
-          pat_bindings_def]
-        >~ [‘"SAdd"’] >- (
-          qrefine ‘ck+1’
-          >> simp[Ntimes evaluate_def 3, nsOptBind_def,
-            do_con_check_def, build_conv_def]
-          >> irule_at (Pos hd) EQ_REFL
-          >> simp[Once e_ce_rel_cases]
-          >> simp[ml_v_vals_def]
-        )
-        >~ [‘"SMul"’] >- (
-          qrefine ‘ck+1’
-          >> simp[Ntimes evaluate_def 3, nsOptBind_def,
-            do_con_check_def, build_conv_def]
-          >> irule_at (Pos hd) EQ_REFL
-          >> simp[Once e_ce_rel_cases]
-          >> simp[ml_v_vals_def]
-        )
+      >> simp[Once ml_v_vals'_cases]
+      >> rpt strip_tac
+      >> gvs[application_def, sadd_def, smul_def, sminus_def,
+        seqv_def, cps_transform_def, cons_list_def]
+      >> qrefine ‘ck+2’
+      >> simp[SimpLHS, evaluate_def, do_con_check_def,
+        build_conv_def, do_opapp_def, dec_clock_def]
+      >> qpat_assum ‘scheme_env env''’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 3, dec_clock_def]
+      >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def]
+      >~ [‘Litv (IntLit i)’] >- (
+        qrefine ‘ck+1’
+        >> simp[Once evaluate_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
+      >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+        Conv (Some (TypeStamp "True" _)) []
+      ])’] >- (
+        qrefine ‘ck+1’
+        >> simp[Once evaluate_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
+      >~ [‘SOME (Conv (SOME (TypeStamp "SBool" _)) [
+        Conv (Some (TypeStamp "False" _)) []
+      ])’] >- (
+        qrefine ‘ck+1’
+        >> simp[Once evaluate_def]
         >> irule_at (Pos hd) EQ_REFL
         >> simp[Once e_ce_rel_cases]
-        >> metis_tac[]
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
       )
-      >> cheat
+      >> qrefine ‘ck+2’
+      >> simp[evaluate_def]
+      >> simp[do_opapp_def,
+      Once find_recfun_def, Once build_rec_env_def]
+      >> simp[Ntimes evaluate_def 4, dec_clock_def]
+      >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def]
+      >~ [‘"SAdd"’] >- (
+        qrefine ‘ck+1’
+        >> simp[Ntimes evaluate_def 3, nsOptBind_def,
+          do_con_check_def, build_conv_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
+      >~ [‘"SMul"’] >- (
+        qrefine ‘ck+1’
+        >> simp[Ntimes evaluate_def 3, nsOptBind_def,
+          do_con_check_def, build_conv_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
+      >~ [‘proc_ml’] >- cheat
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> simp[env_rel_cases, FEVERY_FEMPTY]
+      >> last_assum $ irule_at Any
     )
     >> Cases_on ‘h1 = ApplyK (SOME (fn, vs)) []’ >- (
       gvs[]
@@ -694,25 +725,24 @@ Proof
       >- (
         drule_then (simp o single) $
           DISCH (hd $ hyp $ oneline ml_v_vals_def) $ oneline ml_v_vals_def
+        >> simp[Once ml_v_vals'_cases]
         >> rpt strip_tac
-        >> every_case_tac
         >> gvs[application_def, sadd_def, smul_def, sminus_def,
           seqv_def, cps_transform_def, cons_list_def]
-        (*SAdd cas*)
-        >- (
+        >~ [‘"SAdd"’] >- (
           qrefine ‘ck+1’
           >> simp[evaluate_def, do_con_check_def,
             build_conv_def, do_opapp_def, dec_clock_def]
-          >> qsuff_tac ‘scheme_env env ∧ ¬ MEM t' vconses ⇒ scheme_env (env with v:= nsBind t'
-            (ml_v_vals v) env.v)’
+          >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
+            mlv env''.v)’
           >- (
             simp[] >> strip_tac
-            >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env with v:= nsBind t' (ml_v_vals v)
-            env.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (MAP ml_v_vals (v::vs)))’ >- (
+            >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
+            env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
               strip_tac
               >> drule_all_then assume_tac cons_list_val
               >> gvs[]
-              >> qpat_assum ‘scheme_env env’ $ simp o single o SRULE [scheme_env_def]
+              >> qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
               >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
               >> qrefine ‘ck+3’
               >> simp[Ntimes evaluate_def 3]
@@ -734,18 +764,20 @@ Proof
               >> pop_assum $ simp o single o GSYM
               >> qid_spec_tac ‘n’
               >> pop_assum kall_tac
-              >> rpt $ qpat_x_assum ‘LIST_REL _ _ _’ kall_tac
-              >> Induct_on ‘vs’ using SNOC_INDUCT >- (
-                rpt strip_tac
-                >> simp[ml_v_vals_def, vcons_list_def]
+              >> rpt $ qpat_x_assum ‘LIST_REL _ ts _’ kall_tac
+              >> qpat_assum ‘LIST_REL _ _ _’ mp_tac
+              >> qid_spec_tac ‘mlvs’
+              >> qid_spec_tac ‘vs’
+              >> ho_match_mp_tac LIST_REL_SNOC_ind
+              >> rpt strip_tac >- (
+                gvs[Once ml_v_vals'_cases, vcons_list_def]
                 >> qrefine ‘ck+1’
                 >> simp[Ntimes evaluate_def 2]
                 >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
                   pat_bindings_def]
-                >> Cases_on ‘∃ m . v = SNum m’ >- (
-                  gvs[ml_v_vals_def]
-                  >> qrefine ‘ck+3’
+                >~ [‘SNum m’] >- (
+                  qrefine ‘ck+3’
                   >> simp[evaluate_def, do_app_def, do_opapp_def, dec_clock_def]
                   >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                     same_type_def, same_ctor_def, evaluate_match_def,
@@ -761,29 +793,23 @@ Proof
                   >> simp[sadd_def]
                   >> irule_at (Pos hd) EQ_REFL
                   >> last_assum $ irule_at (Pos hd)
-                  >> simp[Once e_ce_rel_cases, ml_v_vals_def, opn_lookup_def]
+                  >> simp[Once e_ce_rel_cases, opn_lookup_def,
+                    env_rel_cases, FEVERY_FEMPTY, Once ml_v_vals'_cases]
                   >> simp[INT_ADD_COMM]
                 )
-                >> Cases_on ‘v = Prim SAdd ∨ v = Prim SMul ∨ v = Prim SMinus ∨
-                  v = Prim SEqv ∨ v = Prim CallCC ∨
-                  (∃n. v = SNum n) ∨ v = SBool T ∨ v = SBool F’ >- (
-                  simp[oneline ml_v_vals_def]
-                  >> every_case_tac
-                  >> gvs[]
-                  >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
-                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                    same_type_def, same_ctor_def, evaluate_match_def,
-                    pat_bindings_def, do_con_check_def, build_conv_def]
-                  >> irule_at (Pos hd) EQ_REFL
-                  >> last_assum $ irule_at (Pos hd)
-                  >> simp[Once e_ce_rel_cases, sadd_def]
-                ) >> cheat
+                >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def]
+                >> irule_at (Pos hd) EQ_REFL
+                >> last_assum $ irule_at (Pos hd)
+                >> simp[Once e_ce_rel_cases, sadd_def,
+                  env_rel_cases, FEVERY_FEMPTY]
               )
-              >> rpt strip_tac
-              >> gvs[MAP_SNOC, REVERSE_SNOC, vcons_list_def]
-              >> Cases_on ‘∃ m . x = SNum m’ >- (
-                gvs[ml_v_vals_def]
-                >> simp[evaluate_def, do_opapp_def, do_app_def,
+              >> qpat_assum ‘ml_v_vals' h1 h2’ $ assume_tac o SRULE [Once ml_v_vals'_cases]
+              >> gvs[REVERSE_SNOC, vcons_list_def]
+              >~ [‘SNum m’] >- (
+                simp[evaluate_def, do_opapp_def, do_app_def,
                   opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
                   pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
@@ -795,34 +821,27 @@ Proof
                   by (simp[state_component_equality])
                 >> simp[]
                 >> pop_assum kall_tac
-                >> pop_assum $ qspec_then ‘n + m'’ mp_tac
+                >> pop_assum $ qspec_then ‘n + m’ mp_tac
                 >> strip_tac
                 >> qpat_assum ‘evaluate _ _ _ = evaluate _ _ _’ $ irule_at (Pos hd)
                 >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
                 >> simp[Once INT_ADD_COMM]
                 >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
               )
-              >> Cases_on ‘x = Prim SAdd ∨ x = Prim SMul ∨ x = Prim SMinus ∨
-                x = Prim SEqv ∨ x = Prim CallCC ∨
-                (∃n. x = SNum n) ∨ x = SBool T ∨ x = SBool F’ >- (
-                drule_then (simp o single) $
-                  DISCH (hd $ hyp $ oneline ml_v_vals_def) $ oneline ml_v_vals_def
-                >> every_case_tac
-                >> gvs[]
-                >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
-                  opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
-                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                >> simp[sadd_def, Once e_ce_rel_cases]
-                >> irule_at (Pos hd) EQ_REFL
-                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-                >> simp[]
-              ) >> cheat
+              >> gvs[]
+              >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+                opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+              >> simp[sadd_def, Once e_ce_rel_cases]
+              >> irule_at (Pos hd) EQ_REFL
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[env_rel_cases, FEVERY_FEMPTY]
             )
-            >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,vs))’ >- (
-              simp[ml_v_vals_def, LIST_REL_MAP2]
-              >> strip_tac
+            >> simp[]
+            >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
+              strip_tac
               >> drule_then assume_tac EVERY2_LENGTH
               >> drule_all $ iffRL EVERY2_EVERY
               >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
@@ -853,10 +872,11 @@ Proof
         irule_at (Pos $ el 2) o GSYM
       >> simp[Once cont_rel_cases]
       >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-      >> qpat_assum ‘scheme_env env’ $ simp
+      >> qpat_assum ‘scheme_env env'’ $ simp
         o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
       >> irule_at Any str_not_num
       >> simp[isDigit_def, t_in_ts]
+      >> gvs[env_rel_cases]
     )
     >> Cases_on ‘∃ e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
       gvs[]
@@ -878,13 +898,14 @@ Proof
         o SIMP_RULE std_ss [Ntimes (GSYM MAP) 2, MAP_o]
       >> irule_at Any EQ_REFL
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> qpat_assum ‘scheme_env env’ $ simp
+      >> qpat_assum ‘scheme_env env'’ $ simp
         o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
       >> irule_at Any str_not_num
       >> simp[isDigit_def, t_in_ts]
       >> gvs[EVERY_CONJ]
       >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
         o SRULE [EVERY_MEM]
+      >> gvs[env_rel_cases]
       >> irule EVERY2_MEM_MONO
       >> qpat_assum ‘LIST_REL _ _ _’ $ irule_at (Pos last)
       >> qpat_assum ‘LIST_REL _ _ _’ $ assume_tac o cj 1
@@ -894,6 +915,7 @@ Proof
       >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
       >> simp[]
       >> strip_tac
+      >> qpat_assum ‘ml_v_vals' _ _’ $ irule_at (Pos hd)
       >> qsuff_tac ‘x0 ≠ t'’
       >> strip_tac
       >> gvs[]
@@ -909,6 +931,7 @@ Proof
       >> Cases_on ‘l’
       >> simp[lit_to_val_def, to_ml_vals_def]
       >> TRY CASE_TAC (*for Prim cases*)
+      >> TRY (Cases_on ‘b’) (*for Bool cases*)
       >> gvs[lit_to_val_def, to_ml_vals_def]
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
@@ -916,7 +939,8 @@ Proof
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases, ml_v_vals_def]
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+      >> gvs[env_rel_cases]
     )
     >~ [‘Cond c te fe’] >- (
       simp[cps_transform_def]
@@ -929,7 +953,9 @@ Proof
       >> simp[Once e_ce_rel_cases]
       >> irule_at Any EQ_REFL
       >> simp[Once cont_rel_cases]
-      >> gvs[scheme_env_def]
+      >> gvs[scheme_env_def, env_rel_cases]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def]
       >> metis_tac[]
     )
     >~ [‘Apply fn es’] >- (
@@ -947,11 +973,27 @@ Proof
       >> simp[Once cont_rel_cases]
       >> pop_assum $ irule_at (Pos $ el 3) o GSYM
       >> last_assum $ irule_at (Pos hd)
-      >> qpat_assum ‘scheme_env mlenv’ $ simp
-        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> gvs[scheme_env_def, env_rel_cases]
       >> irule_at (Pos hd) str_not_num
       >> simp[isDigit_def, k_in_ts, t_in_ts]
     )
+    >~ [‘Lambda xs xp e’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 7, do_opapp_def,
+        nsOptBind_def, dec_clock_def, do_con_check_def,
+        build_conv_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> last_assum $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+      >> gvs[env_rel_cases]
+      >> pop_assum $ irule_at (Pos last) o GSYM
+      >> pop_assum $ irule_at Any o GSYM
+    )
     >> cheat
   )
   >> cheat
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 8c0a8b7a25..f8e7bbf436 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -96,8 +96,9 @@ Definition cps_transform_def:
     (l, inner) = proc_ml (m+2) xs xp k args ce;
     k' = "k" ++ toString l;
   in
-    (l+1, Fun k' $ App Opapp [Var (Short k');
-      Con (SOME $ Short "Proc") [Fun k $ Fun args inner]])) ∧
+    (l+1, Fun k' $ Let (SOME "v")
+      (Con (SOME $ Short "Proc") [Fun k $ Fun args inner]) $
+      App Opapp [Var (Short k'); Var (Short "v")])) ∧
 
   cps_transform n (Begin e es) = (let
     (m, ce) = cps_transform n e;
@@ -195,15 +196,6 @@ Termination
   >> Cases >> rw[scheme_astTheory.exp_size_def]
 End
 
-Definition scheme_cont_def:
-  scheme_cont [] = Fun "t" $ Var (Short "t") ∧
-  scheme_cont (k:: ks) = SND $ refunc_cont 0 k (scheme_cont ks)
-End
-
-Definition exp_with_cont_def:
-  exp_with_cont k e = App Opapp [SND $ cps_transform 0 e; scheme_cont k]
-End
-
 Definition compile_scheme_prog_def:
   compile_scheme_prog p = let
     (n, cp) = cps_transform 0 p

From 23457f39025956f4dc837bac473611e363d0d7e0 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Fri, 11 Apr 2025 02:00:56 +0100
Subject: [PATCH 073/100] proof of Scheme semantics progress, adjusted begin
 expression semantics, no build

---
 compiler/scheme/scheme_astScript.sml       | 117 ++-
 compiler/scheme/scheme_proofsScript.sml    | 272 +++---
 compiler/scheme/scheme_semanticsScript.sml | 927 ++++++++++++++++++++-
 3 files changed, 1099 insertions(+), 217 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 09c988904e..8b8228ecbd 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -24,7 +24,7 @@ Datatype:
       | Cond exp exp exp
       | Ident mlstring
       | Lambda (mlstring list) (mlstring option) exp
-      | Begin exp (exp list)
+      | Begin (exp list) exp
       | Set mlstring exp
       | Letrec ((mlstring # exp) list) exp
 End
@@ -33,7 +33,7 @@ Datatype:
   (*Contexts for small-step operational semantics*)
   cont = ApplyK ((val # val list) option) (exp list)
        | CondK exp exp
-       | BeginK (exp list)
+       | BeginK (exp list) exp
        | SetK mlstring
 ;
   val = Prim prim | SNum int | Wrong string | SBool bool
@@ -49,39 +49,92 @@ Definition lit_to_val_def:
   lit_to_val (LitBool b) = SBool b
 End
 
-Definition static_scoping_check_def:
-  (static_scoping_check env (Cond c t f) ⇔
-    static_scoping_check env c ∧
-    static_scoping_check env t ∧
-    static_scoping_check env f) ∧
-  (static_scoping_check env (Apply e args) ⇔
-    static_scoping_check env e ∧
-    EVERY (static_scoping_check env) args) ∧
-  (static_scoping_check env (Set _ e) ⇔ static_scoping_check env e) ∧
-  (static_scoping_check env (Begin e es) ⇔
-    static_scoping_check env e ∧
-    EVERY (static_scoping_check env) es) ∧
-  (static_scoping_check env (Lambda xs xp e) ⇔ let xs' = case xp of
-    | NONE => xs
-    | SOME x => x::xs
-    in ALL_DISTINCT xs' ∧ static_scoping_check (env ∪ set xs') e) ∧
-  (static_scoping_check env (Letrec xes e) ⇔ let xs = MAP FST xes
-    in ALL_DISTINCT xs ∧ let env' = env ∪ set xs
-    in static_scoping_check env' e ∧
-       EVERY (static_scoping_check env') (MAP SND xes)) ∧
-  (static_scoping_check env (Ident x) ⇔ env x) ∧
-  (static_scoping_check _ _ ⇔ T)
+Inductive static_scope:
+[~Lit:]
+  static_scope env (Lit lit)
+[~Cond:]
+  static_scope env c ∧
+  static_scope env t ∧
+  static_scope env f
+  ⇒
+  static_scope env (Cond c t f)
+[~Apply:]
+  static_scope env fn ∧
+  EVERY (static_scope env) es
+  ⇒
+  static_scope env (Apply fn es)
+[~Begin:]
+  EVERY (static_scope env) es ∧
+  static_scope env e
+  ⇒
+  static_scope env (Begin es e)
+[~Lambda_NONE:]
+  ALL_DISTINCT xs ∧
+  static_scope (env ∪ set xs) e
+  ⇒
+  static_scope env (Lambda xs NONE e)
+[~Lambda_SOME:]
+  ALL_DISTINCT (x::xs) ∧
+  static_scope (env ∪ set (x::xs)) e
+  ⇒
+  static_scope env (Lambda xs (SOME x) e)
+[~Letrec:]
+  ALL_DISTINCT (MAP FST bs) ∧
+  EVERY (static_scope (env ∪ set (MAP FST bs))) (MAP SND bs) ∧
+  static_scope (env ∪ set (MAP FST bs)) e
+  ⇒
+  static_scope env (Letrec bs e)
+[~Ident:]
+  env x
+  ⇒
+  static_scope env (Ident x)
+[~Set:]
+  env x ∧
+  static_scope env e
+  ⇒
+  static_scope env (Set x e)
+End
+
+Definition exp_rec_def:
+  exp_rec (Lit l) = 1 ∧
+  exp_rec (Cond c t f) = exp_rec c + exp_rec t + exp_rec f ∧
+  exp_rec (Apply fn es) = exp_rec fn + SUM (MAP exp_rec es) ∧
+  exp_rec (Begin es e) = exp_rec e + SUM (MAP exp_rec es) ∧
+  exp_rec (Lambda xs xp e) = exp_rec e ∧
+  exp_rec (Letrec bs e) = exp_rec e + SUM (MAP (exp_rec o SND) bs)∧
+  exp_rec (Ident x) = 1 ∧
+  exp_rec (Set x e) =  exp_rec e
 Termination
-  WF_REL_TAC ‘measure $ exp_size o SND’
-  >> Induct_on ‘xes’ >- (rw[])
-  >> Cases_on ‘h’
-  >> simp[snd (TypeBase.size_of “:exp”), list_size_def, snd (TypeBase.size_of “:'a # 'b”)]
-  >> rpt strip_tac >- (rw[])
-  >> last_x_assum $ qspecl_then [‘e’, ‘a’] $ imp_res_tac
-  >> first_x_assum $ qspec_then ‘e’ $ assume_tac
-  >> rw[]
+  WF_REL_TAC ‘measure exp_size’
 End
 
+Theorem static_scope_mono:
+  ∀ env e env' .
+    env ⊆ env' ∧ static_scope env e ⇒ static_scope env' e
+Proof
+  simp[Once CONJ_COMM]
+  >> simp[GSYM AND_IMP_INTRO]
+  >> simp[GSYM PULL_FORALL]
+  >> ho_match_mp_tac static_scope_ind
+  >> rpt strip_tac
+  >~ [‘Letrec bs e’] >- (
+    simp[Once static_scope_cases]
+    >> ‘env ∪ set (MAP FST bs) ⊆ env' ∪ set (MAP FST bs)’
+      by gvs[SUBSET_UNION_ABSORPTION, UNION_ASSOC]
+    >> qpat_x_assum ‘∀ _._ ⇒ _’ $ irule_at (Pos last)
+    >> simp[]
+    >> irule EVERY_MONOTONIC
+    >> qpat_x_assum ‘EVERY _ _’ $ irule_at (Pos last)
+    >> rpt strip_tac
+    >> gvs[]
+  )
+  >> simp[Once static_scope_cases]
+  >> gvs[SUBSET_DEF, SPECIFICATION]
+  >> irule EVERY_MONOTONIC
+  >> qpat_assum ‘EVERY _ _’ $ irule_at (Pos last)
+  >> gvs[]
+QED
+
 val _ = export_theory();
 
 (*
diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index dd75b35ac5..b2e7ae4f21 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -248,44 +248,11 @@ Theorem scheme_typestamp_def[allow_rebind, simp] = SRULE [] $
   SIMP_CONV pure_ss [SimpRHS, scheme_typestamp_def, EVERY_DEF, cconses_def]
   “EVERY (λ x . scheme_typestamp x = scheme_typestamp x) cconses”;
 
-Definition ml_v_vals_def[nocompute]:
-  ml_v_vals v = case evaluate (<|clock:=0|> :num state)
-      scheme_env' [to_ml_vals v] of
-    | (st, Rval [mlv]) => mlv
-    | _ => ARB
-End
-
-Theorem ml_v_vals_def[allow_rebind, compute] = LIST_CONJ $
-  map (GEN_ALL o (REWR_CONV ml_v_vals_def THENC EVAL)) [
-    “ml_v_vals (Prim SAdd)”,
-    “ml_v_vals (Prim SMul)”,
-    “ml_v_vals (Prim SMinus)”,
-    “ml_v_vals (Prim SEqv)”,
-    “ml_v_vals (Prim CallCC)”,
-    “ml_v_vals (SNum n)”,
-    “ml_v_vals (SBool T)”,
-    “ml_v_vals (SBool F)”
-];
-
 Inductive env_rel:
-  FEVERY (λ (x, n). ∃ v.
-    nsLookup env.v (Short ("s" ++ explode x)) = SOME v) se
+  FEVERY (λ (x, n).
+    nsLookup env.v (Short ("s" ++ explode x)) = SOME (Loc T n)) se
   ⇒
-  env_rel se (env :v sem_env)
-End
-
-Inductive ml_v_vals':
-[~Proc:]
-  env_rel se env ∧
-  (m, ce) = cps_transform n e ∧
-  args = "xs" ++ toString m ∧
-  k = "k" ++ toString (m+1) ∧
-  (l, inner) = proc_ml (m+2) xs xp k args ce
-  ⇒
-  ml_v_vals' (Proc se xs xp e) $
-    Conv (SOME (TypeStamp "Proc" 4)) [
-      Closure env k $ Fun args inner
-    ]
+  env_rel se env
 End
 
 val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
@@ -475,7 +442,7 @@ Theorem more = SRULE [Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def, dec_cl
   Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
   same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
   Once LET_DEF] stuck_again;
-  
+
 SRULE [evaluate_def, do_opapp_def, nsOptBind_def, dec_clock_def,
   do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
   Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
@@ -618,7 +585,7 @@ Proof
     >> Cases_on ‘∃ te fe . h1 = CondK te fe’ >- (
       gvs[]
       >> simp[step_def, return_def]
-      >>simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> simp[Once ml_v_vals'_cases]
       >> rpt strip_tac
       >> gvs[]
@@ -719,141 +686,134 @@ Proof
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases]
-      >> Cases_on ‘fn = Prim SAdd ∨ fn = Prim SMul ∨ fn = Prim SMinus ∨
-        fn = Prim SEqv ∨ fn = Prim CallCC ∨
-        (∃n. fn = SNum n) ∨ fn = SBool T ∨ fn = SBool F’
-      >- (
-        drule_then (simp o single) $
-          DISCH (hd $ hyp $ oneline ml_v_vals_def) $ oneline ml_v_vals_def
-        >> simp[Once ml_v_vals'_cases]
-        >> rpt strip_tac
-        >> gvs[application_def, sadd_def, smul_def, sminus_def,
-          seqv_def, cps_transform_def, cons_list_def]
-        >~ [‘"SAdd"’] >- (
-          qrefine ‘ck+1’
-          >> simp[evaluate_def, do_con_check_def,
-            build_conv_def, do_opapp_def, dec_clock_def]
-          >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
-            mlv env''.v)’
-          >- (
-            simp[] >> strip_tac
-            >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
-            env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
-              strip_tac
-              >> drule_all_then assume_tac cons_list_val
-              >> gvs[]
-              >> qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-              >> qrefine ‘ck+3’
-              >> simp[Ntimes evaluate_def 3]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-              >> simp[Ntimes evaluate_def 3]
+      >> simp[Once ml_v_vals'_cases]
+      >> rpt strip_tac
+      >> gvs[application_def, sadd_def, smul_def, sminus_def,
+        seqv_def, cps_transform_def, cons_list_def]
+      >~ [‘"SAdd"’] >- (
+        qrefine ‘ck+1’
+        >> simp[evaluate_def, do_con_check_def,
+          build_conv_def, do_opapp_def, dec_clock_def]
+        >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
+          mlv env''.v)’
+        >- (
+          simp[] >> strip_tac
+          >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
+          env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
+            strip_tac
+            >> drule_all_then assume_tac cons_list_val
+            >> gvs[]
+            >> qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+3’
+            >> simp[Ntimes evaluate_def 3]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> simp[Ntimes evaluate_def 3]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes evaluate_def 7, do_opapp_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+2’
+            >> simp[Ntimes evaluate_def 2, dec_clock_def]
+            >> Cases_on ‘∃ (n:int) . n = 0’ >~ [‘¬∃n.n=0’] >- gvs[]
+            >> pop_assum mp_tac
+            >> strip_tac
+            >> pop_assum $ simp o single o GSYM
+            >> qid_spec_tac ‘n’
+            >> pop_assum kall_tac
+            >> rpt $ qpat_x_assum ‘LIST_REL _ ts _’ kall_tac
+            >> qpat_assum ‘LIST_REL _ _ _’ mp_tac
+            >> qid_spec_tac ‘mlvs’
+            >> qid_spec_tac ‘vs’
+            >> ho_match_mp_tac LIST_REL_SNOC_ind
+            >> rpt strip_tac >- (
+              gvs[Once ml_v_vals'_cases, vcons_list_def]
+              >> qrefine ‘ck+1’
+              >> simp[Ntimes evaluate_def 2]
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def]
-              >> simp[Ntimes evaluate_def 7, do_opapp_def]
-              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-              >> qrefine ‘ck+2’
-              >> simp[Ntimes evaluate_def 2, dec_clock_def]
-              >> Cases_on ‘∃ (n:int) . n = 0’ >~ [‘¬∃n.n=0’] >- gvs[]
-              >> pop_assum mp_tac
-              >> strip_tac
-              >> pop_assum $ simp o single o GSYM
-              >> qid_spec_tac ‘n’
-              >> pop_assum kall_tac
-              >> rpt $ qpat_x_assum ‘LIST_REL _ ts _’ kall_tac
-              >> qpat_assum ‘LIST_REL _ _ _’ mp_tac
-              >> qid_spec_tac ‘mlvs’
-              >> qid_spec_tac ‘vs’
-              >> ho_match_mp_tac LIST_REL_SNOC_ind
-              >> rpt strip_tac >- (
-                gvs[Once ml_v_vals'_cases, vcons_list_def]
-                >> qrefine ‘ck+1’
-                >> simp[Ntimes evaluate_def 2]
+              >~ [‘SNum m’] >- (
+                qrefine ‘ck+3’
+                >> simp[evaluate_def, do_app_def, do_opapp_def, dec_clock_def]
                 >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
                   pat_bindings_def]
-                >~ [‘SNum m’] >- (
-                  qrefine ‘ck+3’
-                  >> simp[evaluate_def, do_app_def, do_opapp_def, dec_clock_def]
-                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                    same_type_def, same_ctor_def, evaluate_match_def,
-                    pat_bindings_def]
-                  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                  >> simp[Ntimes evaluate_def 4]
-                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                    same_type_def, same_ctor_def, evaluate_match_def,
-                    pat_bindings_def]
-                  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                  >> simp[Ntimes evaluate_def 3, do_con_check_def,
-                  build_conv_def, nsOptBind_def]
-                  >> simp[sadd_def]
-                  >> irule_at (Pos hd) EQ_REFL
-                  >> last_assum $ irule_at (Pos hd)
-                  >> simp[Once e_ce_rel_cases, opn_lookup_def,
-                    env_rel_cases, FEVERY_FEMPTY, Once ml_v_vals'_cases]
-                  >> simp[INT_ADD_COMM]
-                )
-                >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
+                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+                >> simp[Ntimes evaluate_def 4]
                 >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def]
-                >> irule_at (Pos hd) EQ_REFL
-                >> last_assum $ irule_at (Pos hd)
-                >> simp[Once e_ce_rel_cases, sadd_def,
-                  env_rel_cases, FEVERY_FEMPTY]
-              )
-              >> qpat_assum ‘ml_v_vals' h1 h2’ $ assume_tac o SRULE [Once ml_v_vals'_cases]
-              >> gvs[REVERSE_SNOC, vcons_list_def]
-              >~ [‘SNum m’] >- (
-                simp[evaluate_def, do_opapp_def, do_app_def,
-                  opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+                  pat_bindings_def]
                 >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                >> qrefine ‘ck+3’
-                >> simp[Ntimes evaluate_def 2]
+                >> simp[Ntimes evaluate_def 3, do_con_check_def,
+                build_conv_def, nsOptBind_def]
                 >> simp[sadd_def]
-                >> ‘∀ ck . st with <|clock:=ck;refs:=st.refs;ffi:=st.ffi|> = st with clock:=ck’
-                  by (simp[state_component_equality])
-                >> simp[]
-                >> pop_assum kall_tac
-                >> pop_assum $ qspec_then ‘n + m’ mp_tac
-                >> strip_tac
-                >> qpat_assum ‘evaluate _ _ _ = evaluate _ _ _’ $ irule_at (Pos hd)
-                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-                >> simp[Once INT_ADD_COMM]
-                >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
+                >> irule_at (Pos hd) EQ_REFL
+                >> last_assum $ irule_at (Pos hd)
+                >> simp[Once e_ce_rel_cases, opn_lookup_def,
+                  env_rel_cases, FEVERY_FEMPTY, Once ml_v_vals'_cases]
+                >> simp[INT_ADD_COMM]
               )
-              >> gvs[]
-              >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+              >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def, do_con_check_def, build_conv_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> last_assum $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases, sadd_def,
+                env_rel_cases, FEVERY_FEMPTY]
+            )
+            >> qpat_assum ‘ml_v_vals' h1 h2’ $ assume_tac o SRULE [Once ml_v_vals'_cases]
+            >> gvs[REVERSE_SNOC, vcons_list_def]
+            >~ [‘SNum m’] >- (
+              simp[evaluate_def, do_opapp_def, do_app_def,
                 opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
               >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-              >> simp[sadd_def, Once e_ce_rel_cases]
-              >> irule_at (Pos hd) EQ_REFL
+              >> qrefine ‘ck+3’
+              >> simp[Ntimes evaluate_def 2]
+              >> simp[sadd_def]
+              >> ‘∀ ck . st with <|clock:=ck;refs:=st.refs;ffi:=st.ffi|> = st with clock:=ck’
+                by (simp[state_component_equality])
+              >> simp[]
+              >> pop_assum kall_tac
+              >> pop_assum $ qspec_then ‘n + m’ mp_tac
+              >> strip_tac
+              >> qpat_assum ‘evaluate _ _ _ = evaluate _ _ _’ $ irule_at (Pos hd)
               >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[env_rel_cases, FEVERY_FEMPTY]
+              >> simp[Once INT_ADD_COMM]
+              >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
             )
+            >> gvs[]
+            >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+              opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> simp[sadd_def, Once e_ce_rel_cases]
+            >> irule_at (Pos hd) EQ_REFL
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> simp[env_rel_cases, FEVERY_FEMPTY]
+          )
+          >> simp[]
+          >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
+            strip_tac
+            >> drule_then assume_tac EVERY2_LENGTH
+            >> drule_all $ iffRL EVERY2_EVERY
+            >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
+            >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
+            >> ho_match_mp_tac EVERY2_mono
             >> simp[]
-            >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
-              strip_tac
-              >> drule_then assume_tac EVERY2_LENGTH
-              >> drule_all $ iffRL EVERY2_EVERY
-              >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
-              >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
-              >> ho_match_mp_tac EVERY2_mono
-              >> simp[]
-            ) >> simp[EVERY_MEM] >> PairCases >> simp[]
-            >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
-            >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
-            >> strip_tac >> gvs[]
-          ) >> gvs[scheme_env_def]
-        ) >> cheat
+          ) >> simp[EVERY_MEM] >> PairCases >> simp[]
+          >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
+          >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
+          >> strip_tac >> gvs[]
+        ) >> gvs[scheme_env_def]
       ) >> cheat
     )
     >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
@@ -902,6 +862,7 @@ Proof
         o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
       >> irule_at Any str_not_num
       >> simp[isDigit_def, t_in_ts]
+      >> qpat_assum ‘LIST_REL _ vs _’ $ irule_at (Pos hd)
       >> gvs[EVERY_CONJ]
       >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
         o SRULE [EVERY_MEM]
@@ -915,7 +876,6 @@ Proof
       >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
       >> simp[]
       >> strip_tac
-      >> qpat_assum ‘ml_v_vals' _ _’ $ irule_at (Pos hd)
       >> qsuff_tac ‘x0 ≠ t'’
       >> strip_tac
       >> gvs[]
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 263a9d5ebd..aca260d3db 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -56,12 +56,12 @@ Definition fresh_loc_def:
 End
 
 Definition parameterize_def:
-  parameterize store ks env [] NONE e [] = (store, ks, env, Exp e) ∧
-  parameterize store ks env [] (SOME (l:mlstring)) e xs = (let (n, store') = fresh_loc store (SOME $ SList xs)
-    in (store', ks, (env |+ (l, n)), Exp e)) ∧
-  parameterize store ks env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store (SOME x)
-    in parameterize store' ks (env |+ (p, n)) ps lp e xs) ∧
-  parameterize store ks _ _ _ _ _ = (store, ks, FEMPTY, Exception $ strlit "Wrong number of arguments")
+  parameterize store env [] NONE e [] = (store, env, Exp e) ∧
+  parameterize store env [] (SOME (l:mlstring)) e xs = (let (n, store') = fresh_loc store (SOME $ SList xs)
+    in (store', (env |+ (l, n)), Exp e)) ∧
+  parameterize store env (p::ps) lp e (x::xs) = (let (n, store') = fresh_loc store (SOME x)
+    in parameterize store' (env |+ (p, n)) ps lp e xs) ∧
+  parameterize store _ _ _ _ _ = (store, FEMPTY, Exception $ strlit "Wrong number of arguments")
 End
 
 Definition application_def:
@@ -73,8 +73,8 @@ Definition application_def:
   | CallCC => case xs of
     | [v] => (store, (FEMPTY, ApplyK (SOME (v, [])) []) :: ks, FEMPTY, Val $ Throw ks)
     | _ => (store, ks, FEMPTY, Exception $ strlit "Arity mismatch")) ∧
-  application store ks (Proc env ps lp e) xs =
-    parameterize store ks env ps lp e xs ∧
+  application store ks (Proc env ps lp e) xs = (let (store', env', e') =
+    parameterize store env ps lp e xs in (store', ks, env', e')) ∧
   application store ks (Throw ks') xs = (case xs of
     | [v] => (store, ks', FEMPTY, Val v)
     | _ => (store, ks, FEMPTY, Exception $ strlit "Arity mismatch")) ∧
@@ -94,9 +94,9 @@ Definition return_def:
   return store ((env, CondK t f) :: ks) v = (if v = (SBool F)
     then (store, ks, env, Exp f) else (store, ks, env, Exp t)) ∧
 
-  return store ((env, BeginK es) :: ks) v = (case es of
-  | [] => (store, ks, env, Val v)
-  | e::es' => (store, (env, BeginK es') :: ks, env, Exp e)) ∧
+  return store ((env, BeginK es e) :: ks) v = (case es of
+  | [] => (store, ks, env, Exp e)
+  | e'::es' => (store, (env, BeginK es' e) :: ks, env, Exp e')) ∧
   return store ((env, SetK x) :: ks) v = (LUPDATE (SOME v) (env ' x) store, ks, env, Val $ Wrong "Unspecified")
 End
 
@@ -117,13 +117,14 @@ Definition step_def:
     | SOME v => Val v
     in (store, ks, env, ev)) ∧
   step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
-  step (store, ks, env, Exp $ Begin e es) = (store, (env, BeginK es) :: ks, env, Exp e) ∧
+  step (store, ks, env, Exp $ Begin es e) = (case es of
+  | [] => (store, ks, env, Exp e)
+  | e'::es' => (store, (env, BeginK es' e) :: ks, env, Exp e')) ∧
   step (store, ks, env, Exp $ Set x e) = (store, (env, SetK x) :: ks, env, Exp e) ∧
   (*There is a missing reinit check, though the spec says it is optional*)
-  step (store, ks, env, Exp $ Letrec bs e) = (case bs of
-  | [] => (store, ks, env, Exp e)
-  | (x, i)::bs' => let (store', env') = letrec_init store env (MAP FST bs)
-      in (store', (env', BeginK (SNOC e (MAP (UNCURRY Set) bs'))) :: ks, env', Exp $ Set x i)) ∧
+  step (store, ks, env, Exp $ Letrec bs e) = (let
+    (store', env') = letrec_init store env (MAP FST bs)
+      in (store', ks, env', Exp $ Begin (MAP (UNCURRY Set) bs) e)) ∧
 
   step (store, ks, env, Exception ex) = (store, [], env, Exception ex)
 End
@@ -133,6 +134,874 @@ Definition steps_def:
     else steps (n - 1) $ step t
 End
 
+Definition option_to_set_def:
+  option_to_set NONE = ∅ ∧
+  option_to_set (SOME x) = {x}
+End
+
+Inductive can_lookup:
+  FEVERY (λ (x, n). n < LENGTH store) env
+  ⇒
+  can_lookup env store
+End
+
+Inductive valid_val:
+[~val_SNum:]
+  valid_val store (SNum n)
+[~val_SBool:]
+  valid_val store (SBool b)
+[~val_Prim:]
+  valid_val store (Prim p)
+[~val_Wrong:]
+  valid_val store (Wrong w)
+[~val_SList:]
+  EVERY (valid_val store) vs
+  ⇒
+  valid_val store (SList vs)
+[~val_Proc_NONE:]
+  static_scope (FDOM env ∪ set xs) e ∧
+  can_lookup env store
+  ⇒
+  valid_val store (Proc env xs NONE e)
+[~val_Proc_SOME:]
+  static_scope (FDOM env ∪ set (x::xs)) e ∧
+  can_lookup env store
+  ⇒
+  valid_val store (Proc env xs (SOME x) e)
+[~val_Throw:]
+  valid_cont store ks
+  ⇒
+  valid_val store (Throw ks)
+
+[~cont_Id:]
+  valid_cont store []
+[~cont_CondK:]
+  static_scope (FDOM env) t ∧
+  static_scope (FDOM env) f ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, CondK t f)::ks)
+[~cont_ApplyK_NONE:]
+  EVERY (static_scope (FDOM env)) es ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, ApplyK NONE es)::ks)
+[~cont_ApplyK_SOME:]
+  valid_val store fn ∧
+  EVERY (valid_val store) vs ∧
+  EVERY (static_scope (FDOM env)) es ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, ApplyK (SOME (fn, vs)) es)::ks)
+[~cont_BeginK:]
+  EVERY (static_scope (FDOM env)) es ∧
+  static_scope (FDOM env) e ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, BeginK es e)::ks)
+[~cont_SetK:]
+  (FDOM env) x ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, SetK x)::ks)
+End
+
+Inductive valid_state:
+[~Val:]
+  valid_val store v ∧
+  valid_cont store ks ∧
+  can_lookup env store ∧
+  EVERY (OPTION_ALL (valid_val store)) store
+  ⇒
+  valid_state store ks env (Val v)
+[~Exp:]
+  static_scope (FDOM env) e ∧
+  valid_cont store ks ∧
+  can_lookup env store ∧
+  EVERY (OPTION_ALL (valid_val store)) store
+  ⇒
+  valid_state store ks env (Exp e)
+[~Exception:]
+  valid_state store ks env (Exception s)
+End
+
+Theorem FEVERY_MONO:
+  ∀ P Q f .
+    (∀ x . P x ⇒ Q x) ∧ FEVERY P f
+    ⇒
+    FEVERY Q f
+Proof
+  Induct_on ‘f’
+  >> rpt strip_tac >- simp[FEVERY_FEMPTY]
+  >> last_x_assum $ drule_then assume_tac
+  >> gvs[FEVERY_FUPDATE]
+  >> qsuff_tac ‘DRESTRICT f (COMPL {x}) = f’ >- (strip_tac >> gvs[])
+  >> simp[EQ_FDOM_SUBMAP, DRESTRICT_DEF, EXTENSION]
+  >> strip_tac
+  >> iff_tac
+  >> rpt strip_tac
+  >> gvs[]
+QED
+
+Theorem EVERY_OPTION_ALL_MAP_SOME:
+  ∀ f xs . EVERY f xs ⇒ EVERY (OPTION_ALL f) (MAP SOME xs)
+Proof
+  strip_tac
+  >> Induct
+  >> simp[]
+QED
+
+Theorem EVERY_TAKE:
+  ∀ f n xs . EVERY f xs ⇒ EVERY f (TAKE n xs)
+Proof
+  gen_tac
+  >> Induct_on ‘xs’
+  >> Cases_on ‘n’
+  >> simp[]
+QED
+
+Theorem valid_larger_store:
+  ∀ (store :'a list) (store' :'a list) .
+    LENGTH store ≤ LENGTH store'
+    ⇒
+    (∀ v .
+      valid_val store v
+      ⇒
+      valid_val store' v) ∧
+    ∀ ks .
+      valid_cont store ks
+      ⇒
+      valid_cont store' ks
+Proof
+  rpt gen_tac >> strip_tac
+  >> ho_match_mp_tac valid_val_ind
+  >> rpt strip_tac
+  >> simp[Once valid_val_cases]
+  >> gvs[can_lookup_cases]
+  >> gvs[SF ETA_ss]
+  >> irule FEVERY_MONO
+  >> pop_assum $ irule_at (Pos last)
+  >> PairCases
+  >> rpt strip_tac
+  >> gvs[]
+QED
+
+Theorem valid_val_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
+  cj 1 valid_larger_store;
+Theorem valid_cont_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
+  cj 2 valid_larger_store;
+
+Theorem letrec_init_mono:
+  ∀ bs store env store' env' .
+    letrec_init store env bs = (store', env')
+    ⇒
+    FDOM env ⊆ FDOM env'
+Proof
+  Induct
+  >> simp[letrec_init_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule
+  >> simp[]
+QED
+
+Theorem letrec_init_dom:
+  ∀ xs store env store' env' .
+    letrec_init store env xs = (store', env')
+    ⇒
+    FDOM env ∪ set xs = FDOM env' ∧
+    store ++ GENLIST (λ x. NONE) (LENGTH xs) = store'
+Proof
+  Induct
+  >> simp[letrec_init_def, fresh_loc_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_then assume_tac
+  >> gvs[GENLIST] >- (
+    rpt strip_tac
+    >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
+    >> simp[EXTENSION]
+    >> simp[UNION_DEF, INSERT_DEF, SPECIFICATION, GSYM DISJ_ASSOC]
+    >> strip_tac
+    >> iff_tac
+    >> rw[] >> rw[]
+  )
+  >> rpt $ pop_assum kall_tac
+  >> ‘∃ n . LENGTH xs = n’ by simp[]
+  >> simp[]
+  >> pop_assum kall_tac
+  >> Induct_on ‘n’
+  >> simp[GENLIST]
+QED
+
+Theorem letrec_init_lookup:
+  ∀ xs store env store' env' .
+    can_lookup env store ∧
+    letrec_init store env xs = (store', env')
+    ⇒
+    can_lookup env' store'
+Proof
+  Induct
+  >> simp[letrec_init_def, fresh_loc_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> qsuff_tac ‘can_lookup (env |+ (h,LENGTH store)) (SNOC NONE store)’ >- (
+    strip_tac
+    >> last_x_assum drule_all
+    >> simp[]
+  )
+  >> gvs[can_lookup_cases]
+  >> qsuff_tac ‘FEVERY (λ(x,n). n < SUC (LENGTH store)) env’ >- (
+    strip_tac
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+  )
+  >> irule FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_NONE_dom:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs = LENGTH vs ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    Exp e = e' ∧
+    FDOM env ∪ set xs = FDOM env' ∧
+    store ++ MAP SOME vs = store'
+Proof
+  Induct
+  >> simp[parameterize_def]
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 2)
+  >> rpt strip_tac
+  >> gvs[] >- (
+    pop_assum $ simp o single o GSYM
+    >> simp[Once INSERT_SING_UNION, EXTENSION]
+    >> strip_tac
+    >> iff_tac
+    >> strip_tac
+    >> simp[]
+  )
+  >> gvs[fresh_loc_def]
+QED
+
+Theorem parameterize_NONE_lookup:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs = LENGTH vs ∧
+    can_lookup env store ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    can_lookup env' store'
+Proof
+  Induct
+  >> simp[parameterize_def]
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 3)
+  >> rpt strip_tac
+  >> gvs[]
+  >> pop_assum irule
+  >> gvs[can_lookup_cases, fresh_loc_def]
+  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+  >> simp[]
+  >> irule $ FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_NONE_exception:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs ≠ LENGTH vs ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    ∃ s . Exception s = e'
+Proof
+  Induct
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule_all
+  >> simp[]
+QED
+
+Theorem parameterize_SOME_dom:
+  ∀ xs vs store env x store' env' e e' .
+    LENGTH xs ≤ LENGTH vs ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    Exp e = e' ∧
+    FDOM env ∪ set (x::xs) = FDOM env' ∧
+    store ++ MAP SOME (TAKE (LENGTH xs) vs)
+      ++ [SOME (SList (REVERSE (TAKE (LENGTH vs - LENGTH xs) (REVERSE vs))))]
+      = store'
+Proof
+  gen_tac >> gen_tac
+  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
+  >> pop_assum mp_tac
+  >> qid_spec_tac ‘vs’
+  >> Induct_on ‘xs’
+  >> simp[parameterize_def, fresh_loc_def] >- (
+    strip_tac >> strip_tac
+    >> simp_tac bool_ss [Once $ GSYM LENGTH_REVERSE]
+    >> simp[TAKE_LENGTH_ID]
+    >> simp[Once UNION_COMM]
+    >> simp[Once $ GSYM INSERT_SING_UNION]
+  )
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 3)
+  >> rpt strip_tac
+  >> gvs[fresh_loc_def] >- (
+    pop_assum $ simp o single o GSYM
+    >> simp[EXTENSION]
+    >> strip_tac
+    >> iff_tac
+    >> strip_tac
+    >> simp[]
+  )
+  >> simp[TAKE_APPEND1]
+QED
+
+Theorem parameterize_SOME_lookup:
+  ∀ xs vs store env x store' env' e e' .
+    LENGTH xs ≤ LENGTH vs ∧
+    can_lookup env store ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    can_lookup env' store'
+Proof
+  gen_tac >> gen_tac
+  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
+  >> pop_assum mp_tac
+  >> qid_spec_tac ‘vs’
+  >> Induct_on ‘xs’
+  >> simp[parameterize_def, fresh_loc_def] >- (
+    simp[can_lookup_cases]
+    >> rpt strip_tac
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+    >> irule $ FEVERY_MONO
+    >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+    >> PairCases
+    >> simp[]
+  )
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 4)
+  >> rpt strip_tac
+  >> gvs[]
+  >> pop_assum irule
+  >> gvs[fresh_loc_def, can_lookup_cases]
+  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+  >> simp[]
+  >> irule $ FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_SOME_exception:
+  ∀ xs store env x vs store' env' e e' .
+    LENGTH vs < LENGTH xs ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    ∃ s . Exception s = e'
+Proof
+  Induct
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule_all
+  >> simp[]
+QED
+
+Theorem sadd_num_or_exception:
+  ∀ vs n .
+    (∃ m . sadd vs n = Val (SNum m)) ∨
+    (∃ s . sadd vs n = Exception s)
+Proof
+  Induct
+  >> simp[sadd_def]
+  >> Cases
+  >> simp[sadd_def]
+QED
+
+Theorem smul_num_or_exception:
+  ∀ vs n .
+    (∃ m . smul vs n = Val (SNum m)) ∨
+    (∃ s . smul vs n = Exception s)
+Proof
+  Induct
+  >> simp[smul_def]
+  >> Cases
+  >> simp[smul_def]
+QED
+
+Theorem sminus_num_or_exception:
+  ∀ vs .
+    (∃ m . sminus vs = Val (SNum m)) ∨
+    (∃ s . sminus vs = Exception s)
+Proof
+  Cases
+  >> simp[sminus_def]
+  >> Cases_on ‘h’
+  >> simp[sminus_def]
+  >> qspecl_then [‘t’, ‘0’] assume_tac sadd_num_or_exception
+  >> EVERY_CASE_TAC
+  >> gvs[]
+QED
+
+Theorem seqv_bool_or_exception:
+  ∀ vs .
+    (∃ b . seqv vs = Val (SBool b)) ∨
+    (∃ s . seqv vs = Exception s)
+Proof
+  Cases
+  >> simp[seqv_def]
+  >> Cases_on ‘t’
+  >> simp[seqv_def]
+  >> Cases_on ‘t'’
+  >> simp[seqv_def]
+  >> IF_CASES_TAC
+  >> simp[]
+QED
+
+Theorem valid_state_progress:
+  ∀ store ks env state .
+    valid_state store ks env state
+    ⇒
+    ∃ store' ks' env' state' .
+      step (store, ks, env, state) = (store', ks', env', state') ∧
+      valid_state store' ks' env' state'
+Proof
+  Cases_on ‘state’
+  >> rpt strip_tac
+  >~ [‘Exp e’] >- (
+    Cases_on ‘e’
+    >~ [‘Lit l’] >- (
+      Cases_on ‘l’
+      >> simp[step_def, lit_to_val_def]
+      >> simp[Once valid_state_cases, Once valid_val_cases]
+      >> gvs[Once valid_state_cases]
+    )
+    >~ [‘Begin es e’] >- (
+      Cases_on ‘es’ >- (
+        simp[step_def, Once valid_state_cases]
+        >> gvs[Once valid_state_cases, Once static_scope_cases]
+      )
+      >> simp[step_def, Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_cases]
+    )
+    >~ [‘Ident x’] >- (
+      simp[step_def]
+      >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+      >> ‘∀ x . FDOM env x ⇒ ∃ a. FLOOKUP env x = SOME a’
+        by simp[FLOOKUP_DEF, SPECIFICATION]
+      >> pop_assum drule >> strip_tac
+      >> drule_all_then assume_tac FEVERY_FLOOKUP
+      >> qpat_assum ‘EVERY _ _’ $ assume_tac o SRULE [EVERY_EL]
+      >> gvs[]
+      >> pop_assum $ drule_then assume_tac
+      >> ‘∀ x a . FLOOKUP env x = SOME a ⇒ env ' x = a’ by simp[FLOOKUP_DEF]
+      >> pop_assum $ drule_then assume_tac
+      >> simp[]
+      >> Cases_on ‘EL a store’ >- simp[Once valid_state_cases]
+      >> gvs[Once valid_state_cases, can_lookup_cases]
+    )
+    >~ [‘Letrec bs e’] >- (
+      simp[step_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> simp[Once valid_state_cases, Once static_scope_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_cases]
+      >> drule_then assume_tac letrec_init_dom
+      >> drule_all_then assume_tac letrec_init_lookup
+      >> gvs[]
+      >> irule_at (Pos $ el 2) valid_cont_larger_store
+      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> irule_at (Pos $ el 2) EVERY_MONOTONIC
+      >> qpat_assum ‘EVERY (OPTION_ALL _) _’ $ irule_at (Pos $ el 2)
+      >> strip_tac >- (
+        rpt strip_tac
+        >> irule_at (Pos hd) OPTION_ALL_MONO
+        >> pop_assum $ irule_at (Pos last)
+        >> rpt strip_tac
+        >> irule valid_val_larger_store
+        >> pop_assum $ irule_at (Pos last)
+        >> simp[]
+      )
+      >> simp[EVERY_GENLIST]
+      >> qpat_assum ‘EVERY _ (MAP SND bs)’ mp_tac
+      >> qpat_assum ‘FDOM _ ∪ _ = FDOM _’ mp_tac
+      >> rpt (pop_assum kall_tac)
+      >> qid_spec_tac ‘env’
+      >> Induct_on ‘bs’ >- simp[]
+      >> rpt strip_tac
+      >> PairCases_on ‘h’
+      >> simp[Once static_scope_cases]
+      >> gvs[]
+      >> last_x_assum $ qspec_then ‘env |+ (h0, 0)’ assume_tac
+      >> gvs[]
+      >> qsuff_tac ‘FDOM env ∪ (h0 INSERT set (MAP FST bs))
+        = (h0 INSERT FDOM env) ∪ set (MAP FST bs)’ >- (
+        strip_tac
+        >> pop_assum $ gvs o single
+        >> last_x_assum $ simp o single o GSYM
+      )
+      >> rpt $ pop_assum kall_tac
+      >> simp[EXTENSION, UNION_DEF]
+      >> strip_tac
+      >> iff_tac
+      >> strip_tac
+      >> simp[]
+    )
+    >> simp[step_def, Once valid_state_cases]
+    >> simp[Once valid_val_cases]
+    >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+  )
+  >~ [‘Val v’] >- (
+    Cases_on ‘ks’ >- (
+      simp[step_def, return_def, Once valid_state_cases,
+        can_lookup_cases, FEVERY_FEMPTY]
+      >> gvs[Once valid_state_cases]
+    )
+    >> PairCases_on ‘h’
+    >> Cases_on ‘h1’
+    >~ [‘CondK t f’] >- (
+      simp[step_def, return_def]
+      >> IF_CASES_TAC >- (
+        gvs[Once valid_state_cases, Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+        >> simp[Once valid_state_cases]
+      )
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+    )
+    >~ [‘BeginK es e’] >- (
+      simp[step_def, return_def]
+      >> CASE_TAC
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+    )
+    >~ [‘SetK x’] >- (
+      simp[step_def, return_def]
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+      >> irule_at (Pos hd) valid_cont_larger_store
+      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> gvs[can_lookup_cases]
+      >> irule IMP_EVERY_LUPDATE
+      >> simp[OPTION_ALL_def]
+      >> irule_at (Pos hd) valid_val_larger_store
+      >> last_assum $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> irule EVERY_MONOTONIC
+      >> qpat_assum ‘EVERY _ _’ $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule OPTION_ALL_MONO
+      >> pop_assum $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule_at (Pos hd) valid_val_larger_store
+      >> pop_assum $ irule_at (Pos last)
+      >> simp[]
+    )
+    >~ [‘ApplyK fnp es’] >- (
+      simp[step_def]
+      >> Cases_on ‘∃ e es' . es = e::es'’ >-(
+        gvs[]
+        >> Cases_on ‘∃ fn vs . fnp = SOME (fn,vs)’
+        >> Cases_on ‘fnp = NONE’
+        >> gvs[]
+        >> simp[return_def]
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> simp[Once valid_val_cases]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> simp[]
+        >> Cases_on ‘fnp’ >> gvs[] >> PairCases_on ‘x’ >> gvs[]
+      )
+      >> Cases_on ‘es’ >> gvs[]
+      >> Cases_on ‘fnp’ >- (
+        simp[return_def]
+        >> Cases_on ‘v’
+        >> simp[application_def]
+        >~ [‘Prim p’] >- (
+          CASE_TAC
+          >> simp[Once valid_state_cases, sadd_def, smul_def,
+            sminus_def, seqv_def, can_lookup_cases, FEVERY_FEMPTY]
+          >> simp[Once valid_val_cases]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >~ [‘Proc env' xs xp e’] >- (
+          Cases_on ‘xp’
+          >> Cases_on ‘xs’
+          >> simp[parameterize_def] >- (
+            simp[Once valid_state_cases]
+            >> gvs[Once valid_state_cases]
+            >> gvs[Once valid_val_cases]
+            >> gvs[Once valid_val_cases]
+          )
+          >- simp[Once valid_state_cases]
+          >- (
+            rpt (pairarg_tac >> gvs[])
+            >> simp[Once valid_state_cases]
+            >> gvs[Once valid_state_cases, fresh_loc_def]
+            >> gvs[Once valid_val_cases]
+            >> gvs[Once valid_val_cases]
+            >> simp[Once INSERT_SING_UNION, Once UNION_COMM]
+            >> irule_at (Pos hd) valid_cont_larger_store
+            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+            >> simp[Once valid_val_cases]
+            >> irule_at (Pos $ el 2) $ EVERY_MONOTONIC
+            >> pop_assum $ irule_at (Pos $ el 2)
+            >> gvs[can_lookup_cases]
+            >> irule_at (Pos $ el 2) $ cj 2 FEVERY_STRENGTHEN_THM
+            >> simp[]
+            >> irule_at (Pos hd) FEVERY_MONO
+            >> qpat_assum ‘FEVERY _ env'’ $ irule_at (Pos $ el 2)
+            >> rpt strip_tac >- (PairCases_on ‘x'’ >> gvs[])
+            >> irule OPTION_ALL_MONO
+            >> pop_assum $ irule_at (Pos last)
+            >> rpt strip_tac
+            >> irule valid_val_larger_store
+            >> pop_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> simp[Once valid_state_cases]
+          >> gvs[Once valid_state_cases]
+          >> gvs[Once valid_val_cases]
+          >> gvs[Once valid_val_cases]
+        )
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> gvs[Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+      )
+      >> PairCases_on ‘x’
+      >> simp[return_def]
+      >> Cases_on ‘x0’
+      >> simp[application_def]
+      >~ [‘Prim p’] >- (
+        TOP_CASE_TAC >- (
+          qspecl_then [‘REVERSE x1 ++ [v]’, ‘0’] assume_tac sadd_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspecl_then [‘REVERSE x1 ++ [v]’, ‘1’] assume_tac smul_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac sminus_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac seqv_bool_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >> CASE_TAC
+        >> gvs[]
+        >> Cases_on ‘t'’ >- (
+          gvs[]
+          >> simp[Once valid_state_cases]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> rpt strip_tac
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+        )
+        >> gvs[]
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> gvs[Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+      )
+      >~ [‘Proc env' xs xp e’] >- (
+        rpt (pairarg_tac >> gvs[])
+        >> gvs[Once valid_state_cases]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> gvs[] >- (
+          Cases_on ‘LENGTH xs = LENGTH (REVERSE x1 ++ [v])’ >- (
+            drule_all_then mp_tac parameterize_NONE_dom
+            >> drule_all_then mp_tac parameterize_NONE_lookup
+            >> rpt strip_tac
+            >> qpat_x_assum ‘Exp _ = _’ $ simp o single o GSYM
+            >> simp[Once valid_state_cases]
+            >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
+            >> qpat_x_assum ‘_ ++ _ = _’ $ simp o single o GSYM
+            >> irule_at (Pos hd) $ valid_cont_larger_store
+            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+            >> simp[]
+            >> irule_at (Pos hd) EVERY_MONOTONIC
+            >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+            >> strip_tac >- (
+              rpt strip_tac
+              >> irule OPTION_ALL_MONO
+              >> pop_assum $ irule_at (Pos last)
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> strip_tac >- (
+              irule EVERY_OPTION_ALL_MAP_SOME
+              >> irule EVERY_MONOTONIC
+              >> qexists ‘valid_val store’
+              >> simp[]
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> drule_all_then mp_tac parameterize_NONE_exception
+          >> rpt strip_tac
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+        )
+        >> Cases_on ‘LENGTH xs ≤ LENGTH (REVERSE x1 ++ [v])’ >- (
+          drule_all_then mp_tac parameterize_SOME_dom
+          >> drule_all_then mp_tac parameterize_SOME_lookup
+          >> rpt strip_tac
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> irule_at (Pos hd) $ valid_cont_larger_store
+          >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+          >> simp[]
+          >> irule_at (Pos hd) EVERY_MONOTONIC
+          >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+          >> strip_tac >- (
+            rpt strip_tac
+            >> irule OPTION_ALL_MONO
+            >> pop_assum $ irule_at (Pos last)
+            >> rpt strip_tac
+            >> irule valid_val_larger_store
+            >> pop_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> strip_tac >- (
+            irule EVERY_OPTION_ALL_MAP_SOME
+            >> irule EVERY_TAKE
+            >> simp[]
+            >> strip_tac >- (
+              irule EVERY_MONOTONIC
+              >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> simp[Once valid_val_cases]
+          >> irule EVERY_TAKE
+          >> simp[]
+          >> strip_tac >- (
+            irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> irule EVERY_MONOTONIC
+          >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
+          >> rpt strip_tac
+          >> irule valid_val_larger_store
+          >> pop_assum $ irule_at (Pos last)
+          >> simp[]
+        )
+        >> ‘LENGTH (REVERSE x1 ++ [v]) < LENGTH xs’ by gvs[]
+        >> drule_all_then mp_tac parameterize_SOME_exception
+        >> rpt strip_tac
+        >> simp[Once valid_state_cases]
+        >> gvs[]
+      )
+      >~ [‘Throw ks’] >- (
+        CASE_TAC >- simp[Once valid_state_cases]
+        >> CASE_TAC >- (
+          gvs[]
+          >> simp[Once valid_state_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> rpt strip_tac
+          >> qpat_x_assum ‘valid_val _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >> simp[Once valid_state_cases]
+      )
+      >> simp[Once valid_state_cases]
+      >> gvs[Once valid_state_cases]
+      >> gvs[Once valid_val_cases]
+      >> gvs[Once valid_val_cases]
+    )
+  )
+  >> simp[step_def, Once valid_state_cases]
+QED
+
+Theorem statically_scoped_program_valid:
+  ∀ p . static_scope ∅ p ⇒ valid_state [] [] FEMPTY (Exp p)
+Proof
+  simp[Once valid_state_cases,
+    can_lookup_cases, FEVERY_FEMPTY]
+  >> simp[Once valid_val_cases]
+QED
+
 (*
   open scheme_semanticsTheory;
 
@@ -272,27 +1141,27 @@ End
     )
   ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
 
-  EVAL “steps 500 ([], [], FEMPTY, Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
-    Letrec [(strlit "st", Val $ SNum 0); (strlit "acc", Val $ SNum 1)] (
-      Begin ( Apply (Val $ Prim CallCC) [ Lambda [strlit "k"] NONE (
+  EVAL “steps 500 ([], [], FEMPTY, Exp $ Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+    Letrec [(strlit "st", Lit $ LitNum 0); (strlit "acc", Lit $ LitNum 1)] (
+      Begin [ Apply (Lit $ LitPrim CallCC) [ Lambda [strlit "k"] NONE (
         Set (strlit "st") (Ident $ strlit "k")
-      )]) [
-        Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0])
+      )]] (
+        Cond (Apply (Lit $ LitPrim SEqv) [Ident $ strlit "x"; Lit $ LitNum 0])
           (Ident $ strlit "acc")
-          (Apply (Ident $ strlit "st") [ Begin (
-            Set (strlit "acc") (Apply (Val $ Prim SMul) [
+          (Apply (Ident $ strlit "st") [ Begin [
+            Set (strlit "acc") (Apply (Lit $ LitPrim SMul) [
               Ident $ strlit "acc";
               Ident $ strlit "x"
             ])
-          ) [
-            Set (strlit "x") (Apply (Val $ Prim SMinus) [
+          ] (
+            Set (strlit "x") (Apply (Lit $ LitPrim SMinus) [
               Ident $ strlit "x";
-              Val $ SNum 1
+              Lit $ LitNum 1
             ])
-          ]])
-      ]
+          )])
+      )
     )
-  ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
+  ))] (Apply (Ident $ strlit "fac") [Lit $ LitNum 6]))”
 *)
 
 val _ = export_theory();
\ No newline at end of file

From f60ece0d66b69472a8049d20dea48d2380e43922 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Fri, 11 Apr 2025 17:46:38 +0100
Subject: [PATCH 074/100] fix parser, compiler but cps transform termination
 not done

---
 compiler/scheme/scheme_astScript.sml     |  13 ---
 compiler/scheme/scheme_parsingScript.sml |  23 +++--
 compiler/scheme/scheme_to_cakeScript.sml | 126 +++++++++++++----------
 3 files changed, 85 insertions(+), 77 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 8b8228ecbd..6beca9949d 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -95,19 +95,6 @@ Inductive static_scope:
   static_scope env (Set x e)
 End
 
-Definition exp_rec_def:
-  exp_rec (Lit l) = 1 ∧
-  exp_rec (Cond c t f) = exp_rec c + exp_rec t + exp_rec f ∧
-  exp_rec (Apply fn es) = exp_rec fn + SUM (MAP exp_rec es) ∧
-  exp_rec (Begin es e) = exp_rec e + SUM (MAP exp_rec es) ∧
-  exp_rec (Lambda xs xp e) = exp_rec e ∧
-  exp_rec (Letrec bs e) = exp_rec e + SUM (MAP (exp_rec o SND) bs)∧
-  exp_rec (Ident x) = 1 ∧
-  exp_rec (Set x e) =  exp_rec e
-Termination
-  WF_REL_TAC ‘measure exp_size’
-End
-
 Theorem static_scope_mono:
   ∀ env e env' .
     env ⊆ env' ∧ static_scope env e ⇒ static_scope env' e
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index 10f7814654..0f43348576 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -8,7 +8,6 @@ open scheme_astTheory;
 
 val _ = new_theory "scheme_parsing";
 
-
 val _ = monadsyntax.declare_monad("sum", {
   unit = “INR”,
   bind = “λ s f . case s of
@@ -194,6 +193,14 @@ Proof
   >> Cases_on ‘pair_to_list p’ >> gvs[list_size_def]
 QED
 
+Theorem list_size_snoc[simp]:
+  ∀ f x xs .
+    list_size f (SNOC x xs) = 1 + (f x + list_size f xs)
+Proof
+  Induct_on ‘xs’
+  >> simp[list_size_def]
+QED
+
 Definition cons_formals_def:
   cons_formals ps Nil = INR (REVERSE ps, NONE) ∧
   cons_formals ps (Word w) = INR (REVERSE ps, SOME (implode w)) ∧
@@ -223,12 +230,12 @@ Definition cons_ast_def:
           return (Cond ce te fe)
         od
       | _ => INL "Wrong number of expressions in if statement")
-    | Word "begin" => (case ys of
-      | [] => INL "Wrong number of expressions to begin"
-      | y'::ys' => do
-          e <- cons_ast y';
-          es <- cons_ast_list ys';
-          return (Begin e es)
+    | Word "begin" => (if NULL ys
+        then INL "Wrong number of expressions to begin"
+        else do
+          es <- cons_ast_list (FRONT ys);
+          e <- cons_ast (LAST ys);
+          return (Begin es e)
         od)
     | Word "lambda" => (case ys of
       | [xs;y'] => do
@@ -285,6 +292,8 @@ Termination
     dxrule_then (assume_tac o GSYM) pair_to_list_size
     >> gvs[list_size_def]
   )
+  >> Cases_on ‘ys’ using SNOC_CASES
+  >> gvs[]
 End
 
 Definition parse_to_ast_def:
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index f8e7bbf436..774d2032d9 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -7,6 +7,7 @@ open scheme_astTheory;
 
 open semanticPrimitivesTheory;
 open namespaceTheory;
+open prim_recTheory;
 
 val _ = new_theory "scheme_to_cake";
 
@@ -70,17 +71,25 @@ Definition cps_transform_def:
 
   cps_transform n (Cond c t f) = (let
     (m, cc) = cps_transform n c;
-    k = "k" ++ toString m;
-    (l, ck) = refunc_cont (m+1) (CondK t f) (Var (Short k))
+    (l, ct) = cps_transform m t;
+    (j, cf) = cps_transform l f;
+    k = "k" ++ toString j;
+    p = "t" ++ toString (j+1);
   in
-    (l, Fun k $ Let (SOME "k") ck $ App Opapp [cc; Var (Short "k")])) ∧
+    (j+2, Fun k $ Let (SOME "k") (Fun p $ Mat (Var (Short p)) [
+      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
+        App Opapp [cf; Var (Short k)]);
+      (Pany,
+        App Opapp [ct; Var (Short k)])
+    ]) $ App Opapp [cc; Var (Short "k")])) ∧
 
   cps_transform n (Apply fn args) = (let
     (m, cfn) = cps_transform n fn;
     k = "k" ++ toString m;
-    (l, ck) = refunc_cont (m+1) (ApplyK NONE args) (Var (Short k))
+    t = "t" ++ toString (m+1);
+    (l, capp) = cps_transform_app (m+2) (Var (Short t)) [] args (Var (Short k))
   in
-    (l, Fun k $ Let (SOME "k") ck $ App Opapp [cfn; Var (Short "k")])) ∧
+    (l, Fun k $ Let (SOME "k") (Fun t capp) $ App Opapp [cfn; Var (Short "k")])) ∧
 
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
     (n, Fun k $ Mat (App Opderef [Var (Short $ "s" ++ explode x)]) [
@@ -100,19 +109,23 @@ Definition cps_transform_def:
       (Con (SOME $ Short "Proc") [Fun k $ Fun args inner]) $
       App Opapp [Var (Short k'); Var (Short "v")])) ∧
 
-  cps_transform n (Begin e es) = (let
-    (m, ce) = cps_transform n e;
-    k = "k" ++ toString m;
-    (l, seqk) = refunc_cont (m+1) (BeginK es) (Var (Short k))
-  in
-    (l, Fun k $ App Opapp [ce; seqk])) ∧
+  cps_transform n (Begin es e) = (let
+      k = "k" ++ toString n;
+      (m, ce) = cps_transform_seq (n+1) (Var (Short k)) es e
+    in
+      (m, Fun k ce)) ∧
 
   cps_transform n (Set x e) = (let
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
-    (l, setk) = refunc_cont (m+1) (SetK x) (Var (Short k))
+    t = "t" ++ toString (m+1);
   in
-    (l, Fun k $ (App Opapp [ce;setk]))) ∧
+    (m+2, Fun k $ Let (SOME "k")
+      (Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
+            Con (SOME $ Short "Some") [Var (Short t)]]) $
+          Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
+            (App Opapp [Var (Short k); Var (Short "v")])) $
+        App Opapp [ce; Var (Short "k")])) ∧
 
   cps_transform n (Letrec bs e) = (let
     (m, ce) = cps_transform n e;
@@ -121,33 +134,6 @@ Definition cps_transform_def:
   in
     (l, Fun k $ letinit_ml bs inner)) ∧
 
-  refunc_cont n (CondK t f) k = (let
-    (m, ct) = cps_transform n t;
-    (l, cf) = cps_transform m f;
-    p = "t" ++ toString l;
-  in
-    (l+1, Fun p $ Mat (Var (Short p)) [
-      (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []], App Opapp [cf; k]);
-      (Pany, App Opapp [ct; k])
-    ])) ∧
-
-  refunc_cont n (ApplyK fnp es) k = (let
-    t = "t" ++ toString n;
-    (m, ce) = (case fnp of
-      | NONE => cps_transform_app (n+1) (Var (Short t)) [] es k
-      | SOME (fn, vs) => cps_transform_app (n+1) (to_ml_vals fn)
-                           (Var (Short t) :: MAP to_ml_vals vs) es k)
-  in
-    (m, Fun t ce)) ∧
-
-  refunc_cont n (BeginK es) k = cps_transform_seq n k es ∧
-
-  refunc_cont n (SetK x) k = (let
-    t = "t" ++ toString n;
-  in
-    (n+1, Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
-            Con (SOME $ Short "Some") [Var (Short t)]])
-          (App Opapp [k; Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"]]))) ∧
 
   cps_transform_app n tfn ts (e::es) k = (let
     (m, ce) = cps_transform n e;
@@ -161,13 +147,18 @@ Definition cps_transform_def:
       App Opapp [App Opapp [Var (Short "app"); k]; tfn];
       cons_list (REVERSE ts)]) ∧
 
-  cps_transform_seq n k [] = (n, k) ∧
 
-  cps_transform_seq n k (e::es) = (let
-    (m, ce) = cps_transform n e;
-    (l, inner) = cps_transform_seq m k es
+  cps_transform_seq n k [] e = (let
+    (m, ce) = cps_transform n e
+  in
+    (n, App Opapp [ce; k])) ∧
+
+  cps_transform_seq n k (e'::es) e = (let
+    (m, ce) = cps_transform n e';
+    (l, inner) = cps_transform_seq m k es e
   in
-    (l, Fun "_" $ App Opapp [ce; inner])) ∧
+    (l, Let (SOME "k") (Fun "_" $ inner) $ App Opapp [ce; Var (Short "k")])) ∧
+
 
   cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧
 
@@ -181,19 +172,33 @@ Definition cps_transform_def:
         Con (SOME $ Short "Some") [Var (Short t)]])
       inner]))
 Termination
-  WF_REL_TAC ‘measure (λ x . case x of
+  (*WF_REL_TAC ‘measure (λ x . case x of
     | INL(_,e) => exp_size e
-    | INR(INL(_,k,_)) => cont_size k
-    | INR(INR(INL(_,_,_,es,_))) => list_size exp_size es
-    | INR(INR(INR(INL(_,_,es)))) => list_size exp_size es
-    | INR(INR(INR(INR(_,_,es,_)))) => list_size (exp_size o SND) es)’
-  >> rpt (strip_tac >- (Cases >> rw[scheme_astTheory.exp_size_def]))
-  >> rpt (strip_tac >- (
-      Induct >- (Cases >> simp[scheme_astTheory.exp_size_def, list_size_def])
-      >> Cases >> rw[scheme_astTheory.exp_size_def, list_size_def]
-      >> last_x_assum dxrule >> simp[]
-  ))
-  >> Cases >> rw[scheme_astTheory.exp_size_def]
+    | INR(INL(_,_,_,es,_)) => list_size exp_size es
+    | INR(INR(INL(_,_,es,e))) => list_size exp_size (e::es)
+    | INR(INR(INR(_,_,bs,_))) => exp1_size bs)’*)
+  WF_REL_TAC ‘(λ x y . case x of
+    | INL(_,e) => (case y of
+      | INL(_,e') => exp_size e < exp_size e'
+      | INR(INL(_,_,_,es,_)) => exp_size e < exp3_size es
+      | INR(INR(INL(_,_,es,e'))) => exp_size e < exp3_size (e'::es)
+      | INR(INR(INR(_,_,bs,_))) => exp_size e < exp1_size bs)
+    | INR(INL(_,_,_,es,_)) => (case y of
+      | INL(_,e) => T
+      | INR(INL(_,_,_,es',_)) => exp3_size es < exp3_size es'
+      | INR(INR(INL(_,_,es',e))) => exp3_size es < exp3_size (e::es')
+      | INR(INR(INR(_,_,bs,_))) => exp3_size es < exp1_size bs)
+    | INR(INR(INL(_,_,es,e))) => (case y of
+      | INL(_,e') => T
+      | INR(INL(_,_,_,es',_)) => exp3_size (e::es) < exp3_size es'
+      | INR(INR(INL(_,_,es',e'))) => exp3_size (e::es) < exp3_size (e'::es')
+      | INR(INR(INR(_,_,bs,_))) => exp3_size (e::es) < exp1_size bs)
+    | INR(INR(INR(_,_,bs,_))) => (case y of
+      | INL(_,e) => T
+      | INR(INL(_,_,_,es,_)) => exp1_size bs < exp3_size es
+      | INR(INR(INL(_,_,es,e))) => exp1_size bs < exp3_size (e::es)
+      | INR(INR(INR(_,_,bs',_))) => exp1_size bs < exp1_size bs'))’
+  >> cheat
 End
 
 Definition compile_scheme_prog_def:
@@ -417,4 +422,11 @@ Definition codegen_def:
   ]
 End
 
+(*
+open scheme_parsingTheory;
+open scheme_to_cakeTheory;
+EVAL “cps_transform 0 $ OUTR $ parse_to_ast
+"(begin 1 2 3)"”
+*)
+
 val _ = export_theory();
\ No newline at end of file

From dd4fdea42edb1e31ad527ffb7a3909228422501b Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 12 Apr 2025 18:24:05 +0100
Subject: [PATCH 075/100] proven lambdas, fixed cps transform termination

---
 compiler/scheme/scheme_proofsScript.sml    | 728 +++++++++++++++------
 compiler/scheme/scheme_semanticsScript.sml |   2 +-
 compiler/scheme/scheme_to_cakeScript.sml   |  52 +-
 3 files changed, 548 insertions(+), 234 deletions(-)

diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/scheme_proofsScript.sml
index b2e7ae4f21..1e0139721c 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/scheme_proofsScript.sml
@@ -18,7 +18,7 @@ open integerTheory;
 
 val _ = new_theory "scheme_proofs";
 
-val _ = (max_print_depth := 20);
+val _ = (max_print_depth := 50);
 
 Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
   scheme_env1 = case evaluate_decs
@@ -33,7 +33,7 @@ Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
 Definition cconses_def[simp]:
   cconses = ["SNum"; "SBool"; "True"; "False";
     "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
-    "[]"; "::"; "Some"; "None"; "Ex"; "Proc"; "Throw"]
+    "[]"; "::"; "Some"; "None"; "Ex"; "Proc"; "Throw";"SList"]
 End
 
 Theorem scheme_env1_rw[simp] = SRULE [nsLookup_def] $ SIMP_CONV pure_ss [
@@ -250,11 +250,16 @@ Theorem scheme_typestamp_def[allow_rebind, simp] = SRULE [] $
 
 Inductive env_rel:
   FEVERY (λ (x, n).
-    nsLookup env.v (Short ("s" ++ explode x)) = SOME (Loc T n)) se
+    nsLookup env.v (Short ("var" ++ explode x)) = SOME (Loc T n)) se
   ⇒
   env_rel se env
 End
 
+Theorem vcons_list_def[allow_rebind] = SRULE [] $ Define ‘
+  vcons_list [] = Conv (SOME (scheme_typestamp "[]")) [] ∧
+  vcons_list (v::vs) = Conv (SOME (scheme_typestamp "::")) [v; vcons_list vs]
+’;
+
 val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
 (fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
   (ml_v_vals' (SBool T) $
@@ -274,7 +279,8 @@ val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
   (ml_v_vals' (Prim CallCC) $
     Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "CallCC")) []]) ∧
 
-  (env_rel se env ∧
+  (scheme_env env ∧
+  env_rel se env ∧
   (m, ce) = cps_transform n e ∧
   args = "xs" ++ toString m ∧
   k = "k" ++ toString (m+1) ∧
@@ -283,7 +289,19 @@ val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
   ml_v_vals' (Proc se xs xp e) $
     Conv (SOME (scheme_typestamp "Proc")) [
       Closure env k $ Fun args inner
-    ])
+    ]) ∧
+  (LIST_REL ml_v_vals' vs mlvs
+  ⇒
+  ml_v_vals' (SList vs) $
+    Conv (SOME (scheme_typestamp "SList")) [vcons_list mlvs])
+’;
+
+val (store_entry_rel_rules,store_entry_rel_ind,store_entry_rel_cases) =
+(fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
+  (ml_v_vals' v mlv
+  ⇒
+  store_entry_rel (SOME v) (Refv (Conv (SOME (scheme_typestamp "Some")) [mlv]))) ∧
+  store_entry_rel NONE (Refv (Conv (SOME (scheme_typestamp "None")) []))
 ’;
 
 Inductive e_ce_rel:
@@ -331,7 +349,7 @@ Inductive cont_rel:
   env_rel se env ∧
   ¬ MEM var vconses ∧
   ¬ MEM t vconses ∧
-  (∀ x . t ≠ "s" ++ x) ∧
+  (∀ x . t ≠ "var" ++ x) ∧
   var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
@@ -352,7 +370,7 @@ Inductive cont_rel:
   ts = cps_app_ts n es ∧
   ¬ MEM var ts ∧
   ¬ MEM t ts ∧
-  (∀ x . t ≠ "s" ++ x) ∧
+  (∀ x . t ≠ "var" ++ x) ∧
   var ≠ t
   ⇒
   (*Likely needs condition on se i.e. Scheme env*)
@@ -382,7 +400,7 @@ Inductive cont_rel:
   ¬ MEM var ts' ∧
   ¬ MEM fnt ts' ∧
   ¬ MEM t ts' ∧
-  (∀ x . t ≠ "s" ++ x) ∧
+  (∀ x . t ≠ "var" ++ x) ∧
   var ≠ fnt ∧
   var ≠ t ∧
   fnt ≠ t
@@ -478,22 +496,16 @@ QED
 
 Theorem mono_cps_on_n:
   (∀ n e m ce . (m, ce) = cps_transform n e ⇒ m ≥ n) ∧
-  (∀ n k k' m ce . (m, ce) = refunc_cont n k k' ⇒ m ≥ n) ∧
   (∀ n fn ts es k m ce . (m, ce) = cps_transform_app n fn ts es k ⇒ m ≥ n) ∧
-  (∀ n k es m ce . (m, ce) = cps_transform_seq n k es ⇒ m ≥ n) ∧
+  (∀ n k es e m ce . (m, ce) = cps_transform_seq n k es e ⇒ m ≥ n) ∧
   (∀ n k bs ce' m ce . (m, ce) = cps_transform_letreinit n k bs ce' ⇒ m ≥ n)
 Proof
   ho_match_mp_tac $ cps_transform_ind
   >> simp[cps_transform_def]
   >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[]) >- (
-    dxrule $ GSYM mono_proc_ml_on_n
-    >> simp[]
-  )
-  >> pop_assum mp_tac
-  >> every_case_tac
-  >> strip_tac
-  >> gvs[]
+  >> rpt (pairarg_tac >> gvs[])
+  >> dxrule $ GSYM mono_proc_ml_on_n
+  >> simp[]
 QED
 
 Theorem t_in_ts:
@@ -508,11 +520,6 @@ Proof
   >> simp[]
 QED
 
-Theorem vcons_list_def[allow_rebind] = SRULE [] $ Define ‘
-  vcons_list [] = Conv (SOME (scheme_typestamp "[]")) [] ∧
-  vcons_list (v::vs) = Conv (SOME (scheme_typestamp "::")) [v; vcons_list vs]
-’;
-
 Theorem cons_list_val:
   ∀ st env ts vs .
     scheme_env env ∧
@@ -554,12 +561,235 @@ Proof
   >> simp[LIST_REL_SNOC]
 QED
 
+Theorem preservation_of_proc:
+∀ (st:'ffi state) inner n n' m m' env env' mlenv var kv n xs xp e e' ce k args vs mlvs store store' i .
+  valid_val store (Proc env xs xp e) ∧
+  LIST_REL ml_v_vals' vs mlvs ∧
+  EVERY (valid_val store) vs ∧
+  valid_cont store k ∧
+  cont_rel k kv ∧
+  (n', ce) = cps_transform n e ∧
+  (m', inner) = proc_ml m xs xp var args ce ∧
+  (store', env',e') = parameterize store env xs xp e vs ∧
+  EVERY (OPTION_ALL (valid_val store)) store ∧
+  nsLookup mlenv.v (Short var) = SOME kv ∧
+  nsLookup mlenv.v (Short args) = SOME (vcons_list mlvs) ∧
+  env_rel env mlenv ∧
+  scheme_env mlenv ∧
+  can_lookup env store ∧
+  ¬ MEM args vconses ∧
+  ¬ MEM var vconses ∧
+  var ≠ args ∧
+  (∀ s . var ≠ "var" ++ s) ∧
+  (∀ s . args ≠ "var" ++ s) ∧
+  (∀ s . var ≠ "x" ++ s) ∧
+  LIST_REL store_entry_rel store st.refs ∧
+  i > 0
+  ⇒
+  ∃ck st' mlenv' var' kv' mle'.
+    evaluate (st with clock := ck) mlenv [inner]
+      = evaluate st' mlenv' [mle'] ∧
+    cont_rel k kv' ∧
+    e_ce_rel e' var' mlenv' kv' mle' ∧
+    env_rel env' mlenv' ∧
+    LIST_REL store_entry_rel store' st'.refs ∧
+    st'.clock ≤ ck + i ∧
+    st'.clock < ck + i
+Proof
+  Induct_on ‘xs’
+  >> rpt strip_tac
+  >- (
+    qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+    >> Cases_on ‘xp’
+    >> gvs[proc_ml_def] >- (
+      Cases_on ‘vs’
+      >> gvs[parameterize_def] >- (
+        simp[Ntimes evaluate_def 3]
+        >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+          pmatch_def]
+        >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+          o SRULE [scheme_env_def]
+        >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
+      )
+      >> simp[Ntimes evaluate_def 3]
+      >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+        pmatch_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> simp[env_rel_cases, FEVERY_FEMPTY]
+    )
+    >> gvs[parameterize_def]
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+      pmatch_def, do_con_check_def, build_conv_def]
+    >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+      o SRULE [scheme_env_def]
+    >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+    >> simp[Ntimes evaluate_def 2, do_app_def, store_alloc_def]
+    >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+      pmatch_def, do_con_check_def, build_conv_def, nsOptBind_def]
+    >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+      o SRULE [scheme_env_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> simp[]
+    >> rpt (pairarg_tac >> gvs[])
+    >> gvs[fresh_loc_def, store_entry_rel_cases]
+    >> simp[Once ml_v_vals'_cases, vcons_list_def]
+    >> simp[Once e_ce_rel_cases]
+    >> irule_at (Pos hd) EQ_REFL
+    >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
+    >> qpat_assum ‘scheme_env mlenv’ $ simp
+      o curry ((::) o swap) [scheme_env_def]
+      o SRULE [scheme_env_def]
+    >> irule_at (Pos $ el 2) EQ_REFL
+    >> simp[]
+    >> gvs[env_rel_cases]
+    >> Cases_on ‘x ∈ FDOM env’ >- (
+      simp[FEVERY_DEF]
+      >> strip_tac
+      >> Cases_on ‘x = x'’
+      >> gvs[] >- (
+        drule $ cj 1 $ iffLR EVERY2_EVERY
+        >> simp[]
+      )
+      >> strip_tac
+      >> gvs[FEVERY_DEF]
+      >> simp[FAPPLY_FUPDATE_THM]
+    )
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+    >> drule_then assume_tac $ cj 1 $ iffLR EVERY2_EVERY
+    >> simp[FEVERY_DEF]
+    >> rpt strip_tac
+    >> ‘x ≠ x'’ by (strip_tac >> gvs[])
+    >> gvs[FEVERY_DEF]
+  )
+  >> gvs[proc_ml_def]
+  >> rpt (pairarg_tac >> gvs[])
+  >> Cases_on ‘vs’
+  >> gvs[parameterize_def] >- (
+    qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+      pmatch_def]
+    >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+      o SRULE [scheme_env_def]
+    >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> simp[Once e_ce_rel_cases]
+    >> simp[env_rel_cases, FEVERY_FEMPTY]
+  )
+  >> simp[Ntimes evaluate_def 3]
+  >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+    pmatch_def]
+  >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+    o SRULE [scheme_env_def]
+  >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+  >> qsuff_tac ‘STRING #"s" (toString (m + 1)) ≠ toString m’ >- (
+    simp[]
+    >> strip_tac
+    >> simp[Ntimes evaluate_def 4, do_app_def, store_alloc_def]
+    >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+      pmatch_def, do_con_check_def, build_conv_def, nsOptBind_def]
+    >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+      o SRULE [scheme_env_def]
+    >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+    >> last_x_assum irule
+    >> qpat_assum ‘scheme_env mlenv’ $ simp
+      o curry ((::) o swap) [scheme_env_def]
+      o SRULE [scheme_env_def]
+    >> gvs[fresh_loc_def]
+    >> qpat_assum ‘LIST_REL _ t ys’ $ irule_at (Pos last)
+    >> irule_at (Pat ‘parameterize _ _ _ _ _ _ = parameterize _ _ _ _ _ _’) EQ_REFL
+    >> simp[SNOC_APPEND, store_entry_rel_cases]
+    >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+    >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pat ‘_ = cps_transform _ _’)
+    >> qpat_assum ‘proc_ml _ _ _ _ _ _ = _’ $
+      irule_at (Pat ‘_ = proc_ml _ _ _ _ _ _’) o GSYM
+    >> simp[]
+    >> irule_at (Pos hd) EVERY_MONOTONIC
+    >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+    >> strip_tac >- (
+      rpt strip_tac
+      >> irule OPTION_ALL_MONO
+      >> pop_assum $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule valid_val_larger_store
+      >> pop_assum $ irule_at (Pos last)
+      >> simp[]
+    )
+    >> irule_at (Pos hd) valid_val_larger_store
+    >> qpat_assum ‘valid_store _ h'’ $ irule_at (Pos $ el 2)
+    >> simp[]
+    >> irule_at (Pos hd) EVERY_MONOTONIC
+    >> qpat_assum ‘EVERY _ t’ $ irule_at (Pos $ el 2)
+    >> strip_tac >- (
+      rpt strip_tac
+      >> irule valid_val_larger_store
+      >> pop_assum $ irule_at (Pos last)
+      >> simp[]
+    )
+    >> irule_at (Pos $ el 3) valid_cont_larger_store
+    >> qpat_assum ‘valid_cont _ k'’ $ irule_at (Pos $ el 2)
+    >> simp[Once valid_val_cases]
+    >> conj_asm1_tac >- (
+      gvs[can_lookup_cases]
+      >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+      >> irule_at (Pos last) FEVERY_MONO
+      >> qpat_assum ‘FEVERY _ env’ $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> PairCases
+      >> simp[]
+    )
+    >> simp[]
+    >> gvs[env_rel_cases]
+    >> strip_tac >- (
+      Cases_on ‘h ∈ FDOM env’ >- (
+        simp[FEVERY_DEF]
+        >> strip_tac
+        >> Cases_on ‘x = h’
+        >> gvs[] >- (
+          drule $ cj 1 $ iffLR EVERY2_EVERY
+          >> simp[]
+        )
+        >> strip_tac
+        >> gvs[FEVERY_DEF]
+        >> simp[FAPPLY_FUPDATE_THM]
+      )
+      >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+      >> simp[]
+      >> drule_then assume_tac $ cj 1 $ iffLR EVERY2_EVERY
+      >> simp[FEVERY_DEF]
+      >> rpt strip_tac
+      >> ‘x ≠ h’ by (strip_tac >> gvs[])
+      >> gvs[FEVERY_DEF]
+    )
+    >> Cases_on ‘xp’
+    >> simp[]
+    >> irule static_scope_mono
+    >> gvs[Once valid_val_cases]
+    >> qpat_assum ‘static_scope _ _’ $ irule_at (Pos last)
+    >> simp[Ntimes INSERT_SING_UNION 2]
+    >> simp[SUBSET_DEF]
+  )
+  >> irule $ GSYM str_not_num
+  >> simp[isDigit_def]
+QED
+
 Theorem myproof:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
+  valid_state store k env e ∧
   cont_rel k kv ∧
   e_ce_rel e var mlenv kv mle ∧
-  env_rel env mlenv
+  env_rel env mlenv ∧
+  LIST_REL store_entry_rel store st.refs
   ⇒
   ∃ ck st' mlenv' var' kv' mle' .
     evaluate (st with clock:=ck) mlenv [mle]
@@ -568,10 +798,118 @@ Theorem myproof:
     cont_rel k' kv' ∧
     e_ce_rel e' var' mlenv' kv' mle' ∧
     env_rel env' mlenv' ∧
+    LIST_REL store_entry_rel store' st'.refs ∧
     st'.clock ≤ ck ∧
     (k ≠ [] ⇒ st'.clock < ck)
 Proof
   Cases_on ‘e’
+  >~ [‘Exp e’] >- (
+    Cases_on ‘e’
+    >> simp[step_def, Once e_ce_rel_cases]
+    >~ [‘Lit l’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> Cases_on ‘l’
+      >> simp[lit_to_val_def, to_ml_vals_def]
+      >> TRY CASE_TAC (*for Prim cases*)
+      >> TRY (Cases_on ‘b’) (*for Bool cases*)
+      >> gvs[lit_to_val_def, to_ml_vals_def]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
+        do_con_check_def, build_conv_def, nsOptBind_def, dec_clock_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+      >> gvs[env_rel_cases]
+    )
+    >~ [‘Cond c te fe’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> simp[Once cont_rel_cases]
+      >> gvs[scheme_env_def, env_rel_cases]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def]
+      >> metis_tac[]
+    )
+    >~ [‘Apply fn es’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = _’ $
+        irule_at (Pos $ hd o tl) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+      >> last_assum $ irule_at (Pos hd)
+      >> gvs[scheme_env_def, env_rel_cases]
+      >> irule_at (Pos hd) str_not_num
+      >> simp[isDigit_def, k_in_ts, t_in_ts]
+    )
+    >~ [‘Lambda xs xp e’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 7, do_opapp_def,
+        nsOptBind_def, dec_clock_def, do_con_check_def,
+        build_conv_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> last_assum $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+      >> gvs[env_rel_cases]
+      >> pop_assum $ irule_at (Pos last) o GSYM
+      >> pop_assum $ irule_at Any o GSYM
+      >> gvs[scheme_env_def]
+    )
+    >~ [‘Ident x’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> gvs[Once valid_state_cases]
+      >> gvs[Once static_scope_cases]
+      >> gvs[Once $ GSYM SPECIFICATION]
+      >> qpat_assum ‘env_rel _ _’ $ drule_then assume_tac
+        o SRULE [env_rel_cases, FEVERY_DEF]
+      >> qpat_assum ‘can_lookup _ _’ $ drule_then assume_tac
+        o SRULE [can_lookup_cases, FEVERY_DEF]
+      >> qpat_assum ‘LIST_REL _ _ _’ $ mp_tac
+        o SRULE [LIST_REL_EL_EQN, store_entry_rel_cases]
+      >> strip_tac
+      >> pop_assum $ drule_then assume_tac
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> simp[can_pmatch_all_def, pmatch_def, evaluate_match_def,
+        do_app_def, store_lookup_def]
+      >> Cases_on ‘EL (env ' x) store’
+      >> gvs[]
+      >> simp[can_pmatch_all_def, pmatch_def, evaluate_match_def,
+        do_app_def, store_lookup_def]
+      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases]
+      >> gvs[env_rel_cases, FEVERY_DEF]
+    )
+    >> cheat
+  )
   >~ [‘Val v’] >- (
     Cases_on ‘k’
     >- (
@@ -601,9 +939,76 @@ Proof
       >> gvs[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
+      >> irule_at (Pos hd) EQ_REFL
       >> gvs[scheme_env_def, env_rel_cases]
       >> metis_tac[]
     )
+    >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases,
+        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $
+        irule_at (Pos $ el 2) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+      >> qpat_assum ‘scheme_env env'’ $ simp
+        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def, t_in_ts]
+      >> gvs[env_rel_cases]
+    )
+    >> Cases_on ‘∃ e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases,
+        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $ irule_at
+        (Pos $ hd o tl) o GSYM
+      >> simp[Once cont_rel_cases]
+      >> SIMP_TAC std_ss [MAP_o]
+      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
+        o SIMP_RULE std_ss [Ntimes (GSYM MAP) 2, MAP_o]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> qpat_assum ‘scheme_env env'’ $ simp
+        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def, t_in_ts]
+      >> qpat_assum ‘LIST_REL _ vs _’ $ irule_at (Pos hd)
+      >> gvs[EVERY_CONJ]
+      >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
+        o SRULE [EVERY_MEM]
+      >> gvs[env_rel_cases]
+      >> irule EVERY2_MEM_MONO
+      >> qpat_assum ‘LIST_REL _ _ _’ $ irule_at (Pos last)
+      >> qpat_assum ‘LIST_REL _ _ _’ $ assume_tac o cj 1
+        o SRULE [EVERY2_EVERY]
+      >> PairCases >> simp[]
+      >> strip_tac
+      >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
+      >> simp[]
+      >> strip_tac
+      >> qpat_assum ‘LIST_REL _ ts mlvs’ $ assume_tac o cj 1
+        o SRULE [EVERY2_EVERY]
+      >> qsuff_tac ‘x0 ≠ t'’
+      >> strip_tac
+      >> gvs[]
+    )
     >> Cases_on ‘h1 = ApplyK NONE []’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases, Once cont_rel_cases]
@@ -650,6 +1055,14 @@ Proof
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
       )
+      >~ [‘SOME (Conv (SOME (TypeStamp "SList" _)) [_])’] >- (
+        qrefine ‘ck+1’
+        >> simp[Once evaluate_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
       >> qrefine ‘ck+2’
       >> simp[evaluate_def]
       >> simp[do_opapp_def,
@@ -676,7 +1089,29 @@ Proof
         >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
         >> simp[env_rel_cases, FEVERY_FEMPTY]
       )
-      >~ [‘proc_ml’] >- cheat
+      >~ [‘Proc _ _ _ _’] >- (
+        rpt (pairarg_tac >> gvs[])
+        >> irule preservation_of_proc
+        >> simp[]
+        >> qpat_assum ‘scheme_env env'³'’ $ simp
+          o curry ((::) o swap) [scheme_env_def]
+          o SRULE [scheme_env_def]
+        >> first_assum $ irule_at Any o GSYM
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+        >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
+        >> simp[]
+        >> simp[vcons_list_def]
+        >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
+        >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
+        >> strip_tac
+        >> simp[]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> strip_tac
+        >> simp[]
+        >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> strip_tac
+        >> gvs[env_rel_cases]
+      )
       >> irule_at (Pos hd) EQ_REFL
       >> simp[Once e_ce_rel_cases]
       >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -686,24 +1121,23 @@ Proof
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases]
-      >> simp[Once ml_v_vals'_cases]
       >> rpt strip_tac
-      >> gvs[application_def, sadd_def, smul_def, sminus_def,
-        seqv_def, cps_transform_def, cons_list_def]
-      >~ [‘"SAdd"’] >- (
-        qrefine ‘ck+1’
-        >> simp[evaluate_def, do_con_check_def,
-          build_conv_def, do_opapp_def, dec_clock_def]
-        >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
-          mlv env''.v)’
-        >- (
-          simp[] >> strip_tac
-          >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
-          env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
-            strip_tac
-            >> drule_all_then assume_tac cons_list_val
-            >> gvs[]
-            >> qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+      >> gvs[cps_transform_def, cons_list_def]
+      >> qrefine ‘ck+1’
+      >> simp[evaluate_def, do_con_check_def,
+        build_conv_def, do_opapp_def, dec_clock_def]
+      >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
+        mlv env''.v)’
+      >- (
+        simp[] >> strip_tac
+        >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
+        env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
+          strip_tac
+          >> drule_all_then assume_tac cons_list_val
+          >> gvs[Once ml_v_vals'_cases]
+          >> gvs[application_def]
+          >~ [‘"SAdd"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
             >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
             >> qrefine ‘ck+3’
             >> simp[Ntimes evaluate_def 3]
@@ -726,7 +1160,7 @@ Proof
             >> qid_spec_tac ‘n’
             >> pop_assum kall_tac
             >> rpt $ qpat_x_assum ‘LIST_REL _ ts _’ kall_tac
-            >> qpat_assum ‘LIST_REL _ _ _’ mp_tac
+            >> qpat_assum ‘LIST_REL _ vs mlvs’ mp_tac
             >> qid_spec_tac ‘mlvs’
             >> qid_spec_tac ‘vs’
             >> ho_match_mp_tac LIST_REL_SNOC_ind
@@ -753,7 +1187,8 @@ Proof
                 build_conv_def, nsOptBind_def]
                 >> simp[sadd_def]
                 >> irule_at (Pos hd) EQ_REFL
-                >> last_assum $ irule_at (Pos hd)
+                >> simp[]
+                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
                 >> simp[Once e_ce_rel_cases, opn_lookup_def,
                   env_rel_cases, FEVERY_FEMPTY, Once ml_v_vals'_cases]
                 >> simp[INT_ADD_COMM]
@@ -800,159 +1235,60 @@ Proof
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
             >> simp[env_rel_cases, FEVERY_FEMPTY]
           )
-          >> simp[]
-          >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
-            strip_tac
-            >> drule_then assume_tac EVERY2_LENGTH
-            >> drule_all $ iffRL EVERY2_EVERY
-            >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
-            >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
-            >> ho_match_mp_tac EVERY2_mono
+          >~ [‘"Proc"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+3’
+            >> simp[Ntimes evaluate_def 3]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> qrefine ‘ck+1’
+            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+            >> rpt (pairarg_tac >> gvs[])
+            >> irule preservation_of_proc
             >> simp[]
-          ) >> simp[EVERY_MEM] >> PairCases >> simp[]
-          >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
-          >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
-          >> strip_tac >> gvs[]
-        ) >> gvs[scheme_env_def]
-      ) >> cheat
-    )
-    >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
-      gvs[]
-      >> simp[step_def, return_def, Once e_ce_rel_cases,
-        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
-      >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
-      >> qrefine ‘ck+1’
-      >> simp[Ntimes evaluate_def 6, do_opapp_def,
-        nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $
-        irule_at (Pos $ el 2) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-      >> qpat_assum ‘scheme_env env'’ $ simp
-        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def, t_in_ts]
-      >> gvs[env_rel_cases]
-    )
-    >> Cases_on ‘∃ e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
-      gvs[]
-      >> simp[step_def, return_def, Once e_ce_rel_cases,
-        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
-      >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
-      >> qrefine ‘ck+1’
-      >> simp[Ntimes evaluate_def 6, do_opapp_def,
-        nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $ irule_at
-        (Pos $ hd o tl) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> SIMP_TAC std_ss [MAP_o]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-        o SIMP_RULE std_ss [Ntimes (GSYM MAP) 2, MAP_o]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> qpat_assum ‘scheme_env env'’ $ simp
-        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def, t_in_ts]
-      >> qpat_assum ‘LIST_REL _ vs _’ $ irule_at (Pos hd)
-      >> gvs[EVERY_CONJ]
-      >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
-        o SRULE [EVERY_MEM]
-      >> gvs[env_rel_cases]
-      >> irule EVERY2_MEM_MONO
-      >> qpat_assum ‘LIST_REL _ _ _’ $ irule_at (Pos last)
-      >> qpat_assum ‘LIST_REL _ _ _’ $ assume_tac o cj 1
-        o SRULE [EVERY2_EVERY]
-      >> PairCases >> simp[]
-      >> strip_tac
-      >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
-      >> simp[]
-      >> strip_tac
-      >> qsuff_tac ‘x0 ≠ t'’
-      >> strip_tac
-      >> gvs[]
-    )
-    >> cheat
-  )
-  >~ [‘Exp e’] >- (
-    Cases_on ‘e’
-    >> simp[step_def, Once e_ce_rel_cases]
-    >~ [‘Lit l’] >- (
-      simp[cps_transform_def]
-      >> rpt strip_tac
-      >> Cases_on ‘l’
-      >> simp[lit_to_val_def, to_ml_vals_def]
-      >> TRY CASE_TAC (*for Prim cases*)
-      >> TRY (Cases_on ‘b’) (*for Bool cases*)
-      >> gvs[lit_to_val_def, to_ml_vals_def]
-      >> qrefine ‘ck+1’
-      >> simp[SimpLHS, Ntimes evaluate_def 7, do_opapp_def,
-        do_con_check_def, build_conv_def, nsOptBind_def, dec_clock_def]
-      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
-        o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
-      >> gvs[env_rel_cases]
-    )
-    >~ [‘Cond c te fe’] >- (
-      simp[cps_transform_def]
-      >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
-      >> qrefine ‘ck+1’
-      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
-        nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> simp[Once cont_rel_cases]
-      >> gvs[scheme_env_def, env_rel_cases]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def]
-      >> metis_tac[]
-    )
-    >~ [‘Apply fn es’] >- (
-      simp[cps_transform_def]
-      >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
-      >> qrefine ‘ck+1’
-      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
-        nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = _’ $
-        irule_at (Pos $ hd o tl) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-      >> last_assum $ irule_at (Pos hd)
-      >> gvs[scheme_env_def, env_rel_cases]
-      >> irule_at (Pos hd) str_not_num
-      >> simp[isDigit_def, k_in_ts, t_in_ts]
-    )
-    >~ [‘Lambda xs xp e’] >- (
-      simp[cps_transform_def]
-      >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
-      >> qrefine ‘ck+1’
-      >> simp[Ntimes evaluate_def 7, do_opapp_def,
-        nsOptBind_def, dec_clock_def, do_con_check_def,
-        build_conv_def]
-      >> qpat_assum ‘scheme_env mlenv’ $ simp o single
-        o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
-      >> last_assum $ irule_at (Pos hd)
-      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
-      >> gvs[env_rel_cases]
-      >> pop_assum $ irule_at (Pos last) o GSYM
-      >> pop_assum $ irule_at Any o GSYM
+            >> qpat_assum ‘scheme_env env'³'’ $ simp
+              o curry ((::) o swap) [scheme_env_def]
+              o SRULE [scheme_env_def]
+            >> first_assum $ irule_at Any o GSYM
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+            >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
+            >> simp[]
+            >> irule_at (Pos hd) EQ_REFL
+            >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
+            >> irule_at (Pos last) $ cj 1 $ iffLR LIST_REL_APPEND
+            >> simp[]
+            >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
+            >> strip_tac
+            >> simp[]
+            >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+            >> strip_tac
+            >> simp[]
+            >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
+            >> strip_tac
+            >> gvs[env_rel_cases]
+          )
+          >> cheat
+        )
+        >> simp[]
+        >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
+          strip_tac
+          >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
+          >> drule_then assume_tac EVERY2_LENGTH
+          >> rev_drule_all $ iffRL EVERY2_EVERY
+          >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
+          >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
+          >> ho_match_mp_tac EVERY2_mono
+          >> simp[]
+        )
+        >> simp[EVERY_MEM] >> PairCases >> simp[]
+        >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
+        >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
+        >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
+        >> strip_tac >> gvs[]
+      )
+      >> gvs[scheme_env_def]
     )
     >> cheat
   )
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index aca260d3db..cbbed19eb3 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -113,7 +113,7 @@ Definition step_def:
   step (store, ks, env, Exp $ Cond c t f) = (store, (env, CondK t f) :: ks, env, Exp c) ∧
   (*This is undefined if the program doesn't typecheck*)
   step (store, ks, env, Exp $ Ident s) = (let ev = case EL (env ' s) store of
-    | NONE => Exception $ strlit "letrec variable touched"
+    | NONE => Exception $ strlit "Letrec variable touched"
     | SOME v => Val v
     in (store, ks, env, ev)) ∧
   step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 774d2032d9..1e6b57bf46 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -7,7 +7,6 @@ open scheme_astTheory;
 
 open semanticPrimitivesTheory;
 open namespaceTheory;
-open prim_recTheory;
 
 val _ = new_theory "scheme_to_cake";
 
@@ -37,8 +36,9 @@ Definition proc_ml_def:
         (Pany,
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"])
     ]) ∧
-  proc_ml n [] (SOME x) k args ce = (n, Let (SOME $ "s" ++ explode x)
-      (App Opref [Con (SOME $ Short "SList") [Var (Short args)]])
+  proc_ml n [] (SOME x) k args ce = (n, Let (SOME $ "var" ++ explode x)
+      (App Opref [Con (SOME $ Short "Some") [
+        Con (SOME $ Short "SList") [Var (Short args)]]])
       (App Opapp [ce; Var (Short k)])) ∧
   proc_ml n (x::xs) xp k args ce = (let
     arg = "x" ++ toString n;
@@ -49,7 +49,7 @@ Definition proc_ml_def:
         (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
         (Pcon (SOME $ Short "::") [Pvar arg; Pvar args'],
-          Let (SOME $ "s" ++ explode x)
+          Let (SOME $ "var" ++ explode x)
             (App Opref [Con (SOME $ Short "Some") [Var (Short arg)]])
             inner)
     ]))
@@ -57,7 +57,7 @@ End
 
 Definition letinit_ml_def:
   letinit_ml [] inner = inner ∧
-  letinit_ml ((x,_)::bs) inner = Let (SOME $ "s" ++ explode x)
+  letinit_ml ((x,_)::bs) inner = Let (SOME $ "var" ++ explode x)
       (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
 End
 
@@ -92,11 +92,11 @@ Definition cps_transform_def:
     (l, Fun k $ Let (SOME "k") (Fun t capp) $ App Opapp [cfn; Var (Short "k")])) ∧
 
   cps_transform n (Ident x) = (let k = "k" ++ toString n in
-    (n, Fun k $ Mat (App Opderef [Var (Short $ "s" ++ explode x)]) [
+    (n, Fun k $ Mat (App Opderef [Var (Short $ "var" ++ explode x)]) [
       (Pcon (SOME $ Short "None") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Letrec variable touched"]);
-      (Pcon (SOME $ Short "Some") [Pvar $ "s'" ++ explode x],
-        App Opapp [Var (Short k); Var (Short $ "s'" ++ explode x)])])) ∧
+      (Pcon (SOME $ Short "Some") [Pvar $ "'var" ++ explode x],
+        App Opapp [Var (Short k); Var (Short $ "'var" ++ explode x)])])) ∧
 
   cps_transform n (Lambda xs xp e) = (let
     (m, ce) = cps_transform n e;
@@ -121,7 +121,7 @@ Definition cps_transform_def:
     t = "t" ++ toString (m+1);
   in
     (m+2, Fun k $ Let (SOME "k")
-      (Fun t $ Let NONE (App Opassign [Var (Short $ "s" ++ explode x);
+      (Fun t $ Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
             Con (SOME $ Short "Some") [Var (Short t)]]) $
           Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
             (App Opapp [Var (Short k); Var (Short "v")])) $
@@ -168,37 +168,15 @@ Definition cps_transform_def:
     t = "t" ++ toString l
   in
     (l+1, App Opapp [ce'; Fun t $ Let NONE
-      (App Opassign [Var (Short $ "s" ++ explode x);
+      (App Opassign [Var (Short $ "var" ++ explode x);
         Con (SOME $ Short "Some") [Var (Short t)]])
       inner]))
 Termination
-  (*WF_REL_TAC ‘measure (λ x . case x of
-    | INL(_,e) => exp_size e
-    | INR(INL(_,_,_,es,_)) => list_size exp_size es
-    | INR(INR(INL(_,_,es,e))) => list_size exp_size (e::es)
-    | INR(INR(INR(_,_,bs,_))) => exp1_size bs)’*)
-  WF_REL_TAC ‘(λ x y . case x of
-    | INL(_,e) => (case y of
-      | INL(_,e') => exp_size e < exp_size e'
-      | INR(INL(_,_,_,es,_)) => exp_size e < exp3_size es
-      | INR(INR(INL(_,_,es,e'))) => exp_size e < exp3_size (e'::es)
-      | INR(INR(INR(_,_,bs,_))) => exp_size e < exp1_size bs)
-    | INR(INL(_,_,_,es,_)) => (case y of
-      | INL(_,e) => T
-      | INR(INL(_,_,_,es',_)) => exp3_size es < exp3_size es'
-      | INR(INR(INL(_,_,es',e))) => exp3_size es < exp3_size (e::es')
-      | INR(INR(INR(_,_,bs,_))) => exp3_size es < exp1_size bs)
-    | INR(INR(INL(_,_,es,e))) => (case y of
-      | INL(_,e') => T
-      | INR(INL(_,_,_,es',_)) => exp3_size (e::es) < exp3_size es'
-      | INR(INR(INL(_,_,es',e'))) => exp3_size (e::es) < exp3_size (e'::es')
-      | INR(INR(INR(_,_,bs,_))) => exp3_size (e::es) < exp1_size bs)
-    | INR(INR(INR(_,_,bs,_))) => (case y of
-      | INL(_,e) => T
-      | INR(INL(_,_,_,es,_)) => exp1_size bs < exp3_size es
-      | INR(INR(INL(_,_,es,e))) => exp1_size bs < exp3_size (e::es)
-      | INR(INR(INR(_,_,bs',_))) => exp1_size bs < exp1_size bs'))’
-  >> cheat
+  WF_REL_TAC ‘inv_image ($< LEX $<) (λ x . case x of
+    | INL(_,e) => (exp_size e, 0)
+    | INR(INL(_,_,_,es,_)) => (list_size exp_size es, 1n)
+    | INR(INR(INL(_,_,es,e))) => (list_size exp_size es + exp_size e, 1)
+    | INR(INR(INR(_,_,bs,_))) => (exp1_size bs), 1)’
 End
 
 Definition compile_scheme_prog_def:

From 1bbd0bb200d20fb8755748ab2874f78a59ca018d Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 12 Apr 2025 19:04:33 +0100
Subject: [PATCH 076/100] slight restructuring, proof dir

---
 compiler/scheme/README.md                     |   3 +
 compiler/scheme/proofs/Holmakefile            |  21 +
 compiler/scheme/proofs/README.md              |   7 +
 compiler/scheme/proofs/readmePrefix           |   1 +
 .../proofs/scheme_semanticsPropsScript.sml    | 875 ++++++++++++++++++
 .../scheme_to_cakeProofScript.sml}            |   7 +-
 compiler/scheme/scheme_semanticsScript.sml    | 868 -----------------
 7 files changed, 911 insertions(+), 871 deletions(-)
 create mode 100644 compiler/scheme/proofs/Holmakefile
 create mode 100644 compiler/scheme/proofs/README.md
 create mode 100644 compiler/scheme/proofs/readmePrefix
 create mode 100644 compiler/scheme/proofs/scheme_semanticsPropsScript.sml
 rename compiler/scheme/{scheme_proofsScript.sml => proofs/scheme_to_cakeProofScript.sml} (99%)

diff --git a/compiler/scheme/README.md b/compiler/scheme/README.md
index 1e58de6e84..a54bda6550 100644
--- a/compiler/scheme/README.md
+++ b/compiler/scheme/README.md
@@ -6,6 +6,9 @@ Compilation scripts for the Scheme-to-CakeML compiler.
 [examples](examples):
 Example Scheme programs compiled using the Scheme compiler
 
+[proofs](proofs):
+Proofs for Scheme to CakeML compiler
+
 [scheme_astScript.sml](scheme_astScript.sml):
 AST of Scheme
 
diff --git a/compiler/scheme/proofs/Holmakefile b/compiler/scheme/proofs/Holmakefile
new file mode 100644
index 0000000000..366d8e8b5b
--- /dev/null
+++ b/compiler/scheme/proofs/Holmakefile
@@ -0,0 +1,21 @@
+INCLUDES = $(CAKEMLDIR)/translator \
+           $(CAKEMLDIR)/basis \
+           $(CAKEMLDIR)/basis/pure \
+           $(CAKEMLDIR)/compiler/parsing \
+           $(CAKEMLDIR)/semantics \
+           $(CAKEMLDIR)/misc \
+           $(HOLDIR)/examples/formal-languages/context-free \
+           $(CAKEMLDIR)/compiler/scheme
+
+all: $(DEFAULT_TARGETS) README.md
+.PHONY: all
+
+README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
+# Filter out tests/ (they don't have a readmePrefix)
+DIRS = $(patsubst tests/,,$(wildcard */))
+README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+	$(CAKEMLDIR)/developers/readme_gen $(README_SOURCES)
+
+ifdef POLY
+HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap
+endif
diff --git a/compiler/scheme/proofs/README.md b/compiler/scheme/proofs/README.md
new file mode 100644
index 0000000000..521f60311e
--- /dev/null
+++ b/compiler/scheme/proofs/README.md
@@ -0,0 +1,7 @@
+Proofs for Scheme to CakeML compiler
+
+[scheme_semanticsPropsScript.sml](scheme_semanticsPropsScript.sml):
+Proofs of Scheme semantics properties
+
+[scheme_to_cakeProofScript.sml](scheme_to_cakeProofScript.sml):
+Proof of semantic preservation from Scheme to CakeML
diff --git a/compiler/scheme/proofs/readmePrefix b/compiler/scheme/proofs/readmePrefix
new file mode 100644
index 0000000000..07c4426a11
--- /dev/null
+++ b/compiler/scheme/proofs/readmePrefix
@@ -0,0 +1 @@
+Proofs for Scheme to CakeML compiler
diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
new file mode 100644
index 0000000000..f61f79a686
--- /dev/null
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -0,0 +1,875 @@
+(*
+  Proofs of Scheme semantics properties
+*)
+open preamble;
+open mlstringTheory;
+open scheme_astTheory;
+open scheme_semanticsTheory;
+open finite_mapTheory;
+
+val _ = new_theory "scheme_semanticsProps";
+
+Inductive can_lookup:
+  FEVERY (λ (x, n). n < LENGTH store) env
+  ⇒
+  can_lookup env store
+End
+
+Inductive valid_val:
+[~val_SNum:]
+  valid_val store (SNum n)
+[~val_SBool:]
+  valid_val store (SBool b)
+[~val_Prim:]
+  valid_val store (Prim p)
+[~val_Wrong:]
+  valid_val store (Wrong w)
+[~val_SList:]
+  EVERY (valid_val store) vs
+  ⇒
+  valid_val store (SList vs)
+[~val_Proc_NONE:]
+  static_scope (FDOM env ∪ set xs) e ∧
+  can_lookup env store
+  ⇒
+  valid_val store (Proc env xs NONE e)
+[~val_Proc_SOME:]
+  static_scope (FDOM env ∪ set (x::xs)) e ∧
+  can_lookup env store
+  ⇒
+  valid_val store (Proc env xs (SOME x) e)
+[~val_Throw:]
+  valid_cont store ks
+  ⇒
+  valid_val store (Throw ks)
+
+[~cont_Id:]
+  valid_cont store []
+[~cont_CondK:]
+  static_scope (FDOM env) t ∧
+  static_scope (FDOM env) f ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, CondK t f)::ks)
+[~cont_ApplyK_NONE:]
+  EVERY (static_scope (FDOM env)) es ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, ApplyK NONE es)::ks)
+[~cont_ApplyK_SOME:]
+  valid_val store fn ∧
+  EVERY (valid_val store) vs ∧
+  EVERY (static_scope (FDOM env)) es ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, ApplyK (SOME (fn, vs)) es)::ks)
+[~cont_BeginK:]
+  EVERY (static_scope (FDOM env)) es ∧
+  static_scope (FDOM env) e ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, BeginK es e)::ks)
+[~cont_SetK:]
+  (FDOM env) x ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, SetK x)::ks)
+End
+
+Inductive valid_state:
+[~Val:]
+  valid_val store v ∧
+  valid_cont store ks ∧
+  can_lookup env store ∧
+  EVERY (OPTION_ALL (valid_val store)) store
+  ⇒
+  valid_state store ks env (Val v)
+[~Exp:]
+  static_scope (FDOM env) e ∧
+  valid_cont store ks ∧
+  can_lookup env store ∧
+  EVERY (OPTION_ALL (valid_val store)) store
+  ⇒
+  valid_state store ks env (Exp e)
+[~Exception:]
+  valid_state store ks env (Exception s)
+End
+
+Theorem FEVERY_MONO:
+  ∀ P Q f .
+    (∀ x . P x ⇒ Q x) ∧ FEVERY P f
+    ⇒
+    FEVERY Q f
+Proof
+  Induct_on ‘f’
+  >> rpt strip_tac >- simp[FEVERY_FEMPTY]
+  >> last_x_assum $ drule_then assume_tac
+  >> gvs[FEVERY_FUPDATE]
+  >> qsuff_tac ‘DRESTRICT f (COMPL {x}) = f’ >- (strip_tac >> gvs[])
+  >> simp[EQ_FDOM_SUBMAP, DRESTRICT_DEF, EXTENSION]
+  >> strip_tac
+  >> iff_tac
+  >> rpt strip_tac
+  >> gvs[]
+QED
+
+Theorem EVERY_OPTION_ALL_MAP_SOME:
+  ∀ f xs . EVERY f xs ⇒ EVERY (OPTION_ALL f) (MAP SOME xs)
+Proof
+  strip_tac
+  >> Induct
+  >> simp[]
+QED
+
+Theorem EVERY_TAKE:
+  ∀ f n xs . EVERY f xs ⇒ EVERY f (TAKE n xs)
+Proof
+  gen_tac
+  >> Induct_on ‘xs’
+  >> Cases_on ‘n’
+  >> simp[]
+QED
+
+Theorem valid_larger_store:
+  ∀ (store :'a list) (store' :'a list) .
+    LENGTH store ≤ LENGTH store'
+    ⇒
+    (∀ v .
+      valid_val store v
+      ⇒
+      valid_val store' v) ∧
+    ∀ ks .
+      valid_cont store ks
+      ⇒
+      valid_cont store' ks
+Proof
+  rpt gen_tac >> strip_tac
+  >> ho_match_mp_tac valid_val_ind
+  >> rpt strip_tac
+  >> simp[Once valid_val_cases]
+  >> gvs[can_lookup_cases]
+  >> gvs[SF ETA_ss]
+  >> irule FEVERY_MONO
+  >> pop_assum $ irule_at (Pos last)
+  >> PairCases
+  >> rpt strip_tac
+  >> gvs[]
+QED
+
+Theorem valid_val_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
+  cj 1 valid_larger_store;
+Theorem valid_cont_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
+  cj 2 valid_larger_store;
+
+Theorem letrec_init_mono:
+  ∀ bs store env store' env' .
+    letrec_init store env bs = (store', env')
+    ⇒
+    FDOM env ⊆ FDOM env'
+Proof
+  Induct
+  >> simp[letrec_init_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule
+  >> simp[]
+QED
+
+Theorem letrec_init_dom:
+  ∀ xs store env store' env' .
+    letrec_init store env xs = (store', env')
+    ⇒
+    FDOM env ∪ set xs = FDOM env' ∧
+    store ++ GENLIST (λ x. NONE) (LENGTH xs) = store'
+Proof
+  Induct
+  >> simp[letrec_init_def, fresh_loc_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_then assume_tac
+  >> gvs[GENLIST] >- (
+    rpt strip_tac
+    >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
+    >> simp[EXTENSION]
+    >> simp[UNION_DEF, INSERT_DEF, SPECIFICATION, GSYM DISJ_ASSOC]
+    >> strip_tac
+    >> iff_tac
+    >> rw[] >> rw[]
+  )
+  >> rpt $ pop_assum kall_tac
+  >> ‘∃ n . LENGTH xs = n’ by simp[]
+  >> simp[]
+  >> pop_assum kall_tac
+  >> Induct_on ‘n’
+  >> simp[GENLIST]
+QED
+
+Theorem letrec_init_lookup:
+  ∀ xs store env store' env' .
+    can_lookup env store ∧
+    letrec_init store env xs = (store', env')
+    ⇒
+    can_lookup env' store'
+Proof
+  Induct
+  >> simp[letrec_init_def, fresh_loc_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> qsuff_tac ‘can_lookup (env |+ (h,LENGTH store)) (SNOC NONE store)’ >- (
+    strip_tac
+    >> last_x_assum drule_all
+    >> simp[]
+  )
+  >> gvs[can_lookup_cases]
+  >> qsuff_tac ‘FEVERY (λ(x,n). n < SUC (LENGTH store)) env’ >- (
+    strip_tac
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+  )
+  >> irule FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_NONE_dom:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs = LENGTH vs ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    Exp e = e' ∧
+    FDOM env ∪ set xs = FDOM env' ∧
+    store ++ MAP SOME vs = store'
+Proof
+  Induct
+  >> simp[parameterize_def]
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 2)
+  >> rpt strip_tac
+  >> gvs[] >- (
+    pop_assum $ simp o single o GSYM
+    >> simp[Once INSERT_SING_UNION, EXTENSION]
+    >> strip_tac
+    >> iff_tac
+    >> strip_tac
+    >> simp[]
+  )
+  >> gvs[fresh_loc_def]
+QED
+
+Theorem parameterize_NONE_lookup:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs = LENGTH vs ∧
+    can_lookup env store ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    can_lookup env' store'
+Proof
+  Induct
+  >> simp[parameterize_def]
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 3)
+  >> rpt strip_tac
+  >> gvs[]
+  >> pop_assum irule
+  >> gvs[can_lookup_cases, fresh_loc_def]
+  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+  >> simp[]
+  >> irule $ FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_NONE_exception:
+  ∀ xs store env vs store' env' e e' .
+    LENGTH xs ≠ LENGTH vs ∧
+    parameterize store env xs NONE e vs = (store', env', e')
+    ⇒
+    ∃ s . Exception s = e'
+Proof
+  Induct
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule_all
+  >> simp[]
+QED
+
+Theorem parameterize_SOME_dom:
+  ∀ xs vs store env x store' env' e e' .
+    LENGTH xs ≤ LENGTH vs ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    Exp e = e' ∧
+    FDOM env ∪ set (x::xs) = FDOM env' ∧
+    store ++ MAP SOME (TAKE (LENGTH xs) vs)
+      ++ [SOME (SList (REVERSE (TAKE (LENGTH vs - LENGTH xs) (REVERSE vs))))]
+      = store'
+Proof
+  gen_tac >> gen_tac
+  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
+  >> pop_assum mp_tac
+  >> qid_spec_tac ‘vs’
+  >> Induct_on ‘xs’
+  >> simp[parameterize_def, fresh_loc_def] >- (
+    strip_tac >> strip_tac
+    >> simp_tac bool_ss [Once $ GSYM LENGTH_REVERSE]
+    >> simp[TAKE_LENGTH_ID]
+    >> simp[Once UNION_COMM]
+    >> simp[Once $ GSYM INSERT_SING_UNION]
+  )
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 3)
+  >> rpt strip_tac
+  >> gvs[fresh_loc_def] >- (
+    pop_assum $ simp o single o GSYM
+    >> simp[EXTENSION]
+    >> strip_tac
+    >> iff_tac
+    >> strip_tac
+    >> simp[]
+  )
+  >> simp[TAKE_APPEND1]
+QED
+
+Theorem parameterize_SOME_lookup:
+  ∀ xs vs store env x store' env' e e' .
+    LENGTH xs ≤ LENGTH vs ∧
+    can_lookup env store ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    can_lookup env' store'
+Proof
+  gen_tac >> gen_tac
+  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
+  >> pop_assum mp_tac
+  >> qid_spec_tac ‘vs’
+  >> Induct_on ‘xs’
+  >> simp[parameterize_def, fresh_loc_def] >- (
+    simp[can_lookup_cases]
+    >> rpt strip_tac
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+    >> irule $ FEVERY_MONO
+    >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+    >> PairCases
+    >> simp[]
+  )
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum $ drule_at (Pos $ el 4)
+  >> rpt strip_tac
+  >> gvs[]
+  >> pop_assum irule
+  >> gvs[fresh_loc_def, can_lookup_cases]
+  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+  >> simp[]
+  >> irule $ FEVERY_MONO
+  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
+  >> PairCases
+  >> simp[]
+QED
+
+Theorem parameterize_SOME_exception:
+  ∀ xs store env x vs store' env' e e' .
+    LENGTH vs < LENGTH xs ∧
+    parameterize store env xs (SOME x) e vs = (store', env', e')
+    ⇒
+    ∃ s . Exception s = e'
+Proof
+  Induct
+  >> Cases_on ‘vs’
+  >> simp[parameterize_def]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> last_x_assum drule_all
+  >> simp[]
+QED
+
+Theorem sadd_num_or_exception:
+  ∀ vs n .
+    (∃ m . sadd vs n = Val (SNum m)) ∨
+    (∃ s . sadd vs n = Exception s)
+Proof
+  Induct
+  >> simp[sadd_def]
+  >> Cases
+  >> simp[sadd_def]
+QED
+
+Theorem smul_num_or_exception:
+  ∀ vs n .
+    (∃ m . smul vs n = Val (SNum m)) ∨
+    (∃ s . smul vs n = Exception s)
+Proof
+  Induct
+  >> simp[smul_def]
+  >> Cases
+  >> simp[smul_def]
+QED
+
+Theorem sminus_num_or_exception:
+  ∀ vs .
+    (∃ m . sminus vs = Val (SNum m)) ∨
+    (∃ s . sminus vs = Exception s)
+Proof
+  Cases
+  >> simp[sminus_def]
+  >> Cases_on ‘h’
+  >> simp[sminus_def]
+  >> qspecl_then [‘t’, ‘0’] assume_tac sadd_num_or_exception
+  >> EVERY_CASE_TAC
+  >> gvs[]
+QED
+
+Theorem seqv_bool_or_exception:
+  ∀ vs .
+    (∃ b . seqv vs = Val (SBool b)) ∨
+    (∃ s . seqv vs = Exception s)
+Proof
+  Cases
+  >> simp[seqv_def]
+  >> Cases_on ‘t’
+  >> simp[seqv_def]
+  >> Cases_on ‘t'’
+  >> simp[seqv_def]
+  >> IF_CASES_TAC
+  >> simp[]
+QED
+
+Theorem valid_state_progress:
+  ∀ store ks env state .
+    valid_state store ks env state
+    ⇒
+    ∃ store' ks' env' state' .
+      step (store, ks, env, state) = (store', ks', env', state') ∧
+      valid_state store' ks' env' state'
+Proof
+  Cases_on ‘state’
+  >> rpt strip_tac
+  >~ [‘Exp e’] >- (
+    Cases_on ‘e’
+    >~ [‘Lit l’] >- (
+      Cases_on ‘l’
+      >> simp[step_def, lit_to_val_def]
+      >> simp[Once valid_state_cases, Once valid_val_cases]
+      >> gvs[Once valid_state_cases]
+    )
+    >~ [‘Begin es e’] >- (
+      Cases_on ‘es’ >- (
+        simp[step_def, Once valid_state_cases]
+        >> gvs[Once valid_state_cases, Once static_scope_cases]
+      )
+      >> simp[step_def, Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_cases]
+    )
+    >~ [‘Ident x’] >- (
+      simp[step_def]
+      >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+      >> ‘∀ x . FDOM env x ⇒ ∃ a. FLOOKUP env x = SOME a’
+        by simp[FLOOKUP_DEF, SPECIFICATION]
+      >> pop_assum drule >> strip_tac
+      >> drule_all_then assume_tac FEVERY_FLOOKUP
+      >> qpat_assum ‘EVERY _ _’ $ assume_tac o SRULE [EVERY_EL]
+      >> gvs[]
+      >> pop_assum $ drule_then assume_tac
+      >> ‘∀ x a . FLOOKUP env x = SOME a ⇒ env ' x = a’ by simp[FLOOKUP_DEF]
+      >> pop_assum $ drule_then assume_tac
+      >> simp[]
+      >> Cases_on ‘EL a store’ >- simp[Once valid_state_cases]
+      >> gvs[Once valid_state_cases, can_lookup_cases]
+    )
+    >~ [‘Letrec bs e’] >- (
+      simp[step_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> simp[Once valid_state_cases, Once static_scope_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_cases]
+      >> drule_then assume_tac letrec_init_dom
+      >> drule_all_then assume_tac letrec_init_lookup
+      >> gvs[]
+      >> irule_at (Pos $ el 2) valid_cont_larger_store
+      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> irule_at (Pos $ el 2) EVERY_MONOTONIC
+      >> qpat_assum ‘EVERY (OPTION_ALL _) _’ $ irule_at (Pos $ el 2)
+      >> strip_tac >- (
+        rpt strip_tac
+        >> irule_at (Pos hd) OPTION_ALL_MONO
+        >> pop_assum $ irule_at (Pos last)
+        >> rpt strip_tac
+        >> irule valid_val_larger_store
+        >> pop_assum $ irule_at (Pos last)
+        >> simp[]
+      )
+      >> simp[EVERY_GENLIST]
+      >> qpat_assum ‘EVERY _ (MAP SND bs)’ mp_tac
+      >> qpat_assum ‘FDOM _ ∪ _ = FDOM _’ mp_tac
+      >> rpt (pop_assum kall_tac)
+      >> qid_spec_tac ‘env’
+      >> Induct_on ‘bs’ >- simp[]
+      >> rpt strip_tac
+      >> PairCases_on ‘h’
+      >> simp[Once static_scope_cases]
+      >> gvs[]
+      >> last_x_assum $ qspec_then ‘env |+ (h0, 0)’ assume_tac
+      >> gvs[]
+      >> qsuff_tac ‘FDOM env ∪ (h0 INSERT set (MAP FST bs))
+        = (h0 INSERT FDOM env) ∪ set (MAP FST bs)’ >- (
+        strip_tac
+        >> pop_assum $ gvs o single
+        >> last_x_assum $ simp o single o GSYM
+      )
+      >> rpt $ pop_assum kall_tac
+      >> simp[EXTENSION, UNION_DEF]
+      >> strip_tac
+      >> iff_tac
+      >> strip_tac
+      >> simp[]
+    )
+    >> simp[step_def, Once valid_state_cases]
+    >> simp[Once valid_val_cases]
+    >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+  )
+  >~ [‘Val v’] >- (
+    Cases_on ‘ks’ >- (
+      simp[step_def, return_def, Once valid_state_cases,
+        can_lookup_cases, FEVERY_FEMPTY]
+      >> gvs[Once valid_state_cases]
+    )
+    >> PairCases_on ‘h’
+    >> Cases_on ‘h1’
+    >~ [‘CondK t f’] >- (
+      simp[step_def, return_def]
+      >> IF_CASES_TAC >- (
+        gvs[Once valid_state_cases, Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+        >> simp[Once valid_state_cases]
+      )
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+    )
+    >~ [‘BeginK es e’] >- (
+      simp[step_def, return_def]
+      >> CASE_TAC
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+    )
+    >~ [‘SetK x’] >- (
+      simp[step_def, return_def]
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+      >> irule_at (Pos hd) valid_cont_larger_store
+      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> gvs[can_lookup_cases]
+      >> irule IMP_EVERY_LUPDATE
+      >> simp[OPTION_ALL_def]
+      >> irule_at (Pos hd) valid_val_larger_store
+      >> last_assum $ irule_at (Pos $ el 2)
+      >> simp[]
+      >> irule EVERY_MONOTONIC
+      >> qpat_assum ‘EVERY _ _’ $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule OPTION_ALL_MONO
+      >> pop_assum $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule_at (Pos hd) valid_val_larger_store
+      >> pop_assum $ irule_at (Pos last)
+      >> simp[]
+    )
+    >~ [‘ApplyK fnp es’] >- (
+      simp[step_def]
+      >> Cases_on ‘∃ e es' . es = e::es'’ >-(
+        gvs[]
+        >> Cases_on ‘∃ fn vs . fnp = SOME (fn,vs)’
+        >> Cases_on ‘fnp = NONE’
+        >> gvs[]
+        >> simp[return_def]
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> simp[Once valid_val_cases]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> simp[]
+        >> Cases_on ‘fnp’ >> gvs[] >> PairCases_on ‘x’ >> gvs[]
+      )
+      >> Cases_on ‘es’ >> gvs[]
+      >> Cases_on ‘fnp’ >- (
+        simp[return_def]
+        >> Cases_on ‘v’
+        >> simp[application_def]
+        >~ [‘Prim p’] >- (
+          CASE_TAC
+          >> simp[Once valid_state_cases, sadd_def, smul_def,
+            sminus_def, seqv_def, can_lookup_cases, FEVERY_FEMPTY]
+          >> simp[Once valid_val_cases]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >~ [‘Proc env' xs xp e’] >- (
+          Cases_on ‘xp’
+          >> Cases_on ‘xs’
+          >> simp[parameterize_def] >- (
+            simp[Once valid_state_cases]
+            >> gvs[Once valid_state_cases]
+            >> gvs[Once valid_val_cases]
+            >> gvs[Once valid_val_cases]
+          )
+          >- simp[Once valid_state_cases]
+          >- (
+            rpt (pairarg_tac >> gvs[])
+            >> simp[Once valid_state_cases]
+            >> gvs[Once valid_state_cases, fresh_loc_def]
+            >> gvs[Once valid_val_cases]
+            >> gvs[Once valid_val_cases]
+            >> simp[Once INSERT_SING_UNION, Once UNION_COMM]
+            >> irule_at (Pos hd) valid_cont_larger_store
+            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+            >> simp[Once valid_val_cases]
+            >> irule_at (Pos $ el 2) $ EVERY_MONOTONIC
+            >> pop_assum $ irule_at (Pos $ el 2)
+            >> gvs[can_lookup_cases]
+            >> irule_at (Pos $ el 2) $ cj 2 FEVERY_STRENGTHEN_THM
+            >> simp[]
+            >> irule_at (Pos hd) FEVERY_MONO
+            >> qpat_assum ‘FEVERY _ env'’ $ irule_at (Pos $ el 2)
+            >> rpt strip_tac >- (PairCases_on ‘x'’ >> gvs[])
+            >> irule OPTION_ALL_MONO
+            >> pop_assum $ irule_at (Pos last)
+            >> rpt strip_tac
+            >> irule valid_val_larger_store
+            >> pop_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> simp[Once valid_state_cases]
+          >> gvs[Once valid_state_cases]
+          >> gvs[Once valid_val_cases]
+          >> gvs[Once valid_val_cases]
+        )
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> gvs[Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+      )
+      >> PairCases_on ‘x’
+      >> simp[return_def]
+      >> Cases_on ‘x0’
+      >> simp[application_def]
+      >~ [‘Prim p’] >- (
+        TOP_CASE_TAC >- (
+          qspecl_then [‘REVERSE x1 ++ [v]’, ‘0’] assume_tac sadd_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspecl_then [‘REVERSE x1 ++ [v]’, ‘1’] assume_tac smul_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac sminus_num_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >- (
+          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac seqv_bool_or_exception
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >> CASE_TAC
+        >> gvs[]
+        >> Cases_on ‘t'’ >- (
+          gvs[]
+          >> simp[Once valid_state_cases]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> rpt strip_tac
+          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
+        )
+        >> gvs[]
+        >> simp[Once valid_state_cases]
+        >> gvs[Once valid_state_cases]
+        >> gvs[Once valid_val_cases]
+        >> gvs[Once valid_val_cases]
+      )
+      >~ [‘Proc env' xs xp e’] >- (
+        rpt (pairarg_tac >> gvs[])
+        >> gvs[Once valid_state_cases]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
+        >> rpt strip_tac
+        >> gvs[] >- (
+          Cases_on ‘LENGTH xs = LENGTH (REVERSE x1 ++ [v])’ >- (
+            drule_all_then mp_tac parameterize_NONE_dom
+            >> drule_all_then mp_tac parameterize_NONE_lookup
+            >> rpt strip_tac
+            >> qpat_x_assum ‘Exp _ = _’ $ simp o single o GSYM
+            >> simp[Once valid_state_cases]
+            >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
+            >> qpat_x_assum ‘_ ++ _ = _’ $ simp o single o GSYM
+            >> irule_at (Pos hd) $ valid_cont_larger_store
+            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+            >> simp[]
+            >> irule_at (Pos hd) EVERY_MONOTONIC
+            >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+            >> strip_tac >- (
+              rpt strip_tac
+              >> irule OPTION_ALL_MONO
+              >> pop_assum $ irule_at (Pos last)
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> strip_tac >- (
+              irule EVERY_OPTION_ALL_MAP_SOME
+              >> irule EVERY_MONOTONIC
+              >> qexists ‘valid_val store’
+              >> simp[]
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> drule_all_then mp_tac parameterize_NONE_exception
+          >> rpt strip_tac
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+        )
+        >> Cases_on ‘LENGTH xs ≤ LENGTH (REVERSE x1 ++ [v])’ >- (
+          drule_all_then mp_tac parameterize_SOME_dom
+          >> drule_all_then mp_tac parameterize_SOME_lookup
+          >> rpt strip_tac
+          >> simp[Once valid_state_cases]
+          >> gvs[]
+          >> irule_at (Pos hd) $ valid_cont_larger_store
+          >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
+          >> simp[]
+          >> irule_at (Pos hd) EVERY_MONOTONIC
+          >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+          >> strip_tac >- (
+            rpt strip_tac
+            >> irule OPTION_ALL_MONO
+            >> pop_assum $ irule_at (Pos last)
+            >> rpt strip_tac
+            >> irule valid_val_larger_store
+            >> pop_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> strip_tac >- (
+            irule EVERY_OPTION_ALL_MAP_SOME
+            >> irule EVERY_TAKE
+            >> simp[]
+            >> strip_tac >- (
+              irule EVERY_MONOTONIC
+              >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
+              >> rpt strip_tac
+              >> irule valid_val_larger_store
+              >> pop_assum $ irule_at (Pos last)
+              >> simp[]
+            )
+            >> irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> simp[Once valid_val_cases]
+          >> irule EVERY_TAKE
+          >> simp[]
+          >> strip_tac >- (
+            irule valid_val_larger_store
+            >> last_assum $ irule_at (Pos last)
+            >> simp[]
+          )
+          >> irule EVERY_MONOTONIC
+          >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
+          >> rpt strip_tac
+          >> irule valid_val_larger_store
+          >> pop_assum $ irule_at (Pos last)
+          >> simp[]
+        )
+        >> ‘LENGTH (REVERSE x1 ++ [v]) < LENGTH xs’ by gvs[]
+        >> drule_all_then mp_tac parameterize_SOME_exception
+        >> rpt strip_tac
+        >> simp[Once valid_state_cases]
+        >> gvs[]
+      )
+      >~ [‘Throw ks’] >- (
+        CASE_TAC >- simp[Once valid_state_cases]
+        >> CASE_TAC >- (
+          gvs[]
+          >> simp[Once valid_state_cases, can_lookup_cases, FEVERY_FEMPTY]
+          >> gvs[Once valid_state_cases]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> rpt strip_tac
+          >> qpat_x_assum ‘valid_val _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> simp[]
+        )
+        >> simp[Once valid_state_cases]
+      )
+      >> simp[Once valid_state_cases]
+      >> gvs[Once valid_state_cases]
+      >> gvs[Once valid_val_cases]
+      >> gvs[Once valid_val_cases]
+    )
+  )
+  >> simp[step_def, Once valid_state_cases]
+QED
+
+Theorem statically_scoped_program_valid:
+  ∀ p . static_scope ∅ p ⇒ valid_state [] [] FEMPTY (Exp p)
+Proof
+  simp[Once valid_state_cases,
+    can_lookup_cases, FEVERY_FEMPTY]
+  >> simp[Once valid_val_cases]
+QED
+
+val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/scheme_proofsScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
similarity index 99%
rename from compiler/scheme/scheme_proofsScript.sml
rename to compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 1e0139721c..358a6a3bba 100644
--- a/compiler/scheme/scheme_proofsScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -1,13 +1,14 @@
 (*
-  Proofs for Scheme to CakeML compilation
+  Proof of semantic preservation from Scheme to CakeML
 *)
 open preamble;
 open computeLib;
 open scheme_astTheory;
 open scheme_semanticsTheory;
 open scheme_to_cakeTheory;
-open astTheory;
+open scheme_semanticsPropsTheory;
 
+open astTheory;
 open evaluateTheory;
 open evaluatePropsTheory;
 open semanticPrimitivesTheory;
@@ -16,7 +17,7 @@ open primTypesTheory;
 open namespacePropsTheory;
 open integerTheory;
 
-val _ = new_theory "scheme_proofs";
+val _ = new_theory "scheme_to_cakeProof";
 
 val _ = (max_print_depth := 50);
 
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index cbbed19eb3..5e8dd4af93 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -134,874 +134,6 @@ Definition steps_def:
     else steps (n - 1) $ step t
 End
 
-Definition option_to_set_def:
-  option_to_set NONE = ∅ ∧
-  option_to_set (SOME x) = {x}
-End
-
-Inductive can_lookup:
-  FEVERY (λ (x, n). n < LENGTH store) env
-  ⇒
-  can_lookup env store
-End
-
-Inductive valid_val:
-[~val_SNum:]
-  valid_val store (SNum n)
-[~val_SBool:]
-  valid_val store (SBool b)
-[~val_Prim:]
-  valid_val store (Prim p)
-[~val_Wrong:]
-  valid_val store (Wrong w)
-[~val_SList:]
-  EVERY (valid_val store) vs
-  ⇒
-  valid_val store (SList vs)
-[~val_Proc_NONE:]
-  static_scope (FDOM env ∪ set xs) e ∧
-  can_lookup env store
-  ⇒
-  valid_val store (Proc env xs NONE e)
-[~val_Proc_SOME:]
-  static_scope (FDOM env ∪ set (x::xs)) e ∧
-  can_lookup env store
-  ⇒
-  valid_val store (Proc env xs (SOME x) e)
-[~val_Throw:]
-  valid_cont store ks
-  ⇒
-  valid_val store (Throw ks)
-
-[~cont_Id:]
-  valid_cont store []
-[~cont_CondK:]
-  static_scope (FDOM env) t ∧
-  static_scope (FDOM env) f ∧
-  valid_cont store ks ∧
-  can_lookup env store
-  ⇒
-  valid_cont store ((env, CondK t f)::ks)
-[~cont_ApplyK_NONE:]
-  EVERY (static_scope (FDOM env)) es ∧
-  valid_cont store ks ∧
-  can_lookup env store
-  ⇒
-  valid_cont store ((env, ApplyK NONE es)::ks)
-[~cont_ApplyK_SOME:]
-  valid_val store fn ∧
-  EVERY (valid_val store) vs ∧
-  EVERY (static_scope (FDOM env)) es ∧
-  valid_cont store ks ∧
-  can_lookup env store
-  ⇒
-  valid_cont store ((env, ApplyK (SOME (fn, vs)) es)::ks)
-[~cont_BeginK:]
-  EVERY (static_scope (FDOM env)) es ∧
-  static_scope (FDOM env) e ∧
-  valid_cont store ks ∧
-  can_lookup env store
-  ⇒
-  valid_cont store ((env, BeginK es e)::ks)
-[~cont_SetK:]
-  (FDOM env) x ∧
-  valid_cont store ks ∧
-  can_lookup env store
-  ⇒
-  valid_cont store ((env, SetK x)::ks)
-End
-
-Inductive valid_state:
-[~Val:]
-  valid_val store v ∧
-  valid_cont store ks ∧
-  can_lookup env store ∧
-  EVERY (OPTION_ALL (valid_val store)) store
-  ⇒
-  valid_state store ks env (Val v)
-[~Exp:]
-  static_scope (FDOM env) e ∧
-  valid_cont store ks ∧
-  can_lookup env store ∧
-  EVERY (OPTION_ALL (valid_val store)) store
-  ⇒
-  valid_state store ks env (Exp e)
-[~Exception:]
-  valid_state store ks env (Exception s)
-End
-
-Theorem FEVERY_MONO:
-  ∀ P Q f .
-    (∀ x . P x ⇒ Q x) ∧ FEVERY P f
-    ⇒
-    FEVERY Q f
-Proof
-  Induct_on ‘f’
-  >> rpt strip_tac >- simp[FEVERY_FEMPTY]
-  >> last_x_assum $ drule_then assume_tac
-  >> gvs[FEVERY_FUPDATE]
-  >> qsuff_tac ‘DRESTRICT f (COMPL {x}) = f’ >- (strip_tac >> gvs[])
-  >> simp[EQ_FDOM_SUBMAP, DRESTRICT_DEF, EXTENSION]
-  >> strip_tac
-  >> iff_tac
-  >> rpt strip_tac
-  >> gvs[]
-QED
-
-Theorem EVERY_OPTION_ALL_MAP_SOME:
-  ∀ f xs . EVERY f xs ⇒ EVERY (OPTION_ALL f) (MAP SOME xs)
-Proof
-  strip_tac
-  >> Induct
-  >> simp[]
-QED
-
-Theorem EVERY_TAKE:
-  ∀ f n xs . EVERY f xs ⇒ EVERY f (TAKE n xs)
-Proof
-  gen_tac
-  >> Induct_on ‘xs’
-  >> Cases_on ‘n’
-  >> simp[]
-QED
-
-Theorem valid_larger_store:
-  ∀ (store :'a list) (store' :'a list) .
-    LENGTH store ≤ LENGTH store'
-    ⇒
-    (∀ v .
-      valid_val store v
-      ⇒
-      valid_val store' v) ∧
-    ∀ ks .
-      valid_cont store ks
-      ⇒
-      valid_cont store' ks
-Proof
-  rpt gen_tac >> strip_tac
-  >> ho_match_mp_tac valid_val_ind
-  >> rpt strip_tac
-  >> simp[Once valid_val_cases]
-  >> gvs[can_lookup_cases]
-  >> gvs[SF ETA_ss]
-  >> irule FEVERY_MONO
-  >> pop_assum $ irule_at (Pos last)
-  >> PairCases
-  >> rpt strip_tac
-  >> gvs[]
-QED
-
-Theorem valid_val_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
-  cj 1 valid_larger_store;
-Theorem valid_cont_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
-  cj 2 valid_larger_store;
-
-Theorem letrec_init_mono:
-  ∀ bs store env store' env' .
-    letrec_init store env bs = (store', env')
-    ⇒
-    FDOM env ⊆ FDOM env'
-Proof
-  Induct
-  >> simp[letrec_init_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum drule
-  >> simp[]
-QED
-
-Theorem letrec_init_dom:
-  ∀ xs store env store' env' .
-    letrec_init store env xs = (store', env')
-    ⇒
-    FDOM env ∪ set xs = FDOM env' ∧
-    store ++ GENLIST (λ x. NONE) (LENGTH xs) = store'
-Proof
-  Induct
-  >> simp[letrec_init_def, fresh_loc_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ drule_then assume_tac
-  >> gvs[GENLIST] >- (
-    rpt strip_tac
-    >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
-    >> simp[EXTENSION]
-    >> simp[UNION_DEF, INSERT_DEF, SPECIFICATION, GSYM DISJ_ASSOC]
-    >> strip_tac
-    >> iff_tac
-    >> rw[] >> rw[]
-  )
-  >> rpt $ pop_assum kall_tac
-  >> ‘∃ n . LENGTH xs = n’ by simp[]
-  >> simp[]
-  >> pop_assum kall_tac
-  >> Induct_on ‘n’
-  >> simp[GENLIST]
-QED
-
-Theorem letrec_init_lookup:
-  ∀ xs store env store' env' .
-    can_lookup env store ∧
-    letrec_init store env xs = (store', env')
-    ⇒
-    can_lookup env' store'
-Proof
-  Induct
-  >> simp[letrec_init_def, fresh_loc_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> qsuff_tac ‘can_lookup (env |+ (h,LENGTH store)) (SNOC NONE store)’ >- (
-    strip_tac
-    >> last_x_assum drule_all
-    >> simp[]
-  )
-  >> gvs[can_lookup_cases]
-  >> qsuff_tac ‘FEVERY (λ(x,n). n < SUC (LENGTH store)) env’ >- (
-    strip_tac
-    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-    >> simp[]
-  )
-  >> irule FEVERY_MONO
-  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
-  >> PairCases
-  >> simp[]
-QED
-
-Theorem parameterize_NONE_dom:
-  ∀ xs store env vs store' env' e e' .
-    LENGTH xs = LENGTH vs ∧
-    parameterize store env xs NONE e vs = (store', env', e')
-    ⇒
-    Exp e = e' ∧
-    FDOM env ∪ set xs = FDOM env' ∧
-    store ++ MAP SOME vs = store'
-Proof
-  Induct
-  >> simp[parameterize_def]
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ drule_at (Pos $ el 2)
-  >> rpt strip_tac
-  >> gvs[] >- (
-    pop_assum $ simp o single o GSYM
-    >> simp[Once INSERT_SING_UNION, EXTENSION]
-    >> strip_tac
-    >> iff_tac
-    >> strip_tac
-    >> simp[]
-  )
-  >> gvs[fresh_loc_def]
-QED
-
-Theorem parameterize_NONE_lookup:
-  ∀ xs store env vs store' env' e e' .
-    LENGTH xs = LENGTH vs ∧
-    can_lookup env store ∧
-    parameterize store env xs NONE e vs = (store', env', e')
-    ⇒
-    can_lookup env' store'
-Proof
-  Induct
-  >> simp[parameterize_def]
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ drule_at (Pos $ el 3)
-  >> rpt strip_tac
-  >> gvs[]
-  >> pop_assum irule
-  >> gvs[can_lookup_cases, fresh_loc_def]
-  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-  >> simp[]
-  >> irule $ FEVERY_MONO
-  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
-  >> PairCases
-  >> simp[]
-QED
-
-Theorem parameterize_NONE_exception:
-  ∀ xs store env vs store' env' e e' .
-    LENGTH xs ≠ LENGTH vs ∧
-    parameterize store env xs NONE e vs = (store', env', e')
-    ⇒
-    ∃ s . Exception s = e'
-Proof
-  Induct
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum drule_all
-  >> simp[]
-QED
-
-Theorem parameterize_SOME_dom:
-  ∀ xs vs store env x store' env' e e' .
-    LENGTH xs ≤ LENGTH vs ∧
-    parameterize store env xs (SOME x) e vs = (store', env', e')
-    ⇒
-    Exp e = e' ∧
-    FDOM env ∪ set (x::xs) = FDOM env' ∧
-    store ++ MAP SOME (TAKE (LENGTH xs) vs)
-      ++ [SOME (SList (REVERSE (TAKE (LENGTH vs - LENGTH xs) (REVERSE vs))))]
-      = store'
-Proof
-  gen_tac >> gen_tac
-  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
-  >> pop_assum mp_tac
-  >> qid_spec_tac ‘vs’
-  >> Induct_on ‘xs’
-  >> simp[parameterize_def, fresh_loc_def] >- (
-    strip_tac >> strip_tac
-    >> simp_tac bool_ss [Once $ GSYM LENGTH_REVERSE]
-    >> simp[TAKE_LENGTH_ID]
-    >> simp[Once UNION_COMM]
-    >> simp[Once $ GSYM INSERT_SING_UNION]
-  )
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ drule_at (Pos $ el 3)
-  >> rpt strip_tac
-  >> gvs[fresh_loc_def] >- (
-    pop_assum $ simp o single o GSYM
-    >> simp[EXTENSION]
-    >> strip_tac
-    >> iff_tac
-    >> strip_tac
-    >> simp[]
-  )
-  >> simp[TAKE_APPEND1]
-QED
-
-Theorem parameterize_SOME_lookup:
-  ∀ xs vs store env x store' env' e e' .
-    LENGTH xs ≤ LENGTH vs ∧
-    can_lookup env store ∧
-    parameterize store env xs (SOME x) e vs = (store', env', e')
-    ⇒
-    can_lookup env' store'
-Proof
-  gen_tac >> gen_tac
-  >> ‘∃ n . n = LENGTH vs - LENGTH xs’ by simp[]
-  >> pop_assum mp_tac
-  >> qid_spec_tac ‘vs’
-  >> Induct_on ‘xs’
-  >> simp[parameterize_def, fresh_loc_def] >- (
-    simp[can_lookup_cases]
-    >> rpt strip_tac
-    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-    >> simp[]
-    >> irule $ FEVERY_MONO
-    >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
-    >> PairCases
-    >> simp[]
-  )
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ drule_at (Pos $ el 4)
-  >> rpt strip_tac
-  >> gvs[]
-  >> pop_assum irule
-  >> gvs[fresh_loc_def, can_lookup_cases]
-  >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-  >> simp[]
-  >> irule $ FEVERY_MONO
-  >> qpat_assum ‘FEVERY _ _’ $ irule_at (Pos last)
-  >> PairCases
-  >> simp[]
-QED
-
-Theorem parameterize_SOME_exception:
-  ∀ xs store env x vs store' env' e e' .
-    LENGTH vs < LENGTH xs ∧
-    parameterize store env xs (SOME x) e vs = (store', env', e')
-    ⇒
-    ∃ s . Exception s = e'
-Proof
-  Induct
-  >> Cases_on ‘vs’
-  >> simp[parameterize_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum drule_all
-  >> simp[]
-QED
-
-Theorem sadd_num_or_exception:
-  ∀ vs n .
-    (∃ m . sadd vs n = Val (SNum m)) ∨
-    (∃ s . sadd vs n = Exception s)
-Proof
-  Induct
-  >> simp[sadd_def]
-  >> Cases
-  >> simp[sadd_def]
-QED
-
-Theorem smul_num_or_exception:
-  ∀ vs n .
-    (∃ m . smul vs n = Val (SNum m)) ∨
-    (∃ s . smul vs n = Exception s)
-Proof
-  Induct
-  >> simp[smul_def]
-  >> Cases
-  >> simp[smul_def]
-QED
-
-Theorem sminus_num_or_exception:
-  ∀ vs .
-    (∃ m . sminus vs = Val (SNum m)) ∨
-    (∃ s . sminus vs = Exception s)
-Proof
-  Cases
-  >> simp[sminus_def]
-  >> Cases_on ‘h’
-  >> simp[sminus_def]
-  >> qspecl_then [‘t’, ‘0’] assume_tac sadd_num_or_exception
-  >> EVERY_CASE_TAC
-  >> gvs[]
-QED
-
-Theorem seqv_bool_or_exception:
-  ∀ vs .
-    (∃ b . seqv vs = Val (SBool b)) ∨
-    (∃ s . seqv vs = Exception s)
-Proof
-  Cases
-  >> simp[seqv_def]
-  >> Cases_on ‘t’
-  >> simp[seqv_def]
-  >> Cases_on ‘t'’
-  >> simp[seqv_def]
-  >> IF_CASES_TAC
-  >> simp[]
-QED
-
-Theorem valid_state_progress:
-  ∀ store ks env state .
-    valid_state store ks env state
-    ⇒
-    ∃ store' ks' env' state' .
-      step (store, ks, env, state) = (store', ks', env', state') ∧
-      valid_state store' ks' env' state'
-Proof
-  Cases_on ‘state’
-  >> rpt strip_tac
-  >~ [‘Exp e’] >- (
-    Cases_on ‘e’
-    >~ [‘Lit l’] >- (
-      Cases_on ‘l’
-      >> simp[step_def, lit_to_val_def]
-      >> simp[Once valid_state_cases, Once valid_val_cases]
-      >> gvs[Once valid_state_cases]
-    )
-    >~ [‘Begin es e’] >- (
-      Cases_on ‘es’ >- (
-        simp[step_def, Once valid_state_cases]
-        >> gvs[Once valid_state_cases, Once static_scope_cases]
-      )
-      >> simp[step_def, Once valid_state_cases]
-      >> simp[Once valid_val_cases]
-      >> gvs[Once valid_state_cases, Once static_scope_cases]
-    )
-    >~ [‘Ident x’] >- (
-      simp[step_def]
-      >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
-      >> ‘∀ x . FDOM env x ⇒ ∃ a. FLOOKUP env x = SOME a’
-        by simp[FLOOKUP_DEF, SPECIFICATION]
-      >> pop_assum drule >> strip_tac
-      >> drule_all_then assume_tac FEVERY_FLOOKUP
-      >> qpat_assum ‘EVERY _ _’ $ assume_tac o SRULE [EVERY_EL]
-      >> gvs[]
-      >> pop_assum $ drule_then assume_tac
-      >> ‘∀ x a . FLOOKUP env x = SOME a ⇒ env ' x = a’ by simp[FLOOKUP_DEF]
-      >> pop_assum $ drule_then assume_tac
-      >> simp[]
-      >> Cases_on ‘EL a store’ >- simp[Once valid_state_cases]
-      >> gvs[Once valid_state_cases, can_lookup_cases]
-    )
-    >~ [‘Letrec bs e’] >- (
-      simp[step_def]
-      >> rpt (pairarg_tac >> gvs[])
-      >> simp[Once valid_state_cases, Once static_scope_cases]
-      >> gvs[Once valid_state_cases, Once static_scope_cases]
-      >> drule_then assume_tac letrec_init_dom
-      >> drule_all_then assume_tac letrec_init_lookup
-      >> gvs[]
-      >> irule_at (Pos $ el 2) valid_cont_larger_store
-      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
-      >> simp[]
-      >> irule_at (Pos $ el 2) EVERY_MONOTONIC
-      >> qpat_assum ‘EVERY (OPTION_ALL _) _’ $ irule_at (Pos $ el 2)
-      >> strip_tac >- (
-        rpt strip_tac
-        >> irule_at (Pos hd) OPTION_ALL_MONO
-        >> pop_assum $ irule_at (Pos last)
-        >> rpt strip_tac
-        >> irule valid_val_larger_store
-        >> pop_assum $ irule_at (Pos last)
-        >> simp[]
-      )
-      >> simp[EVERY_GENLIST]
-      >> qpat_assum ‘EVERY _ (MAP SND bs)’ mp_tac
-      >> qpat_assum ‘FDOM _ ∪ _ = FDOM _’ mp_tac
-      >> rpt (pop_assum kall_tac)
-      >> qid_spec_tac ‘env’
-      >> Induct_on ‘bs’ >- simp[]
-      >> rpt strip_tac
-      >> PairCases_on ‘h’
-      >> simp[Once static_scope_cases]
-      >> gvs[]
-      >> last_x_assum $ qspec_then ‘env |+ (h0, 0)’ assume_tac
-      >> gvs[]
-      >> qsuff_tac ‘FDOM env ∪ (h0 INSERT set (MAP FST bs))
-        = (h0 INSERT FDOM env) ∪ set (MAP FST bs)’ >- (
-        strip_tac
-        >> pop_assum $ gvs o single
-        >> last_x_assum $ simp o single o GSYM
-      )
-      >> rpt $ pop_assum kall_tac
-      >> simp[EXTENSION, UNION_DEF]
-      >> strip_tac
-      >> iff_tac
-      >> strip_tac
-      >> simp[]
-    )
-    >> simp[step_def, Once valid_state_cases]
-    >> simp[Once valid_val_cases]
-    >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
-  )
-  >~ [‘Val v’] >- (
-    Cases_on ‘ks’ >- (
-      simp[step_def, return_def, Once valid_state_cases,
-        can_lookup_cases, FEVERY_FEMPTY]
-      >> gvs[Once valid_state_cases]
-    )
-    >> PairCases_on ‘h’
-    >> Cases_on ‘h1’
-    >~ [‘CondK t f’] >- (
-      simp[step_def, return_def]
-      >> IF_CASES_TAC >- (
-        gvs[Once valid_state_cases, Once valid_val_cases]
-        >> gvs[Once valid_val_cases]
-        >> simp[Once valid_state_cases]
-      )
-      >> gvs[Once valid_state_cases]
-      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-      >> rpt strip_tac
-      >> simp[Once valid_state_cases]
-    )
-    >~ [‘BeginK es e’] >- (
-      simp[step_def, return_def]
-      >> CASE_TAC
-      >> gvs[Once valid_state_cases]
-      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-      >> rpt strip_tac
-      >> simp[Once valid_state_cases]
-      >> simp[Once valid_val_cases]
-    )
-    >~ [‘SetK x’] >- (
-      simp[step_def, return_def]
-      >> gvs[Once valid_state_cases]
-      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-      >> rpt strip_tac
-      >> simp[Once valid_state_cases]
-      >> simp[Once valid_val_cases]
-      >> irule_at (Pos hd) valid_cont_larger_store
-      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
-      >> simp[]
-      >> gvs[can_lookup_cases]
-      >> irule IMP_EVERY_LUPDATE
-      >> simp[OPTION_ALL_def]
-      >> irule_at (Pos hd) valid_val_larger_store
-      >> last_assum $ irule_at (Pos $ el 2)
-      >> simp[]
-      >> irule EVERY_MONOTONIC
-      >> qpat_assum ‘EVERY _ _’ $ irule_at (Pos last)
-      >> rpt strip_tac
-      >> irule OPTION_ALL_MONO
-      >> pop_assum $ irule_at (Pos last)
-      >> rpt strip_tac
-      >> irule_at (Pos hd) valid_val_larger_store
-      >> pop_assum $ irule_at (Pos last)
-      >> simp[]
-    )
-    >~ [‘ApplyK fnp es’] >- (
-      simp[step_def]
-      >> Cases_on ‘∃ e es' . es = e::es'’ >-(
-        gvs[]
-        >> Cases_on ‘∃ fn vs . fnp = SOME (fn,vs)’
-        >> Cases_on ‘fnp = NONE’
-        >> gvs[]
-        >> simp[return_def]
-        >> simp[Once valid_state_cases]
-        >> gvs[Once valid_state_cases]
-        >> simp[Once valid_val_cases]
-        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-        >> rpt strip_tac
-        >> simp[]
-        >> Cases_on ‘fnp’ >> gvs[] >> PairCases_on ‘x’ >> gvs[]
-      )
-      >> Cases_on ‘es’ >> gvs[]
-      >> Cases_on ‘fnp’ >- (
-        simp[return_def]
-        >> Cases_on ‘v’
-        >> simp[application_def]
-        >~ [‘Prim p’] >- (
-          CASE_TAC
-          >> simp[Once valid_state_cases, sadd_def, smul_def,
-            sminus_def, seqv_def, can_lookup_cases, FEVERY_FEMPTY]
-          >> simp[Once valid_val_cases]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >~ [‘Proc env' xs xp e’] >- (
-          Cases_on ‘xp’
-          >> Cases_on ‘xs’
-          >> simp[parameterize_def] >- (
-            simp[Once valid_state_cases]
-            >> gvs[Once valid_state_cases]
-            >> gvs[Once valid_val_cases]
-            >> gvs[Once valid_val_cases]
-          )
-          >- simp[Once valid_state_cases]
-          >- (
-            rpt (pairarg_tac >> gvs[])
-            >> simp[Once valid_state_cases]
-            >> gvs[Once valid_state_cases, fresh_loc_def]
-            >> gvs[Once valid_val_cases]
-            >> gvs[Once valid_val_cases]
-            >> simp[Once INSERT_SING_UNION, Once UNION_COMM]
-            >> irule_at (Pos hd) valid_cont_larger_store
-            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
-            >> simp[Once valid_val_cases]
-            >> irule_at (Pos $ el 2) $ EVERY_MONOTONIC
-            >> pop_assum $ irule_at (Pos $ el 2)
-            >> gvs[can_lookup_cases]
-            >> irule_at (Pos $ el 2) $ cj 2 FEVERY_STRENGTHEN_THM
-            >> simp[]
-            >> irule_at (Pos hd) FEVERY_MONO
-            >> qpat_assum ‘FEVERY _ env'’ $ irule_at (Pos $ el 2)
-            >> rpt strip_tac >- (PairCases_on ‘x'’ >> gvs[])
-            >> irule OPTION_ALL_MONO
-            >> pop_assum $ irule_at (Pos last)
-            >> rpt strip_tac
-            >> irule valid_val_larger_store
-            >> pop_assum $ irule_at (Pos last)
-            >> simp[]
-          )
-          >> simp[Once valid_state_cases]
-          >> gvs[Once valid_state_cases]
-          >> gvs[Once valid_val_cases]
-          >> gvs[Once valid_val_cases]
-        )
-        >> simp[Once valid_state_cases]
-        >> gvs[Once valid_state_cases]
-        >> gvs[Once valid_val_cases]
-        >> gvs[Once valid_val_cases]
-      )
-      >> PairCases_on ‘x’
-      >> simp[return_def]
-      >> Cases_on ‘x0’
-      >> simp[application_def]
-      >~ [‘Prim p’] >- (
-        TOP_CASE_TAC >- (
-          qspecl_then [‘REVERSE x1 ++ [v]’, ‘0’] assume_tac sadd_num_or_exception
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >- (
-          qspecl_then [‘REVERSE x1 ++ [v]’, ‘1’] assume_tac smul_num_or_exception
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >- (
-          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac sminus_num_or_exception
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >- (
-          qspec_then ‘REVERSE x1 ++ [v]’ assume_tac seqv_bool_or_exception
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >> CASE_TAC
-        >> gvs[]
-        >> Cases_on ‘t'’ >- (
-          gvs[]
-          >> simp[Once valid_state_cases]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> rpt strip_tac
-          >> simp[Once valid_val_cases, can_lookup_cases, FEVERY_FEMPTY]
-        )
-        >> gvs[]
-        >> simp[Once valid_state_cases]
-        >> gvs[Once valid_state_cases]
-        >> gvs[Once valid_val_cases]
-        >> gvs[Once valid_val_cases]
-      )
-      >~ [‘Proc env' xs xp e’] >- (
-        rpt (pairarg_tac >> gvs[])
-        >> gvs[Once valid_state_cases]
-        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-        >> rpt strip_tac
-        >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
-        >> rpt strip_tac
-        >> gvs[] >- (
-          Cases_on ‘LENGTH xs = LENGTH (REVERSE x1 ++ [v])’ >- (
-            drule_all_then mp_tac parameterize_NONE_dom
-            >> drule_all_then mp_tac parameterize_NONE_lookup
-            >> rpt strip_tac
-            >> qpat_x_assum ‘Exp _ = _’ $ simp o single o GSYM
-            >> simp[Once valid_state_cases]
-            >> qpat_x_assum ‘_ ∪ _ = _’ $ simp o single o GSYM
-            >> qpat_x_assum ‘_ ++ _ = _’ $ simp o single o GSYM
-            >> irule_at (Pos hd) $ valid_cont_larger_store
-            >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
-            >> simp[]
-            >> irule_at (Pos hd) EVERY_MONOTONIC
-            >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
-            >> strip_tac >- (
-              rpt strip_tac
-              >> irule OPTION_ALL_MONO
-              >> pop_assum $ irule_at (Pos last)
-              >> rpt strip_tac
-              >> irule valid_val_larger_store
-              >> pop_assum $ irule_at (Pos last)
-              >> simp[]
-            )
-            >> strip_tac >- (
-              irule EVERY_OPTION_ALL_MAP_SOME
-              >> irule EVERY_MONOTONIC
-              >> qexists ‘valid_val store’
-              >> simp[]
-              >> rpt strip_tac
-              >> irule valid_val_larger_store
-              >> pop_assum $ irule_at (Pos last)
-              >> simp[]
-            )
-            >> irule valid_val_larger_store
-            >> last_assum $ irule_at (Pos last)
-            >> simp[]
-          )
-          >> drule_all_then mp_tac parameterize_NONE_exception
-          >> rpt strip_tac
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-        )
-        >> Cases_on ‘LENGTH xs ≤ LENGTH (REVERSE x1 ++ [v])’ >- (
-          drule_all_then mp_tac parameterize_SOME_dom
-          >> drule_all_then mp_tac parameterize_SOME_lookup
-          >> rpt strip_tac
-          >> simp[Once valid_state_cases]
-          >> gvs[]
-          >> irule_at (Pos hd) $ valid_cont_larger_store
-          >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
-          >> simp[]
-          >> irule_at (Pos hd) EVERY_MONOTONIC
-          >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
-          >> strip_tac >- (
-            rpt strip_tac
-            >> irule OPTION_ALL_MONO
-            >> pop_assum $ irule_at (Pos last)
-            >> rpt strip_tac
-            >> irule valid_val_larger_store
-            >> pop_assum $ irule_at (Pos last)
-            >> simp[]
-          )
-          >> strip_tac >- (
-            irule EVERY_OPTION_ALL_MAP_SOME
-            >> irule EVERY_TAKE
-            >> simp[]
-            >> strip_tac >- (
-              irule EVERY_MONOTONIC
-              >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
-              >> rpt strip_tac
-              >> irule valid_val_larger_store
-              >> pop_assum $ irule_at (Pos last)
-              >> simp[]
-            )
-            >> irule valid_val_larger_store
-            >> last_assum $ irule_at (Pos last)
-            >> simp[]
-          )
-          >> simp[Once valid_val_cases]
-          >> irule EVERY_TAKE
-          >> simp[]
-          >> strip_tac >- (
-            irule valid_val_larger_store
-            >> last_assum $ irule_at (Pos last)
-            >> simp[]
-          )
-          >> irule EVERY_MONOTONIC
-          >> qpat_assum ‘EVERY _ x1’ $ irule_at (Pos last)
-          >> rpt strip_tac
-          >> irule valid_val_larger_store
-          >> pop_assum $ irule_at (Pos last)
-          >> simp[]
-        )
-        >> ‘LENGTH (REVERSE x1 ++ [v]) < LENGTH xs’ by gvs[]
-        >> drule_all_then mp_tac parameterize_SOME_exception
-        >> rpt strip_tac
-        >> simp[Once valid_state_cases]
-        >> gvs[]
-      )
-      >~ [‘Throw ks’] >- (
-        CASE_TAC >- simp[Once valid_state_cases]
-        >> CASE_TAC >- (
-          gvs[]
-          >> simp[Once valid_state_cases, can_lookup_cases, FEVERY_FEMPTY]
-          >> gvs[Once valid_state_cases]
-          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> rpt strip_tac
-          >> qpat_x_assum ‘valid_val _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-          >> simp[]
-        )
-        >> simp[Once valid_state_cases]
-      )
-      >> simp[Once valid_state_cases]
-      >> gvs[Once valid_state_cases]
-      >> gvs[Once valid_val_cases]
-      >> gvs[Once valid_val_cases]
-    )
-  )
-  >> simp[step_def, Once valid_state_cases]
-QED
-
-Theorem statically_scoped_program_valid:
-  ∀ p . static_scope ∅ p ⇒ valid_state [] [] FEMPTY (Exp p)
-Proof
-  simp[Once valid_state_cases,
-    can_lookup_cases, FEVERY_FEMPTY]
-  >> simp[Once valid_val_cases]
-QED
-
 (*
   open scheme_semanticsTheory;
 

From c16f2d91b0d364d7aa06b561c646e77ba620ac39 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 12 Apr 2025 20:33:16 +0100
Subject: [PATCH 077/100] proven begin

---
 .../proofs/scheme_to_cakeProofScript.sml      | 131 ++++++++++++------
 compiler/scheme/scheme_to_cakeScript.sml      |   6 +-
 2 files changed, 95 insertions(+), 42 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 358a6a3bba..6d3b723f5b 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -353,7 +353,6 @@ Inductive cont_rel:
   (∀ x . t ≠ "var" ++ x) ∧
   var ≠ t
   ⇒
-  (*Likely needs condition on se i.e. Scheme env*)
   cont_rel ((se, CondK te fe) :: ks)
     (Closure env t $ Mat (Var (Short t)) [
       (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
@@ -363,7 +362,7 @@ Inductive cont_rel:
 [~ApplyK_NONE:]
   cont_rel ks kv ∧
   nsLookup env.v (Short var) = SOME kv ∧
-  (m, ce) = cps_transform_app n (Var (Short t)) [] es (Var (Short var)) ∧
+  (m, inner) = cps_transform_app n (Var (Short t)) [] es (Var (Short var)) ∧
   scheme_env env ∧
   env_rel se env ∧
   ¬ MEM var vconses ∧
@@ -374,13 +373,12 @@ Inductive cont_rel:
   (∀ x . t ≠ "var" ++ x) ∧
   var ≠ t
   ⇒
-  (*Likely needs condition on se i.e. Scheme env*)
   cont_rel ((se, ApplyK NONE es) :: ks)
-    (Closure env t $ ce)
+    (Closure env t $ inner)
 [~ApplyK_SOME:]
   cont_rel ks kv ∧
   nsLookup env.v (Short var) = SOME kv ∧
-  (m, ce) = cps_transform_app n (Var (Short fnt))
+  (m, inner) = cps_transform_app n (Var (Short fnt))
     (Var (Short t) :: MAP (Var o Short) ts) es (Var (Short var)) ∧
   ml_v_vals' fn mlfn ∧
   nsLookup env.v (Short fnt) = SOME mlfn ∧
@@ -406,9 +404,19 @@ Inductive cont_rel:
   var ≠ t ∧
   fnt ≠ t
   ⇒
-  (*Likely needs condition on se i.e. Scheme env*)
   cont_rel ((se, ApplyK (SOME (fn, vs)) es) :: ks)
-    (Closure env t $ ce)
+    (Closure env t $ inner)
+[~BeginK:]
+  cont_rel ks kv ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  (m, inner) = cps_transform_seq n (Var (Short var)) es e ∧
+  scheme_env env ∧
+  env_rel se env ∧
+  ¬ MEM var vconses ∧
+  var ≠ "_"
+  ⇒
+  cont_rel ((se, BeginK es e) :: ks)
+    (Closure env "_" $ inner)
 End
 
 Theorem compile_in_rel:
@@ -437,37 +445,6 @@ open scheme_proofsTheory;
 open scheme_parsingTheory;
 *)
 
-Theorem app = SRULE [Ntimes evaluate_def 45, do_opapp_def, nsOptBind_def, dec_clock_def,
-  do_con_check_def, build_conv_def] $
-  RESTR_EVAL_CONV [“evaluate”, “scheme_env7”]
-    “evaluate <|clock:=999;refs:=[]|> scheme_env7 [
-      compile_scheme_prog $ OUTR $ parse_to_ast
-      "((lambda (x y) (lambda (z) y)) 1 2)"
-    ]”;
-
-Theorem stuck = SRULE [Ntimes evaluate_def 45, do_opapp_def, nsOptBind_def, dec_clock_def,
-  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
-  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
-  same_type_def, same_ctor_def, pat_bindings_def] app;
-
-Theorem stuck_again = SRULE [Ntimes evaluate_def 12, do_opapp_def, nsOptBind_def, dec_clock_def,
-  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
-  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
-  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
-  Once LET_DEF] stuck;
-
-Theorem more = SRULE [Ntimes evaluate_def 6, do_opapp_def, nsOptBind_def, dec_clock_def,
-  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
-  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
-  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
-  Once LET_DEF] stuck_again;
-
-SRULE [evaluate_def, do_opapp_def, nsOptBind_def, dec_clock_def,
-  do_con_check_def, build_conv_def, Ntimes find_recfun_def 2,
-  Ntimes build_rec_env_def 2, can_pmatch_all_def, pmatch_def, evaluate_match_def,
-  same_type_def, same_ctor_def, pat_bindings_def, do_app_def, store_alloc_def,
-  Once LET_DEF] more;
-
 Theorem str_not_num:
   ∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str
 Proof
@@ -783,7 +760,7 @@ Proof
   >> simp[isDigit_def]
 QED
 
-Theorem myproof:
+Theorem step_preservation:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
   valid_state store k env e ∧
@@ -859,6 +836,44 @@ Proof
       >> irule_at (Pos hd) str_not_num
       >> simp[isDigit_def, k_in_ts, t_in_ts]
     )
+    >~ [‘Begin es e’] >- (
+      Cases_on ‘es’
+      >> rpt strip_tac
+      >> gvs[cps_transform_def]
+      >> rpt (pairarg_tac >> gvs[]) >- (
+        qrefine ‘ck+1’
+        >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
+          nsOptBind_def, dec_clock_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases]
+        >> irule_at (Pos hd) EQ_REFL
+        >> pop_assum $ irule_at (Pos hd) o GSYM
+        >> qpat_assum ‘scheme_env _’ $ simp
+          o curry ((::) o swap) [scheme_env_def]
+          o SRULE [scheme_env_def]
+        >> gvs[env_rel_cases]
+      )
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos $ el 2) o GSYM
+      >> qpat_assum ‘scheme_env _’ $ simp
+        o curry ((::) o swap) [scheme_env_def]
+        o SRULE [scheme_env_def]
+      >> gvs[env_rel_cases]
+      >> simp[Once cont_rel_cases]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
+      >> simp[]
+      >> qpat_assum ‘scheme_env _’ $ simp
+        o curry ((::) o swap) [scheme_env_def]
+        o SRULE [scheme_env_def]
+      >> gvs[env_rel_cases]
+    )
     >~ [‘Lambda xs xp e’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
@@ -944,6 +959,44 @@ Proof
       >> gvs[scheme_env_def, env_rel_cases]
       >> metis_tac[]
     )
+    >> Cases_on ‘∃ es e . h1 = BeginK es e’ >- (
+      gvs[]
+      >> Cases_on ‘es’
+      >> rpt strip_tac
+      >> gvs[Once cont_rel_cases, Once e_ce_rel_cases]
+      >> gvs[cps_transform_def, step_def, return_def]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> rpt (pairarg_tac >> gvs[]) >- (
+        irule_at (Pos hd) EQ_REFL
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases]
+        >> irule_at (Pos hd) EQ_REFL
+        >> pop_assum $ irule_at (Pos hd) o GSYM
+        >> qpat_assum ‘scheme_env _’ $ simp
+          o curry ((::) o swap) [scheme_env_def]
+          o SRULE [scheme_env_def]
+        >> gvs[env_rel_cases]
+      )
+      >> simp[SimpLHS, Ntimes evaluate_def 2, nsOptBind_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos $ el 2) o GSYM
+      >> qpat_assum ‘scheme_env _’ $ simp
+        o curry ((::) o swap) [scheme_env_def]
+        o SRULE [scheme_env_def]
+      >> gvs[env_rel_cases]
+      >> simp[Once cont_rel_cases]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
+      >> simp[]
+      >> qpat_assum ‘scheme_env _’ $ simp
+        o curry ((::) o swap) [scheme_env_def]
+        o SRULE [scheme_env_def]
+      >> gvs[env_rel_cases]
+    )
     >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 1e6b57bf46..f39d3fbaff 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -111,9 +111,9 @@ Definition cps_transform_def:
 
   cps_transform n (Begin es e) = (let
       k = "k" ++ toString n;
-      (m, ce) = cps_transform_seq (n+1) (Var (Short k)) es e
+      (m, inner) = cps_transform_seq (n+1) (Var (Short k)) es e
     in
-      (m, Fun k ce)) ∧
+      (m, Fun k inner)) ∧
 
   cps_transform n (Set x e) = (let
     (m, ce) = cps_transform n e;
@@ -157,7 +157,7 @@ Definition cps_transform_def:
     (m, ce) = cps_transform n e';
     (l, inner) = cps_transform_seq m k es e
   in
-    (l, Let (SOME "k") (Fun "_" $ inner) $ App Opapp [ce; Var (Short "k")])) ∧
+    (l, Let (SOME "k") (Fun "_" inner) $ App Opapp [ce; Var (Short "k")])) ∧
 
 
   cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧

From b474daddbe4a53079877acce9ed129d9f8cd5b18 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Tue, 15 Apr 2025 18:08:55 +0100
Subject: [PATCH 078/100] proven set

---
 .../proofs/scheme_to_cakeProofScript.sml      | 79 ++++++++++++++++++-
 compiler/scheme/scheme_to_cakeScript.sml      | 16 ++--
 .../translation/scheme_compilerProgScript.sml |  1 +
 3 files changed, 86 insertions(+), 10 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 6d3b723f5b..c441dc8a9f 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -34,7 +34,7 @@ Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
 Definition cconses_def[simp]:
   cconses = ["SNum"; "SBool"; "True"; "False";
     "Prim";"SAdd";"SMul";"SMinus";"SEqv";"CallCC";
-    "[]"; "::"; "Some"; "None"; "Ex"; "Proc"; "Throw";"SList"]
+    "[]"; "::"; "Some"; "None"; "Ex"; "Proc"; "Throw";"SList";"Wrong"]
 End
 
 Theorem scheme_env1_rw[simp] = SRULE [nsLookup_def] $ SIMP_CONV pure_ss [
@@ -279,6 +279,8 @@ val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
     Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SEqv")) []]) ∧
   (ml_v_vals' (Prim CallCC) $
     Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "CallCC")) []]) ∧
+  (ml_v_vals' (Wrong s) $
+    Conv (SOME (scheme_typestamp "Wrong")) [Litv (StrLit s)]) ∧
 
   (scheme_env env ∧
   env_rel se env ∧
@@ -417,6 +419,20 @@ Inductive cont_rel:
   ⇒
   cont_rel ((se, BeginK es e) :: ks)
     (Closure env "_" $ inner)
+[~SetK:]
+  cont_rel ks kv ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  (m, inner) = refunc_set n (Var (Short t)) (Var (Short var)) x ∧
+  scheme_env env ∧
+  env_rel se env ∧
+  ¬ MEM var vconses ∧
+  ¬ MEM t vconses ∧
+  (∀ x . t ≠ "var" ++ x) ∧
+  var ≠ "v" ∧
+  var ≠ t
+  ⇒
+  cont_rel ((se, SetK x) :: ks)
+    (Closure env t $ inner)
 End
 
 Theorem compile_in_rel:
@@ -441,7 +457,7 @@ Proof
 QED
 
 (*
-open scheme_proofsTheory;
+open scheme_to_cakeProofTheory;
 open scheme_parsingTheory;
 *)
 
@@ -479,7 +495,7 @@ Theorem mono_cps_on_n:
   (∀ n k bs ce' m ce . (m, ce) = cps_transform_letreinit n k bs ce' ⇒ m ≥ n)
 Proof
   ho_match_mp_tac $ cps_transform_ind
-  >> simp[cps_transform_def]
+  >> simp[cps_transform_def, refunc_set_def]
   >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
   >> dxrule $ GSYM mono_proc_ml_on_n
@@ -924,6 +940,24 @@ Proof
       >> simp[Once e_ce_rel_cases]
       >> gvs[env_rel_cases, FEVERY_DEF]
     )
+    >~ [‘Set x e’] >- (
+      simp[cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[Once e_ce_rel_cases]
+      >> irule_at Any EQ_REFL
+      >> simp[Once cont_rel_cases]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
+      >> gvs[scheme_env_def, env_rel_cases]
+      >> irule_at Any str_not_num
+      >> simp[isDigit_def]
+      >> pop_assum $ irule_at (Pos hd) o GSYM
+    )
     >> cheat
   )
   >~ [‘Val v’] >- (
@@ -997,6 +1031,37 @@ Proof
         o SRULE [scheme_env_def]
       >> gvs[env_rel_cases]
     )
+    >> Cases_on ‘∃ x . h1 = SetK x’ >- (
+      gvs[]
+      >> simp[step_def, return_def, Once e_ce_rel_cases, refunc_set_def,
+        Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
+      >> rpt strip_tac
+      >> simp[]
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac
+        o SRULE [Once valid_val_cases]
+      >> strip_tac
+      >> qpat_assum ‘env_rel h0 _’ $ drule_then assume_tac
+        o SRULE [env_rel_cases, FEVERY_DEF, SPECIFICATION]
+      >> qpat_assum ‘can_lookup h0 _’ $ drule_then assume_tac
+        o SRULE [can_lookup_cases, FEVERY_DEF, SPECIFICATION]
+      >> drule_then assume_tac EVERY2_LENGTH
+      >> drule_all_then assume_tac $ cj 2 $ iffLR LIST_REL_EL_EQN
+      >> gvs[store_entry_rel_cases]
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 13, do_con_check_def, nsOptBind_def,
+        build_conv_def, scheme_env_def, do_opapp_def, dec_clock_def,
+        do_app_def, store_assign_def, store_v_same_type_def]
+      >> qpat_assum ‘scheme_env _’ $ simp o single
+        o SRULE [scheme_env_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+      >> gvs[env_rel_cases]
+      >> irule EVERY2_LUPDATE_same
+      >> simp[store_entry_rel_cases]
+    )
     >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
@@ -1117,6 +1182,14 @@ Proof
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
       )
+      >~ [‘SOME (Conv (SOME (TypeStamp "Wrong" _)) [_])’] >- (
+        qrefine ‘ck+1’
+        >> simp[Once evaluate_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[Once e_ce_rel_cases]
+        >> last_assum $ irule_at (Pos hd)
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+      )
       >> qrefine ‘ck+2’
       >> simp[evaluate_def]
       >> simp[do_opapp_def,
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index f39d3fbaff..9739671b7e 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -61,6 +61,13 @@ Definition letinit_ml_def:
       (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
 End
 
+Definition refunc_set_def:
+  refunc_set n t k x = (n, Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
+              Con (SOME $ Short "Some") [t]]) $
+            Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
+              (App Opapp [k; Var (Short "v")]))
+End
+
 Definition cps_transform_def:
   cps_transform n (Lit v) = (let
     k = "k" ++ toString n;
@@ -119,13 +126,9 @@ Definition cps_transform_def:
     (m, ce) = cps_transform n e;
     k = "k" ++ toString m;
     t = "t" ++ toString (m+1);
+    (l, inner) = refunc_set (m+2) (Var (Short t)) (Var (Short k)) x;
   in
-    (m+2, Fun k $ Let (SOME "k")
-      (Fun t $ Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
-            Con (SOME $ Short "Some") [Var (Short t)]]) $
-          Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
-            (App Opapp [Var (Short k); Var (Short "v")])) $
-        App Opapp [ce; Var (Short "k")])) ∧
+    (l, Fun k $ Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")])) ∧
 
   cps_transform n (Letrec bs e) = (let
     (m, ce) = cps_transform n e;
@@ -159,7 +162,6 @@ Definition cps_transform_def:
   in
     (l, Let (SOME "k") (Fun "_" inner) $ App Opapp [ce; Var (Short "k")])) ∧
 
-
   cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧
 
   cps_transform_letreinit n k ((x,e)::bs) ce = (let
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 9760a1fbde..375eb78ca1 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -39,6 +39,7 @@ val r = translate cake_print_def;
 val r = translate to_ml_vals_def;
 val r = translate cons_list_def;
 val r = translate proc_ml_def;
+val r = translate refunc_set_def;
 val r = translate letinit_ml_def;
 val r = translate cps_transform_def;
 val r = translate compile_scheme_prog_def;

From 9cac5e816d2704e0a9d05471745355f96c893436 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 16 Apr 2025 00:09:31 +0100
Subject: [PATCH 079/100] proven letrec (a bit ugly)

---
 .../proofs/scheme_to_cakeProofScript.sml      | 113 +++++++++++++++++-
 compiler/scheme/scheme_to_cakeScript.sml      |  37 +++---
 2 files changed, 124 insertions(+), 26 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index c441dc8a9f..9d538affdc 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -491,8 +491,7 @@ QED
 Theorem mono_cps_on_n:
   (∀ n e m ce . (m, ce) = cps_transform n e ⇒ m ≥ n) ∧
   (∀ n fn ts es k m ce . (m, ce) = cps_transform_app n fn ts es k ⇒ m ≥ n) ∧
-  (∀ n k es e m ce . (m, ce) = cps_transform_seq n k es e ⇒ m ≥ n) ∧
-  (∀ n k bs ce' m ce . (m, ce) = cps_transform_letreinit n k bs ce' ⇒ m ≥ n)
+  (∀ n k es e m ce . (m, ce) = cps_transform_seq n k es e ⇒ m ≥ n)
 Proof
   ho_match_mp_tac $ cps_transform_ind
   >> simp[cps_transform_def, refunc_set_def]
@@ -776,6 +775,86 @@ Proof
   >> simp[isDigit_def]
 QED
 
+Theorem preservation_of_letrec:
+  ∀ xs inner (st:'ffi state) mlenv store env store' env' .
+    (store', env') = letrec_init store env xs ∧
+    env_rel env mlenv ∧
+    LIST_REL store_entry_rel store st.refs ∧
+    scheme_env mlenv
+    ⇒
+    ∃ ck st' mlenv' var' .
+      evaluate (st with clock:=ck) mlenv [letinit_ml xs inner]
+        = evaluate st' mlenv' [inner] ∧
+      env_rel env' mlenv' ∧
+      LIST_REL store_entry_rel store' st'.refs ∧
+      st'.clock ≤ ck ∧
+      (∀ x v . (∀ x' . x ≠ "var" ++ x') ∧ nsLookup mlenv.v (Short x) = SOME v
+      ⇒
+      nsLookup mlenv'.v (Short x) = SOME v) ∧
+      scheme_env mlenv'
+Proof
+  Induct
+  >> simp[letrec_init_def, letinit_ml_def]
+  >> rpt strip_tac >- (
+    irule_at (Pos hd) EQ_REFL >> simp[]
+  )
+  >> rpt (pairarg_tac >> gvs[])
+  >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
+    do_app_def, store_alloc_def, nsOptBind_def]
+  >> qpat_assum ‘scheme_env _’ $ simp o single
+    o SRULE [scheme_env_def]
+  >> qsuff_tac ‘∀ mlenv' .
+          (∀x v.
+             (∀x'. x ≠ STRING #"v" (STRING #"a" (STRING #"r" x'))) ∧
+             nsLookup (mlenv with
+               v :=
+                 nsBind (STRING #"v" (STRING #"a" (STRING #"r" (explode h))))
+                   (Loc T (LENGTH st.refs)) mlenv.v).v (Short x) = SOME v ⇒
+             nsLookup mlenv'.v (Short x) = SOME v)
+          ⇔
+          (∀x v.
+             (∀x'. x ≠ STRING #"v" (STRING #"a" (STRING #"r" x'))) ∧
+             nsLookup mlenv.v (Short x) = SOME v ⇒
+             nsLookup mlenv'.v (Short x) = SOME v)
+        ’ >- (
+    strip_tac
+    >> pop_assum $ simp_tac pure_ss o single o GSYM
+    >> last_x_assum $ irule
+    >> simp[]
+    >> strip_tac >- gvs[scheme_env_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> gvs[env_rel_cases, fresh_loc_def, store_entry_rel_cases]
+    >> Cases_on ‘h ∈ FDOM env’ >- (
+      simp[FEVERY_DEF]
+      >> strip_tac
+      >> Cases_on ‘x = h’
+      >> gvs[] >- (
+        drule $ cj 1 $ iffLR EVERY2_EVERY
+        >> simp[]
+      )
+      >> strip_tac
+      >> gvs[FEVERY_DEF]
+      >> simp[FAPPLY_FUPDATE_THM]
+    )
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> simp[]
+    >> drule_then assume_tac $ cj 1 $ iffLR EVERY2_EVERY
+    >> simp[FEVERY_DEF]
+    >> rpt strip_tac
+    >> ‘x ≠ h’ by (strip_tac >> gvs[])
+    >> gvs[FEVERY_DEF]
+  )
+  >> strip_tac
+  >> iff_tac
+  >> rpt strip_tac
+  >> qpat_assum ‘∀ _ _ . _ ∧ _ ⇒ _’ irule
+  >> simp[]
+  >> qpat_assum ‘∀ _ . _ ≠ _’ $ qspec_then ‘explode h’ assume_tac
+  >> simp[]
+  >> Cases_on ‘mlenv’
+  >> gvs[]
+QED
+
 Theorem step_preservation:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step  (store, k, env, e) = (store', k', env', e') ∧
@@ -958,7 +1037,35 @@ Proof
       >> simp[isDigit_def]
       >> pop_assum $ irule_at (Pos hd) o GSYM
     )
-    >> cheat
+    >~ [‘Letrec bs e’] >- (
+      simp[Once cps_transform_def]
+      >> rpt strip_tac
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 4, do_opapp_def, dec_clock_def]
+      >> pop_assum $ assume_tac o GSYM
+      >> drule preservation_of_letrec
+      >> qsuff_tac ‘env_rel env
+        (mlenv with v := nsBind (STRING #"k" (toString m')) kv mlenv.v)’ >- (
+        rpt strip_tac
+        >> pop_assum $ drule_then drule
+        >> qsuff_tac ‘scheme_env
+          (mlenv with v := nsBind (STRING #"k" (toString m')) kv mlenv.v)’ >- (
+          rpt strip_tac
+          >> pop_assum $ drule
+          >> rpt strip_tac
+          >> pop_assum $ qspec_then
+            ‘(App Opapp [ce'; Var (Short (STRING #"k" (toString m')))])’ mp_tac
+          >> rpt strip_tac
+          >> qpat_assum ‘evaluate _ _ _ = _’ $ irule_at (Pos hd)
+          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+          >> simp[Once e_ce_rel_cases]
+          >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos hd) o GSYM
+        )
+        >> gvs[scheme_env_def]
+      )
+      >> gvs[env_rel_cases]
+    )
   )
   >~ [‘Val v’] >- (
     Cases_on ‘k’
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 9739671b7e..af639f169a 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -57,8 +57,8 @@ End
 
 Definition letinit_ml_def:
   letinit_ml [] inner = inner ∧
-  letinit_ml ((x,_)::bs) inner = Let (SOME $ "var" ++ explode x)
-      (App Opref [Con (SOME $ Short "None") []]) (letinit_ml bs inner)
+  letinit_ml (x::xs) inner = Let (SOME $ "var" ++ explode x)
+      (App Opref [Con (SOME $ Short "None") []]) (letinit_ml xs inner)
 End
 
 Definition refunc_set_def:
@@ -131,11 +131,10 @@ Definition cps_transform_def:
     (l, Fun k $ Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")])) ∧
 
   cps_transform n (Letrec bs e) = (let
-    (m, ce) = cps_transform n e;
-    k = "k" ++ toString m;
-    (l, inner) = cps_transform_letreinit (m+1) (Var (Short k)) bs ce
+    (m, ce) = cps_transform n (Begin (MAP (UNCURRY Set) bs) e);
+    k = "k" ++ toString m
   in
-    (l, Fun k $ letinit_ml bs inner)) ∧
+    (m+1, Fun k $ letinit_ml (MAP FST bs) $ App Opapp [ce; Var (Short k)])) ∧
 
 
   cps_transform_app n tfn ts (e::es) k = (let
@@ -160,25 +159,17 @@ Definition cps_transform_def:
     (m, ce) = cps_transform n e';
     (l, inner) = cps_transform_seq m k es e
   in
-    (l, Let (SOME "k") (Fun "_" inner) $ App Opapp [ce; Var (Short "k")])) ∧
-
-  cps_transform_letreinit n k [] ce = (n, App Opapp [ce; k]) ∧
-
-  cps_transform_letreinit n k ((x,e)::bs) ce = (let
-    (m, ce') = cps_transform n e;
-    (l, inner) = cps_transform_letreinit m k bs ce;
-    t = "t" ++ toString l
-  in
-    (l+1, App Opapp [ce'; Fun t $ Let NONE
-      (App Opassign [Var (Short $ "var" ++ explode x);
-        Con (SOME $ Short "Some") [Var (Short t)]])
-      inner]))
+    (l, Let (SOME "k") (Fun "_" inner) $ App Opapp [ce; Var (Short "k")]))
 Termination
   WF_REL_TAC ‘inv_image ($< LEX $<) (λ x . case x of
-    | INL(_,e) => (exp_size e, 0)
-    | INR(INL(_,_,_,es,_)) => (list_size exp_size es, 1n)
-    | INR(INR(INL(_,_,es,e))) => (list_size exp_size es + exp_size e, 1)
-    | INR(INR(INR(_,_,bs,_))) => (exp1_size bs), 1)’
+    | INL(_,e) => (exp_size e, case e of Letrec _ _ => 1 | _ => 0)
+    | INR(INL(_,_,_,es,_)) => (list_size exp_size es, 2n)
+    | INR(INR(_,_,es,e)) => (list_size exp_size es + exp_size e, 2))’
+  >> strip_tac >- (Cases >> simp[])
+  >> Induct
+  >> simp[exp_size_def]
+  >> PairCases
+  >> simp[exp_size_def]
 End
 
 Definition compile_scheme_prog_def:

From 47175830a98d37015bff3fac7b3396be6f46bba1 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 16 Apr 2025 01:38:12 +0100
Subject: [PATCH 080/100] scheme divergence

---
 .../proofs/scheme_semanticsPropsScript.sml    | 42 +++++++++++++++++++
 .../proofs/scheme_to_cakeProofScript.sml      | 20 ++++++---
 2 files changed, 57 insertions(+), 5 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index f61f79a686..84f1d9b381 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -864,6 +864,48 @@ Proof
   >> simp[step_def, Once valid_state_cases]
 QED
 
+Theorem scheme_divergence:
+  ∀ store ks env state store' ks' env' state' .
+    step (store, ks, env, state) = (store', ks', env', state') ∧
+    (ks = [] ⇒ ∀ v  . state ≠ Val v) ∧
+    (∀ s . state ≠ Exception s)
+    ⇒
+    (store, ks, env, state) ≠ (store', ks', env', state')
+Proof
+  Cases_on ‘state’
+  >> simp[]
+  >~ [‘Exp e’] >- (
+    Cases_on ‘e’
+    >> simp[step_def] >- (
+      rpt strip_tac
+      >> Cases_on ‘EL (env ' m) store’
+      >> gvs[]
+    )
+    >- (
+      CASE_TAC
+      >> simp[]
+      >> rpt strip_tac
+      >> ‘∀ e e' . e = e' ⇒ exp_size e = exp_size e'’ by simp[]
+      >> pop_assum drule
+      >> simp[exp_size_def]
+    )
+    >> rpt strip_tac
+    >> rpt (pairarg_tac >> gvs[])
+  )
+  >> Cases_on ‘ks’
+  >> simp[step_def]
+  >> PairCases_on ‘h’
+  >> simp[oneline return_def, oneline application_def, AllCaseEqs()]
+  >> rpt strip_tac
+  >> rpt (pairarg_tac >> gvs[])
+  >> qpat_x_assum ‘_ = Throw _’ mp_tac
+  >> rpt $ pop_assum kall_tac
+  >> strip_tac
+  >> ‘∀ v v' . v = v' ⇒ val_size v = val_size v'’ by simp[]
+  >> pop_assum drule
+  >> simp[cont_size_def]
+QED
+
 Theorem statically_scoped_program_valid:
   ∀ p . static_scope ∅ p ⇒ valid_state [] [] FEMPTY (Exp p)
 Proof
diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 9d538affdc..1c39e509e6 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -873,9 +873,17 @@ Theorem step_preservation:
     env_rel env' mlenv' ∧
     LIST_REL store_entry_rel store' st'.refs ∧
     st'.clock ≤ ck ∧
-    (k ≠ [] ⇒ st'.clock < ck)
+    (k ≠ [] ∧ (∀ s . e ≠ Exception s) ⇒ st'.clock < ck)
 Proof
   Cases_on ‘e’
+  >~ [‘Exception s’] >- (
+    simp[step_def, Once e_ce_rel_cases]
+    >> rpt strip_tac
+    >> irule_at (Pos hd) EQ_REFL
+    >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+    >> qexistsl [‘scheme_env7’, ‘""’]
+    >> simp[scheme_env_def]
+  )
   >~ [‘Exp e’] >- (
     Cases_on ‘e’
     >> simp[step_def, Once e_ce_rel_cases]
@@ -1191,7 +1199,7 @@ Proof
       >> simp[isDigit_def, t_in_ts]
       >> gvs[env_rel_cases]
     )
-    >> Cases_on ‘∃ e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
+    >> Cases_on ‘∃ fn vs e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
@@ -1351,7 +1359,7 @@ Proof
       >> simp[env_rel_cases, FEVERY_FEMPTY]
       >> last_assum $ irule_at Any
     )
-    >> Cases_on ‘h1 = ApplyK (SOME (fn, vs)) []’ >- (
+    >> Cases_on ‘∃ fn vs . h1 = ApplyK (SOME (fn, vs)) []’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases]
@@ -1524,9 +1532,11 @@ Proof
       )
       >> gvs[scheme_env_def]
     )
-    >> cheat
+    >> Cases_on ‘h1’ >> gvs[]
+    >> Cases_on ‘l’ >> gvs[]
+    >> Cases_on ‘o'’ >> gvs[]
+    >> PairCases_on ‘x’ >> gvs[]
   )
-  >> cheat
 QED
 
 (*Theorem val_correct:

From 1bcdc8e123918e710109945fc49a2e68fd1d81ec Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 16 Apr 2025 15:30:04 +0100
Subject: [PATCH 081/100] messing

---
 compiler/scheme/scheme_astScript.sml          | 89 +++++++++++++++++++
 compiler/scheme/scheme_parsingScript.sml      |  9 +-
 .../translation/scheme_compilerProgScript.sml |  4 +
 3 files changed, 101 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 6beca9949d..7b25863656 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -95,6 +95,95 @@ Inductive static_scope:
   static_scope env (Set x e)
 End
 
+Theorem static_scope_def = LIST_CONJ $ map
+  (SIMP_RULE pure_ss [Once $ GSYM CONJ_ASSOC] o
+    SIMP_RULE pure_ss [Once $ GSYM LIST_TO_SET,
+    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] o
+    GEN_ALL o SCONV [Once static_scope_cases]) [
+  “static_scope env (Lit l)”,
+  “static_scope env (Cond c t f)”,
+  “static_scope env (Apply fn es)”,
+  “static_scope env (Begin es e)”,
+  “static_scope env (Lambda xs NONE e)”,
+  “static_scope env (Lambda xs (SOME x) e)”,
+  “static_scope env (Letrec bs e)”,
+  “static_scope env (Ident x)”,
+  “static_scope env (Set x e)”
+];
+
+Theorem test_def = oneline $ GEN_ALL $
+  SIMP_RULE bool_ss [Once $ GSYM CONJ_ASSOC] $
+  SIMP_RULE bool_ss [Once $ GSYM LIST_TO_SET,
+    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] $
+  SCONV [Once static_scope_cases] “static_scope env (Apply fn es)”;
+
+Inductive static_scope':
+[~Lit:]
+  static_scope' env (Lit lit)
+[~Cond:]
+  static_scope' env c ∧
+  static_scope' env t ∧
+  static_scope' env f
+  ⇒
+  static_scope' env (Cond c t f)
+[~Apply:]
+  static_scope' env fn ∧
+  ALL_EL (static_scope' env) es
+  ⇒
+  static_scope' env (Apply fn es)
+[~Begin:]
+  EVERY (static_scope' env) es ∧
+  static_scope' env e
+  ⇒
+  static_scope' env (Begin es e)
+[~Lambda_NONE:]
+  ALL_DISTINCT xs ∧
+  static_scope' (env ++ xs) e
+  ⇒
+  static_scope' env (Lambda xs NONE e)
+[~Lambda_SOME:]
+  ALL_DISTINCT (x::xs) ∧
+  static_scope' (env ++ x::xs) e
+  ⇒
+  static_scope' env (Lambda xs (SOME x) e)
+[~Letrec:]
+  ALL_DISTINCT (MAP FST bs) ∧
+  EVERY (static_scope' (env ++ MAP FST bs)) (MAP SND bs) ∧
+  static_scope' (env ++ MAP FST bs) e
+  ⇒
+  static_scope' env (Letrec bs e)
+[~Ident:]
+  MEM x env
+  ⇒
+  static_scope' env (Ident x)
+[~Set:]
+  MEM x env ∧
+  static_scope' env e
+  ⇒
+  static_scope' env (Set x e)
+End
+
+Theorem static_scope'_def = LIST_CONJ $ map
+  (SIMP_RULE pure_ss [Once $ GSYM CONJ_ASSOC] o
+    SIMP_RULE pure_ss [Once $ GSYM LIST_TO_SET,
+    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] o
+    GEN_ALL o SCONV [Once static_scope'_cases]) [
+  “static_scope' env (Lit l)”,
+  “static_scope' env (Cond c t f)”,
+  “static_scope' env (Apply fn es)”,
+  “static_scope' env (Begin es e)”,
+  “static_scope' env (Lambda xs NONE e)”,
+  “static_scope' env (Lambda xs (SOME x) e)”,
+  “static_scope' env (Letrec bs e)”,
+  “static_scope' env (Ident x)”,
+  “static_scope' env (Set x e)”
+];
+
+Theorem test'_def = oneline $ GEN_ALL $
+  SCONV [Once static_scope'_cases] “static_scope' env (Apply fn es)”;
+
+dest_eq (concl (oneline static_scope_def));
+
 Theorem static_scope_mono:
   ∀ env e env' .
     env ⊆ env' ∧ static_scope env e ⇒ static_scope env' e
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index 0f43348576..688cfa7c79 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -296,11 +296,18 @@ Termination
   >> gvs[]
 End
 
+Definition static_scope_check_def:
+  static_scope_check p = if static_scope ∅ p
+    then INR p
+    else INL "Not statically scoped or duplicate parameter in lambda or letrec"
+End
+
 Definition parse_to_ast_def:
   parse_to_ast s = do
       lxs <- lexer s;
       e <- parse lxs Nil [];
-      cons_ast (head e)
+      p <- cons_ast (head e);
+      static_scope_check p
     od
 End
 
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 375eb78ca1..5a8e1a2ace 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -25,10 +25,14 @@ val r = translate lexer_def;
 (*val r = translate scheme_valuesTheory.name_def;*)
 val r = translate scheme_valuesTheory.head_def;
 (*val r = translate quote_def;*)
+val r = translate (IN_UNION |> SIMP_RULE bool_ss [SPECIFICATION]);
+val r = translate LIST_TO_SET_DEF;
+val r = translate (test'_def);
 val r = translate parse_def;
 val r = translate pair_to_list_def;
 val r = translate cons_formals_def;
 val r = translate cons_ast_def;
+val r = translate static_scope_check_def;
 val r = translate parse_to_ast_def;
 
 (* codegen *)

From a06376c9acce4eb2f8698e6f765efad8e79dff29 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 16 Apr 2025 17:57:44 +0100
Subject: [PATCH 082/100] compiler static checks

---
 .../proofs/scheme_semanticsPropsScript.sml    |  16 +-
 .../proofs/scheme_to_cakeProofScript.sml      |   2 +-
 compiler/scheme/scheme_astScript.sml          | 231 +++++-------------
 .../translation/scheme_compilerProgScript.sml |   3 +-
 4 files changed, 72 insertions(+), 180 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index 84f1d9b381..906562f0a0 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -476,15 +476,15 @@ Proof
     >~ [‘Begin es e’] >- (
       Cases_on ‘es’ >- (
         simp[step_def, Once valid_state_cases]
-        >> gvs[Once valid_state_cases, Once static_scope_cases]
+        >> gvs[Once valid_state_cases, Once static_scope_def]
       )
       >> simp[step_def, Once valid_state_cases]
       >> simp[Once valid_val_cases]
-      >> gvs[Once valid_state_cases, Once static_scope_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_def]
     )
     >~ [‘Ident x’] >- (
       simp[step_def]
-      >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+      >> gvs[Once valid_state_cases, Once static_scope_def, can_lookup_cases]
       >> ‘∀ x . FDOM env x ⇒ ∃ a. FLOOKUP env x = SOME a’
         by simp[FLOOKUP_DEF, SPECIFICATION]
       >> pop_assum drule >> strip_tac
@@ -501,8 +501,8 @@ Proof
     >~ [‘Letrec bs e’] >- (
       simp[step_def]
       >> rpt (pairarg_tac >> gvs[])
-      >> simp[Once valid_state_cases, Once static_scope_cases]
-      >> gvs[Once valid_state_cases, Once static_scope_cases]
+      >> simp[Once valid_state_cases, Once static_scope_def]
+      >> gvs[Once valid_state_cases, Once static_scope_def]
       >> drule_then assume_tac letrec_init_dom
       >> drule_all_then assume_tac letrec_init_lookup
       >> gvs[]
@@ -528,7 +528,7 @@ Proof
       >> Induct_on ‘bs’ >- simp[]
       >> rpt strip_tac
       >> PairCases_on ‘h’
-      >> simp[Once static_scope_cases]
+      >> simp[Once static_scope_def]
       >> gvs[]
       >> last_x_assum $ qspec_then ‘env |+ (h0, 0)’ assume_tac
       >> gvs[]
@@ -547,7 +547,9 @@ Proof
     )
     >> simp[step_def, Once valid_state_cases]
     >> simp[Once valid_val_cases]
-    >> gvs[Once valid_state_cases, Once static_scope_cases, can_lookup_cases]
+    >> gvs[Once valid_state_cases, Once static_scope_def, can_lookup_cases]
+    >> Cases_on ‘o'’
+    >> gvs[Once valid_state_cases, Once static_scope_def, can_lookup_cases]
   )
   >~ [‘Val v’] >- (
     Cases_on ‘ks’ >- (
diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 1c39e509e6..2a908276b7 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -999,7 +999,7 @@ Proof
       simp[cps_transform_def]
       >> rpt strip_tac
       >> gvs[Once valid_state_cases]
-      >> gvs[Once static_scope_cases]
+      >> gvs[Once static_scope_def]
       >> gvs[Once $ GSYM SPECIFICATION]
       >> qpat_assum ‘env_rel _ _’ $ drule_then assume_tac
         o SRULE [env_rel_cases, FEVERY_DEF]
diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 7b25863656..87837a945b 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -49,189 +49,78 @@ Definition lit_to_val_def:
   lit_to_val (LitBool b) = SBool b
 End
 
-Inductive static_scope:
-[~Lit:]
-  static_scope env (Lit lit)
-[~Cond:]
+Definition static_scope_def:
+  static_scope env (Lit lit) = T ∧
+
+  static_scope env (Cond c t f) = (
   static_scope env c ∧
   static_scope env t ∧
-  static_scope env f
-  ⇒
-  static_scope env (Cond c t f)
-[~Apply:]
+  static_scope env f) ∧
+
+  static_scope env (Apply fn es) = (
   static_scope env fn ∧
-  EVERY (static_scope env) es
-  ⇒
-  static_scope env (Apply fn es)
-[~Begin:]
-  EVERY (static_scope env) es ∧
-  static_scope env e
-  ⇒
-  static_scope env (Begin es e)
-[~Lambda_NONE:]
-  ALL_DISTINCT xs ∧
-  static_scope (env ∪ set xs) e
-  ⇒
-  static_scope env (Lambda xs NONE e)
-[~Lambda_SOME:]
-  ALL_DISTINCT (x::xs) ∧
-  static_scope (env ∪ set (x::xs)) e
-  ⇒
-  static_scope env (Lambda xs (SOME x) e)
-[~Letrec:]
-  ALL_DISTINCT (MAP FST bs) ∧
-  EVERY (static_scope (env ∪ set (MAP FST bs))) (MAP SND bs) ∧
-  static_scope (env ∪ set (MAP FST bs)) e
-  ⇒
-  static_scope env (Letrec bs e)
-[~Ident:]
-  env x
-  ⇒
-  static_scope env (Ident x)
-[~Set:]
-  env x ∧
-  static_scope env e
-  ⇒
-  static_scope env (Set x e)
-End
+  static_scope_list env es) ∧
 
-Theorem static_scope_def = LIST_CONJ $ map
-  (SIMP_RULE pure_ss [Once $ GSYM CONJ_ASSOC] o
-    SIMP_RULE pure_ss [Once $ GSYM LIST_TO_SET,
-    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] o
-    GEN_ALL o SCONV [Once static_scope_cases]) [
-  “static_scope env (Lit l)”,
-  “static_scope env (Cond c t f)”,
-  “static_scope env (Apply fn es)”,
-  “static_scope env (Begin es e)”,
-  “static_scope env (Lambda xs NONE e)”,
-  “static_scope env (Lambda xs (SOME x) e)”,
-  “static_scope env (Letrec bs e)”,
-  “static_scope env (Ident x)”,
-  “static_scope env (Set x e)”
-];
-
-Theorem test_def = oneline $ GEN_ALL $
-  SIMP_RULE bool_ss [Once $ GSYM CONJ_ASSOC] $
-  SIMP_RULE bool_ss [Once $ GSYM LIST_TO_SET,
-    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] $
-  SCONV [Once static_scope_cases] “static_scope env (Apply fn es)”;
-
-Inductive static_scope':
-[~Lit:]
-  static_scope' env (Lit lit)
-[~Cond:]
-  static_scope' env c ∧
-  static_scope' env t ∧
-  static_scope' env f
-  ⇒
-  static_scope' env (Cond c t f)
-[~Apply:]
-  static_scope' env fn ∧
-  ALL_EL (static_scope' env) es
-  ⇒
-  static_scope' env (Apply fn es)
-[~Begin:]
-  EVERY (static_scope' env) es ∧
-  static_scope' env e
-  ⇒
-  static_scope' env (Begin es e)
-[~Lambda_NONE:]
+  static_scope env (Begin es e) = (
+  static_scope_list env es ∧
+  static_scope env e) ∧
+
+  static_scope env (Lambda xs NONE e) = (
   ALL_DISTINCT xs ∧
-  static_scope' (env ++ xs) e
-  ⇒
-  static_scope' env (Lambda xs NONE e)
-[~Lambda_SOME:]
+  static_scope (env ∪ set xs) e) ∧
+
+  static_scope env (Lambda xs (SOME x) e) = (
   ALL_DISTINCT (x::xs) ∧
-  static_scope' (env ++ x::xs) e
-  ⇒
-  static_scope' env (Lambda xs (SOME x) e)
-[~Letrec:]
+  static_scope (env ∪ set (x::xs)) e) ∧
+
+  static_scope env (Letrec bs e) = (
   ALL_DISTINCT (MAP FST bs) ∧
-  EVERY (static_scope' (env ++ MAP FST bs)) (MAP SND bs) ∧
-  static_scope' (env ++ MAP FST bs) e
-  ⇒
-  static_scope' env (Letrec bs e)
-[~Ident:]
-  MEM x env
-  ⇒
-  static_scope' env (Ident x)
-[~Set:]
-  MEM x env ∧
-  static_scope' env e
-  ⇒
-  static_scope' env (Set x e)
+  static_scope_list (env ∪ set (MAP FST bs)) (MAP SND bs) ∧
+  static_scope (env ∪ set (MAP FST bs)) e) ∧
+
+  static_scope env (Ident x) = env x ∧
+
+  static_scope env (Set x e) = (
+  env x ∧
+  static_scope env e) ∧
+
+  (static_scope_list env [] = T) ∧
+  static_scope_list env (e::es) = (static_scope env e ∧ static_scope_list env es)
+Termination
+  WF_REL_TAC ‘measure (λ x . case x of
+    | INL(_,e) => exp_size e
+    | INR(_,es) => list_size exp_size es)’
+  >> Induct_on ‘bs’
+  >> gvs[list_size_def, fetch "-" "exp_size_def"]
+  >> PairCases
+  >> strip_tac
+  >> gvs[list_size_def, fetch "-" "exp_size_def"]
+  >> pop_assum $ qspec_then ‘e’ assume_tac
+  >> gvs[list_size_def, fetch "-" "exp_size_def"]
 End
 
-Theorem static_scope'_def = LIST_CONJ $ map
-  (SIMP_RULE pure_ss [Once $ GSYM CONJ_ASSOC] o
-    SIMP_RULE pure_ss [Once $ GSYM LIST_TO_SET,
-    Once $ CONJ_ASSOC, Once $ GSYM ALL_DISTINCT] o
-    GEN_ALL o SCONV [Once static_scope'_cases]) [
-  “static_scope' env (Lit l)”,
-  “static_scope' env (Cond c t f)”,
-  “static_scope' env (Apply fn es)”,
-  “static_scope' env (Begin es e)”,
-  “static_scope' env (Lambda xs NONE e)”,
-  “static_scope' env (Lambda xs (SOME x) e)”,
-  “static_scope' env (Letrec bs e)”,
-  “static_scope' env (Ident x)”,
-  “static_scope' env (Set x e)”
-];
-
-Theorem test'_def = oneline $ GEN_ALL $
-  SCONV [Once static_scope'_cases] “static_scope' env (Apply fn es)”;
-
-dest_eq (concl (oneline static_scope_def));
-
-Theorem static_scope_mono:
-  ∀ env e env' .
-    env ⊆ env' ∧ static_scope env e ⇒ static_scope env' e
+Theorem static_scope_mono_all:
+    (∀ env' e env . env ⊆ env' ∧ static_scope env e ⇒ static_scope env' e) ∧
+    (∀ env' es env . env ⊆ env' ∧ static_scope_list env es ⇒ static_scope_list env' es)
 Proof
-  simp[Once CONJ_COMM]
-  >> simp[GSYM AND_IMP_INTRO]
-  >> simp[GSYM PULL_FORALL]
-  >> ho_match_mp_tac static_scope_ind
+  ho_match_mp_tac static_scope_ind
   >> rpt strip_tac
-  >~ [‘Letrec bs e’] >- (
-    simp[Once static_scope_cases]
-    >> ‘env ∪ set (MAP FST bs) ⊆ env' ∪ set (MAP FST bs)’
-      by gvs[SUBSET_UNION_ABSORPTION, UNION_ASSOC]
-    >> qpat_x_assum ‘∀ _._ ⇒ _’ $ irule_at (Pos last)
-    >> simp[]
-    >> irule EVERY_MONOTONIC
-    >> qpat_x_assum ‘EVERY _ _’ $ irule_at (Pos last)
-    >> rpt strip_tac
-    >> gvs[]
-  )
-  >> simp[Once static_scope_cases]
+  >> simp[Once static_scope_def]
+  >> gvs[Once static_scope_def]
+  >> rpt (last_x_assum $ drule_at_then (Pos last) assume_tac)
+  >> simp[]
   >> gvs[SUBSET_DEF, SPECIFICATION]
-  >> irule EVERY_MONOTONIC
-  >> qpat_assum ‘EVERY _ _’ $ irule_at (Pos last)
-  >> gvs[]
 QED
 
-val _ = export_theory();
+Theorem static_scope_mono = cj 1 static_scope_mono_all;
 
-(*
-  EVAL “static_scoping_check {} (
-    Apply (
-      Lambda [strlit "f"; strlit "x"] NONE (Begin (
-        Apply (Ident $ strlit "f"
-        ) [Val $ SNum 1]
-      ) [
-        Ident $ strlit "x"
-      ])
-    ) [
-      Lambda [strlit "y"] NONE (Begin (
-        Set (strlit "x") (Val $ SNum 5)
-      ) [
-        Apply (Val $ Prim SAdd) [
-          Ident $ strlit "y";
-          Ident $ strlit "x"
-        ]
-      ]);
-      Val $ SNum 4
-    ]
-  )”
-*)
\ No newline at end of file
+Theorem every_static_scope[simp]:
+  ∀ env . static_scope_list env = EVERY (static_scope env)
+Proof
+  gen_tac
+  >> irule EQ_EXT
+  >> Induct
+  >> simp[static_scope_def]
+QED
+
+val _ = export_theory();
\ No newline at end of file
diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 5a8e1a2ace..5ef52d71b3 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -27,11 +27,12 @@ val r = translate scheme_valuesTheory.head_def;
 (*val r = translate quote_def;*)
 val r = translate (IN_UNION |> SIMP_RULE bool_ss [SPECIFICATION]);
 val r = translate LIST_TO_SET_DEF;
-val r = translate (test'_def);
+val r = translate static_scope_def;
 val r = translate parse_def;
 val r = translate pair_to_list_def;
 val r = translate cons_formals_def;
 val r = translate cons_ast_def;
+val r = translate EMPTY_DEF;
 val r = translate static_scope_check_def;
 val r = translate parse_to_ast_def;
 

From 87d1a5e2f09a99a006eec3bdec3621c0fafdbc99 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Wed, 16 Apr 2025 22:16:51 +0100
Subject: [PATCH 083/100] proven callcc

---
 .../proofs/scheme_to_cakeProofScript.sml      | 288 ++++++++++++++----
 compiler/scheme/scheme_to_cakeScript.sml      |  13 +-
 2 files changed, 233 insertions(+), 68 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 2a908276b7..bb6da87c07 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -261,28 +261,46 @@ Theorem vcons_list_def[allow_rebind] = SRULE [] $ Define ‘
   vcons_list (v::vs) = Conv (SOME (scheme_typestamp "::")) [v; vcons_list vs]
 ’;
 
-val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
-(fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
-  (ml_v_vals' (SBool T) $
-    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "True")) []]) ∧
-  (ml_v_vals' (SBool F) $
-    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "False")) []]) ∧
-  (ml_v_vals' (SNum n') $
-    Conv (SOME (scheme_typestamp "SNum")) [Litv (IntLit n')]) ∧
-  (ml_v_vals' (Prim SAdd) $
-    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SAdd")) []]) ∧
-  (ml_v_vals' (Prim SMul) $
-    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMul")) []]) ∧
-  (ml_v_vals' (Prim SMinus) $
-    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMinus")) []]) ∧
-  (ml_v_vals' (Prim SEqv) $
-    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SEqv")) []]) ∧
-  (ml_v_vals' (Prim CallCC) $
-    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "CallCC")) []]) ∧
-  (ml_v_vals' (Wrong s) $
-    Conv (SOME (scheme_typestamp "Wrong")) [Litv (StrLit s)]) ∧
+Definition cps_app_ts_def:
+  cps_app_ts n (e::es) = (let
+    (m, ce) = cps_transform n e;
+    t = "t" ++ toString m
+  in
+    t :: cps_app_ts (m+1) es) ∧
 
-  (scheme_env env ∧
+  cps_app_ts n [] = []
+End
+
+Inductive val_cont_rels:
+[~SBool_T:]
+  ml_v_vals' (SBool T) $
+    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "True")) []]
+[~SBool_F:]
+  ml_v_vals' (SBool F) $
+    Conv (SOME (scheme_typestamp "SBool")) [Conv (SOME (scheme_typestamp "False")) []]
+[~SNum:]
+  ml_v_vals' (SNum i) $
+    Conv (SOME (scheme_typestamp "SNum")) [Litv (IntLit i)]
+[~Prim_SAdd:]
+  ml_v_vals' (Prim SAdd) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SAdd")) []]
+[~Prim_SMul:]
+  ml_v_vals' (Prim SMul) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMul")) []]
+[~Prim_SMinus:]
+  ml_v_vals' (Prim SMinus) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SMinus")) []]
+[~Prim_SEqv:]
+  ml_v_vals' (Prim SEqv) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "SEqv")) []]
+[~Prim_CallCC:]
+  ml_v_vals' (Prim CallCC) $
+    Conv (SOME (scheme_typestamp "Prim")) [Conv (SOME (scheme_typestamp "CallCC")) []]
+[~Prim_Wrong:]
+  ml_v_vals' (Wrong s) $
+    Conv (SOME (scheme_typestamp "Wrong")) [Litv (StrLit s)]
+[~Proc:]
+  scheme_env env ∧
   env_rel se env ∧
   (m, ce) = cps_transform n e ∧
   args = "xs" ++ toString m ∧
@@ -292,51 +310,18 @@ val (ml_v_vals'_rules,ml_v_vals'_ind,ml_v_vals'_cases) =
   ml_v_vals' (Proc se xs xp e) $
     Conv (SOME (scheme_typestamp "Proc")) [
       Closure env k $ Fun args inner
-    ]) ∧
-  (LIST_REL ml_v_vals' vs mlvs
+    ]
+[~Throw:]
+  cont_rel ks kv
   ⇒
-  ml_v_vals' (SList vs) $
-    Conv (SOME (scheme_typestamp "SList")) [vcons_list mlvs])
-’;
-
-val (store_entry_rel_rules,store_entry_rel_ind,store_entry_rel_cases) =
-(fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
-  (ml_v_vals' v mlv
+  ml_v_vals' (Throw ks) $
+    Conv (SOME (scheme_typestamp "Throw")) [kv]
+[~SList:]
+  LIST_REL ml_v_vals' vs mlvs
   ⇒
-  store_entry_rel (SOME v) (Refv (Conv (SOME (scheme_typestamp "Some")) [mlv]))) ∧
-  store_entry_rel NONE (Refv (Conv (SOME (scheme_typestamp "None")) []))
-’;
-
-Inductive e_ce_rel:
-[~Val:]
-  ml_v_vals' v mlv ∧
-  nsLookup env.v (Short valv) = SOME (mlv) ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  valv ≠ var
-  ⇒
-  e_ce_rel (Val v) var env kv $ App Opapp [Var (Short var); Var (Short valv)]
-[~Exp:]
-  (m, ce) = cps_transform n e ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  scheme_env env
-  ⇒
-  e_ce_rel (Exp e) var env kv $ App Opapp [ce; Var (Short var)]
-[~Exception:]
-  e_ce_rel (Exception s) var env kv $
-    Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]
-End
-
-Definition cps_app_ts_def:
-  cps_app_ts n (e::es) = (let
-    (m, ce) = cps_transform n e;
-    t = "t" ++ toString m
-  in
-    t :: cps_app_ts (m+1) es) ∧
-
-  cps_app_ts n [] = []
-End
+  ml_v_vals' (SList vs) $
+    Conv (SOME (scheme_typestamp "SList")) [vcons_list mlvs]
 
-Inductive cont_rel:
 [~Id:]
   scheme_env env ∧
   ¬ MEM t vconses
@@ -435,6 +420,37 @@ Inductive cont_rel:
     (Closure env t $ inner)
 End
 
+Theorem val_cont_rels_ind[allow_rebind] = SRULE [] $ val_cont_rels_ind;
+Theorem ml_v_vals'_cases = SRULE [] $ cj 1 val_cont_rels_cases;
+Theorem cont_rel_cases = cj 2 val_cont_rels_cases;
+
+val (store_entry_rel_rules,store_entry_rel_ind,store_entry_rel_cases) =
+(fn (x,y,z) => (SRULE [] x,SRULE [] y, SRULE [] z)) $ Hol_reln ‘
+  (ml_v_vals' v mlv
+  ⇒
+  store_entry_rel (SOME v) (Refv (Conv (SOME (scheme_typestamp "Some")) [mlv]))) ∧
+  store_entry_rel NONE (Refv (Conv (SOME (scheme_typestamp "None")) []))
+’;
+
+Inductive e_ce_rel:
+[~Val:]
+  ml_v_vals' v mlv ∧
+  nsLookup env.v (Short valv) = SOME (mlv) ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  valv ≠ var
+  ⇒
+  e_ce_rel (Val v) var env kv $ App Opapp [Var (Short var); Var (Short valv)]
+[~Exp:]
+  (m, ce) = cps_transform n e ∧
+  nsLookup env.v (Short var) = SOME kv ∧
+  scheme_env env
+  ⇒
+  e_ce_rel (Exp e) var env kv $ App Opapp [ce; Var (Short var)]
+[~Exception:]
+  e_ce_rel (Exception s) var env kv $
+    Con (SOME $ Short "Ex") [Lit $ StrLit $ explode s]
+End
+
 Theorem compile_in_rel:
   ∀ p st env .
     scheme_env env
@@ -1511,6 +1527,152 @@ Proof
             >> strip_tac
             >> gvs[env_rel_cases]
           )
+          >~ [‘"SEqv"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+4’
+            >> simp[Ntimes evaluate_def 3]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> Cases_on ‘vs’ using SNOC_CASES
+            >> gvs[vcons_list_def, seqv_def] >- (
+              simp[Ntimes evaluate_def 8]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+            )
+            >> Cases_on ‘mlvs’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> simp[Ntimes evaluate_def 5]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> Cases_on ‘l’ using SNOC_CASES
+            >> gvs[vcons_list_def, seqv_def] >- (
+              simp[Ntimes evaluate_def 8]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> Cases_on ‘x=v’
+              >> simp[Ntimes evaluate_def 5, do_if_def, do_app_def, do_eq_def]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> cheat
+              (*>> irule_at (Pos hd) EQ_REFL
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]*)
+            )
+            >> Cases_on ‘l'’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> Cases_on ‘l''’ using SNOC_CASES
+            >> Cases_on ‘l’ using SNOC_CASES
+            >> gvs[vcons_list_def, seqv_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> simp[Ntimes evaluate_def 8]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+          )
+          >~ [‘"CallCC"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+4’
+            >> simp[Ntimes evaluate_def 5]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> simp[Ntimes evaluate_def 4, do_opapp_def]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> simp[Ntimes evaluate_def 1, do_opapp_def, dec_clock_def]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> Cases_on ‘vs’ using SNOC_CASES
+            >> gvs[vcons_list_def] >- (
+              simp[Ntimes evaluate_def 8]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> simp[Ntimes evaluate_def 5, do_con_check_def, build_conv_def,
+                nsOptBind_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> simp[env_rel_cases, FEVERY_FEMPTY]
+              >> simp[Once cont_rel_cases]
+              >> gvs[cps_transform_def, cps_app_ts_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases]
+              >> simp[Once ml_v_vals'_cases]
+              >> simp[cons_list_def]
+              >> simp[scheme_env_def, env_rel_cases, FEVERY_FEMPTY]
+            )
+            >> Cases_on ‘mlvs’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> Cases_on ‘l’ using SNOC_CASES
+            >> Cases_on ‘l'’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> simp[Ntimes evaluate_def 8]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+          )
+          >~ [‘"Throw"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> qrefine ‘ck+4’
+            >> simp[Ntimes evaluate_def 5]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+            >> Cases_on ‘vs’ using SNOC_CASES
+            >> gvs[vcons_list_def] >- (
+              simp[Ntimes evaluate_def 8]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> simp[env_rel_cases, FEVERY_FEMPTY]
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases]
+            )
+            >> Cases_on ‘mlvs’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> Cases_on ‘l’ using SNOC_CASES
+            >> Cases_on ‘l'’ using SNOC_CASES
+            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+            >> simp[Ntimes evaluate_def 8]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+          )
           >> cheat
         )
         >> simp[]
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index af639f169a..92944c19ef 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -333,11 +333,14 @@ Definition scheme_basis7_def:
       (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
         Mat (Var (Short "xs'")) [
           (Pcon (SOME $ Short "[]") [],
-            App Opapp [
-              App Opapp [
-                App Opapp [Var (Short "app");Var (Short "k")];
-                Var (Short "x")];
-              cons_list [Con (SOME $ Short "Throw") [Var (Short "k")]]]);
+            Let (SOME "k'") (
+              Fun "t" $ App Opapp [
+                App Opapp [
+                  App Opapp [Var (Short "app");Var (Short "k")];
+                  Var (Short "x")];
+                cons_list [Var (Short "t")]]
+            ) $ Let (SOME "v") (Con (SOME $ Short "Throw") [Var (Short "k")]) $
+              App Opapp [Var (Short "k'"); Var (Short "v")]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
         ])

From 1d04e698ac4a1c32fb8a68a0aa47f6a0357c437f Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Fri, 18 Apr 2025 01:23:21 +0100
Subject: [PATCH 084/100] proven eqv, narrowed eqv def a bit

---
 .../proofs/scheme_semanticsPropsScript.sml    |  2 -
 .../proofs/scheme_to_cakeProofScript.sml      | 76 +++++++++++++++++--
 compiler/scheme/scheme_semanticsScript.sml    |  9 ++-
 compiler/scheme/scheme_to_cakeScript.sml      | 26 +++++--
 4 files changed, 98 insertions(+), 15 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index 906562f0a0..9cf531807f 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -451,8 +451,6 @@ Proof
   >> simp[seqv_def]
   >> Cases_on ‘t'’
   >> simp[seqv_def]
-  >> IF_CASES_TAC
-  >> simp[]
 QED
 
 Theorem valid_state_progress:
diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index bb6da87c07..be3f4c05c4 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -1561,15 +1561,79 @@ Proof
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def]
-              >> Cases_on ‘x=v’
-              >> simp[Ntimes evaluate_def 5, do_if_def, do_app_def, do_eq_def]
+              >> Cases_on ‘∃ n . x = SNum n’ >- (
+                gvs[Once ml_v_vals'_cases]
+                >> simp[Ntimes evaluate_def 8]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def]
+                >> Cases_on ‘∃ m . v = SNum m’ >- (
+                  gvs[Once ml_v_vals'_cases]
+                  >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
+                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                    same_type_def, same_ctor_def, evaluate_match_def,
+                    pat_bindings_def, do_con_check_def, build_conv_def,
+                    do_eq_def, lit_same_type_def]
+                  >> irule_at (Pos hd) EQ_REFL
+                  >> simp[env_rel_cases, FEVERY_FEMPTY]
+                  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                  >> Cases_on ‘i=i'’
+                  >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                    Boolv_def, bool_type_num_def]
+                )
+                >> Cases_on ‘v’
+                >> gvs[Once ml_v_vals'_cases]
+                >> simp[Ntimes evaluate_def 8, nsOptBind_def]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def]
+                >> irule_at (Pos hd) EQ_REFL
+                >> simp[env_rel_cases, FEVERY_FEMPTY]
+                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                  Boolv_def, bool_type_num_def]
+              )
+              >> Cases_on ‘∃ b . x = SBool b’ >- (
+                gvs[Once ml_v_vals'_cases]
+                >> simp[Ntimes evaluate_def 8]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def]
+                >> (Cases_on ‘∃ b' . v = SBool b'’ >- (
+                  gvs[Once ml_v_vals'_cases]
+                  >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
+                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                    same_type_def, same_ctor_def, evaluate_match_def,
+                    pat_bindings_def, do_con_check_def, build_conv_def,
+                    do_eq_def, lit_same_type_def, ctor_same_type_def]
+                  >> irule_at (Pos hd) EQ_REFL
+                  >> simp[env_rel_cases, FEVERY_FEMPTY]
+                  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                  >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                    Boolv_def, bool_type_num_def]
+                ))
+                >> Cases_on ‘v’ >> gvs[]
+                >> gvs[Once ml_v_vals'_cases]
+                >> simp[Ntimes evaluate_def 8, nsOptBind_def]
+                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                  same_type_def, same_ctor_def, evaluate_match_def,
+                  pat_bindings_def, do_con_check_def, build_conv_def]
+                >> irule_at (Pos hd) EQ_REFL
+                >> simp[env_rel_cases, FEVERY_FEMPTY]
+                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                  Boolv_def, bool_type_num_def]
+              )
+              >> Cases_on ‘x’ >> gvs[]
+              >> gvs[Once ml_v_vals'_cases]
+              >> simp[Ntimes evaluate_def 9, nsOptBind_def]
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> cheat
-              (*>> irule_at (Pos hd) EQ_REFL
+                pat_bindings_def, do_con_check_def, build_conv_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> simp[env_rel_cases, FEVERY_FEMPTY]
               >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]*)
+              >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
             )
             >> Cases_on ‘l'’ using SNOC_CASES
             >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 5e8dd4af93..d775d5e05c 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -33,7 +33,14 @@ Definition sminus_def:
 End
 
 Definition seqv_def:
-  seqv [v1; v2] = (if v1 = v2 then Val $ SBool T else Val $ SBool F) ∧
+  seqv [v1; v2] = (Val $ SBool $ case v1 of
+  | SNum n => (case v2 of
+    | SNum m => n = m
+    | _ => F)
+  | SBool b => (case v2 of
+    | SBool b' => b = b'
+    | _ => F)
+  | _ => F) ∧
   seqv _ = Exception $ strlit "Arity mismatch"
 End
 
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 92944c19ef..b67c690296 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -298,13 +298,27 @@ Definition scheme_basis5_def:
           (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
             Mat (Var (Short "xs''")) [
               (Pcon (SOME $ Short "[]") [],
-                If (App Equality [Var (Short "x1"); Var (Short "x2")])
-                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "True") []]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")])
-                  (Let (SOME "v") (Con (SOME $ Short "SBool") [Con (SOME $ Short "False") []]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")]));
+                (Let (SOME "v") (Con (SOME $ Short "SBool") [
+                  Mat (Var (Short "x1")) [
+                    (Pcon (SOME $ Short "SNum") [Pvar "n"],
+                      Mat (Var (Short "x2")) [
+                        (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                          App Equality [Var (Short "n"); Var (Short "m")]);
+                        (Pany,
+                          Con (SOME $ Short "False") [])
+                      ]);
+                    (Pcon (SOME $ Short "SBool") [Pvar "b"],
+                      Mat (Var (Short "x2")) [
+                        (Pcon (SOME $ Short "SBool") [Pvar "b'"],
+                          App Equality [Var (Short "b"); Var (Short "b'")]);
+                        (Pany,
+                          Con (SOME $ Short "False") [])
+                      ]);
+                    (Pany,
+                      Con (SOME $ Short "False") [])
+                    ]]) $ App Opapp [Var (Short "k"); Var (Short "v")]));
               (Pany,
-                Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
+                Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
             ])
         ])
     ]

From 61e3a05919062d3294d6df6937eafc0eba45ae8a Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 19 Apr 2025 13:33:08 +0100
Subject: [PATCH 085/100] proven subtraction

---
 .../proofs/scheme_to_cakeProofScript.sml      | 358 ++++++++++++++----
 1 file changed, 279 insertions(+), 79 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index be3f4c05c4..249183ba9c 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -570,6 +570,263 @@ Proof
   >> simp[LIST_REL_SNOC]
 QED
 
+Theorem preservation_of_sadd_body:
+  ∀ vs mlvs .
+    LIST_REL ml_v_vals' vs mlvs
+    ⇒
+  ∀ store st env n k kv i .
+    cont_rel k kv ∧
+    LIST_REL store_entry_rel store st.refs ∧
+    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
+    nsLookup env.v (Short "k") = SOME kv ∧
+    nsLookup env.v (Short "sadd") = nsLookup scheme_env2.v (Short "sadd") ∧
+    env.c = scheme_env1.c ∧
+    i > 0
+    ⇒
+    ∃ck st' mlenv' var' kv' mle'.
+      evaluate (st with clock := ck) env
+        [Mat (Var (Short "xs"))
+           [(Pcon (SOME (Short "[]")) [],
+             Let (SOME "v") (Con (SOME (Short "SNum")) [Var (Short "n")])
+               (App Opapp [Var (Short "k"); Var (Short "v")]));
+            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
+             Mat (Var (Short "x"))
+               [(Pcon (SOME (Short "SNum")) [Pvar "xn"],
+                 App Opapp
+                   [App Opapp
+                      [App Opapp [Var (Short "sadd"); Var (Short "k")];
+                       App (Opn Plus) [Var (Short "n"); Var (Short "xn")]];
+                    Var (Short "xs'")]);
+                (Pany,
+                 Con (SOME (Short "Ex"))
+                   [Lit (StrLit "Arith-op applied to non-number")])])]] =
+      evaluate st' mlenv' [mle'] ∧
+      cont_rel k kv' ∧
+      e_ce_rel (sadd vs n) var' mlenv' kv' mle' ∧
+      env_rel FEMPTY mlenv' ∧
+      LIST_REL store_entry_rel store st'.refs ∧
+      st'.clock ≤ ck + i ∧
+      st'.clock < ck + i
+Proof
+  ho_match_mp_tac LIST_REL_ind
+  >> simp[vcons_list_def, sadd_def]
+  >> rpt strip_tac >- (
+    simp[Ntimes evaluate_def 2]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
+      nsOptBind_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> last_assum $ irule_at (Pos hd)
+    >> simp[Once e_ce_rel_cases, sadd_def, Once ml_v_vals'_cases,
+      env_rel_cases, FEVERY_FEMPTY]
+  )
+  >> gvs[Once ml_v_vals'_cases]
+  >> gvs[vcons_list_def]
+  >~ [‘SNum m’] >- (
+    simp[sadd_def]
+    >> simp[evaluate_def, do_opapp_def, do_app_def,
+      opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+    >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+    >> qrefine ‘ck+3’
+    >> simp[Ntimes evaluate_def 2]
+    >> last_x_assum irule
+    >> simp[]
+    >> simp[Once INT_ADD_COMM]
+  )
+  >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+    opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+    same_type_def, same_ctor_def, evaluate_match_def,
+    pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+  >> simp[sadd_def, Once e_ce_rel_cases]
+  >> irule_at (Pos hd) EQ_REFL
+  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+  >> simp[env_rel_cases, FEVERY_FEMPTY]
+QED
+
+Theorem preservation_of_sminus_body:
+  ∀ vs mlvs .
+    LIST_REL ml_v_vals' vs mlvs
+    ⇒
+  ∀ store (st:'ffi state) env n k kv i .
+    cont_rel k kv ∧
+    LIST_REL store_entry_rel store st.refs ∧
+    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "k") = SOME kv ∧
+    nsLookup env.v (Short "sadd") = nsLookup scheme_env3.v (Short "sadd") ∧
+    env.c = scheme_env1.c ∧
+    i > 0
+    ⇒
+    ∃ck st' mlenv' var' kv' mle'.
+      evaluate (st with clock := ck) env
+        [Mat (Var (Short "xs"))
+           [(Pcon (SOME (Short "[]")) [],
+             Con (SOME (Short "Ex")) [Lit (StrLit "Arity mismatch")]);
+            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
+             Mat (Var (Short "x"))
+               [(Pcon (SOME (Short "SNum")) [Pvar "n"],
+                 App Opapp
+                   [App Opapp
+                      [App Opapp
+                         [Var (Short "sadd");
+                          Fun "t"
+                            (Mat (Var (Short "t"))
+                               [(Pcon (SOME (Short "SNum")) [Pvar "m"],
+                                 Let (SOME "v")
+                                   (Con (SOME (Short "SNum"))
+                                      [App (Opn Minus)
+                                         [Var (Short "n");
+                                          Var (Short "m")]])
+                                   (App Opapp
+                                      [Var (Short "k"); Var (Short "v")]));
+                                (Pany,
+                                 App Opapp
+                                   [Var (Short "k"); Var (Short "t")])])];
+                       Lit (IntLit 0)]; Var (Short "xs'")]);
+                (Pany,
+                 Con (SOME (Short "Ex"))
+                   [Lit (StrLit "Arith-op applied to non-number")])])]] =
+      evaluate st' mlenv' [mle'] ∧
+      cont_rel k kv' ∧
+      e_ce_rel (sminus vs) var' mlenv' kv' mle' ∧
+      env_rel FEMPTY mlenv'
+      ∧ LIST_REL store_entry_rel store st'.refs ∧
+      st'.clock ≤ ck + i ∧ st'.clock < ck + i
+Proof
+  Cases_on ‘vs’ >- (
+    simp[vcons_list_def]
+    >> rpt strip_tac
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> last_assum $ irule_at (Pos hd)
+    >> simp[sminus_def]
+    >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+  )
+  >> Cases_on ‘mlvs’
+  >> simp[vcons_list_def]
+  >> strip_tac
+  >> gvs[Once ml_v_vals'_cases]
+  >~ [‘SNum i’] >- (
+    simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> rpt strip_tac
+    >> qrefine ‘ck+3’
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> simp[Ntimes evaluate_def 7, do_opapp_def]
+    >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+    >> simp[Ntimes evaluate_def 2, dec_clock_def]
+    >> ‘∃ i'' . i' + 3 = i''’ by simp[]
+    >> pop_assum mp_tac >> strip_tac
+    >> ‘i'' > 0’ by simp[]
+    >> qpat_x_assum ‘i' > 0’ kall_tac
+    >> qpat_x_assum ‘i' + 3 = i''’ $ simp o single
+    >> simp[sminus_def]
+    >> ‘∃ n . 0i = n’ by simp[]
+    >> pop_assum mp_tac >> strip_tac
+    >> pop_assum $ simp o single
+    >> ‘∃ kenv . (env with
+                           v :=
+                             nsBind "n" (Litv (IntLit i))
+                               (nsBind "xs'" (vcons_list t')
+                                  (nsBind "x"
+                                     (Conv (SOME (TypeStamp "SNum" 4))
+                                        [Litv (IntLit i)]) env.v)))
+                  = kenv’ by simp[]
+    >> pop_assum mp_tac >> strip_tac
+    >> ‘nsLookup kenv.v (Short "n") = SOME (Litv (IntLit i))’ by gvs[]
+    >> ‘nsLookup kenv.v (Short "k") = SOME kv’ by gvs[]
+    >> ‘kenv.c = scheme_env1.c’ by gvs[]
+    >> qpat_x_assum ‘_ = kenv’ $ simp o single
+    >> rpt $ qpat_x_assum ‘nsLookup env.v _ = _’ kall_tac
+    >> rpt $ pop_assum mp_tac
+    >> strip_tac
+    >> qid_spec_tac ‘i''’
+    >> qid_spec_tac ‘n’
+    >> qid_spec_tac ‘st’
+    >> pop_assum mp_tac
+    >> qid_spec_tac ‘t'’
+    >> qid_spec_tac ‘t’
+    >> ho_match_mp_tac LIST_REL_ind
+    >> rpt strip_tac >- (
+      simp[vcons_list_def, sadd_def]
+      >> simp[Ntimes evaluate_def 3]
+      >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def]
+      >> simp[Ntimes evaluate_def 7, do_opapp_def, do_con_check_def,
+        build_conv_def, nsOptBind_def]
+      >> qrefine ‘ck+1’
+      >> simp[Ntimes evaluate_def 3, dec_clock_def]
+      >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def]
+      >> simp[Ntimes evaluate_def 6, do_app_def, do_con_check_def,
+        build_conv_def, nsOptBind_def, opn_lookup_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[env_rel_cases, FEVERY_FEMPTY]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+    )
+    >> gvs[Once ml_v_vals'_cases]
+    >~ [‘SNum m’] >- (
+      simp[sadd_def, vcons_list_def]
+      >> simp[evaluate_def, do_opapp_def, do_app_def,
+        opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+      >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+      >> qrefine ‘ck+3’
+      >> simp[Ntimes evaluate_def 2]
+      >> simp[Once INT_ADD_COMM]
+    )
+    >> simp[sadd_def, vcons_list_def]
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> simp[Ntimes evaluate_def 3]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> simp[env_rel_cases, FEVERY_FEMPTY]
+    >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+    >> simp[Once e_ce_rel_cases]
+  )
+  >> simp[sminus_def]
+  >> rpt strip_tac
+  >> simp[Ntimes evaluate_def 3]
+  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+    same_type_def, same_ctor_def, evaluate_match_def,
+    pat_bindings_def]
+  >> simp[Ntimes evaluate_def 3]
+  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+    same_type_def, same_ctor_def, evaluate_match_def,
+    pat_bindings_def]
+  >> irule_at (Pos hd) EQ_REFL
+  >> simp[env_rel_cases, FEVERY_FEMPTY]
+  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+  >> simp[Once e_ce_rel_cases]
+QED
+
 Theorem preservation_of_proc:
 ∀ (st:'ffi state) inner n n' m m' env env' mlenv var kv n xs xp e e' ce k args vs mlvs store store' i .
   valid_val store (Proc env xs xp e) ∧
@@ -1411,87 +1668,30 @@ Proof
             >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
             >> qrefine ‘ck+2’
             >> simp[Ntimes evaluate_def 2, dec_clock_def]
-            >> Cases_on ‘∃ (n:int) . n = 0’ >~ [‘¬∃n.n=0’] >- gvs[]
-            >> pop_assum mp_tac
-            >> strip_tac
-            >> pop_assum $ simp o single o GSYM
-            >> qid_spec_tac ‘n’
-            >> pop_assum kall_tac
-            >> rpt $ qpat_x_assum ‘LIST_REL _ ts _’ kall_tac
-            >> qpat_assum ‘LIST_REL _ vs mlvs’ mp_tac
-            >> qid_spec_tac ‘mlvs’
-            >> qid_spec_tac ‘vs’
-            >> ho_match_mp_tac LIST_REL_SNOC_ind
-            >> rpt strip_tac >- (
-              gvs[Once ml_v_vals'_cases, vcons_list_def]
-              >> qrefine ‘ck+1’
-              >> simp[Ntimes evaluate_def 2]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >~ [‘SNum m’] >- (
-                qrefine ‘ck+3’
-                >> simp[evaluate_def, do_app_def, do_opapp_def, dec_clock_def]
-                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def]
-                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                >> simp[Ntimes evaluate_def 4]
-                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def]
-                >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-                >> simp[Ntimes evaluate_def 3, do_con_check_def,
-                build_conv_def, nsOptBind_def]
-                >> simp[sadd_def]
-                >> irule_at (Pos hd) EQ_REFL
-                >> simp[]
-                >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-                >> simp[Once e_ce_rel_cases, opn_lookup_def,
-                  env_rel_cases, FEVERY_FEMPTY, Once ml_v_vals'_cases]
-                >> simp[INT_ADD_COMM]
-              )
-              >> simp[Ntimes evaluate_def 3, do_app_def, do_opapp_def, dec_clock_def]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def, do_con_check_def, build_conv_def]
-              >> irule_at (Pos hd) EQ_REFL
-              >> last_assum $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases, sadd_def,
-                env_rel_cases, FEVERY_FEMPTY]
-            )
-            >> qpat_assum ‘ml_v_vals' h1 h2’ $ assume_tac o SRULE [Once ml_v_vals'_cases]
-            >> gvs[REVERSE_SNOC, vcons_list_def]
-            >~ [‘SNum m’] >- (
-              simp[evaluate_def, do_opapp_def, do_app_def,
-                opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
-              >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-              >> qrefine ‘ck+3’
-              >> simp[Ntimes evaluate_def 2]
-              >> simp[sadd_def]
-              >> ‘∀ ck . st with <|clock:=ck;refs:=st.refs;ffi:=st.ffi|> = st with clock:=ck’
-                by (simp[state_component_equality])
-              >> simp[]
-              >> pop_assum kall_tac
-              >> pop_assum $ qspec_then ‘n + m’ mp_tac
-              >> strip_tac
-              >> qpat_assum ‘evaluate _ _ _ = evaluate _ _ _’ $ irule_at (Pos hd)
-              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once INT_ADD_COMM]
-              >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
-            )
-            >> gvs[]
-            >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
-              opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+            >> irule preservation_of_sadd_body
+            >> simp[]
+            >> irule_at (Pos hd) EQ_REFL
+            >> irule $ cj 1 $ iffLR LIST_REL_APPEND
+            >> simp[]
+          )
+          >~ [‘"SMinus"’] >- (
+            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
             >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> simp[sadd_def, Once e_ce_rel_cases]
+            >> qrefine ‘ck+4’
+            >> simp[Ntimes evaluate_def 3]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+              same_type_def, same_ctor_def, evaluate_match_def,
+              pat_bindings_def]
+            >> irule preservation_of_sminus_body
+            >> simp[]
+            >> simp[scheme_env3_def, scheme_env2_def]
             >> irule_at (Pos hd) EQ_REFL
-            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-            >> simp[env_rel_cases, FEVERY_FEMPTY]
+            >> irule $ cj 1 $ iffLR LIST_REL_APPEND
+            >> simp[]
           )
           >~ [‘"Proc"’] >- (
             qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]

From 8109c1143d9579e261b4fde15bcfe61d2334d64f Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 19 Apr 2025 15:10:21 +0100
Subject: [PATCH 086/100] step preservation proof complete!

---
 .../proofs/scheme_to_cakeProofScript.sml      | 618 ++++++++++--------
 1 file changed, 357 insertions(+), 261 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 249183ba9c..34a3203dae 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -649,6 +649,85 @@ Proof
   >> simp[env_rel_cases, FEVERY_FEMPTY]
 QED
 
+Theorem preservation_of_smul_body:
+  ∀ vs mlvs .
+    LIST_REL ml_v_vals' vs mlvs
+    ⇒
+  ∀ store st env n k kv i .
+    cont_rel k kv ∧
+    LIST_REL store_entry_rel store st.refs ∧
+    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
+    nsLookup env.v (Short "k") = SOME kv ∧
+    nsLookup env.v (Short "smul") = nsLookup scheme_env3.v (Short "smul") ∧
+    env.c = scheme_env1.c ∧
+    i > 0
+    ⇒
+    ∃ck st' mlenv' var' kv' mle'.
+      evaluate (st with clock := ck) env
+        [Mat (Var (Short "xs"))
+           [(Pcon (SOME (Short "[]")) [],
+             Let (SOME "v") (Con (SOME (Short "SNum")) [Var (Short "n")])
+               (App Opapp [Var (Short "k"); Var (Short "v")]));
+            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
+             Mat (Var (Short "x"))
+               [(Pcon (SOME (Short "SNum")) [Pvar "xn"],
+                 App Opapp
+                   [App Opapp
+                      [App Opapp [Var (Short "smul"); Var (Short "k")];
+                       App (Opn Times) [Var (Short "n"); Var (Short "xn")]];
+                    Var (Short "xs'")]);
+                (Pany,
+                 Con (SOME (Short "Ex"))
+                   [Lit (StrLit "Arith-op applied to non-number")])])]] =
+      evaluate st' mlenv' [mle'] ∧
+      cont_rel k kv' ∧
+      e_ce_rel (smul vs n) var' mlenv' kv' mle' ∧
+      env_rel FEMPTY mlenv' ∧
+      LIST_REL store_entry_rel store st'.refs ∧
+      st'.clock ≤ ck + i ∧
+      st'.clock < ck + i
+Proof
+  ho_match_mp_tac LIST_REL_ind
+  >> simp[vcons_list_def, smul_def]
+  >> rpt strip_tac >- (
+    simp[Ntimes evaluate_def 2]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
+      nsOptBind_def]
+    >> irule_at (Pos hd) EQ_REFL
+    >> last_assum $ irule_at (Pos hd)
+    >> simp[Once e_ce_rel_cases, smul_def, Once ml_v_vals'_cases,
+      env_rel_cases, FEVERY_FEMPTY]
+  )
+  >> gvs[Once ml_v_vals'_cases]
+  >> gvs[vcons_list_def]
+  >~ [‘SNum m’] >- (
+    simp[smul_def]
+    >> simp[evaluate_def, do_opapp_def, do_app_def,
+      opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+    >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+    >> qrefine ‘ck+3’
+    >> simp[Ntimes evaluate_def 2]
+    >> last_x_assum irule
+    >> simp[]
+    >> simp[scheme_env2_def, Once INT_MUL_COMM]
+  )
+  >> simp[Ntimes evaluate_def 10, do_opapp_def, do_app_def,
+    opn_lookup_def, can_pmatch_all_def, pmatch_def, nsLookup_def,
+    same_type_def, same_ctor_def, evaluate_match_def,
+    pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
+  >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+  >> simp[smul_def, Once e_ce_rel_cases]
+  >> irule_at (Pos hd) EQ_REFL
+  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+  >> simp[env_rel_cases, FEVERY_FEMPTY]
+QED
+
 Theorem preservation_of_sminus_body:
   ∀ vs mlvs .
     LIST_REL ml_v_vals' vs mlvs
@@ -1641,322 +1720,339 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[evaluate_def, do_con_check_def,
         build_conv_def, do_opapp_def, dec_clock_def]
-      >> qsuff_tac ‘scheme_env env'' ∧ ¬ MEM t' vconses ⇒ scheme_env (env'' with v:= nsBind t'
-        mlv env''.v)’
-      >- (
-        simp[] >> strip_tac
-        >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
-        env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
-          strip_tac
-          >> drule_all_then assume_tac cons_list_val
-          >> gvs[Once ml_v_vals'_cases]
-          >> gvs[application_def]
-          >~ [‘"SAdd"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+3’
-            >> simp[Ntimes evaluate_def 3]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> simp[Ntimes evaluate_def 3]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes evaluate_def 7, do_opapp_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+2’
-            >> simp[Ntimes evaluate_def 2, dec_clock_def]
-            >> irule preservation_of_sadd_body
-            >> simp[]
-            >> irule_at (Pos hd) EQ_REFL
-            >> irule $ cj 1 $ iffLR LIST_REL_APPEND
-            >> simp[]
-          )
-          >~ [‘"SMinus"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+4’
-            >> simp[Ntimes evaluate_def 3]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> irule preservation_of_sminus_body
-            >> simp[]
-            >> simp[scheme_env3_def, scheme_env2_def]
-            >> irule_at (Pos hd) EQ_REFL
-            >> irule $ cj 1 $ iffLR LIST_REL_APPEND
-            >> simp[]
-          )
-          >~ [‘"Proc"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+3’
-            >> simp[Ntimes evaluate_def 3]
+      >> ‘scheme_env (env'' with v:= nsBind t' mlv env''.v)’ by gvs[scheme_env_def]
+      >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
+      env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
+        strip_tac
+        >> drule_all_then assume_tac cons_list_val
+        >> gvs[Once ml_v_vals'_cases]
+        >> gvs[application_def]
+        >> qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
+        >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+        >~ [‘Prim SAdd’] >- (
+          qrefine ‘ck+3’
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes evaluate_def 7, do_opapp_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> qrefine ‘ck+2’
+          >> simp[Ntimes evaluate_def 2, dec_clock_def]
+          >> irule preservation_of_sadd_body
+          >> simp[]
+          >> irule_at (Pos hd) EQ_REFL
+          >> irule $ cj 1 $ iffLR LIST_REL_APPEND
+          >> simp[]
+        )
+        >~ [‘Prim SMul’] >- (
+          qrefine ‘ck+3’
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes evaluate_def 7, do_opapp_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> qrefine ‘ck+2’
+          >> simp[Ntimes evaluate_def 2, dec_clock_def]
+          >> irule preservation_of_smul_body
+          >> simp[]
+          >> simp[scheme_env2_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> irule $ cj 1 $ iffLR LIST_REL_APPEND
+          >> simp[]
+        )
+        >~ [‘Prim SMinus’] >- (
+          qrefine ‘ck+4’
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> irule preservation_of_sminus_body
+          >> simp[]
+          >> simp[scheme_env3_def, scheme_env2_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> irule $ cj 1 $ iffLR LIST_REL_APPEND
+          >> simp[]
+        )
+        >~ [‘Proc _ _ _ _’] >- (
+          qrefine ‘ck+3’
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> qrefine ‘ck+1’
+          >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+          >> rpt (pairarg_tac >> gvs[])
+          >> irule preservation_of_proc
+          >> simp[]
+          >> qpat_assum ‘scheme_env env'³'’ $ simp
+            o curry ((::) o swap) [scheme_env_def]
+            o SRULE [scheme_env_def]
+          >> first_assum $ irule_at Any o GSYM
+          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+          >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
+          >> simp[]
+          >> irule_at (Pos hd) EQ_REFL
+          >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
+          >> irule_at (Pos last) $ cj 1 $ iffLR LIST_REL_APPEND
+          >> simp[]
+          >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
+          >> strip_tac
+          >> simp[]
+          >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> strip_tac
+          >> simp[]
+          >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
+          >> strip_tac
+          >> gvs[env_rel_cases]
+        )
+        >~ [‘Prim SEqv’] >- (
+          qrefine ‘ck+4’
+          >> simp[Ntimes evaluate_def 3]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> Cases_on ‘vs’ using SNOC_CASES
+          >> gvs[vcons_list_def, seqv_def] >- (
+            simp[Ntimes evaluate_def 8]
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
-            >> qrefine ‘ck+1’
-            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
-            >> rpt (pairarg_tac >> gvs[])
-            >> irule preservation_of_proc
-            >> simp[]
-            >> qpat_assum ‘scheme_env env'³'’ $ simp
-              o curry ((::) o swap) [scheme_env_def]
-              o SRULE [scheme_env_def]
-            >> first_assum $ irule_at Any o GSYM
-            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
-            >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
-            >> simp[]
             >> irule_at (Pos hd) EQ_REFL
-            >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
-            >> irule_at (Pos last) $ cj 1 $ iffLR LIST_REL_APPEND
-            >> simp[]
-            >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
-            >> strip_tac
-            >> simp[]
-            >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
-            >> strip_tac
-            >> simp[]
-            >> qpat_x_assum ‘valid_val _ (Proc _ _ _ _)’ $ mp_tac o SRULE [Once valid_val_cases]
-            >> strip_tac
-            >> gvs[env_rel_cases]
+            >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
           )
-          >~ [‘"SEqv"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+4’
-            >> simp[Ntimes evaluate_def 3]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> Cases_on ‘vs’ using SNOC_CASES
-            >> gvs[vcons_list_def, seqv_def] >- (
-              simp[Ntimes evaluate_def 8]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> irule_at (Pos hd) EQ_REFL
-              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
-            )
-            >> Cases_on ‘mlvs’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> simp[Ntimes evaluate_def 5]
+          >> Cases_on ‘mlvs’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> simp[Ntimes evaluate_def 5]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> Cases_on ‘l’ using SNOC_CASES
+          >> gvs[vcons_list_def, seqv_def] >- (
+            simp[Ntimes evaluate_def 8]
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
-            >> Cases_on ‘l’ using SNOC_CASES
-            >> gvs[vcons_list_def, seqv_def] >- (
-              simp[Ntimes evaluate_def 8]
+            >> Cases_on ‘∃ n . x = SNum n’ >- (
+              gvs[Once ml_v_vals'_cases]
+              >> simp[Ntimes evaluate_def 8]
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> Cases_on ‘∃ n . x = SNum n’ >- (
+                pat_bindings_def, do_con_check_def, build_conv_def]
+              >> Cases_on ‘∃ m . v = SNum m’ >- (
                 gvs[Once ml_v_vals'_cases]
-                >> simp[Ntimes evaluate_def 8]
-                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def]
-                >> Cases_on ‘∃ m . v = SNum m’ >- (
-                  gvs[Once ml_v_vals'_cases]
-                  >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
-                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                    same_type_def, same_ctor_def, evaluate_match_def,
-                    pat_bindings_def, do_con_check_def, build_conv_def,
-                    do_eq_def, lit_same_type_def]
-                  >> irule_at (Pos hd) EQ_REFL
-                  >> simp[env_rel_cases, FEVERY_FEMPTY]
-                  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-                  >> Cases_on ‘i=i'’
-                  >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
-                    Boolv_def, bool_type_num_def]
-                )
-                >> Cases_on ‘v’
-                >> gvs[Once ml_v_vals'_cases]
-                >> simp[Ntimes evaluate_def 8, nsOptBind_def]
+                >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
                 >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def]
+                  pat_bindings_def, do_con_check_def, build_conv_def,
+                  do_eq_def, lit_same_type_def]
                 >> irule_at (Pos hd) EQ_REFL
                 >> simp[env_rel_cases, FEVERY_FEMPTY]
                 >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+                >> Cases_on ‘i=i'’
                 >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
                   Boolv_def, bool_type_num_def]
               )
-              >> Cases_on ‘∃ b . x = SBool b’ >- (
+              >> Cases_on ‘v’
+              >> gvs[Once ml_v_vals'_cases]
+              >> simp[Ntimes evaluate_def 8, nsOptBind_def]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def, do_con_check_def, build_conv_def]
+              >> irule_at (Pos hd) EQ_REFL
+              >> simp[env_rel_cases, FEVERY_FEMPTY]
+              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+              >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                Boolv_def, bool_type_num_def]
+            )
+            >> Cases_on ‘∃ b . x = SBool b’ >- (
+              gvs[Once ml_v_vals'_cases]
+              >> simp[Ntimes evaluate_def 8]
+              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+                same_type_def, same_ctor_def, evaluate_match_def,
+                pat_bindings_def, do_con_check_def, build_conv_def]
+              >> (Cases_on ‘∃ b' . v = SBool b'’ >- (
                 gvs[Once ml_v_vals'_cases]
-                >> simp[Ntimes evaluate_def 8]
+                >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
                 >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                   same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def]
-                >> (Cases_on ‘∃ b' . v = SBool b'’ >- (
-                  gvs[Once ml_v_vals'_cases]
-                  >> simp[Ntimes evaluate_def 11, nsOptBind_def, do_app_def]
-                  >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                    same_type_def, same_ctor_def, evaluate_match_def,
-                    pat_bindings_def, do_con_check_def, build_conv_def,
-                    do_eq_def, lit_same_type_def, ctor_same_type_def]
-                  >> irule_at (Pos hd) EQ_REFL
-                  >> simp[env_rel_cases, FEVERY_FEMPTY]
-                  >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-                  >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
-                    Boolv_def, bool_type_num_def]
-                ))
-                >> Cases_on ‘v’ >> gvs[]
-                >> gvs[Once ml_v_vals'_cases]
-                >> simp[Ntimes evaluate_def 8, nsOptBind_def]
-                >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                  same_type_def, same_ctor_def, evaluate_match_def,
-                  pat_bindings_def, do_con_check_def, build_conv_def]
+                  pat_bindings_def, do_con_check_def, build_conv_def,
+                  do_eq_def, lit_same_type_def, ctor_same_type_def]
                 >> irule_at (Pos hd) EQ_REFL
                 >> simp[env_rel_cases, FEVERY_FEMPTY]
                 >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
                 >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
                   Boolv_def, bool_type_num_def]
-              )
-              >> Cases_on ‘x’ >> gvs[]
+              ))
+              >> Cases_on ‘v’ >> gvs[]
               >> gvs[Once ml_v_vals'_cases]
-              >> simp[Ntimes evaluate_def 9, nsOptBind_def]
+              >> simp[Ntimes evaluate_def 8, nsOptBind_def]
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def, do_con_check_def, build_conv_def]
               >> irule_at (Pos hd) EQ_REFL
               >> simp[env_rel_cases, FEVERY_FEMPTY]
               >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
+              >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
+                Boolv_def, bool_type_num_def]
             )
-            >> Cases_on ‘l'’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> Cases_on ‘l''’ using SNOC_CASES
-            >> Cases_on ‘l’ using SNOC_CASES
-            >> gvs[vcons_list_def, seqv_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> simp[Ntimes evaluate_def 8]
+            >> Cases_on ‘x’ >> gvs[]
+            >> gvs[Once ml_v_vals'_cases]
+            >> simp[Ntimes evaluate_def 9, nsOptBind_def]
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
+              pat_bindings_def, do_con_check_def, build_conv_def]
             >> irule_at (Pos hd) EQ_REFL
+            >> simp[env_rel_cases, FEVERY_FEMPTY]
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+            >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
           )
-          >~ [‘"CallCC"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+4’
-            >> simp[Ntimes evaluate_def 5]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> simp[Ntimes evaluate_def 4, do_opapp_def]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> simp[Ntimes evaluate_def 1, do_opapp_def, dec_clock_def]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> Cases_on ‘vs’ using SNOC_CASES
-            >> gvs[vcons_list_def] >- (
-              simp[Ntimes evaluate_def 8]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> simp[Ntimes evaluate_def 5, do_con_check_def, build_conv_def,
-                nsOptBind_def]
-              >> irule_at (Pos hd) EQ_REFL
-              >> simp[env_rel_cases, FEVERY_FEMPTY]
-              >> simp[Once cont_rel_cases]
-              >> gvs[cps_transform_def, cps_app_ts_def]
-              >> irule_at (Pos hd) EQ_REFL
-              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases]
-              >> simp[Once ml_v_vals'_cases]
-              >> simp[cons_list_def]
-              >> simp[scheme_env_def, env_rel_cases, FEVERY_FEMPTY]
-            )
-            >> Cases_on ‘mlvs’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> Cases_on ‘l’ using SNOC_CASES
-            >> Cases_on ‘l'’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> simp[Ntimes evaluate_def 8]
+          >> Cases_on ‘l'’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> Cases_on ‘l''’ using SNOC_CASES
+          >> Cases_on ‘l’ using SNOC_CASES
+          >> gvs[vcons_list_def, seqv_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> simp[Ntimes evaluate_def 8]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+          >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+        )
+        >~ [‘Prim CallCC’] >- (
+          qrefine ‘ck+4’
+          >> simp[Ntimes evaluate_def 5]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 4, do_opapp_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 1, do_opapp_def, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> Cases_on ‘vs’ using SNOC_CASES
+          >> gvs[vcons_list_def] >- (
+            simp[Ntimes evaluate_def 8]
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
+            >> simp[Ntimes evaluate_def 5, do_con_check_def, build_conv_def,
+              nsOptBind_def]
+            >> irule_at (Pos hd) EQ_REFL
+            >> simp[env_rel_cases, FEVERY_FEMPTY]
+            >> simp[Once cont_rel_cases]
+            >> gvs[cps_transform_def, cps_app_ts_def]
             >> irule_at (Pos hd) EQ_REFL
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+            >> simp[Once e_ce_rel_cases]
+            >> simp[Once ml_v_vals'_cases]
+            >> simp[cons_list_def]
+            >> simp[scheme_env_def, env_rel_cases, FEVERY_FEMPTY]
           )
-          >~ [‘"Throw"’] >- (
-            qpat_assum ‘scheme_env env''’ $ simp o single o SRULE [scheme_env_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> qrefine ‘ck+4’
-            >> simp[Ntimes evaluate_def 5]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
-            >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-              same_type_def, same_ctor_def, evaluate_match_def,
-              pat_bindings_def]
-            >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
-            >> Cases_on ‘vs’ using SNOC_CASES
-            >> gvs[vcons_list_def] >- (
-              simp[Ntimes evaluate_def 8]
-              >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
-                same_type_def, same_ctor_def, evaluate_match_def,
-                pat_bindings_def]
-              >> irule_at (Pos hd) EQ_REFL
-              >> simp[env_rel_cases, FEVERY_FEMPTY]
-              >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-              >> simp[Once e_ce_rel_cases]
-            )
-            >> Cases_on ‘mlvs’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> Cases_on ‘l’ using SNOC_CASES
-            >> Cases_on ‘l'’ using SNOC_CASES
-            >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
-            >> simp[Ntimes evaluate_def 8]
+          >> Cases_on ‘mlvs’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> Cases_on ‘l’ using SNOC_CASES
+          >> Cases_on ‘l'’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> simp[Ntimes evaluate_def 8]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+          >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+        )
+        >~ [‘Throw _’] >- (
+          qrefine ‘ck+4’
+          >> simp[Ntimes evaluate_def 5]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> simp[Ntimes evaluate_def 5, do_opapp_def, dec_clock_def]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+          >> Cases_on ‘vs’ using SNOC_CASES
+          >> gvs[vcons_list_def] >- (
+            simp[Ntimes evaluate_def 8]
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
             >> irule_at (Pos hd) EQ_REFL
+            >> simp[env_rel_cases, FEVERY_FEMPTY]
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-            >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
+            >> simp[Once e_ce_rel_cases]
           )
-          >> cheat
-        )
-        >> simp[]
-        >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
-          strip_tac
-          >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
-          >> drule_then assume_tac EVERY2_LENGTH
-          >> rev_drule_all $ iffRL EVERY2_EVERY
-          >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
-          >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
-          >> ho_match_mp_tac EVERY2_mono
-          >> simp[]
+          >> Cases_on ‘mlvs’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> Cases_on ‘l’ using SNOC_CASES
+          >> Cases_on ‘l'’ using SNOC_CASES
+          >> gvs[vcons_list_def, LIST_REL_SNOC, REVERSE_SNOC]
+          >> simp[Ntimes evaluate_def 8]
+          >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+            same_type_def, same_ctor_def, evaluate_match_def,
+            pat_bindings_def]
+          >> irule_at (Pos hd) EQ_REFL
+          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+          >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
         )
-        >> simp[EVERY_MEM] >> PairCases >> simp[]
+        >> qrefine ‘ck+3’
+        >> simp[Ntimes evaluate_def 5]
+        >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+          same_type_def, same_ctor_def, evaluate_match_def,
+          pat_bindings_def]
+        >> simp[Once evaluate_def, do_opapp_def, dec_clock_def,
+          do_con_check_def, build_conv_def]
+        >> irule_at (Pos hd) EQ_REFL
+        >> simp[env_rel_cases, FEVERY_FEMPTY]
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases]
+      )
+      >> simp[]
+      >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
+        strip_tac
         >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
-        >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
-        >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
-        >> strip_tac >> gvs[]
+        >> drule_then assume_tac EVERY2_LENGTH
+        >> rev_drule_all $ iffRL EVERY2_EVERY
+        >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
+        >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
+        >> ho_match_mp_tac EVERY2_mono
+        >> simp[]
       )
-      >> gvs[scheme_env_def]
+      >> simp[EVERY_MEM] >> PairCases >> simp[]
+      >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
+      >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
+      >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
+      >> strip_tac >> gvs[]
     )
     >> Cases_on ‘h1’ >> gvs[]
     >> Cases_on ‘l’ >> gvs[]

From 0806243e69a01084d09d8d054cfb9a36130f41b2 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Sat, 19 Apr 2025 18:30:27 +0100
Subject: [PATCH 087/100] attempt at multistep

---
 .../proofs/scheme_to_cakeProofScript.sml      | 74 ++++++++++++++++++-
 1 file changed, 73 insertions(+), 1 deletion(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 34a3203dae..290a92af9c 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -1209,7 +1209,7 @@ QED
 
 Theorem step_preservation:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
-  step  (store, k, env, e) = (store', k', env', e') ∧
+  step (store, k, env, e) = (store', k', env', e') ∧
   valid_state store k env e ∧
   cont_rel k kv ∧
   e_ce_rel e var mlenv kv mle ∧
@@ -2061,6 +2061,78 @@ Proof
   )
 QED
 
+Theorem steps_preservation:
+  ∀ n store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
+  FUNPOW step n (store, k, env, e) = (store', k', env', e') ∧
+  valid_state store k env e ∧
+  cont_rel k kv ∧
+  e_ce_rel e var mlenv kv mle ∧
+  env_rel env mlenv ∧
+  LIST_REL store_entry_rel store st.refs
+  ⇒
+  ∃ ck st' mlenv' var' kv' mle' .
+    evaluate (st with clock:=ck) mlenv [mle]
+    =
+    evaluate st' mlenv' [mle'] ∧
+    cont_rel k' kv' ∧
+    e_ce_rel e' var' mlenv' kv' mle' ∧
+    env_rel env' mlenv' ∧
+    LIST_REL store_entry_rel store' st'.refs ∧
+    st'.clock ≤ ck ∧
+    (n > 0 ∧ k ≠ [] ∧ (∀ s . e ≠ Exception s) ⇒ st'.clock < ck)
+Proof
+  Induct >- (
+    simp[]
+    >> rpt strip_tac
+    >> irule_at (Pos hd) EQ_REFL
+    >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+    >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
+    >> simp[]
+  )
+  >> simp[FUNPOW]
+  >> rpt strip_tac
+  >> drule valid_state_progress
+  >> rpt strip_tac
+  >> gvs[]
+  >> last_x_assum $ drule_then assume_tac
+  >> pop_assum $ drule_then assume_tac
+  >> drule_all step_preservation
+  >> rpt strip_tac
+  >> qpat_assum ‘∀ _ _ _ _ _ . _ ⇒ _’ drule_all
+  >> rpt strip_tac
+  >> simp[]
+  >> gvs[]
+QED
+
+Theorem value_terminating:
+  ∀ n e v mle mlv store store' ks env (st:'ffi state) mlenv var kv .
+    FUNPOW step n (store, ks, env, e) = (store', [], FEMPTY, Val v) ∧
+    valid_state store ks env e ∧
+    e_ce_rel e var mlenv kv mle ∧
+    cont_rel ks kv ∧
+    env_rel env mlenv ∧
+    LIST_REL store_entry_rel store st.refs
+    ⇒
+    ∃ ck st' mlv . evaluate (st with clock:=ck) mlenv [mle]
+      = (st', Rval [mlv]) ∧
+    ml_v_vals' v mlv
+Proof
+  Induct_on ‘n’
+  >> simp[FUNPOW]
+  >> rpt strip_tac >- (
+    gvs[Once e_ce_rel_cases, Once cont_rel_cases]
+    >> qrefine ‘ck+1’
+    >> simp[evaluate_def, do_opapp_def]
+  )
+  >> drule valid_state_progress
+  >> strip_tac
+  >> gvs[]
+  >> drule_all step_preservation
+  >> strip_tac
+  >> last_x_assum $ drule_all
+  >> strip_tac
+QED
+
 (*Theorem val_correct:
   ∀ n . ∃ k . SND (evaluate <| clock := k |> myEnv [scheme_program_to_cake (Val (SNum n))])
     = Rval [Conv (SOME $ TypeStamp "SNum" 0) [Litv $ IntLit n]]

From c07add3dba83bf77497f19feed2425ae393a0227 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Mon, 21 Apr 2025 17:29:23 +0100
Subject: [PATCH 088/100] simplified arg names

---
 .../proofs/scheme_to_cakeProofScript.sml      | 574 +++++++-----------
 compiler/scheme/scheme_to_cakeScript.sml      | 160 +++--
 2 files changed, 280 insertions(+), 454 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 290a92af9c..0ad6db2375 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -19,7 +19,7 @@ open integerTheory;
 
 val _ = new_theory "scheme_to_cakeProof";
 
-val _ = (max_print_depth := 50);
+val _ = (max_print_depth := 30);
 
 Theorem scheme_env1_def[allow_rebind, compute] = EVAL_RULE $ zDefine ‘
   scheme_env1 = case evaluate_decs
@@ -262,13 +262,12 @@ Theorem vcons_list_def[allow_rebind] = SRULE [] $ Define ‘
 ’;
 
 Definition cps_app_ts_def:
-  cps_app_ts n (e::es) = (let
-    (m, ce) = cps_transform n e;
-    t = "t" ++ toString m
+  cps_app_ts (v::vs) = (let
+    (t, ts) = cps_app_ts vs
   in
-    t :: cps_app_ts (m+1) es) ∧
+    ("t" ++ toString (SUC (LENGTH ts)), t::ts)) ∧
 
-  cps_app_ts n [] = []
+  cps_app_ts [] = ("t0", [])
 End
 
 Inductive val_cont_rels:
@@ -302,14 +301,12 @@ Inductive val_cont_rels:
 [~Proc:]
   scheme_env env ∧
   env_rel se env ∧
-  (m, ce) = cps_transform n e ∧
-  args = "xs" ++ toString m ∧
-  k = "k" ++ toString (m+1) ∧
-  (l, inner) = proc_ml (m+2) xs xp k args ce
+  ce = cps_transform e ∧
+  inner = proc_ml xs xp "k" ce
   ⇒
   ml_v_vals' (Proc se xs xp e) $
     Conv (SOME (scheme_typestamp "Proc")) [
-      Closure env k $ Fun args inner
+      Closure env "k" $ Fun "xs" inner
     ]
 [~Throw:]
   cont_rel ks kv
@@ -323,101 +320,66 @@ Inductive val_cont_rels:
     Conv (SOME (scheme_typestamp "SList")) [vcons_list mlvs]
 
 [~Id:]
-  scheme_env env ∧
-  ¬ MEM t vconses
+  scheme_env env
   ⇒
   cont_rel []
-    (Closure env t (Var (Short t)))
+    (Closure env "t" (Var (Short "t")))
 [~CondK:]
   cont_rel ks kv ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  (n', ct) = cps_transform n te ∧
-  (m', cf) = cps_transform m fe ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  ct = cps_transform te ∧
+  cf = cps_transform fe ∧
   scheme_env env ∧
-  env_rel se env ∧
-  ¬ MEM var vconses ∧
-  ¬ MEM t vconses ∧
-  (∀ x . t ≠ "var" ++ x) ∧
-  var ≠ t
+  env_rel se env
   ⇒
   cont_rel ((se, CondK te fe) :: ks)
-    (Closure env t $ Mat (Var (Short t)) [
+    (Closure env "t" $ Mat (Var (Short "t")) [
       (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
-        App Opapp [cf; Var (Short var)]);
-      (Pany, App Opapp [ct;  Var (Short var)])
+        App Opapp [cf; Var (Short "k")]);
+      (Pany, App Opapp [ct;  Var (Short "k")])
     ])
 [~ApplyK_NONE:]
   cont_rel ks kv ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  (m, inner) = cps_transform_app n (Var (Short t)) [] es (Var (Short var)) ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  inner = cps_transform_app (Var (Short "t")) [] es (Var (Short "k")) ∧
   scheme_env env ∧
-  env_rel se env ∧
-  ¬ MEM var vconses ∧
-  ¬ MEM t vconses ∧
-  ts = cps_app_ts n es ∧
-  ¬ MEM var ts ∧
-  ¬ MEM t ts ∧
-  (∀ x . t ≠ "var" ++ x) ∧
-  var ≠ t
+  env_rel se env
   ⇒
   cont_rel ((se, ApplyK NONE es) :: ks)
-    (Closure env t $ inner)
+    (Closure env "t" $ inner)
 [~ApplyK_SOME:]
   cont_rel ks kv ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  (m, inner) = cps_transform_app n (Var (Short fnt))
-    (Var (Short t) :: MAP (Var o Short) ts) es (Var (Short var)) ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  (t, ts) = cps_app_ts vs ∧
+  inner = cps_transform_app (Var (Short "t"))
+    (Var (Short t) :: MAP (Var o Short) ts) es (Var (Short "k")) ∧
   ml_v_vals' fn mlfn ∧
-  nsLookup env.v (Short fnt) = SOME mlfn ∧
+  nsLookup env.v (Short "t") = SOME mlfn ∧
   LIST_REL ml_v_vals' vs mlvs ∧
   LIST_REL (λ x mlv . nsLookup env.v (Short x) = SOME mlv) ts mlvs ∧
   scheme_env env ∧
-  env_rel se env ∧
-  ALL_DISTINCT ts ∧
-  ¬ MEM var vconses ∧
-  ¬ MEM fnt vconses ∧
-  ¬ MEM t vconses ∧
-  EVERY (λ x . ¬ MEM x vconses) ts ∧
-  ¬ MEM var ts ∧
-  ¬ MEM fnt ts ∧
-  ¬ MEM t ts ∧
-  ts' = cps_app_ts n es ∧
-  EVERY (λ x . ¬ MEM x ts') ts ∧
-  ¬ MEM var ts' ∧
-  ¬ MEM fnt ts' ∧
-  ¬ MEM t ts' ∧
-  (∀ x . t ≠ "var" ++ x) ∧
-  var ≠ fnt ∧
-  var ≠ t ∧
-  fnt ≠ t
+  env_rel se env
   ⇒
   cont_rel ((se, ApplyK (SOME (fn, vs)) es) :: ks)
     (Closure env t $ inner)
 [~BeginK:]
   cont_rel ks kv ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  (m, inner) = cps_transform_seq n (Var (Short var)) es e ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  inner = cps_transform_seq (Var (Short "k")) es e ∧
   scheme_env env ∧
-  env_rel se env ∧
-  ¬ MEM var vconses ∧
-  var ≠ "_"
+  env_rel se env
   ⇒
   cont_rel ((se, BeginK es e) :: ks)
     (Closure env "_" $ inner)
 [~SetK:]
   cont_rel ks kv ∧
-  nsLookup env.v (Short var) = SOME kv ∧
-  (m, inner) = refunc_set n (Var (Short t)) (Var (Short var)) x ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  inner = refunc_set (Var (Short "t")) (Var (Short "k")) x ∧
   scheme_env env ∧
-  env_rel se env ∧
-  ¬ MEM var vconses ∧
-  ¬ MEM t vconses ∧
-  (∀ x . t ≠ "var" ++ x) ∧
-  var ≠ "v" ∧
-  var ≠ t
+  env_rel se env
   ⇒
   cont_rel ((se, SetK x) :: ks)
-    (Closure env t $ inner)
+    (Closure env "t" $ inner)
 End
 
 Theorem val_cont_rels_ind[allow_rebind] = SRULE [] $ val_cont_rels_ind;
@@ -441,7 +403,7 @@ Inductive e_ce_rel:
   ⇒
   e_ce_rel (Val v) var env kv $ App Opapp [Var (Short var); Var (Short valv)]
 [~Exp:]
-  (m, ce) = cps_transform n e ∧
+  ce = cps_transform e ∧
   nsLookup env.v (Short var) = SOME kv ∧
   scheme_env env
   ⇒
@@ -464,10 +426,9 @@ Proof
   >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
   >> simp[Ntimes evaluate_def 2, nsOptBind_def]
-  >> irule_at (Pos hd) EQ_REFL
-  >> irule_at Any EQ_REFL
-  >> pop_assum $ irule_at (Pos hd) o GSYM
-  >> simp[nsLookup_def, Once cont_rel_cases]
+  >> irule_at (Pos last) EQ_REFL
+  >> simp[]
+  >> simp[Once cont_rel_cases]
   >> gvs[scheme_env_def]
   >> metis_tac[]
 QED
@@ -477,56 +438,50 @@ open scheme_to_cakeProofTheory;
 open scheme_parsingTheory;
 *)
 
-Theorem str_not_num:
-  ∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str
-Proof
-  simp[EVERY_isDigit_num_to_dec_string]
-QED
-
-Theorem k_in_ts:
-  ∀ es (n:num) m . ¬ MEM (STRING #"k" (toString n)) (cps_app_ts m es)
+Theorem cps_app_ts_res:
+  ∀ t ts vs .
+    (t, ts) = cps_app_ts vs
+    ⇒
+    t = "t" ++ toString (LENGTH ts) ∧
+    (∀ n:num . n ≥ LENGTH ts ⇒ ¬ MEM ("t" ++ toString n) ts) ∧
+    LENGTH vs = LENGTH ts
 Proof
-  Induct
+  Induct_on ‘vs’
   >> simp[cps_app_ts_def]
-  >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
 QED
 
-Theorem mono_proc_ml_on_n:
-  ∀ xs xp n k args ce m ce' .
-    (m, ce') = proc_ml n xs xp k args ce ⇒ m ≥ n
-Proof
-  Induct >> Cases
-  >> simp[proc_ml_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> last_x_assum $ dxrule o GSYM
-  >> simp[]
-QED
-
-Theorem mono_cps_on_n:
-  (∀ n e m ce . (m, ce) = cps_transform n e ⇒ m ≥ n) ∧
-  (∀ n fn ts es k m ce . (m, ce) = cps_transform_app n fn ts es k ⇒ m ≥ n) ∧
-  (∀ n k es e m ce . (m, ce) = cps_transform_seq n k es e ⇒ m ≥ n)
+Theorem str_not_num:
+  ∀ (n:num) str . ¬ EVERY isDigit str ⇒ toString n ≠ str
 Proof
-  ho_match_mp_tac $ cps_transform_ind
-  >> simp[cps_transform_def, refunc_set_def]
-  >> rpt strip_tac
-  >> rpt (pairarg_tac >> gvs[])
-  >> dxrule $ GSYM mono_proc_ml_on_n
-  >> simp[]
+  simp[EVERY_isDigit_num_to_dec_string]
 QED
 
-Theorem t_in_ts:
-  ∀ es n m . m > n ⇒ ¬ MEM (STRING #"t" (toString n)) (cps_app_ts m es)
+Theorem cps_app_ts_distinct:
+  ∀ t ts vs .
+    (t, ts) = cps_app_ts vs
+    ⇒
+    ¬ MEM t ts ∧
+    ALL_DISTINCT ts ∧
+    t ≠ "t" ∧
+    t ≠ "k" ∧
+    ¬ MEM "t" ts ∧
+    ¬ MEM "k" ts ∧
+    ¬ MEM t vconses ∧
+    EVERY (λ t. ¬ MEM t vconses) ts ∧
+    (∀ x . t ≠ "var" ++ x) ∧
+    EVERY (λ t. ∀ x . t ≠ "var" ++ x) ts
 Proof
-  Induct >> rpt strip_tac
-  >> gvs[cps_app_ts_def]
+  Induct_on ‘vs’
+  >> simp[cps_app_ts_def]
   >> rpt (pairarg_tac >> gvs[])
-  >> dxrule $ GSYM $ cj 1 mono_cps_on_n
-  >> simp[]
-  >> last_x_assum $ qspecl_then [‘n’, ‘m'+1’] mp_tac
+  >> drule_then mp_tac $ GSYM cps_app_ts_res
+  >> strip_tac
+  >> qpat_x_assum ‘_ = t’ $ assume_tac o GSYM
   >> simp[]
+  >> qpat_assum ‘∀ _ . _ ⇒ _’ $ irule_at (Pos hd) o SRULE []
+  >> irule_at (Pos last) str_not_num
+  >> simp[isDigit_def]
 QED
 
 Theorem cons_list_val:
@@ -913,21 +868,15 @@ Theorem preservation_of_proc:
   EVERY (valid_val store) vs ∧
   valid_cont store k ∧
   cont_rel k kv ∧
-  (n', ce) = cps_transform n e ∧
-  (m', inner) = proc_ml m xs xp var args ce ∧
+  ce = cps_transform e ∧
+  inner = proc_ml xs xp "k" ce ∧
   (store', env',e') = parameterize store env xs xp e vs ∧
   EVERY (OPTION_ALL (valid_val store)) store ∧
-  nsLookup mlenv.v (Short var) = SOME kv ∧
-  nsLookup mlenv.v (Short args) = SOME (vcons_list mlvs) ∧
+  nsLookup mlenv.v (Short "k") = SOME kv ∧
+  nsLookup mlenv.v (Short "xs") = SOME (vcons_list mlvs) ∧
   env_rel env mlenv ∧
   scheme_env mlenv ∧
   can_lookup env store ∧
-  ¬ MEM args vconses ∧
-  ¬ MEM var vconses ∧
-  var ≠ args ∧
-  (∀ s . var ≠ "var" ++ s) ∧
-  (∀ s . args ≠ "var" ++ s) ∧
-  (∀ s . var ≠ "x" ++ s) ∧
   LIST_REL store_entry_rel store st.refs ∧
   i > 0
   ⇒
@@ -957,7 +906,6 @@ Proof
         >> simp[same_type_def, same_ctor_def, pat_bindings_def]
         >> irule_at (Pos hd) EQ_REFL
         >> simp[Once e_ce_rel_cases]
-        >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
       )
       >> simp[Ntimes evaluate_def 3]
       >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
@@ -985,16 +933,11 @@ Proof
     >> simp[]
     >> rpt (pairarg_tac >> gvs[])
     >> gvs[fresh_loc_def, store_entry_rel_cases]
-    >> simp[Once ml_v_vals'_cases, vcons_list_def]
+    >> simp[Once ml_v_vals'_cases]
     >> simp[Once e_ce_rel_cases]
-    >> irule_at (Pos hd) EQ_REFL
-    >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
-    >> qpat_assum ‘scheme_env mlenv’ $ simp
-      o curry ((::) o swap) [scheme_env_def]
-      o SRULE [scheme_env_def]
-    >> irule_at (Pos $ el 2) EQ_REFL
+    >> irule_at Any EQ_REFL
     >> simp[]
-    >> gvs[env_rel_cases]
+    >> gvs[scheme_env_def, env_rel_cases]
     >> Cases_on ‘x ∈ FDOM env’ >- (
       simp[FEVERY_DEF]
       >> strip_tac
@@ -1036,95 +979,86 @@ Proof
   >> qpat_assum ‘scheme_env mlenv’ $ simp o single
     o SRULE [scheme_env_def]
   >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-  >> qsuff_tac ‘STRING #"s" (toString (m + 1)) ≠ toString m’ >- (
-    simp[]
-    >> strip_tac
-    >> simp[Ntimes evaluate_def 4, do_app_def, store_alloc_def]
-    >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
-      pmatch_def, do_con_check_def, build_conv_def, nsOptBind_def]
-    >> qpat_assum ‘scheme_env mlenv’ $ simp o single
-      o SRULE [scheme_env_def]
-    >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-    >> last_x_assum irule
-    >> qpat_assum ‘scheme_env mlenv’ $ simp
-      o curry ((::) o swap) [scheme_env_def]
-      o SRULE [scheme_env_def]
-    >> gvs[fresh_loc_def]
-    >> qpat_assum ‘LIST_REL _ t ys’ $ irule_at (Pos last)
-    >> irule_at (Pat ‘parameterize _ _ _ _ _ _ = parameterize _ _ _ _ _ _’) EQ_REFL
-    >> simp[SNOC_APPEND, store_entry_rel_cases]
-    >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
-    >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pat ‘_ = cps_transform _ _’)
-    >> qpat_assum ‘proc_ml _ _ _ _ _ _ = _’ $
-      irule_at (Pat ‘_ = proc_ml _ _ _ _ _ _’) o GSYM
+  >> simp[Ntimes evaluate_def 4, do_app_def, store_alloc_def]
+  >> simp[can_pmatch_all_def, evaluate_match_def, vcons_list_def,
+    pmatch_def, do_con_check_def, build_conv_def, nsOptBind_def]
+  >> qpat_assum ‘scheme_env mlenv’ $ simp o single
+    o SRULE [scheme_env_def]
+  >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+  >> last_x_assum irule
+  >> simp[]
+  >> rpt (pairarg_tac >> gvs[])
+  >> rpt $ irule_at Any EQ_REFL
+  >> simp[]
+  >> qpat_assum ‘scheme_env mlenv’ $ simp
+    o curry ((::) o swap) [scheme_env_def]
+    o SRULE [scheme_env_def]
+  >> gvs[fresh_loc_def]
+  >> simp[SNOC_APPEND, store_entry_rel_cases]
+  >> irule_at (Pos hd) EVERY_MONOTONIC
+  >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
+  >> strip_tac >- (
+    rpt strip_tac
+    >> irule OPTION_ALL_MONO
+    >> pop_assum $ irule_at (Pos last)
+    >> rpt strip_tac
+    >> irule valid_val_larger_store
+    >> pop_assum $ irule_at (Pos last)
     >> simp[]
-    >> irule_at (Pos hd) EVERY_MONOTONIC
-    >> qpat_assum ‘EVERY _ store’ $ irule_at (Pos $ el 2)
-    >> strip_tac >- (
-      rpt strip_tac
-      >> irule OPTION_ALL_MONO
-      >> pop_assum $ irule_at (Pos last)
-      >> rpt strip_tac
-      >> irule valid_val_larger_store
-      >> pop_assum $ irule_at (Pos last)
-      >> simp[]
-    )
-    >> irule_at (Pos hd) valid_val_larger_store
-    >> qpat_assum ‘valid_store _ h'’ $ irule_at (Pos $ el 2)
+  )
+  >> irule_at (Pos hd) valid_val_larger_store
+  >> qpat_assum ‘valid_store _ h'’ $ irule_at (Pos $ el 2)
+  >> simp[]
+  >> irule_at (Pos hd) EVERY_MONOTONIC
+  >> qpat_assum ‘EVERY _ t’ $ irule_at (Pos $ el 2)
+  >> strip_tac >- (
+    rpt strip_tac
+    >> irule valid_val_larger_store
+    >> pop_assum $ irule_at (Pos last)
     >> simp[]
-    >> irule_at (Pos hd) EVERY_MONOTONIC
-    >> qpat_assum ‘EVERY _ t’ $ irule_at (Pos $ el 2)
-    >> strip_tac >- (
-      rpt strip_tac
-      >> irule valid_val_larger_store
-      >> pop_assum $ irule_at (Pos last)
-      >> simp[]
-    )
-    >> irule_at (Pos $ el 3) valid_cont_larger_store
-    >> qpat_assum ‘valid_cont _ k'’ $ irule_at (Pos $ el 2)
-    >> simp[Once valid_val_cases]
-    >> conj_asm1_tac >- (
-      gvs[can_lookup_cases]
-      >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-      >> irule_at (Pos last) FEVERY_MONO
-      >> qpat_assum ‘FEVERY _ env’ $ irule_at (Pos $ el 2)
-      >> simp[]
-      >> PairCases
-      >> simp[]
-    )
+  )
+  >> irule_at (Pos $ el 3) valid_cont_larger_store
+  >> qpat_assum ‘valid_cont _ k'’ $ irule_at (Pos $ el 2)
+  >> simp[Once valid_val_cases]
+  >> conj_asm1_tac >- (
+    gvs[can_lookup_cases]
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
+    >> irule_at (Pos last) FEVERY_MONO
+    >> qpat_assum ‘FEVERY _ env’ $ irule_at (Pos $ el 2)
     >> simp[]
-    >> gvs[env_rel_cases]
-    >> strip_tac >- (
-      Cases_on ‘h ∈ FDOM env’ >- (
-        simp[FEVERY_DEF]
-        >> strip_tac
-        >> Cases_on ‘x = h’
-        >> gvs[] >- (
-          drule $ cj 1 $ iffLR EVERY2_EVERY
-          >> simp[]
-        )
-        >> strip_tac
-        >> gvs[FEVERY_DEF]
-        >> simp[FAPPLY_FUPDATE_THM]
+    >> PairCases
+    >> simp[]
+  )
+  >> simp[]
+  >> gvs[env_rel_cases]
+  >> strip_tac >- (
+    Cases_on ‘h ∈ FDOM env’ >- (
+      simp[FEVERY_DEF]
+      >> strip_tac
+      >> Cases_on ‘x = h’
+      >> gvs[] >- (
+        drule $ cj 1 $ iffLR EVERY2_EVERY
+        >> simp[]
       )
-      >> irule $ cj 2 FEVERY_STRENGTHEN_THM
-      >> simp[]
-      >> drule_then assume_tac $ cj 1 $ iffLR EVERY2_EVERY
-      >> simp[FEVERY_DEF]
-      >> rpt strip_tac
-      >> ‘x ≠ h’ by (strip_tac >> gvs[])
+      >> strip_tac
       >> gvs[FEVERY_DEF]
+      >> simp[FAPPLY_FUPDATE_THM]
     )
-    >> Cases_on ‘xp’
+    >> irule $ cj 2 FEVERY_STRENGTHEN_THM
     >> simp[]
-    >> irule static_scope_mono
-    >> gvs[Once valid_val_cases]
-    >> qpat_assum ‘static_scope _ _’ $ irule_at (Pos last)
-    >> simp[Ntimes INSERT_SING_UNION 2]
-    >> simp[SUBSET_DEF]
+    >> drule_then assume_tac $ cj 1 $ iffLR EVERY2_EVERY
+    >> simp[FEVERY_DEF]
+    >> rpt strip_tac
+    >> ‘x ≠ h’ by (strip_tac >> gvs[])
+    >> gvs[FEVERY_DEF]
   )
-  >> irule $ GSYM str_not_num
-  >> simp[isDigit_def]
+  >> Cases_on ‘xp’
+  >> simp[]
+  >> irule static_scope_mono
+  >> gvs[Once valid_val_cases]
+  >> qpat_assum ‘static_scope _ _’ $ irule_at (Pos last)
+  >> simp[Ntimes INSERT_SING_UNION 2]
+  >> simp[SUBSET_DEF]
 QED
 
 Theorem preservation_of_letrec:
@@ -1233,7 +1167,7 @@ Proof
     >> rpt strip_tac
     >> irule_at (Pos hd) EQ_REFL
     >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
-    >> qexistsl [‘scheme_env7’, ‘""’]
+    >> qexists ‘scheme_env7’
     >> simp[scheme_env_def]
   )
   >~ [‘Exp e’] >- (
@@ -1259,80 +1193,45 @@ Proof
     >~ [‘Cond c te fe’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> simp[Once cont_rel_cases]
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def]
-      >> metis_tac[]
     )
     >~ [‘Apply fn es’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = _’ $
-        irule_at (Pos $ hd o tl) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-      >> last_assum $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
-      >> irule_at (Pos hd) str_not_num
-      >> simp[isDigit_def, k_in_ts, t_in_ts]
     )
     >~ [‘Begin es e’] >- (
       Cases_on ‘es’
       >> rpt strip_tac
-      >> gvs[cps_transform_def]
-      >> rpt (pairarg_tac >> gvs[]) >- (
+      >> gvs[cps_transform_def] >- (
         qrefine ‘ck+1’
         >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
           nsOptBind_def, dec_clock_def]
         >> irule_at (Pos hd) EQ_REFL
         >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
-        >> irule_at (Pos hd) EQ_REFL
-        >> pop_assum $ irule_at (Pos hd) o GSYM
-        >> qpat_assum ‘scheme_env _’ $ simp
-          o curry ((::) o swap) [scheme_env_def]
-          o SRULE [scheme_env_def]
-        >> gvs[env_rel_cases]
+        >> gvs[scheme_env_def, env_rel_cases]
       )
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos $ el 2) o GSYM
-      >> qpat_assum ‘scheme_env _’ $ simp
-        o curry ((::) o swap) [scheme_env_def]
-        o SRULE [scheme_env_def]
-      >> gvs[env_rel_cases]
-      >> simp[Once cont_rel_cases]
-      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
-      >> simp[]
-      >> qpat_assum ‘scheme_env _’ $ simp
-        o curry ((::) o swap) [scheme_env_def]
-        o SRULE [scheme_env_def]
-      >> gvs[env_rel_cases]
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> gvs[scheme_env_def, env_rel_cases]
     )
     >~ [‘Lambda xs xp e’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 7, do_opapp_def,
         nsOptBind_def, dec_clock_def, do_con_check_def,
@@ -1342,10 +1241,7 @@ Proof
       >> irule_at (Pos hd) EQ_REFL
       >> last_assum $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
-      >> gvs[env_rel_cases]
-      >> pop_assum $ irule_at (Pos last) o GSYM
-      >> pop_assum $ irule_at Any o GSYM
-      >> gvs[scheme_env_def]
+      >> gvs[scheme_env_def, env_rel_cases]
     )
     >~ [‘Ident x’] >- (
       simp[cps_transform_def]
@@ -1377,28 +1273,21 @@ Proof
       >> simp[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
-      >> gvs[env_rel_cases, FEVERY_DEF]
+      >> gvs[env_rel_cases]
     )
     >~ [‘Set x e’] >- (
       simp[cps_transform_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> simp[Once cont_rel_cases]
-      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def]
-      >> pop_assum $ irule_at (Pos hd) o GSYM
     )
     >~ [‘Letrec bs e’] >- (
       simp[Once cps_transform_def]
+      >> cheat(*
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
@@ -1424,7 +1313,7 @@ Proof
         )
         >> gvs[scheme_env_def]
       )
-      >> gvs[env_rel_cases]
+      >> gvs[env_rel_cases]*)
     )
   )
   >~ [‘Val v’] >- (
@@ -1456,9 +1345,7 @@ Proof
       >> gvs[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
-      >> irule_at (Pos hd) EQ_REFL
       >> gvs[scheme_env_def, env_rel_cases]
-      >> metis_tac[]
     )
     >> Cases_on ‘∃ es e . h1 = BeginK es e’ >- (
       gvs[]
@@ -1468,35 +1355,16 @@ Proof
       >> gvs[cps_transform_def, step_def, return_def]
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
-        nsOptBind_def, dec_clock_def]
-      >> rpt (pairarg_tac >> gvs[]) >- (
+        nsOptBind_def, dec_clock_def] >- (
         irule_at (Pos hd) EQ_REFL
         >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
-        >> irule_at (Pos hd) EQ_REFL
-        >> pop_assum $ irule_at (Pos hd) o GSYM
-        >> qpat_assum ‘scheme_env _’ $ simp
-          o curry ((::) o swap) [scheme_env_def]
-          o SRULE [scheme_env_def]
-        >> gvs[env_rel_cases]
+        >> gvs[scheme_env_def, env_rel_cases]
       )
       >> simp[SimpLHS, Ntimes evaluate_def 2, nsOptBind_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos $ el 2) o GSYM
-      >> qpat_assum ‘scheme_env _’ $ simp
-        o curry ((::) o swap) [scheme_env_def]
-        o SRULE [scheme_env_def]
-      >> gvs[env_rel_cases]
-      >> simp[Once cont_rel_cases]
-      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> pop_assum $ irule_at (Pos $ el 2) o GSYM
-      >> simp[]
-      >> qpat_assum ‘scheme_env _’ $ simp
-        o curry ((::) o swap) [scheme_env_def]
-        o SRULE [scheme_env_def]
-      >> gvs[env_rel_cases]
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> gvs[scheme_env_def, env_rel_cases]
     )
     >> Cases_on ‘∃ x . h1 = SetK x’ >- (
       gvs[]
@@ -1534,66 +1402,48 @@ Proof
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $
-        irule_at (Pos $ el 2) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-      >> qpat_assum ‘scheme_env env'’ $ simp
-        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def, t_in_ts]
-      >> gvs[env_rel_cases]
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> simp[cps_app_ts_def]
+      >> gvs[scheme_env_def, env_rel_cases]
     )
     >> Cases_on ‘∃ fn vs e es . h1 = ApplyK (SOME (fn, vs)) (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
         Once cont_rel_cases, cps_transform_def, cps_app_ts_def]
       >> rpt strip_tac
-      >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
       >> irule_at (Pos hd) EQ_REFL
-      >> simp[Once e_ce_rel_cases]
-      >> irule_at Any EQ_REFL
-      >> qpat_assum ‘cps_transform _ _ = (_,_)’ $ irule_at
-        (Pos $ hd o tl) o GSYM
-      >> simp[Once cont_rel_cases]
-      >> SIMP_TAC std_ss [MAP_o]
-      >> pop_assum $ irule_at (Pos $ el 3) o GSYM
-        o SIMP_RULE std_ss [Ntimes (GSYM MAP) 2, MAP_o]
-      >> irule_at Any EQ_REFL
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> simp[PULL_EXISTS]
+      >> irule_at (Pos hd) EQ_REFL
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-      >> qpat_assum ‘scheme_env env'’ $ simp
-        o curry ((::) o swap) [scheme_env_def] o SRULE [scheme_env_def]
-      >> irule_at Any str_not_num
-      >> simp[isDigit_def, t_in_ts]
-      >> qpat_assum ‘LIST_REL _ vs _’ $ irule_at (Pos hd)
-      >> gvs[EVERY_CONJ]
-      >> qpat_assum ‘EVERY (λ x . x ≠ _) _’ $ simp o single
-        o SRULE [EVERY_MEM]
-      >> gvs[env_rel_cases]
-      >> irule EVERY2_MEM_MONO
-      >> qpat_assum ‘LIST_REL _ _ _’ $ irule_at (Pos last)
-      >> qpat_assum ‘LIST_REL _ _ _’ $ assume_tac o cj 1
-        o SRULE [EVERY2_EVERY]
-      >> PairCases >> simp[]
+      >> simp[cps_app_ts_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> qpat_assum ‘ml_v_vals' _ _’ $ irule_at Any
+      >> qpat_assum ‘LIST_REL ml_v_vals' _ _’ $ irule_at Any
+      >> drule $ GSYM cps_app_ts_distinct
       >> strip_tac
-      >> drule $ SRULE [Once CONJ_COMM] MEM_ZIP_MEM_MAP
       >> simp[]
-      >> strip_tac
-      >> qpat_assum ‘LIST_REL _ ts mlvs’ $ assume_tac o cj 1
-        o SRULE [EVERY2_EVERY]
-      >> qsuff_tac ‘x0 ≠ t'’
-      >> strip_tac
-      >> gvs[]
+      >> irule_at (Pos hd) EVERY2_MEM_MONO
+      >> qpat_assum ‘LIST_REL _ ts _’ $ irule_at Any
+      >> qpat_x_assum ‘LIST_REL _ ts _’ $ assume_tac
+      >> drule_then assume_tac EVERY2_LENGTH
+      >> strip_tac >- (
+        PairCases >> simp[]
+        >> strip_tac
+        >> drule_at_then (Pos last) assume_tac MEM_ZIP_MEM_MAP
+        >> gvs[]
+        >> qsuff_tac ‘x0 ≠ t'’
+        >> strip_tac
+        >> gvs[]
+      )
+      >> gvs[scheme_env_def, env_rel_cases]
     )
     >> Cases_on ‘h1 = ApplyK NONE []’ >- (
       gvs[]
@@ -1691,11 +1541,7 @@ Proof
           o curry ((::) o swap) [scheme_env_def]
           o SRULE [scheme_env_def]
         >> first_assum $ irule_at Any o GSYM
-        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
-        >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
-        >> simp[]
         >> simp[vcons_list_def]
-        >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
         >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
         >> strip_tac
         >> simp[]
@@ -1720,6 +1566,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[evaluate_def, do_con_check_def,
         build_conv_def, do_opapp_def, dec_clock_def]
+      >> drule $ cps_app_ts_distinct
+      >> strip_tac
       >> ‘scheme_env (env'' with v:= nsBind t' mlv env''.v)’ by gvs[scheme_env_def]
       >> qsuff_tac ‘LIST_REL (λx v'. nsLookup (env'' with v:= nsBind t' mlv
       env''.v).v (Short x) = SOME v') (REVERSE (t'::ts)) (REVERSE (mlv::mlvs))’ >- (
@@ -1804,12 +1652,7 @@ Proof
             o curry ((::) o swap) [scheme_env_def]
             o SRULE [scheme_env_def]
           >> first_assum $ irule_at Any o GSYM
-          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
-          >> qpat_assum ‘_ = proc_ml _ _ _ _ _ _’ $ irule_at Any
-          >> simp[]
-          >> irule_at (Pos hd) EQ_REFL
-          >> qpat_assum ‘_ = cps_transform _ _’ $ irule_at (Pos hd)
-          >> irule_at (Pos last) $ cj 1 $ iffLR LIST_REL_APPEND
+          >> rpt $ irule_at Any EQ_REFL
           >> simp[]
           >> last_x_assum $ mp_tac o SRULE [Once valid_state_cases]
           >> strip_tac
@@ -1971,6 +1814,7 @@ Proof
             >> gvs[cps_transform_def, cps_app_ts_def]
             >> irule_at (Pos hd) EQ_REFL
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+            >> qpat_assum ‘ml_v_vals' _ _’ $ irule_at Any
             >> simp[Once e_ce_rel_cases]
             >> simp[Once ml_v_vals'_cases]
             >> simp[cons_list_def]
@@ -2038,21 +1882,17 @@ Proof
         >> simp[Once e_ce_rel_cases]
       )
       >> simp[]
-      >> qsuff_tac ‘EVERY (λ(x,y). t' ≠ x) (ZIP (ts,mlvs))’ >- (
-        strip_tac
-        >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
-        >> drule_then assume_tac EVERY2_LENGTH
-        >> rev_drule_all $ iffRL EVERY2_EVERY
-        >> qpat_x_assum ‘LIST_REL _ _ _’ mp_tac
-        >> simp[AND_IMP_INTRO, GSYM LIST_REL_CONJ]
-        >> ho_match_mp_tac EVERY2_mono
-        >> simp[]
-      )
-      >> simp[EVERY_MEM] >> PairCases >> simp[]
-      >> qpat_x_assum ‘LIST_REL _ ts mlvs’ assume_tac
-      >> strip_tac >> drule_at_then Any assume_tac MEM_ZIP_MEM_MAP
-      >> drule_then assume_tac EVERY2_LENGTH >> gvs[]
-      >> strip_tac >> gvs[]
+      >> irule_at (Pos hd) EVERY2_MEM_MONO
+      >> qpat_assum ‘LIST_REL _ ts _’ $ irule_at Any
+      >> qpat_x_assum ‘LIST_REL _ ts _’ $ assume_tac
+      >> drule_then assume_tac EVERY2_LENGTH
+      >> PairCases >> simp[]
+      >> strip_tac
+      >> drule_at_then (Pos last) assume_tac MEM_ZIP_MEM_MAP
+      >> gvs[]
+      >> qsuff_tac ‘x0 ≠ t'’
+      >> strip_tac
+      >> gvs[]
     )
     >> Cases_on ‘h1’ >> gvs[]
     >> Cases_on ‘l’ >> gvs[]
@@ -2061,6 +1901,7 @@ Proof
   )
 QED
 
+(*
 Theorem steps_preservation:
   ∀ n store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   FUNPOW step n (store, k, env, e) = (store', k', env', e') ∧
@@ -2132,6 +1973,7 @@ Proof
   >> last_x_assum $ drule_all
   >> strip_tac
 QED
+*)
 
 (*Theorem val_correct:
   ∀ n . ∃ k . SND (evaluate <| clock := k |> myEnv [scheme_program_to_cake (Val (SNum n))])
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index b67c690296..1429404ee9 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -30,29 +30,27 @@ Definition cons_list_def:
 End
 
 Definition proc_ml_def:
-  proc_ml n [] NONE k args ce = (n, Mat (Var (Short args)) [
+  proc_ml [] NONE k ce = Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "[]") [],
           App Opapp [ce; Var (Short k)]);
         (Pany,
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"])
-    ]) ∧
-  proc_ml n [] (SOME x) k args ce = (n, Let (SOME $ "var" ++ explode x)
+    ] ∧
+  proc_ml [] (SOME x) k ce = Let (SOME $ "var" ++ explode x)
       (App Opref [Con (SOME $ Short "Some") [
-        Con (SOME $ Short "SList") [Var (Short args)]]])
-      (App Opapp [ce; Var (Short k)])) ∧
-  proc_ml n (x::xs) xp k args ce = (let
-    arg = "x" ++ toString n;
-    args' = "xs" ++ toString (n+1);
-    (m, inner) = proc_ml (n+2) xs xp k args' ce
+        Con (SOME $ Short "SList") [Var (Short "xs")]]])
+      (App Opapp [ce; Var (Short k)]) ∧
+  proc_ml (x::xs) xp k ce = (let
+    inner = proc_ml xs xp k ce
   in
-    (m, Mat (Var (Short args)) [
+    Mat (Var (Short "xs")) [
         (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
-        (Pcon (SOME $ Short "::") [Pvar arg; Pvar args'],
+        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs"],
           Let (SOME $ "var" ++ explode x)
-            (App Opref [Con (SOME $ Short "Some") [Var (Short arg)]])
+            (App Opref [Con (SOME $ Short "Some") [Var (Short "x")]])
             inner)
-    ]))
+    ])
 End
 
 Definition letinit_ml_def:
@@ -62,109 +60,95 @@ Definition letinit_ml_def:
 End
 
 Definition refunc_set_def:
-  refunc_set n t k x = (n, Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
+  refunc_set t k x = Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
               Con (SOME $ Short "Some") [t]]) $
             Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
-              (App Opapp [k; Var (Short "v")]))
+              (App Opapp [k; Var (Short "v")])
 End
 
 Definition cps_transform_def:
-  cps_transform n (Lit v) = (let
-    k = "k" ++ toString n;
+  cps_transform (Lit v) = (let
     mlv = to_ml_vals $ lit_to_val v
   in
-    (n+1, Fun k $ Let (SOME "v") mlv $
-      App Opapp [Var (Short k); Var (Short "v")])) ∧
-
-  cps_transform n (Cond c t f) = (let
-    (m, cc) = cps_transform n c;
-    (l, ct) = cps_transform m t;
-    (j, cf) = cps_transform l f;
-    k = "k" ++ toString j;
-    p = "t" ++ toString (j+1);
+    Fun "k" $ Let (SOME "v") mlv $
+      App Opapp [Var (Short "k"); Var (Short "v")]) ∧
+
+  cps_transform (Cond c t f) = (let
+    cc = cps_transform c;
+    ct = cps_transform t;
+    cf = cps_transform f;
   in
-    (j+2, Fun k $ Let (SOME "k") (Fun p $ Mat (Var (Short p)) [
+    Fun "k" $ Let (SOME "k'") (Fun "t" $ Mat (Var (Short "t")) [
       (Pcon (SOME $ Short "SBool") [Pcon (SOME $ Short "False") []],
-        App Opapp [cf; Var (Short k)]);
+        App Opapp [cf; Var (Short "k")]);
       (Pany,
-        App Opapp [ct; Var (Short k)])
-    ]) $ App Opapp [cc; Var (Short "k")])) ∧
-
-  cps_transform n (Apply fn args) = (let
-    (m, cfn) = cps_transform n fn;
-    k = "k" ++ toString m;
-    t = "t" ++ toString (m+1);
-    (l, capp) = cps_transform_app (m+2) (Var (Short t)) [] args (Var (Short k))
+        App Opapp [ct; Var (Short "k")])
+    ]) $ App Opapp [cc; Var (Short "k'")]) ∧
+
+  cps_transform (Apply fn args) = (let
+    cfn = cps_transform fn;
+    capp = cps_transform_app (Var (Short "t")) [] args (Var (Short "k"))
   in
-    (l, Fun k $ Let (SOME "k") (Fun t capp) $ App Opapp [cfn; Var (Short "k")])) ∧
+    Fun "k" $ Let (SOME "k'") (Fun "t" capp) $ App Opapp [cfn; Var (Short "k'")]) ∧
 
-  cps_transform n (Ident x) = (let k = "k" ++ toString n in
-    (n, Fun k $ Mat (App Opderef [Var (Short $ "var" ++ explode x)]) [
+  cps_transform (Ident x) = Fun "k" $ Mat (App Opderef [Var (Short $ "var" ++ explode x)]) [
       (Pcon (SOME $ Short "None") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Letrec variable touched"]);
       (Pcon (SOME $ Short "Some") [Pvar $ "'var" ++ explode x],
-        App Opapp [Var (Short k); Var (Short $ "'var" ++ explode x)])])) ∧
-
-  cps_transform n (Lambda xs xp e) = (let
-    (m, ce) = cps_transform n e;
-    args = "xs" ++ toString m;
-    k = "k" ++ toString (m+1);
-    (l, inner) = proc_ml (m+2) xs xp k args ce;
-    k' = "k" ++ toString l;
+        App Opapp [Var (Short "k"); Var (Short $ "'var" ++ explode x)])] ∧
+
+  cps_transform (Lambda xs xp e) = (let
+    ce = cps_transform e;
+    inner = proc_ml xs xp "k" ce;
   in
-    (l+1, Fun k' $ Let (SOME "v")
-      (Con (SOME $ Short "Proc") [Fun k $ Fun args inner]) $
-      App Opapp [Var (Short k'); Var (Short "v")])) ∧
+    Fun "k'" $ Let (SOME "v")
+      (Con (SOME $ Short "Proc") [Fun "k" $ Fun "xs" inner]) $
+      App Opapp [Var (Short "k'"); Var (Short "v")]) ∧
 
-  cps_transform n (Begin es e) = (let
-      k = "k" ++ toString n;
-      (m, inner) = cps_transform_seq (n+1) (Var (Short k)) es e
+  cps_transform (Begin es e) = (let
+      inner = cps_transform_seq (Var (Short "k")) es e
     in
-      (m, Fun k inner)) ∧
+      Fun "k" inner) ∧
 
-  cps_transform n (Set x e) = (let
-    (m, ce) = cps_transform n e;
-    k = "k" ++ toString m;
-    t = "t" ++ toString (m+1);
-    (l, inner) = refunc_set (m+2) (Var (Short t)) (Var (Short k)) x;
+  cps_transform (Set x e) = (let
+    ce = cps_transform e;
+    inner = refunc_set (Var (Short "t")) (Var (Short "k")) x;
   in
-    (l, Fun k $ Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")])) ∧
+    Fun "k" $ Let (SOME "k'") (Fun "t" inner) $ App Opapp [ce; Var (Short "k'")]) ∧
 
-  cps_transform n (Letrec bs e) = (let
-    (m, ce) = cps_transform n (Begin (MAP (UNCURRY Set) bs) e);
-    k = "k" ++ toString m
+  cps_transform (Letrec bs e) = (let
+    ce = cps_transform (Begin (MAP (UNCURRY Set) bs) e);
   in
-    (m+1, Fun k $ letinit_ml (MAP FST bs) $ App Opapp [ce; Var (Short k)])) ∧
+    Fun "k" $ letinit_ml (MAP FST bs) $ App Opapp [ce; Var (Short "k")]) ∧
 
 
-  cps_transform_app n tfn ts (e::es) k = (let
-    (m, ce) = cps_transform n e;
-    t = "t" ++ toString m;
-    (l, inner) = cps_transform_app (m+1) tfn (Var (Short t)::ts) es k
+  cps_transform_app tfn ts (e::es) k = (let
+    ce = cps_transform e;
+    t = "t" ++ toString (LENGTH ts);
+    inner = cps_transform_app tfn (Var (Short t)::ts) es k
   in
-    (l, Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")])) ∧
+    Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")]) ∧
 
-  cps_transform_app n tfn ts [] k = (n,
-    App Opapp [
+  cps_transform_app tfn ts [] k = App Opapp [
       App Opapp [App Opapp [Var (Short "app"); k]; tfn];
-      cons_list (REVERSE ts)]) ∧
+      cons_list (REVERSE ts)] ∧
 
 
-  cps_transform_seq n k [] e = (let
-    (m, ce) = cps_transform n e
+  cps_transform_seq k [] e = (let
+    ce = cps_transform e
   in
-    (n, App Opapp [ce; k])) ∧
+    App Opapp [ce; k]) ∧
 
-  cps_transform_seq n k (e'::es) e = (let
-    (m, ce) = cps_transform n e';
-    (l, inner) = cps_transform_seq m k es e
+  cps_transform_seq k (e'::es) e = (let
+    ce = cps_transform e';
+    inner = cps_transform_seq k es e
   in
-    (l, Let (SOME "k") (Fun "_" inner) $ App Opapp [ce; Var (Short "k")]))
+     Let (SOME "k'") (Fun "_" inner) $ App Opapp [ce; Var (Short "k'")])
 Termination
   WF_REL_TAC ‘inv_image ($< LEX $<) (λ x . case x of
-    | INL(_,e) => (exp_size e, case e of Letrec _ _ => 1 | _ => 0)
-    | INR(INL(_,_,_,es,_)) => (list_size exp_size es, 2n)
-    | INR(INR(_,_,es,e)) => (list_size exp_size es + exp_size e, 2))’
+    | INL(e) => (exp_size e, case e of Letrec _ _ => 1 | _ => 0)
+    | INR(INL(_,_,es,_)) => (list_size exp_size es, 2n)
+    | INR(INR(_,es,e)) => (list_size exp_size es + exp_size e, 2))’
   >> strip_tac >- (Cases >> simp[])
   >> Induct
   >> simp[exp_size_def]
@@ -174,7 +158,7 @@ End
 
 Definition compile_scheme_prog_def:
   compile_scheme_prog p = let
-    (n, cp) = cps_transform 0 p
+    cp = cps_transform p
   in
     Let (SOME $ "k") (Fun "t" $ Var (Short "t")) $
       App Opapp [cp; Var (Short "k")]
@@ -344,15 +328,15 @@ Definition scheme_basis7_def:
     ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
       (Pcon (SOME $ Short "[]") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "xs"],
+        Mat (Var (Short "xs")) [
           (Pcon (SOME $ Short "[]") [],
             Let (SOME "k'") (
-              Fun "t" $ App Opapp [
+              Fun "t0" $ App Opapp [
                 App Opapp [
                   App Opapp [Var (Short "app");Var (Short "k")];
-                  Var (Short "x")];
-                cons_list [Var (Short "t")]]
+                  Var (Short "t")];
+                cons_list [Var (Short "t0")]]
             ) $ Let (SOME "v") (Con (SOME $ Short "Throw") [Var (Short "k")]) $
               App Opapp [Var (Short "k'"); Var (Short "v")]);
           (Pany,

From 00172c9096aaf758c1dcc08bee664fccbd633343 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Mon, 21 Apr 2025 18:53:41 +0100
Subject: [PATCH 089/100] forgot about letrec

---
 .../proofs/scheme_to_cakeProofScript.sml      | 38 +++++++++----------
 compiler/scheme/scheme_to_cakeScript.sml      |  2 +-
 2 files changed, 18 insertions(+), 22 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 0ad6db2375..31ed1f87d1 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -1287,33 +1287,29 @@ Proof
     )
     >~ [‘Letrec bs e’] >- (
       simp[Once cps_transform_def]
-      >> cheat(*
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 4, do_opapp_def, dec_clock_def]
       >> pop_assum $ assume_tac o GSYM
       >> drule preservation_of_letrec
-      >> qsuff_tac ‘env_rel env
-        (mlenv with v := nsBind (STRING #"k" (toString m')) kv mlenv.v)’ >- (
-        rpt strip_tac
-        >> pop_assum $ drule_then drule
-        >> qsuff_tac ‘scheme_env
-          (mlenv with v := nsBind (STRING #"k" (toString m')) kv mlenv.v)’ >- (
-          rpt strip_tac
-          >> pop_assum $ drule
-          >> rpt strip_tac
-          >> pop_assum $ qspec_then
-            ‘(App Opapp [ce'; Var (Short (STRING #"k" (toString m')))])’ mp_tac
-          >> rpt strip_tac
-          >> qpat_assum ‘evaluate _ _ _ = _’ $ irule_at (Pos hd)
-          >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-          >> simp[Once e_ce_rel_cases]
-          >> qpat_assum ‘cps_transform _ _ = _’ $ irule_at (Pos hd) o GSYM
-        )
-        >> gvs[scheme_env_def]
-      )
-      >> gvs[env_rel_cases]*)
+      >> ‘env_rel env (mlenv with v := nsBind "k" kv mlenv.v)’
+        by gvs[env_rel_cases]
+      >> strip_tac
+      >> pop_assum $ drule_then drule
+      >> ‘scheme_env (mlenv with v := nsBind "k" kv mlenv.v)’
+        by gvs[scheme_env_def]
+      >> strip_tac
+      >> pop_assum $ drule
+      >> strip_tac
+      >> pop_assum $ qspec_then
+        ‘App Opapp
+          [cps_transform (Begin (MAP (UNCURRY Set) bs) e);
+           Var (Short "k")]’ mp_tac
+      >> rpt strip_tac
+      >> qpat_assum ‘evaluate _ _ _ = _’ $ irule_at (Pos hd)
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> simp[Once e_ce_rel_cases]
     )
   )
   >~ [‘Val v’] >- (
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 1429404ee9..0d4c486348 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -127,7 +127,7 @@ Definition cps_transform_def:
     t = "t" ++ toString (LENGTH ts);
     inner = cps_transform_app tfn (Var (Short t)::ts) es k
   in
-    Let (SOME "k") (Fun t inner) $ App Opapp [ce; Var (Short "k")]) ∧
+    Let (SOME "k'") (Fun t inner) $ App Opapp [ce; Var (Short "k'")]) ∧
 
   cps_transform_app tfn ts [] k = App Opapp [
       App Opapp [App Opapp [Var (Short "app"); k]; tfn];

From db2a5b02030c1767c7fdf5fa5f90a0f8af307734 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Mon, 21 Apr 2025 22:56:19 +0100
Subject: [PATCH 090/100] ml var renames for consistency

---
 .../proofs/scheme_to_cakeProofScript.sml      |  58 ++++-----
 compiler/scheme/scheme_to_cakeScript.sml      | 116 +++++++++---------
 2 files changed, 87 insertions(+), 87 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 31ed1f87d1..ef51c8f016 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -306,7 +306,7 @@ Inductive val_cont_rels:
   ⇒
   ml_v_vals' (Proc se xs xp e) $
     Conv (SOME (scheme_typestamp "Proc")) [
-      Closure env "k" $ Fun "xs" inner
+      Closure env "k" $ Fun "ts" inner
     ]
 [~Throw:]
   cont_rel ks kv
@@ -532,7 +532,7 @@ Theorem preservation_of_sadd_body:
   ∀ store st env n k kv i .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
-    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "sadd") = nsLookup scheme_env2.v (Short "sadd") ∧
@@ -541,18 +541,18 @@ Theorem preservation_of_sadd_body:
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
       evaluate (st with clock := ck) env
-        [Mat (Var (Short "xs"))
+        [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
-             Let (SOME "v") (Con (SOME (Short "SNum")) [Var (Short "n")])
-               (App Opapp [Var (Short "k"); Var (Short "v")]));
-            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
-             Mat (Var (Short "x"))
-               [(Pcon (SOME (Short "SNum")) [Pvar "xn"],
+             Let (SOME "t") (Con (SOME (Short "SNum")) [Var (Short "n")])
+               (App Opapp [Var (Short "k"); Var (Short "t")]));
+            (Pcon (SOME (Short "::")) [Pvar "t"; Pvar "ts'"],
+             Mat (Var (Short "t"))
+               [(Pcon (SOME (Short "SNum")) [Pvar "tn"],
                  App Opapp
                    [App Opapp
                       [App Opapp [Var (Short "sadd"); Var (Short "k")];
-                       App (Opn Plus) [Var (Short "n"); Var (Short "xn")]];
-                    Var (Short "xs'")]);
+                       App (Opn Plus) [Var (Short "n"); Var (Short "tn")]];
+                    Var (Short "ts'")]);
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
@@ -611,7 +611,7 @@ Theorem preservation_of_smul_body:
   ∀ store st env n k kv i .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
-    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "smul") = nsLookup scheme_env3.v (Short "smul") ∧
@@ -620,18 +620,18 @@ Theorem preservation_of_smul_body:
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
       evaluate (st with clock := ck) env
-        [Mat (Var (Short "xs"))
+        [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
-             Let (SOME "v") (Con (SOME (Short "SNum")) [Var (Short "n")])
-               (App Opapp [Var (Short "k"); Var (Short "v")]));
-            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
-             Mat (Var (Short "x"))
-               [(Pcon (SOME (Short "SNum")) [Pvar "xn"],
+             Let (SOME "t") (Con (SOME (Short "SNum")) [Var (Short "n")])
+               (App Opapp [Var (Short "k"); Var (Short "t")]));
+            (Pcon (SOME (Short "::")) [Pvar "t"; Pvar "ts'"],
+             Mat (Var (Short "t"))
+               [(Pcon (SOME (Short "SNum")) [Pvar "tn"],
                  App Opapp
                    [App Opapp
                       [App Opapp [Var (Short "smul"); Var (Short "k")];
-                       App (Opn Times) [Var (Short "n"); Var (Short "xn")]];
-                    Var (Short "xs'")]);
+                       App (Opn Times) [Var (Short "n"); Var (Short "tn")]];
+                    Var (Short "ts'")]);
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
@@ -690,7 +690,7 @@ Theorem preservation_of_sminus_body:
   ∀ store (st:'ffi state) env n k kv i .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
-    nsLookup env.v (Short "xs") = SOME (vcons_list mlvs) ∧
+    nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "sadd") = nsLookup scheme_env3.v (Short "sadd") ∧
     env.c = scheme_env1.c ∧
@@ -698,11 +698,11 @@ Theorem preservation_of_sminus_body:
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
       evaluate (st with clock := ck) env
-        [Mat (Var (Short "xs"))
+        [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
              Con (SOME (Short "Ex")) [Lit (StrLit "Arity mismatch")]);
-            (Pcon (SOME (Short "::")) [Pvar "x"; Pvar "xs'"],
-             Mat (Var (Short "x"))
+            (Pcon (SOME (Short "::")) [Pvar "t"; Pvar "ts'"],
+             Mat (Var (Short "t"))
                [(Pcon (SOME (Short "SNum")) [Pvar "n"],
                  App Opapp
                    [App Opapp
@@ -711,17 +711,17 @@ Theorem preservation_of_sminus_body:
                           Fun "t"
                             (Mat (Var (Short "t"))
                                [(Pcon (SOME (Short "SNum")) [Pvar "m"],
-                                 Let (SOME "v")
+                                 Let (SOME "t")
                                    (Con (SOME (Short "SNum"))
                                       [App (Opn Minus)
                                          [Var (Short "n");
                                           Var (Short "m")]])
                                    (App Opapp
-                                      [Var (Short "k"); Var (Short "v")]));
+                                      [Var (Short "k"); Var (Short "t")]));
                                 (Pany,
                                  App Opapp
                                    [Var (Short "k"); Var (Short "t")])])];
-                       Lit (IntLit 0)]; Var (Short "xs'")]);
+                       Lit (IntLit 0)]; Var (Short "ts'")]);
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
@@ -779,8 +779,8 @@ Proof
     >> ‘∃ kenv . (env with
                            v :=
                              nsBind "n" (Litv (IntLit i))
-                               (nsBind "xs'" (vcons_list t')
-                                  (nsBind "x"
+                               (nsBind "ts'" (vcons_list t')
+                                  (nsBind "t"
                                      (Conv (SOME (TypeStamp "SNum" 4))
                                         [Litv (IntLit i)]) env.v)))
                   = kenv’ by simp[]
@@ -873,7 +873,7 @@ Theorem preservation_of_proc:
   (store', env',e') = parameterize store env xs xp e vs ∧
   EVERY (OPTION_ALL (valid_val store)) store ∧
   nsLookup mlenv.v (Short "k") = SOME kv ∧
-  nsLookup mlenv.v (Short "xs") = SOME (vcons_list mlvs) ∧
+  nsLookup mlenv.v (Short "ts") = SOME (vcons_list mlvs) ∧
   env_rel env mlenv ∧
   scheme_env mlenv ∧
   can_lookup env store ∧
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index 0d4c486348..b4599535eb 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -30,7 +30,7 @@ Definition cons_list_def:
 End
 
 Definition proc_ml_def:
-  proc_ml [] NONE k ce = Mat (Var (Short "xs")) [
+  proc_ml [] NONE k ce = Mat (Var (Short "ts")) [
         (Pcon (SOME $ Short "[]") [],
           App Opapp [ce; Var (Short k)]);
         (Pany,
@@ -38,17 +38,17 @@ Definition proc_ml_def:
     ] ∧
   proc_ml [] (SOME x) k ce = Let (SOME $ "var" ++ explode x)
       (App Opref [Con (SOME $ Short "Some") [
-        Con (SOME $ Short "SList") [Var (Short "xs")]]])
+        Con (SOME $ Short "SList") [Var (Short "ts")]]])
       (App Opapp [ce; Var (Short k)]) ∧
   proc_ml (x::xs) xp k ce = (let
     inner = proc_ml xs xp k ce
   in
-    Mat (Var (Short "xs")) [
+    Mat (Var (Short "ts")) [
         (Pcon (SOME $ Short "[]") [],
           Con (SOME $ Short "Ex") [Lit $ StrLit "Wrong number of arguments"]);
-        (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs"],
+        (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts"],
           Let (SOME $ "var" ++ explode x)
-            (App Opref [Con (SOME $ Short "Some") [Var (Short "x")]])
+            (App Opref [Con (SOME $ Short "Some") [Var (Short "t")]])
             inner)
     ])
 End
@@ -62,16 +62,16 @@ End
 Definition refunc_set_def:
   refunc_set t k x = Let NONE (App Opassign [Var (Short $ "var" ++ explode x);
               Con (SOME $ Short "Some") [t]]) $
-            Let (SOME "v") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
-              (App Opapp [k; Var (Short "v")])
+            Let (SOME "t") (Con (SOME $ Short "Wrong") [Lit $ StrLit "Unspecified"])
+              (App Opapp [k; Var (Short "t")])
 End
 
 Definition cps_transform_def:
   cps_transform (Lit v) = (let
     mlv = to_ml_vals $ lit_to_val v
   in
-    Fun "k" $ Let (SOME "v") mlv $
-      App Opapp [Var (Short "k"); Var (Short "v")]) ∧
+    Fun "k" $ Let (SOME "t") mlv $
+      App Opapp [Var (Short "k"); Var (Short "t")]) ∧
 
   cps_transform (Cond c t f) = (let
     cc = cps_transform c;
@@ -94,16 +94,16 @@ Definition cps_transform_def:
   cps_transform (Ident x) = Fun "k" $ Mat (App Opderef [Var (Short $ "var" ++ explode x)]) [
       (Pcon (SOME $ Short "None") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Letrec variable touched"]);
-      (Pcon (SOME $ Short "Some") [Pvar $ "'var" ++ explode x],
-        App Opapp [Var (Short "k"); Var (Short $ "'var" ++ explode x)])] ∧
+      (Pcon (SOME $ Short "Some") [Pvar "t"],
+        App Opapp [Var (Short "k"); Var (Short "t")])] ∧
 
   cps_transform (Lambda xs xp e) = (let
     ce = cps_transform e;
     inner = proc_ml xs xp "k" ce;
   in
-    Fun "k'" $ Let (SOME "v")
-      (Con (SOME $ Short "Proc") [Fun "k" $ Fun "xs" inner]) $
-      App Opapp [Var (Short "k'"); Var (Short "v")]) ∧
+    Fun "k" $ Let (SOME "t")
+      (Con (SOME $ Short "Proc") [Fun "k" $ Fun "ts" inner]) $
+      App Opapp [Var (Short "k"); Var (Short "t")]) ∧
 
   cps_transform (Begin es e) = (let
       inner = cps_transform_seq (Var (Short "k")) es e
@@ -202,19 +202,19 @@ End
 
 Definition scheme_basis2_def:
   scheme_basis2 = Dletrec unknown_loc [
-    ("sadd", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+    ("sadd", "k", Fun "n" $ Fun "ts" $ Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
-        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-          App Opapp [Var (Short "k"); Var (Short "v")]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
-          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+        Let (SOME "t") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "t")]);
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts'"],
+        Mat (Var (Short "t")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "tn"],
             App Opapp [
               App Opapp [
                 App Opapp [Var (Short "sadd"); Var (Short "k")];
-                App (Opn Plus) [Var (Short "n"); Var (Short "xn")]
+                App (Opn Plus) [Var (Short "n"); Var (Short "tn")]
               ];
-              Var (Short "xs'")
+              Var (Short "ts'")
             ]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
@@ -225,19 +225,19 @@ End
 
 Definition scheme_basis3_def:
   scheme_basis3 = Dletrec unknown_loc [
-    ("smul", "k", Fun "n" $ Fun "xs" $ Mat (Var (Short "xs")) [
+    ("smul", "k", Fun "n" $ Fun "ts" $ Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
-        Let (SOME "v") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
-          App Opapp [Var (Short "k"); Var (Short "v")]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
-          (Pcon (SOME $ Short "SNum") [Pvar "xn"],
+        Let (SOME "t") (Con (SOME $ Short "SNum") [Var (Short "n")]) $
+          App Opapp [Var (Short "k"); Var (Short "t")]);
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts'"],
+        Mat (Var (Short "t")) [
+          (Pcon (SOME $ Short "SNum") [Pvar "tn"],
             App Opapp [
               App Opapp [
                 App Opapp [Var (Short "smul"); Var (Short "k")];
-                App (Opn Times) [Var (Short "n"); Var (Short "xn")]
+                App (Opn Times) [Var (Short "n"); Var (Short "tn")]
               ];
-              Var (Short "xs'")
+              Var (Short "ts'")
             ]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
@@ -247,23 +247,23 @@ Definition scheme_basis3_def:
 End
 
 Definition scheme_basis4_def:
-  scheme_basis4 = Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
+  scheme_basis4 = Dlet unknown_loc (Pvar "sminus") $ Fun "k" $ Fun "ts" $
+    Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "x")) [
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts'"],
+        Mat (Var (Short "t")) [
           (Pcon (SOME $ Short "SNum") [Pvar "n"],
             App Opapp [App Opapp [App Opapp [Var (Short "sadd");
               Fun "t" $ Mat (Var (Short "t")) [
                 (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                  Let (SOME "v") (Con (SOME $ Short "SNum") [
+                  Let (SOME "t") (Con (SOME $ Short "SNum") [
                       App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
-                    App Opapp [Var (Short "k"); Var (Short "v")]);
+                    App Opapp [Var (Short "k"); Var (Short "t")]);
                 (Pany,
                   App Opapp [Var (Short "k"); Var (Short "t")])
               ]];
-              Lit $ IntLit 0]; Var (Short "xs'")]);
+              Lit $ IntLit 0]; Var (Short "ts'")]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
         ])
@@ -271,28 +271,28 @@ Definition scheme_basis4_def:
 End
 
 Definition scheme_basis5_def:
-  scheme_basis5 = Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
+  scheme_basis5 = Dlet unknown_loc (Pvar "seqv") $ Fun "k" $ Fun "ts" $
+    Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x1"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
+      (Pcon (SOME $ Short "::") [Pvar "t1"; Pvar "ts'"],
+        Mat (Var (Short "ts'")) [
           (Pcon (SOME $ Short "[]") [],
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-          (Pcon (SOME $ Short "::") [Pvar "x2"; Pvar "xs''"],
-            Mat (Var (Short "xs''")) [
+          (Pcon (SOME $ Short "::") [Pvar "t2"; Pvar "ts''"],
+            Mat (Var (Short "ts''")) [
               (Pcon (SOME $ Short "[]") [],
-                (Let (SOME "v") (Con (SOME $ Short "SBool") [
-                  Mat (Var (Short "x1")) [
+                (Let (SOME "t") (Con (SOME $ Short "SBool") [
+                  Mat (Var (Short "t1")) [
                     (Pcon (SOME $ Short "SNum") [Pvar "n"],
-                      Mat (Var (Short "x2")) [
+                      Mat (Var (Short "t2")) [
                         (Pcon (SOME $ Short "SNum") [Pvar "m"],
                           App Equality [Var (Short "n"); Var (Short "m")]);
                         (Pany,
                           Con (SOME $ Short "False") [])
                       ]);
                     (Pcon (SOME $ Short "SBool") [Pvar "b"],
-                      Mat (Var (Short "x2")) [
+                      Mat (Var (Short "t2")) [
                         (Pcon (SOME $ Short "SBool") [Pvar "b'"],
                           App Equality [Var (Short "b"); Var (Short "b'")]);
                         (Pany,
@@ -300,7 +300,7 @@ Definition scheme_basis5_def:
                       ]);
                     (Pany,
                       Con (SOME $ Short "False") [])
-                    ]]) $ App Opapp [Var (Short "k"); Var (Short "v")]));
+                    ]]) $ App Opapp [Var (Short "k"); Var (Short "t")]));
               (Pany,
                 Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
             ])
@@ -309,14 +309,14 @@ Definition scheme_basis5_def:
 End
 
 Definition scheme_basis6_def:
-  scheme_basis6 = Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "xs" $
-    Mat (Var (Short "xs")) [
+  scheme_basis6 = Dlet unknown_loc (Pvar "throw") $ Fun "k" $ Fun "ts" $
+    Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "x"; Pvar "xs'"],
-        Mat (Var (Short "xs'")) [
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts'"],
+        Mat (Var (Short "ts'")) [
           (Pcon (SOME $ Short "[]") [],
-            App Opapp [Var (Short "k"); Var (Short "x")]);
+            App Opapp [Var (Short "k"); Var (Short "t")]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
         ])
@@ -325,11 +325,11 @@ End
 
 Definition scheme_basis7_def:
   scheme_basis7 = Dletrec unknown_loc [
-    ("callcc", "k", Fun "xs" $ Mat (Var (Short "xs")) [
+    ("callcc", "k", Fun "ts" $ Mat (Var (Short "ts")) [
       (Pcon (SOME $ Short "[]") [],
         Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"]);
-      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "xs"],
-        Mat (Var (Short "xs")) [
+      (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts"],
+        Mat (Var (Short "ts")) [
           (Pcon (SOME $ Short "[]") [],
             Let (SOME "k'") (
               Fun "t0" $ App Opapp [
@@ -337,8 +337,8 @@ Definition scheme_basis7_def:
                   App Opapp [Var (Short "app");Var (Short "k")];
                   Var (Short "t")];
                 cons_list [Var (Short "t0")]]
-            ) $ Let (SOME "v") (Con (SOME $ Short "Throw") [Var (Short "k")]) $
-              App Opapp [Var (Short "k'"); Var (Short "v")]);
+            ) $ Let (SOME "t") (Con (SOME $ Short "Throw") [Var (Short "k")]) $
+              App Opapp [Var (Short "k'"); Var (Short "t")]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arity mismatch"])
         ])

From 37ee40f8011458054cf3d8a73394a0bf4eea8a14 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 25 Apr 2025 16:52:36 +0100
Subject: [PATCH 091/100] fix semantic minus bug

---
 .../proofs/scheme_to_cakeProofScript.sml      | 57 +++++++++++++------
 compiler/scheme/scheme_semanticsScript.sml    | 10 ++--
 compiler/scheme/scheme_to_cakeScript.sml      | 26 +++++----
 3 files changed, 61 insertions(+), 32 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index ef51c8f016..f100ed24e4 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -704,24 +704,21 @@ Theorem preservation_of_sminus_body:
             (Pcon (SOME (Short "::")) [Pvar "t"; Pvar "ts'"],
              Mat (Var (Short "t"))
                [(Pcon (SOME (Short "SNum")) [Pvar "n"],
-                 App Opapp
-                   [App Opapp
-                      [App Opapp
-                         [Var (Short "sadd");
-                          Fun "t"
-                            (Mat (Var (Short "t"))
-                               [(Pcon (SOME (Short "SNum")) [Pvar "m"],
-                                 Let (SOME "t")
-                                   (Con (SOME (Short "SNum"))
-                                      [App (Opn Minus)
-                                         [Var (Short "n");
-                                          Var (Short "m")]])
-                                   (App Opapp
-                                      [Var (Short "k"); Var (Short "t")]));
-                                (Pany,
-                                 App Opapp
-                                   [Var (Short "k"); Var (Short "t")])])];
-                       Lit (IntLit 0)]; Var (Short "ts'")]);
+                  Mat (Var (Short "ts'")) [
+                    (Pcon (SOME $ Short "[]") [],
+                      Let (SOME "t") (Con (SOME $ Short "SNum") [
+                          App (Opn Minus) [Lit $ IntLit 0; Var (Short "n")]]) $
+                        App Opapp [Var (Short "k"); Var (Short "t")]);
+                    (Pany, App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+                      Fun "t" $ Mat (Var (Short "t")) [
+                        (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                          Let (SOME "t") (Con (SOME $ Short "SNum") [
+                              App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
+                            App Opapp [Var (Short "k"); Var (Short "t")]);
+                        (Pany,
+                          App Opapp [Var (Short "k"); Var (Short "t")])
+                      ]];
+                      Lit $ IntLit 0]; Var (Short "ts'")])]);
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
@@ -760,6 +757,30 @@ Proof
       same_type_def, same_ctor_def, evaluate_match_def,
       pat_bindings_def]
     >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
+    >> Cases_on ‘t=[]’ >- (
+      gvs[vcons_list_def]
+      >> simp[Ntimes evaluate_def 3]
+      >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+        same_type_def, same_ctor_def, evaluate_match_def,
+        pat_bindings_def]
+      >> simp[Ntimes evaluate_def 6, do_app_def, do_con_check_def,
+        build_conv_def, nsOptBind_def, opn_lookup_def]
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[sminus_def, Once e_ce_rel_cases, Once ml_v_vals'_cases,
+        env_rel_cases, FEVERY_FEMPTY]
+    )
+    >> ‘∃ t' ts' . t'::ts'=t’ by (Cases_on ‘t’ >> gvs[])
+    >> simp[sminus_def]
+    >> first_assum $ simp_tac bool_ss o single o  GSYM
+    >> simp[Ntimes evaluate_def 3]
+    >> ‘∃ y ys . y::ys = t'’ by gvs[]
+    >> pop_assum $ simp_tac bool_ss o single o (fn x => Ntimes x 2) o GSYM
+    >> simp[vcons_list_def]
+    >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
+      same_type_def, same_ctor_def, evaluate_match_def,
+      pat_bindings_def]
+    >> pop_assum kall_tac
+    >> pop_assum kall_tac
     >> simp[Ntimes evaluate_def 3]
     >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
       same_type_def, same_ctor_def, evaluate_match_def,
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index d775d5e05c..4ec5418bd0 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -26,9 +26,11 @@ End
 
 Definition sminus_def:
   sminus [] = Exception $ strlit "Arity mismatch" ∧
-  sminus (SNum n :: xs) = (case sadd xs 0 of
-  | Val (SNum m) => Val (SNum (n - m))
-  | e => e) ∧
+  sminus (SNum n :: xs) = (case xs of
+  | [] => Val (SNum (-n))
+  | _::_ => (case sadd xs 0 of
+    | Val (SNum m) => Val (SNum (n - m))
+    | e => e)) ∧
   sminus _ = Exception $ strlit "Arith-op applied to non-number"
 End
 
@@ -144,7 +146,7 @@ End
 (*
   open scheme_semanticsTheory;
 
-  EVAL “steps 4 ([], [], Apply (Val (Prim SMinus)) [Val (SNum 2); Val (SNum 4)])”
+  EVAL “steps 10 ([], [], FEMPTY, Exp $ Apply (Lit (LitPrim SMinus)) [Lit (LitNum 4); Lit (LitNum 2)])”
   EVAL “steps 4 ([], [], Apply (Val (SNum 7)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
   EVAL “steps 2 ([], [], Cond (Val (SBool F)) (Val (SNum 2)) (Val (SNum 4)))”
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index b4599535eb..cedf9bfb6e 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -254,16 +254,22 @@ Definition scheme_basis4_def:
       (Pcon (SOME $ Short "::") [Pvar "t"; Pvar "ts'"],
         Mat (Var (Short "t")) [
           (Pcon (SOME $ Short "SNum") [Pvar "n"],
-            App Opapp [App Opapp [App Opapp [Var (Short "sadd");
-              Fun "t" $ Mat (Var (Short "t")) [
-                (Pcon (SOME $ Short "SNum") [Pvar "m"],
-                  Let (SOME "t") (Con (SOME $ Short "SNum") [
-                      App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
-                    App Opapp [Var (Short "k"); Var (Short "t")]);
-                (Pany,
-                  App Opapp [Var (Short "k"); Var (Short "t")])
-              ]];
-              Lit $ IntLit 0]; Var (Short "ts'")]);
+            Mat (Var (Short "ts'")) [
+              (Pcon (SOME $ Short "[]") [],
+                Let (SOME "t") (Con (SOME $ Short "SNum") [
+                    App (Opn Minus) [Lit $ IntLit 0; Var (Short "n")]]) $
+                  App Opapp [Var (Short "k"); Var (Short "t")]);
+              (Pany, App Opapp [App Opapp [App Opapp [Var (Short "sadd");
+                Fun "t" $ Mat (Var (Short "t")) [
+                  (Pcon (SOME $ Short "SNum") [Pvar "m"],
+                    Let (SOME "t") (Con (SOME $ Short "SNum") [
+                        App (Opn Minus) [Var (Short "n"); Var (Short "m")]]) $
+                      App Opapp [Var (Short "k"); Var (Short "t")]);
+                  (Pany,
+                    App Opapp [Var (Short "k"); Var (Short "t")])
+                ]];
+                Lit $ IntLit 0]; Var (Short "ts'")])
+            ]);
           (Pany,
             Con (SOME $ Short "Ex") [Lit $ StrLit "Arith-op applied to non-number"])
         ])

From 8d8af5bb557bffff24a3f533f1532bb890e35739 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 30 Apr 2025 01:28:51 +0100
Subject: [PATCH 092/100] value termination and divergence

---
 .../proofs/scheme_semanticsPropsScript.sml    |  35 ++
 .../proofs/scheme_to_cakeProofScript.sml      | 399 ++++++++++++------
 2 files changed, 305 insertions(+), 129 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index 9cf531807f..1bfe14ac3f 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -100,6 +100,11 @@ Inductive valid_state:
   valid_state store ks env (Exception s)
 End
 
+Definition terminating_state_def:
+  terminating_state (store, ks, env, e)
+    ⇔ (ks = [] ∧ ∃ v . e = Val v) ∨ (∃ ex . e = Exception ex)
+End
+
 Theorem FEVERY_MONO:
   ∀ P Q f .
     (∀ x . P x ⇒ Q x) ∧ FEVERY P f
@@ -864,6 +869,36 @@ Proof
   >> simp[step_def, Once valid_state_cases]
 QED
 
+Theorem terminating_direction:
+  ∀ store ks env e store' ks' env' e' .
+    step (store, ks, env, e) = (store', ks', env', e') ∧
+    ¬ terminating_state (store', ks', env', e')
+    ⇒
+    ¬ terminating_state (store, ks, env, e)
+Proof
+  simp[terminating_state_def]
+  >> rpt strip_tac
+  >> gvs[step_def, return_def]
+QED
+
+Theorem terminating_direction_n:
+  ∀ n store ks env e store' ks' env' e' .
+    FUNPOW step n (store, ks, env, e) = (store', ks', env', e') ∧
+    ¬ terminating_state (store', ks', env', e')
+    ⇒
+    ¬ terminating_state (store, ks, env, e)
+Proof
+  Induct
+  >> simp[FUNPOW_SUC]
+  >> rpt gen_tac
+  >> strip_tac
+  >> last_x_assum irule
+  >> Cases_on ‘FUNPOW step n (store,ks,env,e)’
+  >> PairCases_on ‘r’
+  >> drule_all_then assume_tac terminating_direction
+  >> simp[]
+QED
+
 Theorem scheme_divergence:
   ∀ store ks env state store' ks' env' state' .
     step (store, ks, env, state) = (store', ks', env', state') ∧
diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index f100ed24e4..268a6e840a 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -525,22 +525,35 @@ Proof
   >> simp[LIST_REL_SNOC]
 QED
 
+Definition eval_eq_def:
+  eval_eq st mlenv mle st' mlenv' mle' ck = ∀ start.
+    evaluate (st with clock := ck + start) mlenv [mle]
+    =
+    evaluate (st' with clock := start) mlenv' [mle']
+End
+
+Theorem eval_eq_trivial:
+  ∀ st mlenv mle .
+    eval_eq st mlenv mle st mlenv mle 0
+Proof
+  simp[eval_eq_def]
+QED
+
 Theorem preservation_of_sadd_body:
   ∀ vs mlvs .
     LIST_REL ml_v_vals' vs mlvs
     ⇒
-  ∀ store st env n k kv i .
+  ∀ store st env n k kv .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
     nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "sadd") = nsLookup scheme_env2.v (Short "sadd") ∧
-    env.c = scheme_env1.c ∧
-    i > 0
+    env.c = scheme_env1.c
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
-      evaluate (st with clock := ck) env
+      (∀ start . evaluate (st with clock := ck + start) env
         [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
              Let (SOME "t") (Con (SOME (Short "SNum")) [Var (Short "n")])
@@ -556,13 +569,12 @@ Theorem preservation_of_sadd_body:
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
-      evaluate st' mlenv' [mle'] ∧
+      evaluate (st' with clock := start) mlenv' [mle']) ∧
       cont_rel k kv' ∧
       e_ce_rel (sadd vs n) var' mlenv' kv' mle' ∧
       env_rel FEMPTY mlenv' ∧
       LIST_REL store_entry_rel store st'.refs ∧
-      st'.clock ≤ ck + i ∧
-      st'.clock < ck + i
+      st.ffi = st'.ffi
 Proof
   ho_match_mp_tac LIST_REL_ind
   >> simp[vcons_list_def, sadd_def]
@@ -573,7 +585,8 @@ Proof
       pat_bindings_def]
     >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
       nsOptBind_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> last_assum $ irule_at (Pos hd)
     >> simp[Once e_ce_rel_cases, sadd_def, Once ml_v_vals'_cases,
       env_rel_cases, FEVERY_FEMPTY]
@@ -589,6 +602,9 @@ Proof
     >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
     >> qrefine ‘ck+3’
     >> simp[Ntimes evaluate_def 2]
+    >> ‘st.ffi = (st with <|refs := st.refs; ffi := st.ffi|>).ffi’ by simp[]
+    >> first_assum $ once_asm_rewrite_tac o single
+    >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
     >> last_x_assum irule
     >> simp[]
     >> simp[Once INT_ADD_COMM]
@@ -599,7 +615,8 @@ Proof
     pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
   >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
   >> simp[sadd_def, Once e_ce_rel_cases]
-  >> irule_at (Pos hd) EQ_REFL
+  >> simp[GSYM eval_eq_def]
+  >> irule_at (Pos hd) eval_eq_trivial
   >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
   >> simp[env_rel_cases, FEVERY_FEMPTY]
 QED
@@ -608,18 +625,17 @@ Theorem preservation_of_smul_body:
   ∀ vs mlvs .
     LIST_REL ml_v_vals' vs mlvs
     ⇒
-  ∀ store st env n k kv i .
+  ∀ store st env n k kv .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
     nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "n") = SOME (Litv (IntLit n)) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "smul") = nsLookup scheme_env3.v (Short "smul") ∧
-    env.c = scheme_env1.c ∧
-    i > 0
+    env.c = scheme_env1.c
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
-      evaluate (st with clock := ck) env
+      (∀ start . evaluate (st with clock := ck + start) env
         [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
              Let (SOME "t") (Con (SOME (Short "SNum")) [Var (Short "n")])
@@ -635,13 +651,12 @@ Theorem preservation_of_smul_body:
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
-      evaluate st' mlenv' [mle'] ∧
+      evaluate (st' with clock := start) mlenv' [mle']) ∧
       cont_rel k kv' ∧
       e_ce_rel (smul vs n) var' mlenv' kv' mle' ∧
       env_rel FEMPTY mlenv' ∧
       LIST_REL store_entry_rel store st'.refs ∧
-      st'.clock ≤ ck + i ∧
-      st'.clock < ck + i
+      st.ffi = st'.ffi
 Proof
   ho_match_mp_tac LIST_REL_ind
   >> simp[vcons_list_def, smul_def]
@@ -652,7 +667,8 @@ Proof
       pat_bindings_def]
     >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
       nsOptBind_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> last_assum $ irule_at (Pos hd)
     >> simp[Once e_ce_rel_cases, smul_def, Once ml_v_vals'_cases,
       env_rel_cases, FEVERY_FEMPTY]
@@ -668,6 +684,9 @@ Proof
     >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
     >> qrefine ‘ck+3’
     >> simp[Ntimes evaluate_def 2]
+    >> ‘st.ffi = (st with <|refs := st.refs; ffi := st.ffi|>).ffi’ by simp[]
+    >> first_assum $ once_asm_rewrite_tac o single
+    >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
     >> last_x_assum irule
     >> simp[]
     >> simp[scheme_env2_def, Once INT_MUL_COMM]
@@ -678,7 +697,8 @@ Proof
     pat_bindings_def, do_con_check_def, build_conv_def, dec_clock_def]
   >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
   >> simp[smul_def, Once e_ce_rel_cases]
-  >> irule_at (Pos hd) EQ_REFL
+  >> simp[GSYM eval_eq_def]
+  >> irule_at (Pos hd) eval_eq_trivial
   >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
   >> simp[env_rel_cases, FEVERY_FEMPTY]
 QED
@@ -687,17 +707,16 @@ Theorem preservation_of_sminus_body:
   ∀ vs mlvs .
     LIST_REL ml_v_vals' vs mlvs
     ⇒
-  ∀ store (st:'ffi state) env n k kv i .
+  ∀ store (st:'ffi state) env n k kv .
     cont_rel k kv ∧
     LIST_REL store_entry_rel store st.refs ∧
     nsLookup env.v (Short "ts") = SOME (vcons_list mlvs) ∧
     nsLookup env.v (Short "k") = SOME kv ∧
     nsLookup env.v (Short "sadd") = nsLookup scheme_env3.v (Short "sadd") ∧
-    env.c = scheme_env1.c ∧
-    i > 0
+    env.c = scheme_env1.c
     ⇒
     ∃ck st' mlenv' var' kv' mle'.
-      evaluate (st with clock := ck) env
+      (∀ start . evaluate (st with clock := ck + start) env
         [Mat (Var (Short "ts"))
            [(Pcon (SOME (Short "[]")) [],
              Con (SOME (Short "Ex")) [Lit (StrLit "Arity mismatch")]);
@@ -722,12 +741,12 @@ Theorem preservation_of_sminus_body:
                 (Pany,
                  Con (SOME (Short "Ex"))
                    [Lit (StrLit "Arith-op applied to non-number")])])]] =
-      evaluate st' mlenv' [mle'] ∧
+      evaluate (st' with clock := start) mlenv' [mle']) ∧
       cont_rel k kv' ∧
       e_ce_rel (sminus vs) var' mlenv' kv' mle' ∧
-      env_rel FEMPTY mlenv'
-      ∧ LIST_REL store_entry_rel store st'.refs ∧
-      st'.clock ≤ ck + i ∧ st'.clock < ck + i
+      env_rel FEMPTY mlenv' ∧
+      LIST_REL store_entry_rel store st'.refs ∧
+      st.ffi = st'.ffi
 Proof
   Cases_on ‘vs’ >- (
     simp[vcons_list_def]
@@ -736,7 +755,8 @@ Proof
     >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
       same_type_def, same_ctor_def, evaluate_match_def,
       pat_bindings_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> last_assum $ irule_at (Pos hd)
     >> simp[sminus_def]
     >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
@@ -751,7 +771,6 @@ Proof
       same_type_def, same_ctor_def, evaluate_match_def,
       pat_bindings_def]
     >> rpt strip_tac
-    >> qrefine ‘ck+3’
     >> simp[Ntimes evaluate_def 3]
     >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
       same_type_def, same_ctor_def, evaluate_match_def,
@@ -765,10 +784,12 @@ Proof
         pat_bindings_def]
       >> simp[Ntimes evaluate_def 6, do_app_def, do_con_check_def,
         build_conv_def, nsOptBind_def, opn_lookup_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[sminus_def, Once e_ce_rel_cases, Once ml_v_vals'_cases,
         env_rel_cases, FEVERY_FEMPTY]
     )
+    >> qrefine ‘ck+3’
     >> ‘∃ t' ts' . t'::ts'=t’ by (Cases_on ‘t’ >> gvs[])
     >> simp[sminus_def]
     >> first_assum $ simp_tac bool_ss o single o  GSYM
@@ -788,11 +809,6 @@ Proof
     >> simp[Ntimes evaluate_def 7, do_opapp_def]
     >> simp[Ntimes find_recfun_def 2, Ntimes build_rec_env_def 2]
     >> simp[Ntimes evaluate_def 2, dec_clock_def]
-    >> ‘∃ i'' . i' + 3 = i''’ by simp[]
-    >> pop_assum mp_tac >> strip_tac
-    >> ‘i'' > 0’ by simp[]
-    >> qpat_x_assum ‘i' > 0’ kall_tac
-    >> qpat_x_assum ‘i' + 3 = i''’ $ simp o single
     >> simp[sminus_def]
     >> ‘∃ n . 0i = n’ by simp[]
     >> pop_assum mp_tac >> strip_tac
@@ -835,7 +851,8 @@ Proof
         pat_bindings_def]
       >> simp[Ntimes evaluate_def 6, do_app_def, do_con_check_def,
         build_conv_def, nsOptBind_def, opn_lookup_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[env_rel_cases, FEVERY_FEMPTY]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
@@ -851,6 +868,11 @@ Proof
       >> qrefine ‘ck+3’
       >> simp[Ntimes evaluate_def 2]
       >> simp[Once INT_ADD_COMM]
+      >> ‘st.ffi = (st with <|refs := st.refs; ffi := st.ffi|>).ffi’ by simp[]
+      >> first_assum $ once_asm_rewrite_tac o single
+      >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
+      >> last_x_assum irule
+      >> simp[]
     )
     >> simp[sadd_def, vcons_list_def]
     >> simp[Ntimes evaluate_def 3]
@@ -861,7 +883,8 @@ Proof
     >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
       same_type_def, same_ctor_def, evaluate_match_def,
       pat_bindings_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> simp[env_rel_cases, FEVERY_FEMPTY]
     >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
     >> simp[Once e_ce_rel_cases]
@@ -876,14 +899,15 @@ Proof
   >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
     same_type_def, same_ctor_def, evaluate_match_def,
     pat_bindings_def]
-  >> irule_at (Pos hd) EQ_REFL
+  >> simp[GSYM eval_eq_def]
+  >> irule_at (Pos hd) eval_eq_trivial
   >> simp[env_rel_cases, FEVERY_FEMPTY]
   >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
   >> simp[Once e_ce_rel_cases]
 QED
 
 Theorem preservation_of_proc:
-∀ (st:'ffi state) inner n n' m m' env env' mlenv var kv n xs xp e e' ce k args vs mlvs store store' i .
+∀ (st:'ffi state) inner n n' m m' env env' mlenv var kv n xs xp e e' ce k args vs mlvs store store' .
   valid_val store (Proc env xs xp e) ∧
   LIST_REL ml_v_vals' vs mlvs ∧
   EVERY (valid_val store) vs ∧
@@ -898,18 +922,16 @@ Theorem preservation_of_proc:
   env_rel env mlenv ∧
   scheme_env mlenv ∧
   can_lookup env store ∧
-  LIST_REL store_entry_rel store st.refs ∧
-  i > 0
+  LIST_REL store_entry_rel store st.refs
   ⇒
   ∃ck st' mlenv' var' kv' mle'.
-    evaluate (st with clock := ck) mlenv [inner]
-      = evaluate st' mlenv' [mle'] ∧
+    (∀ start . evaluate (st with clock := ck + start) mlenv [inner]
+      = evaluate (st' with clock := start) mlenv' [mle']) ∧
     cont_rel k kv' ∧
     e_ce_rel e' var' mlenv' kv' mle' ∧
     env_rel env' mlenv' ∧
     LIST_REL store_entry_rel store' st'.refs ∧
-    st'.clock ≤ ck + i ∧
-    st'.clock < ck + i
+    st.ffi = st'.ffi
 Proof
   Induct_on ‘xs’
   >> rpt strip_tac
@@ -925,7 +947,8 @@ Proof
         >> qpat_assum ‘scheme_env mlenv’ $ simp o single
           o SRULE [scheme_env_def]
         >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
       )
       >> simp[Ntimes evaluate_def 3]
@@ -934,7 +957,8 @@ Proof
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
       >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases]
       >> simp[env_rel_cases, FEVERY_FEMPTY]
     )
@@ -950,7 +974,8 @@ Proof
       pmatch_def, do_con_check_def, build_conv_def, nsOptBind_def]
     >> qpat_assum ‘scheme_env mlenv’ $ simp o single
       o SRULE [scheme_env_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> simp[]
     >> rpt (pairarg_tac >> gvs[])
     >> gvs[fresh_loc_def, store_entry_rel_cases]
@@ -990,7 +1015,8 @@ Proof
     >> qpat_assum ‘scheme_env mlenv’ $ simp o single
       o SRULE [scheme_env_def]
     >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> simp[Once e_ce_rel_cases]
     >> simp[env_rel_cases, FEVERY_FEMPTY]
   )
@@ -1006,6 +1032,11 @@ Proof
   >> qpat_assum ‘scheme_env mlenv’ $ simp o single
     o SRULE [scheme_env_def]
   >> simp[same_type_def, same_ctor_def, pat_bindings_def]
+  >> ‘st.ffi = (st with <|refs :=
+                  st.refs ++ [Refv (Conv (SOME (TypeStamp "Some" 2)) [y])];
+                ffi := st.ffi|>).ffi’ by simp[]
+  >> first_assum $ once_asm_rewrite_tac o single
+  >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
   >> last_x_assum irule
   >> simp[]
   >> rpt (pairarg_tac >> gvs[])
@@ -1090,20 +1121,22 @@ Theorem preservation_of_letrec:
     scheme_env mlenv
     ⇒
     ∃ ck st' mlenv' var' .
-      evaluate (st with clock:=ck) mlenv [letinit_ml xs inner]
-        = evaluate st' mlenv' [inner] ∧
+      (∀ start . evaluate (st with clock:=ck+start) mlenv [letinit_ml xs inner]
+        = evaluate (st' with clock:=start) mlenv' [inner]) ∧
       env_rel env' mlenv' ∧
       LIST_REL store_entry_rel store' st'.refs ∧
-      st'.clock ≤ ck ∧
       (∀ x v . (∀ x' . x ≠ "var" ++ x') ∧ nsLookup mlenv.v (Short x) = SOME v
       ⇒
       nsLookup mlenv'.v (Short x) = SOME v) ∧
-      scheme_env mlenv'
+      scheme_env mlenv' ∧
+      st.ffi = st'.ffi
 Proof
   Induct
   >> simp[letrec_init_def, letinit_ml_def]
   >> rpt strip_tac >- (
-    irule_at (Pos hd) EQ_REFL >> simp[]
+    simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
+    >> simp[]
   )
   >> rpt (pairarg_tac >> gvs[])
   >> simp[Ntimes evaluate_def 3, do_con_check_def, build_conv_def,
@@ -1126,6 +1159,11 @@ Proof
         ’ >- (
     strip_tac
     >> pop_assum $ simp_tac pure_ss o single o GSYM
+    >> ‘st.ffi = (st with <|refs :=
+                    st.refs ++ [Refv (Conv (SOME (TypeStamp "None" 2)) [])];
+                  ffi := st.ffi|>).ffi’ by simp[]
+    >> first_assum $ once_asm_rewrite_tac o single
+    >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
     >> last_x_assum $ irule
     >> simp[]
     >> strip_tac >- gvs[scheme_env_def]
@@ -1172,21 +1210,23 @@ Theorem step_preservation:
   LIST_REL store_entry_rel store st.refs
   ⇒
   ∃ ck st' mlenv' var' kv' mle' .
-    evaluate (st with clock:=ck) mlenv [mle]
+    (∀ start . evaluate (st with clock := start + ck) mlenv [mle]
     =
-    evaluate st' mlenv' [mle'] ∧
+    evaluate (st' with clock := start) mlenv' [mle']) ∧
     cont_rel k' kv' ∧
     e_ce_rel e' var' mlenv' kv' mle' ∧
     env_rel env' mlenv' ∧
     LIST_REL store_entry_rel store' st'.refs ∧
-    st'.clock ≤ ck ∧
-    (k ≠ [] ∧ (∀ s . e ≠ Exception s) ⇒ st'.clock < ck)
+    (¬ terminating_state (store', k', env', e') ⇒ 0 < ck) ∧
+    st.ffi = st'.ffi
 Proof
   Cases_on ‘e’
+  >> simp[terminating_state_def]
   >~ [‘Exception s’] >- (
     simp[step_def, Once e_ce_rel_cases]
     >> rpt strip_tac
-    >> irule_at (Pos hd) EQ_REFL
+    >> simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
     >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
     >> qexists ‘scheme_env7’
     >> simp[scheme_env_def]
@@ -1207,7 +1247,8 @@ Proof
         do_con_check_def, build_conv_def, nsOptBind_def, dec_clock_def]
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
       >> gvs[env_rel_cases]
     )
@@ -1217,7 +1258,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
     )
@@ -1227,7 +1269,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
     )
@@ -1238,7 +1281,8 @@ Proof
         qrefine ‘ck+1’
         >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
           nsOptBind_def, dec_clock_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
         >> gvs[scheme_env_def, env_rel_cases]
@@ -1246,7 +1290,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
     )
@@ -1259,7 +1304,8 @@ Proof
         build_conv_def]
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> last_assum $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
       >> gvs[scheme_env_def, env_rel_cases]
@@ -1290,7 +1336,8 @@ Proof
       >> qpat_assum ‘scheme_env mlenv’ $ simp o single
         o SRULE [scheme_env_def]
       >> simp[same_type_def, same_ctor_def, pat_bindings_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
@@ -1302,7 +1349,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
     )
@@ -1328,7 +1376,8 @@ Proof
           [cps_transform (Begin (MAP (UNCURRY Set) bs) e);
            Var (Short "k")]’ mp_tac
       >> rpt strip_tac
-      >> qpat_assum ‘evaluate _ _ _ = _’ $ irule_at (Pos hd)
+      >> gvs[GSYM eval_eq_def]
+      >> first_assum $ irule_at (Pos hd)
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
     )
@@ -1338,7 +1387,8 @@ Proof
     >- (
       simp[step_def, return_def]
       >> rw[]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[env_rel_cases, FEVERY_FEMPTY]
       >> metis_tac[]
     )
@@ -1358,7 +1408,8 @@ Proof
           same_type_def, same_ctor_def, do_opapp_def,
           evaluate_match_def, pmatch_def, pat_bindings_def]
         o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> gvs[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases]
@@ -1373,13 +1424,15 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
         nsOptBind_def, dec_clock_def] >- (
-        irule_at (Pos hd) EQ_REFL
+        simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
         >> gvs[scheme_env_def, env_rel_cases]
       )
       >> simp[SimpLHS, Ntimes evaluate_def 2, nsOptBind_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> gvs[scheme_env_def, env_rel_cases]
     )
@@ -1406,7 +1459,8 @@ Proof
         do_app_def, store_assign_def, store_v_same_type_def]
       >> qpat_assum ‘scheme_env _’ $ simp o single
         o SRULE [scheme_env_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[]
       >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
       >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
@@ -1422,7 +1476,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> simp[cps_app_ts_def]
       >> gvs[scheme_env_def, env_rel_cases]
@@ -1435,7 +1490,8 @@ Proof
       >> qrefine ‘ck+1’
       >> simp[Ntimes evaluate_def 6, do_opapp_def,
         nsOptBind_def, dec_clock_def]
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
       >> simp[PULL_EXISTS]
       >> irule_at (Pos hd) EQ_REFL
@@ -1483,7 +1539,8 @@ Proof
       >~ [‘Litv (IntLit i)’] >- (
         qrefine ‘ck+1’
         >> simp[Once evaluate_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1493,7 +1550,8 @@ Proof
       ])’] >- (
         qrefine ‘ck+1’
         >> simp[Once evaluate_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1503,7 +1561,8 @@ Proof
       ])’] >- (
         qrefine ‘ck+1’
         >> simp[Once evaluate_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1511,7 +1570,8 @@ Proof
       >~ [‘SOME (Conv (SOME (TypeStamp "SList" _)) [_])’] >- (
         qrefine ‘ck+1’
         >> simp[Once evaluate_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1519,7 +1579,8 @@ Proof
       >~ [‘SOME (Conv (SOME (TypeStamp "Wrong" _)) [_])’] >- (
         qrefine ‘ck+1’
         >> simp[Once evaluate_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[Once e_ce_rel_cases]
         >> last_assum $ irule_at (Pos hd)
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1536,7 +1597,8 @@ Proof
         qrefine ‘ck+1’
         >> simp[Ntimes evaluate_def 3, nsOptBind_def,
           do_con_check_def, build_conv_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> last_assum $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1545,7 +1607,8 @@ Proof
         qrefine ‘ck+1’
         >> simp[Ntimes evaluate_def 3, nsOptBind_def,
           do_con_check_def, build_conv_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> last_assum $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
         >> simp[env_rel_cases, FEVERY_FEMPTY]
@@ -1569,7 +1632,8 @@ Proof
         >> strip_tac
         >> gvs[env_rel_cases]
       )
-      >> irule_at (Pos hd) EQ_REFL
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
       >> simp[Once e_ce_rel_cases]
       >> simp[env_rel_cases, FEVERY_FEMPTY]
       >> last_assum $ irule_at Any
@@ -1697,7 +1761,8 @@ Proof
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
-            >> irule_at (Pos hd) EQ_REFL
+            >> simp[GSYM eval_eq_def]
+            >> irule_at (Pos hd) eval_eq_trivial
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
             >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
           )
@@ -1726,7 +1791,8 @@ Proof
                   same_type_def, same_ctor_def, evaluate_match_def,
                   pat_bindings_def, do_con_check_def, build_conv_def,
                   do_eq_def, lit_same_type_def]
-                >> irule_at (Pos hd) EQ_REFL
+                >> simp[GSYM eval_eq_def]
+                >> irule_at (Pos hd) eval_eq_trivial
                 >> simp[env_rel_cases, FEVERY_FEMPTY]
                 >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
                 >> Cases_on ‘i=i'’
@@ -1739,7 +1805,8 @@ Proof
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def, do_con_check_def, build_conv_def]
-              >> irule_at (Pos hd) EQ_REFL
+              >> simp[GSYM eval_eq_def]
+              >> irule_at (Pos hd) eval_eq_trivial
               >> simp[env_rel_cases, FEVERY_FEMPTY]
               >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
               >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
@@ -1758,7 +1825,8 @@ Proof
                   same_type_def, same_ctor_def, evaluate_match_def,
                   pat_bindings_def, do_con_check_def, build_conv_def,
                   do_eq_def, lit_same_type_def, ctor_same_type_def]
-                >> irule_at (Pos hd) EQ_REFL
+                >> simp[GSYM eval_eq_def]
+                >> irule_at (Pos hd) eval_eq_trivial
                 >> simp[env_rel_cases, FEVERY_FEMPTY]
                 >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
                 >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
@@ -1770,7 +1838,8 @@ Proof
               >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
                 same_type_def, same_ctor_def, evaluate_match_def,
                 pat_bindings_def, do_con_check_def, build_conv_def]
-              >> irule_at (Pos hd) EQ_REFL
+              >> simp[GSYM eval_eq_def]
+              >> irule_at (Pos hd) eval_eq_trivial
               >> simp[env_rel_cases, FEVERY_FEMPTY]
               >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
               >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases,
@@ -1782,7 +1851,8 @@ Proof
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def, do_con_check_def, build_conv_def]
-            >> irule_at (Pos hd) EQ_REFL
+            >> simp[GSYM eval_eq_def]
+            >> irule_at (Pos hd) eval_eq_trivial
             >> simp[env_rel_cases, FEVERY_FEMPTY]
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
             >> simp[Once e_ce_rel_cases, Once ml_v_vals'_cases]
@@ -1796,7 +1866,8 @@ Proof
           >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
             same_type_def, same_ctor_def, evaluate_match_def,
             pat_bindings_def]
-          >> irule_at (Pos hd) EQ_REFL
+          >> simp[GSYM eval_eq_def]
+          >> irule_at (Pos hd) eval_eq_trivial
           >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
           >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
         )
@@ -1825,7 +1896,8 @@ Proof
               pat_bindings_def]
             >> simp[Ntimes evaluate_def 5, do_con_check_def, build_conv_def,
               nsOptBind_def]
-            >> irule_at (Pos hd) EQ_REFL
+            >> simp[GSYM eval_eq_def]
+            >> irule_at (Pos hd) eval_eq_trivial
             >> simp[env_rel_cases, FEVERY_FEMPTY]
             >> simp[Once cont_rel_cases]
             >> gvs[cps_transform_def, cps_app_ts_def]
@@ -1846,7 +1918,8 @@ Proof
           >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
             same_type_def, same_ctor_def, evaluate_match_def,
             pat_bindings_def]
-          >> irule_at (Pos hd) EQ_REFL
+          >> simp[GSYM eval_eq_def]
+          >> irule_at (Pos hd) eval_eq_trivial
           >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
           >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
         )
@@ -1868,7 +1941,8 @@ Proof
             >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
               same_type_def, same_ctor_def, evaluate_match_def,
               pat_bindings_def]
-            >> irule_at (Pos hd) EQ_REFL
+            >> simp[GSYM eval_eq_def]
+            >> irule_at (Pos hd) eval_eq_trivial
             >> simp[env_rel_cases, FEVERY_FEMPTY]
             >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
             >> simp[Once e_ce_rel_cases]
@@ -1882,7 +1956,8 @@ Proof
           >> simp[can_pmatch_all_def, pmatch_def, nsLookup_def,
             same_type_def, same_ctor_def, evaluate_match_def,
             pat_bindings_def]
-          >> irule_at (Pos hd) EQ_REFL
+          >> simp[GSYM eval_eq_def]
+          >> irule_at (Pos hd) eval_eq_trivial
           >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
           >> simp[Once e_ce_rel_cases, env_rel_cases, FEVERY_FEMPTY]
         )
@@ -1893,7 +1968,8 @@ Proof
           pat_bindings_def]
         >> simp[Once evaluate_def, do_opapp_def, dec_clock_def,
           do_con_check_def, build_conv_def]
-        >> irule_at (Pos hd) EQ_REFL
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
         >> simp[env_rel_cases, FEVERY_FEMPTY]
         >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
         >> simp[Once e_ce_rel_cases]
@@ -1918,7 +1994,6 @@ Proof
   )
 QED
 
-(*
 Theorem steps_preservation:
   ∀ n store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   FUNPOW step n (store, k, env, e) = (store', k', env', e') ∧
@@ -1929,22 +2004,21 @@ Theorem steps_preservation:
   LIST_REL store_entry_rel store st.refs
   ⇒
   ∃ ck st' mlenv' var' kv' mle' .
-    evaluate (st with clock:=ck) mlenv [mle]
+    (∀ start . evaluate (st with clock := start + ck) mlenv [mle]
     =
-    evaluate st' mlenv' [mle'] ∧
+    evaluate (st' with clock := start) mlenv' [mle']) ∧
     cont_rel k' kv' ∧
     e_ce_rel e' var' mlenv' kv' mle' ∧
     env_rel env' mlenv' ∧
     LIST_REL store_entry_rel store' st'.refs ∧
-    st'.clock ≤ ck ∧
-    (n > 0 ∧ k ≠ [] ∧ (∀ s . e ≠ Exception s) ⇒ st'.clock < ck)
+    (¬ terminating_state (store', k', env', e') ⇒ n ≤ ck) ∧
+    st.ffi = st'.ffi
 Proof
   Induct >- (
-    simp[]
+    simp[terminating_state_def]
     >> rpt strip_tac
-    >> irule_at (Pos hd) EQ_REFL
-    >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
-    >> qpat_assum ‘e_ce_rel _ _ _ _ _’ $ irule_at (Pos hd)
+    >> rpt $ pop_assum $ irule_at Any
+    >> qexists ‘0’
     >> simp[]
   )
   >> simp[FUNPOW]
@@ -1956,9 +2030,15 @@ Proof
   >> pop_assum $ drule_then assume_tac
   >> drule_all step_preservation
   >> rpt strip_tac
-  >> qpat_assum ‘∀ _ _ _ _ _ . _ ⇒ _’ drule_all
+  >> qpat_x_assum ‘∀ _ _ _ _ _ . _ ⇒ _’ drule_all
   >> rpt strip_tac
+  >> qexists ‘ck + ck'’
+  >> gvs[SF SFY_ss]
+  >> rpt $ first_assum $ irule_at Any
   >> simp[]
+  >> strip_tac
+  >> gvs[]
+  >> drule_all_then assume_tac terminating_direction_n
   >> gvs[]
 QED
 
@@ -1973,35 +2053,96 @@ Theorem value_terminating:
     ⇒
     ∃ ck st' mlv . evaluate (st with clock:=ck) mlenv [mle]
       = (st', Rval [mlv]) ∧
-    ml_v_vals' v mlv
+    ml_v_vals' v mlv ∧
+    st.ffi = st'.ffi
 Proof
-  Induct_on ‘n’
-  >> simp[FUNPOW]
-  >> rpt strip_tac >- (
-    gvs[Once e_ce_rel_cases, Once cont_rel_cases]
-    >> qrefine ‘ck+1’
-    >> simp[evaluate_def, do_opapp_def]
-  )
-  >> drule valid_state_progress
-  >> strip_tac
+  rpt strip_tac
+  >> drule_all steps_preservation
+  >> rpt strip_tac
+  >> first_x_assum $ qspec_then ‘1’ $ assume_tac
+  >> qexists ‘1 + ck’
+  >> irule_at (Pos hd) EQ_TRANS
+  >> pop_assum $ irule_at (Pos hd)
+  >> qpat_x_assum ‘_ (Val v) _ _ _ _’ mp_tac
+  >> simp[Once e_ce_rel_cases]
+  >> rpt strip_tac
   >> gvs[]
-  >> drule_all step_preservation
-  >> strip_tac
-  >> last_x_assum $ drule_all
-  >> strip_tac
+  >> qpat_x_assum ‘cont_rel [] _’ mp_tac
+  >> simp[Once cont_rel_cases]
+  >> rpt strip_tac
+  >> gvs[]
+  >> simp[evaluate_def, do_opapp_def, dec_clock_def]
+QED
+
+Theorem evaluate_timeout_smaller_clock:
+  ∀ ck ck' st' (st:'ffi state) env e .
+    evaluate (st with clock := ck) env [e] = (st', Rerr (Rabort Rtimeout_error)) ∧
+    ck' ≤ ck
+    ⇒
+    ∃ st'' . evaluate (st with clock := ck') env [e] = (st'', Rerr (Rabort Rtimeout_error))
+Proof
+  rpt strip_tac
+  >> ‘∃ i . ck = ck' + i’ by (qexists ‘ck - ck'’ >> simp[])
+  >> qpat_x_assum ‘_ ≤ _’ kall_tac
+  >> gvs[]
+  >> spose_not_then assume_tac
+  >> Cases_on ‘evaluate (st with clock := ck') env [e]’
+  >> gvs[]
+  >> drule_all_then assume_tac evaluate_add_to_clock
+  >> gvs[]
+QED
+
+Theorem cps_val:
+  ∀ st env e . ∃ mle .
+    evaluate st env [cps_transform e] = (st, Rval [Closure env "k" mle])
+Proof
+  Cases_on ‘e’
+  >> simp[cps_transform_def, evaluate_def]
 QED
-*)
 
-(*Theorem val_correct:
-  ∀ n . ∃ k . SND (evaluate <| clock := k |> myEnv [scheme_program_to_cake (Val (SNum n))])
-    = Rval [Conv (SOME $ TypeStamp "SNum" 0) [Litv $ IntLit n]]
+Theorem diverges:
+  ∀ e v mle mlv store store' ks env (st:'ffi state) mlenv var kv .
+    (∀ n . ¬ terminating_state (FUNPOW step n (store, ks, env, e))) ∧
+    valid_state store ks env e ∧
+    e_ce_rel e var mlenv kv mle ∧
+    cont_rel ks kv ∧
+    env_rel env mlenv ∧
+    LIST_REL store_entry_rel store st.refs
+    ⇒
+    ∀ ck . ∃ st' . evaluate (st with clock:=ck) mlenv [mle]
+      = (st', Rerr (Rabort Rtimeout_error)) ∧
+      st.ffi = st'.ffi
 Proof
-  strip_tac
-  >> qexists_tac ‘99’
-  >> rw[scheme_program_to_cake_def, cps_transform_def, myEnv_def, myC_def,
-    to_ml_vals_def,
-    Once evaluate_def, do_opapp_def, dec_clock_def,
-    nsLookup_def, nsBind_def, do_con_check_def, build_conv_def]
-QED*)
+  rpt strip_tac
+  >> last_x_assum $ qspec_then ‘ck’ assume_tac
+  >> Cases_on ‘FUNPOW step ck (store,ks,env,e)’
+  >> PairCases_on ‘r’
+  >> drule_all steps_preservation
+  >> rpt strip_tac
+  >> gvs[]
+  >> qpat_x_assum ‘∀ _._=_’ $ qspec_then ‘0’ assume_tac
+  >> qpat_x_assum ‘e_ce_rel _ _ _ _ mle'’ $ assume_tac o SRULE [Once e_ce_rel_cases]
+  >> gvs[terminating_state_def]
+  >> qpat_x_assum ‘cont_rel _ kv'’ $ assume_tac o SRULE [Once cont_rel_cases]
+  >> qspecl_then [‘st' with clock:=0’,‘mlenv'’,‘e'’] mp_tac cps_val
+  >> strip_tac
+  >> gvs[evaluate_def, do_opapp_def]
+  >> drule_all evaluate_timeout_smaller_clock
+  >> strip_tac
+  >> simp[]
+  >> rpt $ last_assum $ irule_at Any
+  >> qpat_assum ‘st.ffi = _’ $ simp o single o GSYM o Once
+  >> irule io_events_mono_antisym
+  >> drule_then assume_tac $ cj 1 evaluate_io_events_mono_imp
+  >> gvs[]
+  >> rev_drule_then assume_tac (
+    cj 4 $ SRULE [PULL_FORALL] $ cj 6 $
+    SRULE [is_clock_io_mono_def, pair_CASE_eq_forall] $
+      cj 1 is_clock_io_mono_evaluate
+  )
+  >> gvs[]
+  >> pop_assum $ drule_then assume_tac
+  >> gvs[]
+QED
 
 val _ = export_theory();
\ No newline at end of file

From db690751aa3c073fbd27abf01572a68a0f2be98f Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Wed, 30 Apr 2025 01:36:12 +0100
Subject: [PATCH 093/100] tweak scheme semantics divergence theorem

---
 compiler/scheme/proofs/scheme_semanticsPropsScript.sml | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index 1bfe14ac3f..a907fcb2ff 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -902,13 +902,12 @@ QED
 Theorem scheme_divergence:
   ∀ store ks env state store' ks' env' state' .
     step (store, ks, env, state) = (store', ks', env', state') ∧
-    (ks = [] ⇒ ∀ v  . state ≠ Val v) ∧
-    (∀ s . state ≠ Exception s)
+    ¬ terminating_state (store, ks, env, state)
     ⇒
     (store, ks, env, state) ≠ (store', ks', env', state')
 Proof
   Cases_on ‘state’
-  >> simp[]
+  >> simp[terminating_state_def]
   >~ [‘Exp e’] >- (
     Cases_on ‘e’
     >> simp[step_def] >- (

From 427d3093507cfdf6f90ff084775f59c91bd36670 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Mon, 26 May 2025 11:15:29 +0100
Subject: [PATCH 094/100] developer lint Scheme

---
 compiler/scheme/Holmakefile             | 6 +++---
 compiler/scheme/examples/readmePrefix   | 1 -
 compiler/scheme/unverified/readmePrefix | 1 -
 developers/build-sequence               | 6 ++++++
 4 files changed, 9 insertions(+), 5 deletions(-)
 delete mode 100644 compiler/scheme/examples/readmePrefix
 delete mode 100644 compiler/scheme/unverified/readmePrefix

diff --git a/compiler/scheme/Holmakefile b/compiler/scheme/Holmakefile
index 4fe6e61bb5..4f9d1adf09 100644
--- a/compiler/scheme/Holmakefile
+++ b/compiler/scheme/Holmakefile
@@ -10,9 +10,9 @@ all: $(DEFAULT_TARGETS) README.md
 .PHONY: all
 
 README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml)
-# Filter out tests/ (they don't have a readmePrefix)
-DIRS = $(patsubst tests/,,$(wildcard */))
-README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
+# Filter out unverified/ (they don't have a readmePrefix)
+DIRS = $(patsubst examples/,,$(patsubst unverified/,,$(wildcard */)))
+README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix unverified/README.md examples/README.md $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES)
 	$(CAKEMLDIR)/developers/readme_gen $(README_SOURCES)
 
 ifdef POLY
diff --git a/compiler/scheme/examples/readmePrefix b/compiler/scheme/examples/readmePrefix
deleted file mode 100644
index 3ca08042a5..0000000000
--- a/compiler/scheme/examples/readmePrefix
+++ /dev/null
@@ -1 +0,0 @@
-Example Scheme programs compiled using the Scheme compiler
diff --git a/compiler/scheme/unverified/readmePrefix b/compiler/scheme/unverified/readmePrefix
deleted file mode 100644
index 76a54b1ed3..0000000000
--- a/compiler/scheme/unverified/readmePrefix
+++ /dev/null
@@ -1 +0,0 @@
-An unverified compiler from Scheme to ML written in Haskell
diff --git a/developers/build-sequence b/developers/build-sequence
index 2c8fa267a2..fc04147d88 100644
--- a/developers/build-sequence
+++ b/developers/build-sequence
@@ -114,6 +114,12 @@ compiler/dafny/translation
 compiler/dafny/compilation
 compiler/dafny/semantics
 
+# Scheme compiler
+compiler/scheme
+compiler/scheme/translation
+compiler/scheme/compilation
+compiler/scheme/proofs
+
 # examples and tests
 characteristic/examples
 tutorial/solutions

From 0a048c080ea7bdcbe2b2ed9c9c8fb36d1fe9357a Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Tue, 27 May 2025 00:50:00 +0100
Subject: [PATCH 095/100] parse call/cc correctly

---
 compiler/scheme/examples/Makefile        |  5 +++-
 compiler/scheme/examples/facimp.scm      |  2 +-
 compiler/scheme/examples/fib.scm         |  7 +++++
 compiler/scheme/examples/nondet.scm      | 37 ++++++++++++++++++++++++
 compiler/scheme/examples/tailfib.scm     |  5 ++++
 compiler/scheme/scheme_parsingScript.sml |  2 +-
 6 files changed, 55 insertions(+), 3 deletions(-)
 create mode 100644 compiler/scheme/examples/fib.scm
 create mode 100644 compiler/scheme/examples/nondet.scm
 create mode 100644 compiler/scheme/examples/tailfib.scm

diff --git a/compiler/scheme/examples/Makefile b/compiler/scheme/examples/Makefile
index a79131339f..5fac3c5129 100644
--- a/compiler/scheme/examples/Makefile
+++ b/compiler/scheme/examples/Makefile
@@ -1,4 +1,3 @@
-all: hi.cake$(SUFF)
 .PHONY: all clean
 
 OS ?= $(shell uname)
@@ -21,12 +20,16 @@ ifeq ($(OS),Darwin)
 	EVALFLAG =
 endif
 
+ALL = $(patsubst %.scm,%.cake$(SUFF),$(wildcard *.scm))
+
 CFLAGS+=-O2
 LDLIBS+=-lm
 
 ARCH=x64
 WORD_SIZE=64
 
+all: $(ALL)
+
 %.cake.S: %.scm cake scheme_compiler$(SUFF)
 	cat $< | $(PREF)scheme_compiler$(SUFF) | $(PREF)cake$(SUFF) $(CAKEOPT) > $@
 
diff --git a/compiler/scheme/examples/facimp.scm b/compiler/scheme/examples/facimp.scm
index 859499b8b2..868f28093e 100644
--- a/compiler/scheme/examples/facimp.scm
+++ b/compiler/scheme/examples/facimp.scm
@@ -1,4 +1,4 @@
 (letrec ((fac (lambda (x)
   (letrec ((st 0) (acc 1)) (begin
-    (callcc (lambda (k) (set! st k)))
+    (call/cc (lambda (k) (set! st k)))
     (if (eqv? x 0) acc (st (begin (set! acc ( * acc x)) (set! x (- x 1)))))))))) (fac 6))
diff --git a/compiler/scheme/examples/fib.scm b/compiler/scheme/examples/fib.scm
new file mode 100644
index 0000000000..569499e5a6
--- /dev/null
+++ b/compiler/scheme/examples/fib.scm
@@ -0,0 +1,7 @@
+(letrec
+    ((fib (lambda (n)
+              (if (eqv? n 0) n
+                   (if (eqv? n 1) n
+                       (+ (fib (- n 1))
+                          (fib (- n 2))))))))
+    (fib 30))
diff --git a/compiler/scheme/examples/nondet.scm b/compiler/scheme/examples/nondet.scm
new file mode 100644
index 0000000000..971ad9ffe6
--- /dev/null
+++ b/compiler/scheme/examples/nondet.scm
@@ -0,0 +1,37 @@
+(letrec
+    ((nondet
+      (lambda (fun)
+          (call/cc
+           (lambda (cc)
+               (letrec
+                   ((fail (lambda () (cc (- 1))))
+                    (choose
+                     (lambda (f n m)
+                         (letrec
+                             ((i n)
+                              (last fail))
+                             (begin
+                              (call/cc
+                               (lambda (cc) (set! fail (lambda () (begin (set! i (+ i 1)) (cc (- 1)))))))
+                              (if (eqv? i m)
+                                  (begin (set! fail last) (fail))
+                                  (f i)))))))
+                   (fun choose (lambda () (fail))))))))
+
+     (triangle
+      (lambda (n)
+          (if (eqv? n 0) n
+              (+ n (triangle (- n 1))))))
+     (fib
+      (lambda (n)
+          (if (eqv? n 0) n
+              (if (eqv? n 1) n
+                  (+ (fib (- n 1))
+                     (fib (- n 2))))))))
+
+    ;(display
+     (nondet
+      (lambda (choose fail)
+          (letrec ((x (choose triangle 3 10))
+                   (y (choose fib 3 10)))
+              (if (eqv? x y) x (fail))))));)
diff --git a/compiler/scheme/examples/tailfib.scm b/compiler/scheme/examples/tailfib.scm
new file mode 100644
index 0000000000..39a90854ed
--- /dev/null
+++ b/compiler/scheme/examples/tailfib.scm
@@ -0,0 +1,5 @@
+(letrec
+    ((fib (lambda (n a b)
+              (if (eqv? n 0) a
+                  (fib (- n 1) (+ a b) a)))))
+    (fib 35 0 1))
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index 688cfa7c79..73da40e4b7 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -216,7 +216,7 @@ Definition cons_ast_def:
     if w = "-" then INR (Lit (LitPrim SMinus)) else
     if w = "*" then INR (Lit (LitPrim SMul)) else
     if w = "eqv?" then INR (Lit (LitPrim SEqv)) else
-    if w = "callcc" then INR (Lit (LitPrim CallCC)) else
+    if w = "call/cc" then INR (Lit (LitPrim CallCC)) else
       INR (Ident (implode w))) ∧
   cons_ast Nil = INL "Empty S expression" ∧
   cons_ast (Pair x y) = (case pair_to_list y of

From f3bab934b78f47b913d62379dd17e6e3568efa09 Mon Sep 17 00:00:00 2001
From: pascal <py@lasnier.com>
Date: Tue, 27 May 2025 17:48:17 +0100
Subject: [PATCH 096/100] nondet example simplified

---
 compiler/scheme/examples/nondet.scm | 20 +++++++++-----------
 1 file changed, 9 insertions(+), 11 deletions(-)

diff --git a/compiler/scheme/examples/nondet.scm b/compiler/scheme/examples/nondet.scm
index 971ad9ffe6..50afb3bd6e 100644
--- a/compiler/scheme/examples/nondet.scm
+++ b/compiler/scheme/examples/nondet.scm
@@ -3,20 +3,18 @@
       (lambda (fun)
           (call/cc
            (lambda (cc)
-               (letrec
-                   ((fail (lambda () (cc (- 1))))
-                    (choose
-                     (lambda (f n m)
-                         (letrec
-                             ((i n)
-                              (last fail))
+               (letrec ((k cc))
+                   (fun
+                    (lambda (f n m)
+                         (letrec ((i n)
+                                  (last k))
                              (begin
                               (call/cc
-                               (lambda (cc) (set! fail (lambda () (begin (set! i (+ i 1)) (cc (- 1)))))))
+                               (lambda (cc) (set! k (lambda (v) (begin (set! i (+ i 1)) (cc v))))))
                               (if (eqv? i m)
-                                  (begin (set! fail last) (fail))
-                                  (f i)))))))
-                   (fun choose (lambda () (fail))))))))
+                                  (begin (set! k last) (k (- 1)))
+                                  (f i)))))
+                    (lambda () (k (- 1)))))))))
 
      (triangle
       (lambda (n)

From aa3c04f768d89efeb74e692dd897683df3ca8837 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Thu, 29 May 2025 23:38:40 +0100
Subject: [PATCH 097/100] letrec and letrec*

---
 compiler/scheme/scheme_astScript.sml       |  7 ++++
 compiler/scheme/scheme_parsingScript.sml   |  9 +++++
 compiler/scheme/scheme_semanticsScript.sml | 41 ++++++++++++++-------
 compiler/scheme/scheme_to_cakeScript.sml   | 43 ++++++++++++++++++----
 4 files changed, 79 insertions(+), 21 deletions(-)

diff --git a/compiler/scheme/scheme_astScript.sml b/compiler/scheme/scheme_astScript.sml
index 87837a945b..d8bddd8ccb 100644
--- a/compiler/scheme/scheme_astScript.sml
+++ b/compiler/scheme/scheme_astScript.sml
@@ -27,6 +27,7 @@ Datatype:
       | Begin (exp list) exp
       | Set mlstring exp
       | Letrec ((mlstring # exp) list) exp
+      | Letrecstar ((mlstring # exp) list) exp
 End
 
 Datatype:
@@ -35,6 +36,7 @@ Datatype:
        | CondK exp exp
        | BeginK (exp list) exp
        | SetK mlstring
+       | LetinitK ((mlstring # val) list) mlstring ((mlstring # exp) list) exp
 ;
   val = Prim prim | SNum int | Wrong string | SBool bool
       | SList (val list)
@@ -78,6 +80,11 @@ Definition static_scope_def:
   static_scope_list (env ∪ set (MAP FST bs)) (MAP SND bs) ∧
   static_scope (env ∪ set (MAP FST bs)) e) ∧
 
+  static_scope env (Letrecstar bs e) = (
+  ALL_DISTINCT (MAP FST bs) ∧
+  static_scope_list (env ∪ set (MAP FST bs)) (MAP SND bs) ∧
+  static_scope (env ∪ set (MAP FST bs)) e) ∧
+
   static_scope env (Ident x) = env x ∧
 
   static_scope env (Set x e) = (
diff --git a/compiler/scheme/scheme_parsingScript.sml b/compiler/scheme/scheme_parsingScript.sml
index 73da40e4b7..a0e0c48f9d 100644
--- a/compiler/scheme/scheme_parsingScript.sml
+++ b/compiler/scheme/scheme_parsingScript.sml
@@ -253,6 +253,15 @@ Definition cons_ast_def:
             return (Letrec bs e)
           od)
       | _ => INL "Wrong number of expressions in letrec statement")
+    | Word "letrec*" => (case ys of
+      | [xs;y'] => (case pair_to_list xs of
+        | NONE => INL "Invalid S expression"
+        | SOME xs' => do
+            bs <- cons_ast_bindings xs';
+            e <- cons_ast y';
+            return (Letrecstar bs e)
+          od)
+      | _ => INL "Wrong number of expressions in letrec statement")
     | Word "set!" => (case ys of
       | [Word w;y'] => do
           e <- cons_ast y';
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index 4ec5418bd0..d1616bcab7 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -90,6 +90,12 @@ Definition application_def:
   application store ks _ _ = (store, ks, FEMPTY, Exception $ strlit "Not a procedure")
 End
 
+Definition letinit_def:
+  letinit store (env : mlstring |-> num) [] = store ∧
+  letinit store env ((x,v)::xvs) =
+    letinit (LUPDATE (SOME v) (env ' x) store) env xvs
+End
+
 Definition return_def:
   return store [] v = (store, [], FEMPTY, Val v) ∧
 
@@ -100,6 +106,10 @@ Definition return_def:
   | [] => application store ks vfn (REVERSE $ v::vargs)
   | e::es => (store, (env, ApplyK (SOME (vfn, v::vargs)) es) :: ks, env, Exp e)) ∧
 
+  return store ((env, LetinitK xvs x bs e) :: ks) v = (case bs of
+  | [] => (letinit store env ((x,v)::xvs), ks, env, Exp e)
+  | (x',e')::bs' => (store, (env, LetinitK ((x,v)::xvs) x' bs' e) :: ks, env, Exp e')) ∧
+
   return store ((env, CondK t f) :: ks) v = (if v = (SBool F)
     then (store, ks, env, Exp f) else (store, ks, env, Exp t)) ∧
 
@@ -109,10 +119,10 @@ Definition return_def:
   return store ((env, SetK x) :: ks) v = (LUPDATE (SOME v) (env ' x) store, ks, env, Val $ Wrong "Unspecified")
 End
 
-Definition letrec_init_def:
-  letrec_init store env [] = (store, env) ∧
-  letrec_init store env (x::xs) = (let (n, store') = fresh_loc store NONE
-    in letrec_init store' (env |+ (x, n)) xs)
+Definition letrec_preinit_def:
+  letrec_preinit store env [] = (store, env) ∧
+  letrec_preinit store env (x::xs) = (let (n, store') = fresh_loc store NONE
+    in letrec_preinit store' (env |+ (x, n)) xs)
 End
 
 Definition step_def:
@@ -122,7 +132,7 @@ Definition step_def:
   step (store, ks, env, Exp $ Cond c t f) = (store, (env, CondK t f) :: ks, env, Exp c) ∧
   (*This is undefined if the program doesn't typecheck*)
   step (store, ks, env, Exp $ Ident s) = (let ev = case EL (env ' s) store of
-    | NONE => Exception $ strlit "Letrec variable touched"
+    | NONE => Exception $ strlit "Letrecstar variable touched"
     | SOME v => Val v
     in (store, ks, env, ev)) ∧
   step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧
@@ -131,8 +141,12 @@ Definition step_def:
   | e'::es' => (store, (env, BeginK es' e) :: ks, env, Exp e')) ∧
   step (store, ks, env, Exp $ Set x e) = (store, (env, SetK x) :: ks, env, Exp e) ∧
   (*There is a missing reinit check, though the spec says it is optional*)
-  step (store, ks, env, Exp $ Letrec bs e) = (let
-    (store', env') = letrec_init store env (MAP FST bs)
+  step (store, ks, env, Exp $ Letrec bs e) = (case bs of
+  | [] => (store, ks, env, Exp e)
+  | (x,e')::bs' => let (store', env') = letrec_preinit store env (MAP FST bs)
+      in (store', (env', LetinitK [] x bs' e) :: ks, env', Exp e')) ∧
+  step (store, ks, env, Exp $ Letrecstar bs e) = (let
+    (store', env') = letrec_preinit store env (MAP FST bs)
       in (store', ks, env', Exp $ Begin (MAP (UNCURRY Set) bs) e)) ∧
 
   step (store, ks, env, Exception ex) = (store, [], env, Exception ex)
@@ -146,6 +160,7 @@ End
 (*
   open scheme_semanticsTheory;
 
+  EVAL “steps 100 ([], [], FEMPTY, Exp $ Letrec [(strlit "x",Lit $ LitNum 2);(strlit "y",Ident $ strlit "x")] (Ident $ strlit "y"))”
   EVAL “steps 10 ([], [], FEMPTY, Exp $ Apply (Lit (LitPrim SMinus)) [Lit (LitNum 4); Lit (LitNum 2)])”
   EVAL “steps 4 ([], [], Apply (Val (SNum 7)) [Val (SNum 2); Val (SNum 4)])”
   EVAL “steps 6 ([], [InLetK []], Apply (Val (Prim SMul)) [Val (SNum 2); Val (Prim SAdd)])”
@@ -219,7 +234,7 @@ End
   )”
 
   EVAL “steps 100 ([], [], FEMPTY,
-    Letrec [
+    Letrecstar [
       (strlit $ "to", Lambda [strlit "x"] NONE (
         Apply (Ident $ strlit "fro") [
           Apply (Val $ Prim SAdd) [Val $ SNum 1; Ident $ strlit "x"]
@@ -234,7 +249,7 @@ End
   )”
 
   EVAL “steps 3 ([], [], FEMPTY,
-    Letrec [(strlit $ "fail", Ident $ strlit "fail")] (Val $ SBool F)
+    Letrecstar [(strlit $ "fail", Ident $ strlit "fail")] (Val $ SBool F)
   )”
 
   EVAL “steps 20 ([], [], FEMPTY,
@@ -254,7 +269,7 @@ End
   )”
 
   EVAL “steps 102 ([], [], FEMPTY,
-    Letrec [
+    Letrecstar [
       (strlit $ "double", Val $ SNum 0);
       (strlit $ "x", Val $ SNum 1)
     ] (Begin (
@@ -272,7 +287,7 @@ End
 
   EVAL “steps 10 ([], [], FEMPTY, Apply (Val $ Prim SMinus) [Val $ SNum 3; Val $ SNum 2])”
 
-  EVAL “steps 1000 ([], [], FEMPTY, Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
+  EVAL “steps 1000 ([], [], FEMPTY, Letrecstar [(strlit "fac", Lambda [strlit "x"] NONE (
     Cond (Apply (Val $ Prim SEqv) [Ident $ strlit "x"; Val $ SNum 0]) (
       Val $ SNum 1
     ) (
@@ -282,8 +297,8 @@ End
     )
   ))] (Apply (Ident $ strlit "fac") [Val $ SNum 6]))”
 
-  EVAL “steps 500 ([], [], FEMPTY, Exp $ Letrec [(strlit "fac", Lambda [strlit "x"] NONE (
-    Letrec [(strlit "st", Lit $ LitNum 0); (strlit "acc", Lit $ LitNum 1)] (
+  EVAL “steps 500 ([], [], FEMPTY, Exp $ Letrecstar [(strlit "fac", Lambda [strlit "x"] NONE (
+    Letrecstar [(strlit "st", Lit $ LitNum 0); (strlit "acc", Lit $ LitNum 1)] (
       Begin [ Apply (Lit $ LitPrim CallCC) [ Lambda [strlit "k"] NONE (
         Set (strlit "st") (Ident $ strlit "k")
       )]] (
diff --git a/compiler/scheme/scheme_to_cakeScript.sml b/compiler/scheme/scheme_to_cakeScript.sml
index cedf9bfb6e..6bd532e3ee 100644
--- a/compiler/scheme/scheme_to_cakeScript.sml
+++ b/compiler/scheme/scheme_to_cakeScript.sml
@@ -53,10 +53,10 @@ Definition proc_ml_def:
     ])
 End
 
-Definition letinit_ml_def:
-  letinit_ml [] inner = inner ∧
-  letinit_ml (x::xs) inner = Let (SOME $ "var" ++ explode x)
-      (App Opref [Con (SOME $ Short "None") []]) (letinit_ml xs inner)
+Definition letpreinit_ml_def:
+  letpreinit_ml [] inner = inner ∧
+  letpreinit_ml (x::xs) inner = Let (SOME $ "var" ++ explode x)
+      (App Opref [Con (SOME $ Short "None") []]) (letpreinit_ml xs inner)
 End
 
 Definition refunc_set_def:
@@ -66,6 +66,14 @@ Definition refunc_set_def:
               (App Opapp [k; Var (Short "t")])
 End
 
+Definition letinit_ml_def:
+  letinit_ml [] inner = inner ∧
+  letinit_ml ((x,t)::xts) inner = Let NONE
+    (App Opassign [Var (Short $ "var" ++ explode x);
+      Con (SOME $ Short "Some") [t]]) $
+    letinit_ml xts inner
+End
+
 Definition cps_transform_def:
   cps_transform (Lit v) = (let
     mlv = to_ml_vals $ lit_to_val v
@@ -117,9 +125,14 @@ Definition cps_transform_def:
     Fun "k" $ Let (SOME "k'") (Fun "t" inner) $ App Opapp [ce; Var (Short "k'")]) ∧
 
   cps_transform (Letrec bs e) = (let
+    inner = cps_transform_letinit [] bs e (Var (Short "k"));
+  in
+    Fun "k" $ letpreinit_ml (MAP FST bs) $ inner) ∧
+
+  cps_transform (Letrecstar bs e) = (let
     ce = cps_transform (Begin (MAP (UNCURRY Set) bs) e);
   in
-    Fun "k" $ letinit_ml (MAP FST bs) $ App Opapp [ce; Var (Short "k")]) ∧
+    Fun "k" $ letpreinit_ml (MAP FST bs) $ App Opapp [ce; Var (Short "k")]) ∧
 
 
   cps_transform_app tfn ts (e::es) k = (let
@@ -134,6 +147,19 @@ Definition cps_transform_def:
       cons_list (REVERSE ts)] ∧
 
 
+  cps_transform_letinit xts [] e k = (let
+    ce = cps_transform e
+  in
+    letinit_ml xts $ App Opapp [ce; k]) ∧
+
+  cps_transform_letinit xts ((x, e')::bs) e k = (let
+    ce = cps_transform e';
+    t = "t" ++ toString (LENGTH xts);
+    inner = cps_transform_letinit ((x, Var (Short t))::xts) bs e k
+  in
+    Let (SOME "k'") (Fun t inner) $ App Opapp [ce; Var (Short "k'")]) ∧
+
+
   cps_transform_seq k [] e = (let
     ce = cps_transform e
   in
@@ -146,10 +172,11 @@ Definition cps_transform_def:
      Let (SOME "k'") (Fun "_" inner) $ App Opapp [ce; Var (Short "k'")])
 Termination
   WF_REL_TAC ‘inv_image ($< LEX $<) (λ x . case x of
-    | INL(e) => (exp_size e, case e of Letrec _ _ => 1 | _ => 0)
+    | INL(e) => (exp_size e, case e of Letrecstar _ _ => 1 | _ => 0)
     | INR(INL(_,_,es,_)) => (list_size exp_size es, 2n)
-    | INR(INR(_,es,e)) => (list_size exp_size es + exp_size e, 2))’
-  >> strip_tac >- (Cases >> simp[])
+    | INR(INR(INL(_,bs,e,_))) => (exp1_size bs + exp_size e, 2)
+    | INR(INR(INR(_,es,e))) => (list_size exp_size es + exp_size e, 2))’
+  >> rpt (strip_tac >- (Cases >> simp[]))
   >> Induct
   >> simp[exp_size_def]
   >> PairCases

From 7db068d59ec12c0fb7b04cb6a732e1089069cbe7 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Thu, 29 May 2025 23:38:58 +0100
Subject: [PATCH 098/100] compilation

---
 compiler/scheme/translation/scheme_compilerProgScript.sml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/compiler/scheme/translation/scheme_compilerProgScript.sml b/compiler/scheme/translation/scheme_compilerProgScript.sml
index 5ef52d71b3..71321aa461 100644
--- a/compiler/scheme/translation/scheme_compilerProgScript.sml
+++ b/compiler/scheme/translation/scheme_compilerProgScript.sml
@@ -44,6 +44,7 @@ val r = translate cake_print_def;
 val r = translate to_ml_vals_def;
 val r = translate cons_list_def;
 val r = translate proc_ml_def;
+val r = translate letpreinit_ml_def;
 val r = translate refunc_set_def;
 val r = translate letinit_ml_def;
 val r = translate cps_transform_def;

From 21c22c5c28c30fef3b5280b8fcf3e487da897203 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Fri, 30 May 2025 18:49:46 +0100
Subject: [PATCH 099/100] letrec proof, missing validity

---
 .../proofs/scheme_semanticsPropsScript.sml    |  51 +++-
 .../proofs/scheme_to_cakeProofScript.sml      | 225 +++++++++++++++++-
 compiler/scheme/scheme_semanticsScript.sml    |   2 +-
 3 files changed, 263 insertions(+), 15 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index a907fcb2ff..a8418cfb5d 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -79,6 +79,16 @@ Inductive valid_val:
   can_lookup env store
   ⇒
   valid_cont store ((env, SetK x)::ks)
+[~cont_LetinitK:]
+  EVERY (FDOM env) (MAP FST xvs) ∧
+  EVERY (valid_val store) (MAP SND xvs) ∧
+  (FDOM env) x ∧
+  EVERY (FDOM env) (MAP FST bs) ∧
+  EVERY (static_scope (FDOM env)) (MAP SND bs) ∧
+  valid_cont store ks ∧
+  can_lookup env store
+  ⇒
+  valid_cont store ((env, LetinitK xvs x bs e)::ks)
 End
 
 Inductive valid_state:
@@ -171,29 +181,29 @@ Theorem valid_val_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
 Theorem valid_cont_larger_store = SRULE [PULL_FORALL, AND_IMP_INTRO] $
   cj 2 valid_larger_store;
 
-Theorem letrec_init_mono:
+Theorem letrec_preinit_mono:
   ∀ bs store env store' env' .
-    letrec_init store env bs = (store', env')
+    letrec_preinit store env bs = (store', env')
     ⇒
     FDOM env ⊆ FDOM env'
 Proof
   Induct
-  >> simp[letrec_init_def]
+  >> simp[letrec_preinit_def]
   >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
   >> last_x_assum drule
   >> simp[]
 QED
 
-Theorem letrec_init_dom:
+Theorem letrec_preinit_dom:
   ∀ xs store env store' env' .
-    letrec_init store env xs = (store', env')
+    letrec_preinit store env xs = (store', env')
     ⇒
     FDOM env ∪ set xs = FDOM env' ∧
     store ++ GENLIST (λ x. NONE) (LENGTH xs) = store'
 Proof
   Induct
-  >> simp[letrec_init_def, fresh_loc_def]
+  >> simp[letrec_preinit_def, fresh_loc_def]
   >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
   >> last_x_assum $ drule_then assume_tac
@@ -214,15 +224,15 @@ Proof
   >> simp[GENLIST]
 QED
 
-Theorem letrec_init_lookup:
+Theorem letrec_preinit_lookup:
   ∀ xs store env store' env' .
     can_lookup env store ∧
-    letrec_init store env xs = (store', env')
+    letrec_preinit store env xs = (store', env')
     ⇒
     can_lookup env' store'
 Proof
   Induct
-  >> simp[letrec_init_def, fresh_loc_def]
+  >> simp[letrec_preinit_def, fresh_loc_def]
   >> rpt strip_tac
   >> rpt (pairarg_tac >> gvs[])
   >> qsuff_tac ‘can_lookup (env |+ (h,LENGTH store)) (SNOC NONE store)’ >- (
@@ -502,12 +512,15 @@ Proof
       >> gvs[Once valid_state_cases, can_lookup_cases]
     )
     >~ [‘Letrec bs e’] >- (
+      cheat
+    )
+    >~ [‘Letrecstar bs e’] >- (
       simp[step_def]
       >> rpt (pairarg_tac >> gvs[])
       >> simp[Once valid_state_cases, Once static_scope_def]
       >> gvs[Once valid_state_cases, Once static_scope_def]
-      >> drule_then assume_tac letrec_init_dom
-      >> drule_all_then assume_tac letrec_init_lookup
+      >> drule_then assume_tac letrec_preinit_dom
+      >> drule_all_then assume_tac letrec_preinit_lookup
       >> gvs[]
       >> irule_at (Pos $ el 2) valid_cont_larger_store
       >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pos $ el 2)
@@ -609,6 +622,9 @@ Proof
       >> pop_assum $ irule_at (Pos last)
       >> simp[]
     )
+    >~ [‘LetinitK xvs x bs e’] >- (
+      cheat
+    )
     >~ [‘ApplyK fnp es’] >- (
       simp[step_def]
       >> Cases_on ‘∃ e es' . es = e::es'’ >-(
@@ -923,6 +939,19 @@ Proof
       >> pop_assum drule
       >> simp[exp_size_def]
     )
+    >- (
+      CASE_TAC
+      >> simp[]
+      >> rpt strip_tac
+      >- (
+        ‘∀ e e' . e = e' ⇒ exp_size e = exp_size e'’ by simp[]
+        >> pop_assum drule
+        >> simp[exp_size_def]
+      )
+      >> rpt (pairarg_tac >> gvs[])
+      >> PairCases_on ‘h’
+      >> gvs[]
+    )
     >> rpt strip_tac
     >> rpt (pairarg_tac >> gvs[])
   )
diff --git a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
index 268a6e840a..dadf13cde7 100644
--- a/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
+++ b/compiler/scheme/proofs/scheme_to_cakeProofScript.sml
@@ -380,6 +380,20 @@ Inductive val_cont_rels:
   ⇒
   cont_rel ((se, SetK x) :: ks)
     (Closure env "t" $ inner)
+[~LetinitK:]
+  cont_rel ks kv ∧
+  nsLookup env.v (Short "k") = SOME kv ∧
+  (t, ts) = cps_app_ts xvs ∧
+  inner = cps_transform_letinit
+    ((x,Var (Short t))::ZIP (MAP FST xvs, MAP (Var o Short) ts))
+    bs e (Var (Short "k")) ∧
+  LIST_REL ml_v_vals' (MAP SND xvs) mlvs ∧
+  LIST_REL (λ x mlv . nsLookup env.v (Short x) = SOME mlv) ts mlvs ∧
+  scheme_env env ∧
+  env_rel se env
+  ⇒
+  cont_rel ((se, LetinitK xvs x bs e) :: ks)
+    (Closure env t $ inner)
 End
 
 Theorem val_cont_rels_ind[allow_rebind] = SRULE [] $ val_cont_rels_ind;
@@ -539,6 +553,16 @@ Proof
   simp[eval_eq_def]
 QED
 
+Theorem eval_eq_trans:
+  ∀ st mlenv mle st' mlenv' mle' st'' mlenv'' mle'' ck ck' .
+    eval_eq st mlenv mle st' mlenv' mle' ck ∧
+    eval_eq st' mlenv' mle' st'' mlenv'' mle'' ck'
+    ⇒
+    eval_eq st mlenv mle st'' mlenv'' mle'' (ck + ck')
+Proof
+  simp[eval_eq_def]
+QED
+
 Theorem preservation_of_sadd_body:
   ∀ vs mlvs .
     LIST_REL ml_v_vals' vs mlvs
@@ -1115,13 +1139,13 @@ QED
 
 Theorem preservation_of_letrec:
   ∀ xs inner (st:'ffi state) mlenv store env store' env' .
-    (store', env') = letrec_init store env xs ∧
+    (store', env') = letrec_preinit store env xs ∧
     env_rel env mlenv ∧
     LIST_REL store_entry_rel store st.refs ∧
     scheme_env mlenv
     ⇒
     ∃ ck st' mlenv' var' .
-      (∀ start . evaluate (st with clock:=ck+start) mlenv [letinit_ml xs inner]
+      (∀ start . evaluate (st with clock:=ck+start) mlenv [letpreinit_ml xs inner]
         = evaluate (st' with clock:=start) mlenv' [inner]) ∧
       env_rel env' mlenv' ∧
       LIST_REL store_entry_rel store' st'.refs ∧
@@ -1132,7 +1156,7 @@ Theorem preservation_of_letrec:
       st.ffi = st'.ffi
 Proof
   Induct
-  >> simp[letrec_init_def, letinit_ml_def]
+  >> simp[letrec_preinit_def, letpreinit_ml_def]
   >> rpt strip_tac >- (
     simp[GSYM eval_eq_def]
     >> irule_at (Pos hd) eval_eq_trivial
@@ -1200,6 +1224,72 @@ Proof
   >> gvs[]
 QED
 
+Theorem preservation_of_letinit:
+  ∀ (st:'ffi state) mlenv mlvs store env e k kv var xvs ts .
+    EVERY (FDOM env) (MAP FST xvs) ∧
+    EVERY (valid_val store) (MAP SND xvs) ∧
+    LIST_REL ml_v_vals' (MAP SND xvs) mlvs ∧
+    LIST_REL (λx mlv. nsLookup mlenv.v (Short x) = SOME mlv) ts mlvs ∧
+    cont_rel k kv ∧ nsLookup mlenv.v (Short var) = SOME kv ∧
+    scheme_env mlenv ∧
+    env_rel env mlenv ∧
+    can_lookup env store ∧
+    LIST_REL store_entry_rel store st.refs
+    ⇒
+    ∃ck st' mlenv' var' kv' mle'.
+      (∀start.
+         evaluate (st with clock := ck + start) mlenv
+           [letinit_ml
+              (ZIP (MAP FST xvs,MAP (Var ∘ Short) ts))
+              (App Opapp [cps_transform e; Var (Short var)])] =
+         evaluate (st' with clock := start) mlenv' [mle']) ∧
+      cont_rel k kv' ∧ e_ce_rel (Exp e) var' mlenv' kv' mle' ∧
+      env_rel env mlenv' ∧
+      LIST_REL store_entry_rel (letinit store env xvs) st'.refs ∧
+      st.ffi = st'.ffi
+Proof
+  Induct_on ‘xvs’
+  >> rpt strip_tac
+  >> gvs[letinit_ml_def, letinit_def] >- (
+    simp[GSYM eval_eq_def]
+    >> irule_at (Pos hd) eval_eq_trivial
+    >> simp[Once e_ce_rel_cases]
+  )
+  >> PairCases_on ‘h’
+  >> simp[letinit_def]
+  >> gvs[]
+  >> simp[Ntimes evaluate_def 6, do_con_check_def, build_conv_def,
+    nsOptBind_def]
+  >> qpat_assum ‘scheme_env _’ $ simp o single
+    o SRULE [scheme_env_def]
+  >> qpat_assum ‘env_rel env _’ $ drule_then assume_tac
+    o SRULE [env_rel_cases, FEVERY_DEF, SPECIFICATION]
+  >> simp[do_app_def, store_assign_def, store_v_same_type_def]
+  >> qpat_assum ‘can_lookup env _’ $ drule_then assume_tac
+    o SRULE [can_lookup_cases, FEVERY_DEF, SPECIFICATION]
+  >> drule_then assume_tac EVERY2_LENGTH
+  >> drule_all_then assume_tac $ cj 2 $ iffLR LIST_REL_EL_EQN
+  >> gvs[store_entry_rel_cases]
+  >> (‘st.ffi = (st with <|refs := LUPDATE (Refv (Conv (SOME (TypeStamp "Some" 2)) [y]))
+                      (env ' h0) st.refs; ffi := st.ffi|>).ffi’ by simp[]
+  >> first_assum $ once_asm_rewrite_tac o single
+  >> pop_assum $ simp_tac pure_ss o single o Once o GSYM
+  >> last_x_assum $ irule
+  >> first_assum $ irule_at (Pos last)
+  >> simp[]
+  >> irule_at (Pos hd) EVERY_MONOTONIC
+  >> last_assum $ irule_at (Pos $ el 2)
+  >> strip_tac >- (
+    rpt strip_tac
+    >> irule valid_val_larger_store
+    >> pop_assum $ irule_at (Pos last)
+    >> simp[LENGTH_LUPDATE]
+  )
+  >> gvs[can_lookup_cases]
+  >> irule EVERY2_LUPDATE_same
+  >> simp[store_entry_rel_cases])
+QED
+
 Theorem step_preservation:
   ∀ store store' env env' e e' k k' (st : 'ffi state) mlenv var kv mle .
   step (store, k, env, e) = (store', k', env', e') ∧
@@ -1355,6 +1445,56 @@ Proof
       >> gvs[scheme_env_def, env_rel_cases]
     )
     >~ [‘Letrec bs e’] >- (
+      Cases_on ‘bs’
+      >> rpt strip_tac
+      >> gvs[cps_transform_def] >- (
+        qrefine ‘ck+1’
+        >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
+          nsOptBind_def, dec_clock_def, letpreinit_ml_def, letinit_ml_def]
+        >> simp[GSYM eval_eq_def]
+        >> irule_at (Pos hd) eval_eq_trivial
+        >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+        >> simp[Once e_ce_rel_cases]
+        >> gvs[scheme_env_def, env_rel_cases]
+      )
+      >> PairCases_on ‘h’
+      >> simp[cps_transform_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
+        nsOptBind_def, dec_clock_def]
+      >> qpat_x_assum ‘letrec_preinit _ _ _ = _’ $ assume_tac o GSYM
+      >> drule preservation_of_letrec
+      >> ‘env_rel env (mlenv with v := nsBind "k" kv mlenv.v)’
+        by gvs[env_rel_cases]
+      >> strip_tac
+      >> pop_assum $ drule_then drule
+      >> ‘scheme_env (mlenv with v := nsBind "k" kv mlenv.v)’
+        by gvs[scheme_env_def]
+      >> strip_tac
+      >> pop_assum $ drule
+      >> strip_tac
+      >> pop_assum $ qspec_then
+        ‘Let (SOME "k'")
+           (Fun "t0"
+              (cps_transform_letinit [(h0,Var (Short "t0"))] t e
+                 (Var (Short "k"))))
+           (App Opapp [cps_transform h1; Var (Short "k'")])’ mp_tac
+      >> rpt strip_tac
+      >> gvs[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trans
+      >> first_assum $ irule_at (Pos hd)
+      >> simp[eval_eq_def]
+      >> simp[Ntimes evaluate_def 2, nsOptBind_def]
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
+      >> simp[Once cont_rel_cases]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pat ‘cont_rel _ _’)
+      >> simp[cps_app_ts_def]
+      >> simp[Once e_ce_rel_cases]
+      >> gvs[scheme_env_def, env_rel_cases]
+    )
+    >~ [‘Letrecstar bs e’] >- (
       simp[Once cps_transform_def]
       >> rpt strip_tac
       >> rpt (pairarg_tac >> gvs[])
@@ -1468,6 +1608,85 @@ Proof
       >> irule EVERY2_LUPDATE_same
       >> simp[store_entry_rel_cases]
     )
+    >> Cases_on ‘∃ xvs x bs e . h1 = LetinitK xvs x bs e’ >- (
+      gvs[]
+      >> Cases_on ‘bs’
+      >> rpt strip_tac
+      >> gvs[Once cont_rel_cases, Once e_ce_rel_cases]
+      >> gvs[cps_transform_def, step_def, return_def]
+      >> qrefine ‘ck+1’
+      >> simp[SimpLHS, Ntimes evaluate_def 4, do_opapp_def,
+        nsOptBind_def, dec_clock_def] >- (
+        gvs[Once valid_state_cases]
+        >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac
+          o SRULE [Once valid_val_cases]
+        >> strip_tac
+        >> ‘∃ xvs' . (x,v)::xvs = xvs'’ by simp[]
+        >> first_assum $ simp_tac bool_ss o single
+        >> ‘x::(MAP FST xvs) = MAP FST xvs'’ by gvs[]
+        >> simp_tac bool_ss [Once $ cj 3 $ GSYM ZIP_def]
+        >> first_assum $ simp_tac bool_ss o single
+        >> ‘Var (Short t')::MAP (Var o Short) ts = MAP (Var o Short) (t'::ts)’ by gvs[]
+        >> first_assum $ simp_tac bool_ss o single
+        >> irule preservation_of_letinit
+        >> drule cps_app_ts_distinct
+        >> strip_tac
+        >> gvs[]
+        >> last_assum $ irule_at (Pos last)
+        >> irule_at (Pos $ el 5) EQ_REFL
+        >> irule_at Any EQ_REFL
+        >> simp[]
+        >> irule_at (Pos last) EVERY2_MEM_MONO
+        >> qpat_assum ‘LIST_REL _ ts mlvs’ $ irule_at (Pat ‘LIST_REL _ ts mlvs’)
+        >> strip_tac >- (
+          PairCases
+          >> simp[]
+          >> rpt strip_tac
+          >> qpat_assum ‘LIST_REL _ ts mlvs’ $ assume_tac
+          >> dxrule_then assume_tac EVERY2_LENGTH
+          >> drule_at_then (Pos $ el 2) assume_tac $ cj 1 MEM_ZIP_MEM_MAP
+          >> gvs[]
+          >> Cases_on ‘x'0 = t'’
+          >> gvs[]
+        )
+        >> gvs[scheme_env_def, env_rel_cases]
+      )
+      >> PairCases_on ‘h’
+      >> gvs[]
+      >> simp[cps_transform_def]
+      >> simp[Ntimes evaluate_def 2, nsOptBind_def]
+      >> simp[GSYM eval_eq_def]
+      >> irule_at (Pos hd) eval_eq_trivial
+      >> simp[Once e_ce_rel_cases, Once cont_rel_cases]
+      >> simp_tac bool_ss [Once $ GSYM ZIP_def]
+      >> ‘Var (Short t'')::MAP (Var o Short) ts = MAP (Var o Short) (t''::ts)’ by gvs[]
+      >> first_assum $ simp_tac bool_ss o single
+      >> irule_at (Pos hd) EQ_REFL
+      >> simp[cps_app_ts_def]
+      >> rpt (pairarg_tac >> gvs[])
+      >> qpat_assum ‘LIST_REL _ ts mlvs’ $ assume_tac
+      >> dxrule_then assume_tac EVERY2_LENGTH
+      >> qpat_assum ‘LIST_REL ml_v_vals' _ mlvs’ $ assume_tac
+      >> dxrule_then assume_tac EVERY2_LENGTH
+      >> gvs[]
+      >> qpat_assum ‘cont_rel _ _’ $ irule_at (Pos hd)
+      >> qpat_assum ‘LIST_REL ml_v_vals' _ _’ $ irule_at (Pos $ el 2)
+      >> drule $ GSYM cps_app_ts_distinct
+      >> strip_tac
+      >> simp[]
+      >> irule_at (Pos hd) EVERY2_MEM_MONO
+      >> qpat_assum ‘LIST_REL _ ts mlvs’ $ irule_at (Pat ‘LIST_REL _ ts mlvs’)
+      >> strip_tac >- (
+        PairCases
+        >> simp[]
+        >> rpt strip_tac
+        >> drule_at_then (Pos $ el 2) assume_tac $ cj 1 MEM_ZIP_MEM_MAP
+        >> gvs[]
+        >> Cases_on ‘x'0 = t''’
+        >> gvs[]
+      )
+      >> gvs[scheme_env_def, env_rel_cases]
+    )
     >> Cases_on ‘∃ e es . h1 = ApplyK NONE (e::es)’ >- (
       gvs[]
       >> simp[step_def, return_def, Once e_ce_rel_cases,
diff --git a/compiler/scheme/scheme_semanticsScript.sml b/compiler/scheme/scheme_semanticsScript.sml
index d1616bcab7..790029513c 100644
--- a/compiler/scheme/scheme_semanticsScript.sml
+++ b/compiler/scheme/scheme_semanticsScript.sml
@@ -132,7 +132,7 @@ Definition step_def:
   step (store, ks, env, Exp $ Cond c t f) = (store, (env, CondK t f) :: ks, env, Exp c) ∧
   (*This is undefined if the program doesn't typecheck*)
   step (store, ks, env, Exp $ Ident s) = (let ev = case EL (env ' s) store of
-    | NONE => Exception $ strlit "Letrecstar variable touched"
+    | NONE => Exception $ strlit "Letrec variable touched"
     | SOME v => Val v
     in (store, ks, env, ev)) ∧
   step (store, ks, env, Exp $ Lambda ps lp e) = (store, ks, env, Val $ Proc env ps lp e) ∧

From 2a9deab6e91db380747768935512d60a84818734 Mon Sep 17 00:00:00 2001
From: Pascal Lasnier <py@lasnier.com>
Date: Sat, 31 May 2025 02:26:21 +0100
Subject: [PATCH 100/100] letrec progress/validity

---
 .../proofs/scheme_semanticsPropsScript.sml    | 111 +++++++++++++++++-
 1 file changed, 109 insertions(+), 2 deletions(-)

diff --git a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
index a8418cfb5d..839f272fb3 100644
--- a/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
+++ b/compiler/scheme/proofs/scheme_semanticsPropsScript.sml
@@ -85,6 +85,7 @@ Inductive valid_val:
   (FDOM env) x ∧
   EVERY (FDOM env) (MAP FST bs) ∧
   EVERY (static_scope (FDOM env)) (MAP SND bs) ∧
+  static_scope (FDOM env) e ∧
   valid_cont store ks ∧
   can_lookup env store
   ⇒
@@ -150,6 +151,19 @@ Proof
   >> simp[]
 QED
 
+Theorem SET_MEM:
+  ∀ l x . set l x ⇔ MEM x l
+Proof
+  Induct
+  >> simp[]
+QED
+
+Theorem EVERY_SET:
+  ∀ l . EVERY (set l) l
+Proof
+  simp[EVERY_MEM, SET_MEM]
+QED
+
 Theorem valid_larger_store:
   ∀ (store :'a list) (store' :'a list) .
     LENGTH store ≤ LENGTH store'
@@ -419,6 +433,57 @@ Proof
   >> simp[]
 QED
 
+Theorem letinit_valid:
+  ∀ store env xvs ks .
+    EVERY (OPTION_ALL (valid_val store)) store ∧
+    EVERY (FDOM env) (MAP FST xvs) ∧
+    EVERY (valid_val store) (MAP SND xvs) ∧
+    valid_cont store ks ∧
+    can_lookup env store
+    ⇒
+      valid_cont (letinit store env xvs) ks ∧
+      can_lookup env (letinit store env xvs) ∧
+      EVERY (OPTION_ALL (valid_val (letinit store env xvs)))
+        (letinit store env xvs)
+Proof
+  Induct_on ‘xvs’
+  >> simp[letinit_def]
+  >> PairCases
+  >> simp[letinit_def]
+  >> rpt gen_tac
+  >> strip_tac
+  >> last_x_assum irule
+  >> simp[]
+  >> irule_at (Pos hd) IMP_EVERY_LUPDATE
+  >> simp[]
+  >> irule_at (Pos hd) valid_val_larger_store
+  >> first_assum $ irule_at (Pos $ el 2)
+  >> simp[]
+  >> irule_at (Pos hd) EVERY_MONOTONIC
+  >> last_assum $ irule_at (Pos $ el 2)
+  >> strip_tac >- (
+    rpt strip_tac
+    >> irule OPTION_ALL_MONO
+    >> pop_assum $ irule_at (Pos last)
+    >> rpt strip_tac
+    >> irule_at (Pos hd) valid_val_larger_store
+    >> first_assum $ irule_at (Pos last)
+    >> simp[]
+  )
+  >> irule_at (Pos hd) EVERY_MONOTONIC
+  >> last_assum $ irule_at (Pos $ el 2)
+  >> strip_tac >- (
+    rpt strip_tac
+    >> irule_at (Pos hd) valid_val_larger_store
+    >> first_assum $ irule_at (Pos last)
+    >> simp[]
+  )
+  >> gvs[can_lookup_cases]
+  >> irule valid_cont_larger_store
+  >> first_assum $ irule_at (Pos last)
+  >> simp[]
+QED
+
 Theorem sadd_num_or_exception:
   ∀ vs n .
     (∃ m . sadd vs n = Val (SNum m)) ∨
@@ -512,7 +577,37 @@ Proof
       >> gvs[Once valid_state_cases, can_lookup_cases]
     )
     >~ [‘Letrec bs e’] >- (
-      cheat
+      Cases_on ‘bs’ >- (
+        simp[step_def, Once valid_state_cases]
+        >> gvs[Once valid_state_cases, Once static_scope_def]
+      )
+      >> simp[step_def]
+      >> PairCases_on ‘h’
+      >> rpt (pairarg_tac >> gvs[])
+      >> gvs[Once valid_state_cases, Once static_scope_def]
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
+      >> drule_then assume_tac letrec_preinit_dom
+      >> drule_all_then assume_tac letrec_preinit_lookup
+      >> gvs[]
+      >> irule_at (Pat ‘valid_cont _ _’) valid_cont_larger_store
+      >> qpat_assum ‘valid_cont _ _’ $ irule_at (Pat ‘valid_cont _ _’)
+      >> simp[]
+      >> qpat_x_assum ‘_ = FDOM _’ $ assume_tac o GSYM
+      >> simp[]
+      >> irule_at (Pos hd) EVERY_MONOTONIC
+      >> irule_at (Pos $ el 2) EVERY_SET
+      >> simp[SET_MEM]
+      >> simp[EVERY_GENLIST]
+      >> irule_at (Pos hd) EVERY_MONOTONIC
+      >> first_assum $ irule_at (Pos $ el 2)
+      >> rpt strip_tac
+      >> irule OPTION_ALL_MONO
+      >> pop_assum $ irule_at (Pos last)
+      >> rpt strip_tac
+      >> irule valid_val_larger_store
+      >> pop_assum $ irule_at (Pos last)
+      >> simp[]
     )
     >~ [‘Letrecstar bs e’] >- (
       simp[step_def]
@@ -623,7 +718,19 @@ Proof
       >> simp[]
     )
     >~ [‘LetinitK xvs x bs e’] >- (
-      cheat
+      simp[step_def, return_def]
+      >> CASE_TAC
+      >> gvs[Once valid_state_cases]
+      >> qpat_x_assum ‘valid_cont _ _’ $ mp_tac o SRULE [Once valid_val_cases]
+      >> rpt strip_tac >- (
+        simp[Once valid_state_cases]
+        >> irule letinit_valid
+        >> simp[]
+      )
+      >> PairCases_on ‘h’
+      >> gvs[]
+      >> simp[Once valid_state_cases]
+      >> simp[Once valid_val_cases]
     )
     >~ [‘ApplyK fnp es’] >- (
       simp[step_def]