134 lines
4.2 KiB
OCaml
134 lines
4.2 KiB
OCaml
exception Runtime_error of string
|
|
|
|
module Op = struct
|
|
let add v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.Int (Int64.add x y)
|
|
| _, _ -> raise (Runtime_error "cannot add non integer values")
|
|
|
|
let sub v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.Int (Int64.sub x y)
|
|
| _, _ -> raise (Runtime_error "cannot sub non integer values")
|
|
|
|
let mul v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.Int (Int64.mul x y)
|
|
| _, _ -> raise (Runtime_error "cannot mul non integer values")
|
|
|
|
let eql v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.bool (Int64.equal x y)
|
|
| _, _ -> Value.bool (v1 == v2)
|
|
|
|
let lst v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y < 0)
|
|
| _, _ -> raise (Runtime_error "cannot compare non integer values")
|
|
|
|
let grt v1 v2 =
|
|
match v1, v2 with
|
|
| Value.Int x, Value.Int y -> Value.bool (Int64.compare x y > 0)
|
|
| _, _ -> raise (Runtime_error "cannot compare non integer values")
|
|
|
|
let is_truthy = function
|
|
| Value.False | Value.Nil -> false
|
|
| _ -> true
|
|
|
|
let not v = Value.bool (not (is_truthy v))
|
|
|
|
let slt o nm =
|
|
match o with
|
|
| Value.Obj (vtable, _) -> (
|
|
match Hashtbl.find vtable.elems nm with
|
|
| Value.Field i -> Value.int i
|
|
| Value.Method i -> Value.int (-succ i)
|
|
| exception Not_found -> raise (Runtime_error (Fmt.str "no method %S" nm)))
|
|
| _ -> raise (Runtime_error "get element of non-object")
|
|
|
|
let get o s =
|
|
match o, s with
|
|
| Value.Obj (_, slots), Value.Int i ->
|
|
let i = Int64.to_int i in
|
|
if i < 0 then
|
|
failwith "Interp.Op.get: TODO: method reification"
|
|
else
|
|
slots.(i)
|
|
| _ -> raise (Runtime_error "get field of non-object")
|
|
|
|
let set o s v =
|
|
match o, s with
|
|
| Value.Obj (_, slots), Value.Int i -> slots.(Int64.to_int i) <- v
|
|
| _ -> raise (Runtime_error "set field of non-object")
|
|
|
|
let mthd o s =
|
|
match o, s with
|
|
| Value.Obj (vtable, _), Value.Int i ->
|
|
let i = Int64.to_int i in
|
|
if i < 0 then
|
|
o, vtable.mthds.(-succ i)
|
|
else
|
|
failwith "Interp.Op.get: first class function calls"
|
|
| _ -> raise (Runtime_error "call method of non-object")
|
|
end
|
|
|
|
type frame = {
|
|
regs : Value.t array;
|
|
mutable pc : Code.ins list;
|
|
}
|
|
|
|
let make_frame prog =
|
|
{
|
|
regs = Array.make (Code.frame_size prog) Value.Nil;
|
|
pc = Code.instructions Code.(prog.entrypoint);
|
|
}
|
|
|
|
let return_value fr = fr.regs.(0)
|
|
|
|
let eval fr = function
|
|
| Code.Cst_nil -> Value.Nil
|
|
| Code.Cst_true -> Value.True
|
|
| Code.Cst_false -> Value.False
|
|
| Code.Cst_int n -> Value.Int n
|
|
| Code.Reg i -> fr.regs.(i)
|
|
|
|
let rec exec fr = function
|
|
| Code.MOV (l, r) -> fr.regs.(l) <- eval fr r
|
|
| Code.ADD (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
|
| Code.SUB (l, r) -> fr.regs.(l) <- Op.add fr.regs.(l) (eval fr r)
|
|
| Code.MUL (l, r) -> fr.regs.(l) <- Op.mul fr.regs.(l) (eval fr r)
|
|
| Code.EQL (l, r) -> fr.regs.(l) <- Op.eql fr.regs.(l) (eval fr r)
|
|
| Code.LST (l, r) -> fr.regs.(l) <- Op.lst fr.regs.(l) (eval fr r)
|
|
| Code.GRT (l, r) -> fr.regs.(l) <- Op.grt fr.regs.(l) (eval fr r)
|
|
| Code.NOT l -> fr.regs.(l) <- Op.not fr.regs.(l)
|
|
| Code.CON (l, vt) -> fr.regs.(l) <- Value.make_obj vt
|
|
| Code.SLT (o, s, nm) -> fr.regs.(s) <- Op.slt fr.regs.(o) nm
|
|
| Code.GET (o, s) -> fr.regs.(s) <- Op.get fr.regs.(o) fr.regs.(s)
|
|
| Code.SET (o, s) -> Op.set fr.regs.(o) fr.regs.(s) fr.regs.(s + 1)
|
|
| Code.RET -> fr.pc <- []
|
|
| Code.CLL (o, m, k) ->
|
|
let self, mthd = Op.mthd fr.regs.(o) fr.regs.(m) in
|
|
let args = List.init k (fun i -> fr.regs.(m + i + 1)) in
|
|
fr.regs.(m) <- call mthd self args
|
|
| Code.JMP l -> fr.pc <- Code.instructions l
|
|
| Code.CBR (v, l1, l2) ->
|
|
fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)
|
|
|
|
and call mthd self args = match mthd with
|
|
| Code.Method pr ->
|
|
if args <> [] then
|
|
failwith "Interp.call: TODO: method arguments";
|
|
run_program pr
|
|
| _ ->
|
|
Value.call mthd self args
|
|
|
|
and run fr =
|
|
match fr.pc with
|
|
| [] -> return_value fr
|
|
| is :: rest ->
|
|
fr.pc <- rest;
|
|
exec fr is;
|
|
run fr
|
|
|
|
and run_program pr = run (make_frame pr)
|