Revision a7062da6
Added by LĂ©lio Brun over 3 years ago
src/backends/Ada/ada_backend_common.ml | ||
---|---|---|
1 |
open Utils |
|
1 | 2 |
open Format |
2 | 3 |
open Machine_code_types |
3 | 4 |
open Lustre_types |
... | ... | |
73 | 74 |
|
74 | 75 |
(** Print a type. @param fmt the formater to print on @param type the type **) |
75 | 76 |
let pp_type fmt typ = |
76 |
match (Types.repr typ).Types.tdesc with |
|
77 |
| Types.Tbasic Types.Basic.Tint -> |
|
77 |
let open Types in |
|
78 |
let t = repr typ in |
|
79 |
if is_bool_type t then |
|
80 |
pp_boolean_type fmt |
|
81 |
else if is_int_type t then |
|
78 | 82 |
pp_integer_type fmt |
79 |
| Types.Tbasic Types.Basic.Treal ->
|
|
83 |
else if is_real_type t then
|
|
80 | 84 |
pp_float_type fmt |
81 |
| Types.Tbasic Types.Basic.Tbool -> |
|
82 |
pp_boolean_type fmt |
|
83 |
| Types.Tunivar -> |
|
84 |
pp_polymorphic_type typ.Types.tid fmt |
|
85 |
| Types.Tbasic _ -> |
|
86 |
eprintf "Tbasic@."; |
|
87 |
assert false (*TODO*) |
|
88 |
| Types.Tconst _ -> |
|
89 |
eprintf "Tconst@."; |
|
90 |
assert false (*TODO*) |
|
91 |
| Types.Tclock _ -> |
|
92 |
eprintf "Tclock@."; |
|
93 |
assert false (*TODO*) |
|
94 |
| Types.Tarrow _ -> |
|
95 |
eprintf "Tarrow@."; |
|
96 |
assert false (*TODO*) |
|
97 |
| Types.Ttuple l -> |
|
98 |
eprintf "Ttuple %a @." (Utils.fprintf_list ~sep:" " Types.print_ty) l; |
|
99 |
assert false (*TODO*) |
|
100 |
| Types.Tenum _ -> |
|
101 |
eprintf "Tenum@."; |
|
102 |
assert false (*TODO*) |
|
103 |
| Types.Tstruct _ -> |
|
104 |
eprintf "Tstruct@."; |
|
105 |
assert false (*TODO*) |
|
106 |
| Types.Tarray _ -> |
|
107 |
eprintf "Tarray@."; |
|
108 |
assert false (*TODO*) |
|
109 |
| Types.Tstatic _ -> |
|
110 |
eprintf "Tstatic@."; |
|
111 |
assert false (*TODO*) |
|
112 |
| Types.Tlink _ -> |
|
113 |
eprintf "Tlink@."; |
|
114 |
assert false (*TODO*) |
|
115 |
| Types.Tvar -> |
|
116 |
eprintf "Tvar@."; |
|
117 |
assert false |
|
85 |
else match t.tdesc with |
|
86 |
| Tunivar -> |
|
87 |
pp_polymorphic_type typ.tid fmt |
|
88 |
| Tbasic _ -> |
|
89 |
eprintf "Tbasic@."; |
|
90 |
assert false (*TODO*) |
|
91 |
| Tconst _ -> |
|
92 |
eprintf "Tconst@."; |
|
93 |
assert false (*TODO*) |
|
94 |
| Tclock _ -> |
|
95 |
eprintf "Tclock@."; |
|
96 |
assert false (*TODO*) |
|
97 |
| Tarrow _ -> |
|
98 |
eprintf "Tarrow@."; |
|
99 |
assert false (*TODO*) |
|
100 |
| Ttuple l -> |
|
101 |
eprintf "Ttuple %a @." (pp_print_list print_ty) l; |
|
102 |
assert false (*TODO*) |
|
103 |
| Tenum _ -> |
|
104 |
eprintf "Tenum@."; |
|
105 |
assert false (*TODO*) |
|
106 |
| Tstruct _ -> |
|
107 |
eprintf "Tstruct@."; |
|
108 |
assert false (*TODO*) |
|
109 |
| Tarray _ -> |
|
110 |
eprintf "Tarray@."; |
|
111 |
assert false (*TODO*) |
|
112 |
| Tstatic _ -> |
|
113 |
eprintf "Tstatic@."; |
|
114 |
assert false (*TODO*) |
|
115 |
| Tlink _ -> |
|
116 |
eprintf "Tlink@."; |
|
117 |
assert false (*TODO*) |
|
118 |
| Tvar -> |
|
119 |
eprintf "Tvar@."; |
|
120 |
assert false |
|
118 | 121 |
(*TODO*) |
119 | 122 |
(*| _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false *) |
120 | 123 |
|
121 | 124 |
(** Return a default ada constant for a given type. @param cst_typ the constant |
122 | 125 |
type **) |
123 |
let default_ada_cst cst_typ = |
|
124 |
match cst_typ with |
|
125 |
| Types.Basic.Tint -> |
|
126 |
let default_ada_cst t = |
|
127 |
let open Types in |
|
128 |
if is_bool_type t then |
|
129 |
Const_tag tag_false |
|
130 |
else if is_int_type t then |
|
126 | 131 |
Const_int 0 |
127 |
| Types.Basic.Treal ->
|
|
132 |
else if is_real_type t then
|
|
128 | 133 |
Const_real Real.zero |
129 |
| Types.Basic.Tbool -> |
|
130 |
Const_tag tag_false |
|
131 |
| _ -> |
|
134 |
else |
|
132 | 135 |
assert false |
133 | 136 |
|
134 | 137 |
(** Make a default value from a given type. @param typ the type **) |
135 | 138 |
let mk_default_value typ = |
136 |
match (Types.repr typ).Types.tdesc with |
|
137 |
| Types.Tbasic t -> |
|
139 |
let t = Types.repr typ in |
|
140 |
match t.Types.tdesc with |
|
141 |
| Types.Tbasic _ -> |
|
138 | 142 |
mk_val (Cst (default_ada_cst t)) typ |
139 | 143 |
| _ -> |
140 | 144 |
assert false |
... | ... | |
156 | 160 |
(fun poly1 (poly2, _) -> poly1 = poly2) |
157 | 161 |
polymorphic_types substituion); |
158 | 162 |
let instantiated_types = snd (List.split substitution) in |
159 |
fprintf fmt "%t%t%a" (pp_package_name machine) |
|
160 |
(Utils.pp_final_char_if_non_empty "_" instantiated_types) |
|
161 |
(Utils.fprintf_list ~sep:"_" pp_type) |
|
163 |
fprintf fmt "%t%a" |
|
164 |
(pp_package_name machine) |
|
165 |
(pp_print_list |
|
166 |
~pp_prologue:(fun fmt () -> pp_print_string fmt "_") |
|
167 |
~pp_sep:(fun fmt () -> pp_print_string fmt "_") |
|
168 |
pp_type) |
|
162 | 169 |
instantiated_types |
163 | 170 |
|
164 | 171 |
(** Print the name of a variable. @param fmt the formater to print on @param id |
Also available in: Unified diff
another step towards refactoring