Bugs with 1- empty bitfields, 2- anonymous bitfields, 3- result type of reading a small unsigned bitfield

git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1496 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

5 files changed, 68 insertions, 15 deletions

diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml
index 2abe6b1..a345d97 100644
--- a/cparser/Bitfields.ml
+++ b/cparser/Bitfields.ml
@@ -31,7 +31,9 @@ type bitfield_info =
     bf_carrier_typ: typ; (* type of underlying regular field *)
     bf_pos: int;        (* start bit *)
     bf_size: int;       (* size in bit *)
-    bf_signed: bool }   (* signed or unsigned *)
+    bf_signed: bool;    (* is field signed or unsigned? *)
+    bf_signed_res: bool (* is result of extracting field signed or unsigned? *)
+  }
 
 (* invariants:
      0 <= pos < bitsizeof(int)
@@ -71,7 +73,11 @@ let pack_bitfields env id ml =
               match unroll env m.fld_typ with
               | TInt(ik, _) -> is_signed_ikind ik
               | _ -> assert false (* should never happen, checked in Elab *) in
-            pack ((m.fld_name, pos, n, signed) :: accu) (pos + n) ms
+            let signed2 =
+              match unroll env (type_of_member env m) with
+              | TInt(ik, _) -> is_signed_ikind ik
+              | _ -> assert false (* should never happen, checked in Elab *) in
+            pack ((m.fld_name, pos, n, signed, signed2) :: accu) (pos + n) ms
           end
   in pack [] 0 ml
 
@@ -85,11 +91,13 @@ let rec transf_members env id count = function
         let carrier = sprintf "__bf%d" count in
         let carrier_typ = TInt(unsigned_ikind_for_carrier nbits, []) in
         List.iter
-          (fun (name, pos, sz, signed) ->
-            Hashtbl.add bitfield_table
-              (id, name)
-              {bf_carrier = carrier; bf_carrier_typ = carrier_typ;
-               bf_pos = pos; bf_size = sz; bf_signed = signed})
+          (fun (name, pos, sz, signed, signed2) ->
+            if name <> "" then
+              Hashtbl.add bitfield_table
+                (id, name)
+                {bf_carrier = carrier; bf_carrier_typ = carrier_typ;
+                 bf_pos = pos; bf_size = sz;
+                 bf_signed = signed; bf_signed_res = signed2})
           bitfields;
         { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None}
         :: transf_members env id (count + 1) ml'
@@ -144,8 +152,13 @@ let bitfield_extract bf carrier =
   let ty = TInt((if bf.bf_signed then IInt else IUInt), []) in
   let e2 =
     {edesc = ECast(ty, e1); etyp = ty} in
-  {edesc = EBinop(Oshr, e2, right_shift_count bf, e2.etyp);
-   etyp = e2.etyp}
+  let e3 =
+    {edesc = EBinop(Oshr, e2, right_shift_count bf, e2.etyp);
+     etyp = ty} in
+  if bf.bf_signed_res = bf.bf_signed then e3 else begin
+    let ty' = TInt((if bf.bf_signed_res then IInt else IUInt), []) in
+    {edesc = ECast(ty', e3); etyp = ty'}
+  end
 
 (* Assign a bitfield within a carrier *)
 
diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml
index 2dc1a91..8f89b91 100644
--- a/cparser/Cabshelper.ml
+++ b/cparser/Cabshelper.ml
@@ -42,7 +42,7 @@ let cabslu = {lineno = -10;
 
 (*********** HELPER FUNCTIONS **********)
 
-let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu)
+let missingFieldDecl = ("", JUSTBASE, [], cabslu)
 
 let rec isStatic = function
     [] -> false
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index c7c5e30..cb241e5 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -409,6 +409,16 @@ let unsigned_ikind_of = function
   | ILong | IULong -> IULong
   | ILongLong | IULongLong -> IULongLong
 
+(* Conversion to signed ikind *)
+
+let signed_ikind_of = function
+  | IBool -> IBool
+  | IChar | ISChar | IUChar -> ISChar
+  | IInt | IUInt -> IInt
+  | IShort | IUShort -> IShort
+  | ILong | IULong -> ILong
+  | ILongLong | IULongLong -> ILongLong
+
 (* Some classification functions over types *)
 
 let is_void_type env t =
@@ -559,6 +569,22 @@ let pointer_arithmetic_ok env ty =
   | TVoid _ | TFun _ -> false
   | _ -> not (incomplete_type env ty)
 
+(** The type of [x.fld].  Normally, it's the type of the field [fld],
+  but if it is an unsigned bitfield of size < length of its type,
+  its type is the corresponding signed int. *)
+
+let type_of_member env fld =
+  match fld.fld_bitfield with
+  | None -> fld.fld_typ
+  | Some w ->
+      match unroll env fld.fld_typ with
+      | TInt(ik, attr) ->
+          if w < sizeof_ikind ik * 8
+          then TInt(signed_ikind_of ik, attr)
+          else fld.fld_typ
+      | _ ->
+          assert false
+
 (** Special types *)
 
 let find_matching_unsigned_ikind sz =
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index 2e61cf5..7a185f5 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -93,6 +93,9 @@ val is_signed_ikind : ikind -> bool
 val unsigned_ikind_of : ikind -> ikind
   (* Return the unsigned integer kind corresponding to the given
      integer kind. *)
+val signed_ikind_of : ikind -> ikind
+  (* Return the signed integer kind corresponding to the given
+     integer kind. *)
 val integer_rank : ikind -> int
   (* Order integer kinds from smaller to bigger *)
 val float_rank : fkind -> int
@@ -135,6 +138,10 @@ val ptrdiff_t_ikind : ikind
 
 val type_of_constant : constant -> typ
   (* Return the type of the given constant. *)
+val type_of_member : Env.t -> field -> typ
+  (* Return the type of accessing the given field [fld].
+     Normally it's [fld.fld_type] but there is a special case for
+     small unsigned bitfields. *)
 val is_literal_0 : exp -> bool
   (* Is the given expression the integer literal "0"?  *)
 val is_lvalue : Env.t -> exp -> bool
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 9a4639f..b3e375c 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -547,16 +547,20 @@ and elab_field_group env (spec, fieldlist) =
           match Ceval.integer_expr env' (!elab_expr_f loc env sz) with
           | Some n ->
               if n < 0L then begin
-                error loc "bit size of member (%Ld) is negative" n;
+                error loc "bit size of member %s (%Ld) is negative" id n;
                 None
               end else
               if n > Int64.of_int(sizeof_ikind ik * 8) then begin
-                error loc "bit size of member (%Ld) is too large" n;
+                error loc "bit size of member %s (%Ld) is too large" id n;
+                None
+              end else
+              if n = 0L && id <> "" then begin
+                error loc "member %s has zero size" id;
                 None
               end else
                 Some(Int64.to_int n)
           | None ->
-              error loc "bit size of member is not a compile-time constant";
+              error loc "bit size of member %s is not a compile-time constant" id;
               None in
     { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' } 
   in
@@ -735,7 +739,7 @@ let elab_expr loc env a =
             error "left-hand side of '.' is not a struct or union" in
       (* A field of a const/volatile struct or union is itself const/volatile *)
       { edesc = EUnop(Odot fieldname, b1);
-        etyp = add_attributes_type attrs fld.fld_typ }
+        etyp = add_attributes_type attrs (type_of_member env fld) }
 
   | MEMBEROFPTR(a1, fieldname) ->
       let b1 = elab a1 in
@@ -753,7 +757,7 @@ let elab_expr loc env a =
         | _ ->
             error "left-hand side of '->' is not a pointer " in
       { edesc = EUnop(Oarrow fieldname, b1);
-        etyp = add_attributes_type attrs fld.fld_typ }
+        etyp = add_attributes_type attrs (type_of_member env fld) }
 
 (* Hack to treat vararg.h functions the GCC way.  Helps with testing.
     va_start(ap,n)
@@ -1324,6 +1328,9 @@ let rec elab_init loc env ty ile =
         match fld with
         | [] -> 
             (Init_struct(id, List.rev accu), rem)
+        | {fld_name = ""} :: fld' ->
+            (* anonymous bitfields consume no initializer *)
+            elab_init_fields fld' accu rem
         | fld1 :: fld' ->
             let (i, rem') = elab_init loc env fld1.fld_typ rem in
             elab_init_fields fld' ((fld1, i) :: accu) rem' in