* fixed execution order of implicit finalization and class destructors: first

    the latter, then the former

git-svn-id: trunk@38716 -

.gitattributes

@@ -15846,6 +15846,7 @@ tests/webtbs/tw2916.pp svneol=native#text/plain
 tests/webtbs/tw2920.pp svneol=native#text/plain
 tests/webtbs/tw2923.pp svneol=native#text/plain
 tests/webtbs/tw29244.pp svneol=native#text/pascal
+tests/webtbs/tw29245.pp svneol=native#text/plain
 tests/webtbs/tw29250.pp svneol=native#text/pascal
 tests/webtbs/tw2926.pp svneol=native#text/plain
 tests/webtbs/tw2927.pp svneol=native#text/plain
@@ -16702,6 +16703,7 @@ tests/webtbs/uw28442.pp svneol=native#text/pascal
 tests/webtbs/uw28766.pp svneol=native#text/pascal
 tests/webtbs/uw28964.pp svneol=native#text/plain
 tests/webtbs/uw2920.pp svneol=native#text/plain
+tests/webtbs/uw29245.pp svneol=native#text/plain
 tests/webtbs/uw2956.pp svneol=native#text/plain
 tests/webtbs/uw2984.pp svneol=native#text/plain
 tests/webtbs/uw3103.pp svneol=native#text/plain

compiler/ncal.pas

@@ -54,8 +54,9 @@ interface
          cnf_objc_id_call,       { the procedure is a member call via id -> any ObjC method of any ObjC type in scope is fair game }
          cnf_unit_specified,     { the unit in which the procedure has to be searched has been specified }
          cnf_call_never_returns, { information for the dfa that a subroutine never returns }
-         cnf_call_self_node_done { the call_self_node has been generated if necessary
+         cnf_call_self_node_done,{ the call_self_node has been generated if necessary
                                    (to prevent it from potentially happening again in a wrong context in case of constant propagation or so) }
+         cnf_ignore_visibility   { internally generated call that should ignore visibility checks }
        );
        tcallnodeflags = set of tcallnodeflag;
 
@@ -3596,7 +3597,8 @@ implementation
                      end;
                    { ignore possible private for properties or in delphi mode for anon. inherited (FK) }
                    ignorevisibility:=(nf_isproperty in flags) or
-                                     ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
+                                     ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)) or
+                                     (cnf_ignore_visibility in callnodeflags);
                    candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
                      not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags,
                      callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags,spezcontext);

compiler/ngenutil.pas

@@ -48,6 +48,8 @@ interface
       class function initialize_data_node(p:tnode; force: boolean):tnode; virtual;
       class function finalize_data_node(p:tnode):tnode; virtual;
      strict protected
+      type
+        tstructinifinipotype = potype_class_constructor..potype_class_destructor;
       class procedure sym_maybe_initialize(p: TObject; arg: pointer);
       { generates the code for finalisation of local variables }
       class procedure local_varsyms_finalize(p:TObject;arg:pointer);
@@ -55,6 +57,7 @@ interface
         all local (static) typed consts }
       class procedure static_syms_finalize(p: TObject; arg: pointer);
       class procedure sym_maybe_finalize(var stat: tstatementnode; sym: tsym);
+      class procedure append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode);
      public
       class procedure procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode);
       class procedure procdef_block_add_implicit_finalize_nodes(pd: tprocdef; var stat: tstatementnode);
@@ -421,6 +424,47 @@ implementation
     end;
 
 
+  procedure AddToStructInits(p:TObject;arg:pointer);
+    var
+      StructList: TFPList absolute arg;
+    begin
+      if (tdef(p).typ in [objectdef,recorddef]) and
+         not (df_generic in tdef(p).defoptions) then
+        begin
+          { first add the class... }
+          if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
+            StructList.Add(p);
+          { ... and then also add all subclasses }
+          tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg);
+        end;
+    end;
+
+
+  class procedure tnodeutils.append_struct_initfinis(u: tmodule; initfini: tstructinifinipotype; var stat: tstatementnode);
+    var
+      structlist: tfplist;
+      i: integer;
+      pd: tprocdef;
+    begin
+      structlist:=tfplist.Create;
+      if assigned(u.globalsymtable) then
+        u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
+      u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
+      { write structures }
+      for i:=0 to structlist.Count-1 do
+        begin
+          pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(initfini);
+          if assigned(pd) then
+            begin
+              { class constructors are private -> ignore visibility checks }
+              addstatement(stat,
+                ccallnode.create(nil,tprocsym(pd.procsym),pd.owner,nil,[cnf_ignore_visibility],nil))
+            end;
+        end;
+      structlist.free;
+    end;
+
+
   class procedure tnodeutils.procdef_block_add_implicit_initialize_nodes(pd: tprocdef; var stat: tstatementnode);
     begin
       { initialize local data like ansistrings }
