Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / vhdl_ast.ml @ 090baab6

History | View | Annotate | Download (8.18 KB)

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

    
3
(* TODO ? *)
4
type vhdl_type_t =
5
  | Integer | Natural | Positive
6
  | Real
7
  | Range of string option * int * int
8
  | Byte
9
  | Bit_vector of int * int
10
  | Enumerated of string list
11
  
12
let pp_vhdl_type fmt t =
13
  match t with
14
  | Integer -> Format.fprintf fmt "integer"
15
  | Natural -> Format.fprintf fmt "natural"
16
  | Positive -> Format.fprintf fmt "positive"
17
  | Real -> Format.fprintf fmt "real"
18
  | 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
19
  | Byte -> Format.fprintf fmt "byte"
20
  | Bit_vector (n,m) -> Format.fprintf fmt "bit_vector(%i downto %i)" n m
21
  | Enumerated sl -> Format.fprintf fmt "(%a)" (Utils.fprintf_list ~sep:", " Format.pp_print_string) sl
22

    
23
type vhdl_definition_t =
24
  | Type of {name : string ; definition: vhdl_type_t}
25
  | Subtype of {name : string ; definition: vhdl_type_t}
26
					
27
let pp_vhdl_definition fmt def =
28
  match def with
29
  | Type s -> Format.fprintf fmt "type %s is %a;" s.name pp_vhdl_type s.definition
30
  | Subtype s -> Format.fprintf fmt "subtype %s is %a;" s.name pp_vhdl_type s.definition
31

    
32
(* Optional. Describes shared definitions *)
33
type vhdl_package_t =
34
  {
35
    name: string;
36
    shared_defs: vhdl_definition_t list;
37
  }
38

    
39
let pp_vhdl_package fmt p =
40
  Format.fprintf
41
    fmt
42
    "@[<v 3>package %s is@ %a@ end %s;@]@ "
43
    p.name
44
    (Utils.fprintf_list  ~sep:"@ " pp_vhdl_definition) p.shared_defs
45
    p.name
46

    
47
type vhdl_load_t = Library of string | Use of string list
48
let pp_vhdl_load fmt l =
49
  match l with
50
  | Library s -> Format.fprintf fmt "library %s;" s
51
  | Use sl -> Format.fprintf fmt "use %a;s" (Utils.fprintf_list ~sep:"." Format.pp_print_string) sl
52

    
53

    
54
(* TODO *)
55
type vhdl_generic_t = unit
56
let pp_vhdl_generic fmt g = ()
57

    
58
			      
59
type vhdl_port_kind_t = InPort | OutPort | InoutPort | BufferPort
60
let pp_vhdl_port_kind fmt p =
61
  match p with
62
  | InPort -> Format.fprintf fmt "in"
63
  | OutPort -> Format.fprintf fmt "in"
64
  | InoutPort -> Format.fprintf fmt "inout"
65
  | BufferPort -> Format.fprintf fmt "buffer"
66

    
67
		     
68
type vhdl_port_t =
69
  {
70
    name: string;
71
    kind: vhdl_port_kind_t;
72
    typ: vhdl_type_t;
73
  }
74

    
75
let pp_vhdl_port fmt p =
76
  Format.fprintf fmt "%s : %a %a"
77
		 p.name
78
		 pp_vhdl_port_kind p.kind
79
		 pp_vhdl_type p.typ
80
	 
81
			     
82
type vhdl_entity_t =
83
  {
84
    name: string;
85
    generics: vhdl_generic_t list;
86
    ports: vhdl_port_t list;
87
  }
88
let pp_vhdl_entity fmt e =
89
  Format.fprintf
90
    fmt
91
    "@[<v 3>entity %s is@ %t%t@]@ end %s;"
92
    e.name
93
    (fun fmt -> List.iter (fun g -> Format.fprintf fmt "generic %a;@ " pp_vhdl_generic g) e.generics)
