summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Changelog2
-rw-r--r--cfrontend/C2C.ml2
-rw-r--r--cparser/Bitfields.ml2
-rw-r--r--cparser/C.mli51
-rw-r--r--cparser/Ceval.ml2
-rw-r--r--cparser/Cleanup.ml3
-rw-r--r--cparser/Cprint.ml6
-rw-r--r--cparser/Cutil.ml1
-rw-r--r--cparser/Elab.ml781
-rw-r--r--cparser/PackedStructs.ml6
-rw-r--r--cparser/Rename.ml21
-rw-r--r--cparser/StructReturn.ml4
-rw-r--r--cparser/Unblock.ml201
-rw-r--r--test/regression/Makefile2
-rw-r--r--test/regression/Results/compound25
-rw-r--r--test/regression/compound.c146
16 files changed, 801 insertions, 454 deletions
diff --git a/Changelog b/Changelog
index c497f68..18545bd 100644
--- a/Changelog
+++ b/Changelog
@@ -32,6 +32,8 @@
- Value analysis and constant propagation: more precise treatment of
comparisons against an integer constant.
+- Language features: support C99 compound literals.
+
Release 2.3pl2, 2014-05-15
==========================
diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index b8586e0..ffea5a8 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -588,6 +588,8 @@ let rec convertExpr env e =
Econdition(convertExpr env e1, convertExpr env e2, convertExpr env e3, ty)
| C.ECast(ty1, e1) ->
Ecast(convertExpr env e1, convertTyp env ty1)
+ | C.ECompound(ty1, ie) ->
+ unsupported "compound literals"; ezero
| C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) ->
begin match args with
diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml
index 14c9314..99b93c2 100644
--- a/cparser/Bitfields.ml
+++ b/cparser/Bitfields.ml
@@ -315,6 +315,8 @@ let transf_expr env ctx e =
etyp = e.etyp}
| ECast(ty, e1) ->
{edesc = ECast(ty, texp Val e1); etyp = e.etyp}
+ | ECompound _ ->
+ assert false (* does not occur in unblocked code *)
| ECall(e1, el) ->
{edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp}
diff --git a/cparser/C.mli b/cparser/C.mli
index b1e44eb..71ab1d4 100644
--- a/cparser/C.mli
+++ b/cparser/C.mli
@@ -25,7 +25,7 @@ type ident =
{ name: string; (* name as in the source *)
stamp: int } (* unique ID *)
-(* kinds of integers *)
+(* Kinds of integers *)
type ikind =
| IBool (** [_Bool] *)
@@ -153,6 +153,18 @@ type typ =
| TUnion of ident * attributes
| TEnum of ident * attributes
+(** Struct or union field *)
+
+type field = {
+ fld_name: string;
+ fld_typ: typ;
+ fld_bitfield: int option
+}
+
+type struct_or_union =
+ | Struct
+ | Union
+
(** Expressions *)
type exp = { edesc: exp_desc; etyp: typ }
@@ -167,8 +179,17 @@ and exp_desc =
(* the type at which the operation is performed *)
| EConditional of exp * exp * exp
| ECast of typ * exp
+ | ECompound of typ * init
| ECall of exp * exp list
+(** Initializers *)
+
+and init =
+ | Init_single of exp
+ | Init_array of init list
+ | Init_struct of ident * (field * init) list
+ | Init_union of ident * field * init
+
(** Statements *)
type stmt = { sdesc: stmt_desc; sloc: location }
@@ -201,30 +222,6 @@ and slabel =
and decl =
storage * ident * typ * init option
-(** Initializers *)
-
-and init =
- | Init_single of exp
- | Init_array of init list
- | Init_struct of ident * (field * init) list
- | Init_union of ident * field * init
-
-(** Struct or union field *)
-
-and field = {
- fld_name: string;
- fld_typ: typ;
- fld_bitfield: int option
-}
-
-type struct_or_union =
- | Struct
- | Union
-
-(** Enumerator *)
-
-type enumerator = ident * int64 * exp option
-
(** Function definitions *)
type fundef = {
@@ -239,6 +236,10 @@ type fundef = {
fd_body: stmt
}
+(** Element of an enumeration *)
+
+type enumerator = ident * int64 * exp option
+
(** Global declarations *)
type globdecl =
diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml
index 6fb0d37..39cda58 100644
--- a/cparser/Ceval.ml
+++ b/cparser/Ceval.ml
@@ -258,6 +258,8 @@ let rec expr env e =
(* | ECast(TInt (_, _), EConst (CFloat (_, _))) -> TODO *)
| ECast(ty, e1) ->
cast env ty e1.etyp (expr env e1)
+ | ECompound _ ->
+ raise Notconst
| ECall _ ->
raise Notconst
diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml
index 09595a1..09eaff9 100644
--- a/cparser/Cleanup.ml
+++ b/cparser/Cleanup.ml
@@ -65,9 +65,10 @@ let rec add_exp e =
| EBinop(op, e1, e2, ty) -> add_exp e1; add_exp e2
| EConditional(e1, e2, e3) -> add_exp e1; add_exp e2; add_exp e3
| ECast(ty, e1) -> add_typ ty; add_exp e1
+ | ECompound(ty, ie) -> add_typ ty; add_init ie
| ECall(e1, el) -> add_exp e1; List.iter add_exp el
-let rec add_init = function
+and add_init = function
| Init_single e -> add_exp e
| Init_array il -> List.iter add_init il
| Init_struct(id, il) -> addref id; List.iter (fun (_, i) -> add_init i) il
diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml
index f26025e..ee8002d 100644
--- a/cparser/Cprint.ml
+++ b/cparser/Cprint.ml
@@ -191,7 +191,7 @@ let precedence = function (* H&S section 7.2 *)
| EUnop((Odot _|Oarrow _), _) -> (16, LtoR)
| EUnop((Opostincr|Opostdecr), _) -> (16, LtoR)
| EUnop((Opreincr|Opredecr|Onot|Olognot|Ominus|Oplus|Oaddrof|Oderef), _) -> (15, RtoL)
- | ECast _ -> (14, RtoL)
+ | ECast _ | ECompound _ -> (14, RtoL)
| EBinop((Omul|Odiv|Omod), _, _, _) -> (13, LtoR)
| EBinop((Oadd|Osub), _, _, _) -> (12, LtoR)
| EBinop((Oshl|Oshr), _, _, _) -> (11, LtoR)
@@ -310,6 +310,8 @@ let rec exp pp (prec, a) =
fprintf pp "%a@ ? %a@ : %a" exp (4, a1) exp (4, a2) exp (4, a3)
| ECast(ty, a1) ->
fprintf pp "(%a) %a" typ ty exp (prec', a1)
+ | ECompound(ty, i) ->
+ fprintf pp "(%a) %a" typ ty init i
| ECall({edesc = EVar {name = "__builtin_va_start"}},
[a1; {edesc = EUnop(Oaddrof, a2)}]) ->
fprintf pp "__builtin_va_start@[<hov 1>(%a,@ %a)@]"
@@ -330,7 +332,7 @@ let rec exp pp (prec, a) =
end;
if prec' < prec then fprintf pp ")@]" else fprintf pp "@]"
-let rec init pp = function
+and init pp = function
| Init_single e ->
exp pp (2, e)
| Init_array il ->
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index 1169346..9ad0b13 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -714,6 +714,7 @@ let rec is_lvalue e =
| EUnop((Oderef | Oarrow _), _) -> true
| EUnop(Odot _, e') -> is_lvalue e'
| EBinop(Oindex, _, _, _) -> true
+ | ECompound _ -> true
| _ -> false
(* Check that a C expression is a modifiable l-value: an l-value
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index a352e5f..c4057e6 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -789,6 +789,389 @@ let elab_type loc env spec decl =
ty
+(* Elaboration of initializers. C99 section 6.7.8 *)
+
+let init_char_array_string opt_size s =
+ let len = Int64.of_int (String.length s) in
+ let size =
+ match opt_size with
+ | Some sz -> sz
+ | None -> Int64.succ len (* include final 0 character *) in
+ let rec add_chars i init =
+ if i < 0L then init else begin
+ let c =
+ if i < len then Int64.of_int (Char.code s.[Int64.to_int i]) else 0L in
+ add_chars (Int64.pred i) (Init_single (intconst c IInt) :: init)
+ end in
+ Init_array (add_chars (Int64.pred size) [])
+
+let init_int_array_wstring opt_size s =
+ let len = Int64.of_int (List.length s) in
+ let size =
+ match opt_size with
+ | Some sz -> sz
+ | None -> Int64.succ len (* include final 0 character *) in
+ let rec add_chars i s init =
+ if i < 0L then init else begin
+ let (c, s') =
+ match s with [] -> (0L, []) | c::s' -> (c, s') in
+ add_chars (Int64.pred i) s' (Init_single (intconst c IInt) :: init)
+ end in
+ Init_array (add_chars (Int64.pred size) (List.rev s) [])
+
+let check_init_type loc env a ty =
+ if valid_assignment env a ty then ()
+ else if valid_cast env a.etyp ty then
+ warning loc
+ "initializer has type@ %a@ instead of the expected type @ %a"
+ Cprint.typ a.etyp Cprint.typ ty
+ else
+ error loc
+ "initializer has type@ %a@ instead of the expected type @ %a"
+ Cprint.typ a.etyp Cprint.typ ty
+
+(* Representing initialization state using zippers *)
+
+module I = struct
+
+ type zipinit =
+ | Ztop of string * typ
+
+ | Zarray of zipinit (* ancestor *)
+ * typ (* type of elements *)
+ * int64 option (* size *)
+ * init (* default initializer *)
+ * init list (* elements before point, reversed *)
+ * int64 (* position of point *)
+ * init list (* elements after point *)
+
+ | Zstruct of zipinit (* ancestor *)
+ * ident (* struct type *)
+ * (field * init) list (* elements before current, reversed *)
+ * field (* current field *)
+ * (field * init) list (* elements after current *)
+
+ | Zunion of zipinit (* ancestor *)
+ * ident (* union type *)
+ * field (* current member *)
+
+ type state = zipinit * init (* current point & init for this point *)
+
+ (* The initial state: default initialization, current point at top *)
+ let top env name ty = (Ztop(name, ty), default_init env ty)
+
+ (* Change the initializer for the current point *)
+ let set (z, i) i' = (z, i')
+
+ (* Put the current point back to the top *)
+ let rec to_top = function
+ | Ztop(name, ty), i as zi -> zi
+ | Zarray(z, ty, sz, dfl, before, idx, after), i ->
+ to_top (z, Init_array (List.rev_append before (i :: after)))
+ | Zstruct(z, id, before, fld, after), i ->
+ to_top (z, Init_struct(id, List.rev_append before ((fld, i) :: after)))
+ | Zunion(z, id, fld), i ->
+ to_top (z, Init_union(id, fld, i))
+
+ (* Extract the initializer corresponding to the current state *)
+ let to_init zi = snd (to_top zi)
+
+ (* The type of the current point *)
+ let typeof = function
+ | Ztop(name, ty), i -> ty
+ | Zarray(z, ty, sz, dfl, before, idx, after), i -> ty
+ | Zstruct(z, id, before, fld, after), i -> fld.fld_typ
+ | Zunion(z, id, fld), i -> fld.fld_typ
+
+ (* The name of the path leading to the current point, for error reporting *)
+ let rec zipname = function
+ | Ztop(name, ty) -> name
+ | Zarray(z, ty, sz, dfl, before, idx, after) ->
+ sprintf "%s[%Ld]" (zipname z) idx
+ | Zstruct(z, id, before, fld, after) ->
+ sprintf "%s.%s" (zipname z) fld.fld_name
+ | Zunion(z, id, fld) ->
+ sprintf "%s.%s" (zipname z) fld.fld_name
+
+ let name (z, i) = zipname z
+
+ (* Auxiliary functions to deal with arrays *)
+ let index_below (idx: int64) (sz: int64 option) =
+ match sz with None -> true | Some sz -> idx < sz
+
+ let il_head dfl = function [] -> dfl | i1 :: il -> i1
+ let il_tail = function [] -> [] | i1 :: il -> il
+
+ (* Advance the current point to the next point in right-up order.
+ Return None if no next point, i.e. we are at top *)
+ let rec next = function
+ | Ztop(name, ty), i -> None
+ | Zarray(z, ty, sz, dfl, before, idx, after), i ->
+ let idx' = Int64.succ idx in
+ if index_below idx' sz
+ then Some(Zarray(z, ty, sz, dfl, i :: before, idx', il_tail after),
+ il_head dfl after)
+ else next (z, Init_array (List.rev_append before (i :: after)))
+ | Zstruct(z, id, before, fld, []), i ->
+ next (z, Init_struct(id, List.rev_append before [(fld, i)]))
+ | Zstruct(z, id, before, fld, (fld1, i1) :: after), i ->
+ Some(Zstruct(z, id, (fld, i) :: before, fld1, after), i1)
+ | Zunion(z, id, fld), i ->
+ next (z, Init_union(id, fld, i))
+
+ (* Move the current point "down" to the first component of an array,
+ struct, or union. No effect if the current point is a scalar. *)
+ let rec first env (z, i as zi) =
+ let ty = typeof zi in
+ match unroll env ty, i with
+ | TArray(ty, sz, _), Init_array il ->
+ if index_below 0L sz then begin
+ let dfl = default_init env ty in
+ Some(Zarray(z, ty, sz, dfl, [], 0L, il_tail il), il_head dfl il)
+ end
+ else None
+ | TStruct(id, _), Init_struct(id', []) ->
+ None
+ | TStruct(id, _), Init_struct(id', (fld1, i1) :: flds) ->
+ Some(Zstruct(z, id, [], fld1, flds), i1)
+ | TUnion(id, _), Init_union(id', fld, i) ->
+ begin match (Env.find_union env id).ci_members with
+ | [] -> None
+ | fld1 :: _ ->
+ Some(Zunion(z, id, fld1),
+ if fld.fld_name = fld1.fld_name
+ then i
+ else default_init env fld1.fld_typ)
+ end
+ | (TStruct _ | TUnion _), Init_single a ->
+ (* This is a previous whole-struct initialization that we
+ are going to overwrite. Revert to the default initializer. *)
+ first env (z, default_init env ty)
+ | _ ->
+ Some (z, i)
+
+ (* Move to the [n]-th element of the current point, which must be
+ an array. *)
+ let index env (z, i as zi) n =
+ match unroll env (typeof zi), i with
+ | TArray(ty, sz, _), Init_array il ->
+ if n >= 0L && index_below n sz then begin
+ let dfl = default_init env ty in
+ let rec loop p before after =
+ if p = n then
+ Some(Zarray(z, ty, sz, dfl, before, n, il_tail after),
+ il_head dfl after)
+ else
+ loop (Int64.succ p)
+ (il_head dfl after :: before)
+ (il_tail after)
+ in loop 0L [] il
+ end else
+ None
+ | _, _ ->
+ None
+
+ (* Move to the member named [name] of the current point, which must be
+ a struct or a union. *)
+ let rec member env (z, i as zi) name =
+ let ty = typeof zi in
+ match unroll env ty, i with
+ | TStruct(id, _), Init_struct(id', flds) ->
+ let rec find before = function
+ | [] -> None
+ | (fld, i as f_i) :: after ->
+ if fld.fld_name = name then
+ Some(Zstruct(z, id, before, fld, after), i)
+ else
+ find (f_i :: before) after
+ in find [] flds
+ | TUnion(id, _), Init_union(id', fld, i) ->
+ if fld.fld_name = name then
+ Some(Zunion(z, id, fld), i)
+ else begin
+ let rec find = function
+ | [] -> None
+ | fld1 :: rem ->
+ if fld1.fld_name = name then
+ Some(Zunion(z, id, fld1), default_init env fld1.fld_typ)
+ else
+ find rem
+ in find (Env.find_union env id).ci_members
+ end
+ | (TStruct _ | TUnion _), Init_single a ->
+ member env (z, default_init env ty) name
+ | _, _ ->
+ None
+end
+
+(* Interpret the given designator, moving the initialization state [zi]
+ "down" accordingly. *)
+
+let rec elab_designator loc env zi desig =
+ match desig with
+ | [] ->
+ zi
+ | INFIELD_INIT name :: desig' ->
+ begin match I.member env zi name with
+ | Some zi' ->
+ elab_designator loc env zi' desig'
+ | None ->
+ error loc "%s has no member named %s" (I.name zi) name;
+ raise Exit
+ end
+ | ATINDEX_INIT a :: desig' ->
+ begin match Ceval.integer_expr env (!elab_expr_f loc env a) with
+ | None ->
+ error loc "array element designator for %s is not a compile-time constant"
+ (I.name zi);
+ raise Exit
+ | Some n ->
+ match I.index env zi n with
+ | Some zi' ->
+ elab_designator loc env zi' desig'
+ | None ->
+ error loc "bad array element designator %Ld within %s"
+ n (I.name zi);
+ raise Exit
+ end
+
+(* Elaboration of an initialization expression. Return the corresponding
+ initializer. *)
+
+let elab_init loc env root ty_root ie =
+
+(* Perform the initializations described by the list [il] over
+ the initialization state [zi]. [first] is true if we are at the
+ beginning of a braced initializer. Returns the final initializer. *)
+
+let rec elab_list zi il first =
+ match il with
+ | [] ->
+ (* All initialization items consumed. *)
+ I.to_init zi
+ | (desig, item) :: il' ->
+ if desig = [] then begin
+ match (if first then I.first env zi else I.next zi)
+ with
+ | None ->
+ warning loc "excess elements at end of initializer for %s, ignored"
+ (I.name zi);
+ I.to_init zi
+ | Some zi' ->
+ elab_item zi' item il'
+ end else
+ elab_item (elab_designator loc env (I.to_top zi) desig) item il'
+
+(* Perform the initialization described by [item] for the current
+ subobject of state [zi]. Continue initializing with the list [il]. *)
+
+and elab_item zi item il =
+ let ty = I.typeof zi in
+ match item, unroll env ty with
+ (* Special case char array = "string literal"
+ or wchar array = L"wide string literal" *)
+ | (SINGLE_INIT (CONSTANT (CONST_STRING(w, s)))
+ | COMPOUND_INIT [_, SINGLE_INIT(CONSTANT (CONST_STRING(w, s)))]),
+ TArray(ty_elt, sz, _)
+ when is_integer_type env ty_elt ->
+ begin match elab_string_literal loc w s, unroll env ty_elt with
+ | CStr s, TInt((IChar | ISChar | IUChar), _) ->
+ if not (I.index_below (Int64.of_int(String.length s - 1)) sz) then
+ warning loc "initializer string for array of chars %s is too long"
+ (I.name zi);
+ elab_list (I.set zi (init_char_array_string sz s)) il false
+ | CStr _, _ ->
+ error loc "initialization of an array of non-char elements with a string literal";
+ elab_list zi il false
+ | CWStr s, TInt(ik, _) when ik = wchar_ikind ->
+ if not (I.index_below (Int64.of_int(List.length s - 1)) sz) then
+ warning loc "initializer string for array of wide chars %s is too long"
+ (I.name zi);
+ elab_list (I.set zi (init_int_array_wstring sz s)) il false
+ | CWStr _, _ ->
+ error loc "initialization of an array of non-wchar_t elements with a wide string literal";
+ elab_list zi il false
+ | _ -> assert false
+ end
+ (* Brace-enclosed compound initializer *)
+ | COMPOUND_INIT il', _ ->
+ (* Process the brace-enclosed stuff, obtaining its initializer *)
+ let ini' = elab_list (I.top env (I.name zi) ty) il' true in
+ (* Initialize current subobject with this state, and continue *)
+ elab_list (I.set zi ini') il false
+ (* Single expression *)
+ | SINGLE_INIT a, _ ->
+ let a' = !elab_expr_f loc env a in
+ elab_single zi a' il
+ (* No initializer: can this happen? *)
+ | NO_INIT, _ ->
+ elab_list zi il false
+
+(* Perform initialization by a single expression [a] for the current
+ subobject of state [zi], Continue initializing with the list [il']. *)
+
+and elab_single zi a il =
+ let ty = I.typeof zi in
+ match unroll env ty with
+ | TInt _ | TEnum _ | TFloat _ | TPtr _ ->
+ (* This is a scalar: do direct initialization and continue *)
+ check_init_type loc env a ty;
+ elab_list (I.set zi (Init_single a)) il false
+ | TStruct _ | TUnion _ when compatible_types ~noattrs:true env ty a.etyp ->
+ (* This is a composite that can be initialized directly
+ from the expression: do as above *)
+ elab_list (I.set zi (Init_single a)) il false
+ | TStruct _ | TUnion _ | TArray _ ->
+ (* This is an aggregate: we need to drill into it, recursively *)
+ begin match I.first env zi with
+ | Some zi' ->
+ elab_single zi' a il
+ | None ->
+ error loc "initializer for aggregate %s with no elements requires explicit braces"
+ (I.name zi);
+ raise Exit
+ end
+ | _ ->
+ error loc "impossible to initialize %s of type@ %a"
+ (I.name zi) Cprint.typ ty;
+ raise Exit
+
+(* Start with top-level object initialized to default *)
+
+in elab_item (I.top env root ty_root) ie []
+
+(* Elaboration of a top-level initializer *)
+
+let elab_initial loc env root ty ie =
+ match ie with
+ | NO_INIT -> None
+ | _ ->
+ try
+ Some (elab_init loc env root ty ie)
+ with
+ | Exit -> None (* error was already reported *)
+ | Env.Error msg -> error loc "%s" (Env.error_message msg); None
+
+(* Complete an array type with the size obtained from the initializer:
+ "int x[] = { 1, 2, 3 }" becomes "int x[3] = ..." *)
+
+let fixup_typ loc env ty init =
+ match unroll env ty, init with
+ | TArray(ty_elt, None, attr), Init_array il ->
+ if il = [] then warning loc "array of size 0";
+ TArray(ty_elt, Some(Int64.of_int(List.length il)), attr)
+ | _ -> ty
+
+(* Entry point *)
+
+let elab_initializer loc env root ty ie =
+ match elab_initial loc env root ty ie with
+ | None ->
+ (ty, None)
+ | Some init ->
+ (fixup_typ loc env ty init, Some init)
+
+
(* Elaboration of expressions *)
let elab_expr loc env a =
@@ -923,7 +1306,7 @@ let elab_expr loc env a =
| UNARY(POSDECR, a1) ->
elab_pre_post_incr_decr Opostdecr "postfix '--'" a1
-(* 6.5.3 Unary expressions *)
+(* 6.5.4 Cast operators *)
| CAST ((spec, dcl), SINGLE_INIT a1) ->
let ty = elab_type loc env spec dcl in
@@ -932,11 +1315,16 @@ let elab_expr loc env a =
err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty;
{ edesc = ECast(ty, b1); etyp = ty }
- | CAST ((spec, dcl), _) ->
- err "compound literals are not supported";
- (* continue with dummy expression of the correct type *)
+(* 6.5.2.5 Compound literals *)
+
+ | CAST ((spec, dcl), ie) ->
let ty = elab_type loc env spec dcl in
- { edesc = ECast(ty, nullconst); etyp = ty }
+ begin match elab_initializer loc env "<compound literal>" ty ie with
+ | (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' }
+ | (ty', None) -> error "ill-formed compound literal"
+ end
+
+(* 6.5.3 Unary expressions *)
| EXPR_SIZEOF a1 ->
let b1 = elab a1 in
@@ -1328,389 +1716,6 @@ let elab_for_expr loc env = function
| None -> { sdesc = Sskip; sloc = elab_loc loc }
| Some a -> { sdesc = Sdo (elab_expr loc env a); sloc = elab_loc loc }
-
-(* Elaboration of initializers. C99 section 6.7.8 *)
-
-let init_char_array_string opt_size s =
- let len = Int64.of_int (String.length s) in
- let size =
- match opt_size with
- | Some sz -> sz
- | None -> Int64.succ len (* include final 0 character *) in
- let rec add_chars i init =
- if i < 0L then init else begin
- let c =
- if i < len then Int64.of_int (Char.code s.[Int64.to_int i]) else 0L in
- add_chars (Int64.pred i) (Init_single (intconst c IInt) :: init)
- end in
- Init_array (add_chars (Int64.pred size) [])
-
-let init_int_array_wstring opt_size s =
- let len = Int64.of_int (List.length s) in
- let size =
- match opt_size with
- | Some sz -> sz
- | None -> Int64.succ len (* include final 0 character *) in
- let rec add_chars i s init =
- if i < 0L then init else begin
- let (c, s') =
- match s with [] -> (0L, []) | c::s' -> (c, s') in
- add_chars (Int64.pred i) s' (Init_single (intconst c IInt) :: init)
- end in
- Init_array (add_chars (Int64.pred size) (List.rev s) [])
-
-let check_init_type loc env a ty =
- if valid_assignment env a ty then ()
- else if valid_cast env a.etyp ty then
- warning loc
- "initializer has type@ %a@ instead of the expected type @ %a"
- Cprint.typ a.etyp Cprint.typ ty
- else
- error loc
- "initializer has type@ %a@ instead of the expected type @ %a"
- Cprint.typ a.etyp Cprint.typ ty
-
-(* Representing initialization state using zippers *)
-
-module I = struct
-
- type zipinit =
- | Ztop of string * typ
-
- | Zarray of zipinit (* ancestor *)
- * typ (* type of elements *)
- * int64 option (* size *)
- * init (* default initializer *)
- * init list (* elements before point, reversed *)
- * int64 (* position of point *)
- * init list (* elements after point *)
-
- | Zstruct of zipinit (* ancestor *)
- * ident (* struct type *)
- * (field * init) list (* elements before current, reversed *)
- * field (* current field *)
- * (field * init) list (* elements after current *)
-
- | Zunion of zipinit (* ancestor *)
- * ident (* union type *)
- * field (* current member *)
-
- type state = zipinit * init (* current point & init for this point *)
-
- (* The initial state: default initialization, current point at top *)
- let top env name ty = (Ztop(name, ty), default_init env ty)
-
- (* Change the initializer for the current point *)
- let set (z, i) i' = (z, i')
-
- (* Put the current point back to the top *)
- let rec to_top = function
- | Ztop(name, ty), i as zi -> zi
- | Zarray(z, ty, sz, dfl, before, idx, after), i ->
- to_top (z, Init_array (List.rev_append before (i :: after)))
- | Zstruct(z, id, before, fld, after), i ->
- to_top (z, Init_struct(id, List.rev_append before ((fld, i) :: after)))
- | Zunion(z, id, fld), i ->
- to_top (z, Init_union(id, fld, i))
-
- (* Extract the initializer corresponding to the current state *)
- let to_init zi = snd (to_top zi)
-
- (* The type of the current point *)
- let typeof = function
- | Ztop(name, ty), i -> ty
- | Zarray(z, ty, sz, dfl, before, idx, after), i -> ty
- | Zstruct(z, id, before, fld, after), i -> fld.fld_typ
- | Zunion(z, id, fld), i -> fld.fld_typ
-
- (* The name of the path leading to the current point, for error reporting *)
- let rec zipname = function
- | Ztop(name, ty) -> name
- | Zarray(z, ty, sz, dfl, before, idx, after) ->
- sprintf "%s[%Ld]" (zipname z) idx
- | Zstruct(z, id, before, fld, after) ->
- sprintf "%s.%s" (zipname z) fld.fld_name
- | Zunion(z, id, fld) ->
- sprintf "%s.%s" (zipname z) fld.fld_name
-
- let name (z, i) = zipname z
-
- (* Auxiliary functions to deal with arrays *)
- let index_below (idx: int64) (sz: int64 option) =
- match sz with None -> true | Some sz -> idx < sz
-
- let il_head dfl = function [] -> dfl | i1 :: il -> i1
- let il_tail = function [] -> [] | i1 :: il -> il
-
- (* Advance the current point to the next point in right-up order.
- Return None if no next point, i.e. we are at top *)
- let rec next = function
- | Ztop(name, ty), i -> None
- | Zarray(z, ty, sz, dfl, before, idx, after), i ->
- let idx' = Int64.succ idx in
- if index_below idx' sz
- then Some(Zarray(z, ty, sz, dfl, i :: before, idx', il_tail after),
- il_head dfl after)
- else next (z, Init_array (List.rev_append before (i :: after)))
- | Zstruct(z, id, before, fld, []), i ->
- next (z, Init_struct(id, List.rev_append before [(fld, i)]))
- | Zstruct(z, id, before, fld, (fld1, i1) :: after), i ->
- Some(Zstruct(z, id, (fld, i) :: before, fld1, after), i1)
- | Zunion(z, id, fld), i ->
- next (z, Init_union(id, fld, i))
-
- (* Move the current point "down" to the first component of an array,
- struct, or union. No effect if the current point is a scalar. *)
- let rec first env (z, i as zi) =
- let ty = typeof zi in
- match unroll env ty, i with
- | TArray(ty, sz, _), Init_array il ->
- if index_below 0L sz then begin
- let dfl = default_init env ty in
- Some(Zarray(z, ty, sz, dfl, [], 0L, il_tail il), il_head dfl il)
- end
- else None
- | TStruct(id, _), Init_struct(id', []) ->
- None
- | TStruct(id, _), Init_struct(id', (fld1, i1) :: flds) ->
- Some(Zstruct(z, id, [], fld1, flds), i1)
- | TUnion(id, _), Init_union(id', fld, i) ->
- begin match (Env.find_union env id).ci_members with
- | [] -> None
- | fld1 :: _ ->
- Some(Zunion(z, id, fld1),
- if fld.fld_name = fld1.fld_name
- then i
- else default_init env fld1.fld_typ)
- end
- | (TStruct _ | TUnion _), Init_single a ->
- (* This is a previous whole-struct initialization that we
- are going to overwrite. Revert to the default initializer. *)
- first env (z, default_init env ty)
- | _ ->
- Some (z, i)
-
- (* Move to the [n]-th element of the current point, which must be
- an array. *)
- let index env (z, i as zi) n =
- match unroll env (typeof zi), i with
- | TArray(ty, sz, _), Init_array il ->
- if n >= 0L && index_below n sz then begin
- let dfl = default_init env ty in
- let rec loop p before after =
- if p = n then
- Some(Zarray(z, ty, sz, dfl, before, n, il_tail after),
- il_head dfl after)
- else
- loop (Int64.succ p)
- (il_head dfl after :: before)
- (il_tail after)
- in loop 0L [] il
- end else
- None
- | _, _ ->
- None
-
- (* Move to the member named [name] of the current point, which must be
- a struct or a union. *)
- let rec member env (z, i as zi) name =
- let ty = typeof zi in
- match unroll env ty, i with
- | TStruct(id, _), Init_struct(id', flds) ->
- let rec find before = function
- | [] -> None
- | (fld, i as f_i) :: after ->
- if fld.fld_name = name then
- Some(Zstruct(z, id, before, fld, after), i)
- else
- find (f_i :: before) after
- in find [] flds
- | TUnion(id, _), Init_union(id', fld, i) ->
- if fld.fld_name = name then
- Some(Zunion(z, id, fld), i)
- else begin
- let rec find = function
- | [] -> None
- | fld1 :: rem ->
- if fld1.fld_name = name then
- Some(Zunion(z, id, fld1), default_init env fld1.fld_typ)
- else
- find rem
- in find (Env.find_union env id).ci_members
- end
- | (TStruct _ | TUnion _), Init_single a ->
- member env (z, default_init env ty) name
- | _, _ ->
- None
-end
-
-(* Interpret the given designator, moving the initialization state [zi]
- "down" accordingly. *)
-
-let rec elab_designator loc env zi desig =
- match desig with
- | [] ->
- zi
- | INFIELD_INIT name :: desig' ->
- begin match I.member env zi name with
- | Some zi' ->
- elab_designator loc env zi' desig'
- | None ->
- error loc "%s has no member named %s" (I.name zi) name;
- raise Exit
- end
- | ATINDEX_INIT a :: desig' ->
- begin match Ceval.integer_expr env (elab_expr loc env a) with
- | None ->
- error loc "array element designator for %s is not a compile-time constant"
- (I.name zi);
- raise Exit
- | Some n ->
- match I.index env zi n with
- | Some zi' ->
- elab_designator loc env zi' desig'
- | None ->
- error loc "bad array element designator %Ld within %s"
- n (I.name zi);
- raise Exit
- end
-
-(* Elaboration of an initialization expression. Return the corresponding
- initializer. *)
-
-let elab_init loc env root ty_root ie =
-
-(* Perform the initializations described by the list [il] over
- the initialization state [zi]. [first] is true if we are at the
- beginning of a braced initializer. Returns the final initializer. *)
-
-let rec elab_list zi il first =
- match il with
- | [] ->
- (* All initialization items consumed. *)
- I.to_init zi
- | (desig, item) :: il' ->
- if desig = [] then begin
- match (if first then I.first env zi else I.next zi)
- with
- | None ->
- warning loc "excess elements at end of initializer for %s, ignored"
- (I.name zi);
- I.to_init zi
- | Some zi' ->
- elab_item zi' item il'
- end else
- elab_item (elab_designator loc env (I.to_top zi) desig) item il'
-
-(* Perform the initialization described by [item] for the current
- subobject of state [zi]. Continue initializing with the list [il]. *)
-
-and elab_item zi item il =
- let ty = I.typeof zi in
- match item, unroll env ty with
- (* Special case char array = "string literal"
- or wchar array = L"wide string literal" *)
- | (SINGLE_INIT (CONSTANT (CONST_STRING(w, s)))
- | COMPOUND_INIT [_, SINGLE_INIT(CONSTANT (CONST_STRING(w, s)))]),
- TArray(ty_elt, sz, _)
- when is_integer_type env ty_elt ->
- begin match elab_string_literal loc w s, unroll env ty_elt with
- | CStr s, TInt((IChar | ISChar | IUChar), _) ->
- if not (I.index_below (Int64.of_int(String.length s - 1)) sz) then
- warning loc "initializer string for array of chars %s is too long"
- (I.name zi);
- elab_list (I.set zi (init_char_array_string sz s)) il false
- | CStr _, _ ->
- error loc "initialization of an array of non-char elements with a string literal";
- elab_list zi il false
- | CWStr s, TInt(ik, _) when ik = wchar_ikind ->
- if not (I.index_below (Int64.of_int(List.length s - 1)) sz) then
- warning loc "initializer string for array of wide chars %s is too long"
- (I.name zi);
- elab_list (I.set zi (init_int_array_wstring sz s)) il false
- | CWStr _, _ ->
- error loc "initialization of an array of non-wchar_t elements with a wide string literal";
- elab_list zi il false
- | _ -> assert false
- end
- (* Brace-enclosed compound initializer *)
- | COMPOUND_INIT il', _ ->
- (* Process the brace-enclosed stuff, obtaining its initializer *)
- let ini' = elab_list (I.top env (I.name zi) ty) il' true in
- (* Initialize current subobject with this state, and continue *)
- elab_list (I.set zi ini') il false
- (* Single expression *)
- | SINGLE_INIT a, _ ->
- let a' = elab_expr loc env a in
- elab_single zi a' il
- (* No initializer: can this happen? *)
- | NO_INIT, _ ->
- elab_list zi il false
-
-(* Perform initialization by a single expression [a] for the current
- subobject of state [zi], Continue initializing with the list [il']. *)
-
-and elab_single zi a il =
- let ty = I.typeof zi in
- match unroll env ty with
- | TInt _ | TEnum _ | TFloat _ | TPtr _ ->
- (* This is a scalar: do direct initialization and continue *)
- check_init_type loc env a ty;
- elab_list (I.set zi (Init_single a)) il false
- | TStruct _ | TUnion _ when compatible_types ~noattrs:true env ty a.etyp ->
- (* This is a composite that can be initialized directly
- from the expression: do as above *)
- elab_list (I.set zi (Init_single a)) il false
- | TStruct _ | TUnion _ | TArray _ ->
- (* This is an aggregate: we need to drill into it, recursively *)
- begin match I.first env zi with
- | Some zi' ->
- elab_single zi' a il
- | None ->
- error loc "initializer for aggregate %s with no elements requires explicit braces"
- (I.name zi);
- raise Exit
- end
- | _ ->
- error loc "impossible to initialize %s of type@ %a"
- (I.name zi) Cprint.typ ty;
- raise Exit
-
-(* Start with top-level object initialized to default *)
-
-in elab_item (I.top env root ty_root) ie []
-
-(* Elaboration of a top-level initializer *)
-
-let elab_initial loc env root ty ie =
- match ie with
- | NO_INIT -> None
- | _ ->
- try
- Some (elab_init loc env root ty ie)
- with
- | Exit -> None (* error was already reported *)
- | Env.Error msg -> error loc "%s" (Env.error_message msg); None
-
-(* Complete an array type with the size obtained from the initializer:
- "int x[] = { 1, 2, 3 }" becomes "int x[3] = ..." *)
-
-let fixup_typ loc env ty init =
- match unroll env ty, init with
- | TArray(ty_elt, None, attr), Init_array il ->
- if il = [] then warning loc "array of size 0";
- TArray(ty_elt, Some(Int64.of_int(List.length il)), attr)
- | _ -> ty
-
-(* Entry point *)
-
-let elab_initializer loc env root ty ie =
- match elab_initial loc env root ty ie with
- | None ->
- (ty, None)
- | Some init ->
- (fixup_typ loc env ty init, Some init)
-
(* Handling of __func__ (section 6.4.2.2) *)
let __func__type_and_init s =
diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml
index 41c00ba..3064e78 100644
--- a/cparser/PackedStructs.ml
+++ b/cparser/PackedStructs.ml
@@ -15,6 +15,9 @@
(* Emulation of #pragma pack (experimental) *)
+(* Assumes: unblocked code.
+ Preserves: unblocked code. *)
+
open Printf
open Machine
open C
@@ -303,6 +306,9 @@ let transf_expr loc env ctx e =
| ECast(ty, e1) ->
{edesc = ECast(ty, texp Val e1); etyp = e.etyp}
+ | ECompound _ ->
+ assert false (* does not occur in unblocked code *)
+
| ECall(e1, el) ->
{edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp}
diff --git a/cparser/Rename.ml b/cparser/Rename.ml
index f4bab8e..2b7ec2c 100644
--- a/cparser/Rename.ml
+++ b/cparser/Rename.ml
@@ -105,6 +105,11 @@ and param env (id, ty) =
else
let (id', env') = rename env id in ((id', typ env' ty), env')
+let field env f =
+ { fld_name = f.fld_name;
+ fld_typ = typ env f.fld_typ;
+ fld_bitfield = f.fld_bitfield }
+
let constant env = function
| CEnum(id, v) -> CEnum(ident env id, v)
| cst -> cst
@@ -121,18 +126,10 @@ and exp_desc env = function
| EBinop(op, a, b, ty) -> EBinop(op, exp env a, exp env b, typ env ty)
| EConditional(a, b, c) -> EConditional(exp env a, exp env b, exp env c)
| ECast(ty, a) -> ECast(typ env ty, exp env a)
+ | ECompound(ty, ie) -> ECompound(typ env ty, init env ie)
| ECall(a, al) -> ECall(exp env a, List.map (exp env) al)
-let optexp env = function
- | None -> None
- | Some a -> Some (exp env a)
-
-let field env f =
- { fld_name = f.fld_name;
- fld_typ = typ env f.fld_typ;
- fld_bitfield = f.fld_bitfield }
-
-let rec init env = function
+and init env = function
| Init_single e -> Init_single(exp env e)
| Init_array il -> Init_array (List.map (init env) il)
| Init_struct(id, il) ->
@@ -141,6 +138,10 @@ let rec init env = function
| Init_union(id, f, i) ->
Init_union(ident env id, field env f, init env i)
+let optexp env = function
+ | None -> None
+ | Some a -> Some (exp env a)
+
let decl env (sto, id, ty, int) =
let (id', env') = rename env id in
((sto,
diff --git a/cparser/StructReturn.ml b/cparser/StructReturn.ml
index e13b09d..228cc53 100644
--- a/cparser/StructReturn.ml
+++ b/cparser/StructReturn.ml
@@ -113,6 +113,8 @@ let rec transf_expr env ctx e =
etyp = newty}
| ECast(ty, e1) ->
{edesc = ECast(transf_type env ty, transf_expr env Val e1); etyp = newty}
+ | ECompound(ty, ie) ->
+ {edesc = ECompound(transf_type env ty, transf_init env ie); etyp = newty}
| ECall(fn, args) ->
transf_call env ctx None fn args e.etyp
@@ -176,7 +178,7 @@ and transf_call env ctx opt_lhs fn args ty =
(* Initializers *)
-let rec transf_init env = function
+and transf_init env = function
| Init_single e ->
Init_single (transf_expr env Val e)
| Init_array il ->
diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml
index 34d8cf8..ba8e379 100644
--- a/cparser/Unblock.ml
+++ b/cparser/Unblock.ml
@@ -22,31 +22,24 @@ open C
open Cutil
open Cerrors
-(* Convert an initializer to a list of assignments.
- Prepend those assignments to the given statement. *)
+(* Convert an initializer to a list of assignment expressions. *)
-let sdoseq loc e s =
- sseq loc {sdesc = Sdo e; sloc = loc} s
-
-let rec local_initializer loc env path init k =
+let rec local_initializer env path init k =
match init with
| Init_single e ->
- sdoseq loc
- { edesc = EBinop(Oassign, path, e, path.etyp); etyp = path.etyp }
- k
+ { edesc = EBinop(Oassign, path, e, path.etyp); etyp = path.etyp } :: k
| Init_array il ->
let (ty_elt, sz) =
match unroll env path.etyp with
| TArray(ty_elt, Some sz, _) -> (ty_elt, sz)
- | _ -> fatal_error "%aWrong type for array initializer"
- formatloc loc in
+ | _ -> fatal_error "Wrong type for array initializer" in
let rec array_init pos il =
if pos >= sz then k else begin
let (i1, il') =
match il with
| [] -> (default_init env ty_elt, [])
| i1 :: il' -> (i1, il') in
- local_initializer loc env
+ local_initializer env
{ edesc = EBinop(Oindex, path, intconst pos IInt, TPtr(ty_elt, []));
etyp = ty_elt }
i1
@@ -55,18 +48,37 @@ let rec local_initializer loc env path init k =
array_init 0L il
| Init_struct(id, fil) ->
let field_init (fld, i) k =
- local_initializer loc env
+ local_initializer env
{ edesc = EUnop(Odot fld.fld_name, path); etyp = fld.fld_typ }
i k in
List.fold_right field_init fil k
| Init_union(id, fld, i) ->
- local_initializer loc env
+ local_initializer env
{ edesc = EUnop(Odot fld.fld_name, path); etyp = fld.fld_typ }
i k
-(* Record new variables to be locally defined *)
+(* Prepend assignments to the given statement. *)
+
+let add_inits_stmt loc inits s =
+ List.fold_right
+ (fun e s -> sseq loc {sdesc = Sdo e; sloc = loc} s)
+ inits s
+
+(* Prepend assignments to the given expression. *)
+(* Associate to the left so that it prints more nicely *)
+
+let add_inits_expr inits e =
+ match inits with
+ | [] -> e
+ | i1 :: il ->
+ let comma a b =
+ { edesc = EBinop(Ocomma, a, b, b.etyp); etyp = b.etyp } in
+ comma (List.fold_left comma i1 il) e
+
+(* Record new variables to be locally or globally defined *)
let local_variables = ref ([]: decl list)
+let global_variables = ref ([]: decl list)
(* Note: "const int x = y - 1;" is legal, but we turn it into
"const int x; x = y - 1;", which is not. Therefore, remove
@@ -75,7 +87,97 @@ let local_variables = ref ([]: decl list)
let remove_const env ty = remove_attributes_type env [AConst] ty
-(* Process a variable declaration.
+(* Process a compound literal "(ty) { init }".
+ At top-level, within an initializer for a global variable,
+ it gives rise to a static global definition of a fresh variable,
+ initialized with "init". The compound variable is replaced
+ by the fresh variable.
+ Within a function, it gives rise to a local variable
+ and an explicit initialization at the nearest sequence point. *)
+
+let process_compound_literal islocal env ty init =
+ let id = Env.fresh_ident "__compound" in
+ if islocal then begin
+ let ty' = remove_const env ty in
+ let e = {edesc = EVar id; etyp = ty'} in
+ local_variables :=
+ (Storage_default, id, ty', None) :: !local_variables;
+ (local_initializer env e init [], e)
+ end else begin
+ global_variables :=
+ (Storage_static, id, ty, Some init) :: !global_variables;
+ ([], {edesc = EVar id; etyp = ty})
+ end
+
+(* Elimination of compound literals within an expression.
+ Compound literals are turned into fresh variables, recorded in
+ [local_variables] or [global_variables] depending on [islocal].
+ For local variables, initializing assignments are added before
+ the expression and after sequence points in the expression.
+ Use only if [e] is a r-value. *)
+
+let rec expand_expr islocal env e =
+ let inits = ref [] in (* accumulator for initializing assignments *)
+ let rec expand e =
+ match e.edesc with
+ | EConst _ | ESizeof _ | EAlignof _ | EVar _ -> e
+ | EUnop(op, e1) ->
+ {edesc = EUnop(op, expand e1); etyp = e.etyp}
+ | EBinop(op, e1, e2, ty) ->
+ let e1' = expand e1 in
+ let e2' =
+ match op with
+ | Ocomma | Ologand | Ologor -> expand_expr islocal env e2
+ (* Make sure the initializers of [e2] are performed in
+ sequential order, i.e. just before [e2] but after [e1]. *)
+ | _ -> expand e2 in
+ {edesc = EBinop(op, e1', e2', ty); etyp = e.etyp}
+ | EConditional(e1, e2, e3) ->
+ (* Same remark as above: initializers of [e2] and [e3] must
+ be performed after the conditional is resolved. *)
+ {edesc = EConditional(expand e1,
+ expand_expr islocal env e2,
+ expand_expr islocal env e3);
+ etyp = e.etyp}
+ | ECast(ty, e1) ->
+ {edesc = ECast(ty, expand e1); etyp = e.etyp}
+ | ECompound(ty, ie) ->
+ let ie' = expand_init islocal env ie in
+ let (l, e') = process_compound_literal islocal env ty ie' in
+ inits := l @ !inits;
+ e'
+ | ECall(e1, el) ->
+ {edesc = ECall(expand e1, List.map expand el); etyp = e.etyp}
+ in
+ let e' = expand e in add_inits_expr !inits e'
+
+(* Elimination of compound literals within an initializer. *)
+
+and expand_init islocal env i =
+ let rec expand i =
+ match i with
+ (* The following "flattening" is not C99. GCC documents it; whether
+ it implements it is unclear, Clang implements it. At any rate,
+ it makes it possible to use compound literals in static initializers,
+ something that is not possible in C99 because compound literals
+ are not constant expressions.
+ Note that flattening is done for structs and unions but not for
+ arrays, because a compound literal of array type in r-value position
+ decays to a pointer to its first element. *)
+ | Init_single {edesc = ECompound(_, ((Init_struct _ | Init_union _) as i))} ->
+ expand i
+ | Init_single e ->
+ Init_single (expand_expr islocal env e)
+ | Init_array il ->
+ Init_array (List.map expand il)
+ | Init_struct(id, flds) ->
+ Init_struct(id, List.map (fun (f, i) -> (f, expand i)) flds)
+ | Init_union(id, fld, i) ->
+ Init_union(id, fld, expand i)
+ in
+ expand i
+
+(* Process a block-scoped variable declaration.
The variable is entered in [local_variables].
The initializer, if any, is converted into assignments and
prepended to [k]. *)
@@ -86,32 +188,41 @@ let process_decl loc env (sto, id, ty, optinit) k =
match optinit with
| None -> k
| Some init ->
- local_initializer loc env { edesc = EVar id; etyp = ty' } init k
+ let init' = expand_init true env init in
+ let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in
+ add_inits_stmt loc l k
(* Simplification of blocks within a statement *)
let rec unblock_stmt env s =
match s.sdesc with
| Sskip -> s
- | Sdo e -> s
+ | Sdo e ->
+ {s with sdesc = Sdo(expand_expr true env e)}
| Sseq(s1, s2) ->
{s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)}
| Sif(e, s1, s2) ->
- {s with sdesc = Sif(e, unblock_stmt env s1, unblock_stmt env s2)}
+ {s with sdesc = Sif(expand_expr true env e,
+ unblock_stmt env s1, unblock_stmt env s2)}
| Swhile(e, s1) ->
- {s with sdesc = Swhile(e, unblock_stmt env s1)}
+ {s with sdesc = Swhile(expand_expr true env e, unblock_stmt env s1)}
| Sdowhile(s1, e) ->
- {s with sdesc = Sdowhile(unblock_stmt env s1, e)}
+ {s with sdesc = Sdowhile(unblock_stmt env s1, expand_expr true env e)}
| Sfor(s1, e, s2, s3) ->
- {s with sdesc = Sfor(unblock_stmt env s1, e, unblock_stmt env s2, unblock_stmt env s3)}
+ {s with sdesc = Sfor(unblock_stmt env s1,
+ expand_expr true env e,
+ unblock_stmt env s2,
+ unblock_stmt env s3)}
| Sbreak -> s
| Scontinue -> s
| Sswitch(e, s1) ->
- {s with sdesc = Sswitch(e, unblock_stmt env s1)}
+ {s with sdesc = Sswitch(expand_expr true env e, unblock_stmt env s1)}
| Slabeled(lbl, s1) ->
{s with sdesc = Slabeled(lbl, unblock_stmt env s1)}
| Sgoto lbl -> s
- | Sreturn opte -> s
+ | Sreturn None -> s
+ | Sreturn (Some e) ->
+ {s with sdesc = Sreturn(Some (expand_expr true env e))}
| Sblock sl -> unblock_block env sl
| Sdecl d -> assert false
| Sasm _ -> s
@@ -123,7 +234,7 @@ and unblock_block env = function
| s :: sl ->
sseq s.sloc (unblock_stmt env s) (unblock_block env sl)
-(* Simplification of blocks within a function *)
+(* Simplification of blocks and compound literals within a function *)
let unblock_fundef env f =
local_variables := [];
@@ -132,7 +243,45 @@ let unblock_fundef env f =
local_variables := [];
{ f with fd_locals = f.fd_locals @ decls; fd_body = body }
+(* Simplification of compound literals within a top-level declaration *)
+
+let unblock_decl loc env ((sto, id, ty, optinit) as d) =
+ match optinit with
+ | None -> [d]
+ | Some init ->
+ global_variables := [];
+ let init' = expand_init false env init in
+ let decls = !global_variables in
+ global_variables := [];
+ decls @ [(sto, id, ty, Some init')]
+
+(* Unblocking and simplification for whole files.
+ The environment is used for typedefs only, so we do not maintain
+ other declarations. *)
+
+let rec unblock_glob env accu = function
+ | [] -> List.rev accu
+ | g :: gl ->
+ match g.gdesc with
+ | Gdecl((sto, id, ty, init) as d) ->
+ let dl = unblock_decl g.gloc env d in
+ unblock_glob env
+ (List.rev_append
+ (List.map (fun d' -> {g with gdesc = Gdecl d'}) dl)
+ accu)
+ gl
+ | Gfundef f ->
+ let f' = unblock_fundef env f in
+ unblock_glob env ({g with gdesc = Gfundef f'} :: accu) gl
+ | Gtypedef(id, ty) ->
+ unblock_glob (Env.add_typedef env id ty) (g :: accu) gl
+ | Gcompositedecl _
+ | Gcompositedef _
+ | Genumdef _
+ | Gpragma _ ->
+ unblock_glob env (g :: accu) gl
+
(* Entry point *)
let program p =
- Transform.program ~fundef:unblock_fundef p
+ unblock_glob (Builtins.environment()) [] p
diff --git a/test/regression/Makefile b/test/regression/Makefile
index bd99675..f4f9623 100644
--- a/test/regression/Makefile
+++ b/test/regression/Makefile
@@ -16,7 +16,7 @@ TESTS=int32 int64 floats floats-basics \
expr1 expr6 funptr2 initializers initializers2 initializers3 \
volatile1 volatile2 volatile3 \
funct3 expr5 struct7 struct8 struct11 casts1 casts2 char1 \
- sizeof1 sizeof2 binops bool for1 switch switch2
+ sizeof1 sizeof2 binops bool for1 switch switch2 compound
# Can run, but only in compiled mode, and have reference output in Results
diff --git a/test/regression/Results/compound b/test/regression/Results/compound
new file mode 100644
index 0000000..b7d007b
--- /dev/null
+++ b/test/regression/Results/compound
@@ -0,0 +1,25 @@
+temp1 = "/temp/XXXXXX"
+temp2 = "/temp/XXXXXX"
+mutated temp1 = "/temp/!XXXXX"
+{x = 12, y = 45}
+{x = 42, y = -42}
+{from = {x = 42, y = 43}, to = {x = 44, y = 45}
+{from = {x = 39, y = 40}, to = {x = 41, y = 42}
+{x = -41, y = -41}
+ptrs contains 4 4 4 4 4
+ptrs contains 0 1 2 3 4
+structure = {a = 12, b = "a"}
+foo = { "x", "y", "z" }
+x = {a = 1, b[0] = 'a', b[1] = 'b'}
+{f = 0.250000}
+{i = 11}
+1 + 3 = 4
+{x = 0, y = 0}
+{x = 1, y = 1}
+{x = 2, y = 2}
+{x = 1, y = 0}
+{x = 0, y = 2}
+"first", "second", NULL
+77
+{ n = 3, p -> {0,1,2,0} }
+{ n = 4, p -> {0,1,2,3} }
diff --git a/test/regression/compound.c b/test/regression/compound.c
new file mode 100644
index 0000000..7c6bd2a
--- /dev/null
+++ b/test/regression/compound.c
@@ -0,0 +1,146 @@
+/* Testing compound literals */
+
+#include <stdio.h>
+
+struct point { int x, y; };
+struct line { struct point from, to; };
+
+void printpoint (struct point p)
+{
+ printf("{x = %d, y = %d}\n", p.x, p.y);
+}
+
+void printpointref (struct point * p)
+{
+ printf("{x = %d, y = %d}\n", p->x, p->y);
+}
+
+void printline (struct line l)
+{
+ printf("{from = {x = %d, y = %d}, to = {x = %d, y = %d}\n",
+ l.from.x, l.from.y, l.to.x, l.to.y);
+}
+
+static inline struct point diff(struct point a, struct point b)
+{
+ return (struct point){ b.x - a.x, b.y - a.y };
+}
+
+/* H&S section 7.4.5 */
+
+char * temp1 = (char []) {"/temp/XXXXXX"};
+char * temp2 = "/temp/XXXXXX";
+
+int pow2(int n)
+{
+ if (n >= 0 && n <= 7)
+ return (const int []) {1,2,4,8,16,32,64,128} [n];
+ else
+ return -1;
+}
+
+void test1(int n)
+{
+ printf("temp1 = \"%s\"\n", temp1);
+ printf("temp2 = \"%s\"\n", temp2);
+ temp1[6] = '!';
+ printf("mutated temp1 = \"%s\"\n", temp1);
+
+ printpoint((struct point){.x=12, .y=n+3});
+ printpointref(&(struct point){n,-n});
+ printline((struct line){n,n+1,n+2,n+3});
+ printline((struct line){.from = (struct point){n-3,n-2},
+ .to = (struct point){n-1,n}});
+ printpoint(diff((struct point){n,n}, (struct point){1,1}));
+ int * ptrs[5];
+ int i = 0;
+ again:
+ ptrs[i] = (int [1]){i};
+ if (++i < 5) goto again;
+ printf("ptrs contains %d %d %d %d %d\n",
+ *(ptrs[0]), *(ptrs[1]), *(ptrs[2]), *(ptrs[3]),*(ptrs[4]));
+ i = 0;
+ ptrs[0] = (int [1]){i++};
+ ptrs[1] = (int [1]){i++};
+ ptrs[2] = (int [1]){i++};
+ ptrs[3] = (int [1]){i++};
+ ptrs[4] = (int [1]){i++};
+ printf("ptrs contains %d %d %d %d %d\n",
+ *(ptrs[0]), *(ptrs[1]), *(ptrs[2]), *(ptrs[3]),*(ptrs[4]));
+}
+
+/* Examples from GCC's manual */
+
+struct foo { int a; char b[2]; } structure;
+
+char **foo = (char *[]) { "x", "y", "z" };
+
+static struct foo x = (struct foo) {1, 'a', 'b'};
+// Dubious examples: GCC refuses them, Clang warns.
+// static int y[] = (int []) {1, 2, 3};
+// static int z[] = (int [3]) {1};
+
+void test2(int n)
+{
+ structure = (struct foo) {n, 'a', 0};
+ printf("structure = {a = %d, b = \"%s\"}\n", structure.a, structure.b);
+ printf("foo = { \"%s\", \"%s\", \"%s\" }\n", foo[0], foo[1], foo[2]);
+ printf("x = {a = %d, b[0] = '%c', b[1] = '%c'}\n", x.a, x.b[0], x.b[1]);
+}
+
+/* Example gathered from various places */
+
+union U { float f; int i; };
+
+void printU(int kind, const union U u)
+{
+ switch (kind) {
+ case 0: printf("{f = %f}\n", u.f); break;
+ case 1: printf("{i = %d}\n", u.i); break;
+ }
+}
+
+struct list { char * value; struct list * next; };
+
+void printlist(struct list * l)
+{
+ for (; l != NULL; l = l->next) printf("\"%s\", ", l->value);
+ printf("NULL\n");
+}
+
+void printintref(int * p)
+{
+ printf("%d\n", *p);
+}
+
+struct S { int n; int *p; };
+
+void printS(struct S s)
+{
+ printf("{ n = %d, p -> {%d,%d,%d,%d} }\n",
+ s.n, s.p[0], s.p[1], s.p[2], s.p[3]);
+}
+
+void test3(void)
+{
+ printU(0, (const union U){0.25});
+ printU(1, (const union U){.i = 11});
+ printf("1 + 3 = %d\n", (int){1} + (int){3});
+ for (int i = 0; i < 3; i++) printpoint((struct point){i,i});
+ printpoint((struct point){1});
+ printpoint((struct point){.y=2});
+ printlist(&((struct list){"first", &((struct list){"second", NULL})}));
+ printintref(&((int){77}));
+ struct S s = (struct S) {3, (int[4]){0,1,2}};
+ printS(s);
+ printS((struct S) {4, (int[]){0,1,2,3}});
+}
+
+int main(void)
+{
+ test1(42);
+ test2(12);
+ test3();
+ return 0;
+}
+