diff --git a/compiler/cg386cal.pas b/compiler/cg386cal.pas index 38da1e45f2..8a49a36a2e 100644 --- a/compiler/cg386cal.pas +++ b/compiler/cg386cal.pas @@ -551,7 +551,7 @@ implementation emit_reg(A_PUSH,S_L,R_ESI); { if an inherited con- or destructor should be } { called in a con- or destructor then a warning } - { will be made } + { will be made } { con- and destructors need a pointer to the vmt } if is_con_or_destructor and not(pobjectdef(p^.methodpointer^.resulttype)^.is_class) and @@ -561,12 +561,18 @@ implementation [potype_constructor,potype_destructor]) then CGMessage(cg_w_member_cd_call_from_method); end; - { class destructors get there flag below } + { class destructors get there flag above } + { constructor flags ? } if is_con_or_destructor and not(pobjectdef(p^.methodpointer^.resulttype)^.is_class and assigned(aktprocsym) and (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; hnewn: begin @@ -643,7 +649,7 @@ implementation emit_ref_reg(A_MOV,S_L,r,R_ESI); end; - { direct call to destructor: don't remove data! } + { direct call to destructor: remove data } if (p^.procdefinition^.proctypeoption=potype_destructor) and (p^.methodpointer^.resulttype^.deftype=objectdef) and (pobjectdef(p^.methodpointer^.resulttype)^.is_class) then @@ -653,9 +659,19 @@ implementation if (p^.procdefinition^.proctypeoption=potype_constructor) and (p^.methodpointer^.resulttype^.deftype=objectdef) and (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 - 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; if is_con_or_destructor then @@ -671,7 +687,7 @@ implementation pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname)); end { destructors haven't to dispose the instance, if this is } - { a direct call } + { a direct call } else push_int(0); end; @@ -709,7 +725,10 @@ implementation emit_reg(A_PUSH,S_L,R_ESI); end 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 emit_reg(A_PUSH,S_L,R_ESI); end @@ -1332,7 +1351,11 @@ implementation end. { $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 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 * fixed return with packenum -} +} \ No newline at end of file diff --git a/compiler/cgai386.pas b/compiler/cgai386.pas index 5796ad4a10..f4aa1a5232 100644 --- a/compiler/cgai386.pas +++ b/compiler/cgai386.pas @@ -3089,9 +3089,9 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); { a constructor needs a help procedure } if (aktprocsym^.definition^.proctypeoption=potype_constructor) then begin - {!!!! not yet procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;} if procinfo^._class^.is_class then begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel))); emitinsertcall('FPC_NEW_CLASS'); end @@ -3404,12 +3404,11 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); mangled_length : longint; p : pchar; {$endif GDB} - nofinal,okexitlabel,noreraiselabel : pasmlabel; + nofinal,okexitlabel,noreraiselabel,nodestroycall : pasmlabel; hr : treference; oldexprasmlist : paasmoutput; ai : paicpu; pd : pprocdef; - r : preference; begin oldexprasmlist:=exprasmlist; @@ -3477,30 +3476,39 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); emitjmp(C_E,noreraiselabel); if (aktprocsym^.definition^.proctypeoption=potype_constructor) then begin - { if assigned(procinfo^._class) then begin pd:=procinfo^._class^.searchdestructor; - 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,ref,R_EDI) - emit_ref(A_CALL,S_NO,ref); - end - else + if assigned(pd) then 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 else { 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. { $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 Revision 1.75 2000/01/25 08:46:03 pierre diff --git a/compiler/psub.pas b/compiler/psub.pas index 301168c2d4..b3d2f5d5e7 100644 --- a/compiler/psub.pas +++ b/compiler/psub.pas @@ -310,10 +310,10 @@ begin inc(paramoffset,target_os.size_of_pointer); end; - { destructor flag ? } + { con/-destructor flag ? } if assigned (procinfo^._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); procinfo^.para_offset:=paramoffset; @@ -1969,7 +1969,11 @@ end. { $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 reset of the temp generator) so the optimizer can know which registers are regvars diff --git a/compiler/symdef.inc b/compiler/symdef.inc index 7c98ba4b7b..abbc472ea9 100644 --- a/compiler/symdef.inc +++ b/compiler/symdef.inc @@ -3342,6 +3342,53 @@ Const local_symtable_index : longint = $8001; is_related:=false; 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; begin @@ -3868,7 +3915,11 @@ Const local_symtable_index : longint = $8001; { $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 Revision 1.190 2000/01/28 23:17:53 florian diff --git a/compiler/symdefh.inc b/compiler/symdefh.inc index 686b06c3fb..c9862abbb8 100644 --- a/compiler/symdefh.inc +++ b/compiler/symdefh.inc @@ -174,6 +174,8 @@ {$endif GDB} end; + pprocdef = ^tprocdef; + pobjectdef = ^tobjectdef; tobjectdef = object(tdef) childof : pobjectdef; @@ -200,6 +202,7 @@ function next_free_name_index : longint; procedure insertvmt; procedure set_parent(c : pobjectdef); + function searchdestructor : pprocdef; { debug } {$ifdef GDB} function stabstring : pchar;virtual; @@ -381,7 +384,6 @@ 1 : (i : longint); end; - pprocdef = ^tprocdef; tprocdef = object(tabstractprocdef) private _mangledname : pchar; @@ -528,7 +530,11 @@ { $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 * secondcallparan gets para_alignment size instead of dword_align @@ -646,4 +652,4 @@ position info * Removed comp warnings -} +} \ No newline at end of file