| 22 |
22 |
module Main =
|
| 23 |
23 |
struct
|
| 24 |
24 |
|
| 25 |
|
(* Printing functions for basic operations *)
|
|
25 |
(* Printing functions for basic operations and expressions *)
|
|
26 |
(* TODO: refactor code -> use let rec and for basic pretty printing
|
|
27 |
function *)
|
|
28 |
(** Printing function for Ada tags, mainly booleans.
|
|
29 |
|
|
30 |
@param fmt the formater to use
|
|
31 |
@param t the tag to print
|
|
32 |
**)
|
|
33 |
let pp_ada_tag fmt t =
|
|
34 |
pp_print_string fmt
|
|
35 |
(if t = tag_true then "True" else if t = tag_false then "Flase" else t)
|
|
36 |
|
|
37 |
(** Printing function for machine type constants. For the moment,
|
|
38 |
arrays are not supported.
|
|
39 |
|
|
40 |
@param fmt the formater to use
|
|
41 |
@param c the constant to print
|
|
42 |
**)
|
|
43 |
let pp_ada_const fmt c =
|
|
44 |
match c with
|
|
45 |
| Const_int i -> pp_print_int fmt i
|
|
46 |
| Const_real (c, e, s) -> pp_print_string fmt s
|
|
47 |
| Const_tag t -> pp_ada_tag fmt t
|
|
48 |
| Const_string _ | Const_modeid _ ->
|
|
49 |
(Format.eprintf
|
|
50 |
"internal error: Ada_backend_adb.pp_ada_const cannot print string or modeid.";
|
|
51 |
assert false)
|
|
52 |
| _ ->
|
|
53 |
raise (Ada_not_supported "unsupported: Ada_backend_adb.pp_ada_const does not
|
|
54 |
support this constant")
|
| 26 |
55 |
|
| 27 |
56 |
(** Printing function for expressions [v1 modulo v2]. Depends
|
| 28 |
57 |
on option [integer_div_euclidean] to choose between mathematical
|
| 29 |
58 |
modulo or remainder ([rem] in Ada).
|
| 30 |
59 |
|
| 31 |
|
@param pp_val pretty printer for values
|
|
60 |
@param pp_value pretty printer for values
|
| 32 |
61 |
@param v1 the first value in the expression
|
| 33 |
62 |
@param v2 the second value in the expression
|
| 34 |
63 |
@param fmt the formater to print on
|
| 35 |
64 |
**)
|
| 36 |
|
let pp_mod pp_val v1 v2 fmt =
|
|
65 |
let pp_mod pp_value v1 v2 fmt =
|
| 37 |
66 |
if !Options.integer_div_euclidean then
|
| 38 |
67 |
(* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
|
| 39 |
68 |
Format.fprintf fmt
|
| 40 |
69 |
"((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
|
| 41 |
|
pp_val v1 pp_val v2
|
| 42 |
|
pp_val v1 pp_val v2
|
| 43 |
|
pp_val v2
|
|
70 |
pp_value v1 pp_value v2
|
|
71 |
pp_value v1 pp_value v2
|
|
72 |
pp_value v2
|
| 44 |
73 |
else (* Ada behavior for rem *)
|
| 45 |
|
Format.fprintf fmt "(%a rem %a)" pp_val v1 pp_val v2
|
|
74 |
Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
|
| 46 |
75 |
|
| 47 |
76 |
(** Printing function for expressions [v1 div v2]. Depends on
|
| 48 |
77 |
option [integer_div_euclidean] to choose between mathematic
|
| 49 |
78 |
division or Ada division.
|
| 50 |
79 |
|
| 51 |
|
@param pp_val pretty printer for values
|
|
80 |
@param pp_value pretty printer for values
|
| 52 |
81 |
@param v1 the first value in the expression
|
| 53 |
82 |
@param v2 the second value in the expression
|
| 54 |
83 |
@param fmt the formater to print in
|
| 55 |
84 |
**)
|
| 56 |
|
let pp_div pp_val v1 v2 fmt =
|
|
85 |
let pp_div pp_value v1 v2 fmt =
|
| 57 |
86 |
if !Options.integer_div_euclidean then
|
| 58 |
87 |
(* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
|
| 59 |
88 |
Format.fprintf fmt "(%a - %t) / %a"
|
| 60 |
|
pp_val v1
|
| 61 |
|
(pp_mod pp_val v1 v2)
|
| 62 |
|
pp_val v2
|
| 63 |
|
else (* Ada behovior for / *)
|
| 64 |
|
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
|
|
89 |
pp_value v1
|
|
90 |
(pp_mod pp_value v1 v2)
|
|
91 |
pp_value v2
|
|
92 |
else (* Ada behavior for / *)
|
|
93 |
Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
|
| 65 |
94 |
|
| 66 |
95 |
(** Printing function for basic lib functions.
|
| 67 |
96 |
|
| 68 |
|
@param is_int boolean to choose between integer
|
| 69 |
|
division (resp. remainder) or Ada division
|
| 70 |
|
(resp. remainder)
|
|
97 |
@param pp_value pretty printer for values
|
| 71 |
98 |
@param i a string representing the function
|
| 72 |
|
@param pp_val the pretty printer for values
|
| 73 |
99 |
@param fmt the formater to print on
|
| 74 |
100 |
@param vl the list of operands
|
| 75 |
101 |
**)
|
| 76 |
|
let pp_basic_lib_fun is_int i pp_val fmt vl =
|
| 77 |
|
match i, vl with
|
| 78 |
|
| "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v
|
| 79 |
|
| "not", [v] -> Format.fprintf fmt "(not %a)" pp_val v
|
| 80 |
|
| "impl", [v1; v2] -> Format.fprintf fmt "(not %a or else %a)" pp_val v1 pp_val v2
|
| 81 |
|
| "=", [v1; v2] -> Format.fprintf fmt "(%a = %a)" pp_val v1 pp_val v2
|
| 82 |
|
| "mod", [v1; v2] ->
|
| 83 |
|
if is_int then
|
| 84 |
|
pp_mod pp_val v1 v2 fmt
|
| 85 |
|
else
|
| 86 |
|
Format.fprintf fmt "(%a rem %a)" pp_val v1 pp_val v2
|
| 87 |
|
| "equi", [v1; v2] -> Format.fprintf fmt "((not %a) = (not %a))" pp_val v1 pp_val v2
|
| 88 |
|
| "xor", [v1; v2] -> Format.fprintf fmt "((not %a) \\= (not %a))" pp_val v1 pp_val v2
|
| 89 |
|
| "/", [v1; v2] ->
|
| 90 |
|
if is_int then
|
| 91 |
|
pp_div pp_val v1 v2 fmt
|
| 92 |
|
else
|
| 93 |
|
Format.fprintf fmt "(%a / %a)" pp_val v1 pp_val v2
|
| 94 |
|
| _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2
|
| 95 |
|
| _ -> (Format.eprintf "internal compilation error: basic function %s@." i; assert false)
|
|
102 |
let pp_basic_lib_fun pp_value ident fmt vl =
|
|
103 |
match ident, vl with
|
|
104 |
| "uminus", [v] ->
|
|
105 |
Format.fprintf fmt "(- %a)" pp_value v
|
|
106 |
| "not", [v] ->
|
|
107 |
Format.fprintf fmt "(not %a)" pp_value v
|
|
108 |
| "impl", [v1; v2] ->
|
|
109 |
Format.fprintf fmt "(not %a or else %a)" pp_value v1 pp_value v2
|
|
110 |
| "=", [v1; v2] ->
|
|
111 |
Format.fprintf fmt "(%a = %a)" pp_value v1 pp_value v2
|
|
112 |
| "mod", [v1; v2] -> pp_mod pp_value v1 v2 fmt
|
|
113 |
| "equi", [v1; v2] ->
|
|
114 |
Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
|
|
115 |
| "xor", [v1; v2] ->
|
|
116 |
Format.fprintf fmt "((not %a) \\= (not %a))" pp_value v1 pp_value v2
|
|
117 |
| "/", [v1; v2] -> pp_div pp_value v1 v2 fmt
|
|
118 |
| op, [v1; v2] ->
|
|
119 |
Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
|
|
120 |
| fun_name, _ ->
|
|
121 |
(Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false)
|
|
122 |
|
|
123 |
(** Printing function for values.
|
|
124 |
|
|
125 |
@param fmt the formater to use
|
|
126 |
@param value the value to print. Should be a
|
|
127 |
{!type:Machine_code_types.value_t} value
|
|
128 |
**)
|
|
129 |
let rec pp_value fmt value =
|
|
130 |
match value.value_desc with
|
|
131 |
| Cst c -> pp_ada_const fmt c
|
|
132 |
| Var var_name -> pp_var_name fmt var_name
|
|
133 |
| Fun (f_ident, vl) -> pp_basic_lib_fun pp_value f_ident fmt vl
|
|
134 |
| _ ->
|
|
135 |
raise (Ada_not_supported
|
|
136 |
"unsupported: Ada_backend.adb.pp_value does not support this value type")
|
| 96 |
137 |
|
| 97 |
138 |
(** Printing function for basic assignement [var_name := value;].
|
| 98 |
139 |
|
| 99 |
|
@param pp_var pretty printer for variables
|
| 100 |
140 |
@param fmt the formater to print on
|
| 101 |
141 |
@param var_name the name of the variable
|
| 102 |
142 |
@param value the value to be assigned
|
| 103 |
143 |
**)
|
| 104 |
|
(* TODO remove pp_var *)
|
| 105 |
|
let pp_basic_assign pp_var fmt var_name value =
|
| 106 |
|
fprintf fmt "%a := %a;"
|
| 107 |
|
pp_var var_name
|
| 108 |
|
pp_var value
|
|
144 |
let pp_basic_assign fmt var_name value =
|
|
145 |
fprintf fmt "%a := %a"
|
|
146 |
pp_var_name var_name
|
|
147 |
pp_value value
|
| 109 |
148 |
|
| 110 |
149 |
(** Printing function for assignement. For the moment, only use
|
| 111 |
150 |
[pp_basic_assign] function.
|
| ... | ... | |
| 139 |
178 |
try
|
| 140 |
179 |
List.assoc instance machine.minstances
|
| 141 |
180 |
with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s:@." machine.mname.node_id instance; raise Not_found) in
|
| 142 |
|
fprintf fmt "%a(state.%s);"
|
|
181 |
fprintf fmt "%a(state.%s)"
|
| 143 |
182 |
pp_machine_reset_name (instance, (node, static))
|
| 144 |
183 |
instance
|
| 145 |
184 |
|
| ... | ... | |
| 156 |
195 |
(* no reset *)
|
| 157 |
196 |
| MNoReset _ -> ()
|
| 158 |
197 |
(* reset *)
|
| 159 |
|
| MReset i ->
|
| 160 |
|
pp_machine_reset machine fmt i
|
| 161 |
|
| MLocalAssign (i,v) ->
|
| 162 |
|
fprintf fmt "MLocalAssign @"
|
| 163 |
|
(* pp_basic_assign pp_var_name fmt i v *)
|
| 164 |
|
(* pp_assign
|
| 165 |
|
* machine self (pp_c_var_read m) fmt
|
| 166 |
|
* i.var_type (mk_val (Var i) i.var_type) v *)
|
|
198 |
| MReset ident ->
|
|
199 |
pp_machine_reset machine fmt ident
|
|
200 |
| MLocalAssign (ident, value) ->
|
|
201 |
pp_basic_assign fmt ident value
|
| 167 |
202 |
| MStateAssign (i,v) ->
|
| 168 |
203 |
fprintf fmt "MStateAssign"
|
| 169 |
204 |
(* pp_assign
|
Ada: pretty printing functions for values and assignments in adb