## lustrec / src / tools / importer / mini_vhdl_to_lustre.ml @ 13872a54

History | View | Annotate | Download (18.5 KB)

1 | 1732ef44 | Arnaud Dieumegard | open Vhdl_ast |
---|---|---|---|

2 | open Vhdl_ast_pp |
||

3 | open Mini_vhdl_ast |
||

4 | open Vhdl_2_mini_vhdl_map |
||

5 | open Lustre_types |
||

6 | open Utils |
||

7 | |||

8 | |||

9 | class virtual mini_vhdl_to_lustre_map = |
||

10 | object (self) |
||

11 | inherit vhdl_2_mini_vhdl_map |
||

12 | 13872a54 | Arnaud Dieumegard | |

13 | 1732ef44 | Arnaud Dieumegard | method virtual list : 'a . ('a -> 'a) -> 'a list -> 'a list |

14 | 13872a54 | Arnaud Dieumegard | method virtual option : 'a . ('a -> 'a) -> 'a option -> 'a option |

15 | method virtual string : string -> string |
||

16 | |||

17 | method vhdl_type_t : vhdl_type_t -> vhdl_type_t= |
||

18 | fun x -> |
||

19 | match x with |
||

20 | | Base a -> let a = self#string a in Base a |
||

21 | | Range (a,b,c) -> |
||

22 | let a = self#option self#string a in |
||

23 | let b = self#int b in let c = self#int c in Range (a, b, c) |
||

24 | | Bit_vector (a,b) -> |
||

25 | let a = self#int a in let b = self#int b in Bit_vector (a, b) |
||

26 | | Array { indexes; const; definition } -> |
||

27 | let indexes = self#list self#vhdl_name_t indexes in |
||

28 | let const = self#option self#vhdl_constraint_t const in |
||

29 | let definition = self#vhdl_subtype_indication_t definition in |
||

30 | Array { indexes; const; definition } |
||

31 | | Record a -> |
||

32 | let a = self#list self#vhdl_element_declaration_t a in Record a |
||

33 | | Enumerated a -> |
||

34 | let a = self#list self#vhdl_name_t a in Enumerated a |
||

35 | | Void -> Void |
||

36 | |||

37 | method vhdl_element_declaration_t : |
||

38 | vhdl_element_declaration_t -> vhdl_element_declaration_t= |
||

39 | fun { names; definition } -> |
||

40 | let names = self#list self#vhdl_name_t names in |
||

41 | let definition = self#vhdl_subtype_indication_t definition in |
||

42 | { names; definition } |
||

43 | |||

44 | method vhdl_subtype_indication_t : |
||

45 | vhdl_subtype_indication_t -> vhdl_subtype_indication_t= |
||

46 | fun { name; functionName; const } -> |
||

47 | let name = self#vhdl_name_t name in |
||

48 | let functionName = self#vhdl_name_t functionName in |
||

49 | let const = self#vhdl_constraint_t const in |
||

50 | { name; functionName; const } |
||

51 | |||

52 | method vhdl_discrete_range_t : |
||

53 | vhdl_discrete_range_t -> vhdl_discrete_range_t= |
||

54 | fun x -> |
||

55 | match x with |
||

56 | | SubDiscreteRange a -> |
||

57 | let a = self#vhdl_subtype_indication_t a in SubDiscreteRange a |
||

58 | | NamedRange a -> let a = self#vhdl_name_t a in NamedRange a |
||

59 | | DirectedRange { direction; from; _to } -> |
||

60 | let direction = self#string direction in |
||

61 | let from = self#vhdl_expr_t from in |
||

62 | let _to = self#vhdl_expr_t _to in |
||

63 | DirectedRange { direction; from; _to } |
||

64 | |||

65 | method vhdl_constraint_t : vhdl_constraint_t -> vhdl_constraint_t= |
||

66 | fun x -> |
||

67 | match x with |
||

68 | | RefConstraint { ref_name } -> |
||

69 | let ref_name = self#vhdl_name_t ref_name in |
||

70 | RefConstraint { ref_name } |
||

71 | | RangeConstraint { range } -> |
||

