open Format open Filename open CtrlNbac open Compiler_utils open Compiler_options (* -------------------------------------------------------------------------- *) let report_msgs ?filename = let report_msg = Parser.Reporting.report_msg ?filename err_formatter in List.iter begin function | #CtrlNbac.Parser.msg as msg -> report_msg msg | `TError info -> report_msg (`MError info) end let abort ?filename n msgs = report_msgs ?filename msgs; error "Aborting due to errors in %s" n; exit 1 (* -------------------------------------------------------------------------- *) (** File extensions officially understood by the tool, with associated input types. *) let ityps_alist = [ "ctrlf", `Ctrlf; "cf", `Ctrlf; "ctrls", `Ctrlf; "cs", `Ctrlf; (* No need to discriminate between weaved and split functions (for now). *) ] (** name of official input types as understood by the tool. *) let ityps = List.map fst ityps_alist let set_input_type r t = try r := Some (List.assoc t ityps_alist) with | Not_found -> raise (Arg.Bad (asprintf "Unknown input file type: `%s'" t)) let inputs = ref [] let output = ref "" let input_type = ref None let node = ref "" let modul = ref "" exception Help let usage = "Usage: ctrl2ept [options] { [-i] | -n } \ [ -- { } ]" let print_vers () = fprintf err_formatter "ctrl2ept, version %s (compiled on %s)@." version date; exit 0 let anon x = inputs := x :: !inputs let it = Arg.Symbol (ityps, set_input_type input_type) let options = Arg.align [ "-i", Arg.String anon, " Input file (`-' means standard input)"; "-input-type", it, " Input file type"; "--input-type", it, ""; "-o", Arg.Set_string output, " Select output file (`-' means \ standard output)"; "-n", Arg.Set_string node, " Select base input node"; "-m", Arg.Set_string modul, " Select base input module"; "--", Arg.Rest anon, " Treat all remaining arguments as input files"; "-where", Arg.Unit locate_stdlib, doc_locate_stdlib; "-stdlib", Arg.String set_stdlib, doc_stdlib; "-v",Arg.Set verbose, " Set verbose mode"; "-version", Arg.Unit print_vers, " Print the version of the compiler"; "--version", Arg.Unit print_vers, ""; "-h", Arg.Unit (fun _ -> raise Help), ""; ] (* -------------------------------------------------------------------------- *) type out = { out_mult: bool; (* Are multiple calls to `out_exec' allowed? *) out_exec: string -> out_channel * (unit -> unit); (* oc * close *) } (* --- *) let mk_oc basename = { out_exec = (fun ext -> let filename = asprintf "%s%s" basename ext in let oc = open_out filename in info "Outputting into `%s'…" filename; oc, (fun () -> flush oc; close_out oc)); out_mult = true; } let mk_oc' filename = { out_exec = (fun _ -> let oc = open_out filename in info "Outputting into `%s'…" filename; oc, (fun () -> flush oc; close_out oc)); out_mult = false; } let mk_std_oc = { out_exec = (fun _ -> info "Outputting onto standard output…"; stdout, (fun () -> flush stdout)); out_mult = true; } (* --- *) (** Parses the given input file. *) let parse_input ?filename (parse: ?filename:string -> _) = try let s, n, msgs = parse ?filename () in report_msgs ?filename msgs; s, n with | CtrlNbac.Parser.Error (n, msgs) -> abort ?filename n msgs (* -------------------------------------------------------------------------- *) exception Error of string let suppress_typedecl ?mo prog = let open Heptagon in let p_desc = List.fold_left (fun acc d -> match d with Ptype _ -> acc | _ -> d::acc) [] prog.p_desc in let p_opened = match mo with None -> prog.p_opened | Some m -> m :: prog.p_opened in { prog with p_opened; p_desc = List.rev p_desc; } let parse_n_gen_ept_node ?filename ?node_name ?node_sig ?typ_symbs () = let name, func = parse_input ?filename CtrlNbac.Parser.Unsafe.parse_func in let node_name = match node_name with Some n -> n | None -> match name with None -> assert false | Some n -> Names.local_qn (n ^ "_ctrlr") in name, CtrlNbacAsEpt.gen_func ?typ_symbs ~node_name ?node_sig func let handle_ctrlf ?filename mk_oc = let _, decls = parse_n_gen_ept_node ?filename () in let prog = CtrlNbacAsEpt.create_prog Names.LocalModule in (* don't care? *) let prog = List.fold_right CtrlNbacAsEpt.add_to_prog decls prog in let prog = suppress_typedecl prog in let oc, close = mk_oc.out_exec "ept" in Hept_printer.print oc prog; close () (* -------------------------------------------------------------------------- *) let parse_nodename nn = try Names.qualname_of_string nn with | Exit -> raise (Error (sprintf "Invalid node name: `%s'" nn)) let output_prog prog modul = Modules.select modul; let filename = String.uncapitalize (Names.modul_to_string modul) ^ ".ept" in let oc = open_out filename in info "Outputting into `%s'…" filename; Hept_printer.print oc prog; close_out oc let input_function prog typ_symbs filename node_name node_sig = info "Reading function from `%s'…" filename; let _, decls = parse_n_gen_ept_node ~filename ~node_name ~node_sig ~typ_symbs () in (* XXX: check types are also in signature? actually, we only use the types declared in the signature instead, as long as the controller synthesis tool does not introduce new types. *) List.fold_right CtrlNbacAsEpt.add_to_prog decls prog let try_ctrlf typ_symbs nn prog = let node_name = Ctrln_utils.controller_node nn in if Modules.check_value node_name then let filename = Ctrln_utils.ctrlf_for_node nn in let node_sig = Modules.find_value node_name in input_function prog typ_symbs filename node_name node_sig else raise Exit let try_ctrls typ_symbs nn prog = let rec try_ctrls num prog = let node_name = Ctrln_utils.controller_node ~num nn in if Modules.check_value node_name then let filename = Ctrln_utils.ctrls_for_node nn num in if num = 0 && not (Sys.file_exists filename) then raise Exit; (* abort *) let node_sig = Modules.find_value node_name in let prog = input_function prog typ_symbs filename node_name node_sig in try_ctrls (succ num) prog else prog in try_ctrls 0 prog let handle_node arg = let nn = parse_nodename arg in let mo = Names.modul nn in if mo = Names.Pervasives || mo = Names.LocalModule then raise (Error (sprintf "Invalid node specification: `%s'." arg)); Modules.open_module Names.Pervasives; info "Loading module of controllers for node %s…" (Names.fullname nn); let om = Ctrln_utils.controller_modul mo in info "Translating type declarations of module %s…" (Names.modul_to_string om); let _typs, typ_symbs = CtrlNbacAsEpt.decl_typs_from_module_itf mo in let prog = CtrlNbacAsEpt.create_prog ~open_modul:[mo] om in (* let prog = List.fold_right CtrlNbacAsEpt.add_to_prog typs prog in *) let prog = try try_ctrls typ_symbs nn prog with | Exit -> try try_ctrlf typ_symbs nn prog with Exit -> raise (Error "Unable to load any controller function.") in output_prog prog om let handle_module modname = let mo = Names.modul_of_string modname in if mo = Names.Pervasives || mo = Names.LocalModule then raise (Error (sprintf "Invalid module specification: `%s'." modname)); Modules.open_module Names.Pervasives; Modules.open_module mo; Modules.select mo; let curmod = Modules.current_module () in info "Loading module of controllers for module %s…" (Names.modul_to_string mo); let om = Ctrln_utils.controller_modul mo in info "Translating type declarations of module %s…" (Names.modul_to_string om); let _typs, typ_symbs = CtrlNbacAsEpt.decl_typs_from_module_itf mo in let prog = CtrlNbacAsEpt.create_prog ~open_modul:[mo] om in let prog = Names.NamesEnv.fold (fun nodename _node prog -> info "Handling function %s…" nodename; let nn = Names.{ qual = mo; name = nodename } in try try_ctrls typ_symbs nn prog with | Exit -> try try_ctrlf typ_symbs nn prog with Exit -> prog) curmod.Modules.m_values prog in output_prog prog om (* -------------------------------------------------------------------------- *) let ityp_name_n_handle = function (* | `Ctrln -> "node", handle_ctrln *) | `Ctrlf -> "function", handle_ctrlf (* | `Ctrlr -> "predicate", handle_ctrlr *) let guesstyp_n_output filename = try let typ = match !input_type with | Some t -> t | None -> snd (List.find (fun (suff, _) -> check_suffix filename suff) ityps_alist) in let basename_extra = match typ with | `Ctrlf -> "_ctrlr" in typ, (match !output with | "-" -> mk_std_oc | "" -> (try chop_extension filename ^ basename_extra |> mk_oc with | Invalid_argument _ when filename <> "" -> mk_oc filename | Invalid_argument _ -> mk_std_oc) | o -> mk_oc' o) with | Not_found -> raise (Arg.Bad (sprintf "Cannot guess input type of `%s'" filename)) let handle_input_file filename = let ityp, mk_oc = guesstyp_n_output filename in let itypname, handle = ityp_name_n_handle ityp in info "Reading %s from `%s'…" itypname filename; handle ~filename mk_oc let handle_input_stream = function | None -> info "Reading function from standard input…"; handle_ctrlf mk_std_oc | Some ityp -> let itypname, handle = ityp_name_n_handle ityp in info "Reading %s from standard input…" itypname; handle mk_std_oc (** [main] function to be launched *) let main () = Arg.parse options anon usage; match (!modul,!node,List.rev !inputs) with | "","",[] -> handle_input_stream !input_type | "",n,lst -> (handle_node n; List.iter handle_input_file lst) | m,_,lst -> (handle_module m; List.iter handle_input_file lst) (* -------------------------------------------------------------------------- *) (* Launch the [main] *) let _ = (* CtrlNbac.Symb.reset (); <- not needed as we have only one input file. *) try main () with | Help -> Arg.usage options usage | Errors.Error -> error "aborted."; exit 2 | Error s | Arg.Bad s | Sys_error s -> error "%s" s; exit 2