Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

src/backends/VHDL/vhdl_ast.ml
1 1
(* source: Synario VHDL Reference Manual - March 1997 *)
2 2

  
3
(************************************************************************************)		   
4
(*                       Types                                                      *)
5
(************************************************************************************)		   
6
let base_types = ["integer"; "character"; "bit"; "real"; "natural"; "positive"; "std_logic"; "std_logic_vector" ]
3
(************************************************************************************)
4
(* Types *)
5
(************************************************************************************)
6
let base_types =
7
  [
8
    "integer";
9
    "character";
10
    "bit";
11
    "real";
12
    "natural";
13
    "positive";
14
    "std_logic";
15
    "std_logic_vector";
16
  ]
7 17

  
8 18
type vhdl_type_t =
9 19
  | Base of string
10 20
  | Range of string option * int * int
11
  | Bit_vector of int * int			  
12
  | Array of int * int * vhdl_type_t 
21
  | Bit_vector of int * int
22
  | Array of int * int * vhdl_type_t
13 23
  | Enumerated of string list
14
  
24

  
15 25
let rec pp_vhdl_type fmt t =
16 26
  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"; "-" ]
27
  | Base s ->
28
    Format.fprintf fmt "%s" s
29
  | Bit_vector (n, m) ->
30
    Format.fprintf fmt "bit_vector(%i downto %i)" n m
31
  | Range (base, n, m) ->
32
    Format.fprintf fmt "%trange %i to %i"
33
      (fun fmt ->
34
        match base with Some s -> Format.fprintf fmt "%s " s | None -> ())
35
      n m
36
  | Array (n, m, base) ->
37
    Format.fprintf fmt "array (%i to %i) of %a" n m pp_vhdl_type base
38
  | Enumerated sl ->
39
    Format.fprintf fmt "(%a)"
40
      (Utils.fprintf_list ~sep:", " Format.pp_print_string)
41
      sl
42

  
43
(************************************************************************************)
44
(* Constants *)
45
(************************************************************************************)
46

  
47
(* Std_logic values : 'U': uninitialized. This signal hasn't been set yet. 'X':
48
   unknown. Impossible to determine this value/result. '0': logic 0 '1': logic 1
49
   'Z': High Impedance 'W': Weak signal, can't tell if it should be 0 or 1. 'L':
50
   Weak signal that should probably go to 0 'H': Weak signal that should
51
   probably go to 1 '-': Don't care. *)
52
let std_logic_cst = [ "U"; "X"; "0"; "1"; "Z"; "W"; "L"; "H"; "-" ]
40 53

  
41 54
(* TODO: do we need more constructors ? *)
42
type cst_val_t = CstInt of int | CstStdLogic of string | CstBV of string * string
55
type cst_val_t =
56
  | CstInt of int
57
  | CstStdLogic of string
58
  | CstBV of string * string
43 59

  
44 60
let pp_cst_val fmt c =
45 61
  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
  | CstBV (pref,suff) -> Format.fprintf fmt "%s\"%s\"" pref suff
49

  
50
(************************************************************************************)		   
51
(*                     Declarations                                                 *)
52
(************************************************************************************)		   
62
  | CstInt i ->
63
    Format.fprintf fmt "%i" i
64
  | CstStdLogic s ->
65
    if List.mem s std_logic_cst then Format.fprintf fmt "%s" s else assert false
66
  | CstBV (pref, suff) ->
67
    Format.fprintf fmt "%s\"%s\"" pref suff
53 68

  
69
(************************************************************************************)
70
(* Declarations *)
71
(************************************************************************************)
54 72

  
55 73
(* TODO ? Shall we merge definition / declaration ? Do they appear at the same
56
place or at different ones ? *)
74
   place or at different ones ? *)
57 75
type vhdl_definition_t =
58
  | Type of {name : string ; definition: vhdl_type_t}
59
  | Subtype of {name : string ; definition: vhdl_type_t}
60
					
76
  | Type of { name : string; definition : vhdl_type_t }
77
  | Subtype of { name : string; definition : vhdl_type_t }
78

  
61 79
let pp_vhdl_definition fmt def =
62 80
  match def with
63
  | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
64
  | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
65
		      
81
  | Type s ->
82
    Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
83
  | Subtype s ->
84
    Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
85

  
66 86
type vhdl_declaration_t =
67 87
  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
