Revision c85c2e3d
Added by Christophe Garion over 4 years ago
| src/backends/Ada/ada_backend_adb.ml | ||
|---|---|---|
| 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 |
Also available in: Unified diff
Ada: pretty printing functions for values and assignments in adb