source: Deliverables/D2.2/8051/cparser/Env.ml @ 486

Last change on this file since 486 was 486, checked in by ayache, 8 years ago

Deliverable D2.2

File size: 7.0 KB
Line 
1(* *********************************************************************)
2(*                                                                     *)
3(*              The Compcert verified compiler                         *)
4(*                                                                     *)
5(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
6(*                                                                     *)
7(*  Copyright Institut National de Recherche en Informatique et en     *)
8(*  Automatique.  All rights reserved.  This file is distributed       *)
9(*  under the terms of the GNU General Public License as published by  *)
10(*  the Free Software Foundation, either version 2 of the License, or  *)
11(*  (at your option) any later version.  This file is also distributed *)
12(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
13(*                                                                     *)
14(* *********************************************************************)
15
16(* Typing environment *)
17
18open C
19
20type error =
21  | Unbound_identifier of string
22  | Unbound_tag of string * string
23  | Tag_mismatch of string * string * string
24  | Unbound_typedef of string
25  | No_member of string * string * string
26
27exception Error of error
28
29(* Maps over ident, accessible both by name or by name + stamp *)
30
31module StringMap = Map.Make(String)
32
33module IdentMap = struct
34  type 'a t = (ident * 'a) list StringMap.t
35  let empty : 'a t = StringMap.empty
36
37  (* Search by name and return topmost binding *)
38  let lookup s m =
39    match StringMap.find s m with
40    | id_data :: _ -> id_data
41    | [] -> assert false
42
43  (* Search by identifier and return associated binding *)
44  let find id m =
45    let rec lookup_in = function
46    | [] -> raise Not_found
47    | (id', data) :: rem ->
48         if id'.stamp = id.stamp then data else lookup_in rem in
49    lookup_in (StringMap.find id.name m)
50
51  (* Insert by identifier *)
52  let add id data m =
53    let l = try StringMap.find id.name m with Not_found -> [] in
54    StringMap.add id.name ((id, data) :: l) m
55end
56
57let gensym = ref 0
58
59let fresh_ident s = incr gensym; { name = s; stamp = !gensym }
60
61(* Infos associated with structs or unions *)
62
63type composite_info = {
64  ci_kind: struct_or_union;
65  ci_members: field list;               (* members, in order *)
66  ci_alignof: int option;               (* alignment; None if incomplete *)
67  ci_sizeof: int option;                (* size; None if incomplete *)
68}
69
70(* Infos associated with an ordinary identifier *)
71
72type ident_info =
73  | II_ident of storage * typ
74  | II_enum of int64                    (* value of the enum *)
75
76(* Infos associated with a typedef *)
77
78type typedef_info = typ
79
80(* Environments *)
81
82type t = {
83  env_scope: int;
84  env_ident: ident_info IdentMap.t;
85  env_tag: composite_info IdentMap.t;
86  env_typedef: typedef_info IdentMap.t
87}
88
89let empty = {
90  env_scope = 0;
91  env_ident = IdentMap.empty;
92  env_tag = IdentMap.empty;
93  env_typedef = IdentMap.empty
94}
95
96(* Enter a new scope. *)
97
98let new_scope env =
99  { env with env_scope = !gensym + 1 }
100
101let in_current_scope env id = id.stamp >= env.env_scope
102
103(* Looking up things by source name *)
104
105let lookup_ident env s =
106  try
107    IdentMap.lookup s env.env_ident
108  with Not_found ->
109    raise(Error(Unbound_identifier s))
110
111let lookup_tag env s =
112  try
113    IdentMap.lookup s env.env_tag
114  with Not_found ->
115    raise(Error(Unbound_tag(s, "tag")))
116
117let lookup_struct env s =
118  try
119    let (id, ci as res) = IdentMap.lookup s env.env_tag in
120    if ci.ci_kind <> Struct then
121      raise(Error(Tag_mismatch(s, "struct", "union")));
122    res
123  with Not_found ->
124    raise(Error(Unbound_tag(s, "struct")))
125 
126let lookup_union env s =
127  try
128    let (id, ci as res) = IdentMap.lookup s env.env_tag in
129    if ci.ci_kind <> Union then
130      raise(Error(Tag_mismatch(s, "union", "struct")));
131    res
132  with Not_found ->
133    raise(Error(Unbound_tag(s, "union")))
134 
135let lookup_composite env s =
136  try Some (IdentMap.lookup s env.env_tag)
137  with Not_found -> None
138
139let lookup_typedef env s =
140  try
141    IdentMap.lookup s env.env_typedef
142  with Not_found ->
143    raise(Error(Unbound_typedef s))
144
145(* Checking if a source name is bound *)
146
147let ident_is_bound env s = StringMap.mem s env.env_ident
148
149(* Finding things by translated identifier *)
150
151let find_ident env id =
152  try IdentMap.find id env.env_ident
153  with Not_found ->
154    raise(Error(Unbound_identifier(id.name)))
155
156let find_tag env id =
157  try IdentMap.find id env.env_tag
158  with Not_found ->
159    raise(Error(Unbound_tag(id.name, "tag")))
160
161let find_struct env id =
162  try
163    let ci = IdentMap.find id env.env_tag in
164    if ci.ci_kind <> Struct then
165      raise(Error(Tag_mismatch(id.name, "struct", "union")));
166    ci
167  with Not_found ->
168    raise(Error(Unbound_tag(id.name, "struct")))
169
170let find_union env id =
171  try
172    let ci = IdentMap.find id env.env_tag in
173    if ci.ci_kind <> Union then
174      raise(Error(Tag_mismatch(id.name, "union", "struct")));
175    ci
176  with Not_found ->
177    raise(Error(Unbound_tag(id.name, "union")))
178 
179let find_member ci m =
180  List.find (fun f -> f.fld_name = m) ci
181
182let find_struct_member env (id, m) =
183  try
184    let ci = find_struct env id in
185    find_member ci.ci_members m
186  with Not_found ->
187    raise(Error(No_member(id.name, "struct", m)))
188
189let find_union_member env (id, m) =
190  try
191    let ci = find_union env id in
192    find_member ci.ci_members m
193  with Not_found ->
194    raise(Error(No_member(id.name, "union", m)))
195
196let find_typedef env id =
197  try
198    IdentMap.find id env.env_typedef
199  with Not_found ->
200    raise(Error(Unbound_typedef(id.name)))
201
202(* Inserting things by source name, with generation of a translated name *)
203
204let enter_ident env s sto ty =
205  let id = fresh_ident s in
206  (id,
207   { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident })
208
209let enter_composite env s ci =
210  let id = fresh_ident s in
211  (id, { env with env_tag = IdentMap.add id ci env.env_tag })
212
213let enter_enum_item env s v =
214  let id = fresh_ident s in
215  (id, { env with env_ident = IdentMap.add id (II_enum v) env.env_ident })
216
217let enter_typedef env s info =
218  let id = fresh_ident s in
219  (id, { env with env_typedef = IdentMap.add id info env.env_typedef })
220
221(* Inserting things by translated name *)
222
223let add_ident env id sto ty =
224  { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident }
225
226let add_composite env id ci =
227  { env with env_tag = IdentMap.add id ci env.env_tag }
228
229let add_typedef env id info =
230  { env with env_typedef = IdentMap.add id info env.env_typedef }
231
232(* Error reporting *)
233
234open Printf
235
236let error_message = function
237  | Unbound_identifier name -> 
238      sprintf "Unbound identifier '%s'" name
239  | Unbound_tag(name, kind) ->
240      sprintf "Unbound %s '%s'" kind name
241  | Tag_mismatch(name, expected, actual) ->
242      sprintf "'%s' was declared as a %s but is used as a %s" 
243              name actual expected
244  | Unbound_typedef name ->
245      sprintf "Unbound typedef '%s'" name
246  | No_member(compname, compkind, memname) ->
247      sprintf "%s '%s' has no member named '%s'"
248              compkind compname memname
Note: See TracBrowser for help on using the repository browser.