72 | let range = self#vhdl_discrete_range_t range in |
||

73 | RangeConstraint { range } |
||

74 | | IndexConstraint { ranges } -> |
||

75 | let ranges = self#list self#vhdl_discrete_range_t ranges in |
||

76 | IndexConstraint { ranges } |
||

77 | | ArrayConstraint { ranges; sub } -> |
||

78 | let ranges = self#list self#vhdl_discrete_range_t ranges in |
||

79 | let sub = self#vhdl_constraint_t sub in |
||

80 | ArrayConstraint { ranges; sub } |
||

81 | | RecordConstraint -> RecordConstraint |
||

82 | | NoConstraint -> NoConstraint |
||

83 | |||

84 | method vhdl_definition_t : vhdl_definition_t -> vhdl_definition_t= |
||

85 | fun x -> |
||

86 | match x with |
||

87 | | Type { name; definition } -> |
||

88 | let name = self#vhdl_name_t name in |
||

89 | let definition = self#vhdl_type_t definition in |
||

90 | Type { name; definition } |
||

91 | | Subtype { name; typ } -> |
||

92 | let name = self#vhdl_name_t name in |
||

93 | let typ = self#vhdl_subtype_indication_t typ in |
||

94 | Subtype { name; typ } |
||

95 | |||

96 | method vhdl_expr_t : vhdl_expr_t -> vhdl_expr_t= |
||

97 | fun x -> |
||

98 | match x with |
||

99 | | Call a -> let a = self#vhdl_name_t a in Call a |
||

100 | | Cst { value; unit_name } -> |
||

101 | let value = self#vhdl_cst_val_t value in |
||

102 | let unit_name = self#option self#vhdl_name_t unit_name in |
||

103 | Cst { value; unit_name } |
||

104 | | Op { id; args } -> |
||

105 | let id = self#string id in |
||

106 | let args = self#list self#vhdl_expr_t args in Op { id; args } |
||

107 | | IsNull -> IsNull |
||

108 | | Time { value; phy_unit } -> |
||

109 | let value = self#int value in |
||

110 | let phy_unit = self#string phy_unit in Time { value; phy_unit } |
||

111 | | Sig { name; att } -> |
||

112 | let name = self#vhdl_name_t name in |
||

113 | let att = self#option self#vhdl_signal_attributes_t att in |
||

114 | Sig { name; att } |
||

115 | | SuffixMod { expr; selection } -> |
||

116 | let expr = self#vhdl_expr_t expr in |
||

117 | let selection = self#vhdl_suffix_selection_t selection in |
||

118 | SuffixMod { expr; selection } |
||

119 | | Aggregate { elems } -> |
||

120 | let elems = self#list self#vhdl_element_assoc_t elems in |
||

121 | Aggregate { elems } |
||

122 | | QualifiedExpression { type_mark; aggregate; expression } -> |
||

123 | let type_mark = self#vhdl_name_t type_mark in |
||

124 | let aggregate = self#list self#vhdl_element_assoc_t aggregate in |
||

125 | let expression = self#option self#vhdl_expr_t expression in |
||

126 | QualifiedExpression { type_mark; aggregate; expression } |
||

127 | | Others -> Others |
||

128 | |||

129 | method vhdl_name_t : vhdl_name_t -> vhdl_name_t= |
||

130 | fun x -> |
||

131 | match x with |
||

132 | | Simple a -> let a = self#string a in Simple a |
||

133 | | Identifier a -> let a = self#string a in Identifier a |
||

134 | | Selected a -> let a = self#list self#vhdl_name_t a in Selected a |
||

135 | | Index { id; exprs } -> |
||

136 | let id = self#vhdl_name_t id in |
||

137 | let exprs = self#list self#vhdl_expr_t exprs in |
||

138 | Index { id; exprs } |
||

139 | | Slice { id; range } -> |
||

140 | let id = self#vhdl_name_t id in |
||

141 | let range = self#vhdl_discrete_range_t range in |
||

142 | Slice { id; range } |
||

143 | | Attribute { id; designator; expr } -> |
||

144 | let id = self#vhdl_name_t id in |
||

