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/Elab.ml | 79 +++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 25 deletions(-) (limited to 'cparser/Elab.ml') 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) -- 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/Elab.ml') 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/Elab.ml') 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/Elab.ml') 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/Elab.ml') 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