307f3d8418
- Controllable-Nbac export (CtrlNbacGen): correct handling of float expressions, as well as alias types; - Controllable-Nbac controller importer (CtrlNbacAsEpt): Declaration of enumerated types and aliases that are relocated to controller modules is now performed based on the interface. Dependencies between type aliases are also taken into account now; - ctrl2ept tool: correct loading of pervasives module.
275 lines
9.3 KiB
OCaml
275 lines
9.3 KiB
OCaml
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 ""
|
|
|
|
exception Help
|
|
let usage = "Usage: ctrl2ept [options] { [-i] <filename> | -n <node> } \
|
|
[ -- { <filename> } ]"
|
|
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, "<file> Input file (`-' means standard input)";
|
|
"-input-type", it, " Input file type";
|
|
"--input-type", it, "";
|
|
"-o", Arg.Set_string output, "<file> Select output file (`-' means \
|
|
standard output)";
|
|
"-n", Arg.Set_string node, "<node> Select base input node";
|
|
"--", 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
|
|
CtrlNbac.Symb.reset ();
|
|
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 hack_filter_inputs = let open AST in function *)
|
|
(* | `Desc ({ fn_decls = decls } as f) -> *)
|
|
(* (\* TODO: we should actually _substitute_ these variables with ff in the *)
|
|
(* definitions; yet I think they are unlikely to appear anywhere in the *)
|
|
(* controller. *\) *)
|
|
(* let init_symb = Symb.of_string Ctrln_utils.init_cond_str *)
|
|
(* and sink_symb = Symb.of_string Ctrln_utils.sink_state_str in *)
|
|
(* let decls = SMap.remove init_symb decls in *)
|
|
(* let decls = SMap.remove sink_symb decls in *)
|
|
(* `Desc { f with fn_decls = decls } *)
|
|
(* | _ -> failwith "should be given an unchecked function!" *)
|
|
|
|
let parse_n_gen_ept_node ?filename ?node_name ?node_sig () =
|
|
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
|
|
(* let name = match name with None -> "ctrlr" | Some n -> n ^"_ctrlr" in *)
|
|
(* let func = hack_filter_inputs func in *)
|
|
name, CtrlNbacAsEpt.gen_func ~node_name ?node_sig func
|
|
|
|
let handle_ctrlf ?filename mk_oc =
|
|
let _, (node, typs) = 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 typs prog in
|
|
let prog = CtrlNbacAsEpt.add_to_prog node 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 filename node_name node_sig =
|
|
info "Reading function from `%s'…" filename;
|
|
let res = parse_n_gen_ept_node ~filename ~node_name ~node_sig () in
|
|
let node, typs = snd res in
|
|
(* XXX: check types are also in signature? maybe we should only use the types
|
|
declared in the signature instead, as long as the controller synthesis tool
|
|
does not introduce new types. *)
|
|
let prog = List.fold_right CtrlNbacAsEpt.add_to_prog typs prog in
|
|
let prog = CtrlNbacAsEpt.add_to_prog node prog in
|
|
prog
|
|
|
|
let try_ctrlf 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 filename node_name node_sig
|
|
else
|
|
raise (Error "Unable to load any controller function.")
|
|
|
|
let try_ctrls 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 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
|
|
let prog = CtrlNbacAsEpt.create_prog ~open_modul:[ ] om in
|
|
let prog = try try_ctrls nn prog with Exit -> try_ctrlf nn 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 List.rev !inputs with
|
|
| [] when !node <> "" -> handle_node !node
|
|
| [] -> handle_input_stream !input_type
|
|
| lst -> (if !node <> "" then handle_node !node;
|
|
List.iter handle_input_file lst)
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
(** Launch the [main] *)
|
|
let _ =
|
|
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
|