Revision ca7ff3f7
Added by Lélio Brun 8 months ago
| src/tools/stateflow/json-parser/main_parse_json_file.ml | ||
|---|---|---|
| 4 | 4 |
open Json_parser |
| 5 | 5 |
open Sys |
| 6 | 6 |
|
| 7 |
module ParseExt = |
|
| 8 |
struct |
|
| 7 |
module ParseExt = struct |
|
| 9 | 8 |
open Yojson.Basic |
| 10 |
|
|
| 11 |
|
|
| 9 |
|
|
| 12 | 10 |
let remove_quotes s = |
| 13 | 11 |
let len = String.length s in |
| 14 |
if String.get s 0 = '"' && String.get s (len-1) = '"' then
|
|
| 15 |
String.sub s 1 (len-2)
|
|
| 12 |
if String.get s 0 = '"' && String.get s (len - 1) = '"' then
|
|
| 13 |
String.sub s 1 (len - 2)
|
|
| 16 | 14 |
else ( |
| 17 | 15 |
Format.eprintf "No quotes in string %s@.@?" s; |
| 18 |
assert false |
|
| 19 |
) |
|
| 16 |
assert false) |
|
| 20 | 17 |
|
| 21 | 18 |
let get_vars json = |
| 22 |
let get_vdecls key json = |
|
| 23 |
let s = json |> Util.member key |> to_string in |
|
| 24 |
try |
|
| 25 |
let s'= remove_quotes s in |
|
| 26 |
if s' = "" then [] else |
|
| 27 |
let lexbuf = Lexing.from_string s' in |
|
| 28 |
Parser_lustre.vdecl_list Lexer_lustre.token lexbuf |
|
| 29 |
with _ -> (Format.eprintf "Issues parsing decls for %s: %s@.@?" key s; assert false) |
|
| 30 |
|
|
| 31 |
in |
|
| 32 |
let inputs = get_vdecls "inputs" json in |
|
| 33 |
let outputs = get_vdecls "outputs" json in |
|
| 34 |
let variables = get_vdecls "variables" json in |
|
| 35 |
inputs, outputs, variables |
|
| 36 |
|
|
| 19 |
let get_vdecls key json = |
|
| 20 |
let s = json |> Util.member key |> to_string in |
|
| 21 |
try |
|
| 22 |
let s' = remove_quotes s in |
|
| 23 |
if s' = "" then [] |
|
| 24 |
else |
|
| 25 |
let lexbuf = Lexing.from_string s' in |
|
| 26 |
Parser_lustre.vdecl_list Lexer_lustre.token lexbuf |
|
| 27 |
with _ -> |
|
| 28 |
Format.eprintf "Issues parsing decls for %s: %s@.@?" key s; |
|
| 29 |
assert false |
|
| 30 |
in |
|
| 31 |
|
|
| 32 |
let inputs = get_vdecls "inputs" json in |
|
| 33 |
let outputs = get_vdecls "outputs" json in |
|
| 34 |
let variables = get_vdecls "variables" json in |
|
| 35 |
inputs, outputs, variables |
|
| 36 |
|
|
| 37 | 37 |
(* Protecting the generation of condition/action in case of an empty string |
| 38 | 38 |
instead of a subtree *) |
| 39 | 39 |
let protect default parse_fun embed_fun json = |
| 40 | 40 |
try |
| 41 | 41 |
let vars = get_vars json in |
| 42 |
let actions = json |> Util.member "actions" |> to_string in
|
|
| 43 |
if actions = "[]" || actions = "" then default (* should not happen *) else (
|
|
| 44 |
Format.eprintf "Parsing string: %s@." actions;
|
|
| 45 |
let lexbuf = Lexing.from_string (remove_quotes actions) in
|
|
| 46 |
try
|
|
| 47 |
let content = parse_fun Lexer_lustre.token lexbuf in
|
|
| 48 |
Parsing.clear_parser ();
|
|
| 49 |
embed_fun content vars
|
|
| 50 |
with Parsing.Parse_error ->
|
|
| 51 |
let loc = Location.dummy_loc in
|
|
| 52 |
raise (Parse.Error (loc, Parse.String_Syntax_error actions))
|
|
| 53 |
)
|
|
| 54 |
with Util.Type_error _ -> (
|
|
| 55 |
Format.eprintf |
|
| 56 |
"Unable to explore json subtree: empty string %s@." (to_string json);
|
|
| 42 |
let actions = json |> Util.member "actions" |> to_string in
|
|
| 43 |
if actions = "[]" || actions = "" then default (* should not happen *)
|
|
| 44 |
else (
|
|
| 45 |
Format.eprintf "Parsing string: %s@." actions;
|
|
| 46 |
let lexbuf = Lexing.from_string (remove_quotes actions) in
|
|
| 47 |
try
|
|
| 48 |
let content = parse_fun Lexer_lustre.token lexbuf in
|
|
| 49 |
Parsing.clear_parser ();
|
|
| 50 |
embed_fun content vars
|
|
| 51 |
with Parsing.Parse_error ->
|
|
| 52 |
let loc = Location.dummy_loc in
|
|
| 53 |
raise (Parse.Error (loc, Parse.String_Syntax_error actions)))
|
|
| 54 |
with Util.Type_error _ -> |
|
| 55 |
Format.eprintf "Unable to explore json subtree: empty string %s@."
|
|
| 56 |
(to_string json);
|
|
| 57 | 57 |
default |
| 58 |
) |
|
| 59 |
|
|
| 58 |
|
|
| 60 | 59 |
let parse_condition = |
| 61 |
protect |
|
| 62 |
Condition.tru |
|
| 63 |
Parser_lustre.expr |
|
| 64 |
(fun e (in_,out_,locals_) -> |
|
| 65 |
(* let vars = Corelang.get_expr_vars e in *) |
|
| 66 |
Condition.cquote {
|
|
| 67 |
expr = e; |
|
| 68 |
cinputs = in_; |
|
| 69 |
coutputs = out_; |
|
| 70 |
cvariables = locals_; |
|
| 71 |
|
|
| 72 |
}) |
|
| 73 |
|
|
| 60 |
protect Condition.tru Parser_lustre.expr (fun e (in_, out_, locals_) -> |
|
| 61 |
(* let vars = Corelang.get_expr_vars e in *) |
|
| 62 |
Condition.cquote |
|
| 63 |
{ expr = e; cinputs = in_; coutputs = out_; cvariables = locals_ })
|
|
| 64 |
|
|
| 74 | 65 |
let parse_action = |
| 75 | 66 |
protect Action.nil Parser_lustre.stmt_list |
| 76 | 67 |
(fun (stmts, asserts, annots) (in_, out_, locals_) -> |
| 77 |
if asserts != [] || annots != [] then |
|
| 78 |
assert false (* Stateflow equations should not use asserts nor define |
|
| 79 |
annotations *) |
|
| 80 |
else |
|
| 81 |
Action.aquote ({
|
|
| 82 |
defs = stmts; |
|
| 83 |
ainputs = in_; |
|
| 84 |
aoutputs = out_; |
|
| 85 |
avariables = locals_; |
|
| 86 |
}) |
|
| 87 |
) |
|
| 88 |
|
|
| 89 |
let parse_event json = Some Yojson.Basic.(json |> to_string) |
|
| 68 |
if asserts != [] || annots != [] then assert false |
|
| 69 |
(* Stateflow equations should not use asserts nor define annotations *) |
|
| 70 |
else |
|
| 71 |
Action.aquote |
|
| 72 |
{
|
|
| 73 |
defs = stmts; |
|
| 74 |
ainputs = in_; |
|
| 75 |
aoutputs = out_; |
|
| 76 |
avariables = locals_; |
|
| 77 |
}) |
|
| 78 |
|
|
| 79 |
let parse_event json = Some Yojson.Basic.(json |> to_string) |
|
| 90 | 80 |
end |
| 91 | 81 |
|
| 92 | 82 |
module JParse = Parser (ParseExt) |
| ... | ... | |
| 104 | 94 |
let json_parse _ file pp = |
| 105 | 95 |
try |
| 106 | 96 |
let prog = JParse.parse_prog (Yojson.Basic.from_file file) in |
| 107 |
if pp then |
|
| 108 |
SF.pp_prog Format.std_formatter prog; |
|
| 109 |
|
|
| 110 |
let module Model = |
|
| 111 |
struct |
|
| 112 |
let model = prog |
|
| 113 |
let name = "toto" (* TODO find a meaningful name *) |
|
| 114 |
let traces = [] (* TODO: shall we remove the traces field? *) |
|
| 115 |
end |
|
| 116 |
in |
|
| 97 |
if pp then SF.pp_prog Format.std_formatter prog; |
|
| 98 |
|
|
| 99 |
let module Model = struct |
|
| 100 |
let model = prog |
|
| 101 |
|
|
| 102 |
let name = "toto" |
|
| 103 |
(* TODO find a meaningful name *) |
|
| 104 |
|
|
| 105 |
let traces = [] |
|
| 106 |
(* TODO: shall we remove the traces field? *) |
|
| 107 |
end in |
|
| 117 | 108 |
let modularmode = |
| 118 | 109 |
match !modular with |
| 119 |
| 2 -> true, true, true |
|
| 120 |
| 1 -> false, true, false |
|
| 121 |
| _ (* 0 *) -> false, false ,false |
|
| 110 |
| 2 -> |
|
| 111 |
true, true, true |
|
| 112 |
| 1 -> |
|
| 113 |
false, true, false |
|
| 114 |
| _ (* 0 *) -> |
|
| 115 |
false, false, false |
|
| 122 | 116 |
in |
| 123 | 117 |
let state_vars = Datatype.SF.states Model.model in |
| 124 | 118 |
let global_vars = Datatype.SF.global_vars Model.model in |
| 125 |
|
|
| 119 |
|
|
| 126 | 120 |
let module T = CPS_lustre_generator.LustrePrinter (struct |
| 127 | 121 |
let state_vars = state_vars |
| 128 |
let global_vars = global_vars |
|
| 122 |
|
|
| 123 |
let global_vars = global_vars |
|
| 129 | 124 |
end) in |
| 130 | 125 |
let module Sem = CPS.Semantics (T) (Model) in |
| 131 | 126 |
let prog = Sem.code_gen modularmode in |
| 132 |
let header = List.map Corelang.mktop [ |
|
| 133 |
(LustreSpec.Open (false,"lustrec_math")); |
|
| 134 |
(LustreSpec.Open (false,"conv")); |
|
| 135 |
(LustreSpec.Open (true,"locallib")); |
|
| 136 |
] |
|
| 127 |
let header = |
|
| 128 |
List.map Corelang.mktop |
|
| 129 |
[ |
|
| 130 |
LustreSpec.Open (false, "lustrec_math"); |
|
| 131 |
LustreSpec.Open (false, "conv"); |
|
| 132 |
LustreSpec.Open (true, "locallib"); |
|
| 133 |
] |
|
| 137 | 134 |
in |
| 138 |
let prog =header@prog in
|
|
| 135 |
let prog = header @ prog in
|
|
| 139 | 136 |
Options.print_dec_types := true; |
| 140 |
(* Format.printf "%a@." Printers.pp_prog prog; *) |
|
| 141 | 137 |
|
| 142 |
let auto_file = "sf_gen_test_auto.lus" in (* Could be changed *) |
|
| 138 |
(* Format.printf "%a@." Printers.pp_prog prog; *) |
|
| 139 |
let auto_file = "sf_gen_test_auto.lus" in |
|
| 140 |
(* Could be changed *) |
|
| 143 | 141 |
let auto_out = open_out auto_file in |
| 144 | 142 |
let auto_fmt = Format.formatter_of_out_channel auto_out in |
| 145 | 143 |
Format.fprintf auto_fmt "%a@." Printers.pp_prog prog; |
| 146 |
Format.eprintf "Print initial lustre model with automaton in sf_gen_test_auto.lus@."; |
|
| 147 |
|
|
| 144 |
Format.eprintf |
|
| 145 |
"Print initial lustre model with automaton in sf_gen_test_auto.lus@."; |
|
| 146 |
|
|
| 148 | 147 |
let prog, deps = Compiler_stages.stage1 prog "" "" in |
| 149 | 148 |
|
| 150 | 149 |
(* Format.printf "%a@." Printers.pp_prog prog; *) |
| 151 |
let noauto_file = "sf_gen_test_noauto.lus" in (* Could be changed *) |
|
| 150 |
let noauto_file = "sf_gen_test_noauto.lus" in |
|
| 151 |
(* Could be changed *) |
|
| 152 | 152 |
let noauto_out = open_out noauto_file in |
| 153 | 153 |
let noauto_fmt = Format.formatter_of_out_channel noauto_out in |
| 154 | 154 |
Format.fprintf noauto_fmt "%a@." Printers.pp_prog prog; |
| 155 | 155 |
Format.eprintf "Print expanded lustre model in sf_gen_test_noauto.lus@."; |
| 156 | 156 |
() |
| 157 |
|
|
| 158 |
with Parse.Error (l, err) -> Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l Parse.pp_error err |
|
| 157 |
with Parse.Error (l, err) -> |
|
| 158 |
Format.eprintf "Parse error at loc %a : %a@.@?" Location.pp_loc l |
|
| 159 |
Parse.pp_error err |
|
| 159 | 160 |
|
| 160 | 161 |
(* term representing argument for file *) |
| 161 | 162 |
let file = |
| ... | ... | |
| 167 | 168 |
(* term representing argument for flag for pretty printing the program *) |
| 168 | 169 |
let pp = |
| 169 | 170 |
let doc = "Pretty print the resulting program" in |
| 170 |
Arg.(value & flag & info ["pp"; "pretty-print"] ~docv:"PP" ~doc)
|
|
| 171 |
Arg.(value & flag & info [ "pp"; "pretty-print" ] ~docv:"PP" ~doc)
|
|
| 171 | 172 |
|
| 172 | 173 |
(* term for argument for logging *) |
| 173 | 174 |
let setup_log_arg = |
| ... | ... | |
| 180 | 181 |
(* term info for manpages etc. *) |
| 181 | 182 |
let info = |
| 182 | 183 |
let doc = "parse a JSON file representing a Stateflow model" in |
| 183 |
let man = [ |
|
| 184 |
`S Manpage.s_bugs; |
|
| 185 |
`P "Report bug to Github issues tracking." ] |
|
| 186 |
in |
|
| 184 |
let man = [ `S Manpage.s_bugs; `P "Report bug to Github issues tracking." ] in |
|
| 187 | 185 |
Term.info "parse_json_file" ~doc ~exits:Term.default_exits ~man |
| 188 | 186 |
|
| 189 | 187 |
(* program *) |
| 190 |
let _ = |
|
| 191 |
Term.exit @@ Term.eval (json_parse_t, info) |
|
| 188 |
let _ = Term.exit @@ Term.eval (json_parse_t, info) |
|
Also available in: Unified diff
reformatting