* "procedure of object"-stuff fixed

compiler/cg386cal.pas

@@ -851,8 +851,11 @@ implementation
                 begin
                    { method pointer can't be in a register }
                    inc(p^.right^.location.reference.offset,4);
+                   { load ESI }
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                     newreference(p^.right^.location.reference),R_ESI)));
                    { push self pointer }
-                   exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,newreference(p^.right^.location.reference))));
+                   exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
                    del_reference(p^.right^.location.reference);
                    dec(p^.right^.location.reference.offset,4);
                 end;
@@ -1232,7 +1235,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.58  1999-01-21 22:10:35  peter
+  Revision 1.59  1999-01-27 00:13:52  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.58  1999/01/21 22:10:35  peter
     * fixed array of const
     * generic platform independent high() support
 

compiler/cg386cnv.pas

@@ -1069,12 +1069,20 @@ implementation
 
     procedure second_proc_to_procvar(pto,pfrom : ptree;convtyp : tconverttype);
       begin
-        clear_location(pto^.location);
-        pto^.location.loc:=LOC_REGISTER;
-        pto^.location.register:=getregister32;
-        del_reference(pfrom^.location.reference);
-        exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
-           newreference(pfrom^.location.reference),pto^.location.register)));
+        { method pointer ? }
+        if assigned(pfrom^.left) then
+          begin
+             set_location(pto^.location,pfrom^.location);
+          end
+        else
+          begin
+             clear_location(pto^.location);
+             pto^.location.loc:=LOC_REGISTER;
+             pto^.location.register:=getregister32;
+             del_reference(pfrom^.location.reference);
+             exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+               newreference(pfrom^.location.reference),pto^.location.register)));
+          end;
       end;
 
 
@@ -1562,7 +1570,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.45  1999-01-21 22:10:36  peter
+  Revision 1.46  1999-01-27 00:13:53  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.45  1999/01/21 22:10:36  peter
     * fixed array of const
     * generic platform independent high() support
 

compiler/cg386ld.pas

@@ -51,6 +51,7 @@ implementation
          symtabletype : tsymtabletype;
          i : longint;
          hp : preference;
+         s : pcsymbol;
       begin
          simple_loadn:=true;
          reset_reference(p^.location.reference);
@@ -234,17 +235,73 @@ implementation
                  end;
               procsym:
                  begin
-                    if p^.is_methodpointer then
+                    if assigned(p^.left) then
                       begin
                          secondpass(p^.left);
-                         stringdispose(p^.location.reference.symbol);
+                         p^.location.loc:=LOC_MEM;
+                         gettempofsizereference(8,p^.location.reference);
+
+                         { load class instance address }
+                         case p^.left^.location.loc of
+
+                            LOC_CREGISTER,
+                            LOC_REGISTER:
+                              begin
+                                 hregister:=p^.left^.location.register;
+                                 ungetregister32(p^.left^.location.register);
+                                 { such code is allowed !
+                                   CGMessage(cg_e_illegal_expression); }
+                              end;
+
+                            LOC_MEM,
+                            LOC_REFERENCE:
+                              begin
+                                 hregister:=R_EDI;
+                                 exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                   newreference(p^.left^.location.reference),R_EDI)));
+                                 del_reference(p^.left^.location.reference);
+                                 ungetiftemp(p^.left^.location.reference);
+                              end;
+                            else internalerror(26019);
+                         end;
+
+                         { store the class instance address }
+                         new(hp);
+                         hp^:=p^.location.reference;
+                         inc(hp^.offset,4);
+                         exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
+                           R_EDI,hp)));
+
                          { virtual method ? }
                          if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then
                            begin
+                              new(hp);
+                              reset_reference(hp^);
+                              hp^.base:=hregister;
+                              { load vmt pointer }
+                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                hp,R_EDI)));
+                              { load method address }
+                              new(hp);
+                              reset_reference(hp^);
+                              hp^.base:=R_EDI;
+                              hp^.offset:=pprocsym(p^.symtableentry)^.definition^.extnumber*4+12;
+                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                hp,R_EDI)));
+                              { ... and store it }
+                              exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
+                                R_EDI,newreference(p^.location.reference))));
+
                            end
                          else
                            begin
-                              p^.location.reference.symbol:=stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
+                              new(s);
+                              s^.symbol:=strpnew(pprocsym(p^.symtableentry)^.definition^.mangledname);
+                              s^.offset:=0;
+
+                              exprasmlist^.concat(new(pai386,op_csymbol_ref(A_MOV,S_L,s,
+                                newreference(p^.location.reference))));
+
                               maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
                            end;
                       end
@@ -734,7 +791,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.42  1999-01-21 22:10:40  peter
+  Revision 1.43  1999-01-27 00:13:54  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.42  1999/01/21 22:10:40  peter
     * fixed array of const
     * generic platform independent high() support
 

compiler/pexpr.pas

