Project

General

Profile

Download (6.63 KB) Statistics
| Branch: | Tag: | Revision:
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT - ISAE-SUPAERO     *)
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

    
14
open Machine_code_types
15
open Lustre_types
16
open Corelang
17
open Machine_code_common
18
open Ada_backend_common
19

    
20
(** Main module for generating packages bodies
21
 **)
22
module Main =
23
struct
24

    
25
  (** Printing function for basic assignement [var_name := value;].
26

    
27
      @param fmt the formater to print on
28
      @param var_name the name of the variable
29
      @param value the value to be assigned
30
   **)
31
  let pp_basic_assign m fmt var_name value =
32
    fprintf fmt "%a := %a"
33
      (pp_access_var m) var_name
34
      (pp_value m) value
35

    
36
  (** Printing function for assignement. For the moment, only use
37
      [pp_basic_assign] function.
38

    
39
      @param pp_var pretty printer for variables
40
      @param fmt the formater to print on
41
      @param var_name the name of the variable
42
      @param value the value to be assigned
43
   **)
44
  let pp_assign m pp_var fmt var_name value = pp_basic_assign m
45

    
46
  (* Printing function for reset function *)
47
  (* TODO: clean the call to extract_node *)
48
  (** Printing function for reset function name.
49

    
50
      @param fmt the formater to use
51
      @param encapsulated_node the node encapsulated in a pair
52
             [(instance, (node, static))]
53
   **)
54
  let pp_machine_reset_name fmt encapsulated_node =
55
    fprintf fmt "%a.reset" pp_package_name_from_node (extract_node encapsulated_node)
56

    
57
  (** Printing function for reset function.
58

    
59
      @param machine the considered machine
60
      @param fmt the formater to use
61
      @param instance the considered instance
62
   **)
63
  let pp_machine_reset (machine: machine_t) fmt instance =
64
    let (node, static) =
65
      try
66
        List.assoc instance machine.minstances
67
      with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s:@." machine.mname.node_id instance; raise Not_found) in
68
    fprintf fmt "%a(state.%s)"
69
      pp_machine_reset_name (instance, (node, static))
70
      instance
71

    
72
  (** Printing function for instruction. See
73
      {!type:Machine_code_types.instr_t} for more details on
74
      machine types.
75

    
76
      @param machine the current machine
77
      @param fmt the formater to print on
78
      @param instr the instruction to print
79
   **)
80
  let pp_machine_instr machine fmt instr =
81
    match get_instr_desc instr with
82
    (* no reset *)
83
    | MNoReset _ -> ()
84
    (* reset  *)
85
    | MReset ident ->
86
      pp_machine_reset machine fmt ident
87
    | MLocalAssign (ident, value) ->
88
      pp_basic_assign machine fmt ident value
89
    | MStateAssign (ident, value) ->
90
      pp_basic_assign machine fmt ident value
91
    | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun
92
          (mk_val (Fun (i, vl)) i0.var_type)  ->
93
      fprintf fmt "Null"
94
    (* pp_machine_instr dependencies m self fmt
95
     *   (update_instr_desc instr (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type))) *)
96
    | MStep (il, i, vl) -> fprintf fmt "Null"
97

    
98
    (* pp_basic_instance_call m self fmt i vl il *)
99
    | MBranch (_, []) -> fprintf fmt "Null"
100

    
101
    (* (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." (pp_instr m) instr; assert false) *)
102
    | MBranch (g, hl) -> fprintf fmt "Null"
103
    (* if let t = fst (List.hd hl) in t = tag_true || t = tag_false
104
     * then (\* boolean case, needs special treatment in C because truth value is not unique *\)
105
     *   (\* may disappear if we optimize code by replacing last branch test with default *\)
106
     *   let tl = try List.assoc tag_true  hl with Not_found -> [] in
107
     *   let el = try List.assoc tag_false hl with Not_found -> [] in
108
     *   pp_conditional dependencies m self fmt g tl el
109
     * else (\* enum type case *\)
110
     *   (\*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*\)
111
     *   fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
112
     *     (pp_c_val m self (pp_c_var_read m)) g
113
     *     (Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl *)
114
    | MComment s  ->
115
      fprintf fmt "-- %s@ " s
116
    | _ -> fprintf fmt "Don't  know"
117

    
118

    
119
(** Keep only the MReset from an instruction list.
120
  @param list to filter
121
**)
122
let filter_reset instr_list = List.map
123
    (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false)
124
  instr_list
125

    
126
(** Print the definition of the init procedure from a machine.
127
   @param fmt the formater to print on
128
   @param machine the machine
129
**)
130
let pp_init_definition fmt m = pp_procedure_definition
131
      pp_init_procedure_name
132
      (pp_init_prototype m)
133
      (pp_machine_var_decl NoMode)
134
      (pp_machine_instr m)
135
      fmt
136
      ([], m.minit)
137

    
138
(** Print the definition of the step procedure from a machine.
139
   @param fmt the formater to print on
140
   @param machine the machine
141
**)
142
let pp_step_definition fmt m = pp_procedure_definition
143
      pp_step_procedure_name
144
      (pp_step_prototype m)
145
      (pp_machine_var_decl NoMode)
146
      (pp_machine_instr m)
147
      fmt
148
      (m.mstep.step_locals, m.mstep.step_instrs)
149

    
150
(** Print the definition of the reset procedure from a machine.
151
   @param fmt the formater to print on
152
   @param machine the machine
153
**)
154
let pp_reset_definition fmt m = pp_procedure_definition
155
      pp_reset_procedure_name
156
      (pp_reset_prototype m)
157
      (pp_machine_var_decl NoMode)
158
      (pp_machine_instr m)
159
      fmt
160
      ([], m.minit)
161

    
162
(** Print the definition of the clear procedure from a machine.
163
   @param fmt the formater to print on
164
   @param machine the machine
165
**)
166
let pp_clear_definition fmt m = pp_procedure_definition
167
      pp_clear_procedure_name
168
      (pp_clear_prototype m)
169
      (pp_machine_var_decl NoMode)
170
      (pp_machine_instr m)
171
      fmt
172
      ([], m.minit)
173

    
174
(** Print the package definition(adb) of a machine.
175
   @param fmt the formater to print on
176
   @param machine the machine
177
**)
178
let pp_file fmt machine =
179
  fprintf fmt "%a@,  @[<v>@,%a;@,@,%a;@,@]@,%a;@."
180
    (pp_begin_package true) machine (*Begin the package*)
181
    pp_reset_definition machine (*Define the reset procedure*)
182
    pp_step_definition machine (*Define the step procedure*)
183
    pp_end_package machine  (*End the package*)
184

    
185
end
186

    
187
(* Local Variables: *)
188
(* compile-command: "make -C ../../.." *)
189
(* End: *)
(3-3/6)