diff options
| -rw-r--r-- | Changelog | 2 | ||||
| -rw-r--r-- | cfrontend/C2C.ml | 2 | ||||
| -rw-r--r-- | cparser/Bitfields.ml | 2 | ||||
| -rw-r--r-- | cparser/C.mli | 51 | ||||
| -rw-r--r-- | cparser/Ceval.ml | 2 | ||||
| -rw-r--r-- | cparser/Cleanup.ml | 3 | ||||
| -rw-r--r-- | cparser/Cprint.ml | 6 | ||||
| -rw-r--r-- | cparser/Cutil.ml | 1 | ||||
| -rw-r--r-- | cparser/Elab.ml | 781 | ||||
| -rw-r--r-- | cparser/PackedStructs.ml | 6 | ||||
| -rw-r--r-- | cparser/Rename.ml | 21 | ||||
| -rw-r--r-- | cparser/StructReturn.ml | 4 | ||||
| -rw-r--r-- | cparser/Unblock.ml | 201 | ||||
| -rw-r--r-- | test/regression/Makefile | 2 | ||||
| -rw-r--r-- | test/regression/Results/compound | 25 | ||||
| -rw-r--r-- | test/regression/compound.c | 146 |
16 files changed, 801 insertions, 454 deletions
@@ -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; +} + |