17 files changed, 599 insertions, 0 deletions

diff --git a/src/.merlin b/src/.merlin
new file mode 100644
index 0000000..22dd628
--- /dev/null
+++ b/src/.merlin
@@ -0,0 +1 @@
+PKG kaputt
diff --git a/src/common.ml b/src/common.ml
new file mode 120000
index 0000000..ed50e6f
--- /dev/null
+++ b/src/common.ml
@@ -0,0 +1 @@
+common.mli
\ No newline at end of file
diff --git a/src/common.mli b/src/common.mli
new file mode 100644
index 0000000..4fa838d
--- /dev/null
+++ b/src/common.mli
@@ -0,0 +1,47 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+type line = int
+type label = string
+type regidx = int
+type regval = int
+type reg = Reg of regidx * regval
+
+type urmcmd =
+  | URMCopy of regidx * regidx
+  | URMJump of regidx * regidx * line
+  | URMSucc of regidx
+  | URMZero of regidx
+
+type eurmcmd =
+  | Add of regidx * regidx
+  | Comment of string
+  | Copy of regidx * regidx
+  | Dec of regidx
+  | EqPredicate of regidx * regidx * label
+  | GEqPredicate of regidx * regidx * label
+  | GTPredicate of regidx * regidx * label
+  | Goto of label
+  | Inc of regidx
+  | Label of label
+  | LEqPredicate of regidx * regidx * label
+  | LTPredicate of regidx * regidx * label
+  | Mult of regidx * regidx
+  | Quit
+  | Sub of regidx * regidx
+  | Zero of regidx
+  | ZeroPredicate of regidx * label
+
+type instptr = InstPtr of (line * urmcmd) list * (line * urmcmd) list
+
+type urm = {
+  instptr : instptr;
+  regs : reg list
+}
+
+type state = { todo : int }
+
+exception Syntax_error
+
diff --git a/src/eurm.ml b/src/eurm.ml
new file mode 100644
index 0000000..c571384
--- /dev/null
+++ b/src/eurm.ml
@@ -0,0 +1,22 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+open Common
+
+let compile_preprocess eurmcmds = eurmcmds
+let compile_stage1 eurmcmds state = eurmcmds, state
+let compile_stage2 eurmcmds state = eurmcmds, state
+let compile_stage3 eurmcmds state = eurmcmds, state
+let compile_stage4 eurmcmds state = [URMZero(0)], state
+
+let urm_from_eurm =
+  let chain transform (eurmcmds, compile_state) = transform eurmcmds compile_state
+  and initial_state = 0
+  in (compile_preprocess, initial_state)
+     |> chain compile_stage1
+     |> chain compile_stage2
+     |> chain compile_stage3
+     |> chain compile_stage4
+
diff --git a/src/eurml.mli b/src/eurml.mli
new file mode 100644
index 0000000..8fd8ef1
--- /dev/null
+++ b/src/eurml.mli
@@ -0,0 +1,25 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+open Common
+
+(* Strips out comments and rewrite/enumerate labels *)
+val compile_preprocess : eurmcmd list -> eurmcmd list
+
+(* Rewrites Dec, GEqPredicate, LEqPredicate, LTPredicate, Mult and ZeroPredicate *)
+val compile_stage1 : eurmcmd list -> state -> eurmcmd list * state
+
+(* Rewrites Add, GTPredicate and Sub *)
+val compile_stage2 : eurmcmd list -> state -> eurmcmd list * state
+
+(* Rewrites Goto *)
+val compile_stage3 : eurmcmd list -> state -> eurmcmd list * state
+
+(* Rewrites Inc, EqPredicate, Label and Zero *)
+val compile_stage4 : eurmcmd list -> state -> urmcmd list * state
+
+(* Transcompiles an EURM instruction sequence into URM *)
+val urm_from_eurm : eurmcmd list -> urmcmd list
+
diff --git a/src/eurml_test.ml b/src/eurml_test.ml
new file mode 100644
index 0000000..7dc6e5e
--- /dev/null
+++ b/src/eurml_test.ml
@@ -0,0 +1,75 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+open Common
+open Urm
+open Eurm
+open Kaputt.Abbreviations
+
+let () =
+  Test.add_simple_test
+    ~title:"example_eurm_factorial_conversion"
+    (fun () ->
+       let input_eurm = [
+         Comment "Compute r1! and place the result in r1";
+         ZeroPredicate (1, "r1=0");
+         Goto "r1>0";
+         Comment "r1 holds 0";
+         Label "r1=0";
+         Inc 1;
+         Goto "done";
+         Comment "r1 holds a positive integer";
+         Label "r1>0";
+         Copy (2, 1);
+         Zero 1;
+         Inc 1;
+         Zero 3;
+         Inc 3;
+         Comment "main loop";
+         Label "loop";
+         Mult (1, 3);
+         EqPredicate (2, 3, "done");
+         Inc 3;
+         Goto "loop";
+         Label "done";
+         Quit]
+       and expected_urm = [
+         URMZero 4;
+         URMJump (1, 4, 4);
+         URMZero 8;
+         URMJump (8, 8, 7);
+         URMSucc 1;
+         URMZero 9;
+         URMJump (9, 9, 29);
+         URMCopy (2, 1);
+         URMZero 1;
+         URMSucc 1;
+         URMZero 3;
+         URMSucc 3;
+         URMCopy (5, 1);
+         URMZero 1;
+         URMZero 6;
+         URMJump (3, 6, 25);
+         URMZero 7;
+         URMJump (5, 7, 22);
+         URMSucc 1;
+         URMSucc 7;
+         URMZero 10;
+         URMJump (10, 10, 17);
+         URMSucc 6;
+         URMZero 11;
+         URMJump (11, 11, 15);
+         URMJump (2, 3, 29);
+         URMSucc 3;
+         URMZero 12;
+         URMJump (12, 12, 12);
+         URMZero 13;
+         URMJump (13, 13, 38)]
+       in let output_urm = urm_from_eurm input_eurm
+       in
+         Assert.is_true (output_urm = expected_urm))
+
+let () = if Array.mem "run-tests" Sys.argv then Test.launch_tests ()
+
diff --git a/src/instptr.ml b/src/instptr.ml
new file mode 100644
index 0000000..0311a00
--- /dev/null
+++ b/src/instptr.ml
@@ -0,0 +1,43 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+open Common
+
+let instptr_mk urmcmd_list =
+  let rec aux urmcmd_list count acc = match urmcmd_list with
+    | [] -> acc
+    | instr :: tail -> aux tail (count + 1) ((count, instr) :: acc)
+  in InstPtr([], List.rev (aux urmcmd_list 0 []))
+
+let instptr_move_up = function
+  | InstPtr(instr :: list1, list2) -> InstPtr(list1, instr :: list2)
+  | x -> x
+
+let instptr_move_down = function
+  | InstPtr(list1, instr :: list2) -> InstPtr(instr :: list1, list2)
+  | x -> x
+
+let instptr_get = function
+  | InstPtr(_, x :: _) -> x
+  | InstPtr(_, []) -> failwith "No instruction left"
+
+let instptr_string instptr =
+  let string_of_inst = function
+    | Zero(a) -> "Zero " ^ (string_of_int a)
+    | Succ(a) -> "Succ " ^ (string_of_int a)
+    | Copy(a, b) -> "Copy " ^ (string_of_int a) ^ " " ^ (string_of_int b)
+    | Jump(a, b, c) -> "Jump " ^ (string_of_int a) ^ " " ^ (string_of_int b) ^ " " ^ (string_of_int c)
+  in let string_of_instptr (l, inst) = (string_of_int l) ^ ": " ^ string_of_inst inst
+  in try string_of_instptr (instptr_get instptr) with _ -> "null"
+
+let instptr_end = function
+  | InstPtr(_, []) -> true
+  | _ -> false
+
+let rec instptr_jump ptr offset = match offset with
+  | 0 -> ptr
+  | _ when offset > 0 -> instptr_jump (instptr_move_up ptr) (offset - 1)
+  | _ -> instptr_jump (instptr_move_down ptr) (offset + 1)
+
diff --git a/src/instptr.mli b/src/instptr.mli
new file mode 100644
index 0000000..f1252b5
--- /dev/null
+++ b/src/instptr.mli
@@ -0,0 +1,29 @@
+(*
+ * UPEM / L3 / Functional programming / Project: URM
+ * Pacien TRAN-GIRARD, Adam NAILI
+ *)
+
+open Common
+
+(* Create an instruction pointer for an URM program. *)
+val instptr_mk : urmcmd list -> instptr
+
+(* Move the instruction pointer up. Do nothing if this is not possible. *)
+val instptr_move_up : instptr -> instptr
+
+(* Move the instruction pointer down. Do nothing if this is not possible. *)
+val instptr_move_down : instptr -> instptr
+
+(* Get the current command from the instruction pointer.
+ * Fail if the command pointer is not set on a valid command. *)