Fixed rtti/finalization of objects that have ancestors and fields of managed types:

* Link rtti to ancestor by writing rtti of ancestor as a field of type tkObject and offset zero. This is a cheat from formal point of view (as it replaces inheritance with aggregation), but is fine for the intended purpose of representing memory layout. Now RTL can handle entire instance of descendant object, and such objects can be statically allocated without leaks.
* Bypass finalization in inherited object destructors, as the instance is now entirely finalized in outermost destructor.
+ test

git-svn-id: trunk@16632 -

.gitattributes

@@ -9595,6 +9595,7 @@ tests/test/tobject4.pp svneol=native#text/plain
 tests/test/tobject5.pp svneol=native#text/pascal
 tests/test/tobject6.pp svneol=native#text/plain
 tests/test/tobject7.pp svneol=native#text/plain
+tests/test/tobject8.pp svneol=native#text/plain
 tests/test/toperator1.pp svneol=native#text/plain
 tests/test/toperator10.pp svneol=native#text/pascal
 tests/test/toperator2.pp svneol=native#text/plain

compiler/ncgrtti.pas

@@ -37,7 +37,7 @@ interface
       TRTTIWriter=class
       private
         procedure fields_write_rtti(st:tsymtable;rt:trttitype);
-        procedure fields_write_rtti_data(st:tsymtable;rt:trttitype);
+        procedure fields_write_rtti_data(def:tabstractrecorddef;rt:trttitype);
         procedure write_rtti_extrasyms(def:Tdef;rt:Trttitype;mainrtti:Tasmsymbol);
         procedure published_write_rtti(st:tsymtable;rt:trttitype);
         function  published_properties_count(st:tsymtable):longint;
@@ -137,12 +137,13 @@ implementation
       end;
 
     { writes a 32-bit count followed by array of field infos for given symtable }
-    procedure TRTTIWriter.fields_write_rtti_data(st:tsymtable;rt:trttitype);
+    procedure TRTTIWriter.fields_write_rtti_data(def:tabstractrecorddef;rt:trttitype);
       var
         i   : longint;
         sym : tsym;
         fieldcnt: longint;
         lastai: TLinkedListItem;
+        st: tsymtable;
       begin
         fieldcnt:=0;
         { Count will be inserted at this location. It cannot be nil as we've just
@@ -151,6 +152,17 @@ implementation
         if lastai=nil then
           InternalError(201012212);
 
+        { For objects, treat parent (if any) as a field with offset 0. This
+          provides correct handling of entire instance with RTL rtti routines. }
+        if (def.typ=objectdef) and (tobjectdef(def).objecttype=odt_object) and
+            Assigned(tobjectdef(def).childof) and
+            tobjectdef(def).childof.needs_inittable then
+          begin
+            current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(tobjectdef(def).childof,rt)));
+            current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(0));
+            inc(fieldcnt);
+          end;
+        st:=def.symtable;
         for i:=0 to st.SymList.Count-1 do
           begin
             sym:=tsym(st.SymList[i]);
@@ -604,7 +616,7 @@ implementation
            write_header(def,tkRecord);
            maybe_write_align;
            current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.size));
-           fields_write_rtti_data(def.symtable,rt);
+           fields_write_rtti_data(def,rt);
         end;
 
 
@@ -737,7 +749,7 @@ implementation
           procedure objectdef_rtti_fields(def:tobjectdef);
           begin
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(def.size));
-            fields_write_rtti_data(def.symtable,rt);
+            fields_write_rtti_data(def,rt);
           end;
 
           procedure objectdef_rtti_interface_init(def:tobjectdef);

compiler/psub.pas

@@ -434,9 +434,16 @@ implementation
                 else
                   if is_object(current_structdef) then
                     begin
-                      { finalize object data }
+                      { finalize object data, but only if not in inherited call }
                       if is_managed_type(current_objectdef) then
-                        addstatement(newstatement,finalize_data_node(load_self_node));
+                        begin
+                          addstatement(newstatement,cifnode.create(
+                            caddnode.create(unequaln,
+                              ctypeconvnode.create_internal(load_vmt_pointer_node,voidpointertype),
+                              cnilnode.create),
+                            finalize_data_node(load_self_node),
+                            nil));
+                        end;
                       { parameter 3 : vmt_offset }
                       { parameter 2 : pointer to vmt }
                       { parameter 1 : self pointer }

tests/test/tobject8.pp

@@ -0,0 +1,72 @@
+{ %OPT=-gh }
+// Validate that objects with parent are finalized when statically allocated
+type
+  pobj = ^tobj;
+  tobj = object
+  public
+    foo: ansistring;
+    constructor init(const s: ansistring);
+    procedure test; virtual;
+    destructor done; virtual;
+  end;
+
+  pobj1 = ^tobj1;
+  tobj1 = object(tobj)
+    bar: ansistring;
+    constructor init(const s1,s2: ansistring);
+    procedure test; virtual;
+    destructor done; virtual;
+  end;
+
+constructor tobj.init(const s: ansistring);
+begin
+  foo:=s;
+end;
+
+destructor tobj.done;
+begin
+end;
+
+constructor tobj1.init(const s1,s2: ansistring);
+begin
+  inherited init(s1);
+  bar:=s2;
+end;
+
+destructor tobj1.done;
+begin
+  inherited done;
+end;
+
+procedure tobj.test;
+begin
+end;
+
+procedure tobj1.test;
+begin
+end;
+
+var
+  s1, s2, s3, s4: ansistring;
+  obj: tobj1;
+
+procedure local;
+var
+  instance: tobj1;
+begin
+  instance.init(s3,s4);
+  
+end;
+
+begin
+  s1 := 'string1';
+  s2 := 'string2';
+  s3 := 'string3';
+  s4 := 'string4';
+  UniqueString(s1);  // make it actually allocate memory for strings
+  UniqueString(s2);
+  UniqueString(s3);
+  UniqueString(s4);
+  local;
+  obj.init(s1,s2);
+end.