* merged methodpointer fixes from 1.0.x

compiler/defcmp.pas

@@ -107,7 +107,7 @@ interface
     { True if a function can be assigned to a procvar }
     { changed first argument type to pabstractprocdef so that it can also be }
     { used to test compatibility between two pprocvardefs (JM)               }
-    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
+    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype;
 
 
 implementation
@@ -765,7 +765,7 @@ implementation
                      { proc -> procvar }
                      if (m_tp_procvar in aktmodeswitches) then
                       begin
-                        subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to));
+                        subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),true);
                         if subeq>te_incompatible then
                          begin
                            doconv:=tc_proc_2_procvar;
@@ -776,7 +776,7 @@ implementation
                  procvardef :
                    begin
                      { procvar -> procvar }
-                     eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to));
+                     eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),true);
                    end;
                  pointerdef :
                    begin
@@ -1127,9 +1127,8 @@ implementation
       end;
 
 
-    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
+    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;methoderr:boolean):tequaltype;
       var
-        ismethod : boolean;
         eq : tequaltype;
         po_comp : tprocoptions;
       begin
@@ -1137,19 +1136,11 @@ implementation
          if not(assigned(def1)) or not(assigned(def2)) then
            exit;
          { check for method pointer }
-         if def1.deftype=procvardef then
+         if (def1.is_methodpointer xor def2.is_methodpointer) or
+            (def1.is_addressonly xor def2.is_addressonly) then
           begin
-            ismethod:=(po_methodpointer in def1.procoptions);
-          end
-         else
-          begin
-            ismethod:=assigned(def1.owner) and
-                      (def1.owner.symtabletype=objectsymtable);
-          end;
-         if (ismethod and not (po_methodpointer in def2.procoptions)) or
-            (not(ismethod) and (po_methodpointer in def2.procoptions)) then
-          begin
-            Message(type_e_no_method_and_procedure_not_compatible);
+            if methoderr then
+              Message(type_e_no_method_and_procedure_not_compatible);
             exit;
           end;
          { check return value and options, methodpointer is already checked }
@@ -1188,7 +1179,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.17  2003-01-09 21:43:39  peter
+  Revision 1.18  2003-01-15 01:44:32  peter
+    * merged methodpointer fixes from 1.0.x
+
+  Revision 1.17  2003/01/09 21:43:39  peter
     * constant string conversion fixed, it's now equal to both
       shortstring, ansistring and the typeconvnode will return
       te_equal but still return convtype to change the constnode

compiler/ncal.pas

@@ -431,7 +431,7 @@ type
               { in tp7 mode proc -> procvar is allowed }
               if (m_tp_procvar in aktmodeswitches) and
                  (p.left.nodetype=calln) and
-                 (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to))>=te_equal) then
+                 (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),true)>=te_equal) then
                eq:=te_equal;
             end;
         end;
@@ -2375,7 +2375,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.125  2003-01-12 17:52:07  peter
+  Revision 1.126  2003-01-15 01:44:32  peter
+    * merged methodpointer fixes from 1.0.x
+
+  Revision 1.125  2003/01/12 17:52:07  peter
     * only check for auto inherited in objectsymtable
 
   Revision 1.124  2003/01/09 21:45:46  peter

compiler/ncnv.pas

@@ -1102,7 +1102,7 @@ implementation
                        { Now check if the procedure we are going to assign to
                          the procvar, is compatible with the procvar's type }
                        if proc_to_procvar_equal(tprocsym(tloadnode(left).symtableentry).first_procdef,
-                                                tprocvardef(resulttype.def))=te_incompatible then
+                                                tprocvardef(resulttype.def),true)=te_incompatible then
                          CGMessage2(type_e_incompatible_types,tprocsym(tloadnode(left).symtableentry).first_procdef.typename,resulttype.def.typename);
                        exit;
                      end;
@@ -1129,7 +1129,7 @@ implementation
                      { Now check if the procedure we are going to assign to
                        the procvar, is compatible with the procvar's type }
                      if proc_to_procvar_equal(tprocdef(left.resulttype.def),
-                                              tprocvardef(resulttype.def))=te_incompatible then
+                                              tprocvardef(resulttype.def),true)=te_incompatible then
                        CGMessage2(type_e_incompatible_types,tprocdef(left.resulttype.def).typename,resulttype.def.typename);
                      exit;
                    end;
@@ -2024,7 +2024,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.99  2003-01-09 21:43:39  peter
+  Revision 1.100  2003-01-15 01:44:32  peter
+    * merged methodpointer fixes from 1.0.x
+
+  Revision 1.99  2003/01/09 21:43:39  peter
     * constant string conversion fixed, it's now equal to both
       shortstring, ansistring and the typeconvnode will return
       te_equal but still return convtype to change the constnode

compiler/pexpr.pas

