cparser/Env.ml

   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
  18 open C
  19
  20 type 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
  27 exception Error of error
  28
  29 (* Maps over ident, accessible both by name or by name + stamp *)
  30
  31 module StringMap = Map.Make(String)
  32
  33 module 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
  55 end
  56
  57 let gensym = ref 0
  58
  59 let fresh_ident s = incr gensym; { name = s; stamp = !gensym }
  60
  61 (* Infos associated with structs or unions *)
  62
  63 type 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
  72 type 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
  78 type typedef_info = typ
  79
  80 (* Environments *)
  81
  82 type 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
  89 let 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
  98 let new_scope env =
  99   { env with env_scope = !gensym + 1 }
 100
 101 let in_current_scope env id = id.stamp >= env.env_scope
 102
 103 (* Looking up things by source name *)
 104
 105 let lookup_ident env s =
 106   try
 107     IdentMap.lookup s env.env_ident
 108   with Not_found ->
 109     raise(Error(Unbound_identifier s))
 110
 111 let 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
 117 let 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
 126 let 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
 135 let lookup_composite env s =
 136   try Some (IdentMap.lookup s env.env_tag)
 137   with Not_found -> None
 138
 139 let 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
 147 let ident_is_bound env s = StringMap.mem s env.env_ident
 148
 149 (* Finding things by translated identifier *)
 150
 151 let find_ident env id =
 152   try IdentMap.find id env.env_ident
 153   with Not_found ->
 154     raise(Error(Unbound_identifier(id.name)))
 155
 156 let 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
 161 let 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
 170 let 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
 179 let find_member ci m =
 180   List.find (fun f -> f.fld_name = m) ci
 181
 182 let 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
 189 let 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
 196 let 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
 204 let 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
 209 let 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
 213 let 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
 217 let 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
 223 let add_ident env id sto ty =
 224   { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident }
 225
 226 let add_composite env id ci =
 227   { env with env_tag = IdentMap.add id ci env.env_tag }
 228
 229 let add_typedef env id info =
 230   { env with env_typedef = IdentMap.add id info env.env_typedef }
 231
 232 (* Error reporting *)
 233
 234 open Printf
 235
 236 let 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