Project

General

Profile

Download (3.64 KB) Statistics
| Branch: | Tag: | Revision:
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
(** Access checking module. Done after typing. Generates dimension constraints stored in nodes *)
13

    
14
let debug _fmt _args = () (* Format.eprintf "%a"  *)
15
(* Though it shares similarities with the clock calculus module, no code
16
    is shared.  Simple environments, very limited identifier scoping, no
17
    identifier redefinition allowed. *)
18

    
19
open Utils
20
(* Yes, opening both modules is dirty as some type names will be
21
   overwritten, yet this makes notations far lighter.*)
22
open Lustre_types
23
open Corelang
24

    
25
module ConstraintModule =
26
struct (* bool dimension module *)
27
  type t = Dimension.dim_expr
28
  let equal d1 d2 = Dimension.is_eq_dimension d1 d2
29
  let compare d1 d2 = if equal d1 d2 then 0 else compare d1.Dimension.dim_id d2.Dimension.dim_id
30
  let hash n = Hashtbl.hash n
31
end
32

    
33
module CSet = Set.Make(ConstraintModule)
34

    
35
(** [check_expr env expr] checks expression [expr] and gathers constraints 
36
    in set [checks]. *)
37
let rec check_expr checks expr =
38
  (*Format.eprintf "check_expr %a with type %a@." Printers.pp_expr expr Types.print_ty expr.expr_type;*)
39
  let res = 
40
  match expr.expr_desc with
41
  | Expr_const _
42
  | Expr_ident _ -> checks
43
  | Expr_array elist -> List.fold_left check_expr checks elist
44
  | Expr_access (e1, d) -> check_expr (CSet.add (Dimension.check_access expr.expr_loc (Types.array_type_dimension e1.expr_type) d) checks) e1
45
    (* TODO: check dimensions *)
46
 
47
  | Expr_power (e1, _) -> check_expr checks e1
48
 
49
  | Expr_tuple elist -> List.fold_left check_expr checks elist
50

    
51
  | Expr_ite (c, t, e) -> List.fold_left check_expr checks [c; t; e]
52
 
53
  | Expr_appl (_, args, _) -> check_expr checks args
54
 
55
  | Expr_fby (e1,e2)
56
  | Expr_arrow (e1,e2) -> check_expr (check_expr checks e1) e2
57
  | Expr_pre e1
58
  | Expr_when (e1,_,_) -> check_expr checks e1
59
 
60
  | Expr_merge (_,hl) -> List.fold_left (fun checks (_, h) -> check_expr checks h) checks hl
61
  in (*Format.eprintf "typing %B %a at %a = %a@." const Printers.pp_expr expr Location.pp_loc expr.expr_loc Types.print_ty res;*) res
62

    
63
let rec check_var_decl_type loc checks ty =
64
  if Types.is_array_type ty
65
  then
66
    check_var_decl_type loc
67
      (CSet.add (Dimension.check_bound loc (Types.array_type_dimension ty)) checks)
68
      (Types.array_element_type ty) 
69
  else checks
70

    
71
let check_var_decl checks vdecl =
72
  check_var_decl_type vdecl.var_loc checks vdecl.var_type
73

    
74
(** [check_node nd] checks node [nd]. 
75
    The resulting constraints are stored in nodes. *)
76
let check_node nd =
77
  let checks = CSet.empty in
78
  let checks =
79
    List.fold_left check_var_decl checks (get_node_vars nd) in
80
  let checks =
81
    let eqs, auts = get_node_eqs nd in
82
    assert (auts = []); (* Not checking automata yet . *)
83
    List.fold_left (fun checks eq -> check_expr checks eq.eq_rhs) checks eqs in
84
  nd.node_checks <- CSet.elements checks
85

    
86
let check_top_decl decl =
87
  match decl.top_decl_desc with
88
  | Node nd -> check_node nd
89
  | _ -> ()
90

    
91
let check_prog decls =
92
  List.iter check_top_decl decls
93

    
94

    
95
(* Local Variables: *)
96
(* compile-command:"make -C .." *)
97
(* End: *)
(1-1/5)