Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / Ada / ada_backend_adb.ml @ 826063db

History | View | Annotate | Download (7.48 KB)

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 instruction. See
37
      {!type:Machine_code_types.instr_t} for more details on
38
      machine types.
39

    
40
      @param typed_submachines list of all typed machine instances of this machine
41
      @param machine the current machine
42
      @param fmt the formater to print on
43
      @param instr the instruction to print
44
   **)
45
  let rec pp_machine_instr typed_submachines machine fmt instr =
46
    let pp_instr = pp_machine_instr typed_submachines machine in
47
    (* Print args for a step call *)
48
    let pp_state i fmt = fprintf fmt "%t.%s" pp_state_name i in
49
    let pp_args vl il fmt =
50
      fprintf fmt "@[%a@]%t@[%a@]"
51
        (Utils.fprintf_list ~sep:",@ " (pp_value machine)) vl
52
        (Utils.pp_final_char_if_non_empty ",@," il)
53
        (Utils.fprintf_list ~sep:",@ " pp_var_name) il
54
    in
55
    (* Print a when branch of a case *)
56
    let pp_when fmt (cond, instrs) =
57
      fprintf fmt "when %s =>@,%a" cond (pp_block pp_instr) instrs
58
    in
59
    (* Print a case *)
60
    let pp_case fmt (g, hl) =
61
      fprintf fmt "case %a is@,%aend case"
62
        (pp_value machine) g
63
        (pp_block pp_when) hl
64
    in
65
    (* Print a if *)
66
    (* If neg is true the we must test for the negation of the condition. It
67
       first check that we don't have a negation and a else case, if so it
68
       inverses the two branch and remove the negation doing a recursive
69
       call. *)
70
    let rec pp_if neg fmt (g, instrs1, instrs2) =
71
      match neg, instrs2 with
72
        | true, Some x -> pp_if false fmt (g, x, Some instrs1)
73
        | _ ->
74
          let pp_cond =
75
            if neg then
76
              fun fmt x -> fprintf fmt "! (%a)" (pp_value machine) x
77
            else
78
              pp_value machine
79
          in
80
          let pp_else = match instrs2 with
81
            | None -> fun fmt -> fprintf fmt ""
82
            | Some i2 -> fun fmt ->
83
                fprintf fmt "else@,%a" (pp_block pp_instr) i2
84
          in
85
          fprintf fmt "if %a then@,%a%tend if"
86
            pp_cond g
87
            (pp_block pp_instr) instrs1
88
            pp_else
89
    in
90
    match get_instr_desc instr with
91
      (* no reset *)
92
      | MNoReset _ -> ()
93
      (* reset  *)
94
      | MReset i when List.mem_assoc i typed_submachines ->
95
          let (substitution, submachine) = get_instance i typed_submachines in
96
          pp_package_call
97
            pp_reset_procedure_name
98
            fmt
99
            (substitution, submachine, pp_state i, None)
100
      | MLocalAssign (ident, value) ->
101
          pp_basic_assign machine fmt ident value
102
      | MStateAssign (ident, value) ->
103
          pp_basic_assign machine fmt ident value
104
      | MStep ([i0], i, vl) when is_builtin_fun i ->
105
          let value = mk_val (Fun (i, vl)) i0.var_type in
106
          pp_basic_assign machine fmt i0 value
107
      | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
108
          let (substitution, submachine) = get_instance i typed_submachines in
109
          pp_package_call
110
            pp_step_procedure_name
111
            fmt
112
            (substitution, submachine, pp_state i, Some (pp_args vl il))
113
      | MBranch (_, []) -> assert false
114
      | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
115
          let neg = c1=tag_false in
116
          let other = match tl with
117
            | []         -> None
118
            | [(c2, i2)] -> Some i2
119
            | _          -> assert false
120
          in
121
          pp_if neg fmt (g, i1, other)
122
      | MBranch (g, hl) -> pp_case fmt (g, hl)
123
      | MComment s  ->
124
          let lines = String.split_on_char '\n' s in
125
          fprintf fmt "%a" (Utils.fprintf_list ~sep:"" pp_oneline_comment) lines
126
      | _ -> assert false
127

    
128
  (** Print the definition of the step procedure from a machine.
129

    
130
     @param typed_submachines list of all typed machine instances of this machine
131
     @param fmt the formater to print on
132
     @param machine the machine
133
  **)
134
  let pp_step_definition typed_submachines fmt m =
135
    pp_procedure_definition
136
      pp_step_procedure_name
137
      (pp_step_prototype m)
138
      (pp_machine_var_decl NoMode)
139
      (pp_machine_instr typed_submachines m)
140
      fmt
141
      (m.mstep.step_locals, m.mstep.step_instrs)
142

    
143
  (** Print the definition of the reset procedure from a machine.
144

    
145
     @param typed_submachines list of all typed machine instances of this machine
146
     @param fmt the formater to print on
147
     @param machine the machine
148
  **)
149
  let pp_reset_definition typed_submachines fmt m =
150
    let build_assign = function var ->
151
      mkinstr (MStateAssign (var, mk_default_value var.var_type))
152
    in
153
    let assigns = List.map build_assign m.mmemory in
154
    pp_procedure_definition
155
      pp_reset_procedure_name
156
      (pp_reset_prototype m)
157
      (pp_machine_var_decl NoMode)
158
      (pp_machine_instr typed_submachines m)
159
      fmt
160
      ([], assigns@m.minit)
161

    
162
  (** Print the package definition(ads) of a machine.
163
    It requires the list of all typed instance.
164
    A typed submachine instance is (ident, type_machine) with ident
165
    the instance name and typed_machine is (substitution, machine) with machine
166
    the machine associated to the instance and substitution the instanciation of
167
    all its polymorphic types.
168
     @param fmt the formater to print on
169
     @param typed_submachines list of all typed machine instances of this machine
170
     @param m the machine
171
  **)
172
  let pp_file fmt (typed_submachines, machine) =
173
    let pp_reset fmt =
174
      if is_machine_statefull machine then
175
        fprintf fmt "%a;@,@," (pp_reset_definition typed_submachines) machine
176
      else
177
        fprintf fmt ""
178
    in
179
    let aux pkgs (id, _) =
180
      try
181
        let (pkg, _) = List.assoc id ada_supported_funs in
182
        if List.mem pkg pkgs then
183
          pkgs
184
        else
185
          pkg::pkgs
186
      with Not_found -> pkgs
187
    in
188
    let packages = List.fold_left aux [] machine.mcalls in
189
    fprintf fmt "%a%t%a@,  @[<v>@,%t%a;@,@]@,%a;@."
190
      
191
      (* Include all the required packages*)
192
      (Utils.fprintf_list ~sep:";@," pp_with) packages
193
      (Utils.pp_final_char_if_non_empty ";@,@," packages)
194
      
195
      (*Begin the package*)
196
      (pp_begin_package true) machine
197
      
198
      (*Define the reset procedure*)
199
      pp_reset
200
      
201
      (*Define the step procedure*)
202
      (pp_step_definition typed_submachines) machine
203
      
204
      (*End the package*)
205
      pp_end_package machine
206

    
207
end
208

    
209
(* Local Variables: *)
210
(* compile-command: "make -C ../../.." *)
211
(* End: *)