summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2013-10-13 10:02:52 +0000
committerGravatar xleroy <xleroy@fca1b0fc-160b-0410-b1d3-a4f43f01ea2e>2013-10-13 10:02:52 +0000
commit1d40928b2df6dd395c5c32a21f0ae41a56f74bea (patch)
treea177eddc6e7ec3d1fb9b65d98535815892f9ed64
parenta6c369cbd63996c1571ae601b7d92070f024b22c (diff)
PackedStructs.ml: cleanups and bug-fixes
Ceval.ml: tolerate non-zero integers with pointer types. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2343 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e
-rw-r--r--cparser/Ceval.ml2
-rw-r--r--cparser/PackedStructs.ml30
2 files changed, 17 insertions, 15 deletions
diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml
index 504f7e0..6fb0d37 100644
--- a/cparser/Ceval.ml
+++ b/cparser/Ceval.ml
@@ -272,7 +272,7 @@ let constant_expr env ty e =
try
match unroll env ty, cast env ty e.etyp (expr env e) with
| TInt(ik, _), I n -> Some(CInt(n, ik, ""))
- | TPtr(_, _), I 0L -> Some(CInt(0L, IInt, ""))
+ | TPtr(_, _), I n -> Some(CInt(n, IInt, ""))
| TPtr(_, _), S s -> Some(CStr s)
| TPtr(_, _), WS s -> Some(CWStr s)
| TEnum(_, _), I n -> Some(CInt(n, enum_ikind, ""))
diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml
index 5d0bac9..6d184a6 100644
--- a/cparser/PackedStructs.ml
+++ b/cparser/PackedStructs.ml
@@ -45,7 +45,7 @@ let safe_alignof loc env ty =
match alignof env ty with
| Some al -> al
| None ->
- error "%a: Error: incomplete type for a struct field" formatloc loc; 1
+ error "%aError: incomplete type for a struct field" formatloc loc; 1
(* Remove existing [_Alignas] attributes and add the given [_Alignas] attr. *)
@@ -58,13 +58,13 @@ let set_alignas_attr al attrs =
let transf_field_decl mfa swapped loc env struct_id f =
if f.fld_bitfield <> None then
- error "%a: Error: bitfields in packed structs not allowed"
+ error "%aError: bitfields in packed structs not allowed"
formatloc loc;
(* Register as byte-swapped if needed *)
if swapped then begin
let (can_swap, must_swap) = can_byte_swap env f.fld_typ in
if not can_swap then
- error "%a: Error: cannot byte-swap field of type '%a'"
+ error "%aError: cannot byte-swap field of type '%a'"
formatloc loc Cprint.typ f.fld_typ;
if must_swap then
Hashtbl.add byteswapped_fields (struct_id, f.fld_name) ()
@@ -143,22 +143,19 @@ let accessor_type loc env ty =
let ecast ty e = {edesc = ECast(ty, e); etyp = ty}
let ecast_opt env ty e =
- if compatible_types env ty e.etyp then e else ecast ty e
+ if compatible_types ~noattrs:true env ty e.etyp then e else ecast ty e
(* (ty) __builtin_readNN_reversed(&lval)
or (ty) __builtin_bswapNN(lval) *)
-let use_reversed =
- match !Machine.config.Machine.name with
- | "powerpc" -> true
- | _ -> false
+let use_reversed = ref false
let bswap_read loc env lval =
let ty = lval.etyp in
let (bsize, aty) = accessor_type loc env ty in
assert (bsize = 16 || bsize = 32);
try
- if use_reversed then begin
+ if !use_reversed then begin
let (id, fty) =
lookup_function loc env (sprintf "__builtin_read%d_reversed" bsize) in
let fn = {edesc = EVar id; etyp = fty} in
@@ -174,7 +171,7 @@ let bswap_read loc env lval =
ecast_opt env ty call
end
with Env.Error msg ->
- fatal_error "%a: Error: %s" formatloc loc (Env.error_message msg)
+ fatal_error "%aError: %s" formatloc loc (Env.error_message msg)
(* __builtin_write_intNN_reversed(&lhs,rhs)
or lhs = __builtin_bswapNN(rhs) *)
@@ -185,7 +182,7 @@ let bswap_write loc env lhs rhs =
accessor_type loc env ty in
assert (bsize = 16 || bsize = 32);
try
- if use_reversed then begin
+ if !use_reversed then begin
let (id, fty) =
lookup_function loc env (sprintf "__builtin_write%d_reversed" bsize) in
let fn = {edesc = EVar id; etyp = fty} in
@@ -201,7 +198,7 @@ let bswap_write loc env lhs rhs =
eassign lhs (ecast_opt env ty call)
end
with Env.Error msg ->
- fatal_error "%a: Error: %s" formatloc loc (Env.error_message msg)
+ fatal_error "%aError: %s" formatloc loc (Env.error_message msg)
(* Expressions *)
@@ -247,7 +244,7 @@ let transf_expr loc env ctx e =
| EUnop(Oaddrof, e1) ->
let (e1', swap) = lvalue e1 in
if swap then
- error "%a: Error: & over byte-swapped field" formatloc loc;
+ error "%aError: & over byte-swapped field" formatloc loc;
{edesc = EUnop(Oaddrof, e1'); etyp = e.etyp}
| EUnop((Opreincr|Opredecr) as op, e1) ->
@@ -345,7 +342,7 @@ let transf_init loc env i =
let n' = byteswap_int (sizeof_ikind ik) n in
Init_single {edesc = EConst(CInt(n', ik, "")); etyp = e.etyp}
| _ ->
- error "%a: Error: initializer for byte-swapped field is not \
+ error "%aError: initializer for byte-swapped field is not \
a compile-time integer constant" formatloc loc; i
end
| Init_array il ->
@@ -420,5 +417,10 @@ let rec transf_globdecls env accu = function
(* Program *)
let program p =
+ use_reversed :=
+ begin match !Machine.config.Machine.name with
+ | "powerpc" -> true
+ | _ -> false
+ end;
Hashtbl.clear byteswapped_fields;
transf_globdecls (Builtins.environment()) [] p