diff options
author | Bernhard Schommer <bschommer@users.noreply.github.com> | 2016-12-27 19:50:01 +0100 |
---|---|---|
committer | GitHub <noreply@github.com> | 2016-12-27 19:50:01 +0100 |
commit | 9b022d749dc5b1fdb091ff8a74647c03fc1f84bb (patch) | |
tree | 24218347dd375ebdf36789659a5fd092cc8aa575 | |
parent | 647cc8dc9699277cb1e77ae3b07c007186720d59 (diff) | |
parent | 860f28734063628f5582be91c7429b14f0922917 (diff) | |
download | compcert-kvx-9b022d749dc5b1fdb091ff8a74647c03fc1f84bb.tar.gz compcert-kvx-9b022d749dc5b1fdb091ff8a74647c03fc1f84bb.zip |
Merge pull request #153 from AbsInt/anonymous_struct2
Next try for support of anonymous structs.
-rw-r--r-- | cparser/Bitfields.ml | 6 | ||||
-rw-r--r-- | cparser/C.mli | 3 | ||||
-rw-r--r-- | cparser/Cutil.ml | 9 | ||||
-rw-r--r-- | cparser/Elab.ml | 96 | ||||
-rw-r--r-- | cparser/Env.ml | 30 | ||||
-rw-r--r-- | cparser/Env.mli | 5 | ||||
-rw-r--r-- | cparser/Rename.ml | 3 |
7 files changed, 113 insertions, 39 deletions
diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index 9f38abc6..dc630ad3 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -137,7 +137,7 @@ let rec transf_struct_members env id count = function bf_bool = is_bool} end) bitfields; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} + { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} :: transf_struct_members env id (count + 1) ml' end end @@ -174,7 +174,7 @@ let rec transf_union_members env id count = function bf_pos = pos'; bf_size = nbits; bf_signed = signed; bf_signed_res = signed2; bf_bool = is_bool}; - { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} + { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None; fld_anonymous = false;} :: transf_struct_members env id (count + 1) ms) let transf_composite env su id attr ml = @@ -334,7 +334,7 @@ let rec transf_struct_init id fld_init_list = let (el, rem') = pack_bitfield_init id bf.bf_carrier fld_init_list in ({fld_name = bf.bf_carrier; fld_typ = bf.bf_carrier_typ; - fld_bitfield = None}, + fld_bitfield = None; fld_anonymous = false}, Init_single {edesc = ECast(bf.bf_carrier_typ, or_expr_list el); etyp = bf.bf_carrier_typ}) :: transf_struct_init id rem' diff --git a/cparser/C.mli b/cparser/C.mli index 8d8f2805..cacdbe7c 100644 --- a/cparser/C.mli +++ b/cparser/C.mli @@ -158,7 +158,8 @@ type typ = type field = { fld_name: string; fld_typ: typ; - fld_bitfield: int option + fld_bitfield: int option; + fld_anonymous: bool; } type struct_or_union = diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 4d0cd735..f5d5c425 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -691,10 +691,11 @@ let is_anonymous_composite = function (* Find the info for a field access *) let field_of_dot_access env t m = - match unroll env t with - | TStruct(id, _) -> Env.find_struct_member env (id, m) - | TUnion(id, _) -> Env.find_union_member env (id, m) - | _ -> assert false + let m = match unroll env t with + | TStruct(id, _) -> Env.find_struct_member env (id, m) + | TUnion(id, _) -> Env.find_union_member env (id, m) + | _ -> assert false in + List.hd (List.rev m) let field_of_arrow_access env t m = match unroll env t with diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 127f5fe2..845fc210 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -760,10 +760,9 @@ and elab_init_name_group keep_ty loc env (spec, namelist) = and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = - let fieldlist = List.map ( - function - | (None, x) -> (Name ("", JUSTBASE, [], loc), x) - | (Some n, x) -> (n, x)) + let fieldlist = List.map + (function (None, x) -> (Name ("", JUSTBASE, [], loc), x) + | (Some n, x) -> (n, x)) fieldlist in @@ -815,9 +814,10 @@ and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = error loc "bit-field '%s' width not an integer constant" id; None end in - if id = "" && not (Cutil.is_anonymous_composite ty) && optbitsize = None then + let anon_composite = Cutil.is_anonymous_composite ty in + if id = "" && not anon_composite && optbitsize = None then warning loc Missing_declarations "declaration does not declare anything"; - { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' } + { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize'; fld_anonymous = id = "" && anon_composite} in (List.map2 elab_bitfield fieldlist names, env') @@ -826,16 +826,34 @@ and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = and elab_struct_or_union_info keep_ty kind loc env members attrs = let (m, env') = mmap (elab_field_group keep_ty) env members in let m = List.flatten m in - ignore (List.fold_left (fun acc fld -> - let n = fld.fld_name in - if n <> "" then begin - if List.exists ((=) n) acc then - error loc "duplicate member '%s'" n; - n::acc - end else begin - if Cutil.is_composite_type env fld.fld_typ then - warning loc Celeven_extension "anonymous structs/unions are a C11 extension"; - acc end) [] m); + let m,_ = mmap (fun c fld -> + if fld.fld_anonymous then + let name = Printf.sprintf "<anon>_%d" c in + {fld with fld_name = name},c+1 + else + fld,c) 0 m in + let rec duplicate acc = function + | [] -> () + | fld::rest -> + if fld.fld_anonymous then begin + let warn () = + warning loc Celeven_extension "anonymous structs/unions are a C11 extension" in + let rest = match unroll env fld.fld_typ with + | TStruct (id,_) -> + warn (); + let str = Env.find_struct env' id in + str.ci_members@rest + | TUnion (id,_) -> + warn (); + let union = Env.find_union env' id in + union.ci_members@rest + | _ -> rest in + duplicate acc rest + end else begin + if List.exists ((=) fld.fld_name) acc then + error loc "duplicate member '%s'" fld.fld_name; + duplicate (fld.fld_name::acc) rest end in + duplicate [] m; (* Check for incomplete types *) let rec check_incomplete = function | [] -> () @@ -1160,7 +1178,19 @@ module I = struct end else None | _, _ -> - None + None + + let has_member env name ty = + let mem f id = + try + ignore(f env (id,name)); true + with Env.Error _ -> false in + match ty with + | TStruct (id,_) -> + mem Env.find_struct_member id + | TUnion (id,_) -> + mem Env.find_union_member id + | _ -> false (* Move to the member named [name] of the current point, which must be a struct or a union. *) @@ -1173,6 +1203,9 @@ module I = struct | (fld, i as f_i) :: after -> if fld.fld_name = name then Some(Zstruct(z, id, before, fld, after), i) + else if fld.fld_anonymous && has_member env name fld.fld_typ then + let zi = (Zstruct(z, id, before, fld, after), i) in + member env zi name else find (f_i :: before) after in find [] flds @@ -1185,6 +1218,9 @@ module I = struct | fld1 :: rem -> if fld1.fld_name = name then Some(Zunion(z, id, fld1), default_init env fld1.fld_typ) + else if fld.fld_anonymous && has_member env name fld.fld_typ then + let zi = (Zunion(z, id, fld1),default_init env fld1.fld_typ) in + member env zi name else find rem in find (Env.find_union env id).ci_members @@ -1427,9 +1463,14 @@ let elab_expr vararg loc env a = | _ -> error "request for member '%s' in something not a structure or union" fieldname in (* A field of a const/volatile struct or union is itself const/volatile *) - { edesc = EUnop(Odot fieldname, b1); - etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) - (type_of_member env fld) },env + let rec access = function + | [] -> b1 + | fld::rest -> + let b1 = access rest in + { edesc = EUnop(Odot fld.fld_name, b1); + etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) + (type_of_member env fld) } in + access fld,env | MEMBEROFPTR(a1, fieldname) -> let b1,env = elab env a1 in @@ -1446,9 +1487,18 @@ let elab_expr vararg loc env a = end | _ -> error "member reference type %a is not a pointer" (print_typ env) b1.etyp in - { edesc = EUnop(Oarrow fieldname, b1); - etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) - (type_of_member env fld) },env + let rec access = function + | [] -> assert false + | [fld] -> + { edesc = EUnop(Oarrow fld.fld_name, b1); + etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) + (type_of_member env fld) } + | fld::rest -> + let b1 = access rest in + { edesc = EUnop(Odot fld.fld_name, b1); + etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) + (type_of_member env fld) } in + access fld,env (* Hack to treat vararg.h functions the GCC way. Helps with testing. va_start(ap,n) diff --git a/cparser/Env.ml b/cparser/Env.ml index b2a4e21c..5fa4571a 100644 --- a/cparser/Env.ml +++ b/cparser/Env.ml @@ -181,20 +181,42 @@ let find_union env id = 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 tag_id = function + | TStruct (id,_) + | TUnion (id,_) -> id + | _ -> assert false (* should be checked before *) + +let find_member env ci m = + let rec member acc = function + | [] -> raise Not_found + | f::rest -> if f.fld_name = m then + f::acc + else if f.fld_anonymous then + try + tag acc f + with Not_found -> + member acc rest + else + member acc rest + and tag acc fld = + let id = tag_id fld.fld_typ in + let ci = IdentMap.find id env.env_tag in + member (fld::acc) ci.ci_members + in + member [] ci let find_struct_member env (id, m) = try let ci = find_struct env id in - find_member ci.ci_members m + find_member env 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 + find_member env ci.ci_members m with Not_found -> raise(Error(No_member(id.name, "union", m))) diff --git a/cparser/Env.mli b/cparser/Env.mli index a794d4a4..7ea2c514 100644 --- a/cparser/Env.mli +++ b/cparser/Env.mli @@ -60,9 +60,8 @@ val ident_is_bound : t -> string -> bool val find_ident : t -> C.ident -> ident_info val find_struct : t -> C.ident -> composite_info val find_union : t -> C.ident -> composite_info -val find_member : C.field list -> string -> C.field -val find_struct_member : t -> C.ident * string -> C.field -val find_union_member : t -> C.ident * string -> C.field +val find_struct_member : t -> C.ident * string -> C.field list +val find_union_member : t -> C.ident * string -> C.field list val find_typedef : t -> C.ident -> typedef_info val find_enum : t -> C.ident -> enum_info diff --git a/cparser/Rename.ml b/cparser/Rename.ml index c1f31977..f402ea39 100644 --- a/cparser/Rename.ml +++ b/cparser/Rename.ml @@ -108,7 +108,8 @@ and param env (id, ty) = let field env f = { fld_name = f.fld_name; fld_typ = typ env f.fld_typ; - fld_bitfield = f.fld_bitfield } + fld_bitfield = f.fld_bitfield; + fld_anonymous = f.fld_anonymous; } let constant env = function | CEnum(id, v) -> CEnum(ident env id, v) |