145 | let designator = self#vhdl_name_t designator in |
||

146 | let expr = self#vhdl_expr_t expr in |
||

147 | Attribute { id; designator; expr } |
||

148 | | Function { id; assoc_list } -> |
||

149 | let id = self#vhdl_name_t id in |
||

150 | let assoc_list = self#list self#vhdl_assoc_element_t assoc_list |
||

151 | in |
||

152 | Function { id; assoc_list } |
||

153 | | Open -> Open |
||

154 | | NoName -> NoName |
||

155 | |||

156 | method vhdl_assoc_element_t : |
||

157 | vhdl_assoc_element_t -> vhdl_assoc_element_t= |
||

158 | fun |
||

159 | { formal_name; formal_arg; actual_name; actual_designator; |
||

160 | actual_expr } |
||

161 | -> |
||

162 | let formal_name = self#option self#vhdl_name_t formal_name in |
||

163 | let formal_arg = self#option self#vhdl_name_t formal_arg in |
||

164 | let actual_name = self#option self#vhdl_name_t actual_name in |
||

165 | let actual_designator = |
||

166 | self#option self#vhdl_name_t actual_designator in |
||

167 | let actual_expr = self#option self#vhdl_expr_t actual_expr in |
||

168 | { |
||

169 | formal_name; |
||

170 | formal_arg; |
||

171 | actual_name; |
||

172 | actual_designator; |
||

173 | actual_expr |
||

174 | } |
||

175 | |||

176 | method vhdl_element_assoc_t : |
||

177 | vhdl_element_assoc_t -> vhdl_element_assoc_t= |
||

178 | fun { choices; expr } -> |
||

179 | let choices = self#list self#vhdl_expr_t choices in |
||

180 | let expr = self#vhdl_expr_t expr in { choices; expr } |
||

181 | |||

182 | method vhdl_array_attributes_t : |
||

183 | vhdl_array_attributes_t -> vhdl_array_attributes_t= |
||

184 | fun x -> |
||

185 | match x with |
||

186 | | AAttInt { id; arg } -> |
||

187 | let id = self#string id in |
||

188 | let arg = self#int arg in AAttInt { id; arg } |
||

189 | | AAttAscending -> AAttAscending |
||

190 | |||

191 | method vhdl_signal_attributes_t : |
||

192 | vhdl_signal_attributes_t -> vhdl_signal_attributes_t= |
||

193 | fun x -> match x with | SigAtt a -> let a = self#string a in SigAtt a |
||

194 | |||

195 | method vhdl_string_attributes_t : |
||

196 | vhdl_string_attributes_t -> vhdl_string_attributes_t= |
||

197 | fun x -> |
||

198 | match x with | StringAtt a -> let a = self#string a in StringAtt a |
||

199 | |||

200 | method vhdl_suffix_selection_t : |
||

201 | vhdl_suffix_selection_t -> vhdl_suffix_selection_t= |
||

202 | fun x -> |
||

203 | match x with |
||

204 | | Idx a -> let a = self#int a in Idx a |
||

205 | | SuffixRange (a,b) -> |
||

206 | let a = self#int a in let b = self#int b in SuffixRange (a, b) |
||

207 | |||

208 | method mini_vhdl_sequential_stmt_t : |
||

209 | mini_vhdl_sequential_stmt_t -> mini_vhdl_sequential_stmt_t= |
||

210 | fun x -> |
||

211 | match x with |
||

212 | | VarAssign { label; lhs; rhs } -> |
||

213 | let label = self#option self#vhdl_name_t label in |
||

214 | let lhs = self#vhdl_name_t lhs in |
||

215 | let rhs = self#vhdl_expr_t rhs in VarAssign { label; lhs; rhs } |
||

216 | | SigSeqAssign { label; lhs; rhs } -> |
||

217 | let label = self#option self#vhdl_name_t label in |
||

218 | let lhs = self#vhdl_name_t lhs in |
||

219 | let rhs = self#list self#vhdl_waveform_element_t rhs in |
||

220 | SigSeqAssign { label; lhs; rhs } |
||