68
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t  }
88
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t }
69 89
  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
70 90

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

  
92

  
93
(************************************************************************************)		   
94
(*            Attributes for types, arrays, signals and strings                     *)
95
(************************************************************************************)		   
93
  | VarDecl v ->
94
    Format.fprintf fmt "variable %s : %a%t;" v.name pp_vhdl_type v.typ
95
      (fun fmt ->
96
        match v.init_val with
97
        | Some initv ->
98
          Format.fprintf fmt " := %a" pp_cst_val initv
99
        | _ ->
100
          ())
101
  | CstDecl v ->
102
    Format.fprintf fmt "constant %s : %a := %a;" v.name pp_vhdl_type v.typ
103
      pp_cst_val v.init_val
104
  | SigDecl v ->
105
    Format.fprintf fmt "signal %s : %a%t;" v.name pp_vhdl_type v.typ (fun fmt ->
106
        match v.init_val with
107
        | Some initv ->
108
          Format.fprintf fmt " := %a" pp_cst_val initv
109
        | _ ->
110
          ())
111

  
112
(************************************************************************************)
113
(* Attributes for types, arrays, signals and strings *)
114
(************************************************************************************)
96 115

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

  
103
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
104
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
105
let typ_att_valarg = ["image"]
106
let typ_att_stringarg = ["value"]
107
  
117
  | TAttNoArg of { id : string }
118
  | TAttIntArg of { id : string; arg : int }
119
  | TAttValArg of { id : string; arg : 'basetype }
120
  | TAttStringArg of { id : string; arg : string }
121

  
122
let typ_att_noarg = [ "base"; "left"; "right"; "high"; "low" ]
123

  
124
let typ_att_intarg = [ "pos"; "val"; "succ"; "pred"; "leftof"; "rightof" ]
125

  
126
let typ_att_valarg = [ "image" ]
127

  
128
let typ_att_stringarg = [ "value" ]
129

  
108 130
let pp_type_attribute pp_val fmt tatt =
109 131
  match tatt with
110
  | TAttNoArg a -> Format.fprintf fmt "'%s" a.id
111
  | TAttIntArg a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
112
  | TAttValArg a -> Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
113
  | TAttStringArg a -> Format.fprintf fmt "'%s(%s)" a.id a.arg
132
  | TAttNoArg a ->
133
    Format.fprintf fmt "'%s" a.id
134
  | TAttIntArg a ->
135
    Format.fprintf fmt "'%s(%i)" a.id a.arg
136
  | TAttValArg a ->
137
    Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
138
  | TAttStringArg a ->
139
    Format.fprintf fmt "'%s(%s)" a.id a.arg
140

  
141
type vhdl_array_attributes_t =
142
  | AAttInt of { id : string; arg : int }
143
  | AAttAscending
114 144

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

  
152
let array_att_intarg =
153
  [ "left"; "right"; "high"; "low"; "range"; "reverse_range"; "length" ]
121 154

  
122 155
type vhdl_signal_attributes_t = SigAtt of string
123
let pp_signal_attribute fmt sa = match sa with
124
  | SigAtt s -> Format.fprintf fmt "'%s" s
156

  
157
let pp_signal_attribute fmt sa =
158
  match sa with SigAtt s -> Format.fprintf fmt "'%s" s
159

  
125 160
let signal_att = [ "event"; "stable"; "last_value" ]
126 161

  
127 162
type vhdl_string_attributes_t = StringAtt of string
128
let pp_string_attribute fmt sa = match sa with
129
  | StringAtt s -> Format.fprintf fmt "'%s" s
163

  
164
let pp_string_attribute fmt sa =
165
  match sa with StringAtt s -> Format.fprintf fmt "'%s" s
166

  
130 167
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
131 168

  
132
(************************************************************************************)		   
133
(*                        Expressions  / Statements                                 *)
134
(************************************************************************************)		   
169
(************************************************************************************)
170
(* Expressions / Statements *)
171
(************************************************************************************)
135 172

  
136
			      
137 173
(* TODO: call to functions? procedures? component instanciations ? *)
138 174

  
139 175
type suffix_selection_t = Idx of int | Range of int * int
176

  
140 177
let pp_suffix_selection fmt sel =
141 178
  match sel with
142
  | Idx n -> Format.fprintf fmt "(%i)" n
143
  | Range(n,m) -> Format.fprintf fmt "(%i downto %i)" n m
144
							
179
  | Idx n ->
180
    Format.fprintf fmt "(%i)" n
181
  | Range (n, m) ->
182
    Format.fprintf fmt "(%i downto %i)" n m
183

  
145 184
type vhdl_expr_t =
146
  | Cst of cst_val_t 
147
  | Var of string (* a signal or a variable *)
148
  | Sig of { name: string; att: vhdl_signal_attributes_t option }
185
  | Cst of cst_val_t
186
  | Var of string
187
  (* a signal or a variable *)
188
  | Sig of { name : string; att : vhdl_signal_attributes_t option }
149 189
  | SuffixMod of { expr : vhdl_expr_t; selection : suffix_selection_t }
150
  | Op of { id: string; args: vhdl_expr_t list } 
151
					     
190
  | Op of { id : string; args : vhdl_expr_t list }
191

  
152 192
let rec pp_vhdl_expr fmt e =
153 193
  match e with
154
  | Cst c ->  pp_cst_val fmt c
155
  | Var s -> Format.fprintf fmt "%s" s
156
  | Sig s -> Format.fprintf
157
	       fmt
158
	       "%s%t"
159
	       s.name
160
	       (fun fmt -> match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
194
  | Cst c ->
195
    pp_cst_val fmt c
196
  | Var s ->
197
    Format.fprintf fmt "%s" s
198
  | Sig s ->
199
    Format.fprintf fmt "%s%t" s.name (fun fmt ->
200
        match s.att with None -> () | Some att -> pp_signal_attribute fmt att)
161 201
  | SuffixMod s ->
162
     Format.fprintf fmt "%a %a"
163
		    pp_vhdl_expr s.expr
164
		    pp_suffix_selection s.selection
202
    Format.fprintf fmt "%a %a" pp_vhdl_expr s.expr pp_suffix_selection
203
      s.selection
165 204
  | Op op -> (
166 205
    match op.args with
167
    | [] -> assert false
168
    | [ e1; e2] -> Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id pp_vhdl_expr e2
169
    | _ -> assert false (* all ops are binary up to now *)
170
    (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *)
171
  )
206
    | [] ->
207
      assert false
208
    | [ e1; e2 ] ->
209
      Format.fprintf fmt "@[<hov 3>%a %s %a@]" pp_vhdl_expr e1 op.id
210
        pp_vhdl_expr e2
211
    | _ ->
212
      assert false
213
      (* all ops are binary up to now *)
214
      (* | _ -> Format.fprintf fmt "@[<hov 3>%s (%a)@]" op.id
215
         (Utils.fprintf_list ~sep:",@ " pp_vhdl_expr) op.args *))
172 216

  
173 217
(* Available operators in the standard library. There are some restrictions on
174
types. See reference doc. *)
175
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
176
let bool_funs  = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
177
let rel_funs   = ["<";">";"<=";">=";"/=";"="]
218
   types. See reference doc. *)
