+ fieldtable support for classes

compiler/ptype.pas

@@ -721,7 +721,8 @@ uses
          oldprocsym : pprocsym;
          oldparse_only : boolean;
          methodnametable,intmessagetable,
-         strmessagetable,classnamelabel : pasmlabel;
+         strmessagetable,classnamelabel,
+         fieldtablelabel : pasmlabel;
          storetypecanbeforward : boolean;
 
       procedure setclassattributes;
@@ -804,6 +805,7 @@ uses
            if is_a_class then
             begin
               methodnametable:=genpublishedmethodstable(aktclass);
+              fieldtablelabel:=aktclass^.generate_field_table;
               { rtti }
               if (oo_can_have_published in aktclass^.objectoptions) then
                aktclass^.generate_rtti;
@@ -872,7 +874,7 @@ uses
               else
                 datasegment^.concat(new(pai_const,init_32bit(0)));
               { pointer to field table }
-              datasegment^.concat(new(pai_const,init_32bit(0)));
+              datasegment^.concat(new(pai_const_symbol,init(fieldtablelabel)));
               { pointer to type info of published section }
               if (oo_can_have_published in aktclass^.objectoptions) then
                 datasegment^.concat(new(pai_const_symbol,initname(aktclass^.rtti_name)))
@@ -1592,7 +1594,10 @@ uses
 end.
 {
   $Log$
-  Revision 1.24  2000-03-27 21:51:19  pierre
+  Revision 1.25  2000-06-02 18:48:47  florian
+    + fieldtable support for classes
+
+  Revision 1.24  2000/03/27 21:51:19  pierre
    * fix for bug 739
 
   Revision 1.23  2000/03/19 14:56:38  florian

compiler/symdef.inc

@@ -3333,11 +3333,7 @@ Const local_symtable_index : longint = $8001;
                end;
              vmt_offset:=symtable^.datasize;
              inc(symtable^.datasize,target_os.size_of_pointer);
-{$ifdef INCLUDEOK}
              include(objectoptions,oo_has_vmt);
-{$else}
-             objectoptions:=objectoptions+[oo_has_vmt];
-{$endif}
           end;
      end;
 
@@ -3677,7 +3673,8 @@ Const local_symtable_index : longint = $8001;
     procedure count_published_properties(sym:pnamedindexobject);
       {$ifndef fpc}far;{$endif}
       begin
-         if needs_prop_entry(psym(sym)) then
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ<>varsym) then
            inc(count);
       end;
 
@@ -3734,6 +3731,7 @@ Const local_symtable_index : longint = $8001;
            case psym(sym)^.typ of
               varsym:
                 begin
+{$ifdef dummy}
                    if not(pvarsym(sym)^.vartype.def^.deftype=objectdef) or
                      not(pobjectdef(pvarsym(sym)^.vartype.def)^.is_class) then
                      internalerror(1509992);
@@ -3753,6 +3751,7 @@ Const local_symtable_index : longint = $8001;
                    rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
                    rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
                    rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
+{$endif dummy}
                 end;
               propertysym:
                 begin
@@ -3789,7 +3788,10 @@ Const local_symtable_index : longint = $8001;
          if needs_prop_entry(psym(sym)) then
            case psym(sym)^.typ of
               varsym:
+                ;
+                { now ignored:
                 pvarsym(sym)^.vartype.def^.get_rtti_label;
+                }
               propertysym:
                 ppropertysym(sym)^.proptype.def^.get_rtti_label;
               else
@@ -3818,6 +3820,112 @@ Const local_symtable_index : longint = $8001;
           end;
       end;
 
