diff options
author | Bernhard Schommer <bernhardschommer@gmail.com> | 2016-12-07 16:03:17 +0100 |
---|---|---|
committer | Bernhard Schommer <bernhardschommer@gmail.com> | 2016-12-07 16:03:17 +0100 |
commit | 0c73ba202a910d5ab2ae900a56264fc1534f0214 (patch) | |
tree | 0e7fe704111bec0404916c3b88d02138fadc9b32 /cparser | |
parent | 680444f180c750078a77b0591cd5c19e632612d6 (diff) | |
download | compcert-0c73ba202a910d5ab2ae900a56264fc1534f0214.tar.gz compcert-0c73ba202a910d5ab2ae900a56264fc1534f0214.zip |
Next try for support of anonymous structs.
Instead of using idents the anonymous fileds get names of the
for <anon>_c where c is a counter of all anonymous members.
Bug 20003
Diffstat (limited to 'cparser')
-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 | 79 | ||||
-rw-r--r-- | cparser/Env.ml | 30 | ||||
-rw-r--r-- | cparser/Env.mli | 5 | ||||
-rw-r--r-- | cparser/Rename.ml | 3 |
7 files changed, 94 insertions, 41 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..6adbc679 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -760,15 +760,17 @@ 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)) - fieldlist + let fieldlist,_ = mmap (fun c id -> + match id with + | (None, x) -> + let name = Printf.sprintf "<anon>__%d" c in + (Name (name, JUSTBASE, [], loc), x,true),c+1 + | (Some n, x) -> (n, x,false),c) + 0 fieldlist in let ((names, env'), sto) = - elab_name_group keep_ty loc env (spec, List.map fst fieldlist) in + elab_name_group keep_ty loc env (spec, List.map (fun (a,_,_) -> a) fieldlist) in if sto <> Storage_default then error loc "non-default storage in struct or union"; @@ -779,7 +781,7 @@ and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = (* This should actually never be triggered, empty structs are captured earlier *) warning loc Missing_declarations "declaration does not declare anything"; - let elab_bitfield (Name (_, _, _, loc), optbitsize) (id, ty) = + let elab_bitfield (Name (_, _, _, loc), optbitsize,nameless) (id, ty) = let optbitsize' = match optbitsize with | None -> None @@ -815,9 +817,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 nameless && 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 = nameless && anon_composite} in (List.map2 elab_bitfield fieldlist names, env') @@ -826,16 +829,28 @@ 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 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 | [] -> () @@ -1427,9 +1442,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 aux = function + | [] -> b1 + | fld::rest -> + let b1 = aux 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 + aux fld,env | MEMBEROFPTR(a1, fieldname) -> let b1,env = elab env a1 in @@ -1446,9 +1466,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 aux = 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 = aux 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 + aux 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) |