219
let arith_funs = [ "+"; "-"; "*"; "/"; "mod"; "rem"; "abs"; "**" ]
220

  
221
let bool_funs = [ "and"; "or"; "nand"; "nor"; "xor"; "not" ]
222

  
223
let rel_funs = [ "<"; ">"; "<="; ">="; "/="; "=" ]
178 224

  
179
			  
180 225
type vhdl_if_case_t = {
181
    if_cond: vhdl_expr_t;
182
    if_block: vhdl_sequential_stmt_t list;
183
  }	   
184
 and vhdl_sequential_stmt_t = 
185
   | VarAssign of { lhs: string; rhs: vhdl_expr_t }
186
   | SigSeqAssign of { lhs: string; rhs: vhdl_expr_t }
187
   | If of { if_cases: vhdl_if_case_t list;
188
	    default: (vhdl_sequential_stmt_t list) option; }
189
   | Case of { guard: vhdl_expr_t; branches: vhdl_case_item_t list }
226
  if_cond : vhdl_expr_t;
227
  if_block : vhdl_sequential_stmt_t list;
228
}
229

  
230
and vhdl_sequential_stmt_t =
231
  | VarAssign of { lhs : string; rhs : vhdl_expr_t }
232
  | SigSeqAssign of { lhs : string; rhs : vhdl_expr_t }
233
  | If of {
234
      if_cases : vhdl_if_case_t list;
235
      default : vhdl_sequential_stmt_t list option;
236
    }