+    type
+       tclasslistitem = object(tlinkedlist_item)
+          index : longint;
+          p : pobjectdef;
+       end;
+       pclasslistitem = ^tclasslistitem;
+
+    var
+       classtablelist : tlinkedlist;
+       tablecount : longint;
+
+    function searchclasstablelist(p : pobjectdef) : pclasslistitem;
+
+      var
+         hp : pclasslistitem;
+
+      begin
+         hp:=pclasslistitem(classtablelist.first);
+         while assigned(hp) do
+           if hp^.p=p then
+             begin
+                searchclasstablelist:=hp;
+                exit;
+             end
+           else
+             hp:=pclasslistitem(hp^.next);
+         searchclasstablelist:=nil;
+      end;
+
+    procedure count_published_fields(sym:pnamedindexobject);
+      {$ifndef fpc}far;{$endif}
+
+      var
+         hp : pclasslistitem;
+
+      begin
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ=varsym) then
+          begin
+             if pvarsym(sym)^.vartype.def^.deftype<>objectdef then
+               internalerror(0206001);
+             hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
+             if not(assigned(hp)) then
+               begin
+                  hp:=new(pclasslistitem,init);
+                  hp^.p:=pobjectdef(pvarsym(sym)^.vartype.def);
+                  hp^.index:=tablecount;
+                  classtablelist.concat(hp);
+                  inc(tablecount);
+               end;
+             inc(count);
+          end;
+      end;
+
+    procedure writefields(sym:pnamedindexobject);
+      {$ifndef fpc}far;{$endif}
+
+      var
+         hp : pclasslistitem;
+
+      begin
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ=varsym) then
+          begin
+             rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+             hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
+             if not(assigned(hp)) then
+               internalerror(0206002);
+             rttilist^.concat(new(pai_const,init_32bit(hp^.index)));
+             rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
+             rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
+          end;
+      end;
+
+    function tobjectdef.generate_field_table : pasmlabel;
+
+      var
+         fieldtable,
+         classtable : pasmlabel;
+         hp : pclasslistitem;
+
+      begin
+         classtablelist.init;
+         getlabel(fieldtable);
+         getlabel(classtable);
+         count:=0;
+         tablecount:=0;
+         symtable^.foreach({$ifdef FPC}@{$endif}count_published_fields);
+         rttilist^.concat(new(pai_label,init(fieldtable)));
+         rttilist^.concat(new(pai_const,init_16bit(count)));
+         rttilist^.concat(new(pai_const_symbol,init(classtable)));
+         symtable^.foreach({$ifdef FPC}@{$endif}writefields);
+
+         { generate the class table }
+         rttilist^.concat(new(pai_label,init(classtable)));
+         rttilist^.concat(new(pai_const,init_16bit(tablecount)));
+         hp:=pclasslistitem(classtablelist.first);
+         while assigned(hp) do
+           begin
+              rttilist^.concat(new(pai_const_symbol,initname(pobjectdef(hp^.p)^.vmt_mangledname)));
+              hp:=pclasslistitem(hp^.next);
+           end;
+
+         generate_field_table:=fieldtable;
+         classtablelist.done;
+      end;
 
     function tobjectdef.next_free_name_index : longint;
       var
@@ -3901,7 +4009,6 @@ Const local_symtable_index : longint = $8001;
          get_rtti_label:=rtti_name;
       end;
 
-
 {****************************************************************************
                                 TFORWARDDEF
 ****************************************************************************}
@@ -3954,7 +4061,10 @@ Const local_symtable_index : longint = $8001;
 
 {
   $Log$
-  Revision 1.199  2000-04-01 14:17:08  peter
+  Revision 1.200  2000-06-02 18:48:47  florian
+    + fieldtable support for classes
+
+  Revision 1.199  2000/04/01 14:17:08  peter
     * arraydef.elesize returns 4 when strings are found in an openarray,
       arrayconstructor. Since only the pointers to the strings are stored
 

compiler/symdefh.inc

@@ -216,6 +216,7 @@
           procedure generate_rtti;virtual;
           procedure write_rtti_data;virtual;
           procedure write_child_rtti_data;virtual;
+          function generate_field_table : pasmlabel;
        end;
 
        pclassrefdef = ^tclassrefdef;
@@ -530,7 +531,10 @@
 
 {
   $Log$
-  Revision 1.53  2000-02-09 13:23:04  peter
+  Revision 1.54  2000-06-02 18:48:48  florian
+    + fieldtable support for classes
+
+  Revision 1.53  2000/02/09 13:23:04  peter
     * log truncated
 
   Revision 1.52  2000/02/04 20:00:22  florian
@@ -607,4 +611,4 @@
     * C alignment added for records
     * PPU version increased to solve .12 <-> .13 probs
 
-}
+}

compiler/symtable.pas

@@ -71,6 +71,7 @@ unit symtable;
        ptypesym = ^ttypesym;
        penumsym = ^tenumsym;
        pprocsym = ^tprocsym;
+       tcallback = procedure(p : psym);
 
        pref = ^tref;
        tref = object
@@ -162,8 +163,6 @@ unit symtable;
                           of a unit }
                         staticppusymtable);
 
-       tcallback = procedure(p : psym);
-
        tsearchhasharray = array[0..hasharraysize-1] of psym;
        psearchhasharray = ^tsearchhasharray;
 
@@ -2925,7 +2924,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.93  2000-06-01 19:07:52  peter
+  Revision 1.94  2000-06-02 18:48:48  florian
+    + fieldtable support for classes
+
+  Revision 1.93  2000/06/01 19:07:52  peter
     * delphi/tp mode fixes for dup id checking (tbs319,tbf320)
 
   Revision 1.92  2000/05/23 14:15:44  pierre