Project

General

Profile

Revision 826063db

View differences:

src/backends/Ada/ada_backend.ml
114 114
  (match main_machine with
115 115
    | None -> ()
116 116
    | Some machine ->
117
        write_file destname pp_main_filename Wrapper.pp_main_adb machine;
117
        write_file destname pp_main_filename (Wrapper.pp_main_adb (get_typed_submachines machines machine)) machine;
118 118
        write_file destname (Wrapper.pp_project_name (basename^"_exe")) (Wrapper.pp_project_file machines basename) main_machine);
119 119
  write_file destname Wrapper.pp_project_configuration_name Wrapper.pp_project_configuration_file basename;
120 120
  write_file destname (Wrapper.pp_project_name (basename^"_lib")) (Wrapper.pp_project_file machines basename) None;
src/backends/Ada/ada_backend_adb.ml
33 33
      (pp_access_var m) var_name
34 34
      (pp_value m) value
35 35

  
36
  (** Extract from a machine the instance corresponding to the identifier,
37
        assume that the identifier exists in the instances of the machine.
38

  
39
     @param identifier the instance identifier
40
     @param machine a machine
41
     @return the instance of machine.minstances corresponding to identifier
42
  **)
43
  let get_instance identifier typed_submachines =
44
    try
45
      List.assoc identifier typed_submachines
46
    with Not_found -> assert false
47

  
48
  (** Printing a call to a package function
49

  
50
      @param typed_submachines list of all typed machine instances of this machine
51
      @param pp_name printer for the function name
52
      @param fmt the formater to use
53
      @param identifier the instance identifier
54
      @param pp_args_opt optional printer for other arguments
55
   **)
56
  let pp_package_call typed_submachines pp_name fmt (identifier, pp_args_opt) =
57
    let (substitution, submachine) = get_instance identifier typed_submachines in
58
    let statefull = is_machine_statefull submachine in
59
    let pp_opt fmt = function
60
        | Some pp_args when statefull -> fprintf fmt ",@,%t" pp_args
61
        | Some pp_args -> pp_args fmt
62
        | None -> fprintf fmt ""
63
    in
64
    let pp_state fmt =
65
      if statefull then
66
        fprintf fmt "%t.%s" pp_state_name identifier
67
      else
68
        fprintf fmt ""
69
    in
70
    fprintf fmt "%a.%t(@[<v>%t%a@])"
71
      (pp_package_name_with_polymorphic substitution) submachine
72
      pp_name
73
      pp_state
74
      pp_opt pp_args_opt
75

  
76 36
  (** Printing function for instruction. See
77 37
      {!type:Machine_code_types.instr_t} for more details on
78 38
      machine types.
......
85 45
  let rec pp_machine_instr typed_submachines machine fmt instr =
86 46
    let pp_instr = pp_machine_instr typed_submachines machine in
87 47
    (* Print args for a step call *)
48
    let pp_state i fmt = fprintf fmt "%t.%s" pp_state_name i in
88 49
    let pp_args vl il fmt =
89 50
      fprintf fmt "@[%a@]%t@[%a@]"
90 51
        (Utils.fprintf_list ~sep:",@ " (pp_value machine)) vl
91 52
        (Utils.pp_final_char_if_non_empty ",@," il)
92
        (Utils.fprintf_list ~sep:",@ " (pp_access_var machine)) il
53
        (Utils.fprintf_list ~sep:",@ " pp_var_name) il
93 54
    in
94 55
    (* Print a when branch of a case *)
95 56
    let pp_when fmt (cond, instrs) =
......
130 91
      (* no reset *)
131 92
      | MNoReset _ -> ()
132 93
      (* reset  *)
133
      | MReset i ->
94
      | MReset i when List.mem_assoc i typed_submachines ->
95
          let (substitution, submachine) = get_instance i typed_submachines in
134 96
          pp_package_call
135
            typed_submachines
136 97
            pp_reset_procedure_name
137 98
            fmt
138
            (i, None)
99
            (substitution, submachine, pp_state i, None)
139 100
      | MLocalAssign (ident, value) ->
140 101
          pp_basic_assign machine fmt ident value
141 102
      | MStateAssign (ident, value) ->
......
144 105
          let value = mk_val (Fun (i, vl)) i0.var_type in
145 106
          pp_basic_assign machine fmt i0 value
146 107
      | MStep (il, i, vl) when List.mem_assoc i typed_submachines ->
108
          let (substitution, submachine) = get_instance i typed_submachines in
147 109
          pp_package_call
148
            typed_submachines
149 110
            pp_step_procedure_name
150 111
            fmt
151
            (i, Some (pp_args vl il))
112
            (substitution, submachine, pp_state i, Some (pp_args vl il))
152 113
      | MBranch (_, []) -> assert false
153 114
      | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
154 115
          let neg = c1=tag_false in
src/backends/Ada/ada_backend_common.ml
837 837
  pp_filename extension fmt (function fmt -> pp_package_name fmt machine)
838 838

  
839 839
let pp_main_filename fmt _ = pp_filename "adb" fmt pp_main_procedure_name
840

  
841
(** Extract from a machine the instance corresponding to the identifier,
842
      assume that the identifier exists in the instances of the machine.
843

  
844
   @param identifier the instance identifier
845
   @param machine a machine
846
   @return the instance of machine.minstances corresponding to identifier
847
**)
848
let get_instance identifier typed_submachines =
849
  try
850
    List.assoc identifier typed_submachines
851
  with Not_found -> assert false
852

  
853
(** Printing a call to a package function
854

  
855
    @param typed_submachines list of all typed machine instances of this machine
856
    @param pp_name printer for the function name
857
    @param fmt the formater to use
858
    @param identifier the instance identifier
859
    @param pp_args_opt optional printer for other arguments
860
 **)
861
let pp_package_call pp_name fmt (substitution, submachine, pp_state, pp_args_opt) =
862
  let statefull = is_machine_statefull submachine in
863
  let pp_opt fmt = function
864
      | Some pp_args when statefull -> fprintf fmt ",@,%t" pp_args
865
      | Some pp_args -> pp_args fmt
866
      | None -> fprintf fmt ""
867
  in
868
  let pp_state fmt =
869
    if statefull then
870
      pp_state fmt
871
    else
872
      fprintf fmt ""
873
  in
874
  fprintf fmt "%a.%t(@[<v>%t%a@])"
875
    (pp_package_name_with_polymorphic substitution) submachine
876
    pp_name
877
    pp_state
878
    pp_opt pp_args_opt
879

  
src/backends/Ada/ada_backend_wrapper.ml
48 48
     @param fmt the formater to print on
49 49
     @param machine the main machine
50 50
  **)
