Project

General

Profile

Revision 3de9f6e4 src/backends/Ada/ada_backend_adb.ml

View differences:

src/backends/Ada/ada_backend_adb.ml
43 43
   **)
44 44
  let pp_assign m pp_var fmt var_name value = pp_basic_assign m
45 45

  
46
  (* Printing function for reset function *)
47
  (* TODO: clean the call to extract_node *)
48
  (** Printing function for reset function name.
46
  (** Extract from a machine the instance corresponding to the identifier,
47
        assume that the identifier exists in the instances of the machine.
49 48

  
50
      @param machines list of all machines
51
      @param machine the current machine
52
      @param fmt the formater to use
53
      @param encapsulated_node the node encapsulated in a pair
54
             [(instance, (node, static))]
55
   **)
56
  let pp_machine_reset_name machines m fmt encapsulated_node =
57
    let submachine = get_machine machines encapsulated_node in
58
    let substitution = get_substitution m (fst encapsulated_node) submachine in
59
    fprintf fmt "%a.reset" (pp_package_name_with_polymorphic substitution) submachine
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
60 57

  
61
  (** Printing function for reset function.
58
  (** Printing the reset function. call
62 59

  
63
      @param machines list of all machines
60
      @param typed_instances list of all typed machine instances of this machine
64 61
      @param machine the current machine
65
      @param fmt the formater to use
66 62
      @param instance the considered instance
63
      @param fmt the formater to use
67 64
   **)
68
  let pp_machine_reset machines (machine: machine_t) fmt instance =
69
    let node =
70
      try
71
        List.assoc instance machine.minstances
72
      with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s:@." machine.mname.node_id instance; raise Not_found) in
73
    fprintf fmt "%a(%t.%s)"
74
      (pp_machine_reset_name machines machine) (instance, node)
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
75 70
      pp_state_name
76
      instance
71
      identifier
77 72

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

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

  
105
    (* pp_basic_instance_call m self fmt i vl il *)
106
    | MBranch (_, []) -> fprintf fmt "Null"
107

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

  
125

  
126
(** Keep only the MReset from an instruction list.
127
  @param list to filter
128
**)
129
let filter_reset instr_list = List.map
130
    (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false)
131
  instr_list
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
132 117

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

  
135
   @param machines list of all machines
120
   @param typed_instances list of all typed machine instances of this machine
136 121
   @param fmt the formater to print on
137 122
   @param machine the machine
138 123
**)
139
let pp_step_definition machines fmt m = pp_procedure_definition
124
let pp_step_definition typed_instances fmt m = pp_procedure_definition
140 125
      pp_step_procedure_name
141 126
      (pp_step_prototype m)
142 127
      (pp_machine_var_decl NoMode)
143
      (pp_machine_instr machines m)
128
      (pp_machine_instr typed_instances m)
144 129
      fmt
145 130
      (m.mstep.step_locals, m.mstep.step_instrs)
146 131

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

  
149
   @param machines list of all machines
134
   @param typed_instances list of all typed machine instances of this machine
150 135
   @param fmt the formater to print on
151 136
   @param machine the machine
152 137
**)
153
let pp_reset_definition machines fmt m = pp_procedure_definition
138
let pp_reset_definition typed_instances fmt m = pp_procedure_definition
154 139
      pp_reset_procedure_name
155 140
      (pp_reset_prototype m)
156 141
      (pp_machine_var_decl NoMode)
157
      (pp_machine_instr machines m)
142
      (pp_machine_instr typed_instances m)
158 143
      fmt
159 144
      ([], m.minit)
160 145

  
161
(** Print the package definition(adb) of a machine.
162

  
163
   @param machines list of all machines
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.
164 152
   @param fmt the formater to print on
165
   @param machine the machine
153
   @param typed_instances list of all typed machine instances of this machine
154
   @param m the machine
166 155
**)
167
let pp_file machines fmt machine =
156
let pp_file fmt (typed_instances, machine) =
168 157
  fprintf fmt "%a@,  @[<v>@,%a;@,@,%a;@,@]@,%a;@."
169 158
    (pp_begin_package true) machine (*Begin the package*)
170
    (pp_reset_definition machines) machine (*Define the reset procedure*)
171
    (pp_step_definition machines) machine (*Define the step procedure*)
159
    (pp_reset_definition typed_instances) machine (*Define the reset procedure*)
160
    (pp_step_definition typed_instances) machine (*Define the step procedure*)
172 161
    pp_end_package machine  (*End the package*)
173 162

  
174 163
end

Also available in: Unified diff