diff options
Diffstat (limited to 'cparser/Elab.ml')
| -rw-r--r-- | cparser/Elab.ml | 753 |
1 files changed, 433 insertions, 320 deletions
diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 2b5b4591..9cdf6c29 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -22,6 +22,7 @@ open Machine open !Cabs open Cabshelper open !C +open Cerrors open Cutil open Env @@ -30,13 +31,19 @@ open Env (* Error reporting *) let fatal_error loc fmt = - Cerrors.fatal_error ("%a: Error:@ " ^^ fmt) format_cabsloc loc + fatal_error (loc.filename,loc.lineno) fmt let error loc fmt = - Cerrors.error ("%a: Error:@ " ^^ fmt) format_cabsloc loc + error (loc.filename,loc.lineno) fmt -let warning loc fmt = - Cerrors.warning ("%a: Warning:@ " ^^ fmt) format_cabsloc loc +let warning loc = + warning (loc.filename,loc.lineno) + +let print_typ env fmt ty = + match ty with + | TNamed _ -> + Format.fprintf fmt "'%a' (aka '%a')" Cprint.typ_raw ty Cprint.typ_raw (Cutil.unroll env ty) + | _ -> Format.fprintf fmt "'%a'" Cprint.typ_raw ty (* Error reporting for Env functions *) @@ -115,12 +122,9 @@ let combine_toplevel_definitions loc env s old_sto old_ty sto ty = | Some new_ty -> new_ty | None -> - let id = Env.fresh_ident s in error loc - "redefinition of '%s' with incompatible type.@ \ - Previous declaration: %a.@ \ - New declaration: %a" - s Cprint.simple_decl (id, old_ty) Cprint.simple_decl (id, ty); + "redefinition of '%s' with a different type: %a vs %a" + s (print_typ env) old_ty (print_typ env) ty; ty in let new_sto = (* The only case not allowed is removing static *) @@ -130,8 +134,8 @@ let combine_toplevel_definitions loc env s old_sto old_ty sto ty = | Storage_register,Storage_register | Storage_default,Storage_default -> sto | _,Storage_static -> - error loc "static redefinition of '%s' after non-static definition" s; - sto + error loc "static declaration of '%s' follows non-static declaration" s; + sto | Storage_static,_ -> Storage_static (* Static stays static *) | Storage_extern,_ -> sto | Storage_default,Storage_extern -> Storage_extern @@ -149,14 +153,14 @@ let enter_or_refine_ident local loc env s sto ty = - an enum that was already declared in the same scope. Redefinition of a variable at global scope (or extern) is treated below. *) if redef Env.lookup_typedef env s then - error loc "redefinition of typedef '%s' as different kind of symbol" s; + error loc "redefinition of '%s' as different kind of symbol" s; begin match previous_def Env.lookup_ident env s with | Some(id, II_ident(old_sto, old_ty)) when local && Env.in_current_scope env id && not (sto = Storage_extern && old_sto = Storage_extern) -> - error loc "redefinition of local variable '%s'" s + error loc "redefinition of '%s'" s | Some(id, II_enum _) when Env.in_current_scope env id -> - error loc "redefinition of enumerator '%s'" s + error loc "redefinition of '%s' as different kind of symbol" s; | _ -> () end; @@ -184,8 +188,8 @@ let enter_or_refine_ident local loc env s sto ty = let elab_expr_f : (cabsloc -> Env.t -> Cabs.expression -> C.exp * Env.t) ref = ref (fun _ _ _ -> assert false) -let elab_funbody_f : (C.typ -> Env.t -> statement -> C.stmt) ref - = ref (fun _ _ _ -> assert false) +let elab_funbody_f : (C.typ -> bool -> Env.t -> statement -> C.stmt) ref + = ref (fun _ _ _ _ -> assert false) (** * Elaboration of constants - C99 section 6.4.4 *) @@ -277,7 +281,7 @@ let elab_int_constant loc s0 = try parse_int base s with | Overflow -> - error loc "integer literal '%s' is too large" s0; + error loc "integer literal '%s' is too large to be represented in any integer type" s0; 0L | Bad_digit -> (*error loc "bad digit in integer literal '%s'" s0;*) (* Is caught earlier *) @@ -313,17 +317,23 @@ let elab_char_constant loc wide chars = (* Treat multi-char constants as a number in base 2^nbits *) let max_digit = Int64.shift_left 1L nbits in let max_val = Int64.shift_left 1L (64 - nbits) in - let v = + let v,_ = List.fold_left - (fun acc d -> - if acc < 0L || acc >= max_val then - error loc "character constant overflows"; - if d < 0L || d >= max_digit then - error loc "escape sequence is out of range (code 0x%LX)" d; - Int64.add (Int64.shift_left acc nbits) d) - 0L chars in + (fun (acc,err) d -> + if not err then begin + let overflow = acc < 0L || acc >= max_val + and out_of_range = d < 0L || d >= max_digit in + if overflow then + error loc "character constant too long for its type"; + if out_of_range then + error loc "escape sequence is out of range (code 0x%LX)" d; + Int64.add (Int64.shift_left acc nbits) d,overflow || out_of_range + end else + Int64.add (Int64.shift_left acc nbits) d,true + ) + (0L,false) chars in if not (integer_representable v IInt) then - warning loc "character constant cannot be represented at type 'int'"; + warning loc Unnamed "character constant too long for its type"; (* C99 6.4.4.4 item 10: single character -> represent at type char or wchar_t *) Ceval.normalize_int v @@ -365,7 +375,7 @@ let elab_constant loc = function let elab_simple_string loc wide chars = match elab_string_literal loc wide chars with | CStr s -> s - | _ -> error loc "wide character string not allowed here"; "" + | _ -> error loc "cannot use wide string literal in 'asm'"; "" (** * Elaboration of type expressions, type specifiers, name declarations *) @@ -406,7 +416,8 @@ let elab_gcc_attr loc env = function begin try [Attr(v, List.map (elab_attr_arg loc env) args)] with Wrong_attr_arg -> - warning loc "cannot parse '%s' attribute, ignored" v; [] + warning loc Unknown_attribute + "unknown attribute '%s' ignored" v; [] end let is_power_of_two n = n > 0L && Int64.logand n (Int64.pred n) = 0L @@ -415,8 +426,11 @@ let extract_alignas loc a = match a with | Attr(("aligned"|"__aligned__"), args) -> begin match args with - | [AInt n] when is_power_of_two n -> AAlignas (Int64.to_int n) - | _ -> warning loc "bad 'aligned' attribute, ignored"; a + | [AInt n] when is_power_of_two n -> AAlignas (Int64.to_int n) + | [AInt n] -> error loc "requested alignment is not a power of 2"; a + | [_] -> error loc "requested alignment is not an integer constant"; a + | [] -> a (* Use the default alignment as the gcc does *) + | _ -> error loc "'aligned' attribute takes no more than 1 argument"; a end | _ -> a @@ -431,12 +445,17 @@ let elab_attribute env = function [Attr("__packed__", List.map (elab_attr_arg loc env) args)] | ALIGNAS_ATTR ([a], loc) -> begin match elab_attr_arg loc env a with - | AInt n when is_power_of_two n -> [AAlignas (Int64.to_int n)] - | _ -> warning loc "bad _Alignas value, ignored"; [] - | exception Wrong_attr_arg -> warning loc "bad _Alignas value, ignored"; [] + | AInt n -> + if is_power_of_two n then + [AAlignas (Int64.to_int n)] + else begin + error loc "requested alignment is not a power of 2"; [] + end + | _ -> error loc "requested alignment is not an integer constant"; [] + | exception Wrong_attr_arg -> error loc "bad _Alignas value"; [] end | ALIGNAS_ATTR (_, loc) -> - warning loc "_Alignas takes exactly one parameter, ignored"; [] + error loc "_Alignas takes no more than 1 argument"; [] let elab_attributes env al = List.fold_left add_attributes [] (List.map (elab_attribute env) al) @@ -473,7 +492,7 @@ let is_anonymous_composite spec = C99 section 6.7.2. *) -let rec elab_specifier ?(only = false) loc env specifier = +let rec elab_specifier keep_ty ?(only = false) loc env specifier = (* We first divide the parts of the specifier as follows: - a storage class - a set of attributes (const, volatile, restrict) @@ -490,7 +509,7 @@ let rec elab_specifier ?(only = false) loc env specifier = attr := add_attributes (elab_cvspec env cv) !attr | SpecStorage st -> if !sto <> Storage_default && st <> TYPEDEF then - error loc "multiple storage specifiers"; + error loc "multiple storage-classes in declaration specifier"; begin match st with | AUTO -> () | STATIC -> sto := Storage_static @@ -577,14 +596,14 @@ let rec elab_specifier ?(only = false) loc env specifier = let a' = add_attributes (get_type_attrs()) (elab_attributes env a) in let (id', env') = - elab_struct_or_union only Struct loc id optmembers a' env in + elab_struct_or_union keep_ty only Struct loc id optmembers a' env in (!sto, !inline, !noreturn, !typedef, TStruct(id', !attr), env') | [Cabs.Tstruct_union(UNION, id, optmembers, a)] -> let a' = add_attributes (get_type_attrs()) (elab_attributes env a) in let (id', env') = - elab_struct_or_union only Union loc id optmembers a' env in + elab_struct_or_union keep_ty only Union loc id optmembers a' env in (!sto, !inline, !noreturn, !typedef, TUnion(id', !attr), env') | [Cabs.Tenum(id, optmembers, a)] -> @@ -610,8 +629,15 @@ and elab_cvspecs env cv_specs = List.fold_left add_attributes [] (List.map (elab_cvspec env) cv_specs) (* Elaboration of a type declarator. C99 section 6.7.5. *) +and elab_return_type loc env ty = + match unroll env ty with + | TArray _ -> + error loc "function cannot return array type %a" (print_typ env) ty + | TFun _ -> + error loc "function cannot return function type %a" (print_typ env) ty + | _ -> () -and elab_type_declarator loc env ty kr_ok = function +and elab_type_declarator keep_ty loc env ty kr_ok = function | Cabs.JUSTBASE -> ((ty, None), env) | Cabs.ARRAY(d, cv_specs, sz) -> @@ -624,59 +650,53 @@ and elab_type_declarator loc env ty kr_ok = function let expr,env = (!elab_expr_f loc env sz) in match Ceval.integer_expr env expr with | Some n -> - if n < 0L then error loc "array size is negative"; - if n = 0L then warning loc "array of size 0"; + if n < 0L then error loc "size of array is negative"; + if n = 0L then warning loc Zero_length_array + "zero size arrays are an extension"; Some n | None -> - error loc "array size is not a compile-time constant"; + error loc "size of array is not a compile-time constant"; Some 1L in (* produces better error messages later *) - elab_type_declarator loc env (TArray(ty, sz', a)) kr_ok d + elab_type_declarator keep_ty loc env (TArray(ty, sz', a)) kr_ok d | Cabs.PTR(cv_specs, d) -> let a = elab_cvspecs env cv_specs in - elab_type_declarator loc env (TPtr(ty, a)) kr_ok d + elab_type_declarator keep_ty loc env (TPtr(ty, a)) kr_ok d | Cabs.PROTO(d, (params, vararg)) -> - begin match unroll env ty with - | TArray _ | TFun _ -> - error loc "Illegal function return type@ %a" Cprint.typ ty - | _ -> () - end; - let params' = elab_parameters env params in - elab_type_declarator loc env (TFun(ty, Some params', vararg, [])) kr_ok d + elab_return_type loc env ty; + let params',env' = elab_parameters keep_ty env params in + let env = if keep_ty then Env.add_types env env' else env in + elab_type_declarator keep_ty loc env (TFun(ty, Some params', vararg, [])) kr_ok d | Cabs.PROTO_OLD(d, params) -> - begin match unroll env ty with - | TArray _ | TFun _ -> - error loc "Illegal function return type@ %a" Cprint.typ ty - | _ -> () - end; + elab_return_type loc env ty; match params with | [] -> - elab_type_declarator loc env (TFun(ty, None, false, [])) kr_ok d + elab_type_declarator keep_ty loc env (TFun(ty, None, false, [])) kr_ok d | _ -> if not kr_ok || d <> Cabs.JUSTBASE then - fatal_error loc "Illegal old-style K&R function definition"; + fatal_error loc "illegal old-style K&R function definition"; ((TFun(ty, None, false, []), Some params), env) (* Elaboration of parameters in a prototype *) -and elab_parameters env params = +and elab_parameters keep_ty env params = (* Prototype introduces a new scope *) - let (vars, _) = mmap elab_parameter (Env.new_scope env) params in + let (vars, env) = mmap (elab_parameter keep_ty) (Env.new_scope env) params in (* Catch special case f(t) where t is void or a typedef to void *) match vars with - | [ ( {C.name=""}, t) ] when is_void_type env t -> [] - | _ -> vars + | [ ( {C.name=""}, t) ] when is_void_type env t -> [],env + | _ -> vars,env (* Elaboration of a function parameter *) -and elab_parameter env (PARAM (spec, id, decl, attr, loc)) = - let (sto, inl, noret, tydef, bty, env1) = elab_specifier loc env spec in +and elab_parameter keep_ty env (PARAM (spec, id, decl, attr, loc)) = + let (sto, inl, noret, tydef, bty, env1) = elab_specifier keep_ty loc env spec in if tydef then error loc "'typedef' used in function parameter"; - let ((ty, _), _) = elab_type_declarator loc env1 bty false decl in + let ((ty, _), _) = elab_type_declarator keep_ty loc env1 bty false decl in let ty = add_attributes_type (elab_attributes env attr) ty in if sto <> Storage_default && sto <> Storage_register then error loc - "'extern' or 'static' storage not supported for function parameter"; + "invalid storage-class specifier in function declarator"; if inl then error loc "'inline' can only appear on functions"; if noret then @@ -687,23 +707,23 @@ and elab_parameter env (PARAM (spec, id, decl, attr, loc)) = (* replace array and function types by pointer types *) let ty1 = argument_conversion env1 ty in let (id', env2) = Env.enter_ident env1 id sto ty1 in - ( (id', ty1) , env2 ) + ( (id', ty1) , env2) (* Elaboration of a (specifier, Cabs "name") pair *) -and elab_fundef_name env spec (Name (id, decl, attr, loc)) = - let (sto, inl, noret, tydef, bty, env') = elab_specifier loc env spec in +and elab_fundef_name keep_ty env spec (Name (id, decl, attr, loc)) = + let (sto, inl, noret, tydef, bty, env') = elab_specifier keep_ty loc env spec in if tydef then error loc "'typedef' is forbidden here"; - let ((ty, kr_params), env'') = elab_type_declarator loc env' bty true decl in + let ((ty, kr_params), env'') = elab_type_declarator keep_ty loc env' bty true decl in let a = elab_attributes env attr in (id, sto, inl, noret, add_attributes_type a ty, kr_params, env'') (* Elaboration of a name group. C99 section 6.7.6 *) -and elab_name_group loc env (spec, namelist) = +and elab_name_group keep_ty loc env (spec, namelist) = let (sto, inl, noret, tydef, bty, env') = - elab_specifier loc env spec in + elab_specifier keep_ty loc env spec in if tydef then error loc "'typedef' is forbidden here"; if inl then @@ -712,19 +732,19 @@ and elab_name_group loc env (spec, namelist) = error loc "'_Noreturn' is forbidden here"; let elab_one_name env (Name (id, decl, attr, loc)) = let ((ty, _), env1) = - elab_type_declarator loc env bty false decl in + elab_type_declarator keep_ty loc env bty false decl in let a = elab_attributes env attr in ((id, add_attributes_type a ty), env1) in (mmap elab_one_name env' namelist, sto) (* Elaboration of an init-name group *) -and elab_init_name_group loc env (spec, namelist) = +and elab_init_name_group keep_ty loc env (spec, namelist) = let (sto, inl, noret, tydef, bty, env') = - elab_specifier ~only:(namelist=[]) loc env spec in + elab_specifier keep_ty ~only:(namelist=[]) loc env spec in let elab_one_name env (Init_name (Name (id, decl, attr, loc), init)) = let ((ty, _), env1) = - elab_type_declarator loc env bty false decl in + elab_type_declarator keep_ty loc env bty false decl in let a = elab_attributes env attr in if inl && not (is_function_type env ty) then error loc "'inline' can only appear on functions"; @@ -735,7 +755,7 @@ and elab_init_name_group loc env (spec, namelist) = (* Elaboration of a field group *) -and elab_field_group env (Field_group (spec, fieldlist, loc)) = +and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = let fieldlist = List.map ( function @@ -745,15 +765,16 @@ and elab_field_group env (Field_group (spec, fieldlist, loc)) = in let ((names, env'), sto) = - elab_name_group loc env (spec, List.map fst fieldlist) in + elab_name_group keep_ty loc env (spec, List.map fst fieldlist) in if sto <> Storage_default then error loc "non-default storage in struct or union"; if fieldlist = [] then if is_anonymous_composite spec then - warning loc "ISO C99 does not support anonymous structs/unions" + warning loc Celeven_extension "anonymous structs/unions are a C11 extension" else - warning loc "declaration does not declare any members"; + (* This should actually never be triggered, empty structs are captured earlier *) + warning loc Missing_declarations "declaration does not declare anything"; let elab_bitfield (Name (_, _, _, loc), optbitsize) (id, ty) = let optbitsize' = @@ -767,28 +788,28 @@ and elab_field_group env (Field_group (spec, fieldlist, loc)) = | _ -> ILongLong (* trigger next error message *) in if integer_rank ik > integer_rank IInt then begin error loc - "the type of bitfield '%s' must be an integer type \ - no bigger than 'int'" id; + "the type of bit-field '%s' must be an integer type no bigger than 'int'" id; None end else begin let expr,env' =(!elab_expr_f loc env sz) in match Ceval.integer_expr env' expr with | Some n -> if n < 0L then begin - error loc "bit size of '%s' (%Ld) is negative" id n; + error loc "bit-field '%s' has negative width (%Ld)" id n; None end else - if n > Int64.of_int(sizeof_ikind ik * 8) then begin - error loc "bit size of '%s' (%Ld) exceeds its type" id n; - None + let max = Int64.of_int(sizeof_ikind ik * 8) in + if n > max then begin + error loc "size of bit-field '%s' (%Ld bits) exceeds its type (%Ld bits)" id n max; + None end else if n = 0L && id <> "" then begin - error loc "member '%s' has zero size" id; + error loc "named bit-field '%s' has zero width" id; None end else Some(Int64.to_int n) | None -> - error loc "bit size of '%s' is not a compile-time constant" id; + error loc "bit-field '%s' width not an integer constant" id; None end in { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' } @@ -797,9 +818,17 @@ and elab_field_group env (Field_group (spec, fieldlist, loc)) = (* Elaboration of a struct or union. C99 section 6.7.2.1 *) -and elab_struct_or_union_info kind loc env members attrs = - let (m, env') = mmap elab_field_group env members in +and elab_struct_or_union_info keep_ty kind loc env members attrs = + let (m, env') = mmap (elab_field_group keep_ty) env members in let m = List.flatten m in + ignore (List.fold_left (fun acc fld -> + let n = fld.fld_name in + if n <> "" then begin + if List.exists ((=) n) acc then + error loc "duplicate member '%s'" n; + n::acc + end else + acc) [] m); (* Check for incomplete types *) let rec check_incomplete = function | [] -> () @@ -814,16 +843,16 @@ and elab_struct_or_union_info kind loc env members attrs = (* Warn for empty structs or unions *) if m = [] then if kind = Struct then begin - warning loc "empty struct" + warning loc Gnu_empty_struct "empty struct is a GNU extension" end else begin - fatal_error loc "empty union" + fatal_error loc "empty union is a GNU extension" end; (composite_info_def env' kind attrs m, env') -and elab_struct_or_union only kind loc tag optmembers attrs env = +and elab_struct_or_union keep_ty only kind loc tag optmembers attrs env = let warn_attrs () = if attrs <> [] then - warning loc "attributes over struct/union ignored in this context" in + warning loc Unnamed "attribute declaration must precede definition" in let optbinding, tag = match tag with | None -> None, "" @@ -838,14 +867,16 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = and the composite was bound in another scope, create a new incomplete composite instead via the case "_, None" below. *) + if ci.ci_kind <> kind then + fatal_error loc "use of '%s' with tag type that does not match previous declaration" tag; warn_attrs(); (tag', env) | Some(tag', ({ci_sizeof = None} as ci)), Some members when Env.in_current_scope env tag' -> if ci.ci_kind <> kind then - error loc "struct/union mismatch on tag '%s'" tag; + error loc "use of '%s' with tag type that does not match previous declaration" tag; (* finishing the definition of an incomplete struct or union *) - let (ci', env') = elab_struct_or_union_info kind loc env members attrs in + let (ci', env') = elab_struct_or_union_info keep_ty kind loc env members attrs in (* Emit a global definition for it *) emit_elab env' loc (Gcompositedef(kind, tag', attrs, ci'.ci_members)); (* Replace infos but keep same ident *) @@ -873,7 +904,7 @@ and elab_struct_or_union only kind loc tag optmembers attrs env = emit_elab env' loc (Gcompositedecl(kind, tag', attrs)); (* elaborate the members *) let (ci2, env'') = - elab_struct_or_union_info kind loc env' members attrs in + elab_struct_or_union_info keep_ty kind loc env' members attrs in (* emit a definition *) emit_elab env'' loc (Gcompositedef(kind, tag', attrs, ci2.ci_members)); (* Replace infos but keep same ident *) @@ -892,15 +923,15 @@ and elab_enum_item env ((s, exp), loc) nextval = | Some n -> (n, Some exp') | None -> error loc - "value of enumerator '%s' is not a compile-time constant" s; + "value of enumerator '%s' is not an integer constant" s; (nextval, Some exp') in if redef Env.lookup_ident env s then - error loc "redefinition of identifier '%s'" s; + error loc "'%s' redeclared as different kind of symbol" s; if redef Env.lookup_typedef env s then - error loc "redefinition of typedef '%s' as different kind of symbol" s; + error loc "'%s' redeclared as different kind of symbol" s; if not (int_representable v (8 * sizeof_ikind enum_ikind) (is_signed_ikind enum_ikind)) then - warning loc "the value of '%s' is not representable with type %a" - s Cprint.typ (TInt(enum_ikind, [])); + warning loc Constant_conversion "integer literal '%Ld' is too large to be represented in any integer type" + v; let (id, env') = Env.enter_enum_item env s v in ((id, v, exp'), Int64.succ v, env') @@ -932,8 +963,8 @@ and elab_enum only loc tag optmembers attrs env = (* Elaboration of a naked type, e.g. in a cast *) let elab_type loc env spec decl = - let (sto, inl, noret, tydef, bty, env') = elab_specifier loc env spec in - let ((ty, _), env'') = elab_type_declarator loc env' bty false decl in + let (sto, inl, noret, tydef, bty, env') = elab_specifier false loc env spec in + let ((ty, _), env'') = elab_type_declarator false loc env' bty false decl in if sto <> Storage_default || inl || noret || tydef then error loc "'typedef', 'extern', 'static', 'register' and 'inline' are meaningless in cast"; (ty, env'') @@ -972,13 +1003,18 @@ let init_int_array_wstring opt_size s = let check_init_type loc env a ty = if wrap2 valid_assignment loc env a ty then () else if wrap2 valid_cast loc env a.etyp ty then - warning loc - "initializer has type@ %a@ instead of the expected type @ %a" - Cprint.typ a.etyp Cprint.typ ty + if wrap2 int_pointer_conversion loc env a.etyp ty then + warning loc Int_conversion + "incompatible integer-pointer conversion initializer has type %a instead of the expected type %a" + (print_typ env) a.etyp (print_typ env) ty + else + warning loc Unnamed + "incompatible conversion initializer has type %a instead of the expected type %a" + (print_typ env) a.etyp (print_typ env) ty else error loc - "initializer has type@ %a@ instead of the expected type @ %a" - Cprint.typ a.etyp Cprint.typ ty + "initializer has type %a instead of the expected type %a" + (print_typ env) a.etyp (print_typ env) ty (* Representing initialization state using zippers *) @@ -1171,16 +1207,14 @@ let rec elab_designator loc env zi desig = let expr,env = (!elab_expr_f loc env a) in begin match Ceval.integer_expr env expr with | None -> - error loc "array element designator for %s is not a compile-time constant" - (I.name zi); + error loc "array element designator for %s is not an integer constant expression" (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); + error loc "array index %Ld within %s exceeds array bounds" n (I.name zi); raise Exit end @@ -1203,7 +1237,7 @@ let rec elab_list zi il first = 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" + warning loc Unnamed "excess elements in initializer for %s" (I.name zi); I.to_init zi | Some zi' -> @@ -1226,16 +1260,14 @@ and elab_item zi item il = 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); + warning loc Unnamed "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(_, _) when compatible_types AttrIgnoreTop env ty_elt (TInt(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); + warning loc Unnamed "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"; @@ -1281,13 +1313,22 @@ and elab_single zi a il = raise Exit end | _ -> - error loc "impossible to initialize %s of type@ %a" - (I.name zi) Cprint.typ ty; + error loc "impossible to initialize %s of type %a" + (I.name zi) (print_typ env) ty; raise Exit (* Start with top-level object initialized to default *) -in elab_item (I.top env root ty_root) ie [] +in +if is_function_type env ty_root then begin + error loc "illegal initializer (only variables can be initialized)"; + raise Exit +end; +try + elab_item (I.top env root ty_root) ie [] +with No_default_init -> + error loc "variable has incomplete type %a" Cprint.typ ty_root; + raise Exit (* Elaboration of a top-level initializer *) @@ -1307,7 +1348,7 @@ let elab_initial loc env root ty ie = 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"; + if il = [] then warning loc Zero_length_array "zero size arrays are an extension"; TArray(ty_elt, Some(Int64.of_int(List.length il)), attr) | _ -> ty @@ -1323,11 +1364,22 @@ let elab_initializer loc env root ty ie = (* Elaboration of expressions *) -let elab_expr loc env a = +let elab_expr vararg 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 warning t fmt = + warning loc t fmt in + + let check_ptr_arith env ty s = + match unroll env ty with + | TVoid _ -> + err "illegal arithmetic on a pointer to void in binary '%c'" s + | TFun _ -> + err "illegal arithmetic on a pointer to the function type %a in binary '%c'" (print_typ env) ty s + | _ -> if incomplete_type env ty then + err "arithmetic on a pointer to an incomplete type %a in binary '%c'" (print_typ env) ty s + in let rec elab env = function @@ -1354,7 +1406,7 @@ let elab_expr loc env a = 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 + | t1, t2 -> error "subscripted value is neither an array nor pointer" in { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres },env | MEMBEROF(a1, fieldname) -> @@ -1366,7 +1418,7 @@ let elab_expr loc env a = | 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 + error "request for member '%s' in something not a structure or union" fieldname 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) @@ -1383,10 +1435,10 @@ let elab_expr loc env a = | 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" + error "request for member '%s' in something not a structure or union" fieldname end | _ -> - error "left-hand side of '->' is not a pointer " in + error "member reference type %a is not a pointer" (print_typ env) b1.etyp in { edesc = EUnop(Oarrow fieldname, b1); etyp = add_attributes_type (List.filter attr_inherited_by_members attrs) (type_of_member env fld) },env @@ -1400,6 +1452,8 @@ let elab_expr loc env a = (elaboration) --> __builtin_va_arg(ap, sizeof(ty)) *) | CALL((VARIABLE "__builtin_va_start" as a1), [a2; a3]) -> + if not vararg then + err "'va_start' used in function with fixed args"; let b1,env = elab env a1 in let b2,env = elab env a2 in let _b3,env = elab env a3 in @@ -1417,9 +1471,8 @@ let elab_expr loc env a = let ty = match b3.edesc with ESizeof ty -> ty | _ -> assert false in let ty' = default_argument_conversion env ty in if not (compatible_types AttrIgnoreTop 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; + warning Varargs "%a is promoted to %a when passed through '...'. You should pass %a, not %a, to 'va_arg'" + (print_typ env) ty (print_typ env) ty' (print_typ env) ty' (print_typ env) ty; { edesc = ECall(ident, [b2; b3]); etyp = ty },env | CALL(a1, al) -> @@ -1428,7 +1481,7 @@ let elab_expr loc env a = having declared it *) match a1 with | VARIABLE n when not (Env.ident_is_bound env n) -> - warning "implicit declaration of function '%s'" n; + warning Implicit_function_declaration "implicit declaration of function '%s' is invalid in C99" n; let ty = TFun(TInt(IInt, []), None, false, []) in (* Check against other definitions and enter in env *) let (id, sto, env, ty, linkage) = @@ -1445,9 +1498,9 @@ let elab_expr loc env a = | 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" + | _ -> error "called object type %a is neither a function nor function pointer" (print_typ env) b1.etyp end - | _ -> error "the function part of a call does not have a function type" + | _ -> error "called object type %a is neither a function nor function pointer" (print_typ env) b1.etyp in (* Type-check the arguments against the prototype *) let bl',env = @@ -1457,23 +1510,37 @@ let elab_expr loc env a = { edesc = ECall(b1, bl'); etyp = res },env | UNARY(POSINCR, a1) -> - elab_pre_post_incr_decr Opostincr "postfix '++'" a1 + elab_pre_post_incr_decr Opostincr "increment" a1 | UNARY(POSDECR, a1) -> - elab_pre_post_incr_decr Opostdecr "postfix '--'" a1 + elab_pre_post_incr_decr Opostdecr "decrement" a1 (* 6.5.4 Cast operators *) | CAST ((spec, dcl), SINGLE_INIT a1) -> - let (ty, _) = elab_type loc env spec dcl in + let (ty, env) = elab_type loc env spec dcl in let b1,env = elab env a1 in if not (wrap2 valid_cast loc env b1.etyp ty) then - err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty; + begin match unroll env b1.etyp, unroll env ty with + | _, (TStruct _|TUnion _ | TVoid _) -> + err "used type %a where arithmetic or pointer type is required" + (print_typ env) ty + | (TStruct _| TUnion _ | TVoid _),_ -> + err "operand of type %a where arithmetic or pointer type is required" + (print_typ env) b1.etyp + | TFloat _, TPtr _ -> + err "operand of type %a cannot be cast to a pointer type" + (print_typ env) b1.etyp + | TPtr _ , TFloat _ -> + err "pointer cannot be cast to type %a" (print_typ env) ty + | _ -> + err "illegal cast from %a to %a" (print_typ env) b1.etyp (print_typ env) ty + end; { edesc = ECast(ty, b1); etyp = ty },env (* 6.5.2.5 Compound literals *) | CAST ((spec, dcl), ie) -> - let (ty, _) = elab_type loc env spec dcl in + let (ty, env) = elab_type loc env spec dcl in begin match elab_initializer loc env "<compound literal>" ty ie with | (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' },env | (ty', None) -> error "ill-formed compound literal" @@ -1484,7 +1551,7 @@ let elab_expr loc env a = | EXPR_SIZEOF a1 -> let b1,env = elab env a1 in if wrap incomplete_type loc env b1.etyp then - err "incomplete type %a" Cprint.typ b1.etyp; + error "invalid application of 'sizeof' to an incomplete type %a" (print_typ env) b1.etyp; let bdesc = (* Catch special cases sizeof("string literal") *) match b1.edesc with @@ -1501,49 +1568,49 @@ let elab_expr loc env a = | TYPE_SIZEOF (spec, dcl) -> let (ty, env') = elab_type loc env spec dcl in if wrap incomplete_type loc env' ty then - err "incomplete type %a" Cprint.typ ty; + error "invalid application of 'sizeof' to an incomplete type %a" (print_typ env) ty; { edesc = ESizeof ty; etyp = TInt(size_t_ikind(), []) },env' | EXPR_ALIGNOF a1 -> let b1,env = elab env a1 in if wrap incomplete_type loc env b1.etyp then - err "incomplete type %a" Cprint.typ b1.etyp; + error "invalid application of 'alignof' to an incomplete type %a" (print_typ env) b1.etyp; { edesc = EAlignof b1.etyp; etyp = TInt(size_t_ikind(), []) },env | TYPE_ALIGNOF (spec, dcl) -> let (ty, env') = 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(), []) },env + error "invalid application of 'alignof' to an incomplete type %a" (print_typ env) ty; + { edesc = EAlignof ty; etyp = TInt(size_t_ikind(), []) },env' | UNARY(PLUS, a1) -> let b1,env = elab env a1 in if not (is_arith_type env b1.etyp) then - err "argument of unary '+' is not an arithmetic type"; + error "invalid argument type %a to unary '+'" (print_typ env) b1.etyp; { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp },env | UNARY(MINUS, a1) -> let b1,env = elab env a1 in if not (is_arith_type env b1.etyp) then - err "argument of unary '-' is not an arithmetic type"; + error "invalid argument type %a to unary '-'" (print_typ env) b1.etyp; { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp },env | UNARY(BNOT, a1) -> let b1,env = elab env a1 in if not (is_integer_type env b1.etyp) then - err "argument of '~' is not an integer type"; + error "invalid argument type %a to unary '~'" (print_typ env) b1.etyp; { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp },env | UNARY(NOT, a1) -> let b1,env = elab env a1 in if not (is_scalar_type env b1.etyp) then - err "argument of '!' is not a scalar type"; + error "invalid argument type %a to unary '!'" (print_typ env) b1.etyp; { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []) },env | UNARY(ADDROF, a1) -> let b1,env = elab env a1 in if not (is_lvalue b1 || is_function_type env b1.etyp) then - err "argument of '&' is not an l-value"; + err "argument of '&' is not an lvalue (invalid %a)" (print_typ env) b1.etyp; begin match b1.edesc with | EVar id -> begin match wrap Env.find_ident loc env id with @@ -1571,13 +1638,14 @@ let elab_expr loc env a = | TPtr(ty, _) | TArray(ty, _, _) -> { edesc = EUnop(Oderef, b1); etyp = ty },env | _ -> - error "argument of unary '*' is not a pointer" + error "arguemnt of unary '*' is not a pointer (%a invalid)" + (print_typ env) b1.etyp end | UNARY(PREINCR, a1) -> - elab_pre_post_incr_decr Opreincr "prefix '++'" a1 + elab_pre_post_incr_decr Opreincr "increment" a1 | UNARY(PREDECR, a1) -> - elab_pre_post_incr_decr Opredecr "prefix '--'" a1 + elab_pre_post_incr_decr Opredecr "decrement" a1 (* 6.5.5 to 6.5.12 Binary operator expressions *) @@ -1588,7 +1656,7 @@ let elab_expr loc env a = elab_binary_arithmetic "/" Odiv a1 a2 | BINARY(MOD, a1, a2) -> - elab_binary_integer "/" Omod a1 a2 + elab_binary_integer "%" Omod a1 a2 | BINARY(ADD, a1, a2) -> let b1,env = elab env a1 in @@ -1601,9 +1669,10 @@ let elab_expr loc env a = 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 '+'"; + | _, _ -> error "invalid operands to binary '+' (%a and %a)" + (print_typ env) b1.etyp (print_typ env) b2.etyp + in + check_ptr_arith env ty '+'; TPtr(ty, []) end in { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres },env @@ -1616,25 +1685,25 @@ let elab_expr loc env a = 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 + match wrap unroll loc env b1.etyp, wrap unroll loc env b2.etyp with | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> - if not (pointer_arithmetic_ok env ty) then + if not (wrap pointer_arithmetic_ok loc 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 '-'"; + check_ptr_arith env ty '-'; (TPtr(ty, []), TPtr(ty, [])) | (TPtr(ty1, a1) | TArray(ty1, _, a1)), (TPtr(ty2, a2) | TArray(ty2, _, a2)) -> if not (compatible_types AttrIgnoreAll 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 '-'"; + err "%a and %a are not pointers to compatible types" + (print_typ env) b1.etyp (print_typ env) b1.etyp; + check_ptr_arith env ty1 '-'; 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 '-'" + | _, _ -> error "invalid operands to binary '-' (%a and %a)" + (print_typ env) b1.etyp (print_typ env) b2.etyp end in { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres },env @@ -1677,12 +1746,13 @@ let elab_expr loc env a = let b2,env = elab env a2 in let b3,env = elab env a3 in if not (is_scalar_type env b1.etyp) then - err ("the first argument of '? :' is not a scalar type"); + err "first argument of '?:' is not a scalar type (invalid %a)" + (print_typ env) b1.etyp; 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 },env - | TPtr(ty1, a1), TPtr(ty2, a2) -> + | (TPtr(ty1, a1) as pty1), (TPtr(ty2, a2) as pty2) -> let tyres = if is_void_type env ty1 || is_void_type env ty2 then TPtr(TVoid (add_attributes a1 a2), []) @@ -1690,8 +1760,8 @@ let elab_expr loc env a = match combine_types AttrIgnoreAll env (TPtr(ty1, a1)) (TPtr(ty2, a2)) with | None -> - warning "the second and third arguments of '? :' \ - have incompatible pointer types"; + warning Pointer_type_mismatch "the second and third argument of '?:' have incompatible pointer types (%a and %a)" + (print_typ env) pty1 (print_typ env) pty2; (* tolerance *) TPtr(TVoid (add_attributes a1 a2), []) | Some ty -> ty @@ -1704,7 +1774,8 @@ let elab_expr loc env a = | ty1, ty2 -> match combine_types AttrIgnoreAll env ty1 ty2 with | None -> - error ("the second and third arguments of '? :' have incompatible types") + error "the second and third argument of '?:' incompatible types (%a and %a)" + (print_typ env) ty1 (print_typ env) ty2 | Some tyres -> { edesc = EConditional(b1, b2, b3); etyp = tyres },env end @@ -1715,16 +1786,22 @@ let elab_expr loc env a = let b1,env = elab env a1 in let b2,env = elab env a2 in if List.mem AConst (attributes_of_type env b1.etyp) then - err "left-hand side of assignment has 'const' type"; + error "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"; + err "expression is not assignable"; if not (wrap2 valid_assignment loc env b2 b1.etyp) then begin if wrap2 valid_cast loc 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 + if wrap2 int_pointer_conversion loc env b2.etyp b1.etyp then + warning Int_conversion + "incompatible integer-pointer conversion: assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) b2.etyp + else + warning Unnamed + "incompatible conversion assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) b2.etyp else - err "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ b2.etyp Cprint.typ b1.etyp; + err "assigning to %a from incompatible type %a" + (print_typ env) b1.etyp (print_typ env) b2.etyp; end; { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp },env @@ -1749,14 +1826,20 @@ let elab_expr loc env a = 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"); + err "expression is not assignable"; if not (wrap2 valid_assignment loc env b b1.etyp) then begin if wrap2 valid_cast loc 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 + if wrap2 int_pointer_conversion loc env ty b1.etyp then + warning Int_conversion + "incompatible integer-pointer conversion: assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) ty + else + warning Unnamed + "incompatible conversion assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) ty else - err "assigning a value of type@ %a@ to a lvalue of type@ %a" - Cprint.typ ty Cprint.typ b1.etyp; + err "assigning to %a from incompatible type %a" + (print_typ env) b1.etyp (print_typ env) ty; end; { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp },env | _ -> assert false @@ -1771,45 +1854,42 @@ let elab_expr loc env a = (* Elaboration of pre- or post- increment/decrement *) and elab_pre_post_incr_decr op msg a1 = - let b1,env = elab env 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 },env + let b1,env = elab env a1 in + if not (is_modifiable_lvalue env b1) then + err "expression is not assignable"; + if not (is_scalar_type env b1.etyp) then + err "cannot %s value of type %a" msg (print_typ env) b1.etyp; + { edesc = EUnop(op, b1); etyp = b1.etyp },env (* Elaboration of binary operators over integers *) and elab_binary_integer msg op a1 a2 = - let b1,env = elab env 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,env = elab env 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 },env + let b1,env = elab env a1 in + let b2,env = elab env a2 in + if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then + error "invalid operands to binary '%s' (%a and %a)" msg + (print_typ env) b1.etyp (print_typ env) b2.etyp; + let tyres = binary_conversion env b1.etyp b2.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of binary operators over arithmetic types *) and elab_binary_arithmetic msg op a1 a2 = - let b1,env = elab env 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,env = elab env 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 },env + let b1,env = elab env a1 in + let b2,env = elab env a2 in + if not ((is_arith_type env b1.etyp) && (is_arith_type env b2.etyp)) then + error "invalid operands to binary '%s' (%a and %a)" msg + (print_typ env) b1.etyp (print_typ env) b2.etyp; + let tyres = binary_conversion env b1.etyp b2.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of shift operators *) and elab_shift msg op a1 a2 = - let b1,env = elab env 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,env = elab env 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 },env + let b1,env = elab env a1 in + let b2,env = elab env a2 in + if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then + error "invalid operands to '%s' (%a and %a)" msg + (print_typ env) b1.etyp (print_typ env) b2.etyp; + let tyres = unary_conversion env b1.etyp in + { edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env (* Elaboration of comparisons *) and elab_comparison op a1 a2 = @@ -1831,66 +1911,76 @@ let elab_expr loc env a = EBinop(op, b1, b2, TPtr(ty1, [])) | TPtr(ty1, _), TPtr(ty2, _) -> if not (compatible_types AttrIgnoreAll env ty1 ty2) then - warning "comparison between incompatible pointer types"; + warning Compare_distinct_pointer_types "comparison of distinct pointer types (%a and %a)" + (print_typ env) b1.etyp (print_typ env) b2.etyp; EBinop(op, b1, b2, TPtr(ty1, [])) | TPtr _, (TInt _ | TEnum _) | (TInt _ | TEnum _), TPtr _ -> - warning "comparison between integer and pointer"; + warning Unnamed "comparison between pointer and integer (%a and %a)" + (print_typ env) b1.etyp (print_typ env) b2.etyp; 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 + (print_typ env) b1.etyp (print_typ env) b2.etyp; in { edesc = resdesc; etyp = TInt(IInt, []) },env (* Elaboration of && and || *) and elab_logical_operator msg op a1 a2 = - let b1,env = elab env 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,env = elab env 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, []) },env + let b1,env = elab env a1 in + let b2,env = elab env a2 in + if not ((is_scalar_type env b1.etyp) && (is_scalar_type env b2.etyp)) then + error "invalid operands to binary %s (%a and %a)" msg + (print_typ env) b1.etyp (print_typ env) b2.etyp; + { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []) },env (* Type-checking of function arguments *) and elab_arguments argno args params vararg = match args, params with | ([],env), [] -> [],env - | ([],env), _::_ -> err "not enough arguments in function call"; [], env - | (_::_,env), [] -> + | ([],env), _::_ -> + let found = argno - 1 in + let expected = List.length params + found in + err "too few arguments to function call, expected %d, have %d" expected found; [],env + | (_::_,env), [] -> if vararg then args - else (err "too many arguments in function call"; args) + else + let expected = argno - 1 in + let found = List.length (fst args) + expected in + (err "too many arguments to function call, expected %d, have %d" expected found; args) | (arg1 :: argl,env), (_, ty_p) :: paraml -> let ty_a = argument_conversion env arg1.etyp in if not (wrap2 valid_assignment loc env {arg1 with etyp = ty_a} ty_p) then begin - if wrap2 valid_cast loc 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 + if wrap2 valid_cast loc env ty_a ty_p then begin + if wrap2 int_pointer_conversion loc env ty_a ty_p then + warning Int_conversion + "incompatible integer-pointer conversion: passing %a to parameter %d of type %a" + (print_typ env) ty_a argno (print_typ env) ty_p + else + warning Unnamed + "incompatible conversion passing %a to parameter %d of type %a" + (print_typ env) ty_a argno (print_typ env) ty_p end 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 + "passing %a to parameter %d of incompatible type %a" + (print_typ env) ty_a argno (print_typ env) ty_p end; let rest,env = elab_arguments (argno + 1) (argl,env) paraml vararg in arg1 :: rest,env in elab env a (* Filling in forward declaration *) -let _ = elab_expr_f := elab_expr +let _ = elab_expr_f := (elab_expr false) -let elab_opt_expr loc env = function +let elab_opt_expr vararg loc env = function | None -> None,env - | Some a -> let a,env = (elab_expr loc env a) in + | Some a -> let a,env = (elab_expr vararg loc env a) in Some a,env -let elab_for_expr loc env = function +let elab_for_expr vararg loc env = function | None -> { sdesc = Sskip; sloc = elab_loc loc },env - | Some a -> let a,env = elab_expr loc env a in + | Some a -> let a,env = elab_expr vararg loc env a in { sdesc = Sdo a; sloc = elab_loc loc },env (* Handling of __func__ (section 6.4.2.2) *) @@ -1904,22 +1994,23 @@ let __func__type_and_init s = let enter_typedefs loc env sto dl = if sto <> Storage_default then - error loc "Non-default storage on 'typedef' definition"; + error loc "non-default storage-class on 'typedef' definition"; List.fold_left (fun env (s, ty, init) -> if init <> NO_INIT then error loc "initializer in typedef"; match previous_def Env.lookup_typedef env s with | Some (s',ty') -> if equal_types env ty ty' then begin - warning loc "redefinition of typedef '%s'" s; + warning loc Cerrors.Celeven_extension "redefinition of typedef '%s' is C11 extension" s; env end else begin - error loc "redefinition of typedef '%s' with different type" s; + error loc "typedef redefinition with different types (%a vs %a)" + (print_typ env) ty (print_typ env) ty'; env end | None -> if redef Env.lookup_ident env s then - error loc "redefinition of identifier '%s' as different kind of symbol" s; + error loc "redefinition of '%s' as different kind of symbol" s; let (id, env') = Env.enter_typedef env s ty in emit_elab env loc (Gtypedef(id, ty)); env') env dl @@ -1927,15 +2018,19 @@ let enter_typedefs loc env sto dl = let enter_decdefs local loc env sto dl = (* Sanity checks on storage class *) if sto = Storage_register && not local then - fatal_error loc "'register' on global declaration"; - if sto <> Storage_default && dl = [] then - warning loc "Storage class specifier on empty declaration"; + fatal_error loc "'register' storage-class on file-scoped variable"; + if dl = [] then + warning loc Missing_declarations "declaration does not declare anything"; let enter_decdef (decls, env) (s, ty, init) = let isfun = is_function_type env ty in if sto = Storage_extern && init <> NO_INIT then - error loc "'extern' declaration cannot have an initializer"; - if local && isfun && (sto = Storage_static || sto = Storage_register) then - error loc "invalid storage class for '%s'" s; + error loc "'extern' declaration variable has an initializer"; + if local && isfun then begin + match sto with + | Storage_static -> error loc "function declared in block scope cannot have 'static' storage-class"; + | Storage_register -> error loc "invalid 'register' storage-class on function"; + | _ -> () + end; (* Local function declarations are always treated as extern *) let sto1 = if local && isfun then Storage_extern else sto in (* enter ident in environment with declared type, because @@ -1952,7 +2047,7 @@ let enter_decdefs local loc env sto dl = if local && sto' <> Storage_extern && not isfun && wrap incomplete_type loc env ty' then - error loc "'%s' has incomplete type" s; + error loc "variable has incomplete type %a" (print_typ env) ty'; if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then (* Local definition *) ((sto', id, ty', init') :: decls, env2) @@ -1985,40 +2080,46 @@ let elab_KR_function_parameters env params defs loc = (* Check that the parameters have unique names *) List.iter (fun id -> if List.length (List.filter ((=) id) params) > 1 then - error loc "Parameter '%s' appears more than once in function declaration" id) + fatal_error loc "redefinition of parameter '%s'" id) params; (* Check that the declarations only declare parameters *) let extract_name (Init_name(Name(s, dty, attrs, loc') as name, ie)) = if not (List.mem s params) then error loc' "Declaration of '%s' which is not a function parameter" s; if ie <> NO_INIT then - error loc' "Illegal initialization of function parameter '%s'" s; + error loc' "illegal initialization of parameter '%s'" s; name in (* Extract names and types from the declarations *) let elab_param_def env = function | DECDEF((spec', name_init_list), loc') -> let name_list = List.map extract_name name_init_list in - let (paramsenv, sto) = elab_name_group loc' env (spec', name_list) in - if sto <> Storage_default && sto <> Storage_register then - error loc' "'extern' or 'static' storage not supported for function parameter"; + let (paramsenv, sto) = elab_name_group true loc' env (spec', name_list) in + begin match sto with + | Storage_extern -> + error loc' "invalid 'extern' storage-class specifier for function parameter" + | Storage_static -> + error loc' "invalid 'static' storage-class specifier for function parameter" + | _ -> () + end; paramsenv | d -> (* Should never be produced by the parser *) fatal_error (get_definitionloc d) "Illegal declaration of function parameter" in - let kr_params_defs = - List.concat (fst (mmap elab_param_def env defs)) in + let kr_params_defs,paramsenv = + let params,paramsenv = mmap elab_param_def env defs in + List.concat params,paramsenv in (* Find the type of a parameter *) let type_of_param param = match List.filter (fun (p, _) -> p = param) kr_params_defs with | [] -> (* Parameter is not declared, defaults to "int" in ISO C90, is an error in ISO C99. Just emit a warning. *) - warning loc "Type of '%s' defaults to 'int'" param; + warning loc Pedantic "type of '%s' defaults to 'int'" param; TInt (IInt, []) | (_, ty) :: rem -> if rem <> [] then - error loc "Parameter '%s' defined more than once" param; + error loc "redefinition of parameter '%s'" param; ty in (* Match parameters against declarations *) let rec match_params params' extra_decls = function @@ -2044,7 +2145,8 @@ let elab_KR_function_parameters env params defs loc = ps end in - match_params [] [] params + let a,b = match_params [] [] params in + a,b,paramsenv (* Look for varargs flag in previous definitions of a function *) @@ -2065,30 +2167,30 @@ let inherit_vararg env s sto ty = let elab_fundef env spec name defs body loc = let (s, sto, inline, noret, ty, kr_params, env1) = - elab_fundef_name env spec name in + elab_fundef_name true env spec name in if sto = Storage_register then - fatal_error loc "A function definition cannot have 'register' storage class"; + fatal_error loc "invalid 'register' storage-class on function"; begin match kr_params, defs with - | None, d :: _ -> - error (get_definitionloc d) - "Old-style parameter declaration in a new-style function definition" + | None, d::_ -> + error (get_definitionloc d) + "old-style parameter declarations in prototyped function definition" | _ -> () end; (* Process the parameters and the K&R declarations, if any, to obtain: - [ty]: the full, prototyped type of the function - [extra_decls]: extra declarations to be inserted at the beginning of the function *) - let (ty, extra_decls) = + let (ty, extra_decls,env1) = match ty, kr_params with | TFun(ty_ret, None, vararg, attr), None -> - (TFun(ty_ret, Some [], vararg, attr), []) + (TFun(ty_ret, Some [], vararg, attr), [],env1) | ty, None -> - (ty, []) + (ty, [],env1) | TFun(ty_ret, None, false, attr), Some params -> - warning loc "Non-prototype, pre-standard function definition.@ Converting to prototype form"; - let (params', extra_decls) = + warning loc Cerrors.CompCert_conformance "non-prototype, pre-standard function definition, converting to prototype form"; + let (params', extra_decls,env) = elab_KR_function_parameters env params defs loc in - (TFun(ty_ret, Some params', inherit_vararg env s sto ty, attr), extra_decls) + (TFun(ty_ret, Some params', inherit_vararg env s sto ty, attr), extra_decls,env) | _, Some params -> assert false in @@ -2096,18 +2198,21 @@ let elab_fundef env spec name defs body loc = let (ty_ret, params, vararg, attr) = match ty with | TFun(ty_ret, Some params, vararg, attr) -> - if wrap incomplete_type loc env1 ty_ret - && not (is_void_type env ty_ret) - then error loc "return type is an incomplete type"; - (ty_ret, params, vararg, attr) - | _ -> - fatal_error loc "wrong type for function definition" in + if wrap incomplete_type loc env1 ty_ret && not (is_void_type env ty_ret) then + fatal_error loc "incomplete result type %a in function definition" + (print_typ env) ty_ret; + (ty_ret, params, vararg, attr) + | _ -> fatal_error loc "wrong type for function definition" in (* Enter function in the environment, for recursive references *) let (fun_id, sto1, env1, _, _) = enter_or_refine_ident false loc env1 s sto ty in + let incomplete_param env ty = + if wrap incomplete_type loc env ty then + fatal_error loc "parameter has incomplete type" in (* Enter parameters and extra declarations in the environment *) let env2 = - List.fold_left (fun e (id, ty) -> Env.add_ident e id Storage_default ty) + List.fold_left (fun e (id, ty) -> incomplete_param e ty; + Env.add_ident e id Storage_default ty) (Env.new_scope env1) params in let env2 = List.fold_left (fun e (sto, id, ty, init) -> Env.add_ident e id sto ty) @@ -2119,7 +2224,7 @@ let elab_fundef env spec name defs body loc = emit_elab ~debuginfo:false env3 loc (Gdecl(Storage_static, func_id, func_ty, Some func_init)); (* Elaborate function body *) - let body1 = !elab_funbody_f ty_ret env3 body in + let body1 = !elab_funbody_f ty_ret vararg env3 body in (* Special treatment of the "main" function *) let body2 = if s = "main" then begin @@ -2129,7 +2234,7 @@ let elab_fundef env spec name defs body loc = sseq no_loc body1 {sdesc = Sreturn(Some(intconst 0L IInt)); sloc = no_loc} | _ -> - warning loc "return type of 'main' should be 'int'"; + warning loc Main_return_type "return type of 'main' should be 'int'"; body1 end else body1 in (* Add the extra declarations if any *) @@ -2140,7 +2245,7 @@ let elab_fundef env spec name defs body loc = sloc = no_loc } end in if noret && contains_return body1 then - warning loc "function '%s' declared 'noreturn' should not return" s; + warning loc Invalid_noreturn "function '%s' declared 'noreturn' should not return" s; (* Build and emit function definition *) let fn = { fd_storage = sto1; @@ -2163,14 +2268,14 @@ let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition) (* "int f(int x) { ... }" *) (* "int f(x, y) double y; { ... }" *) | FUNDEF(spec, name, defs, body, loc) -> - if local then error loc "local definition of a function"; + if local then error loc "function definition is not allowed here"; let env1 = elab_fundef env spec name defs body loc in ([], env1) (* "int x = 12, y[10], *z" *) | DECDEF(init_name_group, loc) -> let ((dl, env1), sto, tydef) = - elab_init_name_group loc env init_name_group in + elab_init_name_group false loc env init_name_group in if tydef then let env2 = enter_typedefs loc env1 sto dl in ([], env2) @@ -2191,9 +2296,9 @@ and elab_definitions local env = function (* Extended asm *) -let elab_asm_operand loc env (ASMOPERAND(label, wide, chars, e)) = +let elab_asm_operand vararg loc env (ASMOPERAND(label, wide, chars, e)) = let s = elab_simple_string loc wide chars in - let e',env = elab_expr loc env e in + let e',env = elab_expr vararg loc env e in (label, s, e'),env @@ -2205,7 +2310,8 @@ type stmt_context = { ctx_return_typ: typ; (**r return type for the function *) ctx_labels: StringSet.t; (**r all labels defined in the function *) ctx_break: bool; (**r is 'break' allowed? *) - ctx_continue: bool (**r is 'continue' allowed? *) + ctx_continue: bool; (**r is 'continue' allowed? *) + ctx_vararg: bool; (**r is this a vararg function? *) } let stmt_labels stmt = @@ -2222,7 +2328,7 @@ let stmt_labels stmt = | DEFAULT(s1, _) -> do_stmt s1 | LABEL(lbl, s1, loc) -> if StringSet.mem lbl !lbls then - error loc "multiply-defined label '%s'\n" lbl; + error loc "redefinition of label '%s'\n" lbl; lbls := StringSet.add lbl !lbls; do_stmt s1 | _ -> () @@ -2242,7 +2348,7 @@ let rec elab_stmt env ctx s = (* 6.8.3 Expression statements *) | COMPUTATION(a, loc) -> - let a,env = (elab_expr loc env a) in + let a,env = (elab_expr ctx.ctx_vararg loc env a) in { sdesc = Sdo a; sloc = elab_loc loc },env (* 6.8.1 Labeled statements *) @@ -2252,10 +2358,10 @@ let rec elab_stmt env ctx s = { sdesc = Slabeled(Slabel lbl, s1); sloc = elab_loc loc },env | CASE(a, s1, loc) -> - let a',env = elab_expr loc env a in + let a',env = elab_expr ctx.ctx_vararg loc env a in begin match Ceval.integer_expr env a' with | None -> - error loc "argument of 'case' must be an integer compile-time constant" + error loc "expression of 'case' label is not an integer constant expression" | Some n -> () end; let s1,env = elab_stmt env ctx s1 in @@ -2273,9 +2379,10 @@ let rec elab_stmt env ctx s = (* 6.8.4 Conditional statements *) | If(a, s1, s2, loc) -> - let a',env = elab_expr loc env a in + let a',env = elab_expr ctx.ctx_vararg loc env a in if not (is_scalar_type env a'.etyp) then - error loc "the condition of 'if' does not have scalar type"; + error loc "controlling expression of 'if' does not have scalar type (%a invalid)" + (print_typ env) a'.etyp; let s1',env = elab_stmt env ctx s1 in let s2',env = match s2 with @@ -2287,27 +2394,29 @@ let rec elab_stmt env ctx s = (* 6.8.5 Iterative statements *) | WHILE(a, s1, loc) -> - let a',env = elab_expr loc env a in + let a',env = elab_expr ctx.ctx_vararg loc env a in if not (is_scalar_type env a'.etyp) then - error loc "the condition of 'while' does not have scalar type"; + error loc "controlling expression of 'while' does not have scalar type (%a invalid)" + (print_typ env) a'.etyp; let s1',env = elab_stmt env (ctx_loop ctx) s1 in { sdesc = Swhile(a', s1'); sloc = elab_loc loc },env | DOWHILE(a, s1, loc) -> let s1',env = elab_stmt env (ctx_loop ctx) s1 in - let a',env = elab_expr loc env a in + let a',env = elab_expr ctx.ctx_vararg loc env a in if not (is_scalar_type env a'.etyp) then - error loc "the condition of 'while' does not have scalar type"; + error loc "controlling expression of 'while' does not have scalar type (%a invalid)" + (print_typ env) a'.etyp; { sdesc = Sdowhile(s1', a'); sloc = elab_loc loc },env | FOR(fc, a2, a3, s1, loc) -> let (a1', env', decls') = match fc with | Some (FC_EXP a1) -> - let a1,env = elab_for_expr loc env (Some a1) in + let a1,env = elab_for_expr ctx.ctx_vararg loc env (Some a1) in (a1, env, None) | None -> - let a1,env = elab_for_expr loc env None in + let a1,env = elab_for_expr ctx.ctx_vararg loc env None in (a1, env, None) | Some (FC_DECL def) -> let (dcl, env') = elab_definition true (Env.new_scope env) def in @@ -2317,11 +2426,11 @@ let rec elab_stmt env ctx s = let a2',env = match a2 with | None -> intconst 1L IInt,env - | Some a2 -> elab_expr loc env' a2 + | Some a2 -> elab_expr ctx.ctx_vararg loc env' a2 in if not (is_scalar_type env' a2'.etyp) then - error loc "the condition of 'for' does not have scalar type"; - let a3',env' = elab_for_expr loc env' a3 in + error loc "controlling expression of 'for' does not have scalar type (%a invalid)" (print_typ env) a2'.etyp; + let a3',env' = elab_for_expr ctx.ctx_vararg loc env' a3 in let s1',env' = elab_stmt env' (ctx_loop ctx) s1 in let sfor = { sdesc = Sfor(a1', a2', a3', s1'); sloc = elab_loc loc } in begin match decls' with @@ -2331,47 +2440,50 @@ let rec elab_stmt env ctx s = (* 6.8.4 Switch statement *) | SWITCH(a, s1, loc) -> - let a',env = elab_expr loc env a in + let a',env = elab_expr ctx.ctx_vararg loc env a in if not (is_integer_type env a'.etyp) then - error loc "the argument of 'switch' is not an integer"; + error loc "controlling expression of 'switch' does not have integer type (%a invalid)" + (print_typ env) a'.etyp; let s1',env = elab_stmt env (ctx_switch ctx) s1 in { sdesc = Sswitch(a', s1'); sloc = elab_loc loc },env (* 6.8.6 Break and continue statements *) | BREAK loc -> if not ctx.ctx_break then - error loc "'break' outside of a loop or a 'switch'"; + error loc "'break' statement not in loop or switch statement"; { sdesc = Sbreak; sloc = elab_loc loc },env | CONTINUE loc -> if not ctx.ctx_continue then - error loc "'continue' outside of a loop"; + error loc "'continue' statement not in loop statement"; { sdesc = Scontinue; sloc = elab_loc loc },env (* 6.8.6 Return statements *) | RETURN(a, loc) -> - let a',env = elab_opt_expr loc env a in + let a',env = elab_opt_expr ctx.ctx_vararg loc env a in begin match (unroll env ctx.ctx_return_typ, a') with | TVoid _, None -> () | TVoid _, Some _ -> error loc - "'return' with a value in a function of return type 'void'" + "'return' with a value in a function returning void" | _, None -> - warning loc - "'return' without a value in a function of return type@ %a" - Cprint.typ ctx.ctx_return_typ + warning loc Return_type + "'return' with no value, in a function returning non-void" | _, Some b -> if not (wrap2 valid_assignment loc env b ctx.ctx_return_typ) then begin if wrap2 valid_cast loc env b.etyp ctx.ctx_return_typ then - warning loc - "return value has type@ %a@ \ - instead of the expected type@ %a" - Cprint.typ b.etyp Cprint.typ ctx.ctx_return_typ + if wrap2 int_pointer_conversion loc env b.etyp ctx.ctx_return_typ then + warning loc Int_conversion + "incompatible integer-pointer conversion: returning %a from a function with result type %a" + (print_typ env) b.etyp (print_typ env) ctx.ctx_return_typ + else + warning loc Unnamed + "incompatible conversion returning %a from a function with result type %a" + (print_typ env) b.etyp (print_typ env) ctx.ctx_return_typ else error loc - "return value has type@ %a@ \ - instead of the expected type@ %a" - Cprint.typ b.etyp Cprint.typ ctx.ctx_return_typ + "returning %a from a function with incompatible result type %a" + (print_typ env) b.etyp (print_typ env) ctx.ctx_return_typ end end; { sdesc = Sreturn a'; sloc = elab_loc loc },env @@ -2379,7 +2491,7 @@ let rec elab_stmt env ctx s = (* 6.8.6 Goto statements *) | GOTO(lbl, loc) -> if not (StringSet.mem lbl ctx.ctx_labels) then - error loc "unknown 'goto' label %s" lbl; + error loc "use of undeclared label '%s'" lbl; { sdesc = Sgoto lbl; sloc = elab_loc loc },env (* 6.8.3 Null statements *) @@ -2390,8 +2502,8 @@ let rec elab_stmt env ctx s = | ASM(cv_specs, wide, chars, outputs, inputs, flags, loc) -> let a = elab_cvspecs env cv_specs in let s = elab_simple_string loc wide chars in - let outputs,env = mmap (elab_asm_operand loc) env outputs in - let inputs ,env= mmap (elab_asm_operand loc) env inputs in + let outputs,env = mmap (elab_asm_operand ctx.ctx_vararg loc) env outputs in + let inputs ,env= mmap (elab_asm_operand ctx.ctx_vararg loc) env inputs in let flags = List.map (fun (w,c) -> elab_simple_string loc w c) flags in { sdesc = Sasm(a, s, outputs, inputs, flags); sloc = elab_loc loc },env @@ -2424,12 +2536,13 @@ and elab_block_body env ctx sl = (* Elaboration of a function body. Return the corresponding C statement. *) -let elab_funbody return_typ env b = +let elab_funbody return_typ vararg env b = let ctx = { ctx_return_typ = return_typ; ctx_labels = stmt_labels b; ctx_break = false; - ctx_continue = false } in + ctx_continue = false; + ctx_vararg = vararg;} in fst(elab_stmt env ctx b) (* Filling in forward declaration *) |