aboutsummaryrefslogtreecommitdiff
path: root/projet.ml
diff options
context:
space:
mode:
Diffstat (limited to 'projet.ml')
-rw-r--r--projet.ml122
1 files changed, 0 insertions, 122 deletions
diff --git a/projet.ml b/projet.ml
deleted file mode 100644
index 67e6221..0000000
--- a/projet.ml
+++ /dev/null
@@ -1,122 +0,0 @@
1#load "str.cma"
2
3type line = int
4type regidx = int
5type regval = int
6type reg = Reg of regidx * regval
7
8type urmcmd =
9 | Copy of regidx * regidx
10 | Jump of regidx * regidx * line
11 | Succ of regidx
12 | Zero of regidx
13
14type instptr = InstPtr of (line * urmcmd) list * (line * urmcmd) list
15
16type urm = {
17 instptr : instptr;
18 regs : reg list
19}
20
21exception Syntax_error
22
23let rec string_of_file f =
24 try
25 let str = input_line f
26 in str ^ " " ^ (string_of_file f)
27 with End_of_file -> ""
28
29let rec program_of_lex = function
30 | [] -> []
31 | "zero" :: arg_1 :: tail -> (Zero (int_of_string arg_1)) :: (program_of_lex tail)
32 | "succ" :: arg_1 :: tail -> (Succ (int_of_string arg_1)) :: (program_of_lex tail)
33 | "copy" :: arg_1 :: arg_2 :: tail -> (Copy ((int_of_string arg_1), (int_of_string arg_2))) :: (program_of_lex tail)
34 | "jump" :: arg_1 :: arg_2 :: arg_3 :: tail -> (Jump ((int_of_string arg_1), (int_of_string arg_2), (int_of_string arg_3))) :: (program_of_lex tail)
35 | _ -> raise Syntax_error
36
37let program_of_string str =
38 let lex = Str.split (Str.regexp "[\t\n(),]+") str
39 in List.iter (fun s -> print_string s; print_newline ()) lex; program_of_lex lex
40
41(* Creates a pointer of instruction from an urm command list *)
42let instptr_mk urmcmd_list =
43 let rec aux urmcmd_list count acc =
44 match urmcmd_list with
45 | [] -> acc
46 | instr :: tail -> aux tail (count + 1) ((count, instr) :: acc)
47 in InstPtr([], List.rev (aux urmcmd_list 0 []))
48
49(* Moves the pointer to the previous instruction *)
50let instptr_move_up = function
51 | InstPtr([], list2) -> InstPtr([], list2)
52 | InstPtr(instr :: list1, list2) -> InstPtr(list1, instr :: list2)
53
54(* Moves the pointer to the next instruction *)
55let instptr_move_down = function
56 | InstPtr(list1, []) -> InstPtr(list1, [])
57 | InstPtr(list1, instr :: list2) -> InstPtr(instr :: list1, list2)
58
59(* Returns the couple from the current pointer position : (line, instruction) where instruction is an urm command or fails if there is no instruction pointed *)
60let instptr_get = function
61 | InstPtr(list1, (l, Zero(a)) :: tail)-> (l, Zero(a))
62 | InstPtr(list1, (l, Succ(a)) :: tail) -> (l, Succ(a))
63 | InstPtr(list1, (l, Copy(a, b)) :: tail) -> (l, Copy(a, b))
64 | InstPtr(list1, (l, Jump(a, b, c)) :: tail) -> (l, Jump(a, b, c))
65 | InstPtr(_, [])-> failwith "No instruction left"
66
67(* Converts the current instruction pointed into a string (line and instruction formatted). If there is no instruction, returns "null" *)
68let instptr_string instptr =
69 let aux = function
70 | l, Zero(a) -> (string_of_int l) ^ ": Zero " ^ (string_of_int a)
71 | l, Succ(a) -> (string_of_int l) ^ ": Succ " ^ (string_of_int a)
72 | l, Copy(a, b) -> (string_of_int l) ^ ": Copy " ^ (string_of_int a) ^ " " ^ (string_of_int b)
73 | l, Jump(a, b, c) -> (string_of_int l) ^ ": Jump " ^ (string_of_int a) ^ " " ^ (string_of_int b) ^ " " ^ (string_of_int c)
74 in try aux (instptr_get instptr) with _ -> "null"
75
76(* Returns true if the instruction pointer is not pointing on any instruction (end of the instruction list) *)
77let instptr_end = function
78 | InstPtr(_, []) -> true
79 | _ -> false
80
81(* Returns the pointer of instruction after a jump decided by the given offse t*)
82let rec instptr_jump ptr offset = match offset with
83 | 0 -> ptr
84 | _ when offset > 0 -> instptr_jump (instptr_move_up ptr) (offset - 1)
85 | _ -> instptr_jump (instptr_move_down ptr) (offset + 1)
86
87let reg_idx (Reg(idx, _)) = idx
88let reg_val (Reg(_, value)) = value
89
90(* Compares two registers. Returns -1 if reg1 is lower than reg2, 1 if it is greater than reg2 or 0 if both are equals. *)
91let reg_compar reg1 reg2 = (reg_val reg1) - (reg_val reg2)
92
93(* Returns the value contained in the specified register in a register list *)
94let regs_get reglist idx = List.find (fun (Reg(x,v)) -> x = idx) reglist |> reg_val
95
96(* Set the value of the register to value, or creates it to the value specified if it does not exist *)
97let regs_set reglist index value = Reg(index, value) :: List.filter (fun (Reg(x, v)) -> x != index) reglist
98
99(* Gives a new urm by moving down its instruction pointer *)
100let urm_move_down urm = { instptr = instptr_move_down urm.instptr ; regs = urm.regs }
101
102(* TODO: Verifier pour JUMP que a et b sont deux registres initialisés *)
103
104(* Applies the current instruction pointed by the pointer of instruction. Modifies the pointer of instruction for every instruction *)
105let urm_apply urm =
106 let aux = function
107 | _, Zero(a) -> { instptr = urm.instptr ; regs = regs_set (urm.regs) a 0 } |> urm_move_down
108 | _, Copy(a, b) when a != b -> { instptr = urm.instptr ; regs = regs_set urm.regs a (regs_get urm.regs b) } |> urm_move_down
109 | _, Copy(a, b) -> failwith "Copy from one register to itself"
110 | _, Succ(a) -> { instptr = urm.instptr ; regs = regs_set urm.regs a ((regs_get urm.regs a) + 1) } |> urm_move_down
111 | _, Jump(a, b, c) when (regs_get urm.regs a) = (regs_get urm.regs b) -> { instptr = (instptr_jump urm.instptr (fst (instptr_get urm.instptr) - c)) ; regs = urm.regs }
112 | _, _ -> { instptr = urm.instptr ; regs = urm.regs } |> urm_move_down
113 in if instptr_end urm.instptr then urm else aux (instptr_get urm.instptr)
114
115(* Launches the URM *)
116let rec urm_run = function
117 | { instptr = InstPtr(_, []) ; regs = reg_list } -> reg_list
118 | urm -> urm_apply urm |> urm_run
119
120(* Creates an URM from a command list and a register list *)
121let urm_mk cmd_list reg_list = { instptr = (instptr_mk cmd_list) ; regs = reg_list }
122