Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_ast.ml @ 8f9ce6d4

History | View | Annotate | Download (13 KB)

1
(* source: Synario VHDL Reference Manual - March 1997 *)
2

    
3
(************************************************************************************)		   
4
(*                       Types                                                      *)
5
(************************************************************************************)		   
6
let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
7

    
8
type vhdl_type_t =
9
  | Base of string
10
  | Range of string option * int * int
11
  | Bit_vector of int * int			  
12
  | Array of int * int * vhdl_type_t 
13
  | Enumerated of string list
14
  
15
let rec pp_vhdl_type fmt t =
16
  match t with
17
  | Base s -> Format.fprintf fmt "%s" s 
18
  | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
19
  | Range(base, n, m) -> Format.fprintf fmt "%trange %i to %i" (fun fmt -> match base with Some s -> Format.fprintf fmt "%s " s | None -> ()) n m
20
  | Array (n, m, base) -> Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
21
  | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
22

    
23

    
24

    
25
(************************************************************************************)		   
26
(*                     Constants                                                    *)
27
(************************************************************************************)		   
28

    
29
(* Std_logic values :
30
    'U': uninitialized. This signal hasn't been set yet.
31
    'X': unknown. Impossible to determine this value/result.
32
    '0': logic 0
33
    '1': logic 1
34
    'Z': High Impedance
35
    'W': Weak signal, can't tell if it should be 0 or 1.
36
    'L': Weak signal that should probably go to 0
37
    'H': Weak signal that should probably go to 1
38
    '-': Don't care. *)			       
39
let std_logic_cst = ["U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
40

    
41
(* TODO: do we need more constructors ? *)
42
type cst_val_t = CstInt of int | CstStdLogic of string
43

    
44
let pp_cst_val fmt c =
45
  match c with
46
  | CstInt i -> Format.fprintf fmt "%i" i
47
  | CstStdLogic s -> if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
48

    
49
(************************************************************************************)		   
50
(*                     Declarations                                                 *)
51
(************************************************************************************)		   
52

    
53

    
54
(* TODO ? Shall we merge definition / declaration  *)
55
type vhdl_definition_t =
56
  | Type of {name : string ; definition: vhdl_type_t}
57
  | Subtype of {name : string ; definition: vhdl_type_t}
58
					
59
let pp_vhdl_definition fmt def =
60
  match def with
61
  | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
62
  | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
63
		      
64
type vhdl_declaration_t =
65
  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
66
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t  }
67
  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
68

    
69
let pp_vhdl_declaration fmt decl =
70
  match decl with
71
  | VarDecl v -> Format.fprintf
72
		   fmt
73
		   "variable %s : %a%t;"
74
		   v.name
75
		   pp_vhdl_type v.typ
76
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
77
  | CstDecl v -> Format.fprintf
78
		   fmt
79
		   "constant %s : %a := %a;"
80
		   v.name
81
		   pp_vhdl_type v.typ
82
		   pp_cst_val v.init_val
83
  | SigDecl v -> Format.fprintf
84
		   fmt
85
		   "signal %s : %a%t;"
86
		   v.name
87
		   pp_vhdl_type v.typ
88
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv | _ -> ())
89

    
90

    
91
(************************************************************************************)		   
92
(*            Attributes for types, arrays, signals and strings                     *)
93
(************************************************************************************)		   
94

    
95
type 'basetype vhdl_type_attributes_t =
96
  | TAttNoArg of { id: string }
97
  | TAttIntArg of { id: string; arg: int }
98
  | TAttValArg of { id: string; arg: 'basetype }
99
  | TAttStringArg of { id: string; arg: string }
100

    
101
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
102
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
103
let typ_att_valarg = ["image"]
104
let typ_att_stringarg = ["value"]
105
  
106
let pp_type_attribute pp_val fmt tatt =
107
  match tatt with
108
  | TAttNoArg a -> Format.fprintf fmt "'%s" a.id
109
  | TAttIntArg a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
110
  | TAttValArg a -> Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
111
  | TAttStringArg a -> Format.fprintf fmt "'%s(%s)" a.id a.arg
112

    
113
type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
114
let pp_array_attribute fmt aatt =
115
  match aatt with
116
  | AAttInt a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
117
  | AAttAscending -> Format.fprintf fmt "'ascending"
118
let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]  
119

    
120
type vhdl_signal_attributes_t = SigAtt of string
121
let pp_signal_attribute fmt sa = match sa with
122
  | SigAtt s -> Format.fprintf fmt "'%s" s
