From 891377ce1962cdb31357d6580d6546ec22df2b4f Mon Sep 17 00:00:00 2001 From: xleroy Date: Wed, 3 Mar 2010 10:22:27 +0000 Subject: Switching to the new C parser/elaborator/simplifier git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1269 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cparser/Env.ml | 247 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 247 insertions(+) create mode 100644 cparser/Env.ml (limited to 'cparser/Env.ml') diff --git a/cparser/Env.ml b/cparser/Env.ml new file mode 100644 index 00000000..43ba4c38 --- /dev/null +++ b/cparser/Env.ml @@ -0,0 +1,247 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Typing environment *) + +open C + +type error = + | Unbound_identifier of string + | Unbound_tag of string * string + | Tag_mismatch of string * string * string + | Unbound_typedef of string + | No_member of string * string * string + +exception Error of error + +(* Maps over ident, accessible both by name or by name + stamp *) + +module StringMap = Map.Make(String) + +module IdentMap = struct + type 'a t = (ident * 'a) list StringMap.t + let empty : 'a t = StringMap.empty + + (* Search by name and return topmost binding *) + let lookup s m = + match StringMap.find s m with + | id_data :: _ -> id_data + | [] -> assert false + + (* Search by identifier and return associated binding *) + let find id m = + let rec lookup_in = function + | [] -> raise Not_found + | (id', data) :: rem -> + if id'.stamp = id.stamp then data else lookup_in rem in + lookup_in (StringMap.find id.name m) + + (* Insert by identifier *) + let add id data m = + let l = try StringMap.find id.name m with Not_found -> [] in + StringMap.add id.name ((id, data) :: l) m +end + +let gensym = ref 0 + +let fresh_ident s = incr gensym; { name = s; stamp = !gensym } + +(* Infos associated with structs or unions *) + +type composite_info = { + ci_kind: struct_or_union; + ci_incomplete: bool; (* incompletely defined? *) + ci_members: field list (* members, in order *) +} + +(* Infos associated with an ordinary identifier *) + +type ident_info = + | II_ident of storage * typ + | II_enum of int64 (* value of the enum *) + +(* Infos associated with a typedef *) + +type typedef_info = typ + +(* Environments *) + +type t = { + env_scope: int; + env_ident: ident_info IdentMap.t; + env_tag: composite_info IdentMap.t; + env_typedef: typedef_info IdentMap.t +} + +let empty = { + env_scope = 0; + env_ident = IdentMap.empty; + env_tag = IdentMap.empty; + env_typedef = IdentMap.empty +} + +(* Enter a new scope. *) + +let new_scope env = + { env with env_scope = !gensym + 1 } + +let in_current_scope env id = id.stamp >= env.env_scope + +(* Looking up things by source name *) + +let lookup_ident env s = + try + IdentMap.lookup s env.env_ident + with Not_found -> + raise(Error(Unbound_identifier s)) + +let lookup_tag env s = + try + IdentMap.lookup s env.env_tag + with Not_found -> + raise(Error(Unbound_tag(s, "tag"))) + +let lookup_struct env s = + try + let (id, ci as res) = IdentMap.lookup s env.env_tag in + if ci.ci_kind <> Struct then + raise(Error(Tag_mismatch(s, "struct", "union"))); + res + with Not_found -> + raise(Error(Unbound_tag(s, "struct"))) + +let lookup_union env s = + try + let (id, ci as res) = IdentMap.lookup s env.env_tag in + if ci.ci_kind <> Union then + raise(Error(Tag_mismatch(s, "union", "struct"))); + res + with Not_found -> + raise(Error(Unbound_tag(s, "union"))) + +let lookup_composite env s = + try Some (IdentMap.lookup s env.env_tag) + with Not_found -> None + +let lookup_typedef env s = + try + IdentMap.lookup s env.env_typedef + with Not_found -> + raise(Error(Unbound_typedef s)) + +(* Checking if a source name is bound *) + +let ident_is_bound env s = StringMap.mem s env.env_ident + +(* Finding things by translated identifier *) + +let find_ident env id = + try IdentMap.find id env.env_ident + with Not_found -> + raise(Error(Unbound_identifier(id.name))) + +let find_tag env id = + try IdentMap.find id env.env_tag + with Not_found -> + raise(Error(Unbound_tag(id.name, "tag"))) + +let find_struct env id = + try + let ci = IdentMap.find id env.env_tag in + if ci.ci_kind <> Struct then + raise(Error(Tag_mismatch(id.name, "struct", "union"))); + ci + with Not_found -> + raise(Error(Unbound_tag(id.name, "struct"))) + +let find_union env id = + try + let ci = IdentMap.find id env.env_tag in + if ci.ci_kind <> Union then + raise(Error(Tag_mismatch(id.name, "union", "struct"))); + ci + with Not_found -> + raise(Error(Unbound_tag(id.name, "union"))) + +let find_member ci m = + List.find (fun f -> f.fld_name = m) ci + +let find_struct_member env (id, m) = + try + let ci = find_struct env id in + find_member ci.ci_members m + with Not_found -> + raise(Error(No_member(id.name, "struct", m))) + +let find_union_member env (id, m) = + try + let ci = find_union env id in + find_member ci.ci_members m + with Not_found -> + raise(Error(No_member(id.name, "union", m))) + +let find_typedef env id = + try + IdentMap.find id env.env_typedef + with Not_found -> + raise(Error(Unbound_typedef(id.name))) + +(* Inserting things by source name, with generation of a translated name *) + +let enter_ident env s sto ty = + let id = fresh_ident s in + (id, + { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident }) + +let enter_composite env s ci = + let id = fresh_ident s in + (id, { env with env_tag = IdentMap.add id ci env.env_tag }) + +let enter_enum_item env s v = + let id = fresh_ident s in + (id, { env with env_ident = IdentMap.add id (II_enum v) env.env_ident }) + +let enter_typedef env s info = + let id = fresh_ident s in + (id, { env with env_typedef = IdentMap.add id info env.env_typedef }) + +(* Inserting things by translated name *) + +let add_ident env id sto ty = + { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident } + +let add_composite env id ci = + { env with env_tag = IdentMap.add id ci env.env_tag } + +let add_typedef env id info = + { env with env_typedef = IdentMap.add id info env.env_typedef } + +(* Error reporting *) + +open Printf + +let error_message = function + | Unbound_identifier name -> + sprintf "Unbound identifier '%s'" name + | Unbound_tag(name, kind) -> + sprintf "Unbound %s '%s'" kind name + | Tag_mismatch(name, expected, actual) -> + sprintf "'%s' was declared as a %s but is used as a %s" + name actual expected + | Unbound_typedef name -> + sprintf "Unbound typedef '%s'" name + | No_member(compname, compkind, memname) -> + sprintf "%s '%s' has no member named '%s'" + compkind compname memname -- cgit