Project

General

Profile

Download (5.4 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
open Format
13
open LustreSpec
14
open Corelang
15
open Machine_code
16

    
17
let machine_reset_name id = id ^ "_reset"
18
let machine_step_name id = id ^ "_step" 
19
let machine_stateless_name id = id ^ "_fun" 
20
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
21
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
22
let pp_machine_stateless_name fmt id = fprintf fmt "%s_fun" id
23

    
24
let rec pp_type fmt t =
25
  if Types.is_bool_type t  then fprintf fmt "Bool" else
26
  if Types.is_int_type t then fprintf fmt "Int" else 
27
  if Types.is_real_type t then fprintf fmt "Real" else 
28
  match (Types.repr t).Types.tdesc with
29
  | Types.Tconst ty       -> pp_print_string fmt ty
30
  | Types.Tclock t        -> pp_type fmt t
31
  | Types.Tarray(dim,ty)   -> fprintf fmt "(Array Int "; pp_type fmt ty; fprintf fmt ")"
32
  | Types.Tstatic(d, ty)-> pp_type fmt ty
33
  | Types.Tarrow _
34
  | _                     -> eprintf "internal error: pp_type %a@."
35
    Types.print_ty t; assert false
36

    
37
let pp_decl_var fmt id =
38
  fprintf fmt "(declare-var %s %a)"
39
    id.var_id
40
    pp_type id.var_type
41

    
42
(* let pp_var fmt id = pp_print_string fmt id.var_id  *)
43

    
44

    
45
let pp_conj pp fmt l =
46
  match l with
47
    [] -> assert false
48
  | [x] -> pp fmt x
49
  | _ -> fprintf fmt "(and @[<v 0>%a@]@ )" (Utils.fprintf_list ~sep:"@ " pp) l
50

    
51

    
52

    
53
(********************************************************************************************)
54
(*                    Workaround to prevent the use of declared keywords as node name       *)
55
(********************************************************************************************)
56
let registered_keywords = ["implies"]
57

    
58
let protect_kwd s = 
59
  if List.mem s registered_keywords then
60
    "__" ^ s
61
  else
62
    s
63

    
64
let node_name n =
65
  let name = node_name n in
66
  protect_kwd name
67

    
68

    
69
let concat prefix x = if prefix = "" then x else prefix ^ "." ^ x
70
let rename f = (fun v -> {v with var_id = f v.var_id } )
71
let rename_machine p = rename (fun n -> concat p n)
72
let rename_machine_list p = List.map (rename_machine p)
73

    
74
let rename_current =  rename (fun n -> n ^ "_c")
75
let rename_current_list = List.map rename_current
76
let rename_mid =  rename (fun n -> n ^ "_m")
77
let rename_mid_list = List.map rename_mid
78
let rename_next = rename (fun n -> n ^ "_x")
79
let rename_next_list = List.map rename_next
80

    
81
let get_machine machines node_name =
82
(*  try *)
83
  List.find (fun m  -> m.mname.node_id = node_name) machines
84
(* with Not_found -> Format.eprintf "Unable to find machine %s in machines %a@.@?"  *)
85
(*   node_name *)
86
(*   (Utils.fprintf_list ~sep:", " (fun fmt m -> pp_print_string fmt m.mname.node_id)) machines *)
87
(*   ; assert false *)
88

    
89
let local_memory_vars machines machine =
90
  rename_machine_list machine.mname.node_id machine.mmemory
91
    
92
let instances_memory_vars ?(without_arrow=false) machines machine =
93
  let rec aux fst prefix m =
94
    (
95
      if not fst then (
96
	(rename_machine_list (concat prefix m.mname.node_id) m.mmemory)
97
      )
98
      else []
99
    ) @
100
      List.fold_left (fun accu (id, (n, _)) ->
101
	let name = node_name n in
102
	if without_arrow && name = "_arrow" then
103
	  accu 
104
	else
105
	  let machine_n = get_machine machines name in
106
	  ( aux false (concat prefix 
107
			 (if fst then id else concat m.mname.node_id id))
108
	      machine_n ) @ accu
109
      ) [] (m.minstances)
110
  in
111
  aux true machine.mname.node_id machine
112

    
113
(* Extract the arrows of a given node/machine *)
114
let arrow_vars machines machine : LustreSpec.var_decl list =
115
  let rec aux fst prefix m =
116
    List.fold_left (fun accu (id, (n, _)) ->
117
      let name = node_name n in
118
      if name = "_arrow" then
119
	let arrow_machine = Machine_code.arrow_machine in
120
	(rename_machine_list
121
	  (concat prefix (concat (if fst then id else concat m.mname.node_id id) "_arrow"))
122
	  arrow_machine.mmemory
123
	) @ accu
124
      else
125
	let machine_n = get_machine machines name in
126
	( aux false (concat prefix
127
		       (if fst then id else concat m.mname.node_id id))
128
	    machine_n ) @ accu
129
    ) [] (m.minstances)
130
  in
131
  aux true machine.mname.node_id machine
132

    
133
let full_memory_vars ?(without_arrow=false) machines machine =
134
  (local_memory_vars machines machine)
135
  @ (instances_memory_vars ~without_arrow machines machine)
136

    
137
let inout_vars machines m =
138
  (rename_machine_list m.mname.node_id m.mstep.step_inputs)
139
  @ (rename_machine_list m.mname.node_id m.mstep.step_outputs)
140

    
141
let step_vars machines m =
142
  (inout_vars machines m)
143
  @ (rename_current_list (full_memory_vars machines m)) 
144
  @ (rename_next_list (full_memory_vars machines m))
145

    
146
let step_vars_m_x machines m =
147
  (inout_vars machines m)
148
  @ (rename_mid_list (full_memory_vars machines m)) 
149
  @ (rename_next_list (full_memory_vars machines m))
150

    
151
let reset_vars machines m =
152
  (rename_current_list (full_memory_vars machines m)) 
153
  @ (rename_mid_list (full_memory_vars machines m))
154

    
155

    
156
(* Local Variables: *)
157
(* compile-command:"make -C ../.." *)
158
(* End: *)
(3-3/5)