221 | | SigCondAssign { label; lhs; rhs; delay } -> |
||

222 | let label = self#option self#vhdl_name_t label in |
||

223 | let lhs = self#vhdl_name_t lhs in |
||

224 | let rhs = self#list self#vhdl_signal_condition_t rhs in |
||

225 | let delay = self#option self#vhdl_expr_t delay in |
||

226 | SigCondAssign { label; lhs; rhs; delay } |
||

227 | | SigSelectAssign { label; lhs; sel; branches; delay } -> |
||

228 | let label = self#option self#vhdl_name_t label in |
||

229 | let lhs = self#vhdl_name_t lhs in |
||

230 | let sel = self#vhdl_expr_t sel in |
||

231 | let branches = self#list self#vhdl_signal_selection_t branches |
||

232 | in |
||

233 | let delay = self#option self#vhdl_expr_t delay in |
||

234 | SigSelectAssign { label; lhs; sel; branches; delay } |
||

235 | | If { label; if_cases; default } -> |
||

236 | let label = self#option self#vhdl_name_t label in |
||

237 | let if_cases = self#list self#mini_vhdl_if_case_t if_cases in |
||

238 | let default = self#list self#mini_vhdl_sequential_stmt_t default |
||

239 | in |
||

240 | If { label; if_cases; default } |
||

241 | | Case { label; guard; branches } -> |
||

242 | let label = self#option self#vhdl_name_t label in |
||

243 | let guard = self#vhdl_expr_t guard in |
||

244 | let branches = self#list self#mini_vhdl_case_item_t branches in |
||

245 | Case { label; guard; branches } |
||

246 | | Exit { label; loop_label; condition } -> |
||

247 | let label = self#option self#vhdl_name_t label in |
||

248 | let loop_label = self#option self#string loop_label in |
||

249 | let condition = self#option self#vhdl_expr_t condition in |
||

250 | Exit { label; loop_label; condition } |
||

251 | | Assert { label; cond; report; severity } -> |
||

252 | let label = self#option self#vhdl_name_t label in |
||

253 | let cond = self#vhdl_expr_t cond in |
||

254 | let report = self#vhdl_expr_t report in |
||

255 | let severity = self#vhdl_expr_t severity in |
||

256 | Assert { label; cond; report; severity } |
||

257 | | ProcedureCall { label; name; assocs } -> |
||

258 | let label = self#option self#vhdl_name_t label in |
||

259 | let name = self#vhdl_name_t name in |
||

260 | let assocs = self#list self#vhdl_assoc_element_t assocs in |
||

261 | ProcedureCall { label; name; assocs } |
||

262 | | Wait -> Wait |
||

263 | | Null { label } -> |
||

264 | let label = self#option self#vhdl_name_t label in Null { label } |
||

265 | | Return { label; expr } -> |
||

266 | let label = self#option self#vhdl_name_t label in |
||

267 | let expr = self#option self#vhdl_expr_t expr in |
||

268 | Return { label; expr } |
||

269 | |||

270 | method mini_vhdl_if_case_t : mini_vhdl_if_case_t -> mini_vhdl_if_case_t= |
||

271 | fun { if_cond; if_block } -> |
||

272 | let if_cond = self#vhdl_expr_t if_cond in |
||

273 | let if_block = self#list self#mini_vhdl_sequential_stmt_t if_block |
||

274 | in |
||

275 | { if_cond; if_block } |
||

276 | |||

277 | method mini_vhdl_case_item_t : |
||

278 | mini_vhdl_case_item_t -> mini_vhdl_case_item_t= |
||

279 | fun { when_cond; when_stmt } -> |
||

280 | let when_cond = self#list self#vhdl_expr_t when_cond in |
||

281 | let when_stmt = self#list self#mini_vhdl_sequential_stmt_t when_stmt |
||

282 | in |
||

283 | { when_cond; when_stmt } |
||

284 | |||

285 | method mini_vhdl_declaration_t : |
||

286 | mini_vhdl_declaration_t -> mini_vhdl_declaration_t= |
||

287 | fun x -> |
||

288 | match x with |
||

