open Bigarray

let create_array n = Array1.create int32 c_layout n
let empty_array = create_array 0
let array_copy a = 
  let t = Array1.create int32 c_layout (Array1.dim a) in
  Array1.blit a t;
  t

let arr = Array.create 65536 [||]

let arr_get n =
  let high = Int32.to_int (Int32.shift_right_logical n 16) in
  assert (0 <= high && high <= 0xffff);
  let low = (Int32.to_int n) land 0xffff in
  assert (0 <= low && low <= 0xffff);
  let a = arr.(high) in
  assert (Array.length a = 65536);
  a.(low)

let arr_set n ba =
  let high = Int32.to_int (Int32.shift_right_logical n 16) in
  assert (0 <= high && high <= 0xffff);
  let low = (Int32.to_int n) land 0xffff in
  assert (0 <= low && low <= 0xffff);
  if Array.length arr.(high) = 0 then 
    arr.(high) <- Array.create 65536 empty_array;
  let a = arr.(high) in
  a.(low) <- ba

let code =
  let file = Sys.argv.(1) in
  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
  let len = Unix.lseek fd 0 Unix.SEEK_END in
  ignore (Unix.lseek fd 0 Unix.SEEK_SET);
  let arr = Array1.create int32 c_layout (len/4) in
  let ch = Unix.in_channel_of_descr fd in
  for i = 0 to len/4 - 1 do
    let a = input_char ch in
    let b = input_char ch in
    let c = input_char ch in
    let d = input_char ch in
    Array1.set arr i 
      (Int32.logor (Int32.shift_left (Int32.of_int (Char.code a)) 24)
	 (Int32.logor (Int32.shift_left (Int32.of_int (Char.code b)) 16)
	    (Int32.logor (Int32.shift_left (Int32.of_int (Char.code c)) 8)
	       ((Int32.of_int (Char.code d))))))
  done;
  arr

let () = arr_set 0l code 

let free_stack = Stack.create ()
let max_stack = ref 1024
let () = for i = 1 to !max_stack -  1 do Stack.push i free_stack done

let alloc n =
  if Stack.is_empty free_stack then begin
    let nb = !max_stack in
    if nb > max_int - 1024 then failwith "jc_um3: overflow in alloc";
    max_stack := !max_stack + 1024;
    for i = nb to nb + 1023 do Stack.push i free_stack done
  end;
  let idx = Stack.pop free_stack in
  let a = create_array n in
  Array1.fill a 0l;
  let idxl = Int32.of_int idx in
  arr_set idxl a;
  idxl

let dealloc idx =
  arr_set idx empty_array;
  Stack.push (Int32.to_int idx) free_stack

let all_ones = 
  Int32.logor 
    (Int32.of_int 0b1111111111111111)
    (Int32.shift_left (Int32.of_int 0b1111111111111111) 16)

let int64_of_uint32 n = 
  if n >= 0l then 
    Int64.of_int32 n
  else
    Int64.add (Int64.of_int32 n) (Int64.shift_left Int64.one 32)

let add_uint32 x y = 
  Int64.to_int32 (Int64.add (int64_of_uint32 x) (int64_of_uint32 y))
let mul_uint32 x y = 
  Int64.to_int32 (Int64.mul (int64_of_uint32 x) (int64_of_uint32 y))
let div_uint32 x y = 
  Int64.to_int32 (Int64.div (int64_of_uint32 x) (int64_of_uint32 y))

let reg = Array.create 8 Int32.zero

let decode n =
  Int32.to_int (Int32.shift_right_logical n 28),
  (Int32.to_int (Int32.shift_right n 6)) land 7,
  (Int32.to_int (Int32.shift_right n 3)) land 7,
  (Int32.to_int n) land 7

let decode13 n =
  (Int32.to_int (Int32.shift_right n 25)) land 7,
  Int32.logand n 33554431l

let rec exec pc =
  let n = Array1.get (arr_get 0l) pc in
  let op,a,b,c = decode n in
  (*Format.printf "n=%ld op=%d a=%d b=%d c=%d@." n op a b c;*)
  match op with
    | 0 ->
	if reg.(c) <> 0l then reg.(a) <- reg.(b);
	exec (pc+1)
    | 1 ->
	reg.(a) <- 
	  Array1.get 
	  (arr_get reg.(b)) 
	  (Int32.to_int reg.(c));
	exec (pc+1)
    | 2 ->
	Array1.set (arr_get reg.(a)) (Int32.to_int reg.(b)) reg.(c);
	exec (pc+1)
    | 3 ->
	reg.(a) <- add_uint32 reg.(b) reg.(c);
	exec (pc+1)
    | 4 ->
	reg.(a) <- mul_uint32 reg.(b) reg.(c);
	exec (pc+1)
    | 5 ->
	reg.(a) <- div_uint32 reg.(b) reg.(c);
	exec (pc+1)
    | 6 ->
	reg.(a) <- Int32.lognot (Int32.logand reg.(b) reg.(c));
	exec (pc+1)
    | 7 ->
	print_string "halt.\n";
	exit 0
    | 8 ->
	reg.(b) <- alloc (Int32.to_int reg.(c));
	exec (pc+1)
    | 9 -> 
	dealloc reg.(c);
	exec (pc+1)
    | 10 ->
	let c = Int32.to_int reg.(c) in
	assert (0 <= c && c <= 255);
	print_char (Char.chr c); flush stdout;
	exec (pc+1)
    | 11 ->
	begin
	  try 
	    let ch = input_char stdin in
	    reg.(c) <- Int32.of_int (Char.code ch)
	  with End_of_file ->
	    reg.(c) <- all_ones
	end;
	exec (pc+1)
    | 12 -> 
	let valb = reg.(b) in
	if valb <> 0l then begin
	  let new_code = arr_get valb in
	  arr_set 0l (array_copy new_code)
	end;
	exec (Int32.to_int reg.(c))
    | 13 -> 
	let a,value = decode13 n in
	reg.(a) <- value;
	exec (pc+1)
    | d -> 
	failwith ("unsupported operation: " ^ string_of_int d)

let () = exec 0