Implémentation de l'héritage multiple (au niveau du typage)

9 files changed, 198 insertions, 144 deletions

diff --git a/.gitignore b/.gitignore
index c4ed90c..0232dfd 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,5 +7,6 @@ _build
 *~
 *.ps
 *.pdf
+*.s
 src/parser.automaton
 src/parser.conflicts
diff --git a/src/Makefile b/src/Makefile
index f045726..e9cde1c 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -2,11 +2,9 @@ BIN=minic++
 
 all: $(BIN)
 
-$(BIN): main.byte
-	cp main.byte minic++
-
-main.byte: main.ml ast.ml parser.mly lexer.mll pretty.ml typing.ml pretty_typing.ml
+$(BIN): main.ml ast.ml parser.mly lexer.mll pretty.ml typing.ml pretty_typing.ml
 	ocamlbuild main.byte
+	mv main.byte minic++
 
 clean:
 	rm -r _build
diff --git a/src/ast.ml b/src/ast.ml
index 48a2de3..8c25853 100644
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -42,6 +42,7 @@ and expr_desc =
 	| ENull
 	| EThis
 	| EIdent of ident
+  | EQIdent of tident * ident (* class * member name *)         
 	| EAssign of expression * expression
 	| ECall of expression * expression list
 	| EUnary of unop * expression
diff --git a/src/codegen.ml b/src/codegen.ml
new file mode 100644
index 0000000..2709526
--- /dev/null
+++ b/src/codegen.ml
@@ -0,0 +1,6 @@
+open Mips
+
+
+let generate p =
+  { text = nop;
+    data = nop }
diff --git a/src/main.ml b/src/main.ml
index ca1134a..976586f 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -13,70 +13,72 @@ let set_var v s = v := s
 let usage = "usage: mini-cpp [options] file.cpp"
 
 let localisation pos =
-	let l = pos.pos_lnum in
-	let c = pos.pos_cnum - pos.pos_bol + 1 in
-	eprintf "File \"%s\", line %d, characters %d-%d:\n"
-		!ifile l (c-1) c
+  let l = pos.pos_lnum in
+  let c = pos.pos_cnum - pos.pos_bol + 1 in
+  eprintf "File \"%s\", line %d, characters %d-%d:\n"
+    !ifile l (c-1) c
 
 let localisation2 (pos1,pos2) =
-	let l = pos1.pos_lnum in
-	let c1 = pos1.pos_cnum - pos1.pos_bol + 1 in
-	let c2 = pos2.pos_cnum - pos2.pos_bol + 1 in
-	eprintf "File \"%s\", line %d, characters %d-%d:\n"
-		!ifile l c1 c2
-	
+  let l = pos1.pos_lnum in
+  let c1 = pos1.pos_cnum - pos1.pos_bol + 1 in
+  let c2 = pos2.pos_cnum - pos2.pos_bol + 1 in
+  eprintf "File \"%s\", line %d, characters %d-%d:\n"
+    !ifile l c1 c2
+  
 let options = [
-	"--parse-only", Arg.Set parse_only, "Stops after parsing of the input file.";
-	"--type-only", Arg.Set type_only, "Stops after typechecking of the input file.";
-	"--dump", Arg.Set dump, "Dump the AST after parsing.";
-	"--dumpt", Arg.Set dumpt, "Dump the AST after typing."
-	]
+  "--parse-only", Arg.Set parse_only, "Stops after parsing of the input file.";
+  "--type-only", Arg.Set type_only, "Stops after typechecking of the input file.";
+  "--dump", Arg.Set dump, "Dump the AST after parsing.";
+  "--dumpt", Arg.Set dumpt, "Dump the AST after typing."
+  ]
 
 let () =
-	Arg.parse options (set_var ifile) usage;
+  Arg.parse options (set_var ifile) usage;
 
-	if !ifile = "" then (
-		eprintf "No input file\n@?";
-		exit 1);
-	
-	if not (Filename.check_suffix !ifile ".cpp") then (
-		eprintf "Input files must have suffix .cpp\n@?";
-		Arg.usage options usage;
-		exit 1);
-	
-	let f = open_in !ifile in
-	let buf = Lexing.from_channel f in
+  if !ifile = "" then (
+    eprintf "No input file\n@?";
+    exit 1);
+  
+  if not (Filename.check_suffix !ifile ".cpp") then (
+    eprintf "Input files must have suffix .cpp\n@?";
+    Arg.usage options usage;
+    exit 1);
+  let basename = Filename.chop_suffix !ifile ".cpp" in
+  
+  let f = open_in !ifile in
+  let buf = Lexing.from_channel f in
 
