diff options
Diffstat (limited to 'cparser/Elab.ml')
| -rw-r--r-- | cparser/Elab.ml | 577 |
1 files changed, 321 insertions, 256 deletions
diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 0c35638b..728739bf 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; @@ -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,10 @@ 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 + | _ -> error loc "'aligned' attribute takes no more than 1 argument"; a end | _ -> a @@ -431,12 +444,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) @@ -490,7 +508,7 @@ let rec elab_specifier keep_ty ?(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 specifiers"; begin match st with | AUTO -> () | STATIC -> sto := Storage_static @@ -610,6 +628,13 @@ 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 keep_ty loc env ty kr_ok = function | Cabs.JUSTBASE -> @@ -624,37 +649,30 @@ and elab_type_declarator keep_ty 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 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 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; + 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 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 *) @@ -677,7 +695,7 @@ and elab_parameter keep_ty env (PARAM (spec, id, decl, attr, loc)) = 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 @@ -752,9 +770,10 @@ and elab_field_group keep_ty env (Field_group (spec, fieldlist, loc)) = 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' = @@ -768,28 +787,28 @@ and elab_field_group keep_ty 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 bitfield '%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-filed '%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' witdth not an integer constant" id; None end in { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' } @@ -815,16 +834,16 @@ and elab_struct_or_union_info keep_ty 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 Celeven_extension "anonymous structs are a C11 extension" end else begin - fatal_error loc "empty union" + fatal_error loc "anonymous unions are a C11 extension" end; (composite_info_def env' kind attrs m, 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, "" @@ -840,13 +859,13 @@ and elab_struct_or_union keep_ty only kind loc tag optmembers attrs env = create a new incomplete composite instead via the case "_, None" below. *) if ci.ci_kind <> kind then - fatal_error loc "struct/union mismatch on tag '%s'" tag; + 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 keep_ty kind loc env members attrs in (* Emit a global definition for it *) @@ -895,15 +914,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') @@ -975,13 +994,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 to pointer conversion initializing %a with an expression of type %a" + (print_typ env) ty (print_typ env) a.etyp + else + warning loc Int_conversion + "incompatible pointer to integer conversion initializing %a with an expression of type %a" + (print_typ env) ty (print_typ env) a.etyp else error loc - "initializer has type@ %a@ instead of the expected type @ %a" - Cprint.typ a.etyp Cprint.typ ty + "initializing %a with an expression of incompatible type %a" + (print_typ env) ty (print_typ env) a.etyp (* Representing initialization state using zippers *) @@ -1167,23 +1191,21 @@ let rec elab_designator loc env zi desig = | Some zi' -> elab_designator loc env zi' desig' | None -> - error loc "%s has no member named %s" (I.name zi) name; + error loc "field designator '%s' does not have refer to any field in type '%s'" name (I.name zi); raise Exit end | ATINDEX_INIT a :: 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 "expression is not an integer constant expression"; 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 in initializer exceeds array bounds"; raise Exit end @@ -1206,7 +1228,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' -> @@ -1229,16 +1251,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 is too long"; 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 is too long"; 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"; @@ -1284,8 +1304,8 @@ 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 *) @@ -1319,7 +1339,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 @@ -1339,7 +1359,18 @@ 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 = + match unroll env ty with + | TVoid _ -> + err "illegal arithmetic on a pointer to void" + | TFun _ -> + err "illegal arithmetic on a pointer to the function type %a" (print_typ env) ty + | _ -> if incomplete_type env ty then + err "arithmetic on a pointer to an incomplete type %a" (print_typ env) ty + in let rec elab env = function @@ -1366,7 +1397,7 @@ let elab_expr vararg 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 not an array, or pointer" in { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres },env | MEMBEROF(a1, fieldname) -> @@ -1378,7 +1409,7 @@ let elab_expr vararg 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 "member reference base type %a is not a structure or union" (print_typ env) b1.etyp 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) @@ -1395,10 +1426,10 @@ let elab_expr vararg 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 "member reference base type %a is not a struct or union" (print_typ env) b1.etyp 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 @@ -1431,9 +1462,8 @@ let elab_expr vararg 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 "second argument of va_rarg is of promotable type %a; this var_arg has undefined behavior because arguments will be promoted to %a" + (print_typ env) ty (print_typ env) ty'; { edesc = ECall(ident, [b2; b3]); etyp = ty },env | CALL(a1, al) -> @@ -1442,7 +1472,7 @@ let elab_expr vararg 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) = @@ -1459,9 +1489,9 @@ let elab_expr vararg 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 not a function or 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 not a function or function pointer" (print_typ env) b1.etyp in (* Type-check the arguments against the prototype *) let bl',env = @@ -1471,9 +1501,9 @@ let elab_expr vararg 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 *) @@ -1481,7 +1511,21 @@ let elab_expr vararg loc env a = 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 typ" + (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 *) @@ -1498,7 +1542,7 @@ let elab_expr vararg loc env a = | EXPR_SIZEOF a1 -> let b1,env = elab env a1 in if wrap incomplete_type loc env b1.etyp then - error "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 @@ -1515,49 +1559,49 @@ let elab_expr vararg 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 - error "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 - error "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 - error "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 expression" (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 expression" (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 expression" (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 expression" (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 "cannot take the address of an rvalue of type %a" (print_typ env) b1.etyp; begin match b1.edesc with | EVar id -> begin match wrap Env.find_ident loc env id with @@ -1585,24 +1629,25 @@ let elab_expr vararg loc env a = | TPtr(ty, _) | TArray(ty, _, _) -> { edesc = EUnop(Oderef, b1); etyp = ty },env | _ -> - error "argument of unary '*' is not a pointer" + error "indirection requires pointer operand (%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 *) | BINARY(MUL, a1, a2) -> - elab_binary_arithmetic "*" Omul a1 a2 + elab_binary_arithmetic Omul a1 a2 | BINARY(DIV, a1, a2) -> - elab_binary_arithmetic "/" Odiv a1 a2 + 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 @@ -1615,9 +1660,10 @@ let elab_expr vararg 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 expression (%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 @@ -1636,27 +1682,27 @@ let elab_expr vararg loc env a = err "illegal pointer arithmetic in binary '-'"; (TPtr(ty, []), TPtr(ty, [])) | (TInt _ | TEnum _), (TPtr(ty, a) | TArray(ty, _, a)) -> - if not (wrap pointer_arithmetic_ok loc 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 expression (%a and %a)" + (print_typ env) b1.etyp (print_typ env) b2.etyp end in { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres },env | BINARY(SHL, a1, a2) -> - elab_shift "<<" Oshl a1 a2 + elab_binary_integer Oshl a1 a2 | BINARY(SHR, a1, a2) -> - elab_shift ">>" Oshr a1 a2 + elab_binary_integer Oshr a1 a2 | BINARY(EQ, a1, a2) -> elab_comparison Oeq a1 a2 @@ -1672,11 +1718,11 @@ let elab_expr vararg loc env a = elab_comparison Oge a1 a2 | BINARY(BAND, a1, a2) -> - elab_binary_integer "&" Oand a1 a2 + elab_binary_integer Oand a1 a2 | BINARY(BOR, a1, a2) -> - elab_binary_integer "|" Oor a1 a2 + elab_binary_integer Oor a1 a2 | BINARY(XOR, a1, a2) -> - elab_binary_integer "^" Oxor a1 a2 + elab_binary_integer Oxor a1 a2 (* 6.5.13 and 6.5.14 Logical operator expressions *) @@ -1691,12 +1737,13 @@ let elab_expr vararg 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 "used type %a where arithmetic or pointer type is required" + (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), []) @@ -1704,8 +1751,8 @@ let elab_expr vararg 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 "pointer type mismatch (%a and %a)" + (print_typ env) pty1 (print_typ env) pty2; (* tolerance *) TPtr(TVoid (add_attributes a1 a2), []) | Some ty -> ty @@ -1718,7 +1765,8 @@ let elab_expr vararg 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 "incompatible operand types (%a and %a)" + (print_typ env) ty1 (print_typ env) ty2 | Some tyres -> { edesc = EConditional(b1, b2, b3); etyp = tyres },env end @@ -1729,16 +1777,22 @@ let elab_expr vararg 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 "read-only variable is not assignable"; 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 to pointer conversion assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) b2.etyp + else + warning Int_conversion + "incompatible pointer to integer conversion assgining 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 @@ -1761,16 +1815,22 @@ let elab_expr vararg loc env a = begin match elab env (BINARY(sop, a1, a2)) with | ({ edesc = EBinop(_, b1, b2, _); etyp = ty } as b),env -> if List.mem AConst (attributes_of_type env b1.etyp) then - err "left-hand side of assignment has 'const' type"; + err "read-only variable is not assignable"; 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 to pointer conversion assigning to %a from %a" + (print_typ env) b1.etyp (print_typ env) ty + else + warning Int_conversion + "incompatible pointer to integer conversion assgining 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 @@ -1785,45 +1845,32 @@ let elab_expr vararg 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 + and elab_binary_integer op a1 a2 = + 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 expression (%a and %a)" + (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 - -(* 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 + and elab_binary_arithmetic op a1 a2 = + 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 expression (%a and %a)" + (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 comparisons *) and elab_comparison op a1 a2 = @@ -1845,50 +1892,60 @@ let elab_expr vararg 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 "ordered 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 expression (%a and %a)" + (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 to pointer conversion passing %a to parameter of type %a" + (print_typ env) ty_a (print_typ env) ty_p + else + warning Int_conversion + "incompatible pointer to integer conversion passing %a to parameter of type %a" + (print_typ env) ty_a (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 of incompatible type %a" + (print_typ env) ty_a (print_typ env) ty_p end; let rest,env = elab_arguments (argno + 1) (argl,env) paraml vararg in arg1 :: rest,env @@ -1918,22 +1975,22 @@ 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 "cannot combine with previous 'typedef' declaration specifier"; 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; + if equal_types env ty ty' then env - end else begin - error loc "redefinition of typedef '%s' with different type" s; + else begin + error loc "typdef 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 @@ -1941,15 +1998,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"; + fatal_error loc "illegal storage class on file-scoped variable"; if sto <> Storage_default && dl = [] then - warning loc "Storage class specifier on empty declaration"; + 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 "illegal 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 @@ -1966,7 +2027,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) @@ -1999,14 +2060,14 @@ 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' "parameter '%s' is initialized" s; name in (* Extract names and types from the declarations *) @@ -2015,7 +2076,7 @@ let elab_KR_function_parameters env params defs loc = let name_list = List.map extract_name name_init_list in let (paramsenv, sto) = elab_name_group true 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"; + error loc' "invalid storage class specifier in function declarator"; paramsenv | d -> (* Should never be produced by the parser *) fatal_error (get_definitionloc d) @@ -2028,11 +2089,11 @@ let elab_KR_function_parameters env params defs loc = | [] -> (* 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 @@ -2081,11 +2142,11 @@ let elab_fundef env spec name defs body loc = let (s, sto, inline, noret, ty, kr_params, env1) = 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 "illegal 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: @@ -2099,7 +2160,6 @@ let elab_fundef env spec name defs body loc = | ty, None -> (ty, []) | TFun(ty_ret, None, false, attr), Some params -> - warning loc "Non-prototype, pre-standard function definition.@ Converting to prototype form"; let (params', extra_decls) = elab_KR_function_parameters env params defs loc in (TFun(ty_ret, Some params', inherit_vararg env s sto ty, attr), extra_decls) @@ -2110,12 +2170,11 @@ 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 @@ -2147,7 +2206,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 *) @@ -2158,7 +2217,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; @@ -2181,7 +2240,7 @@ 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) @@ -2241,7 +2300,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 | _ -> () @@ -2274,7 +2333,7 @@ let rec elab_stmt env ctx s = 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 is not an integer constant expression" | Some n -> () end; let s1,env = elab_stmt env ctx s1 in @@ -2294,7 +2353,8 @@ let rec elab_stmt env ctx s = | If(a, s1, s2, loc) -> 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 "statement requires expression of scalar type (%a invalid)" + (print_typ env) a'.etyp; let s1',env = elab_stmt env ctx s1 in let s2',env = match s2 with @@ -2308,7 +2368,8 @@ let rec elab_stmt env ctx s = | WHILE(a, s1, loc) -> 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 "statement requires expression of 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 @@ -2316,7 +2377,8 @@ let rec elab_stmt env ctx s = let s1',env = elab_stmt env (ctx_loop ctx) s1 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 "statement requires expression of scalar type (%a invalid)" + (print_typ env) a'.etyp; { sdesc = Sdowhile(s1', a'); sloc = elab_loc loc },env | FOR(fc, a2, a3, s1, loc) -> @@ -2339,7 +2401,7 @@ let rec elab_stmt env ctx s = | 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"; + error loc "statement requires expression of 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 @@ -2352,18 +2414,19 @@ let rec elab_stmt env ctx s = | SWITCH(a, s1, loc) -> 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 "statement requires expression of 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 *) @@ -2373,24 +2436,26 @@ let rec elab_stmt env ctx s = | 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 to 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 Int_conversion + "incompatible integer to pointer 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 @@ -2398,7 +2463,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 *) |