Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/compiler_common.ml
10 10
(********************************************************************)
11 11

  
12 12
open Utils
13
open Format 
13
open Format
14 14
open Lustre_types
15 15
open Corelang
16 16

  
17 17
let check_main () =
18
  if !Options.main_node = "" then
19
    begin
20
      eprintf "Code generation error: %a@." Error.pp_error_msg Error.No_main_specified;
21
      raise (Error.Error (Location.dummy_loc, Error.No_main_specified))
22
    end
18
  if !Options.main_node = "" then (
19
    eprintf "Code generation error: %a@." Error.pp_error_msg
20
      Error.No_main_specified;
21
    raise (Error.Error (Location.dummy_loc, Error.No_main_specified)))
23 22

  
24 23
let create_dest_dir () =
25
  begin
26
    if not (Sys.file_exists !Options.dest_dir) then
27
      begin
28
	Log.report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@ ");
29
	Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
30
      end;
31
    if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then
32
      begin
33
	eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
34
	exit 1
35
      end
36
  end
24
  if not (Sys.file_exists !Options.dest_dir) then (
25
    Log.report ~level:1 (fun fmt ->
26
        fprintf fmt ".. creating destination directory@ ");
27
    Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm);
28
  if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then (
29
    eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
30
    exit 1)
37 31

  
38
(* Loading Lus/Lusi file and filling type tables with parsed
39
   functions/nodes *)
32
(* Loading Lus/Lusi file and filling type tables with parsed functions/nodes *)
40 33
let parse filename extension =
41 34
  (* Location.set_input filename; *)
42 35
  (* let f_in = open_in filename in *)
43 36
  (* let lexbuf = Lexing.from_channel f_in in *)
44 37
  (* Location.init lexbuf filename; *)
45 38
  (* Parsing *)
46
  let prog = 
39
  let prog =
47 40
    try
48
      Parse.(parse_filename (module Lexer_lustre) filename
49
               (match extension with
50
                | ".lusi" ->
51
                  Log.report ~level:1
52
                    (fun fmt -> fprintf fmt ".. parsing header file %s@ " filename);
53
                  Header
54
                | ".lus" ->
55
                  Log.report ~level:1
56
                    (fun fmt -> fprintf fmt ".. parsing source file %s@ " filename);
57
                  Program
58
                | _ -> assert false))
41
      Parse.(
42
        parse_filename
43
          (module Lexer_lustre)
44
          filename
45
          (match extension with
46
          | ".lusi" ->
47
            Log.report ~level:1 (fun fmt ->
48
                fprintf fmt ".. parsing header file %s@ " filename);
49
            Header
50
          | ".lus" ->
51
            Log.report ~level:1 (fun fmt ->
52
                fprintf fmt ".. parsing source file %s@ " filename);
53
            Program
54
          | _ ->
55
            assert false))
59 56
    with
60 57
    (* | (Parse.Error err) as exc ->
61 58
     *    Parse.report_error err;
62 59
     *    raise exc *)
63
    | Error.Error (loc, err) as exc -> (
64
      eprintf "Parsing error: %a%a@."
65
        Error.pp_error_msg err
66
        Location.pp_loc loc;
60
    | Error.Error (loc, err) as exc ->
61
      eprintf "Parsing error: %a%a@." Error.pp_error_msg err Location.pp_loc loc;
67 62
      raise exc
68
    )
69 63
  in
70 64
  (* close_in f_in; *)
71 65
  prog
72
    
73 66

  
74 67
let expand_automata decls =
75 68
  Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. expanding automata@ ");
76
  try
77
    Automata.expand_decls decls
78
  with (Error.Error (loc, err)) as exc ->
79
    eprintf "Automata error: %a%a@."
80
      Error.pp_error_msg err
81
      Location.pp_loc loc;
69
  try Automata.expand_decls decls
70
  with Error.Error (loc, err) as exc ->