-	try
-		let p = Parser.prog Lexer.token buf in
-		close_in f;
-		
-		if !dump then Pretty.print_prog p;
-		if not !parse_only then begin
-			let t = Typing.prog p in
-			if !dumpt then Pretty_typing.print_prog t;
+  try
+    let p = Parser.prog Lexer.token buf in
+    close_in f;
+    
+    if !dump then Pretty.print_prog p;
+    if not !parse_only then begin
+      let p = Typing.prog p in
+      if !dumpt then Pretty_typing.print_prog p;
 
-			if not !type_only then begin
-				()
-			end
-		end
-	with
-		| Lexer.Lexing_error s ->
-			localisation (Lexing.lexeme_start_p buf);
-			eprintf "Lexical analysis error: %s@." s;
-			exit 1
-		| Parser.Error -> 
-		        localisation (Lexing.lexeme_start_p buf);
-			eprintf "Parsing error.@.";
-			exit 1
-		| Typing.Error(msg) ->
-			eprintf "Typing error (unknown location): %s@." msg;
-			exit 2
-		| Typing.LocError (loc, msg) ->
-		  localisation2 loc;
-		  eprintf "%s@." msg;
-		  exit 2
-		  
-		| _ ->
-			eprintf "Unexpected error...@.";
-			exit 3
+      if not !type_only then begin
+        let asm = Codegen.generate p in
+        Mips.print_in_file (basename ^ ".s") asm
+      end
+    end
+  with
+    | Lexer.Lexing_error s ->
+      localisation (Lexing.lexeme_start_p buf);
+      eprintf "Lexical analysis error: %s@." s;
+      exit 1
+    | Parser.Error -> 
+            localisation (Lexing.lexeme_start_p buf);
+      eprintf "Parsing error.@.";
+      exit 1
+    | Typing.Error(msg) ->
+      eprintf "Typing error (unknown location): %s@." msg;
+      exit 2
+    | Typing.LocError (loc, msg) ->
+      localisation2 loc;
+      eprintf "%s@." msg;
+      exit 2
+      
+    | _ ->
+      eprintf "Unexpected error...@.";
+      exit 3
diff --git a/src/parser.mly b/src/parser.mly
index 3d1eb22..2d9c206 100644
--- a/src/parser.mly
+++ b/src/parser.mly
@@ -236,6 +236,10 @@ common_statement:
 	{ SWriteCout(a) }
 ;
 
+qident:
+| c = TIDENT DOUBLECOLON i = IDENT { c, i }
+;
+
 expression:
 |	e = expression_desc
 	{ { e_loc = $startpos, $endpos; e_desc = e } }
@@ -283,6 +287,8 @@ primary_desc:
 |	a = primary LPAREN arg = separated_list(COMMA, expression) RPAREN { ECall(a, arg) }
 |	a = primary DOT b = IDENT
 	{ EMember(a, b) }
+| s = qident
+  { let c, i = s in EQIdent(c, i) }
 ;
 
 runop:
diff --git a/src/pretty_typing.ml b/src/pretty_typing.ml
index 1da6f24..f9e69ff 100644
--- a/src/pretty_typing.ml
+++ b/src/pretty_typing.ml
@@ -50,8 +50,8 @@ let rec expr_string e = match e.te_desc with
 	| TENew(c, proto, arg) -> "new " ^ c.tc_name
 			^ (match proto with | None -> "" | Some p -> " ." ^ p.tp_unique_ident)
 			 ^ " (" ^ (csl expr_string arg) ^ ")"
-	| TECallVirtual(exp, pos, args) ->
-		"(" ^ (expr_string exp) ^ ")#" ^  (string_of_int pos) ^ "(" ^ (csl expr_string args) ^ ")"
+	| TECallVirtual(exp, pos1, pos2, args) ->
+		"(" ^ (expr_string exp) ^ ")@" ^ (string_of_int pos1) ^ "#" ^  (string_of_int pos2) ^ "(" ^ (csl expr_string args) ^ ")"
 
 let rec print_stmt l x =
 	for i = 1 to l do print_string " " done;
@@ -104,18 +104,23 @@ let proto_str p =
 	      p.tp_args)
   ^ ") : " ^ (match p.tp_ret_type with | Some (ty,b) -> var_type_str ty | None -> "constructor")
   	^ "  ." ^ p.tp_unique_ident
