Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / EMF / EMF_backend.ml @ a6df3992

History | View | Annotate | Download (5.55 KB)

1
open LustreSpec
2
open Format
3
open Utils
4

    
5
let pp_var_string fmt v = fprintf fmt "\"%s\"" v
6
let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v
7

    
8
let pp_node_args = fprintf_list ~sep:", " pp_var_name
9

    
10
let pp_expr vars fmt expr =
11
  (* simple function to extract the element id in the list. Starts from 1. *)
12
  let rec get_idx x l =
13
    match l with
14
    | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
15
    | [] -> assert false
16
  in
17
  let rec pp_expr fmt expr =
18
    match expr.expr_desc with
19
    | Expr_const c -> Printers.pp_const fmt c
20
    | Expr_ident id ->
21
       if List.mem id vars then
22
	 Format.fprintf fmt "u(%i)" (get_idx id vars)
23
       else
24
	 assert false (* impossible to find element id in var list *)
25
    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
26
    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
27
    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
28
    | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
29
    | Expr_ite (c, t, e) -> fprintf fmt "(if %a then %a else %a)" pp_expr c pp_expr t pp_expr e
30
    | Expr_arrow (e1, e2) ->(
31
      match e1.expr_desc, e2.expr_desc with
32
      | Expr_const c1, Expr_const c2 -> if c1 = Corelang.const_of_bool true && c2 = Corelang.const_of_bool false then fprintf fmt "STEP" else assert false (* only handle true -> false *)
33
      | _ -> assert false (* only handle true -> false *)
34
    )
35
    | Expr_fby (e1, e2) -> assert false (* not covered yet *)
36
    | Expr_pre e -> fprintf fmt "UNITDELAY" 
37
    | Expr_when (e, id, l) -> assert false (* clocked based expressions are not handled yet *)
38
    | Expr_merge (id, hl) -> assert false (* clocked based expressions are not handled yet *)
39
    | Expr_appl (id, e, r) -> pp_app fmt id e r
40

    
41
  and pp_tuple fmt el =
42
    fprintf_list ~sep:"," pp_expr fmt el
43

    
44
  and pp_app fmt id e r =
45
    match r with
46
    | None -> pp_call fmt id e
47
    | Some c -> assert false (* clocked based expressions are not handled yet *)
48

    
49
  and pp_call fmt id e =
50
    match id, e.expr_desc with
51
    | "+", Expr_tuple([e1;e2]) -> fprintf fmt "(%a + %a)" pp_expr e1 pp_expr e2
52
    | "uminus", _ -> fprintf fmt "(- %a)" pp_expr e
53
    | "-", Expr_tuple([e1;e2]) -> fprintf fmt "(%a - %a)" pp_expr e1 pp_expr e2
54
    | "*", Expr_tuple([e1;e2]) -> fprintf fmt "(%a * %a)" pp_expr e1 pp_expr e2
55
    | "/", Expr_tuple([e1;e2]) -> fprintf fmt "(%a / %a)" pp_expr e1 pp_expr e2
56
    | "mod", Expr_tuple([e1;e2]) -> fprintf fmt "mod (%a, %a)" pp_expr e1 pp_expr e2
57
    | "&&", Expr_tuple([e1;e2]) -> fprintf fmt "(%a & %a)" pp_expr e1 pp_expr e2
58
    | "||", Expr_tuple([e1;e2]) -> fprintf fmt "(%a | %a)" pp_expr e1 pp_expr e2
59
    | "xor", Expr_tuple([e1;e2]) -> fprintf fmt "xor (%a, %a)" pp_expr e1 pp_expr e2
60
    | "impl", Expr_tuple([e1;e2]) -> fprintf fmt "((~%a) | %a)" pp_expr e1 pp_expr e2
61
    | "<", Expr_tuple([e1;e2]) -> fprintf fmt "(%a < %a)" pp_expr e1 pp_expr e2
62
    | "<=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a <= %a)" pp_expr e1 pp_expr e2
63
    | ">", Expr_tuple([e1;e2]) -> fprintf fmt "(%a > %a)" pp_expr e1 pp_expr e2
