let cast_to_c ((cdefs, funcs, mains, ancestry) : Cast.program) channel =
let out string = Printf.fprintf channel "%s\n" string in
let noblanks = function
| "" -> ()
| string -> Printf.fprintf channel "%s\n" string in
let incl file = out (Format.sprintf "#include \"%s.h\"\n" file) in
let comment string =
let comments = Str.split (Str.regexp "\n") string in
let commented = List.map (Format.sprintf " * %s") comments in
out (Format.sprintf "\n\n/*\n%s\n */" (String.concat "\n" commented)) in
let func_compare f g =
let strcmp = Pervasives.compare f.name g.name in
if f.builtin = g.builtin then strcmp else if f.builtin then -1 else 1 in
let funcs = List.sort func_compare funcs in
comment "Passing over code to find dispatch data.";
List.iter collect_dispatch_func funcs;
comment "Gamma preamble -- macros and such needed by various things";
incl "gamma-preamble";
comment "Ancestry meta-info to link to later.";
let classes = List.map (fun (kls, _) -> String.trim (GenCast.get_tname kls)) (StringMap.bindings ancestry) in
let class_strs = List.map (Format.sprintf "\t%s") (print_class_strings classes) in
out (Format.sprintf "char *m_classes[] = {\n%s\n};" (String.concat "\n" class_strs));
comment "Enums used to reference into ancestry meta-info strings.";
let class_enums = List.map (Format.sprintf "\t%s") (print_class_enums classes) in
out (Format.sprintf "enum m_class_idx {\n%s\n};" (String.concat "\n" class_enums));
comment "Header file containing meta information for built in classes.";
incl "gamma-builtin-meta";
comment "Meta structures for each class.";
let print_meta (klass, ancestors) =
if StringSet.mem (GenCast.get_tname klass) GenCast.built_in_names then ()
else out (setup_meta klass) in
List.iter print_meta (StringMap.bindings ancestry);
out "";
out (meta_init (StringMap.bindings ancestry));
comment "Header file containing structure information for built in classes.";
incl "gamma-builtin-struct";
comment "Structures for each of the objects.";
let print_class klass data =
if StringSet.mem klass GenCast.built_in_names then ()
else out (cast_to_c_class_struct klass data) in
StringMap.iter print_class cdefs;
comment "Header file containing information regarding built in functions.";
incl "gamma-builtin-functions";
comment "All of the function prototypes we need to do magic.";
List.iter (fun func -> noblanks (cast_to_c_proto func)) funcs;
comment "All the dispatching functions we need to continue the magic.";
List.iter (fun d -> out (cast_to_c_proto_dispatch_on d)) (!dispatchon);
List.iter (fun d -> out (cast_to_c_proto_dispatch d)) (!dispatches);
comment "Array allocators also do magic.";
List.iter (fun d -> out (cast_to_c_proto_dispatch_arr d)) (!dispatcharr);
comment "All of the functions we need to run the program.";
List.iter (fun func -> out (cast_to_c_func func)) funcs;
comment "Dispatch looks like this.";
List.iter (fun d -> out (generate_testsw d)) (!dispatchon);
List.iter (fun d -> out (generate_refinesw d)) (!dispatches);
comment "Array allocators.";
List.iter (fun d -> out (generate_arrayalloc d)) (!dispatcharr);
comment "The main.";
out (cast_to_c_main mains);