From ccd94e19cc8232ff165e55df68f1fae29afa7d1b Mon Sep 17 00:00:00 2001 From: florian Date: Wed, 27 Jan 1999 00:13:52 +0000 Subject: [PATCH] * "procedure of object"-stuff fixed --- compiler/cg386cal.pas | 10 +++++-- compiler/cg386cnv.pas | 25 +++++++++++----- compiler/cg386ld.pas | 68 ++++++++++++++++++++++++++++++++++++++++--- compiler/pexpr.pas | 8 +++-- compiler/tccnv.pas | 19 ++++++++---- compiler/tcld.pas | 15 +++++++++- compiler/tree.pas | 12 ++++++-- compiler/types.pas | 13 +++++++-- 8 files changed, 143 insertions(+), 27 deletions(-) diff --git a/compiler/cg386cal.pas b/compiler/cg386cal.pas index 2cf7315df1..9650681140 100644 --- a/compiler/cg386cal.pas +++ b/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 diff --git a/compiler/cg386cnv.pas b/compiler/cg386cnv.pas index 9732cc52d2..e1ecdaa711 100644 --- a/compiler/cg386cnv.pas +++ b/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 diff --git a/compiler/cg386ld.pas b/compiler/cg386ld.pas index 94f364d867..b4c26abd12 100644 --- a/compiler/cg386ld.pas +++ b/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 diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 91bcd9baee..d18db558da 100644 --- a/compiler/pexpr.pas +++ b/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 diff --git a/compiler/tccnv.pas b/compiler/tccnv.pas index 33b09bb3c3..dcfdf3ba79 100644 --- a/compiler/tccnv.pas +++ b/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 diff --git a/compiler/tcld.pas b/compiler/tcld.pas index 3ae45f068e..179c314c13 100644 --- a/compiler/tcld.pas +++ b/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 diff --git a/compiler/tree.pas b/compiler/tree.pas index c38584abf5..321fa519ff 100644 --- a/compiler/tree.pas +++ b/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 diff --git a/compiler/types.pas b/compiler/types.pas index 1ff12a70f0..959c6b1bbb 100644 --- a/compiler/types.pas +++ b/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