Project

General

Profile

« Previous | Next » 

Revision 230b168e

Added by Guillaume DAVY almost 3 years ago

Ada: Refactor Ada Backend to reduce redundancy, make it more modular and
more simple.

View differences:

src/backends/Ada/ada_backend_adb.ml
15 15
open Lustre_types
16 16
open Corelang
17 17
open Machine_code_common
18

  
19
open Misc_printer
20
open Misc_lustre_function
21
open Ada_printer
18 22
open Ada_backend_common
19 23

  
20 24
(** Main module for generating packages bodies
......
42 46
      @param fmt the formater to print on
43 47
      @param instr the instruction to print
44 48
   **)
45
  let rec pp_machine_instr typed_submachines machine fmt instr =
49
  let rec pp_machine_instr typed_submachines machine instr fmt =
46 50
    let pp_instr = pp_machine_instr typed_submachines machine in
47 51
    (* Print args for a step call *)
48 52
    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 53
    (* 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
54
    let pp_when (cond, instrs) fmt =
55
      fprintf fmt "when %s =>@,%a" cond pp_block (List.map pp_instr instrs)
58 56
    in
59 57
    (* Print a case *)
60 58
    let pp_case fmt (g, hl) =
61 59
      fprintf fmt "case %a is@,%aend case"
62 60
        (pp_value machine) g
63
        (pp_block pp_when) hl
61
        pp_block (List.map pp_when hl)
64 62
    in
65 63
    (* Print a if *)
66 64
    (* If neg is true the we must test for the negation of the condition. It
......
80 78
          let pp_else = match instrs2 with
81 79
            | None -> fun fmt -> fprintf fmt ""
82 80
            | Some i2 -> fun fmt ->
83
                fprintf fmt "else@,%a" (pp_block pp_instr) i2
81
                fprintf fmt "else@,%a" pp_block (List.map pp_instr i2)
84 82
          in
85 83
          fprintf fmt "if %a then@,%a%tend if"
86 84
            pp_cond g
87
            (pp_block pp_instr) instrs1
85
            pp_block (List.map pp_instr instrs1)
88 86
            pp_else
89 87
    in
90 88
    match get_instr_desc instr with
......
93 91
      (* reset  *)
94 92
      | MReset i when List.mem_assoc i typed_submachines ->
95 93
          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)
94
          let pp_package = pp_package_name_with_polymorphic substitution submachine in
95
          let args = if is_machine_statefull submachine then [[pp_state i]] else [] in
96
          pp_call fmt (pp_package_access (pp_package, pp_reset_procedure_name), args)
100 97
      | MLocalAssign (ident, value) ->
101 98
          pp_basic_assign machine fmt ident value
102 99
      | MStateAssign (ident, value) ->
......
106 103
          pp_basic_assign machine fmt i0 value
107 104
      | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
108 105
          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))
106
          let pp_package = pp_package_name_with_polymorphic substitution submachine in
107
          let input = List.map (fun x fmt -> pp_value machine fmt x) vl in
108
          let output = List.map (fun x fmt -> pp_var_name fmt x) il in
109
          let args =
110
            (if is_machine_statefull submachine then [[pp_state i]] else [])
111
              @(if input!=[] then [input] else [])
112
              @(if output!=[] then [output] else [])
113
          in
114
          pp_call fmt (pp_package_access (pp_package, pp_step_procedure_name), args)
113 115
      | MBranch (_, []) -> assert false
114 116
      | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
115 117
          let neg = c1=tag_false in
......
131 133
     @param fmt the formater to print on
132 134
     @param machine the machine
133 135
  **)
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)
136
  let pp_step_definition typed_submachines fmt (m, m_spec_opt) =
137
    let spec_instrs = match m_spec_opt with
138
      | None -> []
139
      | Some m -> m.mstep.step_instrs
140
    in
141
    let spec_locals = match m_spec_opt with
142
      | None -> []
143
      | Some m -> m.mstep.step_locals
144
    in
145
    let pp_local_list = List.map build_pp_var_decl_local (m.mstep.step_locals@spec_locals) in
146
    let pp_instr_list = List.map (pp_machine_instr typed_submachines m) (m.mstep.step_instrs@spec_instrs) in
147
    let content = AdaProcedureContent ((if pp_local_list = [] then [] else [pp_local_list]), pp_instr_list) in
148
    pp_procedure pp_step_procedure_name (build_pp_arg_step m) None fmt content
142 149

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

  
......
151 158
      mkinstr (MStateAssign (var, mk_default_value var.var_type))
152 159
    in
153 160
    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
    let pp_instr_list = List.map (pp_machine_instr typed_submachines m) (assigns@m.minit) in
162
    pp_procedure pp_reset_procedure_name (build_pp_arg_reset m) None fmt (AdaProcedureContent ([], pp_instr_list))
161 163

  
162 164
  (** Print the package definition(ads) of a machine.
163 165
    It requires the list of all typed instance.
......
169 171
     @param typed_submachines list of all typed machine instances of this machine
170 172
     @param m the machine
171 173
  **)
172
  let pp_file fmt (typed_submachines, machine) =
174
  let pp_file fmt (typed_submachines, ((opt_spec_machine, guarantees), machine)) =
173 175
    let pp_reset fmt =
174 176
      if is_machine_statefull machine then
175 177
        fprintf fmt "%a;@,@," (pp_reset_definition typed_submachines) machine
......
185 187
          pkg::pkgs
186 188
      with Not_found -> pkgs
187 189
    in
188
    let packages = List.fold_left aux [] machine.mcalls in
189
    fprintf fmt "%a%t%a@,  @[<v>@,%t%a;@,@]@,%a;@."
190
    let packages = List.map pp_str (List.fold_left aux [] machine.mcalls) in
191
    let pp_content fmt =
192
      fprintf fmt "%t%a"
193
        (*Define the reset procedure*)
194
        pp_reset
195
        
196
        (*Define the step procedure*)
197
        (pp_step_definition typed_submachines) (machine, opt_spec_machine)
198
    in
199
    fprintf fmt "%a%t%a;@."
190 200
      
191 201
      (* Include all the required packages*)
192
      (Utils.fprintf_list ~sep:";@," pp_with) packages
202
      (Utils.fprintf_list ~sep:";@," (pp_with AdaNoVisibility)) packages
193 203
      (Utils.pp_final_char_if_non_empty ";@,@," packages)
194 204
      
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
205
      (*Print package*)
206
      (pp_package (pp_package_name machine) [] true ) pp_content
206 207

  
207 208
end
208 209

  

Also available in: Unified diff