paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-11 09:26:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

* include unit name in error messages when types are the same

Browse Source
This commit is contained in:
peter 2004-06-23 16:22:45 +00:00
parent b55648ad7d
commit cf3c1198ea
3 changed files with 52 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
compiler/htypechk.pas
View File

@ -152,7 +152,7 @@ implementation
cutils,verbose,globals, cutils,verbose,globals,
symtable, symtable,
defutil,defcmp, defutil,defcmp,
pass_1,nbas,ncnv,nld,nmem,ncal,nmat,nutils, nbas,ncnv,nld,nmem,ncal,nmat,nutils,
cgbase,procinfo cgbase,procinfo
; ;
@ -1894,17 +1894,22 @@ implementation
guess that it is a missing typeconv } guess that it is a missing typeconv }
if hp^.wrongpara.paratyp in [vs_var,vs_out] then if hp^.wrongpara.paratyp in [vs_var,vs_out] then
CGMessagePos2(pt.fileinfo,parser_e_call_by_ref_without_typeconv, CGMessagePos2(pt.fileinfo,parser_e_call_by_ref_without_typeconv,
pt.resulttype.def.typename,hp^.wrongpara.paratype.def.typename) FullTypeName(pt.resulttype.def,hp^.wrongpara.paratype.def),
FullTypeName(hp^.wrongpara.paratype.def,pt.resulttype.def))
else else
CGMessagePos3(pt.fileinfo,type_e_wrong_parameter_type, CGMessagePos3(pt.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr),
tostr(hp^.wrongparanr),pt.resulttype.def.typename,hp^.wrongpara.paratype.def.typename); FullTypeName(pt.resulttype.def,hp^.wrongpara.paratype.def),
FullTypeName(hp^.wrongpara.paratype.def,pt.resulttype.def));
end; end;
end. end.
{ {
$Log$ $Log$
Revision 1.94 2004-06-20 08:55:29 florian Revision 1.95 2004-06-23 16:22:45 peter
* include unit name in error messages when types are the same
Revision 1.94 2004/06/20 08:55:29 florian
* logs truncated * logs truncated
Revision 1.93 2004/06/16 20:07:07 florian Revision 1.93 2004/06/16 20:07:07 florian

58
compiler/ncnv.pas
View File

@ -1362,7 +1362,9 @@ implementation
{ check if the types are related } { check if the types are related }
if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
(not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then (not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
CGMessage2(type_w_classes_not_related,left.resulttype.def.typename,resulttype.def.typename); CGMessage2(type_w_classes_not_related,
FullTypeName(left.resulttype.def,resulttype.def),
FullTypeName(resulttype.def,left.resulttype.def));
end; end;
end end
@ -2257,7 +2259,9 @@ implementation
{ the operands must be related } { the operands must be related }
if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
(tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then (tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(right.resulttype.def)<>-1)) then
CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename); CGMessage2(type_e_classes_not_related,
FullTypeName(left.resulttype.def,right.resulttype.def),
FullTypeName(right.resulttype.def,left.resulttype.def))
end end
{ left is an interface } { left is an interface }
else if is_interface(left.resulttype.def) then else if is_interface(left.resulttype.def) then
@ -2265,7 +2269,9 @@ implementation
{ the operands must be related } { the operands must be related }
if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
(not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then (not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename); CGMessage2(type_e_classes_not_related,
FullTypeName(left.resulttype.def,right.resulttype.def),
FullTypeName(right.resulttype.def,left.resulttype.def));
end end
else else
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename); CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
@ -2342,8 +2348,9 @@ implementation
tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
(not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related( (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
tobjectdef(left.resulttype.def)))) then tobjectdef(left.resulttype.def)))) then
CGMessage2(type_e_classes_not_related,left.resulttype.def.typename, CGMessage2(type_e_classes_not_related,
tclassrefdef(right.resulttype.def).pointertype.def.typename); FullTypeName(left.resulttype.def,tclassrefdef(right.resulttype.def).pointertype.def),
FullTypeName(tclassrefdef(right.resulttype.def).pointertype.def,left.resulttype.def));
end end
else else
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename); CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
@ -2352,39 +2359,9 @@ implementation
else if is_interface(right.resulttype.def) then else if is_interface(right.resulttype.def) then
begin begin
{ left is a class } { left is a class }
if is_class(left.resulttype.def) then if not(is_class(left.resulttype.def) or
begin is_interface(left.resulttype.def)) then
{ the operands must be related CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
no, because the class instance could be a child class of the current one which
implements additional interfaces (FK)
b:=false;
o:=tobjectdef(left.resulttype.def);
while assigned(o) do
begin
if assigned(o.implementedinterfaces) and
(o.implementedinterfaces.searchintf(right.resulttype.def)<>-1) then
begin
b:=true;
break;
end;
o:=o.childof;
end;
if not(b) then
CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename);
}
end
{ left is an interface }
else if is_interface(left.resulttype.def) then
begin
{ the operands must be related
we don't necessarily know how the both interfaces are implemented, so we can't do this check (FK)
if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(right.resulttype.def)))) and
(not(tobjectdef(right.resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,right.resulttype.def.typename);
}
end
else
CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
resulttype:=right.resulttype; resulttype:=right.resulttype;
@ -2463,7 +2440,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.149 2004-06-20 08:55:29 florian Revision 1.150 2004-06-23 16:22:45 peter
* include unit name in error messages when types are the same
Revision 1.149 2004/06/20 08:55:29 florian
* logs truncated * logs truncated
Revision 1.148 2004/06/16 20:07:08 florian Revision 1.148 2004/06/16 20:07:08 florian

36
compiler/symtable.pas
View File

@ -191,6 +191,7 @@ interface
procedure globaldef(const s : string;var t:ttype); procedure globaldef(const s : string;var t:ttype);
function findunitsymtable(st:tsymtable):tsymtable; function findunitsymtable(st:tsymtable):tsymtable;
procedure duplicatesym(sym:tsym); procedure duplicatesym(sym:tsym);
function FullTypeName(def,otherdef:tdef):string;
procedure incompatibletypes(def1,def2:tdef); procedure incompatibletypes(def1,def2:tdef);
{*** Search ***} {*** Search ***}
@ -1761,24 +1762,30 @@ implementation
end; end;
procedure incompatibletypes(def1,def2:tdef); function FullTypeName(def,otherdef:tdef):string;
var var
s1,s2 : string; s1,s2 : string;
begin begin
s1:=def.typename;
{ When the names are the same try to include the unit name }
if assigned(otherdef) and
(def.owner.symtabletype in [globalsymtable,staticsymtable]) then
begin
s2:=otherdef.typename;
if upper(s1)=upper(s2) then
s1:=def.owner.realname^+'.'+s1;
end;
FullTypeName:=s1;
end;
procedure incompatibletypes(def1,def2:tdef);
begin
{ When there is an errordef there is already an error message show }
if (def2.deftype=errordef) or if (def2.deftype=errordef) or
(def1.deftype=errordef) then (def1.deftype=errordef) then
exit; exit;
s1:=def1.typename; CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
s2:=def2.typename;
{ When the names are the same try to include the unit name }
if upper(s1)=upper(s2) then
begin
if (def1.owner.symtabletype in [globalsymtable,staticsymtable]) then
s1:=def1.owner.realname^+'.'+s1;
if (def2.owner.symtabletype in [globalsymtable,staticsymtable]) then
s2:=def2.owner.realname^+'.'+s2;
end;
CGMessage2(type_e_incompatible_types,s1,s2);
end; end;
@ -2325,7 +2332,10 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.150 2004-06-20 08:55:30 florian Revision 1.151 2004-06-23 16:22:45 peter
* include unit name in error messages when types are the same
Revision 1.150 2004/06/20 08:55:30 florian
* logs truncated * logs truncated
Revision 1.149 2004/06/16 20:07:09 florian Revision 1.149 2004/06/16 20:07:09 florian