-  	^ (match p.tp_virtual with | None -> "" | Some k -> " #" ^ (string_of_int k))
+  	^ (match p.tp_virtual with | None -> "" | Some (k, l) -> " @" ^ (string_of_int k) ^ "#" ^ (string_of_int l))
 
 let print_class_decl c =
-	print_string ("class " ^ c.tc_name ^ " (size : " ^ (string_of_int c.tc_size) ^ ")"^
-		(match c.tc_super with | None -> "" | Some(k) -> " : "^ k) ^" {\n");
+	print_string ("class " ^ c.tc_name ^ " (size : " ^ (string_of_int c.tc_size) ^ ") {\n");
 	print_string " members:\n";
 	Smap.iter (fun name (t, pos) -> print_string ("  " ^ name ^ " : " ^ (var_type_str t)
 				^ " @" ^ (string_of_int pos) ^ "\n")) c.tc_members;
 	print_string " methods:\n";
 	List.iter(fun p -> print_string ("  " ^ (proto_str p) ^ "\n")) c.tc_methods;
-	print_string " vtable:\n";
-	List.iter(fun (i, p) -> print_string ("  #" ^ (string_of_int i) ^ ": ." ^ (p.tp_unique_ident) ^ "\n")) c.tc_vtable;
+	print_string " hier:\n";
+  let rec print_hier s =
+    print_string ("    @" ^ (string_of_int s.h_pos) ^" : " ^ s.h_class ^ "\n");
+	  List.iter 
+      (fun (i, p) -> print_string ("      #" ^ (string_of_int i) ^ ": ." ^ (p.tp_unique_ident) ^ "\n"))
+          s.h_vtable;
+    List.iter print_hier s.h_supers
+  in print_hier c.tc_hier;
 	print_string "}\n"
 
 let print_prog p =
diff --git a/src/test.sh b/src/test.sh
index 525be77..c1884a2 100755
--- a/src/test.sh
+++ b/src/test.sh
@@ -4,14 +4,14 @@
 echo "Testing SYNTAX/"
 
 for a in ../tests/syntax/good/*.cpp; do
-	if ./main.byte --parse-only $a;
+	if ./minic++ --parse-only $a;
 		then echo "OK    $a";
 		else echo "FAIL  $a";
 	fi;
 done;
 
 for a in ../tests/syntax/bad/*.cpp; do
-	if ./main.byte --parse-only $a 2> /dev/null;
+	if ./minic++ --parse-only $a 2> /dev/null;
 		then echo "FAIL  $a";
 		else echo "OK    $a";
 	fi;
@@ -20,7 +20,7 @@ done;
 echo "---"
 echo "Testing TYPING/ only against parsing"
 for a in ../tests/typing/*/*.cpp; do
-	if ./main.byte --parse-only $a;
+	if ./minic++ --parse-only $a;
 		then echo "OK    $a";
 		else echo "FAIL  $a";
 	fi;