289 | | VarDecl { names; typ; init_val } -> |
||

290 | let names = self#list self#vhdl_name_t names in |
||

291 | let typ = self#vhdl_subtype_indication_t typ in |
||

292 | let init_val = self#vhdl_expr_t init_val in |
||

293 | VarDecl { names; typ; init_val } |
||

294 | | CstDecl { names; typ; init_val } -> |
||

295 | let names = self#list self#vhdl_name_t names in |
||

296 | let typ = self#vhdl_subtype_indication_t typ in |
||

297 | let init_val = self#vhdl_expr_t init_val in |
||

298 | CstDecl { names; typ; init_val } |
||

299 | | SigDecl { names; typ; init_val } -> |
||

300 | let names = self#list self#vhdl_name_t names in |
||

301 | let typ = self#vhdl_subtype_indication_t typ in |
||

302 | let init_val = self#vhdl_expr_t init_val in |
||

303 | SigDecl { names; typ; init_val } |
||

304 | | ComponentDecl { name; generics; ports } -> |
||

305 | let name = self#vhdl_name_t name in |
||

306 | let generics = self#list self#vhdl_port_t generics in |
||

307 | let ports = self#list self#vhdl_port_t ports in |
||

308 | ComponentDecl { name; generics; ports } |
||

309 | | Subprogram { spec; decl_part; stmts } -> |
||

310 | let spec = self#vhdl_subprogram_spec_t spec in |
||

311 | let decl_part = self#list self#mini_vhdl_declaration_t decl_part |
||

312 | in |
||

313 | let stmts = self#list self#mini_vhdl_sequential_stmt_t stmts in |
||

314 | Subprogram { spec; decl_part; stmts } |
||

315 | |||

316 | method mini_vhdl_declarative_item_t : |
||

317 | mini_vhdl_declarative_item_t -> mini_vhdl_declarative_item_t= |
||

318 | fun { use_clause; declaration; definition } -> |
||

319 | let use_clause = self#option self#vhdl_load_t use_clause in |
||

320 | let declaration = |
||

321 | self#option self#mini_vhdl_declaration_t declaration in |
||

322 | let definition = self#option self#vhdl_definition_t definition in |
||

323 | { use_clause; declaration; definition } |
||

324 | 304640aa | Arnaud Dieumegard | |

325 | method mini_vhdl_process_t : mini_vhdl_process_t -> mini_vhdl_process_t= |
||

326 | 13872a54 | Arnaud Dieumegard | fun { id; declarations; active_sigs; body; postponed; label } -> |

327 | let id = self#vhdl_name_t id in |
||

328 | let declarations = |
||

329 | self#list self#mini_vhdl_declarative_item_t declarations in |
||

330 | let active_sigs = self#list self#vhdl_name_t active_sigs in |
||

331 | let body = self#list self#mini_vhdl_sequential_stmt_t body in |
||

332 | let postponed = self#bool postponed in |
||

333 | let label = self#option self#vhdl_name_t label in |
||

334 | { id; declarations; active_sigs; body; postponed; label } |
||

335 | 304640aa | Arnaud Dieumegard | |

336 | 1732ef44 | Arnaud Dieumegard | method mini_vhdl_component_instantiation_t : |

337 | mini_vhdl_component_instantiation_t -> statement= |
||

338 | fun { name; archi; entity; generic_map; port_map } -> |
||

339 | let name = self#vhdl_name_t name in |
||

340 | let archi = archi in |
||

341 | let entity = entity in |
||

342 | let generic_map = self#list self#vhdl_assoc_element_t generic_map in |
||

343 | let port_map = self#list self#vhdl_assoc_element_t port_map in |
||

344 | Eq {eq_lhs=[show_vhdl_name_t name]; |
||

345 | eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto"; |
||

346 | expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0}; |
||

347 | expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc}; |
||

348 | eq_loc=Location.dummy_loc} |
||

349 | |||

350 | method mini_vhdl_concurrent_stmt_t : |
||

351 | mini_vhdl_concurrent_stmt_t -> statement= |
||

352 | fun x -> |
||

353 | match x with |
||