237
  | Case of { guard : vhdl_expr_t; branches : vhdl_case_item_t list }
238

  
190 239
and vhdl_case_item_t = {
191
    when_cond: vhdl_expr_t;
192
    when_stmt: vhdl_sequential_stmt_t;
193
  }
240
  when_cond : vhdl_expr_t;
241
  when_stmt : vhdl_sequential_stmt_t;
242
}
194 243

  
195
					    
196
		 
197 244
let rec pp_vhdl_sequential_stmt fmt stmt =
198 245
  match stmt with
199
  | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
200
  | SigSeqAssign va -> Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
201
  | If ifva -> (
202
     List.iteri (fun idx ifcase ->
203
		 if idx = 0 then
204
		   Format.fprintf fmt "@[<v 3>if"
205
		 else
206
		   Format.fprintf fmt "@ @[<v 3>elsif";
207
		 Format.fprintf fmt " %a then@ %a@]"
208
				pp_vhdl_expr ifcase.if_cond
209
				pp_vhdl_sequential_stmts ifcase.if_block
210
		) ifva.if_cases;
211
     let _ =
212
       match ifva.default with
213
       | None -> ()
214
       | Some bl -> Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
215
     in
216
     Format.fprintf fmt "@ end if;"
217
  )
218
  | Case caseva -> (
219
    Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;"
220
		   pp_vhdl_expr caseva.guard
221
		   (Utils.fprintf_list ~sep:"@ " pp_vhdl_case) caseva.branches
222
  )
223

  
224
     
225
and pp_vhdl_sequential_stmts fmt l  = Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
246
  | VarAssign va ->
247
    Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
248
  | SigSeqAssign va ->
249
    Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
250
  | If ifva ->
251
    List.iteri
252
      (fun idx ifcase ->
253
        if idx = 0 then Format.fprintf fmt "@[<v 3>if"
254
        else Format.fprintf fmt "@ @[<v 3>elsif";
255
        Format.fprintf fmt " %a then@ %a@]" pp_vhdl_expr ifcase.if_cond
256
          pp_vhdl_sequential_stmts ifcase.if_block)
257
      ifva.if_cases;
258
    let _ =
259
      match ifva.default with
260
      | None ->
261
        ()
262
      | Some bl ->
263
        Format.fprintf fmt "@ @[<v 3>else@ %a@]" pp_vhdl_sequential_stmts bl
264
    in
265
    Format.fprintf fmt "@ end if;"
266
  | Case caseva ->
267
    Format.fprintf fmt "@[<v 3>case %a is@ %a@]@ end case;" pp_vhdl_expr
268
      caseva.guard
269
      (Utils.fprintf_list ~sep:"@ " pp_vhdl_case)
270
      caseva.branches
271

  
272
and pp_vhdl_sequential_stmts fmt l =
273
  Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt fmt l
274

  
226 275
and pp_vhdl_case fmt case =
227
  Format.fprintf fmt "when %a => %a"
228
		 pp_vhdl_expr case.when_cond
229
		 pp_vhdl_sequential_stmt case.when_stmt
230
						  
231
type signal_condition_t =
232
  {                            
233
    expr: vhdl_expr_t;              (* when expression *)
234
    else_case: vhdl_expr_t option;  (* optional else case expression. 
235
                                             If None, could be a latch  *)
236
  }
237

  
238
type signal_selection_t =
239
  {
240
    sel_lhs: string;
241
    expr : vhdl_expr_t;
242
    when_sel: vhdl_expr_t option;
243
  }
244

  
245
type conditional_signal_t =
246
  {
247
      lhs: string;                        (* assigned signal *)
248
      rhs: vhdl_expr_t;                   (* expression *)
249
      cond: signal_condition_t option     (* conditional signal statement *)
250
  }
251

  
252
type process_t =
253
  { id: string option; active_sigs: string list; body: vhdl_sequential_stmt_t list }
254

  
255
type selected_signal_t = { sel: vhdl_expr_t;  branches: signal_selection_t list }
256
			   
276
  Format.fprintf fmt "when %a => %a" pp_vhdl_expr case.when_cond
277
    pp_vhdl_sequential_stmt case.when_stmt