71
    eprintf "Automata error: %a%a@." Error.pp_error_msg err Location.pp_loc loc;
82 72
    raise exc
83 73

  
84 74
let check_stateless_decls decls =
85
  Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. checking stateless/stateful status@ ");
86
  try
87
    Stateless.check_prog decls
88
  with (Stateless.Error (loc, err)) as exc ->
89
    eprintf "Stateless status error: %a%a@."
90
      Stateless.pp_error err
75
  Log.report ~level:1 (fun fmt ->
76
      fprintf fmt "@ .. checking stateless/stateful status@ ");
77
  try Stateless.check_prog decls
78
  with Stateless.Error (loc, err) as exc ->
79
    eprintf "Stateless status error: %a%a@." Stateless.pp_error err
91 80
      Location.pp_loc loc;
92 81
    raise exc
93 82

  
94 83
let force_stateful_decls decls =
95 84
  Log.report ~level:1 (fun fmt -> fprintf fmt "@ .. forcing stateful status@ ");
96
  try
97
    Stateless.force_prog decls
98
  with (Stateless.Error (loc, err)) as exc ->
99
    eprintf "Stateless status error: %a%a@."
100
      Stateless.pp_error err
85
  try Stateless.force_prog decls
86
  with Stateless.Error (loc, err) as exc ->
87
    eprintf "Stateless status error: %a%a@." Stateless.pp_error err
101 88
      Location.pp_loc loc;
102 89
    raise exc
103 90

  
104
let type_decls env decls =  
91
let type_decls env decls =
105 92
  Log.report ~level:1 (fun fmt -> fprintf fmt "@ @[<v 2>.. typing@ ");
106
  let new_env = 
107
    try
108
      Typing.type_prog env decls
109
    with Types.Error (loc,err) as exc ->
110
      eprintf "Typing error: %a%a@."
111
        Types.pp_error err
112
        Location.pp_loc loc;
93
  let new_env =
94
    try Typing.type_prog env decls
95
    with Types.Error (loc, err) as exc ->
96
      eprintf "Typing error: %a%a@." Types.pp_error err Location.pp_loc loc;
113 97
      raise exc
114 98
  in
115 99
  Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
116 100
  if !Options.print_types || !Options.verbose_level > 2 then
117
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_type decls);
101
    Log.report ~level:1 (fun fmt ->
102
        fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_type decls);
118 103
  new_env
119
      
120
let clock_decls env decls = 
104

  
105
let clock_decls env decls =
121 106
  Log.report ~level:1 (fun fmt -> fprintf fmt "@ @[<v 2>.. clock calculus@ ");
122 107
  let new_env =
123
    try
124
      Clock_calculus.clock_prog env decls
125
    with (Clocks.Error (loc,err)) as exc ->
126
      eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc loc;
108
    try Clock_calculus.clock_prog env decls
109
    with Clocks.Error (loc, err) as exc ->
110
      eprintf "Clock calculus error: %a%a@." Clocks.pp_error err Location.pp_loc
111
        loc;
127 112
      raise exc
128 113
  in
129 114
  Log.report ~level:1 (fun fmt -> fprintf fmt "@]");
130
  if !Options.print_clocks  || !Options.verbose_level > 2 then
131
    Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_clock decls);
115
  if !Options.print_clocks || !Options.verbose_level > 2 then
116
    Log.report ~level:1 (fun fmt ->
117
        fprintf fmt "@[<v 2>  %a@]@ " Corelang.pp_prog_clock decls);
132 118
  new_env
133 119

  
134 120
(* Typing/Clocking with an empty env *)
135 121
let check_top_decls header =
136
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
137
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
122
  let new_tenv = type_decls Basic_library.type_env header in
123
  (* Typing *)
124
  let new_cenv = clock_decls Basic_library.clock_env header in
125
  (* Clock calculus *)
138 126
  header, new_tenv, new_cenv
