Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / Ada / ada_backend_adb.ml @ 3de9f6e4

History | View | Annotate | Download (6.61 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 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
  (** Extract from a machine the instance corresponding to the identifier,
47
        assume that the identifier exists in the instances of the machine.
48

    
49
     @param identifier the instance identifier
50
     @param machine a machine
51
     @return the instance of machine.minstances corresponding to identifier
52
  **)
53
  let get_instance identifier typed_instances =
54
    try
55
      List.assoc identifier typed_instances
56
    with Not_found -> assert false
57

    
58
  (** Printing the reset function. call
59

    
60
      @param typed_instances list of all typed machine instances of this machine
61
      @param machine the current machine
62
      @param instance the considered instance
63
      @param fmt the formater to use
64
   **)
65
  let pp_machine_reset typed_instances (machine: machine_t) fmt identifier =
66
    let (substitution, submachine) = get_instance identifier typed_instances in
67
    fprintf fmt "%a.%t(%t.%s)"
68
      (pp_package_name_with_polymorphic substitution) submachine
69
      pp_reset_procedure_name
70
      pp_state_name
71
      identifier
72

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

    
77
      @param typed_instances list of all typed machine instances of this machine
78
      @param machine the current machine
79
      @param fmt the formater to print on
80
      @param instr the instruction to print
81
   **)
82
  let pp_machine_instr typed_instances machine fmt instr =
83
    match get_instr_desc instr with
84
      (* no reset *)
85
      | MNoReset _ -> ()
86
      (* reset  *)
87
      | MReset ident ->
88
          pp_machine_reset typed_instances machine fmt ident
89
      | MLocalAssign (ident, value) ->
90
          pp_basic_assign machine fmt ident value
91
      | MStateAssign (ident, value) ->
92
          pp_basic_assign machine fmt ident value
93
      | MStep ([i0], i, vl) when Basic_library.is_internal_fun i
94
                                   (List.map (fun v -> v.value_type) vl) ->
95
          let value = mk_val (Fun (i, vl)) i0.var_type in
96
          pp_basic_assign machine fmt i0 value
97
      | MStep (il, i, vl) -> fprintf fmt "Null"
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
        let lines = String.split_on_char '\n' s in
116
        fprintf fmt "%a" (Utils.fprintf_list ~sep:"" pp_oneline_comment) lines
117

    
118
(** Print the definition of the step procedure from a machine.
119

    
120
   @param typed_instances list of all typed machine instances of this machine
121
   @param fmt the formater to print on
122
   @param machine the machine
123
**)
124
let pp_step_definition typed_instances fmt m = pp_procedure_definition
125
      pp_step_procedure_name
126
      (pp_step_prototype m)
127
      (pp_machine_var_decl NoMode)
128
      (pp_machine_instr typed_instances m)
129
      fmt
130
      (m.mstep.step_locals, m.mstep.step_instrs)
131

    
132
(** Print the definition of the reset procedure from a machine.
133

    
134
   @param typed_instances list of all typed machine instances of this machine
135
   @param fmt the formater to print on
136
   @param machine the machine
137
**)
138
let pp_reset_definition typed_instances fmt m = pp_procedure_definition
139
      pp_reset_procedure_name
140
      (pp_reset_prototype m)
141
      (pp_machine_var_decl NoMode)
142
      (pp_machine_instr typed_instances m)
143
      fmt
144
      ([], m.minit)
145

    
146
(** Print the package definition(ads) of a machine.
147
  It requires the list of all typed instance.
148
  A typed submachine instance is (ident, type_machine) with ident
149
  the instance name and typed_machine is (substitution, machine) with machine
150
  the machine associated to the instance and substitution the instanciation of
151
  all its polymorphic types.
152
   @param fmt the formater to print on
153
   @param typed_instances list of all typed machine instances of this machine
154
   @param m the machine
155
**)
156
let pp_file fmt (typed_instances, machine) =
157
  fprintf fmt "%a@,  @[<v>@,%a;@,@,%a;@,@]@,%a;@."
158
    (pp_begin_package true) machine (*Begin the package*)
159
    (pp_reset_definition typed_instances) machine (*Define the reset procedure*)
160
    (pp_step_definition typed_instances) machine (*Define the step procedure*)
161
    pp_end_package machine  (*End the package*)
162

    
163
end
164

    
165
(* Local Variables: *)
166
(* compile-command: "make -C ../../.." *)
167
(* End: *)