354 | 304640aa | Arnaud Dieumegard | | Process a -> let a = self#mini_vhdl_process_t a in |

355 | 1732ef44 | Arnaud Dieumegard | Eq {eq_lhs=["Process"]; |

356 | eq_rhs={expr_tag=Utils.new_tag (); expr_desc=Expr_ident "toto"; |
||

357 | expr_type={tdesc=Tconst "cst"; tid=0}; expr_clock={cdesc=Cvar;cscoped=false;cid=0}; |
||

358 | expr_delay={ddesc=Dundef;did=0}; expr_annot=None; expr_loc=Location.dummy_loc}; |
||

359 | eq_loc=Location.dummy_loc} |
||

360 | | ComponentInst a -> |
||

361 | let a = self#mini_vhdl_component_instantiation_t a in a |
||

362 | |||

363 | 304640aa | Arnaud Dieumegard | method mini_vhdl_package_t : mini_vhdl_package_t -> top_decl_desc= |

364 | 1732ef44 | Arnaud Dieumegard | fun { name; shared_defs; shared_decls; shared_uses } -> |

365 | let name = self#vhdl_name_t name in |
||

366 | let shared_defs = self#list self#vhdl_definition_t shared_defs in |
||

367 | 304640aa | Arnaud Dieumegard | let shared_decls = List.map self#mini_vhdl_declaration_t shared_decls in |

368 | 1732ef44 | Arnaud Dieumegard | let shared_uses = self#list self#vhdl_load_t shared_uses in |

369 | let node_id = show_vhdl_name_t name in |
||

370 | let node_type = Types.new_var () in |
||

371 | let node_clock = Clocks.new_ck Cvar false in |
||

372 | Node { node_id; node_type; node_clock; |
||

373 | node_inputs=[]; node_outputs = []; node_locals = []; |
||

374 | node_gencalls = []; node_checks = []; node_asserts = []; |
||

375 | node_stmts = []; node_dec_stateless = false; node_stateless = None; |
||

376 | node_spec = None; node_annot = [] } |
||

377 | |||

378 | method mini_vhdl_component_t : |
||

379 | mini_vhdl_component_t -> top_decl_desc= |
||

380 | fun |
||

381 | { names; generics; ports; contexts; declarations; definitions; body } |
||

382 | -> |
||

383 | let names = self#list self#vhdl_name_t names in |
||

384 | let generics = self#list self#vhdl_port_t generics in |
||

385 | let ports = self#list self#vhdl_port_t ports in |
||

386 | let contexts = self#list self#vhdl_load_t contexts in |
||

387 | 304640aa | Arnaud Dieumegard | let declarations = List.map self#mini_vhdl_declaration_t declarations in |

388 | 1732ef44 | Arnaud Dieumegard | let definitions = self#list self#vhdl_definition_t definitions in |

389 | let body = List.map self#mini_vhdl_concurrent_stmt_t body in |
||

390 | let node_id = String.concat "__" (List.map show_vhdl_name_t names) in |
||

391 | let node_type = Types.new_var () in |
||

392 | let node_clock = Clocks.new_ck Cvar false in |
||

393 | Node { node_id; node_type; node_clock; |
||

394 | node_inputs=[]; node_outputs = []; node_locals = []; |
||

395 | node_gencalls = []; node_checks = []; node_asserts = []; |
||

396 | node_stmts = body; node_dec_stateless = false; node_stateless = None; |
||

397 | node_spec = None; node_annot = [] } |
||

398 | |||

399 | method mini_vhdl_design_file_t : |
||

400 | mini_vhdl_design_file_t -> program = |
||

401 | fun { components; packages } -> |
||

402 | let components = List.map self#mini_vhdl_component_t components in |
||

403 | let packages = List.map self#mini_vhdl_package_t packages in |
||

404 | let desc x = { top_decl_desc = x; top_decl_owner = ""; top_decl_itf = false; top_decl_loc = Location.dummy_loc } in |
||

405 | let desc1 = List.map desc components in |
||

406 | let desc2 = List.map desc packages in |
||

407 | desc1 @ desc2 |
||

408 | end |