139 127

  
128
(* List.fold_right (fun top_decl (ty_env, ck_env) -> match
129
   top_decl.top_decl_desc with | Node nd -> (Env.add_value ty_env nd.node_id
130
   nd.node_type, Env.add_value ck_env nd.node_id nd.node_clock) | ImportedNode
131
   ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type, Env.add_value
132
   ck_env ind.nodei_id ind.nodei_clock) | Const c -> get_envs_from_const c
133
   (ty_env, ck_env) | TypeDef _ -> List.fold_left (fun envs top ->
134
   consts_of_enum_type top_decl | Open _ -> (ty_env, ck_env)) header
135
   (Env.initial, Env.initial) *)
140 136

  
141
(*
142
 List.fold_right
143
   (fun top_decl (ty_env, ck_env) ->
144
     match top_decl.top_decl_desc with
145
     | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,
146
			    Env.add_value ck_env nd.node_id nd.node_clock)
147
     | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,
148
			    Env.add_value ck_env ind.nodei_id ind.nodei_clock)
149
     | Const c          -> get_envs_from_const c (ty_env, ck_env)
150
     | TypeDef _        -> List.fold_left (fun envs top -> consts_of_enum_type top_decl
151
     | Open _           -> (ty_env, ck_env))
152
   header
153
   (Env.initial, Env.initial)
154
 *)
155

  
156
	 
157

  
158
    
159
let check_compatibility (_, computed_types_env, computed_clocks_env) (header, declared_types_env, declared_clocks_env) =
137
let check_compatibility (_, computed_types_env, computed_clocks_env)
138
    (header, declared_types_env, declared_clocks_env) =
160 139
  try
161 140
    (* checking defined types are compatible with declared types*)
162 141
    Typing.check_typedef_compat header;
......
165 144
    Typing.check_env_compat header declared_types_env computed_types_env;
166 145

  
167 146
    (* checking clocks compatibility with computed clocks*)
168
    Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
147
    Clock_calculus.check_env_compat header declared_clocks_env
148
      computed_clocks_env;
169 149

  
170 150
    (* checking stateless status compatibility *)
171 151
    Stateless.check_compat header
172 152
  with
173
  | (Types.Error (loc,err)) as exc ->
174
    eprintf "Type mismatch between computed type and declared type in lustre interface file: %a%a@."
175
      Types.pp_error err
176
      Location.pp_loc loc;
153
  | Types.Error (loc, err) as exc ->
154
    eprintf
155
      "Type mismatch between computed type and declared type in lustre \
156
       interface file: %a%a@."
157
      Types.pp_error err Location.pp_loc loc;
177 158
    raise exc
178 159
  | Clocks.Error (loc, err) as exc ->
179
    eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a%a@."
180
      Clocks.pp_error err
181
      Location.pp_loc loc;
160
    eprintf
161
      "Clock mismatch between computed clock and declared clock in lustre \
162
       interface file: %a%a@."
163
      Clocks.pp_error err Location.pp_loc loc;
182 164
    raise exc
183 165
  | Stateless.Error (loc, err) as exc ->
184
    eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a%a@."
185
      Stateless.pp_error err
186
      Location.pp_loc loc;
166
    eprintf
167
      "Stateless status mismatch between defined status and declared status in \
168
       lustre interface file: %a%a@."
169
      Stateless.pp_error err Location.pp_loc loc;
187 170
    raise exc
188 171

  
189 172
(* Process each node/imported node and introduce the associated contract node *)
190 173
let resolve_contracts prog =
191
  (* Bind a fresh node with a new name according to existing nodes and freshly binded contract node. Clean the contract to remove the stmts  *)
174
  (* Bind a fresh node with a new name according to existing nodes and freshly
175
     binded contract node. Clean the contract to remove the stmts *)
192 176
  let process_contract new_contracts c =
193 177
    (* Format.eprintf "Process contract@."; *)
194 178
    (* Resolve first the imports *)