51
  let pp_main_adb fmt machine =
51
  let pp_main_adb typed_submachines fmt machine =
52
    let statefull = is_machine_statefull machine in
52 53
    let pp_str str fmt = fprintf fmt "%s" str in
54
    
53 55
    (* Dependances *)
54 56
    let text_io = "Ada.Text_IO" in
55 57
    let float_io = "package Float_IO is new Ada.Text_IO.Float_IO(Float)" in
56 58
    let integer_io = "package Integer_IO is new Ada.Text_IO.Integer_IO(Integer)" in
57 59
    
58 60
    (* Locals *)
59
    let stateVar = "state" in
60
    let step_parameters = machine.mstep.step_inputs@machine.mstep.step_outputs in
61
    let stateVar = asprintf "%t" pp_state_name in
61 62
    let pp_local_state_var_decl fmt = pp_node_state_decl [] stateVar fmt machine in
62 63
    let apply_pp_var_decl var fmt = pp_machine_var_decl NoMode fmt var in
64
    let step_parameters = machine.mstep.step_inputs@machine.mstep.step_outputs in
63 65
    let locals = List.map apply_pp_var_decl step_parameters in
64
    let locals = (pp_str integer_io)::(pp_str float_io)::pp_local_state_var_decl::locals in
66
    let locals = [pp_str integer_io;pp_str float_io]@(if statefull then [pp_local_state_var_decl] else [])@locals in
65 67

  
66 68
    (* Node instructions *)
67 69
    let pp_reset fmt =
68
      fprintf fmt "%a.reset(%s)"
69
        pp_package_name machine
70
        stateVar in
70
      pp_package_call
71
        pp_reset_procedure_name
72
        fmt
73
        ([], machine, pp_state_name, None)
74
    in
75
    let pp_args fmt =
76
      fprintf fmt "@[%a@]"
77
        (Utils.fprintf_list ~sep:",@ " pp_var_name) step_parameters
78
    in
71 79
    let pp_step fmt =
72
      fprintf fmt "%a.step(@[%s,@ %a@])"
73
        pp_package_name machine
74
        stateVar
75
        (Utils.fprintf_list ~sep:",@ " pp_var_name) step_parameters in
80
          pp_package_call
81
            pp_step_procedure_name
82
            fmt
83
            ([], machine, pp_state_name, Some pp_args)
84
    in
76 85

  
77 86
    (* Stream instructions *)
78 87
    let get_basic var = match (Types.repr var.var_type ).Types.tdesc with
......
112 121
        (Utils.fprintf_list ~sep:";@," pp_write) machine.mstep.step_outputs in
113 122
    
114 123
    (* Print the file *)
115
    let instrs = [ pp_reset;
116
                   pp_loop] in
124
    let instrs = (if statefull then [pp_reset] else [])@[pp_loop] in
117 125
    fprintf fmt "@[<v>%a;@,%a;@,@,%a;@]"
118 126
      pp_private_with (pp_str text_io)
119 127
      pp_with_machine machine

Also available in: Unified diff