@@ -29,7 +29,7 @@ done;
 echo "---"
 echo "Testing EXEC/ only against parsing"
 for a in ../tests/exec/*.cpp; do
-	if ./main.byte --parse-only $a;
+	if ./minic++ --parse-only $a;
 		then echo "OK    $a";
 		else echo "FAIL  $a";
 	fi;
@@ -38,14 +38,14 @@ done;
 echo "---"
 echo "Testing TYPING/"
 for a in ../tests/typing/good/*.cpp; do
-	if ./main.byte $a;
+	if ./minic++ $a;
 		then echo "OK    $a";
 		else echo "FAIL  $a";
 	fi;
 done;
 
 for a in ../tests/typing/bad/*.cpp; do
-	if ./main.byte $a 2> /dev/null;
+	if ./minic++ $a 2> /dev/null;
 		then echo "FAIL  $a";
 		else echo "OK    $a";
 	fi;
@@ -54,7 +54,7 @@ done;
 echo "---"
 echo "Testing EXEC/ only against typing"
 for a in ../tests/exec/*.cpp; do
-	if ./main.byte --type-only $a;
+	if ./minic++ --type-only $a;
 		then echo "OK    $a";
 		else echo "FAIL  $a";
 	fi;
diff --git a/src/typing.ml b/src/typing.ml
index d7f11eb..6b1c801 100644
--- a/src/typing.ml
+++ b/src/typing.ml
@@ -12,14 +12,15 @@ let err_add_loc loc f =
     with
         | Error(k) -> raise (LocError(loc, k))
         | LocError(_, _) as e -> raise e
+        | NoCorrespondingPrototype -> raise (LocError (loc, "No corresponding prototype"))
+        | AmbiguousOverload -> raise (LocError (loc, "Ambiguous overload"))
         | Assert_failure (k, a, b) -> raise (LocError (loc,
             "(unexpected) Assertion failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
         | Not_found -> raise (LocError (loc, "(unexpected) Not found"))
         | Invalid_argument(k) -> raise (LocError (loc, "(unexpected) Invalid argument: "^k))
         | Match_failure(k, a, b) -> raise (LocError (loc,
             "(unexpected) Match failure: "^k^" at "^(string_of_int a)^":"^(string_of_int b)))
-        | NoCorrespondingPrototype -> raise (LocError (loc, "No corresponding prototype"))
-        | AmbiguousOverload -> raise (LocError (loc, "Ambiguous overload"))
+        | Stack_overflow -> raise (LocError (loc, "(unexpected) Stack overflow"))
         | _ -> raise (LocError (loc, "(unexpected) Other error"))
 
 (* AST typés *)
@@ -50,7 +51,7 @@ and texpr_desc =
   | TECallFun of ident * texpression list (* changé : te -> ident *)
     (* calls to non-virtual methods are compiled using TECallFun, with the object cons'ed at
         the begining of the arguments expression list *)
-  | TECallVirtual of texpression * int * texpression list (* object * index in vtable * arguments *)
+  | TECallVirtual of texpression * int * int * texpression list (* object * index in vtable * arguments *)
   | TEUnary of unop * texpression
   | TEBinary of texpression * binop * texpression
   | TEMember of texpression * int   (* object * position of member *)
@@ -81,9 +82,9 @@ and ts_desc =
 and tblock = tstatement list
 
 and tproto = {
-    tp_virtual : int option;    (* only used for class methods ; if none then not virtual,
-                                        if some then gives the index of the method in the vtable (same for all classes
-                                                of the hierarchy that have that method) *)
+    tp_virtual : (int * int) option;    (* only used for class methods ; if none then not virtual,
+                          if some then gives the index of the method in the vtable (same for all classes
+                          of the hierarchy that have that method) *)
     tp_loc : loc;
     tp_name : ident;    
     tp_unique_ident : ident;    (* label de la fonction dans le code assembleur *)
@@ -92,11 +93,19 @@ and tproto = {
     tp_args : (type_ref * ident) list;
 }
 
+and tcls_supers = tcls_hier list
+and tcls_hier = {
+    h_class : tident;
+    h_pos : int;
+    mutable h_vtable : (int * tproto) list; (* only to be muted during class definition parsing *)
+    h_supers : tcls_supers
+}
+
 and tcls = {
     tc_name : tident;
     tc_size : int;
-    tc_super : tident option;
-    tc_vtable : (int * tproto) list;
+    tc_hier : tcls_hier;
+        (* tous les supers à tous les niveaux, plus la classe actuelle *)
     tc_members : (typ * int) Smap.t;    (* type du membre * position du membre dans les données de l'objet *)
     tc_methods : tproto list;
 }
@@ -170,13 +179,11 @@ let rec subtype env a b = match a, b with
     | Typenull, TPoint(_) -> true
     | TPoint(ka), TPoint(kb) -> subtype env ka kb
     | TClass(i), TClass(j) ->
-        if i = j then true
-        else let c = get_c env i in
-            (* NOT DONE : multiple supers *)
-            begin match c.tc_super with
-            | None -> false
-            | Some(k) -> subtype env (TClass k) (TClass j)
-            end
+        let c = get_c env i in
+        let rec find_in_hier h =
+          h.h_class = j ||
+          (List.exists find_in_hier h.h_supers)
+        in find_in_hier c.tc_hier
     | _ -> false
 
 let type_size env t = match t with
@@ -200,26 +207,31 @@ let closest_proto env arg_type_list fun_list =
     | [] -> raise NoCorrespondingPrototype
     | [p] -> p
     | _ -> raise AmbiguousOverload
-let find_proto_in_class env cls name arg_type_list =
-    let rec aux = function
-    | None -> raise NoCorrespondingPrototype
-    | Some(k) -> let c = get_c env k in
-        let f = List.filter (fun p -> p.tp_name = name) c.tc_methods in
-        begin try closest_proto env arg_type_list f
-        with NoCorrespondingPrototype -> aux c.tc_super
-        end
-    in aux (Some cls)
-    
+let find_protos_in_class env cls name =
+  let rec aux s =
+    match List.filter (fun p -> p.tp_name = name) (get_c env s.h_class).tc_methods with
+    | [] ->
+      List.fold_left (fun q r ->
+            match q, (aux r) with | [], l -> l | l, [] -> l | _, _ -> raise AmbiguousOverload) [] s.h_supers
+    | k -> k
+  in aux (get_c env cls).tc_hier
+
 
 let find_cls_mem env cls_name mem_name =
-    let rec aux = function
+    let rec aux s =
+      begin try let mty, mi = Smap.find mem_name (get_c env s.h_class).tc_members in
+        Some (mty, mi + s.h_pos)
+      with Not_found -> 
+        List.fold_left (fun q r ->
+          match q, (aux r) with
+          | Some l, None -> Some l
+          | None, Some l -> Some l
+          | None, None -> None
+          | _, _ -> ty_error ("Ambiguous reference to member " ^ mem_name)) None s.h_supers
+      end
+    in match aux (get_c env cls_name).tc_hier with
+    | Some k -> k
     | None -> raise Not_found
-    | Some(k) -> let c = get_c env k in
-        begin try let mty, mi = Smap.find mem_name c.tc_members in
-            mty, mi
-        with Not_found -> aux c.tc_super
-        end
-    in aux (Some cls_name)
 
 
 (* -------------------------------------------- *)
@@ -271,6 +283,7 @@ and compute_type env e =
             TEIdent i, (t, false, true)
         with Not_found -> ty_error ("Undeclared identifier: " ^ i)
         end
+    | EQIdent(c, i) -> assert false (* TODO *)
     | EAssign (e1,e2) -> let te1,(ty1,r3,b3) = get_expr0 env e1 in
              let te2,(ty2,_,_) = get_expr0 env e2 in
              ty_assert (b3 || r3) "Can only assign to lvalue";
@@ -321,7 +334,8 @@ and compute_type env e =
                     begin match env.b_class with
                     | None -> None, closest_proto env.b_pe args_types funs
                     | Some k ->
-                        begin try Some e_this_not_ptr, find_proto_in_class env.b_pe k.tc_name i args_types
+                        begin try Some e_this_not_ptr,
+                            closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k.tc_name i)
                         with NoCorrespondingPrototype ->
                             None, closest_proto env.b_pe args_types funs
                         end
@@ -330,7 +344,7 @@ and compute_type env e =
                     let e = type_expr env e in
                     begin match e.type_expr with
                     | TClass(k), a, b when a || b ->
-                        Some e, find_proto_in_class env.b_pe k i args_types
+                        Some e, closest_proto env.b_pe args_types (find_protos_in_class env.b_pe k i)
                     | _ -> ty_error "Invalid argument type for method call (not a class, or not a lvalue)"
                     end
                 | _ -> ty_error "Calling something that is neither a function nor a method") in
@@ -344,7 +358,7 @@ and compute_type env e =
           | None, Some(obj)->
                 TECallFun(tproto.tp_unique_ident,obj::l_te),(ty,b,false)
           | Some(idx), Some(obj) ->
-                TECallVirtual(obj, idx, l_te),(ty,b,false)
+                TECallVirtual(obj, fst idx, snd idx, l_te),(ty,b,false)
           | _ -> ty_error "(should not happen) Virtual function applied to no object..."
           end
     | EMember (e, id) ->
@@ -549,22 +563,34 @@ let compute_tclass env c =
     let cls_name = c.c_name in
     ty_assert (not (Smap.mem cls_name env.e_classes)) ("Redeclaration of class " ^cls_name^".");
     (* artifice pour que la classe en train d'être définie puisse être utilisée par elle-même *)
-    let forward_def = {tc_name = cls_name; tc_size = 0; tc_super = None; tc_members = Smap.empty; tc_methods = []; tc_vtable = [] } in
+    let forward_def = {
+        tc_name = cls_name;
+        tc_size = 0;
+        tc_hier = { h_class = cls_name; h_pos = 0; h_vtable = []; h_supers = [] } ;
+        tc_members = Smap.empty; tc_methods = []; } in
     let forward_env = {
         e_globals = env.e_globals;
         e_funs = env.e_funs;
         e_classes = (Smap.add cls_name forward_def env.e_classes); } in
 
-    let super, vtable, used = match c.c_supers with
-        | Some [] | None -> None, ref [], 0
-        | Some [n] -> 
-            begin try let c = get_c env n in
-                Some n, ref c.tc_vtable, c.tc_size  (* copy parent vtable, will be modified when redefined members *)
-            with Not_found -> ty_error ("Super " ^ n ^ " does not exist or is not a class.")
-            end
-        | _ -> ty_error "Intentionnal sacrifice : multiple inheritance not supported."
+    let super_list = match c.c_supers with | None -> [] | Some l -> l in
+
+    let hier, used =
+      let rec move_super diff s =
+        { h_class = s.h_class;
+          h_pos = s.h_pos + diff;
+          h_vtable = s.h_vtable;
+          h_supers = List.map (move_super diff) s.h_supers }
+      in
+      let sup, used = List.fold_left
+        (fun (sup, u) n -> let c = get_c env n in
+          (move_super u c.tc_hier)::sup, u + c.tc_size) ([], 4) super_list in
+      { h_class = cls_name;
+        h_pos = 0;
+        h_vtable = [];
+        h_supers = sup }, used
     in
-    let used = (if used = 0 then 4 else used) in    (* If no supers, reserve space for vtable pointer *)
+
     let (mem, mem_u), meth = List.fold_left
         (fun ((mem, mem_u), meth) n -> match n with
             | CVar(t, i) ->
@@ -592,26 +618,36 @@ let compute_tclass env c =
                     (*  If method is redefined from a virtual method of a parent class, it becomes virtual with same offset
                         Else if method is virtual, it gets new offset !
                         Else method is not virtual, everything is simple. *)
-                    let rec check_super = function
-                    | None -> None
-                    | Some(n) -> let c = get_c env n in
-                        try let proto = List.find
-                            (fun p -> p.tp_name = proto.p_name && p.tp_virtual <> None && (List.map fst p.tp_args) = (List.map fst args))
-                            c.tc_methods
-                        in Some (proto)
-                        with Not_found -> check_super (c.tc_super)
-                    in
-                    let vproto_in_super = check_super super in
-                    let virtl = match vproto_in_super with
-                    | Some(k) -> k.tp_virtual
-                    | None ->
-                        if not virt then None
-                        else    (* allocate new spot in vtable *)
-                            Some (List.fold_left (fun n (x, _) -> max n (x+4)) 0 !vtable)
+
+                    let rec check_in_super (s:tcls_hier) =
+                      match List.fold_left (fun k s ->
+                          let r = check_in_super s in
+                          match k, r with
+                          | None, None -> None
+                          | None, Some k -> Some k
+                          | Some k, None -> None
+                          | Some k, Some r -> ty_error ("Ambiguous redefinition of " ^ proto.p_name))
+                        None s.h_supers
+                      with
+                      | Some k -> Some k
+                      | None ->
+                        List.fold_left (fun f (i, p) -> 
+                          if (p.tp_name = proto.p_name && (List.map fst p.tp_args) = (List.map fst args))
+                            then Some (i, s)
+                            else f) None s.h_vtable
+                    in let super = match check_in_super hier with
+                    | None -> if virt then 
+                          (*  allocate new spot in vtable of this object *)
+                          Some (List.fold_left (fun n (x, _) -> max n (x+4)) 0 hier.h_vtable, hier)
+                        else None
+                    | Some k -> Some k
                     in
+
                     (* Build proto *)
                     let tproto = 
-                    {   tp_virtual = virtl;
+                    {   tp_virtual = (match super with
+                          | Some(i, c) -> Some(c.h_pos, i)
+                          | None -> None);
                         tp_loc = proto.p_loc;
                         tp_name = proto.p_name;
                         tp_unique_ident = proto.p_name ^ (tproto_unique_number()) ;
@@ -620,18 +656,17 @@ let compute_tclass env c =
                         tp_args = args;
                     } in
                     (* Add to vtable *)
-                    begin match virtl with
+                    begin match super with
                     | None -> ()
-                    | Some i ->
-                        vtable := (i, tproto)::(List.remove_assoc i !vtable)
+                    | Some (i, c) ->
+                        c.h_vtable <- (i, tproto)::(List.remove_assoc i c.h_vtable)
                     end;
                     tproto) in
                 (mem, mem_u), m::meth
         ) ((Smap.empty, used), []) c.c_members in
     {   tc_name = cls_name;
-        tc_vtable = !vtable;
         tc_size = mem_u;
-        tc_super = super;
+        tc_hier = hier;
         tc_members = mem;
         tc_methods = meth; }