paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 03:29:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* an exception in a construcor calls now the destructor (this applies only

Browse Source 
to classes)
This commit is contained in:
florian 2000-02-04 20:00:21 +00:00
parent b24d42f9be
commit a0cc4f970b
5 changed files with 135 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
compiler/cg386cal.pas
View File

@ -551,7 +551,7 @@ implementation
emit_reg(A_PUSH,S_L,R_ESI); emit_reg(A_PUSH,S_L,R_ESI);
{ if an inherited con- or destructor should be } { if an inherited con- or destructor should be }
{ called in a con- or destructor then a warning } { called in a con- or destructor then a warning }
{ will be made } { will be made }
{ con- and destructors need a pointer to the vmt } { con- and destructors need a pointer to the vmt }
if is_con_or_destructor and if is_con_or_destructor and
not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and
@ -561,12 +561,18 @@ implementation
[potype_constructor,potype_destructor]) then [potype_constructor,potype_destructor]) then
CGMessage(cg_w_member_cd_call_from_method); CGMessage(cg_w_member_cd_call_from_method);
end; end;
{ class destructors get there flag below } { class destructors get there flag above }
{ constructor flags ? }
if is_con_or_destructor and if is_con_or_destructor and
not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and
assigned(aktprocsym) and assigned(aktprocsym) and
(aktprocsym^.definition^.proctypeoption=potype_destructor)) then (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
push_int(0); begin
{ a constructor needs also a flag }
if pobjectdef(p^.methodpointer^.resulttype)^.is_class then
push_int(0);
push_int(0);
end;
end; end;
hnewn: hnewn:
begin begin
@ -643,7 +649,7 @@ implementation
emit_ref_reg(A_MOV,S_L,r,R_ESI); emit_ref_reg(A_MOV,S_L,r,R_ESI);
end; end;
{ direct call to destructor: don't remove data! } { direct call to destructor: remove data }
if (p^.procdefinition^.proctypeoption=potype_destructor) and if (p^.procdefinition^.proctypeoption=potype_destructor) and
(p^.methodpointer^.resulttype^.deftype=objectdef) and (p^.methodpointer^.resulttype^.deftype=objectdef) and
(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
@ -653,9 +659,19 @@ implementation
if (p^.procdefinition^.proctypeoption=potype_constructor) and if (p^.procdefinition^.proctypeoption=potype_constructor) and
(p^.methodpointer^.resulttype^.deftype=objectdef) and (p^.methodpointer^.resulttype^.deftype=objectdef) and
(pobjectdef(p^.methodpointer^.resulttype)^.is_class) then (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then
emit_const(A_PUSH,S_L,0) begin
emit_const(A_PUSH,S_L,0);
emit_const(A_PUSH,S_L,0);
end
else else
emit_reg(A_PUSH,S_L,R_ESI); begin
{ constructor call via classreference => allocate memory }
if (p^.procdefinition^.proctypeoption=potype_constructor) and
(p^.methodpointer^.resulttype^.deftype=classrefdef) and
(pobjectdef(pclassrefdef(p^.methodpointer^.resulttype)^.pointertype.def)^.is_class) then
emit_const(A_PUSH,S_L,1);
emit_reg(A_PUSH,S_L,R_ESI);
end;
end; end;
if is_con_or_destructor then if is_con_or_destructor then
@ -671,7 +687,7 @@ implementation
pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)); pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname));
end end
{ destructors haven't to dispose the instance, if this is } { destructors haven't to dispose the instance, if this is }
{ a direct call } { a direct call }
else else
push_int(0); push_int(0);
end; end;
@ -709,7 +725,10 @@ implementation
emit_reg(A_PUSH,S_L,R_ESI); emit_reg(A_PUSH,S_L,R_ESI);
end end
else if (p^.procdefinition^.proctypeoption=potype_constructor) then else if (p^.procdefinition^.proctypeoption=potype_constructor) then
emit_const(A_PUSH,S_L,0) begin
emit_const(A_PUSH,S_L,0);
emit_const(A_PUSH,S_L,0);
end
else else
emit_reg(A_PUSH,S_L,R_ESI); emit_reg(A_PUSH,S_L,R_ESI);
end end
@ -1332,7 +1351,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.123 2000-01-26 15:03:59 peter Revision 1.124 2000-02-04 20:00:21 florian
* an exception in a construcor calls now the destructor (this applies only
to classes)
Revision 1.123 2000/01/26 15:03:59 peter
* fixed pop_size included twice with clearstack * fixed pop_size included twice with clearstack
Revision 1.122 2000/01/26 12:02:29 peter Revision 1.122 2000/01/26 12:02:29 peter
@ -1465,4 +1488,4 @@ end.
Revision 1.90.2.3 1999/06/22 13:30:08 peter Revision 1.90.2.3 1999/06/22 13:30:08 peter
* fixed return with packenum * fixed return with packenum
} }

