diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Makefile | 6 | ||||
| -rw-r--r-- | src/ast.ml | 1 | ||||
| -rw-r--r-- | src/codegen.ml | 6 | ||||
| -rw-r--r-- | src/main.ml | 120 | ||||
| -rw-r--r-- | src/parser.mly | 6 | ||||
| -rw-r--r-- | src/pretty_typing.ml | 19 | ||||
| -rwxr-xr-x | src/test.sh | 14 | ||||
| -rw-r--r-- | src/typing.ml | 169 |
8 files changed, 197 insertions, 144 deletions
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 @@ -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; } |