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

    to classes)

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
 
-}
+}

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

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

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

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
 
-}
+}