56
compiler/cgai386.pas
View File

@ -3089,9 +3089,9 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{ a constructor needs a help procedure } { a constructor needs a help procedure }
if (aktprocsym^.definition^.proctypeoption=potype_constructor) then if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
begin begin
{!!!! not yet procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;}
if procinfo^._class^.is_class then if procinfo^._class^.is_class then
begin begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel))); exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel)));
emitinsertcall('FPC_NEW_CLASS'); emitinsertcall('FPC_NEW_CLASS');
end end
@ -3404,12 +3404,11 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
mangled_length : longint; mangled_length : longint;
p : pchar; p : pchar;
{$endif GDB} {$endif GDB}
nofinal,okexitlabel,noreraiselabel : pasmlabel; nofinal,okexitlabel,noreraiselabel,nodestroycall : pasmlabel;
hr : treference; hr : treference;
oldexprasmlist : paasmoutput; oldexprasmlist : paasmoutput;
ai : paicpu; ai : paicpu;
pd : pprocdef; pd : pprocdef;
r : preference;
begin begin
oldexprasmlist:=exprasmlist; oldexprasmlist:=exprasmlist;
@ -3477,30 +3476,39 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
emitjmp(C_E,noreraiselabel); emitjmp(C_E,noreraiselabel);
if (aktprocsym^.definition^.proctypeoption=potype_constructor) then if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
begin begin
{
if assigned(procinfo^._class) then if assigned(procinfo^._class) then
begin begin
pd:=procinfo^._class^.searchdestructor; pd:=procinfo^._class^.searchdestructor;
if procinfo^._class^.is_class then if assigned(pd) then
begin
emit_const(A_PUSH,S_L,1);
emit_reg(A_PUSH,S_L,R_ESI);
end
else
begin
emit_reg(A_PUSH,S_L,R_ESI);
emit_sym(A_PUSH,S_L,newasmsymbol(procinfo._class^.vmt_mangledname);
end;
if (po_virtualmethod in pd^.procoptions) then
begin
emit_ref_reg(A_MOV,S_L,ref,R_EDI)
emit_ref(A_CALL,S_NO,ref);
end
else
begin begin
getlabel(nodestroycall);
emit_const_ref(A_CMP,S_L,0,new_reference(procinfo^.framepointer,
procinfo^.selfpointer_offset));
emitjmp(C_E,nodestroycall);
if procinfo^._class^.is_class then
begin
emit_const(A_PUSH,S_L,1);
emit_reg(A_PUSH,S_L,R_ESI);
end
else
begin
emit_reg(A_PUSH,S_L,R_ESI);
emit_sym(A_PUSH,S_L,newasmsymbol(procinfo^._class^.vmt_mangledname));
end;
if (po_virtualmethod in pd^.procoptions) then
begin
emit_ref_reg(A_MOV,S_L,new_reference(R_ESI,0),R_EDI);
emit_ref(A_CALL,S_NO,new_reference(R_EDI,procinfo^._class^.vmtmethodoffset(pd^.extnumber)));
end
else
emitcall(pd^.mangledname);
{ not necessary because the result is never assigned in the
case of an exception (FK) }
emit_const_reg(A_MOV,S_L,0,R_ESI);
emit_const_ref(A_MOV,S_L,0,new_reference(procinfo^.framepointer,8));
emitlab(nodestroycall);
end; end;
end end
}
end end
else else
{ must be the return value finalized before reraising the exception? } { must be the return value finalized before reraising the exception? }
@ -3724,7 +3732,11 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
end. end.
{ {
$Log$ $Log$
Revision 1.76 2000-02-04 14:29:57 pierre Revision 1.77 2000-02-04 20:00:21 florian
* an exception in a construcor calls now the destructor (this applies only
to classes)
Revision 1.76 2000/02/04 14:29:57 pierre
+ add pseudo local var parent_ebp for local procs + add pseudo local var parent_ebp for local procs
Revision 1.75 2000/01/25 08:46:03 pierre Revision 1.75 2000/01/25 08:46:03 pierre

10
compiler/psub.pas
View File

@ -310,10 +310,10 @@ begin
inc(paramoffset,target_os.size_of_pointer); inc(paramoffset,target_os.size_of_pointer);
end; end;
{ destructor flag ? } { con/-destructor flag ? }
if assigned (procinfo^._Class) and if assigned (procinfo^._Class) and
procinfo^._class^.is_class and procinfo^._class^.is_class and
(pd^.proctypeoption=potype_destructor) then (pd^.proctypeoption in [potype_destructor,potype_constructor]) then
inc(paramoffset,target_os.size_of_pointer); inc(paramoffset,target_os.size_of_pointer);
procinfo^.para_offset:=paramoffset; procinfo^.para_offset:=paramoffset;
@ -1969,7 +1969,11 @@ end.
{ {
$Log$ $Log$
Revision 1.45 2000-02-04 14:54:17 jonas Revision 1.46 2000-02-04 20:00:22 florian
* an exception in a construcor calls now the destructor (this applies only
to classes)
Revision 1.45 2000/02/04 14:54:17 jonas
* moved call to resetusableregs to compile_proc_body (put it right before the * moved call to resetusableregs to compile_proc_body (put it right before the
reset of the temp generator) so the optimizer can know which registers are reset of the temp generator) so the optimizer can know which registers are
regvars regvars

53
compiler/symdef.inc
View File

@ -3342,6 +3342,53 @@ Const local_symtable_index : longint = $8001;
is_related:=false; is_related:=false;
end; end;
var
sd : pprocdef;
procedure _searchdestructor(sym : pnamedindexobject);{$ifndef fpc}far;{$endif}
var
p : pprocdef;
begin
{ if we found already a destructor, then we exit }
if assigned(sd) then
exit;
if psym(sym)^.typ=procsym then
begin
p:=pprocsym(sym)^.definition;
while assigned(p) do
begin
if p^.proctypeoption=potype_destructor then
begin
sd:=p;
exit;
end;
p:=p^.nextoverloaded;
end;
end;
end;
function tobjectdef.searchdestructor : pprocdef;
var
o : pobjectdef;
begin
searchdestructor:=nil;
o:=@self;
sd:=nil;
while assigned(o) do
begin
symtable^.foreach({$ifndef TP}@{$endif}_searchdestructor);
if assigned(sd) then
begin
searchdestructor:=sd;
exit;
end;
o:=o^.childof;
end;
end;
function tobjectdef.size : longint; function tobjectdef.size : longint;
begin begin
@ -3868,7 +3915,11 @@ Const local_symtable_index : longint = $8001;
{ {
$Log$ $Log$
Revision 1.191 2000-01-30 23:29:06 peter Revision 1.192 2000-02-04 20:00:22 florian
* an exception in a construcor calls now the destructor (this applies only
to classes)
Revision 1.191 2000/01/30 23:29:06 peter
* fixed dup rtti writing for classes * fixed dup rtti writing for classes
Revision 1.190 2000/01/28 23:17:53 florian Revision 1.190 2000/01/28 23:17:53 florian

12
compiler/symdefh.inc
View File

@ -174,6 +174,8 @@
{$endif GDB} {$endif GDB}
end; end;
pprocdef = ^tprocdef;
pobjectdef = ^tobjectdef; pobjectdef = ^tobjectdef;
tobjectdef = object(tdef) tobjectdef = object(tdef)
childof : pobjectdef; childof : pobjectdef;
@ -200,6 +202,7 @@
function next_free_name_index : longint; function next_free_name_index : longint;
procedure insertvmt; procedure insertvmt;
procedure set_parent(c : pobjectdef); procedure set_parent(c : pobjectdef);
function searchdestructor : pprocdef;
{ debug } { debug }
{$ifdef GDB} {$ifdef GDB}
function stabstring : pchar;virtual; function stabstring : pchar;virtual;
@ -381,7 +384,6 @@
1 : (i : longint); 1 : (i : longint);
end; end;
pprocdef = ^tprocdef;
tprocdef = object(tabstractprocdef) tprocdef = object(tabstractprocdef)
private private
_mangledname : pchar; _mangledname : pchar;
@ -528,7 +530,11 @@
{ {
$Log$ $Log$
Revision 1.51 2000-01-26 12:02:30 peter Revision 1.52 2000-02-04 20:00:22 florian
* an exception in a construcor calls now the destructor (this applies only
to classes)
Revision 1.51 2000/01/26 12:02:30 peter
* abstractprocdef.para_size needs alignment parameter * abstractprocdef.para_size needs alignment parameter
* secondcallparan gets para_alignment size instead of dword_align * secondcallparan gets para_alignment size instead of dword_align
@ -646,4 +652,4 @@
position info position info
* Removed comp warnings * Removed comp warnings
} }