From c46b574d5b21fb2728c76c5cab1c46890c0fb1cd Mon Sep 17 00:00:00 2001 From: xleroy Date: Thu, 21 Aug 2014 13:23:30 +0000 Subject: Support C99 compound literals (by expansion in Unblock pass). git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2615 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- Changelog | 2 + cfrontend/C2C.ml | 2 + cparser/Bitfields.ml | 2 + cparser/C.mli | 51 +- cparser/Ceval.ml | 2 + cparser/Cleanup.ml | 3 +- cparser/Cprint.ml | 6 +- cparser/Cutil.ml | 1 + cparser/Elab.ml | 1649 +++++++++++++++++++------------------- cparser/PackedStructs.ml | 6 + cparser/Rename.ml | 21 +- cparser/StructReturn.ml | 4 +- cparser/Unblock.ml | 201 ++++- test/regression/Makefile | 2 +- test/regression/Results/compound | 25 + test/regression/compound.c | 146 ++++ 16 files changed, 1235 insertions(+), 888 deletions(-) create mode 100644 test/regression/Results/compound create mode 100644 test/regression/compound.c 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@[(%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,927 +789,932 @@ let elab_type loc env spec decl = ty -(* Elaboration of expressions *) - -let elab_expr loc env a = - - let err fmt = error loc fmt in (* non-fatal error *) - let error fmt = fatal_error loc fmt in - let warning fmt = warning loc fmt in +(* Elaboration of initializers. C99 section 6.7.8 *) - let rec elab = function +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) []) -(* 6.5.1 Primary expressions *) +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) []) - | VARIABLE s -> - begin match wrap Env.lookup_ident loc env s with - | (id, II_ident(sto, ty)) -> - { edesc = EVar id; etyp = ty } - | (id, II_enum v) -> - { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) } - end +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 - | CONSTANT cst -> - let cst' = elab_constant loc cst in - { edesc = EConst cst'; etyp = type_of_constant cst' } +(* Representing initialization state using zippers *) -(* 6.5.2 Postfix expressions *) +module I = struct - | INDEX(a1, a2) -> (* e1[e2] *) - let b1 = elab a1 in let b2 = elab a2 in - let tres = - match (unroll env b1.etyp, unroll env b2.etyp) with - | (TPtr(t, _) | TArray(t, _, _)), (TInt _ | TEnum _) -> t - | (TInt _ | TEnum _), (TPtr(t, _) | TArray(t, _, _)) -> t - | t1, t2 -> error "incorrect types for array subscripting" in - { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres } + type zipinit = + | Ztop of string * typ - | MEMBEROF(a1, fieldname) -> - let b1 = elab a1 in - let (fld, attrs) = - match unroll env b1.etyp with - | TStruct(id, attrs) -> - (wrap Env.find_struct_member loc env (id, fieldname), attrs) - | TUnion(id, attrs) -> - (wrap Env.find_union_member loc env (id, fieldname), attrs) - | _ -> - error "left-hand side of '.' is not a struct or union" in - (* A field of a const/volatile struct or union is itself const/volatile *) - { edesc = EUnop(Odot fieldname, b1); - etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) - (type_of_member env fld) } + | 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 *) - | MEMBEROFPTR(a1, fieldname) -> - let b1 = elab a1 in - let (fld, attrs) = - match unroll env b1.etyp with - | TPtr(t, _) | TArray(t,_,_) -> - begin match unroll env t with - | TStruct(id, attrs) -> - (wrap Env.find_struct_member loc env (id, fieldname), attrs) - | TUnion(id, attrs) -> - (wrap Env.find_union_member loc env (id, fieldname), attrs) - | _ -> - error "left-hand side of '->' is not a pointer to a struct or union" - end - | _ -> - error "left-hand side of '->' is not a pointer " in - { edesc = EUnop(Oarrow fieldname, b1); - etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) - (type_of_member env fld) } + | Zstruct of zipinit (* ancestor *) + * ident (* struct type *) + * (field * init) list (* elements before current, reversed *) + * field (* current field *) + * (field * init) list (* elements after current *) -(* Hack to treat vararg.h functions the GCC way. Helps with testing. - va_start(ap,n) - (preprocessing) --> __builtin_va_start(ap, arg) - (elaboration) --> __builtin_va_start(ap) - va_arg(ap, ty) - (preprocessing) --> __builtin_va_arg(ap, ty) - (elaboration) --> __builtin_va_arg(ap, sizeof(ty)) -*) - | CALL((VARIABLE "__builtin_va_start" as a1), [a2; a3]) -> - let b1 = elab a1 and b2 = elab a2 and _b3 = elab a3 in - { edesc = ECall(b1, [b2]); - etyp = TVoid [] } + | Zunion of zipinit (* ancestor *) + * ident (* union type *) + * field (* current member *) - | BUILTIN_VA_ARG (a2, a3) -> - let ident = - match wrap Env.lookup_ident loc env "__builtin_va_arg" with - | (id, II_ident(sto, ty)) -> { edesc = EVar id; etyp = ty } - | _ -> assert false - in - let b2 = elab a2 and b3 = elab (TYPE_SIZEOF a3) in - let ty = match b3.edesc with ESizeof ty -> ty | _ -> assert false in - let ty' = default_argument_conversion env ty in - if not (compatible_types env ty ty') then - warning "'%a' is promoted to '%a' when passed through '...'.@ You should pass '%a', not '%a', to 'va_arg'" - Cprint.typ ty Cprint.typ ty' - Cprint.typ ty' Cprint.typ ty; - { edesc = ECall(ident, [b2; b3]); etyp = ty } + type state = zipinit * init (* current point & init for this point *) - | CALL(a1, al) -> - let b1 = - (* Catch the old-style usage of calling a function without - having declared it *) - match a1 with - | VARIABLE n when not (Env.ident_is_bound env n) -> - warning "implicit declaration of function '%s'" n; - let ty = TFun(TInt(IInt, []), None, false, []) in - (* Emit an extern declaration for it *) - let id = Env.fresh_ident n in - emit_elab loc (Gdecl(Storage_extern, id, ty, None)); - { edesc = EVar id; etyp = ty } - | _ -> elab a1 in - let bl = List.map elab al in - (* Extract type information *) - let (res, args, vararg) = - match unroll env b1.etyp with - | TFun(res, args, vararg, a) -> (res, args, vararg) - | TPtr(ty, a) -> - begin match unroll env ty with - | TFun(res, args, vararg, a) -> (res, args, vararg) - | _ -> error "the function part of a call does not have a function type" - end - | _ -> error "the function part of a call does not have a function type" - in - (* Type-check the arguments against the prototype *) - let bl' = - match args with - | None -> bl - | Some proto -> elab_arguments 1 bl proto vararg in - { edesc = ECall(b1, bl'); etyp = res } + (* The initial state: default initialization, current point at top *) + let top env name ty = (Ztop(name, ty), default_init env ty) - | UNARY(POSINCR, a1) -> - elab_pre_post_incr_decr Opostincr "postfix '++'" a1 - | UNARY(POSDECR, a1) -> - elab_pre_post_incr_decr Opostdecr "postfix '--'" a1 + (* Change the initializer for the current point *) + let set (z, i) i' = (z, i') -(* 6.5.3 Unary expressions *) + (* 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)) - | CAST ((spec, dcl), SINGLE_INIT a1) -> - let ty = elab_type loc env spec dcl in - let b1 = elab a1 in - if not (valid_cast env b1.etyp ty) then - err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty; - { edesc = ECast(ty, b1); etyp = ty } + (* Extract the initializer corresponding to the current state *) + let to_init zi = snd (to_top zi) - | CAST ((spec, dcl), _) -> - err "compound literals are not supported"; - (* continue with dummy expression of the correct type *) - let ty = elab_type loc env spec dcl in - { edesc = ECast(ty, nullconst); etyp = ty } + (* 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 - | EXPR_SIZEOF a1 -> - let b1 = elab a1 in - if wrap incomplete_type loc env b1.etyp then - err "incomplete type %a" Cprint.typ b1.etyp; - let bdesc = - (* Catch special cases sizeof("string literal") *) - match b1.edesc with - | EConst(CStr s) -> - let sz = String.length s + 1 in - EConst(CInt(Int64.of_int sz, size_t_ikind, "")) - | EConst(CWStr s) -> - let sz = (!config).sizeof_wchar * (List.length s + 1) in - EConst(CInt(Int64.of_int sz, size_t_ikind, "")) - | _ -> - ESizeof b1.etyp in - { edesc = bdesc; etyp = TInt(size_t_ikind, []) } + (* 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 - | TYPE_SIZEOF (spec, dcl) -> - let ty = elab_type loc env spec dcl in - if wrap incomplete_type loc env ty then - err "incomplete type %a" Cprint.typ ty; - { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []) } + let name (z, i) = zipname z - | EXPR_ALIGNOF a1 -> - let b1 = elab a1 in - if wrap incomplete_type loc env b1.etyp then - err "incomplete type %a" Cprint.typ b1.etyp; - { edesc = EAlignof b1.etyp; etyp = TInt(size_t_ikind, []) } + (* Auxiliary functions to deal with arrays *) + let index_below (idx: int64) (sz: int64 option) = + match sz with None -> true | Some sz -> idx < sz - | TYPE_ALIGNOF (spec, dcl) -> - let ty = elab_type loc env spec dcl in - if wrap incomplete_type loc env ty then - err "incomplete type %a" Cprint.typ ty; - { edesc = EAlignof ty; etyp = TInt(size_t_ikind, []) } + let il_head dfl = function [] -> dfl | i1 :: il -> i1 + let il_tail = function [] -> [] | i1 :: il -> il - | UNARY(PLUS, a1) -> - let b1 = elab a1 in - if not (is_arith_type env b1.etyp) then - err "argument of unary '+' is not an arithmetic type"; - { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp } + (* 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)) - | UNARY(MINUS, a1) -> - let b1 = elab a1 in - if not (is_arith_type env b1.etyp) then - err "argument of unary '-' is not an arithmetic type"; - { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp } + (* 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) - | UNARY(BNOT, a1) -> - let b1 = elab a1 in - if not (is_integer_type env b1.etyp) then - err "argument of '~' is not an integer type"; - { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp } + (* 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 - | UNARY(NOT, a1) -> - let b1 = elab a1 in - if not (is_scalar_type env b1.etyp) then - err "argument of '!' is not a scalar type"; - { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []) } + (* 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 - | UNARY(ADDROF, a1) -> - let b1 = elab a1 in - if not (is_lvalue b1 || is_function_type env b1.etyp) then - err "argument of '&' is not an l-value"; - { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.etyp, []) } +(* Interpret the given designator, moving the initialization state [zi] + "down" accordingly. *) - | UNARY(MEMOF, a1) -> - let b1 = elab a1 in - begin match unroll env b1.etyp with - (* '*' applied to a function type has no effect *) - | TFun _ -> b1 - | TPtr(ty, _) | TArray(ty, _, _) -> - { edesc = EUnop(Oderef, b1); etyp = ty } - | _ -> - error "argument of unary '*' is not a pointer" +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 - | UNARY(PREINCR, a1) -> - elab_pre_post_incr_decr Opreincr "prefix '++'" a1 - | UNARY(PREDECR, a1) -> - elab_pre_post_incr_decr Opredecr "prefix '--'" a1 +(* Elaboration of an initialization expression. Return the corresponding + initializer. *) -(* 6.5.5 to 6.5.12 Binary operator expressions *) +let elab_init loc env root ty_root ie = - | BINARY(MUL, a1, a2) -> - elab_binary_arithmetic "*" Omul a1 a2 +(* 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. *) - | BINARY(DIV, a1, a2) -> - elab_binary_arithmetic "/" Odiv a1 a2 +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' - | BINARY(MOD, a1, a2) -> - elab_binary_integer "/" Omod a1 a2 +(* Perform the initialization described by [item] for the current + subobject of state [zi]. Continue initializing with the list [il]. *) - | BINARY(ADD, a1, a2) -> - let b1 = elab a1 in - let b2 = elab a2 in - let tyres = - if is_arith_type env b1.etyp && is_arith_type env b2.etyp then - binary_conversion env b1.etyp b2.etyp - else begin - let ty = - match unroll env b1.etyp, unroll env b2.etyp with - | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> ty - | (TInt _ | TEnum _), (TPtr(ty, a) | TArray(ty, _, a)) -> ty - | _, _ -> error "type error in binary '+'" in - if not (pointer_arithmetic_ok env ty) then - err "illegal pointer arithmetic in binary '+'"; - TPtr(ty, []) - end in - { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres } +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 - | BINARY(SUB, a1, a2) -> - let b1 = elab a1 in - let b2 = elab a2 in - let (tyop, tyres) = - if is_arith_type env b1.etyp && is_arith_type env b2.etyp then begin - let tyres = binary_conversion env b1.etyp b2.etyp in - (tyres, tyres) - end else begin - match unroll env b1.etyp, unroll env b2.etyp with - | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> - if not (pointer_arithmetic_ok env ty) then - err "illegal pointer arithmetic in binary '-'"; - (TPtr(ty, []), TPtr(ty, [])) - | (TInt _ | TEnum _), (TPtr(ty, a) | TArray(ty, _, a)) -> - if not (pointer_arithmetic_ok env ty) then - err "illegal pointer arithmetic in binary '-'"; - (TPtr(ty, []), TPtr(ty, [])) - | (TPtr(ty1, a1) | TArray(ty1, _, a1)), - (TPtr(ty2, a2) | TArray(ty2, _, a2)) -> - if not (compatible_types ~noattrs:true env ty1 ty2) then - err "mismatch between pointer types in binary '-'"; - if not (pointer_arithmetic_ok env ty1) then - err "illegal pointer arithmetic in binary '-'"; - if wrap sizeof loc env ty1 = Some 0 then - err "subtraction between two pointers to zero-sized objects"; - (TPtr(ty1, []), TInt(ptrdiff_t_ikind, [])) - | _, _ -> error "type error in binary '-'" - end in - { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres } +(* Perform initialization by a single expression [a] for the current + subobject of state [zi], Continue initializing with the list [il']. *) - | BINARY(SHL, a1, a2) -> - elab_shift "<<" Oshl a1 a2 +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 - | BINARY(SHR, a1, a2) -> - elab_shift ">>" Oshr a1 a2 +(* Start with top-level object initialized to default *) - | BINARY(EQ, a1, a2) -> - elab_comparison Oeq a1 a2 - | BINARY(NE, a1, a2) -> - elab_comparison One a1 a2 - | BINARY(LT, a1, a2) -> - elab_comparison Olt a1 a2 - | BINARY(GT, a1, a2) -> - elab_comparison Ogt a1 a2 - | BINARY(LE, a1, a2) -> - elab_comparison Ole a1 a2 - | BINARY(GE, a1, a2) -> - elab_comparison Oge a1 a2 +in elab_item (I.top env root ty_root) ie [] - | BINARY(BAND, a1, a2) -> - elab_binary_integer "&" Oand a1 a2 - | BINARY(BOR, a1, a2) -> - elab_binary_integer "|" Oor a1 a2 - | BINARY(XOR, a1, a2) -> - elab_binary_integer "^" Oxor a1 a2 +(* Elaboration of a top-level initializer *) -(* 6.5.13 and 6.5.14 Logical operator expressions *) +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 - | BINARY(AND, a1, a2) -> - elab_logical_operator "&&" Ologand a1 a2 - | BINARY(OR, a1, a2) -> - elab_logical_operator "||" Ologor a1 a2 +(* Complete an array type with the size obtained from the initializer: + "int x[] = { 1, 2, 3 }" becomes "int x[3] = ..." *) -(* 6.5.15 Conditional expressions *) - | QUESTION(a1, a2, a3) -> - let b1 = elab a1 in - let b2 = elab a2 in - let b3 = elab a3 in - if not (is_scalar_type env b1.etyp) then - err ("the first argument of '? :' is not a scalar type"); - begin match pointer_decay env b2.etyp, pointer_decay env b3.etyp with - | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> - { edesc = EConditional(b1, b2, b3); - etyp = binary_conversion env b2.etyp b3.etyp } - | TPtr(ty1, a1), TPtr(ty2, a2) -> - let tyres = - if is_void_type env ty1 || is_void_type env ty2 then - TPtr(TVoid (add_attributes a1 a2), []) - else - match combine_types ~noattrs:true env - (TPtr(ty1, a1)) (TPtr(ty2, a2)) with - | None -> - error "the second and third arguments of '? :' \ - have incompatible pointer types" - | Some ty -> ty - in - { edesc = EConditional(b1, b2, b3); etyp = tyres } - | TPtr(ty1, a1), TInt _ when is_literal_0 b3 -> - { edesc = EConditional(b1, b2, nullconst); etyp = TPtr(ty1, []) } - | TInt _, TPtr(ty2, a2) when is_literal_0 b2 -> - { edesc = EConditional(b1, nullconst, b3); etyp = TPtr(ty2, []) } - | ty1, ty2 -> - match combine_types ~noattrs:true env ty1 ty2 with - | None -> - error ("the second and third arguments of '? :' have incompatible types") - | Some tyres -> - { edesc = EConditional(b1, b2, b3); etyp = tyres } - end +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 -(* 6.5.16 Assignment expressions *) +(* Entry point *) - | BINARY(ASSIGN, a1, a2) -> - let b1 = elab a1 in - let b2 = elab a2 in - if List.mem AConst (attributes_of_type env b1.etyp) then - err "left-hand side of assignment has 'const' type"; - if not (is_modifiable_lvalue env b1) then - err "left-hand side of assignment is not a modifiable l-value"; - if not (valid_assignment env b2 b1.etyp) then begin - if valid_cast env b2.etyp b1.etyp then - warning "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ b2.etyp Cprint.typ b1.etyp - else - err "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ b2.etyp Cprint.typ b1.etyp; - end; - { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp } +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) - | BINARY((ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN - | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN - as op), a1, a2) -> - let (sop, top) = - match op with - | ADD_ASSIGN -> (ADD, Oadd_assign) - | SUB_ASSIGN -> (SUB, Osub_assign) - | MUL_ASSIGN -> (MUL, Omul_assign) - | DIV_ASSIGN -> (DIV, Odiv_assign) - | MOD_ASSIGN -> (MOD, Omod_assign) - | BAND_ASSIGN -> (BAND, Oand_assign) - | BOR_ASSIGN -> (BOR, Oor_assign) - | XOR_ASSIGN -> (XOR, Oxor_assign) - | SHL_ASSIGN -> (SHL, Oshl_assign) - | SHR_ASSIGN -> (SHR, Oshr_assign) - | _ -> assert false in - begin match elab (BINARY(sop, a1, a2)) with - | { edesc = EBinop(_, b1, b2, _); etyp = ty } as b -> - if List.mem AConst (attributes_of_type env b1.etyp) then - err "left-hand side of assignment has 'const' type"; - if not (is_modifiable_lvalue env b1) then - err ("left-hand side of assignment is not a modifiable l-value"); - if not (valid_assignment env b b1.etyp) then begin - if valid_cast env ty b1.etyp then - warning "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ ty Cprint.typ b1.etyp - else - err "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ ty Cprint.typ b1.etyp; - end; - { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp } - | _ -> assert false + +(* Elaboration of expressions *) + +let elab_expr loc env a = + + let err fmt = error loc fmt in (* non-fatal error *) + let error fmt = fatal_error loc fmt in + let warning fmt = warning loc fmt in + + let rec elab = function + +(* 6.5.1 Primary expressions *) + + | VARIABLE s -> + begin match wrap Env.lookup_ident loc env s with + | (id, II_ident(sto, ty)) -> + { edesc = EVar id; etyp = ty } + | (id, II_enum v) -> + { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) } end -(* 6.5.17 Sequential expressions *) + | CONSTANT cst -> + let cst' = elab_constant loc cst in + { edesc = EConst cst'; etyp = type_of_constant cst' } - | BINARY(COMMA, a1, a2) -> - let b1 = elab a1 in - let b2 = elab a2 in - { edesc = EBinop (Ocomma, b1, b2, b2.etyp); etyp = b2.etyp } +(* 6.5.2 Postfix expressions *) -(* Elaboration of pre- or post- increment/decrement *) - and elab_pre_post_incr_decr op msg a1 = - let b1 = elab a1 in - if not (is_modifiable_lvalue env b1) then - err "the argument of %s is not a modifiable l-value" msg; - if not (is_scalar_type env b1.etyp) then - err "the argument of %s must be an arithmetic or pointer type" msg; - { edesc = EUnop(op, b1); etyp = b1.etyp } + | INDEX(a1, a2) -> (* e1[e2] *) + let b1 = elab a1 in let b2 = elab a2 in + let tres = + match (unroll env b1.etyp, unroll env b2.etyp) with + | (TPtr(t, _) | TArray(t, _, _)), (TInt _ | TEnum _) -> t + | (TInt _ | TEnum _), (TPtr(t, _) | TArray(t, _, _)) -> t + | t1, t2 -> error "incorrect types for array subscripting" in + { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres } -(* Elaboration of binary operators over integers *) - and elab_binary_integer msg op a1 a2 = + | MEMBEROF(a1, fieldname) -> let b1 = elab a1 in - if not (is_integer_type env b1.etyp) then - error "the first argument of '%s' is not an integer type" msg; - let b2 = elab a2 in - if not (is_integer_type env b2.etyp) then - error "the second argument of '%s' is not an integer type" msg; - let tyres = binary_conversion env b1.etyp b2.etyp in - { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } + let (fld, attrs) = + match unroll env b1.etyp with + | TStruct(id, attrs) -> + (wrap Env.find_struct_member loc env (id, fieldname), attrs) + | TUnion(id, attrs) -> + (wrap Env.find_union_member loc env (id, fieldname), attrs) + | _ -> + error "left-hand side of '.' is not a struct or union" in + (* A field of a const/volatile struct or union is itself const/volatile *) + { edesc = EUnop(Odot fieldname, b1); + etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) + (type_of_member env fld) } -(* Elaboration of binary operators over arithmetic types *) - and elab_binary_arithmetic msg op a1 a2 = + | MEMBEROFPTR(a1, fieldname) -> let b1 = elab a1 in - if not (is_arith_type env b1.etyp) then - error "the first argument of '%s' is not an arithmetic type" msg; - let b2 = elab a2 in - if not (is_arith_type env b2.etyp) then - error "the second argument of '%s' is not an arithmetic type" msg; - let tyres = binary_conversion env b1.etyp b2.etyp in - { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } - -(* Elaboration of shift operators *) - and elab_shift msg op a1 a2 = - let b1 = elab a1 in - if not (is_integer_type env b1.etyp) then - error "the first argument of '%s' is not an integer type" msg; - let b2 = elab a2 in - if not (is_integer_type env b2.etyp) then - error "the second argument of '%s' is not an integer type" msg; - let tyres = unary_conversion env b1.etyp in - { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } + let (fld, attrs) = + match unroll env b1.etyp with + | TPtr(t, _) | TArray(t,_,_) -> + begin match unroll env t with + | TStruct(id, attrs) -> + (wrap Env.find_struct_member loc env (id, fieldname), attrs) + | TUnion(id, attrs) -> + (wrap Env.find_union_member loc env (id, fieldname), attrs) + | _ -> + error "left-hand side of '->' is not a pointer to a struct or union" + end + | _ -> + error "left-hand side of '->' is not a pointer " in + { edesc = EUnop(Oarrow fieldname, b1); + etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) + (type_of_member env fld) } -(* Elaboration of comparisons *) - and elab_comparison op a1 a2 = - let b1 = elab a1 in - let b2 = elab a2 in - let resdesc = - match pointer_decay env b1.etyp, pointer_decay env b2.etyp with - | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> - EBinop(op, b1, b2, binary_conversion env b1.etyp b2.etyp) - | TInt _, TPtr(ty, _) when is_literal_0 b1 -> - EBinop(op, nullconst, b2, TPtr(ty, [])) - | TPtr(ty, _), TInt _ when is_literal_0 b2 -> - EBinop(op, b1, nullconst, TPtr(ty, [])) - | TPtr(ty1, _), TPtr(ty2, _) - when is_void_type env ty1 -> - EBinop(op, b1, b2, TPtr(ty2, [])) - | TPtr(ty1, _), TPtr(ty2, _) - when is_void_type env ty2 -> - EBinop(op, b1, b2, TPtr(ty1, [])) - | TPtr(ty1, _), TPtr(ty2, _) -> - if not (compatible_types ~noattrs:true env ty1 ty2) then - warning "comparison between incompatible pointer types"; - EBinop(op, b1, b2, TPtr(ty1, [])) - | TPtr _, (TInt _ | TEnum _) - | (TInt _ | TEnum _), TPtr _ -> - warning "comparison between integer and pointer"; - EBinop(op, b1, b2, TPtr(TVoid [], [])) - | ty1, ty2 -> - error "illegal comparison between types@ %a@ and %a" - Cprint.typ b1.etyp Cprint.typ b2.etyp in - { edesc = resdesc; etyp = TInt(IInt, []) } +(* Hack to treat vararg.h functions the GCC way. Helps with testing. + va_start(ap,n) + (preprocessing) --> __builtin_va_start(ap, arg) + (elaboration) --> __builtin_va_start(ap) + va_arg(ap, ty) + (preprocessing) --> __builtin_va_arg(ap, ty) + (elaboration) --> __builtin_va_arg(ap, sizeof(ty)) +*) + | CALL((VARIABLE "__builtin_va_start" as a1), [a2; a3]) -> + let b1 = elab a1 and b2 = elab a2 and _b3 = elab a3 in + { edesc = ECall(b1, [b2]); + etyp = TVoid [] } -(* Elaboration of && and || *) - and elab_logical_operator msg op a1 a2 = - let b1 = elab a1 in - if not (is_scalar_type env b1.etyp) then - err "the first argument of '%s' is not a scalar type" msg; - let b2 = elab a2 in - if not (is_scalar_type env b2.etyp) then - err "the second argument of '%s' is not a scalar type" msg; - { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []) } + | BUILTIN_VA_ARG (a2, a3) -> + let ident = + match wrap Env.lookup_ident loc env "__builtin_va_arg" with + | (id, II_ident(sto, ty)) -> { edesc = EVar id; etyp = ty } + | _ -> assert false + in + let b2 = elab a2 and b3 = elab (TYPE_SIZEOF a3) in + let ty = match b3.edesc with ESizeof ty -> ty | _ -> assert false in + let ty' = default_argument_conversion env ty in + if not (compatible_types env ty ty') then + warning "'%a' is promoted to '%a' when passed through '...'.@ You should pass '%a', not '%a', to 'va_arg'" + Cprint.typ ty Cprint.typ ty' + Cprint.typ ty' Cprint.typ ty; + { edesc = ECall(ident, [b2; b3]); etyp = ty } -(* Type-checking of function arguments *) - and elab_arguments argno args params vararg = - match args, params with - | [], [] -> [] - | [], _::_ -> err "not enough arguments in function call"; [] - | _::_, [] -> - if vararg - then args - else (err "too many arguments in function call"; args) - | arg1 :: argl, (_, ty_p) :: paraml -> - let ty_a = argument_conversion env arg1.etyp in - if not (valid_assignment env {arg1 with etyp = ty_a} ty_p) then begin - if valid_cast env ty_a ty_p then - warning - "argument #%d of function call has type@ %a@ \ - instead of the expected type@ %a" - argno Cprint.typ ty_a Cprint.typ ty_p - else - err - "argument #%d of function call has type@ %a@ \ - instead of the expected type@ %a" - argno Cprint.typ ty_a Cprint.typ ty_p - end; - arg1 :: elab_arguments (argno + 1) argl paraml vararg + | CALL(a1, al) -> + let b1 = + (* Catch the old-style usage of calling a function without + having declared it *) + match a1 with + | VARIABLE n when not (Env.ident_is_bound env n) -> + warning "implicit declaration of function '%s'" n; + let ty = TFun(TInt(IInt, []), None, false, []) in + (* Emit an extern declaration for it *) + let id = Env.fresh_ident n in + emit_elab loc (Gdecl(Storage_extern, id, ty, None)); + { edesc = EVar id; etyp = ty } + | _ -> elab a1 in + let bl = List.map elab al in + (* Extract type information *) + let (res, args, vararg) = + match unroll env b1.etyp with + | TFun(res, args, vararg, a) -> (res, args, vararg) + | TPtr(ty, a) -> + begin match unroll env ty with + | TFun(res, args, vararg, a) -> (res, args, vararg) + | _ -> error "the function part of a call does not have a function type" + end + | _ -> error "the function part of a call does not have a function type" + in + (* Type-check the arguments against the prototype *) + let bl' = + match args with + | None -> bl + | Some proto -> elab_arguments 1 bl proto vararg in + { edesc = ECall(b1, bl'); etyp = res } - in elab a + | UNARY(POSINCR, a1) -> + elab_pre_post_incr_decr Opostincr "postfix '++'" a1 + | UNARY(POSDECR, a1) -> + elab_pre_post_incr_decr Opostdecr "postfix '--'" a1 -(* Filling in forward declaration *) -let _ = elab_expr_f := elab_expr +(* 6.5.4 Cast operators *) -let elab_opt_expr loc env = function - | None -> None - | Some a -> Some (elab_expr loc env a) + | CAST ((spec, dcl), SINGLE_INIT a1) -> + let ty = elab_type loc env spec dcl in + let b1 = elab a1 in + if not (valid_cast env b1.etyp ty) then + err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty; + { edesc = ECast(ty, b1); etyp = ty } -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 } +(* 6.5.2.5 Compound literals *) - -(* Elaboration of initializers. C99 section 6.7.8 *) + | CAST ((spec, dcl), ie) -> + let ty = elab_type loc env spec dcl in + begin match elab_initializer loc env "" ty ie with + | (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' } + | (ty', None) -> error "ill-formed compound literal" + end -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) []) +(* 6.5.3 Unary expressions *) -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) []) + | EXPR_SIZEOF a1 -> + let b1 = elab a1 in + if wrap incomplete_type loc env b1.etyp then + err "incomplete type %a" Cprint.typ b1.etyp; + let bdesc = + (* Catch special cases sizeof("string literal") *) + match b1.edesc with + | EConst(CStr s) -> + let sz = String.length s + 1 in + EConst(CInt(Int64.of_int sz, size_t_ikind, "")) + | EConst(CWStr s) -> + let sz = (!config).sizeof_wchar * (List.length s + 1) in + EConst(CInt(Int64.of_int sz, size_t_ikind, "")) + | _ -> + ESizeof b1.etyp in + { edesc = bdesc; etyp = TInt(size_t_ikind, []) } -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 + | TYPE_SIZEOF (spec, dcl) -> + let ty = elab_type loc env spec dcl in + if wrap incomplete_type loc env ty then + err "incomplete type %a" Cprint.typ ty; + { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []) } -(* Representing initialization state using zippers *) + | EXPR_ALIGNOF a1 -> + let b1 = elab a1 in + if wrap incomplete_type loc env b1.etyp then + err "incomplete type %a" Cprint.typ b1.etyp; + { edesc = EAlignof b1.etyp; etyp = TInt(size_t_ikind, []) } -module I = struct + | TYPE_ALIGNOF (spec, dcl) -> + let ty = elab_type loc env spec dcl in + if wrap incomplete_type loc env ty then + err "incomplete type %a" Cprint.typ ty; + { edesc = EAlignof ty; etyp = TInt(size_t_ikind, []) } - type zipinit = - | Ztop of string * typ + | UNARY(PLUS, a1) -> + let b1 = elab a1 in + if not (is_arith_type env b1.etyp) then + err "argument of unary '+' is not an arithmetic type"; + { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp } - | 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 *) + | UNARY(MINUS, a1) -> + let b1 = elab a1 in + if not (is_arith_type env b1.etyp) then + err "argument of unary '-' is not an arithmetic type"; + { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp } - | Zstruct of zipinit (* ancestor *) - * ident (* struct type *) - * (field * init) list (* elements before current, reversed *) - * field (* current field *) - * (field * init) list (* elements after current *) + | UNARY(BNOT, a1) -> + let b1 = elab a1 in + if not (is_integer_type env b1.etyp) then + err "argument of '~' is not an integer type"; + { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp } - | Zunion of zipinit (* ancestor *) - * ident (* union type *) - * field (* current member *) + | UNARY(NOT, a1) -> + let b1 = elab a1 in + if not (is_scalar_type env b1.etyp) then + err "argument of '!' is not a scalar type"; + { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []) } - type state = zipinit * init (* current point & init for this point *) + | UNARY(ADDROF, a1) -> + let b1 = elab a1 in + if not (is_lvalue b1 || is_function_type env b1.etyp) then + err "argument of '&' is not an l-value"; + { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.etyp, []) } - (* The initial state: default initialization, current point at top *) - let top env name ty = (Ztop(name, ty), default_init env ty) + | UNARY(MEMOF, a1) -> + let b1 = elab a1 in + begin match unroll env b1.etyp with + (* '*' applied to a function type has no effect *) + | TFun _ -> b1 + | TPtr(ty, _) | TArray(ty, _, _) -> + { edesc = EUnop(Oderef, b1); etyp = ty } + | _ -> + error "argument of unary '*' is not a pointer" + end - (* Change the initializer for the current point *) - let set (z, i) i' = (z, i') + | UNARY(PREINCR, a1) -> + elab_pre_post_incr_decr Opreincr "prefix '++'" a1 + | UNARY(PREDECR, a1) -> + elab_pre_post_incr_decr Opredecr "prefix '--'" a1 - (* 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)) +(* 6.5.5 to 6.5.12 Binary operator expressions *) - (* Extract the initializer corresponding to the current state *) - let to_init zi = snd (to_top zi) + | BINARY(MUL, a1, a2) -> + elab_binary_arithmetic "*" Omul a1 a2 - (* 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 + | BINARY(DIV, a1, a2) -> + elab_binary_arithmetic "/" Odiv a1 a2 - (* 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 + | BINARY(MOD, a1, a2) -> + elab_binary_integer "/" Omod a1 a2 - let name (z, i) = zipname z + | BINARY(ADD, a1, a2) -> + let b1 = elab a1 in + let b2 = elab a2 in + let tyres = + if is_arith_type env b1.etyp && is_arith_type env b2.etyp then + binary_conversion env b1.etyp b2.etyp + else begin + let ty = + match unroll env b1.etyp, unroll env b2.etyp with + | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> ty + | (TInt _ | TEnum _), (TPtr(ty, a) | TArray(ty, _, a)) -> ty + | _, _ -> error "type error in binary '+'" in + if not (pointer_arithmetic_ok env ty) then + err "illegal pointer arithmetic in binary '+'"; + TPtr(ty, []) + end in + { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres } - (* Auxiliary functions to deal with arrays *) - let index_below (idx: int64) (sz: int64 option) = - match sz with None -> true | Some sz -> idx < sz + | BINARY(SUB, a1, a2) -> + let b1 = elab a1 in + let b2 = elab a2 in + let (tyop, tyres) = + if is_arith_type env b1.etyp && is_arith_type env b2.etyp then begin + let tyres = binary_conversion env b1.etyp b2.etyp in + (tyres, tyres) + end else begin + match unroll env b1.etyp, unroll env b2.etyp with + | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> + if not (pointer_arithmetic_ok env ty) then + err "illegal pointer arithmetic in binary '-'"; + (TPtr(ty, []), TPtr(ty, [])) + | (TInt _ | TEnum _), (TPtr(ty, a) | TArray(ty, _, a)) -> + if not (pointer_arithmetic_ok env ty) then + err "illegal pointer arithmetic in binary '-'"; + (TPtr(ty, []), TPtr(ty, [])) + | (TPtr(ty1, a1) | TArray(ty1, _, a1)), + (TPtr(ty2, a2) | TArray(ty2, _, a2)) -> + if not (compatible_types ~noattrs:true env ty1 ty2) then + err "mismatch between pointer types in binary '-'"; + if not (pointer_arithmetic_ok env ty1) then + err "illegal pointer arithmetic in binary '-'"; + if wrap sizeof loc env ty1 = Some 0 then + err "subtraction between two pointers to zero-sized objects"; + (TPtr(ty1, []), TInt(ptrdiff_t_ikind, [])) + | _, _ -> error "type error in binary '-'" + end in + { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres } - let il_head dfl = function [] -> dfl | i1 :: il -> i1 - let il_tail = function [] -> [] | i1 :: il -> il + | BINARY(SHL, a1, a2) -> + elab_shift "<<" Oshl a1 a2 - (* 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)) + | BINARY(SHR, a1, a2) -> + elab_shift ">>" Oshr a1 a2 - (* 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) + | BINARY(EQ, a1, a2) -> + elab_comparison Oeq a1 a2 + | BINARY(NE, a1, a2) -> + elab_comparison One a1 a2 + | BINARY(LT, a1, a2) -> + elab_comparison Olt a1 a2 + | BINARY(GT, a1, a2) -> + elab_comparison Ogt a1 a2 + | BINARY(LE, a1, a2) -> + elab_comparison Ole a1 a2 + | BINARY(GE, a1, a2) -> + elab_comparison Oge a1 a2 - (* 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 + | BINARY(BAND, a1, a2) -> + elab_binary_integer "&" Oand a1 a2 + | BINARY(BOR, a1, a2) -> + elab_binary_integer "|" Oor a1 a2 + | BINARY(XOR, a1, a2) -> + elab_binary_integer "^" Oxor a1 a2 - (* 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 +(* 6.5.13 and 6.5.14 Logical operator expressions *) -(* Interpret the given designator, moving the initialization state [zi] - "down" accordingly. *) + | BINARY(AND, a1, a2) -> + elab_logical_operator "&&" Ologand a1 a2 + | BINARY(OR, a1, a2) -> + elab_logical_operator "||" Ologor a1 a2 -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' +(* 6.5.15 Conditional expressions *) + | QUESTION(a1, a2, a3) -> + let b1 = elab a1 in + let b2 = elab a2 in + let b3 = elab a3 in + if not (is_scalar_type env b1.etyp) then + err ("the first argument of '? :' is not a scalar type"); + begin match pointer_decay env b2.etyp, pointer_decay env b3.etyp with + | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> + { edesc = EConditional(b1, b2, b3); + etyp = binary_conversion env b2.etyp b3.etyp } + | TPtr(ty1, a1), TPtr(ty2, a2) -> + let tyres = + if is_void_type env ty1 || is_void_type env ty2 then + TPtr(TVoid (add_attributes a1 a2), []) + else + match combine_types ~noattrs:true env + (TPtr(ty1, a1)) (TPtr(ty2, a2)) with + | None -> + error "the second and third arguments of '? :' \ + have incompatible pointer types" + | Some ty -> ty + in + { edesc = EConditional(b1, b2, b3); etyp = tyres } + | TPtr(ty1, a1), TInt _ when is_literal_0 b3 -> + { edesc = EConditional(b1, b2, nullconst); etyp = TPtr(ty1, []) } + | TInt _, TPtr(ty2, a2) when is_literal_0 b2 -> + { edesc = EConditional(b1, nullconst, b3); etyp = TPtr(ty2, []) } + | ty1, ty2 -> + match combine_types ~noattrs:true env ty1 ty2 with | None -> - error loc "bad array element designator %Ld within %s" - n (I.name zi); - raise Exit + error ("the second and third arguments of '? :' have incompatible types") + | Some tyres -> + { edesc = EConditional(b1, b2, b3); etyp = tyres } + end + +(* 6.5.16 Assignment expressions *) + + | BINARY(ASSIGN, a1, a2) -> + let b1 = elab a1 in + let b2 = elab a2 in + if List.mem AConst (attributes_of_type env b1.etyp) then + err "left-hand side of assignment has 'const' type"; + if not (is_modifiable_lvalue env b1) then + err "left-hand side of assignment is not a modifiable l-value"; + if not (valid_assignment env b2 b1.etyp) then begin + if valid_cast env b2.etyp b1.etyp then + warning "assigning a value of type@ %a@ to a lvalue of type@ %a" + Cprint.typ b2.etyp Cprint.typ b1.etyp + else + err "assigning a value of type@ %a@ to a lvalue of type@ %a" + Cprint.typ b2.etyp Cprint.typ b1.etyp; + end; + { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp } + + | BINARY((ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN + | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN + as op), a1, a2) -> + let (sop, top) = + match op with + | ADD_ASSIGN -> (ADD, Oadd_assign) + | SUB_ASSIGN -> (SUB, Osub_assign) + | MUL_ASSIGN -> (MUL, Omul_assign) + | DIV_ASSIGN -> (DIV, Odiv_assign) + | MOD_ASSIGN -> (MOD, Omod_assign) + | BAND_ASSIGN -> (BAND, Oand_assign) + | BOR_ASSIGN -> (BOR, Oor_assign) + | XOR_ASSIGN -> (XOR, Oxor_assign) + | SHL_ASSIGN -> (SHL, Oshl_assign) + | SHR_ASSIGN -> (SHR, Oshr_assign) + | _ -> assert false in + begin match elab (BINARY(sop, a1, a2)) with + | { edesc = EBinop(_, b1, b2, _); etyp = ty } as b -> + if List.mem AConst (attributes_of_type env b1.etyp) then + err "left-hand side of assignment has 'const' type"; + if not (is_modifiable_lvalue env b1) then + err ("left-hand side of assignment is not a modifiable l-value"); + if not (valid_assignment env b b1.etyp) then begin + if valid_cast env ty b1.etyp then + warning "assigning a value of type@ %a@ to a lvalue of type@ %a" + Cprint.typ ty Cprint.typ b1.etyp + else + err "assigning a value of type@ %a@ to a lvalue of type@ %a" + Cprint.typ ty Cprint.typ b1.etyp; + end; + { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp } + | _ -> assert false 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' +(* 6.5.17 Sequential expressions *) -(* Perform the initialization described by [item] for the current - subobject of state [zi]. Continue initializing with the list [il]. *) + | BINARY(COMMA, a1, a2) -> + let b1 = elab a1 in + let b2 = elab a2 in + { edesc = EBinop (Ocomma, b1, b2, b2.etyp); etyp = b2.etyp } -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 +(* Elaboration of pre- or post- increment/decrement *) + and elab_pre_post_incr_decr op msg a1 = + let b1 = elab a1 in + if not (is_modifiable_lvalue env b1) then + err "the argument of %s is not a modifiable l-value" msg; + if not (is_scalar_type env b1.etyp) then + err "the argument of %s must be an arithmetic or pointer type" msg; + { edesc = EUnop(op, b1); etyp = b1.etyp } -(* Perform initialization by a single expression [a] for the current - subobject of state [zi], Continue initializing with the list [il']. *) +(* Elaboration of binary operators over integers *) + and elab_binary_integer msg op a1 a2 = + let b1 = elab a1 in + if not (is_integer_type env b1.etyp) then + error "the first argument of '%s' is not an integer type" msg; + let b2 = elab a2 in + if not (is_integer_type env b2.etyp) then + error "the second argument of '%s' is not an integer type" msg; + let tyres = binary_conversion env b1.etyp b2.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } -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 +(* Elaboration of binary operators over arithmetic types *) + and elab_binary_arithmetic msg op a1 a2 = + let b1 = elab a1 in + if not (is_arith_type env b1.etyp) then + error "the first argument of '%s' is not an arithmetic type" msg; + let b2 = elab a2 in + if not (is_arith_type env b2.etyp) then + error "the second argument of '%s' is not an arithmetic type" msg; + let tyres = binary_conversion env b1.etyp b2.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } -(* Start with top-level object initialized to default *) +(* Elaboration of shift operators *) + and elab_shift msg op a1 a2 = + let b1 = elab a1 in + if not (is_integer_type env b1.etyp) then + error "the first argument of '%s' is not an integer type" msg; + let b2 = elab a2 in + if not (is_integer_type env b2.etyp) then + error "the second argument of '%s' is not an integer type" msg; + let tyres = unary_conversion env b1.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres } -in elab_item (I.top env root ty_root) ie [] +(* Elaboration of comparisons *) + and elab_comparison op a1 a2 = + let b1 = elab a1 in + let b2 = elab a2 in + let resdesc = + match pointer_decay env b1.etyp, pointer_decay env b2.etyp with + | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> + EBinop(op, b1, b2, binary_conversion env b1.etyp b2.etyp) + | TInt _, TPtr(ty, _) when is_literal_0 b1 -> + EBinop(op, nullconst, b2, TPtr(ty, [])) + | TPtr(ty, _), TInt _ when is_literal_0 b2 -> + EBinop(op, b1, nullconst, TPtr(ty, [])) + | TPtr(ty1, _), TPtr(ty2, _) + when is_void_type env ty1 -> + EBinop(op, b1, b2, TPtr(ty2, [])) + | TPtr(ty1, _), TPtr(ty2, _) + when is_void_type env ty2 -> + EBinop(op, b1, b2, TPtr(ty1, [])) + | TPtr(ty1, _), TPtr(ty2, _) -> + if not (compatible_types ~noattrs:true env ty1 ty2) then + warning "comparison between incompatible pointer types"; + EBinop(op, b1, b2, TPtr(ty1, [])) + | TPtr _, (TInt _ | TEnum _) + | (TInt _ | TEnum _), TPtr _ -> + warning "comparison between integer and pointer"; + EBinop(op, b1, b2, TPtr(TVoid [], [])) + | ty1, ty2 -> + error "illegal comparison between types@ %a@ and %a" + Cprint.typ b1.etyp Cprint.typ b2.etyp in + { edesc = resdesc; etyp = TInt(IInt, []) } -(* Elaboration of a top-level initializer *) +(* Elaboration of && and || *) + and elab_logical_operator msg op a1 a2 = + let b1 = elab a1 in + if not (is_scalar_type env b1.etyp) then + err "the first argument of '%s' is not a scalar type" msg; + let b2 = elab a2 in + if not (is_scalar_type env b2.etyp) then + err "the second argument of '%s' is not a scalar type" msg; + { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []) } -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 +(* Type-checking of function arguments *) + and elab_arguments argno args params vararg = + match args, params with + | [], [] -> [] + | [], _::_ -> err "not enough arguments in function call"; [] + | _::_, [] -> + if vararg + then args + else (err "too many arguments in function call"; args) + | arg1 :: argl, (_, ty_p) :: paraml -> + let ty_a = argument_conversion env arg1.etyp in + if not (valid_assignment env {arg1 with etyp = ty_a} ty_p) then begin + if valid_cast env ty_a ty_p then + warning + "argument #%d of function call has type@ %a@ \ + instead of the expected type@ %a" + argno Cprint.typ ty_a Cprint.typ ty_p + else + err + "argument #%d of function call has type@ %a@ \ + instead of the expected type@ %a" + argno Cprint.typ ty_a Cprint.typ ty_p + end; + arg1 :: elab_arguments (argno + 1) argl paraml vararg -(* Complete an array type with the size obtained from the initializer: - "int x[] = { 1, 2, 3 }" becomes "int x[3] = ..." *) + in elab a -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 +(* Filling in forward declaration *) +let _ = elab_expr_f := elab_expr -(* Entry point *) +let elab_opt_expr loc env = function + | None -> None + | Some a -> Some (elab_expr loc env a) -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) +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 } (* Handling of __func__ (section 6.4.2.2) *) 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 + +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; +} + -- cgit v1.2.3