refactor handling slot/method indices

lib/runtime/code.ml

@@ -48,7 +48,6 @@ let add_ins bb is =
   bb.ins_list <- []
 
 type program = { entrypoint : basic_block }
-
 type Value.mthd += Method of program
 
 let make_program entrypoint = { entrypoint }

lib/runtime/interp.ml

@@ -1,20 +1,22 @@
 exception Runtime_error of string
 
+let runtime_error f = Fmt.kstr (fun s -> raise (Runtime_error s)) f
+
 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")
+    | _, _ -> 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")
+    | _, _ -> 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")
+    | _, _ -> runtime_error "cannot mul non integer values"
 
   let eql v1 v2 =
     match v1, v2 with
@@ -24,12 +26,12 @@ module Op = struct
   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")
+    | _, _ -> 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")
+    | _, _ -> runtime_error "cannot compare non integer values"
 
   let is_truthy = function
     | Value.False | Value.Nil -> false
@@ -37,39 +39,35 @@ module Op = struct
 
   let not v = Value.bool (not (is_truthy v))
 
-  let slt o nm =
+  let slt obj name =
-    match o with
+    match obj with
     | Value.Obj (vtable, _) -> (
-      match Hashtbl.find vtable.elems nm with
+        try Value.of_elem (Hashtbl.find vtable.elems name)
-      | Value.Field i -> Value.int i
+        with Not_found -> runtime_error "no such element %S" name)
-      | Value.Method i -> Value.int (-succ i)
+    | _ -> runtime_error "get element of non-object"
-      | exception Not_found -> raise (Runtime_error (Fmt.str "no method %S" nm)))
-    | _ -> raise (Runtime_error "get element of non-object")
 
-  let get o s =
+  let get obj el =
-    match o, s with
+    match obj, Value.to_elem el with
-    | Value.Obj (_, slots), Value.Int i ->
+    | Value.Obj (_, slots), Field i -> slots.(i)
-        let i = Int64.to_int i in
+    | Value.Obj (_, _), Method _ -> failwith "Interp.Op.get: TODO: method reification"
-        if i < 0 then
+    | exception Invalid_argument _ -> runtime_error "invalid index"
-          failwith "Interp.Op.get: TODO: method reification"
+    | _ -> runtime_error "get field of non-object"
-        else
-          slots.(i)
-    | _ -> raise (Runtime_error "get field of non-object")
 
-  let set o s v =
+  let set obj el v =
-    match o, s with
+    match obj, Value.to_elem el with
-    | Value.Obj (_, slots), Value.Int i -> slots.(Int64.to_int i) <- v
+    | Value.Obj (_, slots), Field i -> slots.(i) <- v
-    | _ -> raise (Runtime_error "set field of non-object")
+    | Value.Obj (_, _), Method _ -> runtime_error "cannot reassign method"
+    | exception Invalid_argument _ -> runtime_error "invalid index"
+    | _ -> runtime_error "set field of non-object"
 
-  let mthd o s =
+  let mthd obj el =
-    match o, s with
+    match obj, Value.to_elem el with
-    | Value.Obj (vtable, _), Value.Int i ->
+    | Value.Obj (vtable, _), Method i -> obj, vtable.mthds.(i)
-        let i = Int64.to_int i in
+    | Value.Obj (_, _), Field _ -> failwith "Interp.Op.get: TODO: fcf calls"
-        if i < 0 then
+    | exception Invalid_argument _ -> runtime_error "invalid index"
-          o, vtable.mthds.(-succ i)
+    | _ ->
-        else
+        (* TODO: create vtable from primitive types *)
-          failwith "Interp.Op.get: first class function calls"
+        runtime_error "call field of non-object"
-    | _ -> raise (Runtime_error "call method of non-object")
 end
 
 type frame = {
@@ -102,9 +100,9 @@ let rec exec fr = function
   | 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.SLT (o, e, nm) -> fr.regs.(e) <- Op.slt fr.regs.(o) nm
-  | Code.GET (o, s) -> fr.regs.(s) <- Op.get fr.regs.(o) fr.regs.(s)
+  | Code.GET (o, e) -> fr.regs.(e) <- Op.get fr.regs.(o) fr.regs.(e)
-  | Code.SET (o, s) -> Op.set fr.regs.(o) fr.regs.(s) fr.regs.(s + 1)
+  | Code.SET (o, e) -> Op.set fr.regs.(o) fr.regs.(e) fr.regs.(e + 1)
   | Code.RET -> fr.pc <- []
   | Code.CLL (o, m, k) ->
       let self, mthd = Op.mthd fr.regs.(o) fr.regs.(m) in
@@ -114,13 +112,12 @@ let rec exec fr = function
   | 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
+and call mthd self args =
+  match mthd with
   | Code.Method pr ->
-      if args <> [] then
+      if args <> [] then failwith "Interp.call: TODO: method arguments";
-        failwith "Interp.call: TODO: method arguments";
       run_program pr
-  | _ ->
+  | _ -> Value.call mthd self args
-      Value.call mthd self args
 
 and run fr =
   match fr.pc with

lib/runtime/value.ml

@@ -21,12 +21,25 @@ type t =
   | Obj of vtable * t array
 
 let make_obj vtable = Obj (vtable, Array.make vtable.n_slots Nil)
-let int n = Int (Int64.of_int n)
 
 let bool = function
   | true -> True
   | false -> False
 
+let of_elem e =
+  let idx =
+    match e with
+    | Field i -> i
+    | Method i -> -succ i
+  in
+  Int (Int64.of_int idx)
+
+let to_elem = function
+  | Int idx ->
+      let i = Int64.to_int idx in
+      if i >= 0 then Field i else Method (-succ i)
+  | _ -> invalid_arg "to_elem: non integer value"
+
 let rec pp ppf = function
   | Obj (vtable, slots) -> pp_obj ppf vtable slots
   | Int n -> Fmt.string ppf (Int64.to_string n)
@@ -50,9 +63,9 @@ and pp_obj ppf vtable slots =
     vtable.elems;
   Fmt.pf ppf "}"
 
-type mthd +=
+type mthd += Native_function of (t -> t list -> t)
-   | Native_function of (t -> t list -> t)
 
-let call mthd self args = match mthd with
+let call mthd self args =
+  match mthd with
   | Native_function f -> f self args
   | _ -> raise Not_found