Merge pull request #153 from AbsInt/anonymous_struct2

Next try for support of anonymous structs.

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)