add named fields and preliminary method support

bin/main.ml

@@ -5,7 +5,7 @@ let () =
   Logs.set_level (Some Logs.Debug);
 
   try
-    let ast = parse "val z = 5 val output = 1 + (({ val x = 3 val y = 4  x * y }) + z)" in
+    let ast = parse "obj pos { val x = 3 val y = 4 } val result = pos.x" in
     let prog = compile ast in
     let ret = run prog in
     Fmt.pr "{\"program\":%a,\"output\":%a}" Code.pp_program prog Value.pp ret

lib/compile/bcc.ml

@@ -27,6 +27,11 @@ let compile modl =
             emit_mov sp (Code.cst_of_int slot);
             emit (GET (self, sp));
             Reg sp)
+    | Ast.Path (Ele (obj, ele)) ->
+        emit_mov (sp + 1) (compile_exp env sp obj);
+        emit (SLT (sp + 1, sp, ele));
+        emit (GET (sp + 1, sp));
+        Reg sp
     | Ast.Binop (op, lhs, rhs) ->
         let lhs = compile_exp env sp lhs in
         emit_mov sp lhs;
@@ -83,7 +88,11 @@ let compile modl =
         (env, 0)
         items
     in
-    let vtable = Value.{ elems; n_slots } in
+
+    (* compile methods *)
+    let mthds = [||] in
+
+    let vtable = Value.{ n_slots; elems; mthds } in
 
     (* emit constructor, compile val fields, and get result of final expression *)
     emit (CON (self, vtable));

lib/runtime/code.ml

@@ -26,8 +26,10 @@ and ins =
   | GRT of regidx * operand
   | NOT of regidx
   | CON of regidx * Value.vtable
+  | SLT of regidx * regidx * string
   | GET of regidx * regidx
   | SET of regidx * regidx
+  | CLL of regidx * regidx * int
   | JMP of basic_block
   | CBR of operand * basic_block * basic_block
   | RET
@@ -47,6 +49,8 @@ let add_ins bb is =
 
 type program = { entrypoint : basic_block }
 
+type Value.mthd += Method of program
+
 let make_program entrypoint = { entrypoint }
 
 let frame_size prog =
@@ -67,12 +71,13 @@ let frame_size prog =
     | LST (r, v)
     | GRT (r, v) -> op (reg acc r) v
     | CON (r, _) | NOT r -> reg acc r
-    | GET (o, v) -> reg (reg acc o) v
+    | GET (o, s) | SLT (o, s, _) -> reg (reg acc o) s
-    | SET (o, v) -> reg (reg acc o) (v + 1)
+    | SET (o, s) -> reg (reg acc o) (s + 1)
     | CBR (v, b1, b2) ->
         enqueue b1;
         enqueue b2;
         op acc v
+    | CLL (o, m, k) -> reg (reg acc o) (m + k + 1)
     | JMP b ->
         enqueue b;
         acc
@@ -104,7 +109,7 @@ let pp_vtable ppf vt =
   let sep = ref "" in
   Hashtbl.iter
     (fun name -> function
-      | Value.Method -> ()
+      | Value.Method _ -> ()
       | Value.Field idx ->
           Fmt.pf ppf "%s%s@%d" !sep name idx;
           sep := ";")
@@ -121,8 +126,16 @@ let pp_ins ~label ppf = function
   | GRT (l, r) -> Fmt.pf ppf "grt %a, %a" pp_reg l pp_operand r
   | NOT l -> Fmt.pf ppf "not %a" pp_reg l
   | CON (l, vt) -> Fmt.pf ppf "con %a, %a" pp_reg l pp_vtable vt
+  | SLT (o, s, n) -> Fmt.pf ppf "mov %a, @%a.%s" pp_reg s pp_reg o n
   | GET (o, s) -> Fmt.pf ppf "mov %a, %a[%a]" pp_reg s pp_reg o pp_reg s
   | SET (o, s) -> Fmt.pf ppf "mov %a[%a], %a" pp_reg o pp_reg s pp_reg (s + 1)
+  | CLL (o, m, k) ->
+      Fmt.pf ppf "cll %a[%a](" pp_reg o pp_reg m;
+      for i = 1 to k do
+        if i > 1 then Fmt.pf ppf ",";
+        Fmt.pf ppf "%a" pp_reg (m + i)
+      done;
+      Fmt.pf ppf ")"
   | CBR (v, b1, b2) ->
       let l1 = label b1 in
       let l2 = label b2 in

lib/runtime/interp.ml

@@ -31,21 +31,45 @@ module Op = struct
     | Value.Int x, Value.Int y -> Value.bool (Int64.compare x y > 0)
     | _, _ -> raise (Runtime_error "cannot compare non integer values")
 
-  let truthy = function
+  let is_truthy = function
     | Value.False | Value.Nil -> false
     | _ -> true
 
-  let not v = Value.bool (not (truthy v))
+  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 -> slots.(Int64.to_int i)
+    | 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 = {
@@ -68,7 +92,7 @@ let eval fr = function
   | Code.Cst_int n -> Value.Int n
   | Code.Reg i -> fr.regs.(i)
 
-let exec fr = function
+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)
@@ -78,14 +102,27 @@ let 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.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.truthy (eval fr v) then l1 else l2)
+      fr.pc <- Code.instructions (if Op.is_truthy (eval fr v) then l1 else l2)
 
-let rec run fr =
+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 ->
@@ -93,4 +130,4 @@ let rec run fr =
       exec fr is;
       run fr
 
-let run_program pr = run (make_frame pr)
+and run_program pr = run (make_frame pr)

lib/runtime/value.ml

@@ -1,19 +1,17 @@
+type slotidx = int
+type mthdidx = int
+
 type vtable = {
   n_slots : int;
   elems : (string, elem) Hashtbl.t;
+  mthds : mthd array;
 }
 
-and slotidx = int
-
 and elem =
   | Field of slotidx
-  | Method (* of callable *)
+  | Method of mthdidx
 
-let make_vtable fields =
+and mthd = ..
-  {
-    n_slots = List.length fields;
-    elems = List.to_seq fields |> Seq.mapi (fun i name -> name, Field i) |> Hashtbl.of_seq;
-  }
 
 type t =
   | Nil
@@ -23,6 +21,7 @@ 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
@@ -44,9 +43,16 @@ and pp_obj ppf vtable slots =
   let sep = ref "" in
   Hashtbl.iter
     (fun name -> function
-      | Method -> ()
+      | Method _ -> ()
       | Field idx ->
           Fmt.pf ppf "%s%S:%a" !sep name pp slots.(idx);
           sep := ",")
     vtable.elems;
   Fmt.pf ppf "}"
+
+type mthd +=
+   | Native_function of (t -> t list -> t)
+
+let call mthd self args = match mthd with
+  | Native_function f -> f self args
+  | _ -> raise Not_found