195 179
    let stmts, locals, c =
196
      List.fold_left (
197
          fun (stmts, locals, c) import ->
198
          (* Search for contract in prog.
199
             The node have to be processed already. Otherwise raise an error.
200
             Each stmts in injected with a fresh name
201
             Inputs are renamed and associated to the expression in1
202
             Same thing for outputs.
180
      List.fold_left
181
        (fun (stmts, locals, c) import ->
182
          (* Search for contract in prog. The node have to be processed already.
183
             Otherwise raise an error. Each stmts in injected with a fresh name
184
             Inputs are renamed and associated to the expression in1 Same thing
185
             for outputs.
203 186

  
204
             Last the contracts elements are replaced with the renamed vars and merged with c contract.
205
           *)
187
             Last the contracts elements are replaced with the renamed vars and
188
             merged with c contract. *)
206 189
          let name = import.import_nodeid in
207 190
          (* Format.eprintf "Process contract import %s@." name; *)
208 191
          let loc = import.import_loc in
209 192
          try
210
            let imp_nd = get_node name new_contracts in (* Get the contract node in process contracts *)
193
            let imp_nd = get_node name new_contracts in
194
            (* Get the contract node in process contracts *)
211 195
            (* checking that it's actually a (processed) contract *)
212 196
            let _ =
213
              if not (is_node_contract imp_nd) then
214
                assert false (* should be a contract *)
197
              if not (is_node_contract imp_nd) then assert false
198
                (* should be a contract *)
215 199
              else
216 200
                let imp_c = get_node_contract imp_nd in
217
                if not (imp_c.imports = [] && imp_c.locals = [] && imp_c.consts = [] && imp_c.stmts = []) then
218
                (  Format.eprintf "Invalid processed contract: %i %i %i %i@.@?" (List.length imp_c.imports) (List.length imp_c.locals) (List.length imp_c.consts) (List.length imp_c.stmts);
219
                assert false (* should be processed *)
220
                )
201
                if
202
                  not
203
                    (imp_c.imports = [] && imp_c.locals = []
204
                   && imp_c.consts = [] && imp_c.stmts = [])
205
                then (
206
                  Format.eprintf "Invalid processed contract: %i %i %i %i@.@?"
207
                    (List.length imp_c.imports)
208
                    (List.length imp_c.locals) (List.length imp_c.consts)
209
                    (List.length imp_c.stmts);
210
                  assert false (* should be processed *))
221 211
            in
222 212
            let name_prefix x = "__" ^ name ^ "__" ^ x in
223
            let imp_nd = rename_node (fun x -> x (* not changing node names *)) name_prefix imp_nd in
213
            let imp_nd =
214
              rename_node
215
                (fun x -> x (* not changing node names *))
216
                name_prefix imp_nd
217
            in
224 218
            let imp_in = imp_nd.node_inputs in
225 219
            let imp_out = imp_nd.node_outputs in
226 220
            let imp_locals = imp_nd.node_locals in
227
            let locals = imp_in@imp_out@imp_locals@locals in
221
            let locals = imp_in @ imp_out @ imp_locals @ locals in
228 222
            let imp_c = get_node_contract imp_nd in
229 223
            (* Assigning in and out *)
230 224
            let mk_def vars_l e =
......
233 227
            in
234 228
            let in_assigns = mk_def imp_in import.inputs in
235 229
            let out_assigns = mk_def imp_out import.outputs in
236
            let stmts = in_assigns :: out_assigns :: imp_nd.node_stmts @ stmts in
230
            let stmts =
231
              in_assigns :: out_assigns :: imp_nd.node_stmts @ stmts
232
            in
237 233
            let c = merge_contracts c imp_c in
238
            stmts, locals, c 
239
          with Not_found -> Format.eprintf "Where is contract %s@.@?" name; raise (Error.Error (loc, (Error.Unbound_symbol ("contract " ^ name))))
240

  
241
         
242
        ) ([], c.consts@c.locals, c) c.imports
234
            stmts, locals, c
235
          with Not_found ->
236
            Format.eprintf "Where is contract %s@.@?" name;
237
            raise (Error.Error (loc, Error.Unbound_symbol ("contract " ^ name))))
238
        ([], c.consts @ c.locals, c)
239
        c.imports
243 240
    in
244
    let stmts = stmts @ c.stmts in 
241
    let stmts = stmts @ c.stmts in
245 242
    (* Other contract elements will be normalized later *)
246
    let c = { c with (* we erase locals and stmts sinced they are now in the parent node *)
247
              locals = [];
248
              consts = [];
249
              stmts = [];
250
              imports = []
251
            }
243
    let c =
244
      {
245
        c with
246
        (* we erase locals and stmts sinced they are now in the parent node *)
247
        locals = [];
248
        consts = [];
249
        stmts = [];
250
        imports = [];
251
      }
252 252
    in
253
    
253

  
254 254
    (* Format.eprintf "Processed stmts: %a@." Printers.pp_node_stmts stmts;
255 255
     * Format.eprintf "Processed locals: %a@." Printers.pp_vars locals; *)
256 256
    stmts, locals, c
257
    
258 257
  in
258

  
259 259
  let process_contract_new_node accu_contracts prog top =
260 260
    let id, spec, inputs, outputs =
261 261
      match top.top_decl_desc with
262
      | Node nd -> nd.node_id, nd.node_spec, nd.node_inputs, nd.node_outputs
263
      | ImportedNode ind -> ind.nodei_id, ind.nodei_spec, ind.nodei_inputs, ind.nodei_outputs
264
      | _ -> assert false
262
      | Node nd ->
263
        nd.node_id, nd.node_spec, nd.node_inputs, nd.node_outputs
264
      | ImportedNode ind ->
265
        ind.nodei_id, ind.nodei_spec, ind.nodei_inputs, ind.nodei_outputs
266
      | _ ->
267
        assert false
265 268
    in
266
    (* Format.eprintf "Process contract new node for node %s@." id; *)
267 269

  
270
    (* Format.eprintf "Process contract new node for node %s@." id; *)
268 271
    let stmts, locals, c =
269 272
      match spec with
270
      | None | Some (NodeSpec _) -> assert false
273
      | None | Some (NodeSpec _) ->
274
        assert false
271 275
      | Some (Contract c) ->
272
         (* Format.eprintf "Processing contract of node %s@." id; *)
273
         process_contract accu_contracts c
276
        (* Format.eprintf "Processing contract of node %s@." id; *)
277
        process_contract accu_contracts c
274 278
    in
275 279
    (* Create a fresh name *)
276
    let used v = List.exists (fun top ->
277
                     match top.top_decl_desc with
278
                     | Node _
279
                       | ImportedNode _ ->
280
                        (node_name top) = v
281
                     | _ -> false
282
                   ) (accu_contracts@prog)
280
    let used v =
281
      List.exists
282
        (fun top ->
283
          match top.top_decl_desc with
284
          | Node _ | ImportedNode _ ->
285
            node_name top = v
286
          | _ ->
287
            false)
288
        (accu_contracts @ prog)
283 289
    in
284 290
    let new_nd_id = mk_new_name used (id ^ "_coco") in
285 291
    let new_nd =
286
      mktop_decl
287
        c.spec_loc
288
        top.top_decl_owner
289
        top.top_decl_itf
290
        (Node {
292
      mktop_decl c.spec_loc top.top_decl_owner top.top_decl_itf
293
        (Node
294
           {
291 295
             node_id = new_nd_id;
292
	     node_type = Types.new_var ();
293
	     node_clock = Clocks.new_var true;
294
	     node_inputs = inputs;
295
	     node_outputs = outputs;
296
	     node_locals = locals;
297
	     node_gencalls = [];
298
	     node_checks = [];
299
	     node_asserts = []; 
300
	     node_stmts = stmts;
301
	     node_dec_stateless = false;
302
	     node_stateless = None;
303
	     node_spec = Some (Contract c);
304
	     node_annot = [];
305
	     node_iscontract = true;
306
        }) in
296
             node_type = Types.new_var ();
297
             node_clock = Clocks.new_var true;
298
             node_inputs = inputs;
299
             node_outputs = outputs;
300
             node_locals = locals;
301
             node_gencalls = [];
302
             node_checks = [];
303
             node_asserts = [];
304
             node_stmts = stmts;
305
             node_dec_stateless = false;
306
             node_stateless = None;
307
             node_spec = Some (Contract c);
308
             node_annot = [];
309
             node_iscontract = true;
310
           })
311
    in
307 312
    new_nd
308 313
  in
309 314
  (* Processing nodes in order. Should have been sorted by now
310 315

  
311 316
     Each top level contract is processed: stmts pushed in node
312 317

  
313
     Each regular imported node or node associated with a contract is
314
     replaced with a simplidfied contract and its contract is bound to
315
     a fresh node.
316

  
317
   *)
318
     Each regular imported node or node associated with a contract is replaced
319
     with a simplidfied contract and its contract is bound to a fresh node. *)