@@ -432,6 +476,9 @@ implementation
              if assigned(current_module.globalsymtable) then
                TSymtable(current_module.globalsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat);
              TSymtable(current_module.localsymtable).SymList.ForEachCall(@sym_maybe_initialize,@stat);
+             { insert class constructors  }
+             if (current_module.flags and uf_classinits) <> 0 then
+               append_struct_initfinis(current_module, potype_class_constructor, stat);
            end;
          { units have seperate code for initilization and finalization }
          potype_unitfinalize: ;
@@ -453,6 +500,9 @@ implementation
       case current_procinfo.procdef.proctypeoption of
          potype_unitfinalize:
            begin
+             { insert class destructors  }
+             if (current_module.flags and uf_classinits) <> 0 then
+               append_struct_initfinis(current_module, potype_class_destructor, stat);
              { this is also used for initialization of variables in a
                program which does not have a globalsymtable }
              if assigned(current_module.globalsymtable) then
@@ -894,82 +944,16 @@ implementation
     end;
 
 
-  procedure AddToStructInits(p:TObject;arg:pointer);
-    var
-      StructList: TFPList absolute arg;
-    begin
-      if (tdef(p).typ in [objectdef,recorddef]) and
-         not (df_generic in tdef(p).defoptions) then
-        begin
-          { first add the class... }
-          if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
-            StructList.Add(p);
-          { ... and then also add all subclasses }
-          tabstractrecorddef(p).symtable.deflist.foreachcall(@AddToStructInits,arg);
-        end;
-    end;
-
-
   class function tnodeutils.get_init_final_list:tfplist;
-
-    procedure append_struct_inits(u:tmodule);
-      var
-        i : integer;
-        structlist : tfplist;
-        pd : tprocdef;
-        entry : pinitfinalentry;
-      begin
-        structlist:=tfplist.Create;
-        if assigned(u.globalsymtable) then
-          u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
-        u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
-        { write structures }
-        for i:=0 to structlist.Count-1 do
-        begin
-          new(entry);
-          entry^.module:=u;
-          pd:=tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_constructor);
-          if assigned(pd) then
-            begin
-              entry^.initfunc:=pd.mangledname;
-              entry^.initpd:=pd;
-            end
-          else
-            begin
-              entry^.initfunc:='';
-              entry^.initpd:=nil;
-            end;
-          pd := tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_destructor);
-          if assigned(pd) then
-            begin
-              entry^.finifunc:=pd.mangledname;
-              entry^.finipd:=pd;
-            end
-          else
-            begin
-              entry^.finifunc:='';
-              entry^.finipd:=nil;
-            end;
-          if assigned(entry^.finipd) or assigned(entry^.initpd) then
-            result.add(entry)
-          else
-            { AddToStructInits only adds structs that have either a class constructor or destructor or both }
-            internalerror(2017051902);
-        end;
-        structlist.free;
-      end;
-
     var
       hp : tused_unit;
       entry : pinitfinalentry;
     begin
       result:=tfplist.create;
+      { Insert initialization/finalization of the used units }
       hp:=tused_unit(usedunits.first);
       while assigned(hp) do
        begin
-         { insert class constructors/destructors of the unit }
-         if (hp.u.flags and uf_classinits) <> 0 then
-           append_struct_inits(hp.u);
          if (hp.u.flags and (uf_init or uf_finalize))<>0 then
            begin
              new(entry);
@@ -989,8 +973,6 @@ implementation
          hp:=tused_unit(hp.next);
        end;
 
