diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/mod_student/translator.ml | 115 |
1 files changed, 110 insertions, 5 deletions
diff --git a/source/mod_student/translator.ml b/source/mod_student/translator.ml index 1514319..6831038 100644 --- a/source/mod_student/translator.ml +++ b/source/mod_student/translator.ml @@ -114,6 +114,8 @@ module Make() = struct let i32_0 = Int32.of_int 0 let i32_1 = Int32.of_int 1 + let int32_of_bool b = Int32.of_int ( + if b then 1 else 0 ) (* --------------------------------------------------- *) let rec translate_expression env current_bb = function @@ -121,8 +123,74 @@ module Make() = struct current_bb, E_Int (Int32.of_int @@ Char.code value) | Ast.EXPR_Id {id; _} -> + current_bb, E_Reg (Environment.lookup_var id env) - + | Ast.EXPR_Int {value;_} -> + current_bb, E_Int value + + | Ast.EXPR_Bool {value; _} -> + current_bb, E_Int (int32_of_bool value) + + | Ast.EXPR_Binop {lhs;rhs;op=Ast.BINOP_Add;tag;_} -> + let reg= allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + begin + match Hashtbl.find node2type tag with + | TP_Int -> append_instruction current_bb @@ I_Add ( reg, lhs, rhs) + | TP_Array _ -> append_instruction current_bb @@ I_Concat ( reg, lhs, rhs) + | TP_Bool -> failwith "Internal error" + end; + current_bb, E_Reg reg + + | Ast.EXPR_Binop {lhs;rhs;op=Ast.BINOP_Sub;_} -> + let reg= allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + append_instruction current_bb @@ I_Sub ( reg, lhs, rhs); + current_bb, E_Reg reg + + | Ast.EXPR_Binop {lhs;rhs;op=Ast.BINOP_Mult;_} -> + let reg= allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + append_instruction current_bb @@ I_Mul ( reg, lhs, rhs); + current_bb, E_Reg reg + + | Ast.EXPR_Binop {lhs;rhs;op=Ast.BINOP_Div;_} -> + let reg= allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + append_instruction current_bb @@ I_Div ( reg, lhs, rhs); + current_bb, E_Reg reg + + | Ast.EXPR_Binop {lhs;rhs;op=Ast.BINOP_Rem;_} -> + let reg= allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + append_instruction current_bb @@ I_Rem ( reg, lhs, rhs); + current_bb, E_Reg reg + | Ast.EXPR_Call call -> + let reg =allocate_register() in + let current_bb,env = translate_call env current_bb call [reg] in + current_bb, E_Reg reg + | Ast.EXPR_Relation {op;lhs;rhs;_} -> + begin + let convert_rel = function + | Ast.RELOP_Eq -> COND_Eq + | Ast.RELOP_Ne -> COND_Ne + | Ast.RELOP_Lt -> COND_Lt + | Ast.RELOP_Gt -> COND_Gt + | Ast.RELOP_Le -> COND_Le + | Ast.RELOP_Ge -> COND_Ge + in + let reg = allocate_register() in + let current_bb,lhs = translate_expression env current_bb lhs in + let current_bb,rhs = translate_expression env current_bb rhs in + append_instruction current_bb @@ I_Set(reg,convert_rel op,lhs,rhs); + current_bb, E_Reg reg + + end | _ -> failwith "not yet implemented" @@ -134,9 +202,9 @@ module Make() = struct | Ast.EXPR_Bool {value=false; _} -> set_jump current_bb else_bb; allocate_block () - + (* Zaimplementuj dodatkowe przypadki *) - + | e -> let current_bb, res = translate_expression env current_bb e in let next_bb = allocate_block () in @@ -145,14 +213,51 @@ module Make() = struct (* --------------------------------------------------- *) - + and translate_call env current_bb (Ast.Call {callee;arguments;tag;_}) returns = + begin + let rec aux current_bb = function + | [] -> [] + | x::xs -> let current_bb,r = + translate_expression env current_bb x + in r::(aux current_bb xs) + in + let arguments = aux current_bb arguments in + append_instruction current_bb @@ I_Call ( returns, Environment.lookup_proc callee env, arguments, []); + current_bb,env + end let rec translate_statement env current_bb = function + | Ast.STMT_Return {values;_} -> + begin + let rec aux current_bb = function + | [] -> [] + | x::xs -> let current_bb,r = + translate_expression env current_bb x + in r::(aux current_bb xs) + in + set_return current_bb (aux current_bb values); + current_bb,env + end + | STMT_Assign {lhs=Ast.LVALUE_Id{id;_};rhs;_} -> + let current_bb, reg = translate_expression env current_bb rhs in + let my_reg = allocate_register() in + append_instruction current_bb @@ I_Move (my_reg, reg); + current_bb, (Environment.add_var id my_reg env) + | STMT_Call call -> + translate_call env current_bb call [] | _ -> failwith "not yet implemented" and translate_block env current_bb (Ast.STMTBlock {body; _}) = - failwith "not yet implemented" + begin + let rec aux env current_bb = function + | [] -> env,current_bb + | x::xs -> let current_bb,env = + translate_statement env current_bb x + in aux env current_bb xs + in aux env current_bb body + end + let bind_var_declaration env vardecl = let r = allocate_register () in |