Project

General

Profile

Revision 89b9e25c

View differences:

src/clock_calculus.ml
743 743
(* Clocks a variable declaration *)
744 744
let clock_var_decl scoped env vdecl =
745 745
  let ck = clock_coreclock env vdecl.var_dec_clock vdecl.var_id vdecl.var_loc scoped in
746
  let ck = 
746
  let ck =
747
(* WTF ????
747 748
    if vdecl.var_dec_const
748 749
    then
749 750
      (try_generalize ck vdecl.var_loc; ck)
750 751
    else
751
      match vdecl.var_type.Types.tdesc with
752
      | Types.Tclock _ -> new_ck (Ccarrying ((new_carrier Carry_name scoped),ck)) scoped
753
      | _              -> ck in
752
 *)
753
      if Types.is_clock_type vdecl.var_type
754
      then new_ck (Ccarrying ((new_carrier Carry_name scoped),ck)) scoped
755
      else ck in
754 756
  vdecl.var_clock <- ck;
755 757
  Env.add_value env vdecl.var_id ck
756 758

  
......
759 761
  List.fold_left (clock_var_decl scoped) env l
760 762

  
761 763
(** [clock_node env nd] performs the clock-calculus for node [nd] in
762
    environment [env]. *)
764
    environment [env].
765
    Generalization of clocks wrt scopes follows this rule:
766
    - generalize inputs (unscoped).
767
    - generalize outputs. As they are scoped, only clocks coming from inputs
768
      are allowed to be generalized.
769
    - generalize locals. As outputs don't depend on them (checked the step before),
770
      they can be generalized. 
771
 *)
763 772
let clock_node env loc nd =
764 773
  (* let is_main = nd.node_id = !Options.main_node in *)
765 774
  let new_env = clock_var_decl_list env false nd.node_inputs in
766 775
  let new_env = clock_var_decl_list new_env true nd.node_outputs in
767
  let new_env = clock_var_decl_list new_env true nd.node_locals in
776
  let new_env = clock_var_decl_list new_env false nd.node_locals in
768 777
  List.iter (clock_eq new_env) nd.node_eqs;
769 778
  let ck_ins = clock_of_vlist nd.node_inputs in
770 779
  let ck_outs = clock_of_vlist nd.node_outputs in
771 780
  let ck_node = new_ck (Carrow (ck_ins,ck_outs)) false in
772 781
  unify_imported_clock None ck_node;
773 782
  (*Log.report ~level:3 (fun fmt -> print_ck fmt ck_node);*)
774
  try_generalize ck_node loc;
