Permalink
Browse files

Update C back-end to handle overloading.

  • Loading branch information...
xlq committed Sep 16, 2012
1 parent eb445b0 commit de9cf93fd7a668910e4e8434772b8d388427de99
Showing with 146 additions and 81 deletions.
  1. +114 −61 backend_c.ml
  2. +9 −1 symbols.ml
  3. +7 −1 symbols.mli
  4. +15 −9 translation.ml
  5. +1 −9 type_checking.ml
View
@@ -5,39 +5,90 @@ open Misc
open Formatting
open Big_int
type context = {
tc_vars: symbol_v Symbols.Maps.t;
}
let rec erase_type t =
match t with
| Boolean_type -> Boolean_type
| Integer_type -> Integer_type
| Uninitialised(t) -> erase_type t
let collect_types_type types loc x t =
let t = erase_type t in
match
begin try Some (Symbols.Maps.find x !types)
with Not_found -> None end
with
| None -> types := Symbols.Maps.add x t !types
| Some t2 when same_types t t2 -> ()
| Some t2 ->
Errors.semantic_error loc
(String.capitalize (describe_symbol x)
^ " has type `"
^ string_of_type t ^ "' here and type `"
^ string_of_type t2 ^ "' elsewhere. These types"
^ " cannot be stored in the same location.")
let rec collect_types_expr types = function
| Boolean_literal _ -> ()
| Integer_literal _ -> ()
| Var_v(loc, xv) ->
collect_types_type types loc xv.ver_symbol xv.ver_type
| Negation(e) -> collect_types_expr types e
| Comparison(op, lhs, rhs) ->
collect_types_expr types lhs;
collect_types_expr types rhs
let no_context = {
tc_vars = Symbols.Maps.empty;
}
let rec collect_types_iterm types = function
| Assignment_term(loc, dest, src, tail) ->
collect_types_expr types src;
collect_types_expr types dest;
collect_types_iterm types tail
| If_term(loc, condition, true_part, false_part) ->
collect_types_expr types condition;
collect_types_iterm types true_part;
collect_types_iterm types false_part
| Return_term _ -> ()
| Jump_term _ -> ()
| Call_term(call, tail) ->
List.iter (fun (arg_in, arg_out) ->
collect_types_expr types arg_in;
match arg_out with
| None -> ()
| Some arg_out ->
collect_types_expr types arg_out
) (fst call.call_arguments);
List.iter (fun (_, (arg_in, arg_out)) ->
collect_types_expr types arg_in;
match arg_out with
| None -> ()
| Some arg_out ->
collect_types_expr types arg_out
) (snd call.call_arguments);
collect_types_iterm types tail
let collect_types_blocks types blocks =
List.iter (fun block ->
collect_types_iterm types (unsome block.bl_body)
) blocks
let c_name_of_parameter sym =
let c_name_of_local sym =
sym.sym_name
let c_name_of_variable sym_v =
sym_v.ver_symbol.sym_name ^ "__" ^ string_of_int sym_v.ver_number
let c_name_of_symbol_v sym_v =
match sym_v.ver_symbol.sym_info with
| Variable_sym -> c_name_of_variable sym_v
| Parameter_sym _ -> c_name_of_parameter sym_v.ver_symbol
let c_name_of_symbol context sym =
let c_name_of_symbol sym =
match sym.sym_info with
| Variable_sym ->
c_name_of_variable (Symbols.Maps.find sym context.tc_vars)
| Parameter_sym _ ->
c_name_of_parameter sym
| Variable_sym | Parameter_sym _ ->
c_name_of_local sym
| _ ->
String.concat "__" (dotted_name sym)
let c_name_of_type = function
| Unit_type -> "void"
| Boolean_type -> "bool"
| Integer_type -> "int"
let c_name_of_subprogram ({sym_info = Subprogram_sym(info)} as sym) =
c_name_of_symbol sym
^ (if info.sub_overload_num == 0 then ""
else "__" ^ string_of_int info.sub_overload_num)
let start_output options =
match options.co_output_file with
| Some _ -> ()
@@ -53,24 +104,24 @@ let paren prec (sprec, s) =
s
(* The numbers are precedences to avoid generating excessive parentheses. *)
let rec translate_expr context = function
let rec translate_expr = function
| Boolean_literal(_,true) -> 100, "true"
| Boolean_literal(_,false) -> 100, "false"
| Integer_literal(_,i) -> 100, string_of_big_int i
| Var_v(_,x) ->
begin match x.ver_symbol.sym_info with
| Parameter_sym((Const_parameter | In_parameter), _)
| Variable_sym ->
100, c_name_of_symbol_v x
100, c_name_of_local x.ver_symbol
| Parameter_sym((In_out_parameter | Out_parameter), _) ->
90, ("*" ^ c_name_of_symbol_v x)
90, ("*" ^ c_name_of_local x.ver_symbol)
end
| Negation(e) ->
let e = translate_expr context e in
let e = translate_expr e in
90, "!" ^ paren 90 e
| Comparison(op, lhs, rhs) ->
let lhs = translate_expr context lhs in
let rhs = translate_expr context rhs in
let lhs = translate_expr lhs in
let rhs = translate_expr rhs in
50, paren 50 lhs ^ " "
^ (match op with
| EQ -> "=="
@@ -81,68 +132,67 @@ let rec translate_expr context = function
| GE -> ">=")
^ " " ^ paren 50 rhs
let translate_lvalue context = function
let translate_lvalue = function
| Var_v(_,x) ->
begin match x.ver_symbol.sym_info with
| Parameter_sym(_, _) ->
"*" ^ c_name_of_symbol_v x
"*" ^ c_name_of_local x.ver_symbol
| Variable_sym ->
c_name_of_symbol_v x
c_name_of_local x.ver_symbol
end
let rec translate_icode context f = function
let rec translate_icode f = function
| Return_term _ ->
puts f "return;";
break f
| Assignment_term(loc, dest, src, tail) ->
puts f (translate_lvalue context dest
^ " = " ^ snd (translate_expr context src) ^ ";");
puts f (translate_lvalue dest
^ " = " ^ snd (translate_expr src) ^ ";");
break f;
translate_icode context f tail
translate_icode f tail
| If_term(loc, cond, true_part, false_part) ->
puts f ("if (" ^ snd (translate_expr context cond) ^ "){");
puts f ("if (" ^ snd (translate_expr cond) ^ "){");
break f; indent f;
translate_icode context f true_part;
translate_icode f true_part;
undent f; puts f "} else {"; break f; indent f;
translate_icode context f false_part;
translate_icode f false_part;
undent f; puts f "}"; break f
| Jump_term(jmp) ->
puts f ("goto block" ^ string_of_int jmp.jmp_target.bl_id ^ ";");
| Jump_term(loc, target) ->
puts f ("goto block" ^ string_of_int target.bl_id ^ ";");
break f
| Call_term(call, tail) ->
let target = List.hd call.call_candidates (* XXX: VERY WRONG *) in
puts f (c_name_of_symbol context target ^ "("
let [target] = call.call_candidates in
puts f (c_name_of_subprogram target ^ "("
^ String.concat ", "
(List.map (fun arg -> snd (translate_expr context arg)) call.call_bound_arguments)
(List.map (fun (arg, _) -> snd (translate_expr arg)) call.call_bound_arguments)
^ ");");
break f;
translate_icode context f tail
| Inspect_type_term(_,_,tail) -> translate_icode context f tail
| Static_assert_term(_,_,tail) -> translate_icode context f tail
translate_icode f tail
| Inspect_type_term(_,_,tail) -> translate_icode f tail
| Static_assert_term(_,_,tail) -> translate_icode f tail
let translate_block context f block =
let translate_block f block =
puts f ("block" ^ string_of_int block.bl_id ^ ": ;");
break f;
indent f;
translate_icode context f (unsome block.bl_body);
translate_icode f (unsome block.bl_body);
undent f
let declare_locals f subprogram_sym =
List.iter (fun sym ->
match sym.sym_info with
let declare_locals f types =
Symbols.Maps.iter (fun x t ->
match x.sym_info with
| Variable_sym ->
List.iter (fun sym_v ->
puts f (c_name_of_type (unsome sym_v.ver_type)
^ " " ^ c_name_of_symbol_v sym_v ^ ";");
break f
) sym.sym_versions
| _ -> ()
) subprogram_sym.sym_children
puts f (c_name_of_type t
^ " " ^ c_name_of_local x ^ ";");
break f
| Parameter_sym _ ->
()
) types
let declare_function f subprogram_sym =
match subprogram_sym.sym_info with Subprogram_sym(sub) ->
puts f ("void "
^ c_name_of_symbol no_context subprogram_sym
^ c_name_of_subprogram subprogram_sym
^ "("
^ String.concat ", "
(List.map
@@ -182,12 +232,15 @@ let translate
puts f "{";
break f; indent f;
declare_locals f subprogram_sym;
let types = ref Symbols.Maps.empty in
collect_types_blocks types blocks;
declare_locals f !types;
break f;
translate_block {tc_vars = entry_point.bl_in} f entry_point;
translate_block f entry_point;
List.iter (fun block ->
if block != entry_point then
translate_block {tc_vars = block.bl_in} f block
translate_block f block
) blocks;
undent f;
puts f "}";
View
@@ -57,9 +57,10 @@ and symbol_info =
| Parameter_sym of param_mode * ttype
and subprogram_info = {
mutable sub_parameters : symbol list;
mutable sub_parameters : symbol list;
mutable sub_preconditions : expr list;
mutable sub_postconditions: expr list;
mutable sub_overload_num : int;
}
exception Already_defined of symbol
@@ -194,6 +195,13 @@ let dump_symbols () =
List.iter dump_sym sym.sym_children
in dump_sym root_symbol
let same_types t1 t2 =
match t1, t2 with
| Boolean_type, Boolean_type
| Integer_type, Integer_type -> true
| Boolean_type, _ | _, Boolean_type
| Integer_type, _ | _, Integer_type -> false
let free_variables e =
let rec search vars = function
| Boolean_literal _ -> vars
View
@@ -76,9 +76,14 @@ and symbol_info =
| Parameter_sym of param_mode * ttype
and subprogram_info = {
mutable sub_parameters : symbol list;
mutable sub_parameters : symbol list;
mutable sub_preconditions : expr list;
mutable sub_postconditions: expr list;
(* The overload number is used to produce unique symbol
names for overloaded symbols.
Equal to 0 for non-overloaded symbols.
Greater than 0 for overloaded symbols. *)
mutable sub_overload_num : int;
}
exception Already_defined of symbol
@@ -110,6 +115,7 @@ val new_overloaded_symbol : symbol
-> symbol
val new_version : symbol -> symbol_v
val dump_symbols : unit -> unit
val same_types : ttype -> ttype -> bool
(* Return a list of all the free variables in an expression. *)
val free_variables : expr -> symbol_v list
View
@@ -278,21 +278,27 @@ and translate_block
let translate_subprogram_prototype state scope sub =
match sub.Parse_tree.sub_name with [name] ->
let competing_declarations =
let competing_declarations, new_overload_num =
match find scope name with
| [] -> []
| [x] when is_subprogram x -> [x]
| [] -> ([], 0)
| [{sym_info=Subprogram_sym(info)} as sub] ->
assert (info.sub_overload_num = 0);
info.sub_overload_num <- 1;
([sub], 2)
| [x] ->
already_declared_error x sub.Parse_tree.sub_location;
[]
([], 0)
| results ->
assert (List.for_all is_subprogram results);
results
(results, 1 + List.fold_left
(fun ax {sym_info=Subprogram_sym(info)} ->
assert (info.sub_overload_num > 0);
max ax info.sub_overload_num) 0 results)
in
let subprogram_info = {
sub_parameters = [];
sub_preconditions = [];
sub_postconditions = [];
sub_overload_num = new_overload_num;
} in
let subprogram_sym =
try
@@ -394,7 +400,7 @@ let translate_subprogram_body compiler state subprogram_sym sub =
subprogram_info.sub_preconditions;
Type_checking.type_check_blocks state.st_blocks;
Constraint_checking.constraint_check_blocks state.st_blocks entry_point;
(*Backend_c.translate compiler subprogram_sym entry_point state.st_blocks;*)
Backend_c.translate compiler subprogram_sym entry_point state.st_blocks;
state.st_blocks <- []
let translate_declarations state scope declarations =
@@ -409,8 +415,8 @@ let translate_declarations state scope declarations =
let finish_translation compiler state =
let subs = state.st_subprograms in
state.st_subprograms <- [];
(*List.iter (fun (sym, sub) ->
Backend_c.declare compiler sym) subs;*)
List.iter (fun (sym, sub) ->
Backend_c.declare compiler sym) subs;
List.iter (fun (sym, sub) ->
try translate_subprogram_body compiler state sym sub
with Bail_out -> ()) subs
View
@@ -164,14 +164,6 @@ let same_mode a b =
| In_out_parameter, In_out_parameter -> true
| _ -> false
(* XXX: This is very similar to coerce. *)
let conflicting_types t1 t2 =
match t1, t2 with
| Boolean_type, Boolean_type
| Integer_type, Integer_type -> true
| Boolean_type, _ | _, Boolean_type
| Integer_type, _ | _, Integer_type -> false
let check_overload
(competing: symbol list)
({sym_declared = Some loc;
@@ -198,7 +190,7 @@ let check_overload
let {sym_info = Parameter_sym(decl_mode, decl_t)} = decl_param in
let {sym_info = Parameter_sym(mode, t)} = param in
if (same_mode mode decl_mode)
&& (conflicting_types t decl_t) then
&& (same_types t decl_t) then
(* Still conflicting. *)
loop ((decl, decl_params)::filtered, decls, param::params)
else

0 comments on commit de9cf93

Please sign in to comment.