@@ -1838,9 +1838,10 @@ unit pexpr;
                                          (proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then
                                         begin
                                            p2^.treetype:=loadn;
+                                           p2^.disposetyp:=dt_left;
                                            p2^.left:=p2^.methodpointer;
                                            p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
-                                           p2^.symtableentry:=p2^.symtableprocentry;
+                                           p2^.symtableentry:=pvarsym(p2^.symtableprocentry);
                                         end;
                                    end
                                  else if (proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then
@@ -1930,7 +1931,10 @@ unit pexpr;
 end.
 {
   $Log$
-  Revision 1.80  1999-01-21 16:41:01  pierre
+  Revision 1.81  1999-01-27 00:13:55  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.80  1999/01/21 16:41:01  pierre
    * fix for constructor inside with statements
 
   Revision 1.79  1998/12/30 22:15:48  peter

compiler/tccnv.pas

@@ -679,9 +679,12 @@ implementation
            own resulttype. They will therefore always be incompatible with
            a procvar. Because isconvertable cannot check for procedures we
            use an extra check for them.}
-           if (m_tp_procvar in aktmodeswitches) and
-             ((is_procsym_load(p^.left) or is_procsym_call(p^.left)) and
-             (p^.resulttype^.deftype=procvardef)) then
+           if (p^.resulttype^.deftype=procvardef) and
+              ((m_tp_procvar in aktmodeswitches) or
+              { method pointer use always the TP syntax }
+               ((pprocvardef(p^.resulttype)^.options and pomethodpointer)<>0)
+              ) and
+             ((is_procsym_load(p^.left) or is_procsym_call(p^.left))) then
              begin
                 { just a test: p^.explizit:=false; }
                 if is_procsym_call(p^.left) then
@@ -744,7 +747,10 @@ implementation
                     proctype:=aprocdef^.deftype;
                     aprocdef^.deftype:=procvardef;
 
-                    if not is_equal(aprocdef,p^.resulttype) then
+                    { only methods can be assigned to method pointers }
+                    if (assigned(p^.left^.left) and
+                      ((pprocvardef(p^.resulttype)^.options and pomethodpointer)=0)) or
+                       not(is_equal(aprocdef,p^.resulttype)) then
                       begin
                         aprocdef^.deftype:=proctype;
                         CGMessage(type_e_mismatch);
@@ -949,7 +955,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.14  1999-01-19 12:17:45  peter
+  Revision 1.15  1999-01-27 00:13:57  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.14  1999/01/19 12:17:45  peter
     * removed rangecheck warning which was shown twice
 
   Revision 1.13  1998/12/30 22:13:47  peter

compiler/tcld.pas

@@ -171,6 +171,16 @@ implementation
                    if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
                      CGMessage(parser_e_no_overloaded_procvars);
                    p^.resulttype:=pprocsym(p^.symtableentry)^.definition;
+                   { method pointer ? }
+                   if assigned(p^.left) then
+                     begin
+                        firstpass(p^.left);
+                        p^.registers32:=max(p^.registers32,p^.left^.registers32);
+                        p^.registersfpu:=max(p^.registersfpu,p^.left^.registersfpu);
+{$ifdef SUPPORT_MMX}
+                        p^.registersmmx:=max(p^.registersmmx,p^.left^.registersmmx);
+{$endif SUPPORT_MMX}
+                     end;
                 end;
             else internalerror(3);
          end;
@@ -437,7 +447,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  1999-01-21 16:41:07  pierre
+  Revision 1.14  1999-01-27 00:13:58  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.13  1999/01/21 16:41:07  pierre
    * fix for constructor inside with statements
 
   Revision 1.12  1998/12/30 13:41:19  peter

compiler/tree.pas

@@ -238,7 +238,7 @@ unit tree;
              callparan : (is_colon_para : boolean;exact_match_found : boolean;hightree:ptree);
              assignn : (assigntyp : tassigntyp;concat_string : boolean);
              loadn : (symtableentry : psym;symtable : psymtable;
-                      is_absolute,is_first,is_methodpointer : boolean);
+                      is_absolute,is_first : boolean);
              calln : (symtableprocentry : psym;
                       symtableproc : psymtable;procdefinition : pprocdef;
                       methodpointer : ptree;
@@ -484,6 +484,8 @@ unit tree;
       begin
          if not(assigned(p)) then
            exit;
+         if not(p^.treetype in [addn..loadvmtn]) then
+           internalerror(26219);
          case p^.disposetyp of
             dt_leftright :
               begin
@@ -927,7 +929,6 @@ unit tree;
          p^.symtableentry:=v;
          p^.symtable:=st;
          p^.is_first := False;
-         p^.is_methodpointer:=false;
          { method pointer load nodes can use the left subtree }
          p^.disposetyp:=dt_left;
          p^.left:=nil;
@@ -948,6 +949,7 @@ unit tree;
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
+         p^.left:=nil;
          p^.resulttype:=v^.definition;
          p^.symtableentry:=v;
          p^.symtable:=st;
@@ -972,6 +974,7 @@ unit tree;
          p^.registersmmx:=0;
 {$endif SUPPORT_MMX}
          p^.treetype:=loadn;
+         p^.left:=nil;
          p^.resulttype:=sym^.definition;
          p^.symtableentry:=pvarsym(sym);
          p^.symtable:=st;
@@ -1663,7 +1666,10 @@ unit tree;
 end.
 {
   $Log$
-  Revision 1.62  1999-01-21 22:10:52  peter
+  Revision 1.63  1999-01-27 00:14:00  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.62  1999/01/21 22:10:52  peter
     * fixed array of const
     * generic platform independent high() support
 

compiler/types.pas

@@ -688,8 +688,12 @@ unit types;
             if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
               begin
                  { poassembler isn't important for compatibility }
-                 b:=((pprocvardef(def1)^.options and not(poassembler))=
-                     (pprocvardef(def2)^.options and not(poassembler))
+                 { if a method is assigned to a methodpointer    }
+                 { is checked before                             }
+                 b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
+                       povirtualmethod or pooverridingmethod))=
+                     (pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
+                       povirtualmethod or pooverridingmethod))
                     ) and
                    is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
                  { now evalute the parameters }
@@ -1056,7 +1060,10 @@ unit types;
 end.
 {
   $Log$
-  Revision 1.46  1999-01-21 22:10:54  peter
+  Revision 1.47  1999-01-27 00:14:01  florian
+    * "procedure of object"-stuff fixed
+
+  Revision 1.46  1999/01/21 22:10:54  peter
     * fixed array of const
     * generic platform independent high() support