783
  (* Local variables may contain first-order carrier variables that should be generalized.
784
     That's not the case for types. *)
785
  List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_inputs;
786
  List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_outputs;
787
  List.iter (fun vdecl -> try_generalize vdecl.var_clock vdecl.var_loc) nd.node_locals;
775 788
  (* TODO : Xavier pourquoi ai je cette erreur ? *)
776 789
(*  if (is_main && is_polymorphic ck_node) then
777 790
    raise (Error (loc,(Cannot_be_polymorphic ck_node)));
......
861 874
   Once restored in this formulation, clocks may be meaningfully printed.
862 875
*)
863 876
let uneval_vdecl_generics vdecl =
877
 (*Format.eprintf "Clock_calculus.uneval_vdecl_generics %a@." Printers.pp_node_var vdecl;*)
864 878
 if Types.is_clock_type vdecl.var_type
865 879
 then
866 880
   match get_carrier_name vdecl.var_clock with
......
873 887
let uneval_top_generics decl =
874 888
  match decl.top_decl_desc with
875 889
  | Node nd ->
876
      uneval_node_generics (nd.node_inputs @ nd.node_outputs)
890
      (* A node could contain first-order carrier variable in local vars. This is not the case for types. *)
891
      uneval_node_generics (nd.node_inputs @ nd.node_locals @ nd.node_outputs)
877 892
  | ImportedNode nd ->
878 893
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
879 894
  | ImportedFun nd ->
src/clocks.ml
574 574
      print_ck ck
575 575

  
576 576
let uneval const cr =
577
 (*Format.printf "uneval %s %a@." const print_carrier cr;*)
577
  (*Format.printf "Clocks.uneval %s %a@." const print_carrier cr;*)
578 578
  let cr = carrier_repr cr in
579 579
  match cr.carrier_desc with
580 580
  | Carry_var -> cr.carrier_desc <- Carry_const const
src/machine_code.ml
240 240
    LocalVar (Corelang.var_decl_of_const (Hashtbl.find Corelang.consts_table id))
241 241

  
242 242
let rec control_on_clock node ((m, si, j, d, s) as args) ck inst =
243
 match ck.cdesc with
243
 match (Clocks.repr ck).cdesc with
244 244
 | Con    (ck1, cr, l) ->
245 245
   let id  = const_of_carrier cr in
246 246
   control_on_clock node args ck1 (MBranch (translate_ident node args id,
......
331 331
  | Some (x, l) -> [control_on_clock node args c (MBranch (translate_ident node args x, [l, [MReset i]]))]
332 332

  
333 333
let translate_eq node ((m, si, j, d, s) as args) eq =
334
  (*Format.eprintf "translate_eq %a@." Printers.pp_node_eq eq;*)
334
  (*Format.eprintf "translate_eq %a with clock %a@." Printers.pp_node_eq eq Clocks.print_ck eq.eq_rhs.expr_clock;*)
335 335
  match eq.eq_lhs, eq.eq_rhs.expr_desc with
336 336
  | [x], Expr_arrow (e1, e2)                     ->
337 337
    let var_x = node_var x node in
src/main_lustre_compiler.ml
65 65

  
66 66
(* Loading Lusi file and filling type tables with parsed
67 67
   functions/nodes *)
68
let load_lusi filename =
68
let load_lusi own filename =
69 69
  Location.input_name := filename;
70 70
  let lexbuf = Lexing.from_channel (open_in filename) in
71 71
  Location.init lexbuf filename;
72 72
  (* Parsing *)
73 73
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
74 74
  try
75
    Parse.prog Parser_lustre.header Lexer_lustre.token lexbuf
76
  with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
75
    Parse.header own Parser_lustre.header Lexer_lustre.token lexbuf
76
  with
77
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
77 78
    Parse.report_error err;
78 79
    raise exc
80
  | Corelang.Error (err, loc) as exc ->
81
     Format.eprintf "Parsing error at loc %a: %a@]@."
82
       Location.pp_loc loc
83
       Corelang.pp_error err;
84
     raise exc
79 85

  
80 86
let check_lusi header =
81 87
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
......
118 124
      try
119 125
	let basename = s ^ ".lusi" in 
120 126
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
121
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi basename) in 
127
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
122 128
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
123 129
	Env.overwrite type_env lusi_type_env,
124 130
	Env.overwrite clock_env lusi_clock_env      
......
182 188
  let _ = 
183 189
    try 
184 190
      let _ = open_in lusi_name in
185
      let header = load_lusi lusi_name in
191
      let header = load_lusi true lusi_name in
186 192
      let _, declared_types_env, declared_clocks_env = check_lusi header in
187 193
      (* checking type compatibility with computed types*)
188 194
      Typing.check_env_compat header declared_types_env computed_types_env;
189 195
      (* checking clocks compatibility with computed clocks*)
190 196
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
191
      Typing.uneval_prog_generics prog
197
      Typing.uneval_prog_generics prog;
198
      Clock_calculus.uneval_prog_generics prog
192 199
    with Sys_error _ -> ( 
193 200
      (* Printing lusi file is necessary *)
194 201
      report ~level:1 
......
219 226
  (* Normalization phase *)
220 227
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
221 228
  let normalized_prog = Normalization.normalize_prog prog in
222
  (*Typing.uneval_prog_generics normalized_prog;*)
223 229
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
224 230
  (* Checking array accesses *)
225 231
  if !Options.check then
src/parse.ml
27 27
let report_error loc =
28 28
  Location.print loc;
29 29
  print_string "Syntax error\n"
30
(*
31
let wrap own parsing_fun token_fun lexbuf =
32
  try
33
    let ast = parsing_fun token_fun lexbuf own in
34
    Parsing.clear_parser ();
35
    ast
36
  with
37
  | Parsing.Parse_error ->
38
    let loc = Location.curr lexbuf in
39
    raise (Syntax_err loc)
40
 *)
41
let header own parsing_fun token_fun lexbuf =
42
  try
43
    let ast = parsing_fun token_fun lexbuf own in
44
    Parsing.clear_parser ();
45
    ast
46
  with
47
  | Parsing.Parse_error ->
48
    let loc = Location.curr lexbuf in
49
    raise (Syntax_err loc)
30 50

  
31
let wrap parsing_fun token_fun lexbuf =
51
let prog parsing_fun token_fun lexbuf =
32 52
  try
33 53
    let ast = parsing_fun token_fun lexbuf in
34 54
    Parsing.clear_parser ();
......
38 58
    let loc = Location.curr lexbuf in
39 59
    raise (Syntax_err loc)
40 60

  
41
let prog parse lex = wrap parse lex
42

  
43 61
(* Local Variables: *)
44 62
(* compile-command:"make -C .." *)
45 63
(* End: *)
src/parser_lustre.mly
42 42
let mkdim_appl f args = mkdim_appl (Location.symbol_rloc ()) f args
43 43
let mkdim_ite i t e = mkdim_ite (Location.symbol_rloc ()) i t e
44 44

  
45
let add_node own msg hashtbl name value =
46
  try
47
    match (Hashtbl.find hashtbl name).top_decl_desc, value.top_decl_desc with
48
    | Node _        , ImportedNode _ when own
49
                        ->
50
       Hashtbl.add hashtbl name value
51
    | ImportedNode _, _ ->
52
       Hashtbl.add hashtbl name value
53
    | Node _        , _ -> 
54
       raise (Corelang.Error (Corelang.Already_bound_symbol msg, Location.symbol_rloc ()))
55
    | _                 -> assert false
56
  with
57
    Not_found ->
58
       Hashtbl.add hashtbl name value
59

  
45 60
let add_symbol msg hashtbl name value =
46 61
 if Hashtbl.mem hashtbl name
47 62
 then raise (Corelang.Error (Corelang.Already_bound_symbol msg, Location.symbol_rloc ()))
......
102 117
%start prog
103 118
%type <Corelang.top_decl list> prog
104 119
%start header
105
%type <Corelang.top_decl list> header
120
%type <bool -> Corelang.top_decl list> header
106 121

  
107 122
%%
108 123

  
......
110 125
 open_list typ_def_list top_decl_list EOF { $1 @ (List.rev $3) }
111 126

  
112 127
header:
113
 open_list typ_def_list top_decl_header_list EOF { $1 @ (List.rev $3) }
128
 open_list typ_def_list top_decl_header_list EOF { (fun own -> ($1 @ (List.rev ($3 own)))) }
114 129

  
115 130
open_list:
116 131
  { [] }
......
125 140

  
126 141

  
127 142
top_decl_header_list:
128
  top_decl_header {[$1]}
129
| top_decl_header_list top_decl_header {$2::$1}
143
  top_decl_header {(fun own -> [$1 own]) }
144
| top_decl_header_list top_decl_header {(fun own -> ($2 own)::($1 own)) }
130 145

  
131 146

  
132 147
top_decl_header:
......
140 155
			     nodei_stateless = $12;
141 156
			     nodei_spec = None})
142 157
    in
143
    add_symbol ("node " ^ $2) node_table $2 nd; nd}