94
    (fun fmt ->
95
     if e.ports = [] then () else
96
       Format.fprintf fmt "port (@[<hov 0>%a@]);" (Utils.fprintf_list ~sep:"@ " pp_vhdl_port) e.ports)
97
    e.name
98

    
99

    
100
(* TODO *)
101

    
102
type cst_val_t = CstInt of int
103
let pp_cst_val fmt c =
104
  match c with
105
  | CstInt i -> Format.fprintf fmt "%i" i
106
			       
107
type vhdl_declaration_t =
108
  | VarDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
109
  | CstDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t  }
110
  | SigDecl of { name : string; typ : vhdl_type_t; init_val : cst_val_t option }
111

    
112
let pp_vhdl_declaration fmt decl =
113
  match decl with
114
  | VarDecl v -> Format.fprintf
115
		   fmt
116
		   "variable %s : %a%t;"
117
		   v.name
118
		   pp_vhdl_type v.typ
119
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv)
120
  | CstDecl v -> Format.fprintf
121
		   fmt
122
		   "constant %s : %a := %a;"
123
		   v.name
124
		   pp_vhdl_type v.typ
125
		   pp_cst_val v.init_val
126
  | SigDecl v -> Format.fprintf
127
		   fmt
128
		   "signal %s : %a%t;"
129
		   v.name
130
		   pp_vhdl_type v.typ
131
		   (fun fmt -> match v.init_val with Some initv -> Format.fprintf fmt " := %a" pp_cst_val initv)
132

    
133
(************************************************************************************)		   
134
(*            Attributes for types, arrays, signals and strings                     *)
135
(************************************************************************************)		   
136
type 'basetype vhdl_type_attributes_t =
137
  | TAttNoArg of { id: string }
138
  | TAttIntArg of { id: string; arg: int }