-      if (current_module.flags and uf_classinits) <> 0 then
-        append_struct_inits(current_module);
       { Insert initialization/finalization of the program }
       if (current_module.flags and (uf_init or uf_finalize))<>0 then
         begin

compiler/symtable.pas

@@ -70,7 +70,7 @@ interface
           procedure allprivatesused;
           procedure check_forwards;
           procedure checklabels;
-          function  needs_init_final : boolean;
+          function  needs_init_final : boolean; virtual;
           procedure testfordefaultproperty(sym:TObject;arg:pointer);
           procedure register_children;
        end;
@@ -226,7 +226,9 @@ interface
           function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
           function findnamespace(const n:string):TSymEntry;virtual;
           function iscurrentunit:boolean;override;
+          function needs_init_final: boolean; override;
           procedure insertunit(sym:TSymEntry);
+          function has_class_condestructors: boolean;
        end;
 
        tglobalsymtable = class(tabstractuniTSymtable)
@@ -2420,6 +2422,23 @@ implementation
                 );
       end;
 
+
+    function tabstractuniTSymtable.needs_init_final: boolean;
+      begin
+        if not init_final_check_done then
+          begin
+            result:=inherited needs_init_final;
+            if not result then
+              begin
+                result:=has_class_condestructors;
+                if result then
+                  include(tableoptions,sto_needs_init_final);
+              end;
+          end;
+        result:=sto_needs_init_final in tableoptions;
+      end;
+
+
     procedure tabstractuniTSymtable.insertunit(sym:TSymEntry);
       var
         p:integer;
@@ -2444,6 +2463,32 @@ implementation
           end;
       end;
 
+
+    procedure CheckForClassConDestructors(p:TObject;arg:pointer);
+      var
+        result: pboolean absolute arg;
+      begin
+        if result^ then
+          exit;
+        if (tdef(p).typ in [objectdef,recorddef]) and
+           not (df_generic in tdef(p).defoptions) then
+          begin
+            { first check the class... }
+            if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
+              result^:=true;;
+            { ... and then also check all subclasses }
+            if not result^ then
+              tabstractrecorddef(p).symtable.deflist.foreachcall(@CheckForClassConDestructors,arg);
+          end;
+      end;
+
+
+    function tabstractuniTSymtable.has_class_condestructors: boolean;
+      begin
+        result:=false;
+        deflist.foreachcall(@CheckForClassConDestructors,@result);
+      end;
+
 {****************************************************************************
                               TStaticSymtable
 ****************************************************************************}

tests/webtbs/tw29245.pp

@@ -0,0 +1,36 @@
+{ %opt=-gh }
+
+{$mode delphi}
+
+uses
+  uw29245;
+
+ type
+  TBar = class
+  class var
+    F: array of TObject;
+  strict private
+    class constructor Create;
+    class destructor Destroy;
+  end;
+
+class constructor TBar.Create;
+begin
+  writeln('tbar class constructor');
+  SetLength(F, 10);
+end;
+
+class destructor TBar.Destroy;
+begin
+  writeln('tbar class destructor');
+  if length(Tbar.F)<>10 then
+    halt(5);
+end;
+
+begin
+  HaltOnNotReleased := true;
+  writeln('main program');
+  if length(TBar.F)<>10 then
+    halt(4);
+end.
+

tests/webtbs/uw29245.pp

@@ -0,0 +1,41 @@
+unit uw29245;
+
+{$mode delphi}
+
+interface
+
+ type
+  TFoo = class
+  class var
+    F: array of TObject;
+  private
+    class constructor Create;
+    class destructor Destroy;
+  end;
+
+implementation
+
+class constructor TFoo.Create;
+begin
+  writeln('tfoo class constructor');
+  SetLength(F, 10);
+end;
+
+class destructor TFoo.Destroy;
+begin
+  writeln('tfoo class destructor');
+  if length(TFOO.F)<>10 then
+    halt(3);
+end;
+
+initialization
+  writeln('unit initialization');
+  if length(TFOO.F)<>10 then
+    halt(1);
+
+finalization
+  writeln('unit finalization');
+  if length(TFOO.F)<>10 then
+    halt(2);
+
+end.