158
    (fun own -> add_node own ("node " ^ $2) node_table $2 nd; nd) }
144 159

  
145 160
| nodespec_list NODE IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR stateless_opt SCOL
146 161
    {let nd = mktop_decl (ImportedNode
......
152 167
			     nodei_stateless = $13;
153 168
			     nodei_spec = Some $1})
154 169
    in
155
    add_symbol ("node " ^ $3) node_table $3 nd; nd}
170
    (fun own -> add_node own ("node " ^ $3) node_table $3 nd; nd) }
156 171

  
157 172
| FUNCTION IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL
158 173
    {let nd = mktop_decl (ImportedNode
......
164 179
			     nodei_stateless = true;
165 180
			     nodei_spec = None})
166 181
     in
167
     add_symbol ("function " ^ $2) node_table $2 nd; nd}
182
     (fun own -> add_node own ("function " ^ $2) node_table $2 nd; nd) }
168 183

  
169 184
| nodespec_list FUNCTION IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL
170 185
    {let nd = mktop_decl (ImportedNode
......
176 191
			     nodei_stateless = true;
177 192
			     nodei_spec = Some $1})
178 193
     in
179
    add_symbol ("function " ^ $3) node_table $3 nd; nd}
194
    (fun own -> add_node own ("function " ^ $3) node_table $3 nd; nd) }
180 195

  
181 196
top_decl:
182 197
| CONST cdecl_list { mktop_decl (Consts (List.rev $2)) }
......
197 212
			     node_spec = None;
198 213
			     node_annot = match annots with [] -> None | _ -> Some annots})
199 214
    in
200
    add_symbol ("node " ^ $2) node_table $2 nd; nd}
215
    add_node true ("node " ^ $2) node_table $2 nd; nd}
201 216

  
202 217
| nodespec_list NODE IDENT LPAR vdecl_list SCOL_opt RPAR RETURNS LPAR vdecl_list SCOL_opt RPAR SCOL_opt locals LET eq_list TEL 
203 218
    {let eqs, asserts, annots = $16 in
......
215 230
			     node_spec = Some $1;
216 231
			     node_annot = match annots with [] -> None | _ -> Some annots})
217 232
    in
218
    add_symbol ("node " ^ $3) node_table $3 nd; nd}
233
    add_node true ("node " ^ $3) node_table $3 nd; nd}
219 234

  
220 235
nodespec_list:
221 236
NODESPEC { $1 }

Also available in: Unified diff