121 lines
3.8 KiB
OCaml
121 lines
3.8 KiB
OCaml
exception Runtime_error of string
|
|
|
|
let runtime_error f =
|
|
Fmt.kstr (fun s -> raise (Runtime_error s)) f
|
|
|
|
module Prim = struct
|
|
let intop name ( ** ) v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.Int (x ** y)
|
|
| _, _ -> runtime_error "cannot %s non integer values" name
|
|
|
|
let cmpop ( </> ) v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.of_bool (Int64.compare x y </> 0)
|
|
| _, _ -> runtime_error "cannot compare non integer values"
|
|
|
|
let add = intop "add" Int64.add
|
|
let sub = intop "sub" Int64.sub
|
|
let mul = intop "mul" Int64.mul
|
|
let lst = cmpop ( < )
|
|
let grt = cmpop ( > )
|
|
let eql v1 v2 = Value.of_bool (Value.equal v1 v2)
|
|
let not v = Value.of_bool (not (Value.truthy v))
|
|
|
|
let loc obj name =
|
|
try
|
|
match obj with
|
|
| Value.Obj (vtable, _) ->
|
|
Value.of_elem (Hashtbl.find vtable.elems name)
|
|
| _ ->
|
|
(* TODO: vtable of primitive types *)
|
|
raise Not_found
|
|
with
|
|
Not_found -> runtime_error "no such element %S" name
|
|
|
|
let get obj loc =
|
|
match obj, Value.to_elem loc with
|
|
| Value.Obj (_, s), Field i -> s.(i)
|
|
| Value.Obj (_, _), Method _ -> failwith "Interp.Prim.get: TODO: fcf"
|
|
| exception Invalid_argument _ -> runtime_error "invalid index"
|
|
| _ -> runtime_error "get field of non-object"
|
|
|
|
let set obj loc v =
|
|
match obj, Value.to_elem loc with
|
|
| Value.Obj (_, s), Field i -> s.(i) <- v
|
|
| Value.Obj (_, _), Method _ -> runtime_error "cannot reassign method"
|
|
| exception Invalid_argument _ -> runtime_error "invalid index"
|
|
| _ -> runtime_error "set field of non-object"
|
|
|
|
let mthd obj loc =
|
|
match obj, Value.to_elem loc with
|
|
| Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
|
|
| Value.Obj (_, _), Field _ -> failwith "Interp.Prim.mthd: TODO: fcf"
|
|
| exception Invalid_argument _ -> runtime_error "invalid index"
|
|
| _ ->
|
|
(* TODO: vtable of primitive types *)
|
|
runtime_error "call method of non-object"
|
|
end
|
|
|
|
type frame = {
|
|
r : Value.t array;
|
|
mutable pc : Code.ins list;
|
|
mutable rv : Value.t;
|
|
}
|
|
|
|
let jmp fr b = fr.pc <- Code.instructions b
|
|
|
|
let rec exec ({ r; _ } as fr) = function
|
|
| Code.LDI (R a, v) -> r.(a) <- v
|
|
| Code.LDR (R a, R b) -> r.(a) <- r.(b)
|
|
| Code.ADD (R a, R b, R c) -> r.(a) <- Prim.add r.(b) r.(c)
|
|
| Code.SUB (R a, R b, R c) -> r.(a) <- Prim.sub r.(b) r.(c)
|
|
| Code.MUL (R a, R b, R c) -> r.(a) <- Prim.mul r.(b) r.(c)
|
|
| Code.LST (R a, R b, R c) -> r.(a) <- Prim.lst r.(b) r.(c)
|
|
| Code.GRT (R a, R b, R c) -> r.(a) <- Prim.grt r.(b) r.(c)
|
|
| Code.NOT (R a, R b) -> r.(a) <- Prim.not r.(b)
|
|
| Code.EQL (R a, R b, R c) -> r.(a) <- Prim.eql r.(b) r.(c)
|
|
| Code.GET (R a, R b, R c) -> r.(a) <- Prim.get r.(b) r.(c)
|
|
| Code.SET (R a, R b, R c) -> Prim.set r.(b) r.(c) r.(a)
|
|
| Code.LOC (R a, R b, el) -> r.(a) <- Prim.loc r.(b) el
|
|
| Code.CON (R a, vtbl) -> r.(a) <- Value.make_obj vtbl
|
|
| Code.CAL (R a, R b, R c, args) ->
|
|
let obj, mthd = Prim.mthd r.(b) r.(c) in
|
|
let args = List.map (fun (Code.R i) -> r.(i)) args in
|
|
r.(a) <- call mthd obj args
|
|
| Code.JMP b -> jmp fr b
|
|
| Code.CBR (R a, b1, b2) ->
|
|
jmp fr (if Value.truthy r.(a) then b1 else b2)
|
|
| Code.RET (R a) ->
|
|
fr.rv <- r.(a);
|
|
fr.pc <- []
|
|
|
|
and call mthd self args =
|
|
match mthd with
|
|
| Code.Function fn -> run fn self args
|
|
| _ -> Value.call mthd self args
|
|
|
|
and step fr =
|
|
match fr.pc with
|
|
| [] -> ()
|
|
| i :: rest ->
|
|
fr.pc <- rest;
|
|
exec fr i;
|
|
step fr
|
|
|
|
and run fn self args =
|
|
let Code.{ n_args; frame_size; entry } = fn in
|
|
if List.length args <> n_args then
|
|
runtime_error "wrong number of arguments, expected %d, got %d"
|
|
n_args (List.length args);
|
|
|
|
let r = Array.make frame_size Value.Nil in
|
|
r.(0) <- self;
|
|
List.iteri (fun i v -> r.(i + 1) <- v) args;
|
|
|
|
let fr = { r; pc = []; rv = Nil } in
|
|
jmp fr entry;
|
|
step fr;
|
|
fr.rv
|
|
|