diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 2843669..eeb5aae 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -21,6 +21,21 @@ let rec print_list ff print sep l = fprintf ff "%s@ " sep; print_list ff print sep l +(** [cname_of_name name] translates the string [name] to a valid C identifier. + Copied verbatim from the old C backend. *) +let cname_of_name name = + let buf = Buffer.create (String.length name) in + let rec convert c = + match c with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> + Buffer.add_char buf c + | '\'' -> Buffer.add_string buf "_prime" + | _ -> + Buffer.add_string buf "lex"; + Buffer.add_string buf (string_of_int (Char.code c)); + Buffer.add_string buf "_" in + String.iter convert name; + Buffer.contents buf (******************************) @@ -141,13 +156,14 @@ let rec pp_list f sep fmt l = match l with | [] -> fprintf fmt "" | h :: t -> fprintf fmt "@ %a%s%a" f h sep (pp_list f sep) t -let pp_string fmt s = fprintf fmt "%s" s +let pp_string fmt s = + fprintf fmt "%s" (cname_of_name s) let rec pp_cty fmt cty = match cty with | Cty_int -> fprintf fmt "int" | Cty_float -> fprintf fmt "float" | Cty_char -> fprintf fmt "char" - | Cty_id s -> fprintf fmt "%s" s + | Cty_id s -> pp_string fmt s | Cty_ptr cty' -> fprintf fmt "%a*" pp_cty cty' | Cty_arr (n, cty') -> fprintf fmt "%a[%d]" pp_cty cty' n | Cty_void -> fprintf fmt "void" @@ -171,10 +187,10 @@ let rec pp_param_cty fmt = function let rec pp_vardecl fmt (s, cty) = match cty with | Cty_arr (n, cty') -> let ty, indices = pp_array_decl cty in - fprintf fmt "%a %s%s" pp_cty ty s indices - | _ -> fprintf fmt "%a %s" pp_cty cty s + fprintf fmt "%a %a%s" pp_cty ty pp_string s indices + | _ -> fprintf fmt "%a %a" pp_cty cty pp_string s and pp_paramdecl fmt (s, cty) = match cty with - | Cty_arr (n, cty') -> fprintf fmt "%a* %s" pp_param_cty cty' s + | Cty_arr (n, cty') -> fprintf fmt "%a* %a" pp_param_cty cty' pp_string s | _ -> pp_vardecl fmt (s, cty) and pp_param_list fmt l = pp_list1 pp_paramdecl "," fmt l and pp_var_list fmt l = pp_list pp_vardecl ";" fmt l @@ -200,8 +216,9 @@ and pp_cstm fmt stm = match stm with fprintf fmt "@[@[if (%a) {%a@]@ @[} else {%a@]@ }@]" pp_cexpr c pp_cstm_list t pp_cstm_list e | Cfor(x, lower, upper, e) -> - fprintf fmt "@[@[for (int %s = %d; %s < %d; ++%s) {%a@]@ }@]" - x lower x upper x pp_cstm_list e + fprintf fmt "@[@[for (int %a = %d; %a < %d; ++%a) {%a@]@ }@]" + pp_string x lower pp_string x + upper pp_string x pp_cstm_list e | Cwhile (e, b) -> fprintf fmt "@[@[while (%a) {%a@]@ }@]" pp_cexpr e pp_cstm_list b | Csblock cb -> pp_cblock fmt cb @@ -210,23 +227,24 @@ and pp_cstm fmt stm = match stm with and pp_cexpr fmt ce = match ce with | Cuop (s, e) -> fprintf fmt "%s(%a)" s pp_cexpr e | Cbop (s, l, r) -> fprintf fmt "(%a%s%a)" pp_cexpr l s pp_cexpr r - | Cfun_call (s, el) -> fprintf fmt "%s(@[%a@])" s (pp_list1 pp_cexpr ",") el + | Cfun_call (s, el) -> + fprintf fmt "%a(@[%a@])" pp_string s (pp_list1 pp_cexpr ",") el | Cconst (Ccint i) -> fprintf fmt "%d" i | Cconst (Ccfloat f) -> fprintf fmt "%f" f | Cconst (Ctag "true") -> fprintf fmt "TRUE" | Cconst (Ctag "false") -> fprintf fmt "FALSE" - | Cconst (Ctag t) -> fprintf fmt "%s" t + | Cconst (Ctag t) -> pp_string fmt t | Cconst (Cstrlit t) -> fprintf fmt "\"%s\"" t | Clhs lhs -> fprintf fmt "%a" pp_clhs lhs | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs | Cstructlit (s, el) -> - fprintf fmt "(%s){@[%a@]}" s (pp_list1 pp_cexpr ",") el + fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el | Carraylit el -> fprintf fmt "((int *){@[%a@]})" (pp_list1 pp_cexpr ",") el (* WRONG *) and pp_clhs fmt lhs = match lhs with - | Cvar s -> fprintf fmt "%s" s + | Cvar s -> pp_string fmt s | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' - | Cfield (Cderef lhs, f) -> fprintf fmt "%a->%s" pp_clhs lhs f + | Cfield (Cderef lhs, f) -> fprintf fmt "%a->%a" pp_clhs lhs pp_string f | Cfield (lhs, f) -> fprintf fmt "%a.%s" pp_clhs lhs f | Carray (lhs, e) -> fprintf fmt "%a[%a]" @@ -235,14 +253,14 @@ and pp_clhs fmt lhs = match lhs with let pp_cdecl fmt cdecl = match cdecl with | Cdecl_enum (s, sl) -> - fprintf fmt "@[@[typedef enum {@ %a@]@ } %s;@ @]@\n" - (pp_list1 pp_string ",") sl s + fprintf fmt "@[@[typedef enum {@ %a@]@ } %a;@ @]@\n" + (pp_list1 pp_string ",") sl pp_string s | Cdecl_struct (s, fl) -> let pp_field fmt (s, cty) = fprintf fmt "@ %a;" pp_vardecl (s,cty) in - fprintf fmt "@[@[typedef struct %s {" s; + fprintf fmt "@[@[typedef struct %a {" pp_string s; List.iter (pp_field fmt) fl; - fprintf fmt "@]@ } %s;@ @]@\n" s + fprintf fmt "@]@ } %a;@ @]@\n" pp_string s | Cdecl_function (n, retty, args) -> fprintf fmt "@[%a %s(@[%a@]);@ @]@\n" pp_cty retty n pp_param_list args @@ -253,7 +271,7 @@ let pp_cdef fmt cdef = match cdef with "@[@[%a %s(@[%a@]) {%a@]@ }@ @]@\n" pp_cty cfd.f_retty cfd.f_name pp_param_list cfd.f_args pp_cblock cfd.f_body - | Cvardef (s, cty) -> fprintf fmt "%a %s;@\n" pp_cty cty s + | Cvardef (s, cty) -> fprintf fmt "%a %a;@\n" pp_cty cty pp_string s let pp_cfile_desc fmt filen cfile = (** [filen_wo_ext] is the file's name without the extension. *) @@ -297,22 +315,6 @@ let output dir cprog = (** { Lexical conversions to C's syntax } *) -(** [cname_of_name name] translates the string [name] to a valid C identifier. - Copied verbatim from the old C backend. *) -let cname_of_name name = - let buf = Buffer.create (String.length name) in - let rec convert c = - match c with - | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> - Buffer.add_char buf c - | '\'' -> Buffer.add_string buf "_prime" - | _ -> - Buffer.add_string buf "lex"; - Buffer.add_string buf (string_of_int (Char.code c)); - Buffer.add_string buf "_" in - String.iter convert name; - Buffer.contents buf - (** Converts an expression to a lhs. *) let lhs_of_exp e = match e with diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 9496828..07486ae 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -57,10 +57,6 @@ let rec struct_name ty = let int_of_static_exp se = Static.int_of_static_exp NamesEnv.empty se -let cname_of_name' name = match name with - | Name n -> Name (cname_of_name n) - | _ -> name - (* Functions to deal with opened modules set. *) type world = { mutable opened_modules : S.t } let world = { opened_modules = S.empty } @@ -91,17 +87,18 @@ let node_info classln = id = modname_name })) with Not_found -> (* name might be of the form Module.name, remove the module name*) - let ind_name = (String.length modname) + 1 in + (*let ind_name = (String.length modname) + 1 in let name = String.sub modname_name ind_name ((String.length modname_name)-ind_name) in begin try modname, find_value (Modname({qual = modname; id = name })) - with Not_found -> - Error.message no_location (Error.Enode name) - end + with Not_found ->*) + Error.message no_location (Error.Enode modname) + (*end *) end | Name n -> + assert false; Error.message no_location (Error.Enode n) let output_names_list sig_info = @@ -544,7 +541,7 @@ let fun_def_of_step_fun name obj_env mem objs md = let out_vars = unique (List.map (fun obj -> out_var_name_of_objn (shortname obj.o_class), - Cty_id ((cname_of_name (shortname obj.o_class)) ^ "_out")) + Cty_id ((shortname obj.o_class) ^ "_out")) (List.filter (fun obj -> not (is_op obj.o_class)) objs)) in (** The body *) @@ -575,7 +572,7 @@ let mem_decl_of_class_def cd = let struct_field_of_obj_dec l od = if is_statefull od.o_class then let clsname = shortname od.o_class in - let ty = Cty_id ((cname_of_name clsname) ^ "_mem") in + let ty = Cty_id (clsname ^ "_mem") in let ty = match od.o_size with | Some se -> Cty_arr (int_of_static_exp se, ty) | None -> ty in @@ -623,11 +620,8 @@ let cdefs_and_cdecls_of_class_def cd = let step_m = find_step_method cd in let memory_struct_decl = mem_decl_of_class_def cd in let out_struct_decl = out_decl_of_class_def cd in - let obj_env = - List.map (fun od -> { od with o_class = cname_of_name' od.o_class }) - cd.cd_objs in let step_fun_def - = fun_def_of_step_fun cd.cd_name obj_env cd.cd_mems cd.cd_objs step_m in + = fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems cd.cd_objs step_m in (** C function for resetting our memory structure. *) let reset_fun_def = reset_fun_def_of_class_def cd in let res_fun_decl = cdecl_of_cfundef reset_fun_def in