278

  
279
type signal_condition_t = {
280
  expr : vhdl_expr_t;
281
  (* when expression *)
282
  else_case : vhdl_expr_t option;
283
      (* optional else case expression. If None, could be a latch *)
284
}
285

  
286
type signal_selection_t = {
287
  sel_lhs : string;
288
  expr : vhdl_expr_t;
289
  when_sel : vhdl_expr_t option;
290
}
291

  
292
type conditional_signal_t = {
293
  lhs : string;
294
  (* assigned signal *)
295
  rhs : vhdl_expr_t;
296
  (* expression *)
297
  cond : signal_condition_t option; (* conditional signal statement *)
298
}
299

  
300
type process_t = {
301
  id : string option;
302
  active_sigs : string list;
303
  body : vhdl_sequential_stmt_t list;
304
}
305

  
306
type selected_signal_t = {
307
  sel : vhdl_expr_t;
308
  branches : signal_selection_t list;
309
}
310

  
257 311
type vhdl_concurrent_stmt_t =
258
  | SigAssign of conditional_signal_t 
259
  | Process of process_t 
312
  | SigAssign of conditional_signal_t
313
  | Process of process_t
260 314
  | SelectedSig of selected_signal_t
261
  (*
262
type vhdl_statement_t =
263
  
264
  (* | DeclarationStmt of declaration_stmt_t *)
265
  | ConcurrentStmt of vhdl_concurrent_stmt_t
266
  | SequentialStmt of vhdl_sequential_stmt_t
267
   *)
268
		     
315
(* type vhdl_statement_t =
316

  
317
   (* | DeclarationStmt of declaration_stmt_t *) | ConcurrentStmt of
318
   vhdl_concurrent_stmt_t | SequentialStmt of vhdl_sequential_stmt_t *)
319

  
269 320
let pp_vhdl_concurrent_stmt fmt stmt =
270
  let pp_sig_cond fmt va = 
271
    Format.fprintf
272
      fmt
273
      "%s <= %a%t;"
274
      va.lhs
275
      pp_vhdl_expr va.rhs
276
      (fun fmt -> match va.cond with
277
		  | None -> ()
278
		  | Some cond ->
279
		     Format.fprintf
280
		       fmt
281
		       " when %a%t"
282
		       pp_vhdl_expr cond.expr
283
		       (fun fmt -> match cond.else_case with
284
				   | None -> ()
285
				   | Some else_case ->
286
				      Format.fprintf
287
					fmt
288
					" else %a"
289
					pp_vhdl_expr else_case
290
		       )
291
      )
321
  let pp_sig_cond fmt va =
322
    Format.fprintf fmt "%s <= %a%t;" va.lhs pp_vhdl_expr va.rhs (fun fmt ->
323
        match va.cond with
324
        | None ->
325
          ()
326
        | Some cond ->
327
          Format.fprintf fmt " when %a%t" pp_vhdl_expr cond.expr (fun fmt ->
328
              match cond.else_case with
329
              | None ->
330
                ()
331
              | Some else_case ->
332
                Format.fprintf fmt " else %a" pp_vhdl_expr else_case))
292 333
  in
293 334
  let pp_process fmt p =
294
    Format.fprintf
295
      fmt
296
      "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
297
      (fun fmt -> match p.id with Some id -> Format.fprintf fmt "%s: " id| None -> ())
335
    Format.fprintf fmt "@[<v 0>%tprocess %a@ @[<v 3>begin@ %a@]@ end process;@]"
336
      (fun fmt ->
337
        match p.id with Some id -> Format.fprintf fmt "%s: " id | None -> ())
298 338
      (fun fmt asigs ->
299
       if asigs <> [] then
300
	 Format.fprintf
301
	   fmt
302
	   "(@[<hov 0>%a)@]"
303
	   (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)
339
        if asigs <> [] then
340
          Format.fprintf fmt "(@[<hov 0>%a)@]"
341
            (Utils.fprintf_list ~sep:",@ " Format.pp_print_string)
342
            asigs)
304 343
      p.active_sigs
305
      (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt) p.body
344
      (Utils.fprintf_list ~sep:"@ " pp_vhdl_sequential_stmt)
345
      p.body
306 346
  in
307 347
  let pp_sig_sel fmt va =
308
    Format.fprintf fmt "@[<v 3>with %a select@ %a;@]"
309
		   pp_vhdl_expr va.sel