139
  | TAttValArg of { id: string; arg: 'basetype }
140
  | TAttStringArg of { id: string; arg: string }
141

    
142
let typ_att_noarg = ["base"; "left"; "right"; "high"; "low"]
143
let typ_att_intarg = ["pos"; "val"; "succ"; "pred"; "leftof"; "rightof"]
144
let typ_att_valarg = ["image"]
145
let typ_att_stringarg = ["value"]
146
  
147
let pp_type_attribute pp_val fmt tatt =
148
  match tatt with
149
  | TAttNoArg a -> Format.fprintf fmt "'%s" a.id
150
  | TAttIntArg a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
151
  | TAttValArg a -> Format.fprintf fmt "'%s(%a)" a.id pp_val a.arg
152
  | TAttStringArg a -> Format.fprintf fmt "'%s(%s)" a.id a.arg
153

    
154
type vhdl_array_attributes_t = AAttInt of { id: string; arg: int; } | AAttAscending
155
let pp_array_attribute fmt aatt =
156
  match aatt with
157
  | AAttInt a -> Format.fprintf fmt "'%s(%i)" a.id a.arg
158
  | AAttAscending -> Format.fprintf fmt "'ascending"
159
let array_att_intarg = ["left"; "right"; "high"; "low"; "range"; "reverse_range"; "length"]  
160

    
161
type vhdl_signal_attributes_t = SigAtt of string
162
let pp_signal_attribute fmt sa = match sa with
163
  | SigAtt s -> Format.fprintf fmt "'%s" s
164
let signal_att = [ "event"; "stable"; "last_value" ]
165

    
166
type vhdl_string_attributes_t = StringAtt of string
167
let pp_signal_attribute fmt sa = match sa with
168
  | StringAtt s -> Format.fprintf fmt "'%s" s
169
let signal_att = [ "simple_name"; "path_name"; "instance_name" ]
170

    
171
				      
172
(* TODO *)  
173
type vhdl_expr_t =
174
  | Binop of { op: string; args: vhdl_expr_t list }
175
					     
176
let pp_vhdl_expr fmt e = ()
177

    
178
let arith_funs = ["+";"-";"*";"/";"mod"; "rem";"abs";"**"]
179
let bool_funs  = ["and"; "or"; "nand"; "nor"; "xor"; "not"]
180
let rel_funs   = ["<";">";"<=";">=";"/=";"="]
181
  
182
			   
183

    
184

    
185
type vhdl_sequential_stmt_t = unit 
186
(*  | VarAssign of { lhs: string; rhs: vhdl_expr_t }
187
  | Case of { guard: vhdl_expr_t; branches: { case: }
188
	    | Case of { guard: vhdl_expr_t; branches 
189
 *)
190
type vhdl_concurrent_stmt_t =
191
  | SigAssign of { lhs: string; rhs: vhdl_expr_t }
192
  | Process of { active_sigs: string list; body: vhdl_sequential_stmt_t list }
193
  
194
type vhdl_statement_t =
195
  
196
  (* | DeclarationStmt of declaration_stmt_t *)
197
  | ConcurrentStmt of vhdl_concurrent_stmt_t
198
  | SequentialStmt of vhdl_sequential_stmt_t
199
			
200

    
201
let rec pp_vhdl_statement fmt stmt = ()
202
(*  match stmt with
203
  | VarAssign va -> Format.fprintf fmt "%s := %a;" va.lhs pp_vhdl_expr va.rhs
204
  | SigAssign va -> Format.fprintf fmt "%s <= %a;" va.lhs pp_vhdl_expr va.rhs
205
  | Process p ->
206
     Format.fprintf
207
       fmt
208
       "@[<v 0>process %a@ @[<v 3>begin@ %a@]@ end process;@]"
209
       (fun fmt asigs ->
210
	if asigs <> [] then
211
	  Format.fprintf
212
	    fmt
213
	    "(@[<hov 0>%a)@]"
214
	    (Utils.fprintf_list ~sep:",@ " Format.pp_print_string) asigs)
215
       p.active_sigs
216
       (Utils.fprintf_list ~sep:"@ " pp_vhdl_statement) p.body
217
 *)     
218

    
219
type vhdl_architecture_t =
220
  {
221
    name: string;
222
    entity: string;
223
    declarations: vhdl_declaration_t list;
224
    body: vhdl_statement_t list;
225
  }
226
    
227
let pp_vhdl_architecture fmt a =
228
  Format.fprintf
229
    fmt
230
    "@[<v 3>architecture %s of %s is@ %a@]@ @[<v 3>begin@ %a@]end %s"
231
    a.name
232
    a.entity
233
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_declaration) a.declarations
234
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_statement) a.body
235
    a.name
236
    
237

    
238
(* TODO. Configuraiton is optional *)
239
type vhdl_configuration_t = unit
240
let pp_vhdl_configuration fmt c = ()
241

    
242

    
243

    
244
type vhdl_design_t =
245
  {
246
    packages: vhdl_package_t list;
247
    libraries: vhdl_load_t list;
248
    entities: vhdl_entity_t list;
249
    architectures: vhdl_architecture_t list;
250
    configuration: vhdl_configuration_t option;
251
  }
252

    
253
let pp_vhdl_design fmt d =
254
  Format.fprintf
255
    fmt
256
    "@[<v 0>%a%t%a%t%a%t%a%t@]"
257
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_package) d.packages
258
    (fun fmt -> if d.packages <> [] then Format.fprintf fmt "@ ")
259
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_load) d.libraries
260
    (fun fmt -> if d.libraries <> [] then Format.fprintf fmt "@ ")
261
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_entity) d.entities
262
    (fun fmt -> if d.entities <> [] then Format.fprintf fmt "@ ")
263
    (Utils.fprintf_list ~sep:"@ " pp_vhdl_architecture) d.architectures
264
    (fun fmt -> if d.architectures <> [] then Format.fprintf fmt "@ ")