318 320
  let new_contracts, prog =
319 321
    List.fold_left
320
      (
321
        fun (accu_contracts, accu_nodes) top ->
322
      (fun (accu_contracts, accu_nodes) top ->
322 323
        match top.top_decl_desc with
323
          
324 324
        | Node nd when nd.node_iscontract -> (
325 325
          match nd.node_spec with
326
          | None | Some (NodeSpec _) -> assert false
326
          | None | Some (NodeSpec _) ->
327
            assert false
327 328
          | Some (Contract c) ->
328
             (* Format.eprintf "Processing top contract %s@." nd.node_id; *)
329
             let stmts, locals, c = process_contract accu_contracts c in
330
             let nd =
331
               { nd with
332
                 node_locals = nd.node_locals @ locals;
333
                 node_stmts = nd.node_stmts @ stmts;
334
                 node_spec = Some (Contract c);
335
               }
336
             in
337
             { top with top_decl_desc = Node nd }::accu_contracts,
338
             accu_nodes
339
             
340
        )
329
            (* Format.eprintf "Processing top contract %s@." nd.node_id; *)
330
            let stmts, locals, c = process_contract accu_contracts c in
331
            let nd =
332
              {
333
                nd with
334
                node_locals = nd.node_locals @ locals;
335
                node_stmts = nd.node_stmts @ stmts;
336
                node_spec = Some (Contract c);
337
              }
338
            in
339
            { top with top_decl_desc = Node nd } :: accu_contracts, accu_nodes)
341 340
        | Node nd -> (
342 341
          match nd.node_spec with
343
          | None -> accu_contracts, top::accu_nodes (* A boring node: no contract *)
344
          | Some (NodeSpec _) -> (* shall not happen, its too early *)
345
             assert false
346
          | Some (Contract _) -> (* A contract: processing it *)
347
             (* we bind a fresh node *)
348
             let new_nd = process_contract_new_node accu_contracts prog top in
349
             (* Format.eprintf "Creating new contract node %s@." (node_name new_nd); *)
350
             let nd = { nd with node_spec = (Some (NodeSpec (node_name new_nd))) } in
351
             new_nd::accu_contracts,
352
             { top with top_decl_desc = Node nd }::accu_nodes
353
             
354
        )
355
                   
356
        | ImportedNode ind -> ( (* Similar treatment for imported nodes *)
342
          | None ->
343
            accu_contracts, top :: accu_nodes (* A boring node: no contract *)
344
          | Some (NodeSpec _) ->
345
            (* shall not happen, its too early *)
346
            assert false
347
          | Some (Contract _) ->
348
            (* A contract: processing it *)
349
            (* we bind a fresh node *)
350
            let new_nd = process_contract_new_node accu_contracts prog top in
351
            (* Format.eprintf "Creating new contract node %s@." (node_name
352
               new_nd); *)
353
            let nd =
354
              { nd with node_spec = Some (NodeSpec (node_name new_nd)) }
355
            in
356
            ( new_nd :: accu_contracts,
357
              { top with top_decl_desc = Node nd } :: accu_nodes ))
358
        | ImportedNode ind -> (
359
          (* Similar treatment for imported nodes *)
357 360
          match ind.nodei_spec with
358
            None -> accu_contracts, top::accu_nodes (* A boring node: no contract *)
359
          | Some (NodeSpec _) -> (* shall not happen, its too early *)
360
             assert false
361
          | Some (Contract _) -> (* A contract: processing it *)
362
             (* we bind a fresh node *)
363
             let new_nd = process_contract_new_node accu_contracts prog top in
364
             let ind = { ind with nodei_spec = (Some (NodeSpec (node_name new_nd))) } in
365
             new_nd::accu_contracts,
366
             { top with top_decl_desc = ImportedNode ind }::accu_nodes
367
        )
368
        | _ -> accu_contracts, top::accu_nodes
369
      ) ([],[]) prog
