caml-urm

A OCaml module for manipulating unlimited register machines
urm.ml (3780B)

  1 open Array
  2 open Genlex
  3 
  4 type instruction =
  5   | T of int * int
  6   | Z of int
  7   | S of int
  8   | P of int
  9   | J of int * int * int
 10 
 11 type t =
 12   { instruction_pointer : int;
 13     registers : int -> int;
 14   }
 15 
 16 type machine = t
 17 
 18 let of_registers f =
 19   { instruction_pointer = 0;
 20     registers = f
 21   }
 22 
 23 let of_list xs =
 24   let f acc (reg_n, reg_val) = fun n -> if n = reg_n then reg_val else acc n
 25   in xs |> List.fold_left f (fun _ -> 0) |> of_registers
 26 
 27 let zeros = of_registers (fun _ -> 0)
 28 
 29 let register m = m.registers
 30 
 31 (** Executes the next instruction. Returns [Some _] is the instruction pointer
 32  points to a valid adress and [None] otherwise. *)
 33 let step (program : instruction array) (m : machine) : machine option =
 34   if m.instruction_pointer >= length program then None
 35   else
 36     let updated =
 37       match program.(m.instruction_pointer) with
 38       | T (r1, r2) ->
 39         { registers =
 40             (fun n -> if n == r2 then m.registers r1 else m.registers n);
 41           instruction_pointer = m.instruction_pointer + 1;
 42         }
 43       | Z r ->
 44         { registers = (fun n -> if n == r then 0 else m.registers n);
 45           instruction_pointer = m.instruction_pointer + 1;
 46         }
 47       | S r ->
 48         { registers =
 49             (fun n -> if n == r then 1 + (m.registers n) else m.registers n);
 50           instruction_pointer = m.instruction_pointer + 1;
 51         }
 52       | P r ->
 53         { registers =
 54             (fun n -> if n == r then (m.registers n) - 1 else m.registers n);
 55           instruction_pointer = m.instruction_pointer + 1;
 56         }
 57       | J (r1, r2, i) when m.registers r1 == m.registers r2 ->
 58         (* [i - 1] is used so that the instruction count starts at 1 instead of
 59          0 *)
 60         if i > 0 then { m with instruction_pointer = i - 1 }
 61         else
 62           let e = Printf.sprintf "invalid jump address: J(%d, %d, %d)" r1 r2 i
 63           in raise (Invalid_argument e)
 64       | J _ ->
 65         { m with instruction_pointer = m.instruction_pointer + 1 }
 66     in Some updated
 67 
 68 let rec exec program m =
 69   match step program m with
 70   | None -> { m with instruction_pointer = 0 }
 71   | Some n -> exec program n
 72 
 73 let nexec max program m =
 74   if max <= 0
 75   then raise (Invalid_argument "the number of clock-cycles must be positive ")
 76   else
 77     let rec exec_safe_tail m clock_cycles =
 78       if clock_cycles <= max
 79       then
 80         match step program m with
 81         | None -> Some { m with instruction_pointer = 0 }
 82         | Some n -> exec_safe_tail n (clock_cycles + 1)
 83       else None
 84     in exec_safe_tail m 0
 85 
 86 
 87 (********************************** Parsing **********************************)
 88 
 89 exception Syntax_error of string
 90 
 91 (** A simple lexer for instructions *)
 92 let lex = make_lexer ["T"; "Z"; "S"; "P"; "J"; "("; ")"; ","]
 93 
 94 (** Parse a single instruction *)
 95 let parse_instruction (i : token list) : instruction =
 96   match i with
 97   | [ Kwd "T"; Kwd "("; Int r1; Kwd ","; Int r2; Kwd ")" ] ->
 98       T (r1, r2)
 99   | [ Kwd "Z"; Kwd "("; Int r; Kwd ")" ] ->
100       Z r
101   | [ Kwd "S"; Kwd "("; Int r; Kwd ")" ] ->
102       S r
103   | [ Kwd "P"; Kwd "("; Int r; Kwd ")" ] ->
104       P r
105   | [ Kwd "J"; Kwd "("; Int r1; Kwd ","; Int r2; Kwd ","; Int i; Kwd ")" ]
106   when i > 0 ->
107       J (r1, r2, i)
108   | [ Kwd "J"; Kwd "("; Int _; Kwd ","; Int _; Kwd ","; Int i; Kwd ")" ] ->
109       raise (Syntax_error (Printf.sprintf "invalid jump address: %d" i))
110   | _ ->
111       raise (Syntax_error "invalid syntax")
112 
113 let parse (s : string) : instruction array =
114     let f s =
115       let s = String.trim s in
116       if s = "" then None
117       else
118           s |> Stream.of_string
119             |> lex
120             |> Stream.npeek 8
121             |> parse_instruction
122             |> Option.some
123     in
124       s |> String.split_on_char '\n'
125         |> List.filter_map f
126         |> Array.of_list
127