Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

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