paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-13 05:59:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* "procedure of object"-stuff fixed

Browse Source
This commit is contained in:
florian 1999-01-27 00:13:52 +00:00
parent db12b9222a
commit ccd94e19cc
8 changed files with 143 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler/cg386cal.pas
View File

@ -851,8 +851,11 @@ implementation
begin begin
{ method pointer can't be in a register } { method pointer can't be in a register }
inc(p^.right^.location.reference.offset,4); 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 } { 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); del_reference(p^.right^.location.reference);
dec(p^.right^.location.reference.offset,4); dec(p^.right^.location.reference.offset,4);
end; end;
@ -1232,7 +1235,10 @@ implementation
end. end.
{ {
$Log$ $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 * fixed array of const
* generic platform independent high() support * generic platform independent high() support

25
compiler/cg386cnv.pas
View File

@ -1069,12 +1069,20 @@ implementation
procedure second_proc_to_procvar(pto,pfrom : ptree;convtyp : tconverttype); procedure second_proc_to_procvar(pto,pfrom : ptree;convtyp : tconverttype);
begin begin
clear_location(pto^.location); { method pointer ? }
pto^.location.loc:=LOC_REGISTER; if assigned(pfrom^.left) then
pto^.location.register:=getregister32; begin
del_reference(pfrom^.location.reference); set_location(pto^.location,pfrom^.location);
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, end
newreference(pfrom^.location.reference),pto^.location.register))); 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; end;
@ -1562,7 +1570,10 @@ implementation
end. end.
{ {
$Log$ $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 * fixed array of const
* generic platform independent high() support * generic platform independent high() support

68
compiler/cg386ld.pas
View File

@ -51,6 +51,7 @@ implementation
symtabletype : tsymtabletype; symtabletype : tsymtabletype;
i : longint; i : longint;
hp : preference; hp : preference;
s : pcsymbol;
begin begin
simple_loadn:=true; simple_loadn:=true;
reset_reference(p^.location.reference); reset_reference(p^.location.reference);
@ -234,17 +235,73 @@ implementation
end; end;
procsym: procsym:
begin begin
if p^.is_methodpointer then if assigned(p^.left) then
begin begin
secondpass(p^.left); 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 ? } { virtual method ? }
if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then
begin 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 end
else else
begin 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); maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
end; end;
end end
@ -734,7 +791,10 @@ implementation
end. end.
{ {
$Log$ $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 * fixed array of const
* generic platform independent high() support * generic platform independent high() support

8
compiler/pexpr.pas
View File

@ -1838,9 +1838,10 @@ unit pexpr;
(proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then (proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then
begin begin
p2^.treetype:=loadn; p2^.treetype:=loadn;
p2^.disposetyp:=dt_left;
p2^.left:=p2^.methodpointer; p2^.left:=p2^.methodpointer;
p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition; p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
p2^.symtableentry:=p2^.symtableprocentry; p2^.symtableentry:=pvarsym(p2^.symtableprocentry);
end; end;
end end
else if (proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then else if (proc_to_procvar_equal(getprocvardef,pprocsym(p2^.symtableentry)^.definition)) then
@ -1930,7 +1931,10 @@ unit pexpr;
end. end.
{ {
$Log$ $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 * fix for constructor inside with statements
Revision 1.79 1998/12/30 22:15:48 peter Revision 1.79 1998/12/30 22:15:48 peter

19
compiler/tccnv.pas
View File

@ -679,9 +679,12 @@ implementation
own resulttype. They will therefore always be incompatible with own resulttype. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we a procvar. Because isconvertable cannot check for procedures we
use an extra check for them.} use an extra check for them.}
if (m_tp_procvar in aktmodeswitches) and if (p^.resulttype^.deftype=procvardef) and
((is_procsym_load(p^.left) or is_procsym_call(p^.left)) and ((m_tp_procvar in aktmodeswitches) or
(p^.resulttype^.deftype=procvardef)) then { 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 begin
{ just a test: p^.explizit:=false; } { just a test: p^.explizit:=false; }
if is_procsym_call(p^.left) then if is_procsym_call(p^.left) then
@ -744,7 +747,10 @@ implementation
proctype:=aprocdef^.deftype; proctype:=aprocdef^.deftype;
aprocdef^.deftype:=procvardef; 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 begin
aprocdef^.deftype:=proctype; aprocdef^.deftype:=proctype;
CGMessage(type_e_mismatch); CGMessage(type_e_mismatch);
@ -949,7 +955,10 @@ implementation
end. end.
{ {
$Log$ $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 * removed rangecheck warning which was shown twice
Revision 1.13 1998/12/30 22:13:47 peter Revision 1.13 1998/12/30 22:13:47 peter

15
compiler/tcld.pas
View File

@ -171,6 +171,16 @@ implementation
if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
CGMessage(parser_e_no_overloaded_procvars); CGMessage(parser_e_no_overloaded_procvars);
p^.resulttype:=pprocsym(p^.symtableentry)^.definition; 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; end;
else internalerror(3); else internalerror(3);
end; end;
@ -437,7 +447,10 @@ implementation
end. end.
{ {
$Log$ $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 * fix for constructor inside with statements
Revision 1.12 1998/12/30 13:41:19 peter Revision 1.12 1998/12/30 13:41:19 peter

12
compiler/tree.pas
View File

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

13
compiler/types.pas
View File

@ -688,8 +688,12 @@ unit types;
if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
begin begin
{ poassembler isn't important for compatibility } { poassembler isn't important for compatibility }
b:=((pprocvardef(def1)^.options and not(poassembler))= { if a method is assigned to a methodpointer }
(pprocvardef(def2)^.options and not(poassembler)) { 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 ) and
is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef); is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
{ now evalute the parameters } { now evalute the parameters }
@ -1056,7 +1060,10 @@ unit types;
end. end.
{ {
$Log$ $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 * fixed array of const
* generic platform independent high() support * generic platform independent high() support