Project

General

Profile

Download (3.8 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
13
    stored in nodes *)
14

    
15
let debug _fmt _args = ()
16

    
17
(* Format.eprintf "%a" *)
18
(* Though it shares similarities with the clock calculus module, no code is
19
   shared. Simple environments, very limited identifier scoping, no identifier
20
   redefinition allowed. *)
21

    
22
open Utils
23

    
24
(* Yes, opening both modules is dirty as some type names will be overwritten,
25
   yet this makes notations far lighter.*)
26
open Lustre_types
27
open Corelang
28

    
29
module ConstraintModule = struct
30
  (* bool dimension module *)
31
  type t = Dimension.dim_expr
32

    
33
  let equal d1 d2 = Dimension.is_eq_dimension d1 d2
34

    
35
  let compare d1 d2 =
36
    if equal d1 d2 then 0 else compare d1.Dimension.dim_id d2.Dimension.dim_id
37

    
38
  let hash n = Hashtbl.hash n
39
end
40

    
41
module CSet = Set.Make (ConstraintModule)
42

    
43
(** [check_expr env expr] checks expression [expr] and gathers constraints in
44
    set [checks]. *)
45
let rec check_expr checks expr =
46
  (*Format.eprintf "check_expr %a with type %a@." Printers.pp_expr expr
47
    Types.print_ty expr.expr_type;*)
48
  let res =
49
    match expr.expr_desc with
50
    | Expr_const _ | Expr_ident _ ->
51
      checks
52
    | Expr_array elist ->
53
      List.fold_left check_expr checks elist
54
    | Expr_access (e1, d) ->
55
      check_expr
56
        (CSet.add
57
           (Dimension.check_access expr.expr_loc
58
              (Types.array_type_dimension e1.expr_type)
59
              d)
60
           checks)
61
        e1
62
    (* TODO: check dimensions *)
63
    | Expr_power (e1, _) ->
64
      check_expr checks e1
65
    | Expr_tuple elist ->
66
      List.fold_left check_expr checks elist
67
    | Expr_ite (c, t, e) ->
68
      List.fold_left check_expr checks [ c; t; e ]
69
    | Expr_appl (_, args, _) ->
70
      check_expr checks args
71
    | Expr_fby (e1, e2) | Expr_arrow (e1, e2) ->
72
      check_expr (check_expr checks e1) e2
73
    | Expr_pre e1 | Expr_when (e1, _, _) ->
74
      check_expr checks e1
75
    | Expr_merge (_, hl) ->
76
      List.fold_left (fun checks (_, h) -> check_expr checks h) checks hl
77
  in
78
  (*Format.eprintf "typing %B %a at %a = %a@." const Printers.pp_expr expr
79
    Location.pp_loc expr.expr_loc Types.print_ty res;*)
80
  res
81

    
82
let rec check_var_decl_type loc checks ty =
83
  if Types.is_array_type ty then
84
    check_var_decl_type loc
85
      (CSet.add
86
         (Dimension.check_bound loc (Types.array_type_dimension ty))
87
         checks)
88
      (Types.array_element_type ty)
89
  else checks
90

    
91
let check_var_decl checks vdecl =
92
  check_var_decl_type vdecl.var_loc checks vdecl.var_type
93

    
94
(** [check_node nd] checks node [nd]. The resulting constraints are stored in
95
    nodes. *)
96
let check_node nd =
97
  let checks = CSet.empty in
98
  let checks = List.fold_left check_var_decl checks (get_node_vars nd) in
99
  let checks =
100
    let eqs, auts = get_node_eqs nd in
101
    assert (auts = []);
102
    (* Not checking automata yet . *)
103
    List.fold_left (fun checks eq -> check_expr checks eq.eq_rhs) checks eqs
104
  in
105
  nd.node_checks <- CSet.elements checks
106

    
107
let check_top_decl decl =
108
  match decl.top_decl_desc with Node nd -> check_node nd | _ -> ()
109

    
110
let check_prog decls = List.iter check_top_decl decls
111

    
112
(* Local Variables: *)
113
(* compile-command:"make -C .." *)
114
(* End: *)
(1-1/5)