310
		   (Utils.fprintf_list
311
		      ~sep:"@ "
312
		      (fun fmt b ->
313
		       Format.fprintf
314
			 fmt
315
			 "%s <= %a when %t"
316
			 b.sel_lhs
317
			 pp_vhdl_expr b.expr
318
			 (fun fmt -> match b.when_sel with
319
				     | None -> Format.fprintf fmt "others"
320
				     | Some w -> pp_vhdl_expr fmt w
321
			 ))
322
		   ) va.branches  in
348
    Format.fprintf fmt "@[<v 3>with %a select@ %a;@]" pp_vhdl_expr va.sel
349
      (Utils.fprintf_list ~sep:"@ " (fun fmt b ->
350
           Format.fprintf fmt "%s <= %a when %t" b.sel_lhs pp_vhdl_expr b.expr
351
             (fun fmt ->
352
               match b.when_sel with
353
               | None ->
354
                 Format.fprintf fmt "others"
355
               | Some w ->
356
                 pp_vhdl_expr fmt w)))
357
      va.branches
358
  in
323 359
  match stmt with
324
  | SigAssign va -> pp_sig_cond fmt va       
325
  | Process p -> pp_process fmt p
326
  | SelectedSig va -> pp_sig_sel fmt va
327
 
328

  
329
  
330
       
331

  
360
  | SigAssign va ->
361
    pp_sig_cond fmt va
362
  | Process p ->
363
    pp_process fmt p
364
  | SelectedSig va ->
365
    pp_sig_sel fmt va
332 366

  
367
(************************************************************************************)
368
(* Entities *)
369
(************************************************************************************)
333 370

  
334
(************************************************************************************)		   
335
(*                     Entities                                                     *)
336
(************************************************************************************)		   
337
			     
338 371
(* TODO? Seems to appear optionally in entities *)
339 372
type vhdl_generic_t = unit
373

  
340 374
let pp_vhdl_generic fmt g = ()
341 375

  
342
			      
343 376
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
377

  
344 378
let pp_vhdl_port_kind fmt p =
345 379
  match p with
346
  | InPort -> Format.fprintf fmt "in"
347
  | OutPort -> Format.fprintf fmt "in"
348
  | InoutPort -> Format.fprintf fmt "inout"
349
  | BufferPort -> Format.fprintf fmt "buffer"
350

  
351
		     
352
type vhdl_port_t =
353
  {
354
    name: string;
355
    kind: vhdl_port_kind_t;
356
    typ: vhdl_type_t;
357
  }
380
  | InPort ->
381
    Format.fprintf fmt "in"
382
  | OutPort ->
383
    Format.fprintf fmt "in"
384
  | InoutPort ->
385
    Format.fprintf fmt "inout"
386
  | BufferPort ->
387
    Format.fprintf fmt "buffer"
388

  
389
type vhdl_port_t = { name : string; kind : vhdl_port_kind_t; typ : vhdl_type_t }
358 390

  
359 391
let pp_vhdl_port fmt p =
360
  Format.fprintf fmt "%s : %a %a"
361
		 p.name
362
		 pp_vhdl_port_kind p.kind
363
		 pp_vhdl_type p.typ
364
	 
365
			     
366
type vhdl_entity_t =
367
  {
368
    name: string;
369
    generics: vhdl_generic_t list;
370
    ports: vhdl_port_t list;
371
  }
392
  Format.fprintf fmt "%s : %a %a" p.name pp_vhdl_port_kind p.kind pp_vhdl_type
393
    p.typ
394

  
395
type vhdl_entity_t = {
396
  name : string;
397
  generics : vhdl_generic_t list;
398
  ports : vhdl_port_t list;
399
}
400

  
372 401
let pp_vhdl_entity fmt e =
373
  Format.fprintf
374
    fmt
375
    "@[<v 3>entity %s is@ %t%t@]@ end %s;@ "
376
    e.name
377
    (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)
402
  Format.fprintf fmt "@[<v 3>entity %s is@ %t%t@]@ end %s;@ " e.name
403
    (fun fmt ->
404
      List.iter
405
        (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g)
406
        e.generics)
378 407
    (fun fmt ->
379
     if e.ports = [] then () else
380
       Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:",@ " pp_vhdl_port) e.ports)
408
      if e.ports = [] then ()
409
      else
410
        Format.fprintf fmt "port (@[<hov 0>%a@]);"
411
          (Utils.fprintf_list ~sep:",@ " pp_vhdl_port)