361
          | None ->
362
            accu_contracts, top :: accu_nodes (* A boring node: no contract *)
363
          | Some (NodeSpec _) ->
364
            (* shall not happen, its too early *)
365
            assert false
366
          | Some (Contract _) ->
367
            (* A contract: processing it *)
368
            (* we bind a fresh node *)
369
            let new_nd = process_contract_new_node accu_contracts prog top in
370
            let ind =
371
              { ind with nodei_spec = Some (NodeSpec (node_name new_nd)) }
372
            in
373
            ( new_nd :: accu_contracts,
374
              { top with top_decl_desc = ImportedNode ind } :: accu_nodes ))
375
        | _ ->
376
          accu_contracts, top :: accu_nodes)
377
      ([], []) prog
370 378
  in
371
  (List.rev new_contracts) @ (List.rev prog)
372
         
379
  List.rev new_contracts @ List.rev prog
373 380

  
374
  
375 381
let track_exception () =
376
  if !Options.track_exceptions
377
  then (Printexc.print_backtrace stdout; flush stdout)
382
  if !Options.track_exceptions then (
383
    Printexc.print_backtrace stdout;
384
    flush stdout)
378 385
  else ()
379 386

  
380

  
381 387
let update_vdecl_parents_prog prog =
382
  let update_vdecl_parents parent v =
383
    v.var_parent_nodeid <- Some parent
384
  in
385
  List.iter (
386
    fun top -> match top.top_decl_desc with
387
    | Node nd ->
388
       List.iter
389
	 (update_vdecl_parents nd.node_id)
390
	 (nd.node_inputs @ nd.node_outputs @ nd.node_locals )  
391
    | ImportedNode ind -> 
392
       List.iter
393
	 (update_vdecl_parents ind.nodei_id)
394
	 (ind.nodei_inputs @ ind.nodei_outputs )  
395
    | _ -> ()
396
  ) prog
388
  let update_vdecl_parents parent v = v.var_parent_nodeid <- Some parent in
389
  List.iter
390
    (fun top ->
391
      match top.top_decl_desc with
392
      | Node nd ->
393
        List.iter
394
          (update_vdecl_parents nd.node_id)
395
          (nd.node_inputs @ nd.node_outputs @ nd.node_locals)
396
      | ImportedNode ind ->
397
        List.iter
398
          (update_vdecl_parents ind.nodei_id)
399
          (ind.nodei_inputs @ ind.nodei_outputs)
400
      | _ ->
401
        ())
402
    prog

Also available in: Unified diff