@@ -2320,8 +2320,8 @@ implementation
 end.
 {
   $Log$
-  Revision 1.99  2003-01-14 23:48:09  peter
-    * fixed tw2273
+  Revision 1.100  2003-01-15 01:44:32  peter
+    * merged methodpointer fixes from 1.0.x
 
   Revision 1.98  2003/01/12 17:51:42  peter
     * tp procvar handling fix for tb0448

compiler/symdef.pas

@@ -437,6 +437,8 @@ interface
           function  para_size(alignsize:longint) : longint;
           function  typename_paras : string;
           procedure test_if_fpu_result;
+          function  is_methodpointer:boolean;virtual;
+          function  is_addressonly:boolean;virtual;
           { debug }
 {$ifdef GDB}
           function  stabstring : pchar;override;
@@ -449,8 +451,10 @@ interface
           constructor ppuload(ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function  size : longint;override;
-          function gettypename:string;override;
-          function is_publishable : boolean;override;
+          function  gettypename:string;override;
+          function  is_publishable : boolean;override;
+          function  is_methodpointer:boolean;override;
+          function  is_addressonly:boolean;override;
           { debug }
 {$ifdef GDB}
           function stabstring : pchar;override;
@@ -534,8 +538,10 @@ interface
           }
           procedure insert_localst;
           function  fullprocname:string;
-          function fullprocnamewithret:string;
+          function  fullprocnamewithret:string;
           function  cplusplusmangledname : string;
+          function  is_methodpointer:boolean;override;
+          function  is_addressonly:boolean;override;
           { debug }
 {$ifdef GDB}
           function  stabstring : pchar;override;
@@ -903,6 +909,7 @@ implementation
     function tstoreddef.getcopy : tstoreddef;
       begin
          Message(sym_e_cant_create_unique_type);
+         getcopy:=nil;
       end;
 
     procedure tstoreddef.ppuwritedef(ppufile:tcompilerppufile);
@@ -3313,6 +3320,18 @@ implementation
       end;
 
 
+    function tabstractprocdef.is_methodpointer:boolean;
+      begin
+        result:=false;
+      end;
+
+
+    function tabstractprocdef.is_addressonly:boolean;
+      begin
+        result:=true;
+      end;
+
+
 {$ifdef GDB}
     function tabstractprocdef.stabstring : pchar;
       begin
@@ -3594,6 +3613,19 @@ implementation
       end;
 
 
+    function tprocdef.is_methodpointer:boolean;
+      begin
+        result:=assigned(owner) and
+                (owner.symtabletype=objectsymtable);
+      end;
+
+
+    function tprocdef.is_addressonly:boolean;
+      begin
+        result:=true;
+      end;
+
+
     function tprocdef.getsymtable(t:tgetsymtable):tsymtable;
       begin
         case t of
@@ -4020,6 +4052,19 @@ implementation
       end;
 
 
+    function tprocvardef.is_methodpointer:boolean;
+      begin
+        result:=(po_methodpointer in procoptions);
+      end;
+
+
+    function tprocvardef.is_addressonly:boolean;
+      begin
+        result:=not(po_methodpointer in procoptions) or
+                (po_addressonly in procoptions);
+      end;
+
+
 {$ifdef GDB}
     function tprocvardef.stabstring : pchar;
       var
@@ -4134,14 +4179,17 @@ implementation
       begin
          s:='<';
          if po_classmethod in procoptions then
-           s := s+'class method'
+           s := s+'class method type of'
          else
-           s := s+'procedure variable';
+           if po_addressonly in procoptions then
+             s := s+'address of'
+           else
+             s := s+'procedure variable type of';
          if assigned(rettype.def) and
             (rettype.def<>voidtype.def) then
-           s:=s+' type of function'+typename_paras+':'+rettype.def.gettypename
+           s:=s+' function'+typename_paras+':'+rettype.def.gettypename
          else
-           s:=s+' type of procedure'+typename_paras;
+           s:=s+' procedure'+typename_paras;
          if po_methodpointer in procoptions then
            s := s+' of object';
          gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
@@ -5599,7 +5647,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.124  2003-01-09 21:52:37  peter
+  Revision 1.125  2003-01-15 01:44:33  peter
+    * merged methodpointer fixes from 1.0.x
+
+  Revision 1.124  2003/01/09 21:52:37  peter
     * merged some verbosity options.
     * V_LineInfo is a verbosity flag to include line info
 

compiler/symsym.pas

@@ -1062,7 +1062,7 @@ implementation
         pd:=pdlistfirst;
         while assigned(pd) do
          begin
-           eq:=proc_to_procvar_equal(pd^.def,d);
+           eq:=proc_to_procvar_equal(pd^.def,d,false);
            if eq>=te_equal then
             begin
               { multiple procvars with the same equal level }
@@ -2563,7 +2563,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.92  2003-01-09 21:52:38  peter
+  Revision 1.93  2003-01-15 01:44:33  peter
+    * merged methodpointer fixes from 1.0.x
+
+  Revision 1.92  2003/01/09 21:52:38  peter
     * merged some verbosity options.
     * V_LineInfo is a verbosity flag to include line info