From 0c73ba202a910d5ab2ae900a56264fc1534f0214 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Wed, 7 Dec 2016 16:03:17 +0100 Subject: Next try for support of anonymous structs. Instead of using idents the anonymous fileds get names of the for _c where c is a counter of all anonymous members. Bug 20003 --- cparser/Bitfields.ml | 6 ++-- cparser/C.mli | 3 +- cparser/Cutil.ml | 9 +++--- cparser/Elab.ml | 79 +++++++++++++++++++++++++++++++++++----------------- cparser/Env.ml | 30 +++++++++++++++++--- cparser/Env.mli | 5 ++-- cparser/Rename.ml | 3 +- 7 files changed, 94 insertions(+), 41 deletions(-) (limited to 'cparser') 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 "__%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) -- cgit From 10c99650f3f696d6970a62861478ca6a021465b3 Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Dec 2016 13:05:41 +0100 Subject: Moved naming and changed names of aux functions The naming of anonymous structs is performed by an additional step in elab_struct_or_union_info instead of in elab_field_group. Also the aux functions are renamed to access. Bug 20003 --- cparser/Elab.ml | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) (limited to 'cparser') diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 6adbc679..866468ac 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -760,17 +760,15 @@ 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,_ = mmap (fun c id -> - match id with + let fieldlist = List.map (function | (None, x) -> - let name = Printf.sprintf "__%d" c in - (Name (name, JUSTBASE, [], loc), x,true),c+1 - | (Some n, x) -> (n, x,false),c) - 0 fieldlist + (Name ("", JUSTBASE, [], loc), x) + | (Some n, x) -> (n, x)) + fieldlist in let ((names, env'), sto) = - elab_name_group keep_ty loc env (spec, List.map (fun (a,_,_) -> a) fieldlist) in + elab_name_group keep_ty loc env (spec, List.map fst fieldlist) in if sto <> Storage_default then error loc "non-default storage in struct or union"; @@ -781,7 +779,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,nameless) (id, ty) = + let elab_bitfield (Name (_, _, _, loc), optbitsize) (id, ty) = let optbitsize' = match optbitsize with | None -> None @@ -818,9 +816,9 @@ and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = None end in let anon_composite = Cutil.is_anonymous_composite ty in - if nameless && not anon_composite && optbitsize = None then + 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_anonymous = nameless && anon_composite} + { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize'; fld_anonymous = id = "" && anon_composite} in (List.map2 elab_bitfield fieldlist names, env') @@ -829,6 +827,12 @@ 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 + let m,_ = mmap (fun c fld -> + if fld.fld_anonymous then + let name = Printf.sprintf "_%d" c in + {fld with fld_name = name},c+1 + else + fld,c) 0 m in let rec duplicate acc = function | [] -> () | fld::rest -> @@ -1442,14 +1446,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 *) - let rec aux = function + let rec access = function | [] -> b1 | fld::rest -> - let b1 = aux rest in + 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 - aux fld,env + access fld,env | MEMBEROFPTR(a1, fieldname) -> let b1,env = elab env a1 in @@ -1466,18 +1470,18 @@ let elab_expr vararg loc env a = end | _ -> error "member reference type %a is not a pointer" (print_typ env) b1.etyp in - let rec aux = function + 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 = aux rest in + 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 - aux fld,env + access fld,env (* Hack to treat vararg.h functions the GCC way. Helps with testing. va_start(ap,n) -- cgit From 5d8085e17db7ea39720d185564b46e72ac22058b Mon Sep 17 00:00:00 2001 From: Bernhard Schommer Date: Mon, 12 Dec 2016 13:41:55 +0100 Subject: Added code for initializers. Bug 20003 --- cparser/Elab.ml | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'cparser') diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 866468ac..72cac164 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1179,7 +1179,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 _ -> 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. *) @@ -1192,6 +1204,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 @@ -1204,6 +1219,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 -- cgit From 9ae11643d2faaeedce3c69925ff5089437ea4dff Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 26 Dec 2016 18:07:37 +0100 Subject: Cosmetic indentation change --- cparser/Elab.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'cparser') diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 72cac164..7b2c14e9 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -760,11 +760,10 @@ 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 = List.map + (function (None, x) -> (Name ("", JUSTBASE, [], loc), x) + | (Some n, x) -> (n, x)) + fieldlist in let ((names, env'), sto) = -- cgit From 860f28734063628f5582be91c7429b14f0922917 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 26 Dec 2016 18:09:57 +0100 Subject: Avoid exception catch-all "try ...; true with _ -> false" is dangerous if "..." raises unexpected exceptions such as Out_of_memory or Stack_overflow. --- cparser/Elab.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'cparser') diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 7b2c14e9..845fc210 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1184,7 +1184,7 @@ module I = struct let mem f id = try ignore(f env (id,name)); true - with _ -> false in + with Env.Error _ -> false in match ty with | TStruct (id,_) -> mem Env.find_struct_member id -- cgit