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

compiler/htypechk.pas

@@ -152,7 +152,7 @@ implementation
        cutils,verbose,globals,
        symtable,
        defutil,defcmp,
-       pass_1,nbas,ncnv,nld,nmem,ncal,nmat,nutils,
+       nbas,ncnv,nld,nmem,ncal,nmat,nutils,
        cgbase,procinfo
        ;
 
@@ -1894,17 +1894,22 @@ implementation
           guess that it is a missing typeconv }
         if hp^.wrongpara.paratyp in [vs_var,vs_out] then
           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
-          CGMessagePos3(pt.fileinfo,type_e_wrong_parameter_type,
-            tostr(hp^.wrongparanr),pt.resulttype.def.typename,hp^.wrongpara.paratype.def.typename);
+          CGMessagePos3(pt.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr),
+            FullTypeName(pt.resulttype.def,hp^.wrongpara.paratype.def),
+            FullTypeName(hp^.wrongpara.paratype.def,pt.resulttype.def));
       end;
 
 
 end.
 {
   $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
 
   Revision 1.93  2004/06/16 20:07:07  florian

compiler/ncnv.pas

@@ -1362,7 +1362,9 @@ implementation
                         { check if the types are related }
                         if (not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
                            (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
 
@@ -2257,7 +2259,9 @@ implementation
                { the operands must be related }
                if not(assigned(tobjectdef(left.resulttype.def).implementedinterfaces) and
                       (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
             { left is an interface }
             else if is_interface(left.resulttype.def) then
@@ -2265,7 +2269,9 @@ implementation
                { the operands must be related }
                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);
+                 CGMessage2(type_e_classes_not_related,
+                    FullTypeName(left.resulttype.def,right.resulttype.def),
+                    FullTypeName(right.resulttype.def,left.resulttype.def));
              end
             else
              CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
@@ -2342,8 +2348,9 @@ implementation
                   tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def)))) and
                   (not(tobjectdef(tclassrefdef(right.resulttype.def).pointertype.def).is_related(
                   tobjectdef(left.resulttype.def)))) then
-                 CGMessage2(type_e_classes_not_related,left.resulttype.def.typename,
-                            tclassrefdef(right.resulttype.def).pointertype.def.typename);
+                 CGMessage2(type_e_classes_not_related,
+                    FullTypeName(left.resulttype.def,tclassrefdef(right.resulttype.def).pointertype.def),
+                    FullTypeName(tclassrefdef(right.resulttype.def).pointertype.def,left.resulttype.def));
              end
             else
              CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
@@ -2352,39 +2359,9 @@ implementation
          else if is_interface(right.resulttype.def) then
           begin
             { left is a class }
-            if is_class(left.resulttype.def) then
-             begin
-               { the operands must be related
-                 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);
+            if not(is_class(left.resulttype.def) or
+                   is_interface(left.resulttype.def)) then
+              CGMessage1(type_e_class_type_expected,left.resulttype.def.typename);
 
             resulttype:=right.resulttype;
 
@@ -2463,7 +2440,10 @@ begin
 end.
 {
   $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
 
   Revision 1.148  2004/06/16 20:07:08  florian

compiler/symtable.pas

@@ -191,6 +191,7 @@ interface
     procedure globaldef(const s : string;var t:ttype);
     function  findunitsymtable(st:tsymtable):tsymtable;
     procedure duplicatesym(sym:tsym);
+    function  FullTypeName(def,otherdef:tdef):string;
     procedure incompatibletypes(def1,def2:tdef);
 
 {*** Search ***}
@@ -1761,24 +1762,30 @@ implementation
        end;
 
 
-    procedure incompatibletypes(def1,def2:tdef);
+    function FullTypeName(def,otherdef:tdef):string;
       var
         s1,s2 : string;
       begin
-        if (def2.deftype=errordef) or
-           (def1.deftype=errordef) then
-          exit;
-        s1:=def1.typename;
-        s2:=def2.typename;
+        s1:=def.typename;
         { When the names are the same try to include the unit name }
-        if upper(s1)=upper(s2) then
+        if assigned(otherdef) and
+           (def.owner.symtabletype in [globalsymtable,staticsymtable]) 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;
+            s2:=otherdef.typename;
+            if upper(s1)=upper(s2) then
+              s1:=def.owner.realname^+'.'+s1;
           end;
-        CGMessage2(type_e_incompatible_types,s1,s2);
+        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
+           (def1.deftype=errordef) then
+          exit;
+        CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
       end;
 
 
@@ -2325,7 +2332,10 @@ implementation
 end.
 {
   $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
 
   Revision 1.149  2004/06/16 20:07:09  florian