123
let signal_att = [ "event"; "stable"; "last_value" ]
124

    
125
type vhdl_string_attributes_t = StringAtt of string
126
let pp_signal_attribute fmt sa = match sa with
127
  | StringAtt s -> Format.fprintf fmt "'%s" s
128
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
129

    
130
(************************************************************************************)		   
131
(*                        Expressions  / Statements                                 *)
132
(************************************************************************************)		   
133

    
134
			      
135
(* TODO: call to functions? procedures? *)  
136
type vhdl_expr_t =
137
  | Var of string (* a signal or a variable *)
138
  | Op of { id: string; args: vhdl_expr_t list } 
139
					     
140
let rec pp_vhdl_expr fmt e =
141
  match e with
142
  | Var s -> Format.fprintf fmt "%s" s
143
  | Op op -> (
144
    match op.args with
145
    | [] -> assert false
146
    | _ -> Format.fprintf fmt "%s (%a)" op.id (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args
147
  )
148

    
149
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
150
let bool_funs  = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
151
let rel_funs   = ["<";">";"<=";">=";"/=";"="]
152
  
153
		   
154

    
155

    
156
type vhdl_sequential_stmt_t = 
157
  | VarAssign of { lhs: string; rhs: vhdl_expr_t }
158
(*  | Case of { guard: vhdl_expr_t; branches: { case: }
159
	    | Case of { guard: vhdl_expr_t; branches 
160
 *)
161

    
162
let pp_vhdl_sequential_stmt fmt stmt =
163
  match stmt with
164
  | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
165
				    
166
type signal_condition_t =
167
  {                            
168
    expr: vhdl_expr_t;              (* when expression *)
169
    else_case: vhdl_expr_t option;  (* optional else case expression. 
170
                                             If None, could be a latch  *)
171
  }
172

    
173
type signal_selection_t =
174
  {
175
    sel_lhs: string;
176
    expr : vhdl_expr_t;
177
    when_sel: vhdl_expr_t option;
178
  }
179

    
180
type conditional_signal_t =
181
  {
182
      lhs: string;                        (* assigned signal *)
183
      rhs: vhdl_expr_t;                   (* expression *)
184
      cond: signal_condition_t option     (* conditional signal statement *)
185
  }
186

    
187
type process_t =
188
  { id: string option; active_sigs: string list; body: vhdl_sequential_stmt_t list }
189

    
190
type selected_signal_t = { sel: vhdl_expr_t;  branches: signal_selection_t list }
191
			   
192
type vhdl_concurrent_stmt_t =
193
  | SigAssign of conditional_signal_t 
194
  | Process of process_t 
195
  | SelectedSig of selected_signal_t
196
  (*
197
type vhdl_statement_t =
198
  
199
  (* | DeclarationStmt of declaration_stmt_t *)
200
  | ConcurrentStmt of vhdl_concurrent_stmt_t
201
  | SequentialStmt of vhdl_sequential_stmt_t
202
   *)
203
		     
204
let pp_vhdl_concurrent_stmt fmt stmt =
205
  let pp_sig_cond fmt va = 
206
    Format.fprintf
207
      fmt
208
      "%s <= %a%t;"
209
      va.lhs
210
      pp_vhdl_expr va.rhs
211
      (fun fmt -> match va.cond with
212
		  | None -> ()
213
		  | Some cond ->
214
		     Format.fprintf
215
		       fmt
216
		       " when %a%t"
217
		       pp_vhdl_expr cond.expr
218
		       (fun fmt -> match cond.else_case with
219
				   | None -> ()
220
				   | Some else_case ->
221
				      Format.fprintf
222
					fmt
223
					" else %a"
224
					pp_vhdl_expr else_case
225
		       )
226
      )
227
  in
228
  let pp_process fmt p =
229
    Format.fprintf
230
      fmt
231
      "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
232
      (fun fmt -> match p.id with Some id -> Format.fprintf fmt "%s: " id| None -> ())
233
      (fun fmt asigs ->
234
       if asigs <> [] then
235
	 Format.fprintf
236
	   fmt
237
	   "(@[<hov 0>%a)@]"
238
	   (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)
239
      p.active_sigs
240
      (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body
241
  in
242
  let pp_sig_sel fmt va =
243
    Format.fprintf fmt "@[<v 3>with %a select@ %a;@]"
244
		   pp_vhdl_expr va.sel
245
		   (Utils.fprintf_list
246
		      ~sep:"@ "
247
		      (fun fmt b ->
248
		       Format.fprintf
249
			 fmt
250
			 "%s <= %a when %t"
251
			 b.sel_lhs
252
			 pp_vhdl_expr b.expr
253
			 (fun fmt -> match b.when_sel with
254
				     | None -> Format.fprintf fmt "others"
255
				     | Some w -> pp_vhdl_expr fmt w
256
			 ))
257
		   ) va.branches  in
258
  match stmt with
259
  | SigAssign va -> pp_sig_cond fmt va       
260
  | Process p -> pp_process fmt p
261
  | SelectedSig va -> pp_sig_sel fmt va
262
 
263

    
264
  
265
       
266

    
267

    
268

    
269
(************************************************************************************)		   
270
(*                     Entities                                                     *)
271
(************************************************************************************)		   
272
			     
273
(* TODO? Seems to appear optionally in entities *)
274
type vhdl_generic_t = unit
275
let pp_vhdl_generic fmt g = ()
276

    
277
			      
278
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
279
let pp_vhdl_port_kind fmt p =
280
  match p with
281
  | InPort -> Format.fprintf fmt "in"
282
  | OutPort -> Format.fprintf fmt "in"
283
  | InoutPort -> Format.fprintf fmt "inout"
284
  | BufferPort -> Format.fprintf fmt "buffer"
285

    
286
		     
287
type vhdl_port_t =
288
  {
289
    name: string;
290
    kind: vhdl_port_kind_t;
291
    typ: vhdl_type_t;
292
  }
293

    
294
let pp_vhdl_port fmt p =
295
  Format.fprintf fmt "%s : %a %a"
296
		 p.name
297
		 pp_vhdl_port_kind p.kind
298
		 pp_vhdl_type p.typ
299
	 
300
			     
301
type vhdl_entity_t =
302
  {
303
    name: string;
304
    generics: vhdl_generic_t list;
305
    ports: vhdl_port_t list;
306
  }
307
let pp_vhdl_entity fmt e =
308
  Format.fprintf
309
    fmt
310
    "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "
311
    e.name
312
    (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)
313
    (fun fmt ->
314
     if e.ports = [] then () else
315
       Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:",@ " pp_vhdl_port) e.ports)
316
    e.name
317

    
318

    
319

    
320

    
321
(************************************************************************************)		   
322
(*                    Packages / Library loading                                    *)
323
(************************************************************************************)		   
324

    
325
				
326
				
327
(* Optional. Describes shared definitions *)
328
type vhdl_package_t =
329
  {
330
    name: string;
331
    shared_defs: vhdl_definition_t list;
332
  }
333

    
334
let pp_vhdl_package fmt p =
335
  Format.fprintf
336
    fmt
337
    "@[<v 3>package %s is@ %a@]@ end %s;@ "
338
    p.name
339
    (Utils.fprintf_list  ~sep:"@ " pp_vhdl_definition) p.shared_defs
340
    p.name
341

    
342
type vhdl_load_t = Library of string | Use of string list
343
let pp_vhdl_load fmt l =
344
  match l with
345
  | Library s -> Format.fprintf fmt "library %s;@ " s
346
  | Use sl -> Format.fprintf fmt "use %a;@ " (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl
347

    
348

    
349
(************************************************************************************)		   
350
(*                        Architecture / VHDL Design                                *)
351
(************************************************************************************)		   
352
				       
353
				       
354
type vhdl_architecture_t =
355
  {
356
    name: string;
357
    entity: string;
358
    declarations: vhdl_declaration_t list;
359
    body: vhdl_concurrent_stmt_t list;
360
  }
361
    
362
let pp_vhdl_architecture fmt a =
363
  Format.fprintf
364
    fmt
365
    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s"
366
    a.name
367
    a.entity
368
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration) a.declarations
369
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt) a.body
370
    a.name
371
    
372

    
373
(* TODO. Configuraiton is optional *)
374
type vhdl_configuration_t = unit
375
let pp_vhdl_configuration fmt c = ()
376

    
377

    
378

    
379
type vhdl_design_t =
380
  {
381
    packages: vhdl_package_t list;
382
    libraries: vhdl_load_t list;
383
    entities: vhdl_entity_t list;
384
    architectures: vhdl_architecture_t list;
385
    configuration: vhdl_configuration_t option;
386
  }
387

    
388
let pp_vhdl_design fmt d =
389
  Format.fprintf
390
    fmt
391
    "@[<v 0>%a%t%a%t%a%t%a%t@]"
392
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package) d.packages
393
    (fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
394
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries
395
    (fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
396
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities
397
    (fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
398
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures
399
    (fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")