412
          e.ports)
381 413
    e.name
382 414

  
415
(************************************************************************************)
416
(* Packages / Library loading *)
417
(************************************************************************************)
383 418

  
384

  
385

  
386
(************************************************************************************)		   
387
(*                    Packages / Library loading                                    *)
388
(************************************************************************************)		   
389

  
390
				
391
				
392 419
(* Optional. Describes shared definitions *)
393
type vhdl_package_t =
394
  {
395
    name: string;
396
    shared_defs: vhdl_definition_t list;
397
  }
420
type vhdl_package_t = { name : string; shared_defs : vhdl_definition_t list }
398 421

  
399 422
let pp_vhdl_package fmt p =
400
  Format.fprintf
401
    fmt
402
    "@[<v 3>package %s is@ %a@]@ end %s;@ "
403
    p.name
404
    (Utils.fprintf_list  ~sep:"@ " pp_vhdl_definition) p.shared_defs
405
    p.name
423
  Format.fprintf fmt "@[<v 3>package %s is@ %a@]@ end %s;@ " p.name
424
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_definition)
425
    p.shared_defs p.name
406 426

  
407 427
type vhdl_load_t = Library of string | Use of string list
428

  
408 429
let pp_vhdl_load fmt l =
409 430
  match l with
410
  | Library s -> Format.fprintf fmt "library %s;@ " s
411
  | Use sl -> Format.fprintf fmt "use %a;@ " (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl
412

  
413

  
414
(************************************************************************************)		   
415
(*                        Architecture / VHDL Design                                *)
416
(************************************************************************************)		   
417
				       
418
				       
419
type vhdl_architecture_t =
420
  {
421
    name: string;
422
    entity: string;
423
    declarations: vhdl_declaration_t list;
424
    body: vhdl_concurrent_stmt_t list;
425
  }
426
    
431
  | Library s ->
432
    Format.fprintf fmt "library %s;@ " s
433
  | Use sl ->
434
    Format.fprintf fmt "use %a;@ "
435
      (Utils.fprintf_list ~sep:"." Format.pp_print_string)
436
      sl
437

  
438
(************************************************************************************)
439
(* Architecture / VHDL Design *)
440
(************************************************************************************)
441

  
442
type vhdl_architecture_t = {
443
  name : string;
444
  entity : string;
445
  declarations : vhdl_declaration_t list;
446
  body : vhdl_concurrent_stmt_t list;
447
}
448

  
427 449
let pp_vhdl_architecture fmt a =
428
  Format.fprintf
429
    fmt
430
    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;"
431
    a.name
450
  Format.fprintf fmt
451
    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]@ end %s;" a.name
432 452
    a.entity
433
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration) a.declarations
434
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt) a.body
435
    a.name
436
    
453
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration)
454
    a.declarations
455
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_concurrent_stmt)
456
    a.body a.name
437 457

  
438 458
(* TODO. Configuraiton is optional *)
439 459
type vhdl_configuration_t = unit
440
let pp_vhdl_configuration fmt c = ()
441

  
442 460

  
461
let pp_vhdl_configuration fmt c = ()
443 462

  
444
type vhdl_design_t =
445
  {
446
    packages: vhdl_package_t list;
447
    libraries: vhdl_load_t list;
448
    entities: vhdl_entity_t list;
449
    architectures: vhdl_architecture_t list;
450
    configuration: vhdl_configuration_t option;
451
  }
463
type vhdl_design_t = {
464
  packages : vhdl_package_t list;
465
  libraries : vhdl_load_t list;
466
  entities : vhdl_entity_t list;
467
  architectures : vhdl_architecture_t list;
468
  configuration : vhdl_configuration_t option;
469
}
452 470

  
453 471
let pp_vhdl_design fmt d =
454
  Format.fprintf
455
    fmt
456
    "@[<v 0>%a%t%a%t%a%t%a%t@]"
457
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package) d.packages
472
  Format.fprintf fmt "@[<v 0>%a%t%a%t%a%t%a%t@]"
473
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package)
474
    d.packages
458 475
    (fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
459
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries
476
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load)
477
    d.libraries
460 478
    (fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
461
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities
479
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity)
480
    d.entities
462 481
    (fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
463
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures
482
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture)
483
    d.architectures
464 484
    (fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")

Also available in: Unified diff