64
    | ">=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a >= %a)" pp_expr e1 pp_expr e2
65
    | "!=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a != %a)" pp_expr e1 pp_expr e2
66
    | "=", Expr_tuple([e1;e2]) -> fprintf fmt "(%a = %a)" pp_expr e1 pp_expr e2
67
    | "not", _ -> fprintf fmt "(~%a)" pp_expr e
68
    | _, Expr_tuple _ -> fprintf fmt "%s %a" id pp_expr e
69
    | _ -> fprintf fmt "%s (%a)" id pp_expr e
70

    
71
  in
72
  pp_expr fmt expr
73

    
74
(*
75
let rec translate_expr expr vars =
76
  match expr with
77
    match expr.expr_desc with
78
    | Expr_const _ -> expr, vars
79
    | Expr_ident id -> if List.exists id Format.fprintf fmt "%s" id
80
    | Expr_array a -> fprintf fmt "[%a]" pp_tuple a
81
    | Expr_access (a, d) -> fprintf fmt "%a[%a]" pp_expr a Dimension.pp_dimension d
82
    | Expr_power (a, d) -> fprintf fmt "(%a^%a)" pp_expr a Dimension.pp_dimension d
83
    | Expr_tuple el -> fprintf fmt "(%a)" pp_tuple el
84
    | Expr_ite (c, t, e) -> fprintf fmt "(if %a then %a else %a)" pp_expr c pp_expr t pp_expr e
85
    | Expr_arrow (e1, e2) -> fprintf fmt "(%a -> %a)" pp_expr e1 pp_expr e2
86
    | Expr_fby (e1, e2) -> fprintf fmt "%a fby %a" pp_expr e1 pp_expr e2
87
    | Expr_pre e -> fprintf fmt "pre %a" pp_expr e
88
    | Expr_when (e, id, l) -> fprintf fmt "%a when %s(%s)" pp_expr e l id
89
    | Expr_merge (id, hl) -> 
90
      fprintf fmt "merge %s %a" id pp_handlers hl
91
    | Expr_appl (id, e, r) -> pp_app fmt id e r
92
*)
93
    
94
let pp_stmt fmt stmt =
95
  match stmt with
96
  | Eq eq -> (
97
    match eq.eq_lhs with
98
      [var] -> (
99
     (* first, we extract the expression and associated variables *)
100
	let vars = Utils.ISet.elements (Corelang.get_expr_vars eq.eq_rhs) in
101
	
102
	fprintf fmt "\"%s\": @[<v 2>{ \"expr\": \"%a\";@ \"vars\": [%a] @]}"
103
	  var
104
	  (pp_expr vars) eq.eq_rhs (* todo_pp_expr expr *)
105
	  (fprintf_list ~sep:", " pp_var_string) vars
106
      )
107
    | _ -> assert false (* should not happen for input of EMF backend (cocospec generated nodes *)
108
  )
109
  | _ -> assert false (* should not happen with EMF backend *)
110

    
111
let pp_node fmt nd =
112
  fprintf fmt "@[<v 2>\"%s\": {@ \"inputs\": [%a];@ \"outputs\": [%a];@ "
113
    nd.node_id
114
    pp_node_args nd.node_inputs
115
    pp_node_args nd.node_outputs;
116
  fprintf fmt "\"exprs\": {@[<v 1> %a@]@ }"
117
    (fprintf_list ~sep:";@ " pp_stmt ) nd.node_stmts;
118
  fprintf fmt "@]@ }"
119
    
120
let pp_decl fmt decl =
121
  match decl.top_decl_desc with
122
  | Node nd -> fprintf fmt "%a@ " pp_node nd
123
  | ImportedNode _ 
124
  | Const _
125
  | Open _ 
126
  | TypeDef _ -> eprintf "should not happen in EMF backend"
127

    
128

    
129
let translate fmt prog =
130
  fprintf fmt "@[<v 0>{@ ";
131
  fprintf_list ~sep:"@ " pp_decl fmt prog;
132
  fprintf fmt "@ @]}"
133