Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / access.ml @ b08ffca7

History | View | Annotate | Download (3.58 KB)

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 LustreSpec
23
open Corelang
24
open Types
25
open Format
26

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

    
35
module CSet = Set.Make(ConstraintModule)
36

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

    
53
  | Expr_ite (c, t, e) -> List.fold_left check_expr checks [c; t; e]
54
 
55
  | Expr_appl (_, args, _) -> check_expr checks args
56
 
57
  | Expr_fby (e1,e2)
58
  | Expr_arrow (e1,e2) -> check_expr (check_expr checks e1) e2
59
  | Expr_pre e1
60
  | Expr_when (e1,_,_) -> check_expr checks e1
61
 
62
  | Expr_merge (_,hl) -> List.fold_left (fun checks (l, h) -> check_expr checks h) checks hl
63
  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
64

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

    
73
let check_var_decl checks vdecl =
74
  check_var_decl_type vdecl.var_loc checks vdecl.var_type
75

    
76
(** [check_node nd] checks node [nd]. 
77
    The resulting constraints are stored in nodes. *)
78
let check_node nd =
79
  let checks = CSet.empty in
80
  let checks =
81
    List.fold_left check_var_decl checks (get_node_vars nd) in
82
  let checks =
83
    List.fold_left (fun checks eq -> check_expr checks eq.eq_rhs) checks (get_node_eqs nd) 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: *)