* Ported hcgdata to new symtable.

  * Alignment code changed as suggested by Peter
  + Usage of my is operator replacement, is_object

compiler/new/cgbase.pas

@@ -60,7 +60,9 @@ unit cgbase;
           { current class, if we are in a method }
           _class : pobjectdef;
           { return type }
-       {$IFNDEF NEWST}
+       {$IFDEF NEWST}
+          retdef:Pdef;
+       {$ELSE}
           returntype : ttype;
        {$ENDIF NEWST}
           { symbol of the function, and the sym for result variable }
@@ -523,7 +525,12 @@ unit cgbase;
 end.
 {
   $Log$
-  Revision 1.18  2000-02-28 17:23:58  daniel
+  Revision 1.19  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.18  2000/02/28 17:23:58  daniel
   * Current work of symtable integration committed. The symtable can be
     activated by defining 'newst', but doesn't compile yet. Changes in type
     checking and oop are completed. What is left is to write a new

compiler/new/cgobj.pas

@@ -26,7 +26,11 @@ unit cgobj;
   interface
 
     uses
-       cobjects,aasm,symtable,symconst,cpuasm,cpubase,cgbase,cpuinfo,tainst;
+       cobjects,aasm,symtable,cpuasm,cpubase,cgbase,cpuinfo,tainst
+       {$IFDEF NEWST}
+       {$ELSE}
+       ,symconst
+       {$ENDIF NEWST};
 
     type
        talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);
@@ -181,7 +185,10 @@ unit cgobj;
 
     uses
        strings,globals,globtype,options,files,gdb,systems,
-       ppu,verbose,types,tgobj,tgcpu;
+       ppu,verbose,types,tgobj,tgcpu
+       {$IFDEF NEWST}
+       ,symbols,defs,symtablt
+       {$ENDIF NEWST};
 
 {*****************************************************************************
                             basic functionallity
@@ -442,6 +449,27 @@ unit cgobj;
          hr : treference;
 
       begin
+      {$IFDEF NEWST}
+         if (typeof(p^)=typeof(Tvarsym)) and
+            assigned(pvarsym(p)^.definition) and
+            not((typeof((pvarsym(p)^.definition^))=typeof(Tobjectdef)) and
+              (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and
+            pvarsym(p)^.definition^.needs_inittable then
+           begin
+              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+              reset_reference(hr);
+              if typeof((psym(p)^.owner^))=typeof(Tprocsymtable) then
+                begin
+                   hr.base:=procinfo^.framepointer;
+                   hr.offset:=-pvarsym(p)^.address;
+                end
+              else
+                begin
+                   hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
+                end;
+              g_initialize(list,pvarsym(p)^.definition,hr,false);
+           end;
+      {$ELSE}
          if (psym(p)^.typ=varsym) and
             assigned(pvarsym(p)^.vartype.def) and
             not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
@@ -461,6 +489,7 @@ unit cgobj;
                 end;
               g_initialize(list,pvarsym(p)^.vartype.def,hr,false);
            end;
+      {$ENDIF NEWST}
       end;
 
 
@@ -471,6 +500,25 @@ unit cgobj;
          hr : treference;
 
       begin
+      {$IFDEF NEWST}
+         if (typeof((psym(p)^))=typeof(Tparamsym)) and
+            not((typeof((Pparamsym(p)^.definition^))=typeof(Tobjectdef)) and
+              (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and
+            Pparamsym(p)^.definition^.needs_inittable and
+            ((Pparamsym(p)^.varspez=vs_value)) then
+           begin
+              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+              reset_reference(hr);
+              hr.symbol:=pvarsym(p)^.definition^.get_inittable_label;
+              a_param_ref_addr(list,hr,2);
+              reset_reference(hr);
+              hr.base:=procinfo^.framepointer;
+              hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
+              a_param_ref_addr(list,hr,1);
+              reset_reference(hr);
+              a_call_name(list,'FPC_ADDREF',0);
+           end;
+      {$ELSE}
          if (psym(p)^.typ=varsym) and
             not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
               pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
@@ -488,6 +536,7 @@ unit cgobj;
               reset_reference(hr);
               a_call_name(list,'FPC_ADDREF',0);
            end;
+      {$ENDIF NEWST}
       end;
 
 
@@ -498,6 +547,36 @@ unit cgobj;
          hr : treference;
 
       begin
+      {$IFDEF NEWST}
+         if (typeof((psym(p)^))=typeof(Tvarsym)) and
+            assigned(pvarsym(p)^.definition) and
+            not((typeof((pvarsym(p)^.definition^))=typeof(Tobjectdef)) and
+            (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and
+            pvarsym(p)^.definition^.needs_inittable then
+           begin
+              { not all kind of parameters need to be finalized  }
+              if (typeof((psym(p)^.owner^))=typeof(Tprocsymtable)) and
+                ((pparamsym(p)^.varspez=vs_var)  or
+                 (Pparamsym(p)^.varspez=vs_const) { and
+                 (dont_copy_const_param(pvarsym(p)^.definition)) } ) then
+                exit;
+              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+              reset_reference(hr);
+              if typeof((Psym(p)^.owner^))=typeof(Tprocsymtable) then
+                 begin
+                    hr.base:=procinfo^.framepointer;
+                    hr.offset:=-pvarsym(p)^.address;
+                 end
+              else if typeof((Psym(p)^.owner^))=typeof(Tprocsymtable) then
+                 begin
+                    hr.base:=procinfo^.framepointer;
+                    hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
+                 end
+               else
+                 hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
+              g_finalize(list,pvarsym(p)^.definition,hr,false);
+           end;
+      {$ELSE}
          if (psym(p)^.typ=varsym) and
             assigned(pvarsym(p)^.vartype.def) and
             not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
@@ -528,6 +607,7 @@ unit cgobj;
               end;
               g_finalize(list,pvarsym(p)^.vartype.def,hr,false);
            end;
+      {$ENDIF NEWST}
       end;
 
 
@@ -543,11 +623,13 @@ unit cgobj;
     { wrappers for the methods, because TP doesn't know procedures }
     { of objects                                                   }
 
+    {$IFNDEF NEWST}
     procedure _copyvalueparas(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
 
       begin
          cg^.g_copyvalueparas(_list,s);
       end;
+    {$ENDIF NEWST}
 
     procedure tcg.g_finalizetempansistrings(list : paasmoutput);
 
@@ -572,6 +654,24 @@ unit cgobj;
            end;
      end;
 
+ {$IFDEF NEWST}
+    procedure _initialize_local(s:Pnamedindexobject);{$IFNDEF FPC}far;{$ENDIF}
+
+    begin
+        if typeof(s^)=typeof(Tparamsym) then
+            cg^.g_incr_data(_list,Psym(s))
+        else
+            cg^.g_initialize_data(_list,Psym(s));
+    end;
+
+    procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
+
+    begin
+        if typeof(s^)=typeof(Tvarsym) then
+            cg^.g_finalize_data(_list,s);
+    end;
+
+ {$ELSE}
     procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif}
 
       begin
@@ -589,12 +689,22 @@ unit cgobj;
       begin
          cg^.g_initialize_data(_list,psym(s));
       end;
+ {$ENDIF NEWST}
 
     { generates the entry code for a procedure }
     procedure tcg.g_entrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean;
        stackframe:longint;var parasize:longint;var nostackframe:boolean;
        inlined : boolean);
 
+
+    {$IFDEF NEWST}
+        procedure _copyvalueparas(s:Pparamsym);{$ifndef FPC}far;{$endif}
+
+        begin
+            cg^.g_copyvalueparas(_list,s);
+        end;
+    {$ENDIF NEWST}
+
       var
          hs : string;
          hp : pused_unit;
@@ -617,7 +727,11 @@ unit cgobj;
                   list^.insert(new(pai_align,init(4)));
           end;
          { save registers on cdecl }
+         {$IFDEF NEWST}
+         if (posavestdregs in aktprocdef^.options) then
+         {$ELSE}
          if (po_savestdregs in aktprocsym^.definition^.procoptions) then
+         {$ENDIF NEWST}
            begin
               for r:=firstreg to lastreg do
                 begin
@@ -639,21 +753,39 @@ unit cgobj;
             begin
                CGMessage(cg_d_stackframe_omited);
                nostackframe:=true;
-               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+            {$IFDEF NEWST}
+               if (aktprocdef^.proctype in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+                 parasize:=0
+               else
+                 parasize:=aktprocdef^.localst^.paramdatasize+procinfo^.para_offset-pointersize;
+            {$ELSE}
+               if (aktproc^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
                  parasize:=0
                else
                  parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize;
+            {$ENDIF NEWST}
             end
           else
             begin
-               if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+            {$IFDEF NEWST}
+               if (aktprocdef^.proctype in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
+                 parasize:=0
+               else
+                 parasize:=aktprocdef^.localst^.paramdatasize+procinfo^.para_offset-pointersize*2;
+            {$ELSE}
+               if (aktprocdef^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then
                  parasize:=0
                else
                  parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize*2;
+            {$ENDIF}
                nostackframe:=false;
-
-               if (po_interrupt in aktprocsym^.definition^.procoptions) then
+            {$IFDEF NEWST}
+               if (pointerrupt in aktprocdef^.options) then
+                 g_interrupt_stackframe_entry(list);
+            {$ELSE}
+               if (po_interrupt in aktprocdef^.procoptions) then
                  g_interrupt_stackframe_entry(list);
+            {$ENDIF NEWST}
 
                g_stackframe_entry(list,stackframe);
 
@@ -664,7 +796,11 @@ unit cgobj;
 
          if cs_profile in aktmoduleswitches then
            g_profilecode(@initcode);
+         {$IFDEF NEWST}
+          if (not inlined) and (aktprocdef^.proctype in [potype_unitinit]) then
+         {$ELSE}
           if (not inlined) and (aktprocsym^.definition^.proctypeoption in [potype_unitinit]) then
+         {$ENDIF NEWST}
             begin
 
               { needs the target a console flags ? }
@@ -715,6 +851,18 @@ unit cgobj;
            list^.insert(new(pai_force_line,init));
   {$endif GDB}
 
+        {$IFDEF NEWST}
+         { initialize return value }
+         if assigned(procinfo^.retdef) and
+           is_ansistring(procinfo^.retdef) or
+           is_widestring(procinfo^.retdef) then
+           begin
+              reset_reference(hr);
+              hr.offset:=procinfo^.return_offset;
+              hr.base:=procinfo^.framepointer;
+              a_load_const_ref(list,OS_32,0,hr);
+           end;
+        {$ELSE}
          { initialize return value }
          if assigned(procinfo^.returntype.def) and
            is_ansistring(procinfo^.returntype.def) or
@@ -725,21 +873,42 @@ unit cgobj;
               hr.base:=procinfo^.framepointer;
               a_load_const_ref(list,OS_32,0,hr);
            end;
+        {$ENDIF}
 
          _list:=list;
          { generate copies of call by value parameters }
+        {$IFDEF NEWST}
+         if (poassembler in aktprocdef^.options) then
+            aktprocdef^.parameters^.foreach(@_copyvalueparas);
+        {$ELSE}
          if (po_assembler in aktprocsym^.definition^.procoptions) then
             aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_copyvalueparas);
+        {$ENDIF NEWST}
 
+        {$IFDEF NEWST}
+         { initialisizes local data }
+         aktprocdef^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_local);
+        {$ELSE}
          { initialisizes local data }
          aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_data);
          { add a reference to all call by value/const parameters }
          aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_incr_data);
+        {$ENDIF NEWST}
 
+        {$IFDEF NEWST}
+         if (cs_profile in aktmoduleswitches) or
+           (typeof(aktprocdef^.owner^)=typeof(Tglobalsymtable)) or
+           (typeof(aktprocdef^.owner^)=typeof(Timplsymtable)) or
+           (assigned(procinfo^._class) and
+           (typeof(procinfo^._class^.owner^)=typeof(Tglobalsymtable)) or
+           (typeof(procinfo^._class^.owner^)=typeof(Timplsymtable))) then
+           make_global:=true;
+        {$ELSE}
          if (cs_profile in aktmoduleswitches) or
            (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
            (assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then
            make_global:=true;
+        {$ENDIF NEWST}
          if not inlined then
            begin
               hs:=proc_names.get;
@@ -798,9 +967,17 @@ unit cgobj;
            list^.insert(new(pai_label,init(aktexitlabel)));
 
          { call the destructor help procedure }
+         {$IFDEF NEWST}
+         if (aktprocdef^.proctype=potype_destructor) then
+         {$ELSE}
          if (aktprocsym^.definition^.proctypeoption=potype_destructor) then
+         {$ENDIF}
            begin
+           {$IFDEF NEWST}
+             if oo_is_class in procinfo^._class^.options then
+           {$ELSE NEWST}
              if procinfo^._class^.is_class then
+           {$ENDIF}
                a_call_name(list,'FPC_DISPOSE_CLASS',0)
              else
                begin
@@ -835,11 +1012,17 @@ unit cgobj;
          _list:=list;
 
          { finalize local data }
+         {$IFDEF NEWST}
+         aktprocdef^.localst^.foreach({$ifndef TP}@{$endif}_finalize_data);
+         {$ELSE}
          aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}_finalize_data);
+         {$ENDIF}
 
+         {$IFNDEF NEWST}
          { finalize paras data }
-         if assigned(aktprocsym^.definition^.parast) then
+         if assigned(aktprocdef^.parast) then
            aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}_finalize_data);
+         {$ENDIF NEWST}
 
          { do we need to handle exceptions because of ansi/widestrings ? }
          if (procinfo^.flags and pi_needs_implicit_finally)<>0 then
@@ -852,6 +1035,19 @@ unit cgobj;
               a_cmp_reg_const_label(list,OS_32,OC_EQ,0,accumulator,noreraiselabel);
               a_reg_dealloc(list,accumulator);
 
+           {$IFDEF NEWST}
+              { must be the return value finalized before reraising the exception? }
+              if (procinfo^.retdef<>pdef(voiddef)) and
+                (procinfo^.retdef^.needs_inittable) and
+                ((typeof(procinfo^.retdef^)<>typeof(Tobjectdef)) or
+                not(oo_is_class in pobjectdef(procinfo^.retdef)^.options)) then
+                begin
+                   reset_reference(hr);
+                   hr.offset:=procinfo^.return_offset;
+                   hr.base:=procinfo^.framepointer;
+                   g_finalize(list,procinfo^.retdef,hr,not (dp_ret_in_acc in procinfo^.retdef^.properties));
+                end;
+           {$ELSE}
               { must be the return value finalized before reraising the exception? }
               if (procinfo^.returntype.def<>pdef(voiddef)) and
                 (procinfo^.returntype.def^.needs_inittable) and
@@ -863,18 +1059,29 @@ unit cgobj;
                    hr.base:=procinfo^.framepointer;
                    g_finalize(list,procinfo^.returntype.def,hr,ret_in_param(procinfo^.returntype.def));
                 end;
+           {$ENDIF}
 
               a_call_name(list,'FPC_RERAISE',0);
               a_label(list,noreraiselabel);
            end;
 
          { call __EXIT for main program }
+      {$IFDEF NEWST}
+         if (not DLLsource) and (not inlined) and (aktprocdef^.proctype=potype_proginit) then
+           a_call_name(list,'FPC_DO_EXIT',0);
+      {$ELSE}
          if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then
            a_call_name(list,'FPC_DO_EXIT',0);
+      {$ENDIF NEWST}
 
          { handle return value }
+      {$IFDEF NEWST}
+         if not(poassembler in aktprocdef^.options) then
+             if (aktprocdef^.proctype<>potype_constructor) then
+      {$ELSE}
          if not(po_assembler in aktprocsym^.definition^.procoptions) then
              if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then
+      {$ENDIF NEWST}
                { handle_return_value(inlined) }
              else
                begin
@@ -918,11 +1125,19 @@ unit cgobj;
          { at last, the return is generated }
 
          if not inlined then
+         {$IFDEF NEWST}
+           if pointerrupt in aktprocdef^.options then
+         {$ELSE}
            if po_interrupt in aktprocsym^.definition^.procoptions then
+         {$ENDIF NEWST}
              g_interrupt_stackframe_exit(list)
          else
            g_return_from_proc(list,parasize);
+    {$IFDEF NEWST}
+         list^.concat(new(pai_symbol_end,initname(aktprocdef^.mangledname)));
+    {$ELSE NEWST}
          list^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname)));
+    {$ENDIF NEWST}
 
     {$ifdef GDB}
          if (cs_debuginfo in aktmoduleswitches) and not inlined  then
@@ -1114,7 +1329,12 @@ unit cgobj;
 end.
 {
   $Log$
-  Revision 1.35  2000-03-01 15:36:13  florian
+  Revision 1.36  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.35  2000/03/01 15:36:13  florian
     * some new stuff for the new cg
 
   Revision 1.34  2000/02/20 20:49:46  florian

compiler/new/symtable/cobjects.pas

@@ -33,12 +33,14 @@ unit cobjects;
 interface
 
 uses    strings,objects
+{$IFDEF TP}
+        ,xobjects
+{$ENDIF}
 {$ifndef linux}
-       ,dos
+        ,dos
 {$else}
-       ,linux
-{$endif}
-      ;
+        ,linux
+{$endif};
 
     const
        { the real size will be [-hasharray..hasharray] ! }
@@ -75,6 +77,9 @@ type   pfileposinfo = ^tfileposinfo;
        plinkedlist_item = ^tlinkedlist_item;
        tlinkedlist_item = object(Tobject)
           next,previous : plinkedlist_item;
+       {$IFDEF TP}
+          constructor init;
+       {$ENDIF TP}
           function getcopy:plinkedlist_item;virtual;
        end;
 
@@ -90,6 +95,9 @@ type   pfileposinfo = ^tfileposinfo;
        plinkedlist = ^tlinkedlist;
        tlinkedlist = object(Tobject)
           first,last : plinkedlist_item;
+       {$IFDEF TP}
+          constructor init;
+       {$ENDIF TP}
           destructor done;virtual;
 
           { disposes the items of the list }
@@ -122,6 +130,9 @@ type   pfileposinfo = ^tfileposinfo;
        PStringQueue=^TStringQueue;
        TStringQueue=object(Tobject)
          first,last : PStringItem;
+       {$IFDEF TP}
+         constructor init;
+       {$ENDIF TP}
          destructor Done;virtual;
          function Empty:boolean;
          function Get:string;
@@ -189,7 +200,6 @@ type   pfileposinfo = ^tfileposinfo;
          procedure usehash;
          procedure clear;
          function  empty:boolean;
-         function contains(obj:Pnamedindexobject):boolean;
          procedure foreach(proc2call:Tnamedindexcallback);
          function  insert(obj:Pnamedindexobject):Pnamedindexobject;
          function  rename(const olds,news : string):Pnamedindexobject;
@@ -535,6 +545,14 @@ end;
                                   TStringQueue
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tstringqueue.init;
+
+begin
+    setparent(typeof(Tobject));
+end;
+{$ENDIF TP}
+
 function TStringQueue.Empty:boolean;
 begin
   Empty:=(first=nil);
@@ -652,6 +670,7 @@ end;
     constructor tstringcontainer.init;
       begin
          inherited init;
+         {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
          doubles:=true;
       end;
 
@@ -659,6 +678,7 @@ end;
     constructor tstringcontainer.init_no_double;
       begin
          doubles:=false;
+         {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
       end;
 
 
@@ -799,6 +819,14 @@ end;
  ****************************************************************************}
 
 
+    {$IFDEF TP}
+    constructor Tlinkedlist_item.init;
+
+    begin
+        setparent(typeof(Tobject));
+    end;
+    {$ENDIF TP}
+
     function tlinkedlist_item.getcopy:plinkedlist_item;
       var
         l : longint;
@@ -818,6 +846,7 @@ end;
     constructor tstring_item.init(const s : string);
       begin
          inherited init;
+         {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
          str:=stringdup(s);
       end;
 
@@ -834,6 +863,14 @@ end;
  ****************************************************************************}
 
 
+    {$IFDEF TP}
+    constructor Tlinkedlist.init;
+
+    begin
+        setparent(typeof(Tobject));
+    end;
+    {$ENDIF TP}
+
     destructor tlinkedlist.done;
       begin
          clear;
@@ -1006,6 +1043,7 @@ end;
 constructor Tnamedindexobject.init(const n:string);
 begin
   inherited init;
+  {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
   { index }
   indexnr:=-1;
   { dictionary }
@@ -1034,6 +1072,7 @@ end;
     constructor Tdictionary.init;
       begin
         inherited init;
+        {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
         replace_existing:=false;
       end;
 
@@ -1450,6 +1489,7 @@ end;
     constructor tdynamicarray.init(Aelemlen,Agrow:longint);
       begin
         inherited init;
+        {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
         elemlen:=Aelemlen;
         growcount:=Agrow;
         grow;
@@ -1609,6 +1649,7 @@ end;
 
       begin
          inherited init;
+         {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
          assign(f,filename);
          bufsize:=_bufsize;
          clear_crc;
@@ -1930,7 +1971,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.2  2000-03-01 11:43:55  daniel
+  Revision 1.3  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.2  2000/03/01 11:43:55  daniel
   * Some more work on the new symtable.
   + Symtable stack unit 'symstack' added.
 

compiler/new/symtable/defs.pas

@@ -29,7 +29,8 @@ unit defs;
 
 interface
 
-uses    symtable,objects,cobjects,symtablt,globtype
+uses    symtable,objects,{$IFDEF TP}xobjects,{$ENDIF}
+        cobjects,symtablt,globtype
 {$ifdef i386}
         ,cpubase
 {$endif}
@@ -47,7 +48,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
         Tobjprop=(sp_public,sp_private,sp_protected,sp_published,sp_static);
         Tobjpropset=set of Tobjprop;
 
-        Tobjoption=(oo_is_abstract,         {The object/class has
+        Tobjoption=(oo_has_abstract,         {The object/class has
                                              an abstract method => no
                                              instances can be created.}
                     oo_is_class,            {The object is a class.}
@@ -64,6 +65,7 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
                                              constructor.}
                     oo_has_destructor,      {The object/class has a
                                              destructor.}
+
                     oo_has_vmt,             {The object/class has a vmt.}
                     oo_has_msgstr,
                     oo_has_msgint,
@@ -173,6 +175,9 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
 
         Perrordef=^Terrordef;
         Terrordef=object(Tdef)
+{$IFDEF TP}
+            constructor init(Aowner:Pcontainingsymtable);
+{$ENDIF}
 {$ifdef GDB}
             function stabstring:Pchar;virtual;
 {$endif GDB}
@@ -204,6 +209,9 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
 
         Pclassrefdef=^Tclassrefdef;
         Tclassrefdef=object(Tpointerdef)
+{$IFDEF TP}
+            constructor init(Aowner:Pcontainingsymtable;def:Pdef);
+{$ENDIF TP}
 {$ifdef GDB}
             function stabstring : pchar;virtual;
             procedure concatstabto(asmlist : paasmoutput);virtual;
@@ -465,29 +473,48 @@ type    Targconvtyp=(act_convertable,act_equal,act_exact);
             function para_size:longint;
             procedure store(var s:Tstream);virtual;
             procedure test_if_fpu_result;
- {$ifdef GDB}
+{$ifdef GDB}
             function stabstring : pchar;virtual;
             procedure concatstabto(asmlist : paasmoutput);virtual;
- {$endif GDB}
+{$endif GDB}
         end;
 
         Pprocvardef=^Tprocvardef;
         Tprocvardef=object(Tabstractprocdef)
+{$IFDEF TP}
+            constructor init(Aowner:Pcontainingsymtable);
+{$ENDIF TP}
             function size:longint;virtual;
- {$ifdef GDB}
+{$ifdef GDB}
             function stabstring:Pchar;virtual;
             procedure concatstabto(asmlist:Paasmoutput); virtual;
- {$endif GDB}
+{$endif GDB}
             procedure write_child_rtti_data;virtual;
             function is_publishable:boolean;virtual;
             procedure write_rtti_data;virtual;
             function gettypename:string;virtual;
         end;
 
+        {This datastructure is used to store the message information
+         when a procedure is declared as:
+          ;message 'str';
+          ;message int;
+          ;virtual int;
+        }
+        Tmessageinf=record
+            case integer of
+                0:(str:Pchar);
+                1:(i:longint);
+        end;
+
+        {This object can be splitted into a Tprocdef, for normal procedures,
+         a Tmethoddef for methods, and a Tinlinedprocdef and a
+         Tinlinedmethoddef for inlined procedures.}
         Pprocdef = ^Tprocdef;
         Tprocdef = object(tabstractprocdef)
            objprop:Tobjpropset;
            extnumber:longint;
+           messageinf:Tmessageinf;
            { where is this function defined, needed here because there
              is only one symbol for all overloaded functions }
            fileinfo:Tfileposinfo;
@@ -579,7 +606,7 @@ var     cformaldef:Pformaldef;      {Unique formal definition.}
 
 implementation
 
-uses    systems,symbols,verbose,globals,aasm,files;
+uses    systems,symbols,verbose,globals,aasm,files,strings;
 
 const   {If you change one of the following contants,
          you have also to change the typinfo unit
@@ -628,6 +655,7 @@ constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     filetype:=ft;
     definition:=tas;
     setsize;
@@ -700,6 +728,7 @@ constructor Tformaldef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     savesize:=target_os.size_of_pointer;
 end;
 
@@ -729,6 +758,15 @@ end;
                                   Terrordef
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Terrordef.init(Aowner:Pcontainingsymtable);
+
+begin
+    inherited init(Aowner);
+    setparent(typeof(Tdef));
+end;
+{$ENDIF TP}
+
 function Terrordef.gettypename:string;
 
 begin
@@ -743,6 +781,7 @@ constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     include(properties,dp_ret_in_acc);
     definition:=def;
     savesize:=target_os.size_of_pointer;
@@ -782,6 +821,7 @@ constructor Tpointerdef.initfar(Aowner:Pcontainingsymtable;def:Pdef);
 
 begin
    inherited init(Aowner,def);
+    {$IFDEF TP}setparent(typeof(Tabstractpointerdef));{$ENDIF}
    is_far:=true;
 end;
 
@@ -809,6 +849,15 @@ end;
                               Tclassrefdef
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tclassrefdef.init(Aowner:Pcontainingsymtable;def:Pdef);
+
+begin
+    inherited init(Aowner,def);
+    setparent(typeof(Tpointerdef));
+end;
+{$ENDIF TP}
+
 function Tclassrefdef.gettypename:string;
 
 begin
@@ -824,6 +873,7 @@ constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     new(publicsyms,init);
     publicsyms^.name:=stringdup(n);
     publicsyms^.defowner:=@self;
@@ -1301,6 +1351,7 @@ constructor Tarraydef.init(const l,h:Tconstant;rd:Pdef;
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     lowrange:=l;
     highrange:=h;
     rangedef:=rd;
@@ -1487,6 +1538,7 @@ constructor Tenumdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     include(properties,dp_ret_in_acc);
     new(symbols,init(8,8));
     calcsavesize;
@@ -1663,6 +1715,7 @@ constructor Torddef.init(t:Tbasetype;l,h:Tconstant;
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     include(properties,dp_ret_in_acc);
     low:=l;
     high:=h;
@@ -1805,6 +1858,7 @@ constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     if t=f32bit then
         include(properties,dp_ret_in_acc);
     typ:=t;
@@ -1891,6 +1945,7 @@ constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     definition:=s;
     if high<32 then
         begin
@@ -1987,6 +2042,7 @@ constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     symtable:=s;
     savesize:=symtable^.datasize;
 end;
@@ -2185,6 +2241,7 @@ constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     string_typ:=st_shortstring;
     len:=l;
     savesize:=len+1;
@@ -2413,6 +2470,7 @@ constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
     include(properties,dp_ret_in_acc);
     retdef:=voiddef;
     savesize:=target_os.size_of_pointer;
@@ -2525,6 +2583,7 @@ constructor Tprocdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tabstractprocdef));{$ENDIF}
     fileinfo:=aktfilepos;
     extnumber:=-1;
     new(localst,init);
@@ -2677,6 +2736,8 @@ end;
 destructor Tprocdef.done;
 
 begin
+    if pomsgstr in options then
+        strdispose(messageinf.str);
     if references<>nil then
         dispose(references,done);
     if (localst<>nil) and (typeof(localst^)<>typeof(Timplsymtable)) then
@@ -2785,11 +2846,18 @@ begin
         end;
 end;
 
-
 {***************************************************************************
                                  Tprocvardef
 ***************************************************************************}
 
+{$IFDEF TP}
+constructor Tprocvardef.init(Aowner:Pcontainingsymtable);
+
+begin
+    setparent(typeof(Tabstractprocdef));
+end;
+{$ENDIF TP}
+
 
 function Tprocvardef.size:longint;
 
@@ -2893,6 +2961,7 @@ begin
 {   oldregisterdef:=registerdef;
     registerdef:=false;}
     inherited init(Aowner);
+    {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
 {   registerdef:=oldregisterdef;}
     tosymname:=s;
     forwardpos:=pos;
@@ -2909,7 +2978,12 @@ end.
 
 {
   $Log$
-  Revision 1.4  2000-03-01 11:43:55  daniel
+  Revision 1.5  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.4  2000/03/01 11:43:55  daniel
   * Some more work on the new symtable.
   + Symtable stack unit 'symstack' added.
 

compiler/new/symtable/hcgdata.pas

@@ -0,0 +1,651 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Daniel Mantione,
+     and other members of the Free Pascal development team
+
+    Routines for the code generation of data structures
+    like VMT,Messages
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit hcgdata;
+interface
+
+    uses
+       symtable,aasm,defs;
+
+    { generates the message tables for a class }
+    function genstrmsgtab(_class : pobjectdef) : pasmlabel;
+    function genintmsgtab(_class : pobjectdef) : pasmlabel;
+    { generates the method name table }
+    function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel;
+
+    { generates a VMT for _class }
+    procedure genvmt(list : paasmoutput;_class : pobjectdef);
+
+{$ifdef WITHDMT}
+    { generates a DMT for _class }
+    function gendmt(_class : pobjectdef) : pasmlabel;
+{$endif WITHDMT}
+
+implementation
+
+    uses
+       strings,cobjects,globtype,globals,verbose,
+       types,hcodegen,symbols,objects,xobjects;
+
+
+{*****************************************************************************
+                                Message
+*****************************************************************************}
+
+    type
+       pprocdeftree = ^tprocdeftree;
+       tprocdeftree = record
+          p   : pprocdef;
+          nl  : pasmlabel;
+          l,r : pprocdeftree;
+       end;
+
+    var
+       root : pprocdeftree;
+       count : longint;
+
+    procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
+
+      var
+         i : longint;
+
+      begin
+         if at=nil then
+           begin
+              at:=p;
+              inc(count);
+           end
+         else
+           begin
+              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
+              if i<0 then
+                insertstr(p,at^.l)
+              else if i>0 then
+                insertstr(p,at^.r)
+              else
+                Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
+           end;
+      end;
+
+    procedure disposeprocdeftree(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           disposeprocdeftree(p^.l);
+         if assigned(p^.r) then
+           disposeprocdeftree(p^.r);
+         dispose(p);
+      end;
+
+    procedure insertmsgstr(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
+
+        procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF}
+
+        var pt:Pprocdeftree;
+
+        begin
+            if pomsgstr in Pprocdef(p)^.options then
+                begin
+                    new(pt);
+                    pt^.p:=p;
+                    pt^.l:=nil;
+                    pt^.r:=nil;
+                    insertstr(pt,root);
+                end;
+        end;
+
+    begin
+        if typeof(p^)=typeof(Tprocsym) then
+            Pprocsym(p)^.foreach(@inserter);
+    end;
+
+    procedure insertint(p : pprocdeftree;var at : pprocdeftree);
+
+      begin
+         if at=nil then
+           begin
+              at:=p;
+              inc(count);
+           end
+         else
+           begin
+              if p^.p^.messageinf.i<at^.p^.messageinf.i then
+                insertint(p,at^.l)
+              else if p^.p^.messageinf.i>at^.p^.messageinf.i then
+                insertint(p,at^.r)
+              else
+                Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
+           end;
+      end;
+
+    procedure insertmsgint(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
+
+        procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF}
+
+        var pt:Pprocdeftree;
+
+        begin
+            if pomsgint in Pprocdef(p)^.options then
+                begin
+                    new(pt);
+                    pt^.p:=p;
+                    pt^.l:=nil;
+                    pt^.r:=nil;
+                    insertint(pt,root);
+                end;
+        end;
+
+    begin
+        if typeof(p^)=typeof(Tprocsym) then
+            Pprocsym(p)^.foreach(@inserter);
+    end;
+
+    procedure writenames(p : pprocdeftree);
+
+      begin
+         getdatalabel(p^.nl);
+         if assigned(p^.l) then
+           writenames(p^.l);
+         datasegment^.concat(new(pai_label,init(p^.nl)));
+         datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
+         datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
+         if assigned(p^.r) then
+           writenames(p^.r);
+      end;
+
+    procedure writestrentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writestrentry(p^.l);
+
+         { write name label }
+         datasegment^.concat(new(pai_const_symbol,init(p^.nl)));
+         datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
+
+         if assigned(p^.r) then
+           writestrentry(p^.r);
+      end;
+
+    function genstrmsgtab(_class : pobjectdef) : pasmlabel;
+
+
+      var
+         r : pasmlabel;
+
+      begin
+         root:=nil;
+         count:=0;
+         if _class^.privatesyms<>nil then
+            _class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
+         if _class^.privatesyms<>nil then
+            _class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
+         if _class^.privatesyms<>nil then
+            _class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
+
+         { write all names }
+         if assigned(root) then
+           writenames(root);
+
+         { now start writing of the message string table }
+         getdatalabel(r);
+         datasegment^.concat(new(pai_label,init(r)));
+         genstrmsgtab:=r;
+         datasegment^.concat(new(pai_const,init_32bit(count)));
+         if assigned(root) then
+           begin
+              writestrentry(root);
+              disposeprocdeftree(root);
+           end;
+      end;
+
+
+    procedure writeintentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writeintentry(p^.l);
+
+         { write name label }
+         datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
+         datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
+
+         if assigned(p^.r) then
+           writeintentry(p^.r);
+      end;
+
+    function genintmsgtab(_class : pobjectdef) : pasmlabel;
+
+      var
+         r : pasmlabel;
+
+      begin
+         root:=nil;
+         count:=0;
+         if _class^.privatesyms<>nil then
+            _class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
+         if _class^.privatesyms<>nil then
+            _class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
+         if _class^.privatesyms<>nil then
+            _class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
+
+         { now start writing of the message string table }
+         getdatalabel(r);
+         datasegment^.concat(new(pai_label,init(r)));
+         genintmsgtab:=r;
+         datasegment^.concat(new(pai_const,init_32bit(count)));
+         if assigned(root) then
+           begin
+              writeintentry(root);
+              disposeprocdeftree(root);
+           end;
+      end;
+
+{$ifdef WITHDMT}
+
+    procedure insertdmtentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
+
+      var
+         hp : pprocdef;
+         pt : pprocdeftree;
+
+      begin
+         if psym(p)^.typ=procsym then
+           begin
+              hp:=pprocsym(p)^.definition;
+              while assigned(hp) do
+                begin
+                   if (po_msgint in hp^.procoptions) then
+                     begin
+                        new(pt);
+                        pt^.p:=hp;
+                        pt^.l:=nil;
+                        pt^.r:=nil;
+                        insertint(pt,root);
+                     end;
+                   hp:=hp^.nextoverloaded;
+                end;
+           end;
+      end;
+
+    procedure writedmtindexentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writedmtindexentry(p^.l);
+         datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
+         if assigned(p^.r) then
+           writedmtindexentry(p^.r);
+      end;
+
+    procedure writedmtaddressentry(p : pprocdeftree);
+
+      begin
+         if assigned(p^.l) then
+           writedmtaddressentry(p^.l);
+         datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
+         if assigned(p^.r) then
+           writedmtaddressentry(p^.r);
+      end;
+
+    function gendmt(_class : pobjectdef) : pasmlabel;
+
+      var
+         r : pasmlabel;
+
+      begin
+         root:=nil;
+         count:=0;
+         gendmt:=nil;
+         { insert all message handlers into a tree, sorted by number }
+         _class^.symtable^.foreach({$ifndef TP}@{$endif}insertdmtentry);
+
+         if count>0 then
+           begin
+              getdatalabel(r);
+              gendmt:=r;
+              datasegment^.concat(new(pai_label,init(r)));
+              { entries for caching }
+              datasegment^.concat(new(pai_const,init_32bit(0)));
+              datasegment^.concat(new(pai_const,init_32bit(0)));
+
+              datasegment^.concat(new(pai_const,init_32bit(count)));
+              if assigned(root) then
+                begin
+                   writedmtindexentry(root);
+                   writedmtaddressentry(root);
+                   disposeprocdeftree(root);
+                end;
+           end;
+      end;
+
+{$endif WITHDMT}
+
+    procedure genpubmethodtableentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
+
+        procedure do_concat(q:pointer);{$ifndef FPC}far;{$endif}
+
+        var l:Pasmlabel;
+
+        begin
+            if (sp_published in Pprocdef(q)^.objprop) then
+                begin
+                   getlabel(l);
+
+                   consts^.concat(new(pai_label,init(l)));
+                   consts^.concat(new(pai_const,init_8bit(length(p^.name))));
+                   consts^.concat(new(pai_string,init(p^.name)));
+
+                   datasegment^.concat(new(pai_const_symbol,init(l)));
+                   datasegment^.concat(new(pai_const_symbol,initname(Pprocdef(q)^.mangledname)));
+                end;
+        end;
+
+    begin
+        if p^.is_object(typeof(Tprocsym)) then
+            Pprocsym(p)^.foreach(@do_concat);
+    end;
+
+    procedure sym_do_count(p:Pnamedindexobject);{$ifndef FPC}far;{$endif}
+
+        procedure def_do_count(p:pointer);{$ifndef FPC}far;{$endif}
+
+        begin
+            if (sp_published in Pprocdef(p)^.objprop) then
+             inc(count);
+        end;
+
+    begin
+        if Pobject(p)^.is_object(typeof(Tprocsym)) then
+            Pprocsym(p)^.foreach(@def_do_count);
+    end;
+
+    function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel;
+
+    var l:Pasmlabel;
+
+    begin
+        count:=0;
+        if Aclass^.privatesyms<>nil then
+            Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
+        if Aclass^.protectedsyms<>nil then
+            Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
+        if Aclass^.publicsyms<>nil then
+            Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
+        if count>0 then
+            begin
+                getlabel(l);
+                datasegment^.concat(new(pai_label,init(l)));
+                datasegment^.concat(new(pai_const,init_32bit(count)));
+                if Aclass^.privatesyms<>nil then
+                    Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
+                if Aclass^.protectedsyms<>nil then
+                    Aclass^.protectedsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
+                if Aclass^.publicsyms<>nil then
+                    Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
+                genpublishedmethodstable:=l;
+            end
+        else
+            genpublishedmethodstable:=nil;
+    end;
+
+{*****************************************************************************
+                                    VMT
+*****************************************************************************}
+
+var wurzel:Pcollection;
+    nextvirtnumber : longint;
+    _c : pobjectdef;
+    has_constructor,has_virtual_method : boolean;
+
+procedure eachsym(sym:Pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
+
+var symcoll:Pcollection;
+    _name:string;
+    stored:boolean;
+
+    {Creates a new entry in the procsym list.}
+    procedure newentry;
+
+        procedure numbervirtual(p:pointer);{$IFDEF TP}far;{$ENDIF TP}
+
+        begin
+            { if it's a virtual method }
+            if (povirtualmethod in Pprocdef(p)^.options) then
+                begin
+                    {Then it gets a number ...}
+                    Pprocdef(p)^.extnumber:=nextvirtnumber;
+                    {And we inc the number }
+                    inc(nextvirtnumber);
+                    has_virtual_method:=true;
+                end;
+
+            if (Pprocdef(p)^.proctype=potype_constructor) then
+                has_constructor:=true;
+
+            { check, if a method should be overridden }
+            if (pooverridingmethod in Pprocdef(p)^.options) then
+                messagepos1(Pprocdef(p)^.fileinfo,parser_e_nothing_to_be_overridden,
+                 _c^.objname^+'.'+_name+Pprocdef(p)^.demangled_paras);
+        end;
+
+    begin
+        symcoll^.insert(sym);
+        Pprocsym(sym)^.foreach(@numbervirtual);
+    end;
+
+    function match(p:pointer):boolean;{$IFDEF TP}far;{$ENDIF}
+
+    begin
+        {Does the symbol already exist in the list ?}
+        match:=_name=Psym(p)^.name;
+    end;
+
+    procedure eachdef(p:pointer);{$IFDEF TP}far;{$ENDIF}
+
+        function check_override(q:pointer):boolean;{$IFDEF TP}far;{$ENDIF}
+
+        begin
+            check_override:=false;
+            {Check if the parameters are equal and if one of the methods
+             is virtual.}
+            if equal_paras(Pprocdef(p)^.parameters,
+             Pprocdef(q)^.parameters,false) and
+             ((povirtualmethod in Pprocdef(p)^.options) or
+              (povirtualmethod in Pprocdef(q)^.options)) then
+                begin
+                    {Wenn sie gleich sind
+                     und eine davon virtual deklariert ist
+                     Fehler falls nur eine VIRTUAL }
+                    if (povirtualmethod in Pprocdef(p)^.options)<>
+                     (povirtualmethod in Pprocdef(q)^.options) then
+                        begin
+                            { in classes, we hide the old method }
+                            if oo_is_class in _c^.options then
+                                begin
+                                    {Warn only if it is the first time,
+                                     we hide the method.}
+                                    if _c=Pprocsym(Pprocdef(p)^.sym)^._class then
+                                        message1(parser_w_should_use_override,_c^.objname^+'.'+_name);
+                                    newentry;
+                                    check_override:=true;
+                                    exit;
+                                end
+                            else
+                                if _c=Pprocsym(Pprocdef(p)^.sym)^._class then
+                                    begin
+                                        if (povirtualmethod in Pprocdef(q)^.options) then
+                                            message1(parser_w_overloaded_are_not_both_virtual,_c^.objname^+'.'+_name)
+                                        else
+                                            message1(parser_w_overloaded_are_not_both_non_virtual,
+                                             _c^.objname^+'.'+_name);
+                                        newentry;
+                                        check_override:=true;
+                                        exit;
+                                    end;
+                        end
+                    else
+                        {The flags have to match except abstract
+                         and override, but only if both are virtual!!}
+                        if (Pprocdef(q)^.calloptions<>Pprocdef(p)^.calloptions) or
+                         (Pprocdef(q)^.proctype<>Pprocdef(p)^.proctype) or
+                         ((Pprocdef(q)^.options-[poabstractmethod,pooverridingmethod,poassembler])<>
+                         (Pprocdef(p)^.options-[poabstractmethod,pooverridingmethod,poassembler])) then
+                            message1(parser_e_header_dont_match_forward,_c^.objname^+'.'+_name);
+
+                    {Check, if the override directive is set
+                     (povirtualmethod is set!}
+
+                    {Class ?}
+                    if (oo_is_class in _c^.options) and
+                     not(pooverridingmethod in Pprocdef(p)^.options) then
+                        begin
+                            {Warn only if it is the first time,
+                             we hide the method.}
+                            if _c=Pprocsym(Pprocdef(p)^.sym)^._class then
+                                message1(parser_w_should_use_override,_c^.objname^+'.'+_name);
+                            newentry;
+                            check_override:=true;
+                            exit;
+                        end;
+
+                    { error, if the return types aren't equal }
+                    if not(is_equal(Pprocdef(q)^.retdef,Pprocdef(p)^.retdef)) and
+                     not(Pprocdef(q)^.retdef^.is_object(typeof(Tobjectdef)) and
+                      Pprocdef(p)^.retdef^.is_object(typeof(Tobjectdef)) and
+                      (oo_is_class in Pobjectdef(Pprocdef(q)^.retdef)^.options) and
+                      (oo_is_class in Pobjectdef(Pprocdef(p)^.retdef)^.options) and
+                      (pobjectdef(Pprocdef(p)^.retdef)^.is_related(
+                       pobjectdef(Pprocdef(q)^.retdef)))) then
+                        message1(parser_e_overloaded_methodes_not_same_ret,_c^.objname^+'.'+_name);
+
+
+                    {now set the number }
+                    Pprocdef(p)^.extnumber:=Pprocdef(q)^.extnumber;
+                end;  { same parameters }
+        end;
+
+    begin
+        if Pprocsym(sym)^.firstthat(@check_override)=nil then
+            newentry;
+    end;
+
+
+begin
+    {Put only subroutines into the VMT.}
+    if sym^.is_object(typeof(Tprocsym)) then
+        begin
+            symcoll:=wurzel;
+            Pprocsym(symcoll^.firstthat(@match))^.foreach(@eachdef);
+            newentry;
+        end;
+end;
+
+procedure genvmt(list:Paasmoutput;_class:Pobjectdef);
+
+var symcoll:Pcollection;
+    i:longint;
+
+    procedure do_genvmt(p:Pobjectdef);
+
+    begin
+        {Start with the base class.}
+        if assigned(p^.childof) then
+            do_genvmt(p^.childof);
+
+        { walk through all public syms }
+        { I had to change that to solve bug0260 (PM)}
+        _c:=p;
+        { Florian, please check if you agree (PM) }
+        p^.privatesyms^.foreach({$ifndef TP}@{$endif}eachsym);
+        p^.protectedsyms^.foreach({$ifndef TP}@{$endif}eachsym);
+        p^.publicsyms^.foreach({$ifndef TP}@{$endif}eachsym);
+    end;
+
+ procedure symwritevmt(p:pointer);{$IFDEF TP}far;{$ENDIF}
+
+     procedure defwritevmt(q:pointer);{$IFDEF TP}far;{$ENDIF}
+
+     begin
+         { writes the addresses to the VMT }
+         { but only this which are declared as virtual }
+         if (Pprocdef(q)^.extnumber=i) and
+          (povirtualmethod in Pprocdef(q)^.options) then
+             begin
+                 { if a method is abstract, then is also the }
+                 { class abstract and it's not allow to      }
+                 { generates an instance                     }
+                 if (poabstractmethod in Pprocdef(q)^.options) then
+                     begin
+                         include(_class^.options,oo_has_abstract);
+                         list^.concat(new(pai_const_symbol,initname('FPC_ABSTRACTERROR')));
+                     end
+                 else
+                     begin
+                         list^.concat(new(pai_const_symbol,
+                          initname(Pprocdef(q)^.mangledname)));
+                     end;
+             end;
+     end;
+
+ begin
+     Pprocsym(p)^.foreach(@defwritevmt);
+ end;
+
+begin
+    new(wurzel,init(64,16));
+    nextvirtnumber:=0;
+
+    has_constructor:=false;
+    has_virtual_method:=false;
+
+    { generates a tree of all used methods }
+    do_genvmt(_class);
+
+    if has_virtual_method and not(has_constructor) then
+        message1(parser_w_virtual_without_constructor,_class^.objname^);
+
+
+    { generates the VMT }
+
+    { walk trough all numbers for virtual methods and search }
+    { the method                                             }
+    for i:=0 to nextvirtnumber-1 do
+        begin
+            symcoll:=wurzel;
+            symcoll^.foreach(@symwritevmt);
+        end;
+    dispose(symcoll,done);
+end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-03-11 21:11:25  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+}

compiler/new/symtable/htypechk.pas

@@ -122,7 +122,7 @@ implementation
        { tp7 procvar def support, in tp7 a procvar is always called, if the
          procvar is passed explicit a addrn would be there }
          if (m_tp_procvar in aktmodeswitches) and
-            (typeof(def_from^)=typeof(Tprocvardef)) and
+            (def_from^.is_object(typeof(Tprocvardef))) and
             (fromtreetype=loadn) then
           begin
             def_from:=pprocvardef(def_from)^.retdef;
@@ -131,9 +131,9 @@ implementation
        { we walk the wanted (def_to) types and check then the def_from
          types if there is a conversion possible }
          b:=0;
-         if typeof(def_to^)=typeof(Torddef) then
+         if def_to^.is_object(typeof(Torddef)) then
             begin
-              if typeof(def_from^)=typeof(Torddef) then
+              if def_from^.is_object(typeof(Torddef)) then
                  begin
                    doconv:=basedefconverts[basedeftbl[Tbasetype(porddef(def_from)^.typ)],basedeftbl[porddef(def_to)^.typ]];
                    b:=1;
@@ -146,7 +146,7 @@ implementation
                        (not is_boolean(def_to))) then
                      b:=0;
                  end
-              else if typeof(def_from^)=typeof(Torddef) then
+              else if def_from^.is_object(typeof(Tenumdef)) then
                  begin
                    { needed for char(enum) }
                    if explicit then
@@ -156,14 +156,14 @@ implementation
                     end;
                  end;
             end
-         else if typeof(def_to^)=typeof(Tstringdef) then
+         else if def_to^.is_object(typeof(Tstringdef)) then
              begin
-               if typeof(def_from^)=typeof(Tstringdef) then
+               if def_from^.is_object(typeof(Tstringdef)) then
                    begin
                      doconv:=tc_string_2_string;
                      b:=1;
                    end
-               else if typeof(def_from^)=typeof(Torddef) then
+               else if def_from^.is_object(typeof(Torddef)) then
                    begin
                    { char to string}
                      if is_char(def_from) then
@@ -172,7 +172,7 @@ implementation
                         b:=1;
                       end;
                    end
-               else if typeof(def_from^)=typeof(Tarraydef) then
+               else if def_from^.is_object(typeof(Tarraydef)) then
                    begin
                    { array of char to string, the length check is done by the firstpass of this node }
                      if is_chararray(def_from) then
@@ -187,7 +187,7 @@ implementation
                          b:=2;
                       end;
                    end
-               else if typeof(def_from^)=typeof(Tpointerdef) then
+               else if def_from^.is_object(typeof(Tpointerdef)) then
                    begin
                    { pchar can be assigned to short/ansistrings }
                      if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
@@ -197,9 +197,9 @@ implementation
                       end;
                    end;
              end
-         else if typeof(def_to^)=typeof(Tfloatdef) then
+         else if def_to^.is_object(typeof(Tfloatdef)) then
              begin
-               if typeof(def_from^)=typeof(Torddef) then
+               if def_from^.is_object(typeof(Torddef)) then
                    begin { ordinal to real }
                      if is_integer(def_from) then
                        begin
@@ -210,7 +210,7 @@ implementation
                           b:=1;
                        end;
                    end
-               else if typeof(def_from^)=typeof(Tfloatdef) then
+               else if def_from^.is_object(typeof(Tfloatdef)) then
                    begin { 2 float types ? }
                      if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
                        doconv:=tc_equal
@@ -227,9 +227,9 @@ implementation
                      b:=1;
                    end;
              end
-         else if typeof(def_to^)=typeof(Tenumdef) then
+         else if def_to^.is_object(typeof(Tenumdef)) then
              begin
-               if typeof(def_from^)=typeof(Tenumdef) then
+               if def_from^.is_object(typeof(Tenumdef)) then
                 begin
                   if assigned(penumdef(def_from)^.basedef) then
                    hd1:=penumdef(def_from)^.basedef
@@ -243,7 +243,7 @@ implementation
                    b:=1;
                 end;
              end
-         else if typeof(def_to^)=typeof(Tarraydef) then
+         else if def_to^.is_object(typeof(Tarraydef)) then
              begin
              { open array is also compatible with a single element of its base type }
                if is_open_array(def_to) and
@@ -254,7 +254,7 @@ implementation
                 end
                else
                 begin
-                  if typeof(def_from^)=typeof(Tarraydef) then
+                  if def_from^.is_object(typeof(Tarraydef)) then
                       begin
                         { array constructor -> open array }
                         if is_open_array(def_to) and
@@ -275,7 +275,7 @@ implementation
                              end;
                          end;
                       end
-                  else if typeof(def_from^)=typeof(Tpointerdef) then
+                  else if def_from^.is_object(typeof(Tpointerdef)) then
                       begin
                         if is_zero_based_array(def_to) and
                            is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
@@ -284,7 +284,7 @@ implementation
                            b:=1;
                          end;
                       end
-                  else if typeof(def_from^)=typeof(Tstringdef) then
+                  else if def_from^.is_object(typeof(Tstringdef)) then
                       begin
                         { string to array of char}
                         if (not(is_special_array(def_to)) or is_open_array(def_to)) and
@@ -296,9 +296,9 @@ implementation
                       end;
                 end;
              end
-         else if typeof(def_to^)=typeof(Tpointerdef) then
+         else if def_to^.is_object(typeof(Tpointerdef)) then
              begin
-               if typeof(def_from^)=typeof(Tstringdef) then
+               if def_from^.is_object(typeof(Tstringdef)) then
                    begin
                      { string constant to zero terminated string constant }
                      if (fromtreetype=stringconstn) and
@@ -308,7 +308,7 @@ implementation
                         b:=1;
                       end;
                    end
-               else if typeof(def_from^)=typeof(Torddef) then
+               else if def_from^.is_object(typeof(Torddef)) then
                    begin
                      { char constant to zero terminated string constant }
                      if (fromtreetype=ordconstn) then
@@ -327,7 +327,7 @@ implementation
                           end;
                       end;
                    end
-               else if typeof(def_from^)=typeof(Tarraydef) then
+               else if def_from^.is_object(typeof(Tarraydef)) then
                    begin
                      { chararray to pointer }
                      if is_zero_based_array(def_from) and
@@ -337,13 +337,12 @@ implementation
                         b:=1;
                       end;
                    end
-               else if typeof(def_from^)=typeof(Tpointerdef) then
+               else if def_from^.is_object(typeof(Tpointerdef)) then
                    begin
                      { child class pointer can be assigned to anchestor pointers }
                      if (
-                            {Bug in TP: typeof(( )) required when typecasting.}
-                         (typeof((Ppointerdef(def_from)^.definition^))=typeof(Tobjectdef)) and
-                         (typeof((Ppointerdef(def_to)^.definition^))=typeof(Tobjectdef)) and
+                         (Ppointerdef(def_from)^.definition^.is_object(typeof(Tobjectdef))) and
+                         (Ppointerdef(def_to)^.definition^.is_object(typeof(Tobjectdef))) and
                          pobjectdef(ppointerdef(def_from)^.definition)^.is_related(
                            pobjectdef(ppointerdef(def_to)^.definition))
                         ) or
@@ -357,7 +356,7 @@ implementation
                          b:=1;
                        end;
                    end
-               else if typeof(def_from^)=typeof(Tprocvardef) then
+               else if def_from^.is_object(typeof(Tprocvardef)) then
                    begin
                      { procedure variable can be assigned to an void pointer }
                      { Not anymore. Use the @ operator now.}
@@ -369,17 +368,17 @@ implementation
                         b:=1;
                       end;
                    end
-               else if (typeof(def_from^)=typeof(Tclassrefdef)) or
-                (typeof(def_from^)=typeof(Tobjectdef)) then
+               else if def_from^.is_object(typeof(Tclassrefdef)) or
+                def_from^.is_object(typeof(Tobjectdef)) then
                    begin
                      { class types and class reference type
                        can be assigned to void pointers      }
                      if (
-                         ((typeof(def_from^)=typeof(Tobjectdef)) and
-                         (oo_is_class in pobjectdef(def_from)^.options)) or
-                         (typeof(def_from^)=typeof(Tclassrefdef))
+                         (def_from^.is_object(typeof(Tobjectdef)) and
+                         (oo_is_class in pobjectdef(def_from)^.options))) or
+                         (def_from^.is_object(typeof(Tclassrefdef))
                         ) and
-                        (typeof((ppointerdef(def_to)^.definition^))=typeof(Torddef)) and
+                         ppointerdef(def_to)^.definition^.is_object(typeof(Torddef)) and
                         (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
                        begin
                          doconv:=tc_equal;
@@ -387,7 +386,7 @@ implementation
                        end;
                    end;
              end
-         else if typeof(def_to^)=typeof(Tsetdef) then
+         else if def_to^.is_object(typeof(Tsetdef)) then
              begin
                { automatic arrayconstructor -> set conversion }
                if is_array_constructor(def_from) then
@@ -396,10 +395,10 @@ implementation
                   b:=1;
                 end;
              end
-         else if typeof(def_to^)=typeof(Tprocvardef) then
+         else if def_to^.is_object(typeof(Tprocvardef)) then
              begin
                { proc -> procvar }
-               if (typeof(def_from^)=typeof(Tprocdef)) then
+               if def_from^.is_object(typeof(Tprocdef)) then
                 begin
                   doconv:=tc_proc_2_procvar;
                   if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
@@ -409,8 +408,8 @@ implementation
                 { for example delphi allows the assignement from pointers }
                 { to procedure variables                                  }
                 if (m_pointer_2_procedure in aktmodeswitches) and
-                  (typeof(def_from^)=typeof(Tpointerdef)) and
-                  (typeof((ppointerdef(def_from)^.definition^))=typeof(Torddef)) and
+                  def_from^.is_object(typeof(Tpointerdef)) and
+                  ppointerdef(def_from)^.definition^.is_object(typeof(Torddef)) and
                   (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then
                 begin
                    doconv:=tc_equal;
@@ -424,10 +423,10 @@ implementation
                    b:=1;
                  end;
              end
-         else if typeof(def_to^)=typeof(Tobjectdef) then
+         else if def_to^.is_object(typeof(Tobjectdef)) then
              begin
                { object pascal objects }
-               if typeof(def_from^)=typeof(Tobjectdef) then
+               if def_from^.is_object(typeof(Tobjectdef)) then
                 begin
                   doconv:=tc_equal;
                   if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then
@@ -453,10 +452,10 @@ implementation
                      end;
                  end;
              end
-         else if typeof(def_to^)=typeof(Tclassrefdef) then
+         else if def_to^.is_object(typeof(Tclassrefdef)) then
              begin
                { class reference types }
-               if typeof(def_from^)=typeof(Tclassrefdef) then
+               if def_from^.is_object(typeof(Tclassrefdef)) then
                 begin
                   doconv:=tc_equal;
                   if pobjectdef(pclassrefdef(def_from)^.definition)^.is_related(
@@ -471,7 +470,7 @@ implementation
                    b:=1;
                  end;
              end
-         else if typeof(def_to^)=typeof(Tfiledef) then
+         else if def_to^.is_object(typeof(Tfiledef)) then
              begin
                { typed files are all equal to the abstract file type
                name TYPEDFILE in system.pp in is_equal in types.pas
@@ -886,7 +885,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.1  2000-02-28 17:23:58  daniel
+  Revision 1.2  2000-03-11 21:11:25  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.1  2000/02/28 17:23:58  daniel
   * Current work of symtable integration committed. The symtable can be
     activated by defining 'newst', but doesn't compile yet. Changes in type
     checking and oop are completed. What is left is to write a new

compiler/new/symtable/symbols.pas

@@ -90,6 +90,7 @@ type    Ttypeprop=(sp_primary_typesym);
             _class:Pobjectdef;
             constructor init(const n:string;Asub_of:Pprocsym);
             constructor load(var s:Tstream);
+            function count:word;
             function firstthat(action:pointer):Pprocdef;
             procedure foreach(action:pointer);
             procedure insert(def:Pdef);
@@ -244,7 +245,7 @@ type    Ttypeprop=(sp_primary_typesym);
 
         Pfuncretsym=^Tfuncretsym;
         Tfuncretsym=object(tsym)
-            funcretprocinfo : pointer{ should be pprocinfo};
+            funcretprocinfo:pointer{Pprocinfo};
             funcretdef:Pdef;
             address:longint;
             constructor init(const n:string;approcinfo:pointer{pprocinfo});
@@ -307,6 +308,7 @@ constructor Tlabelsym.init(const n:string;l:Pasmlabel);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     lab:=l;
     defined:=false;
 end;
@@ -339,6 +341,7 @@ constructor terrorsym.init;
 
 begin
     inherited init('');
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
 end;
 {****************************************************************************
                                   Tprocsym
@@ -348,6 +351,7 @@ constructor Tprocsym.init(const n:string;Asub_of:Pprocsym);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     sub_of:=Asub_of;
 end;
 
@@ -358,6 +362,15 @@ begin
 {   definition:=Pprocdef(readdefref);}
 end;
 
+function Tprocsym.count:word;
+
+begin
+    if typeof(definitions^)=typeof(Tcollection) then
+        count:=Pcollection(definitions)^.count
+    else
+        count:=1;
+end;
+
 function Tprocsym.firstthat(action:pointer):Pprocdef;
 
 begin
@@ -522,6 +535,7 @@ constructor Ttypesym.init(const n:string;d:Pdef);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     definition:=d;
     if assigned(definition) then
         begin
@@ -679,6 +693,7 @@ constructor Tsyssym.init(const n:string;l:longint);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     number:=l;
 end;
 
@@ -704,6 +719,7 @@ constructor Tenumsym.init(const n:string;def:Penumdef;v:longint);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     definition:=def;
     value:=v;
     if def^.minval>v then
@@ -796,6 +812,7 @@ constructor Tvarsym.init(const n:string;p:Pdef);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     definition:=p;
     {Can we load the value into a register ? }
     if dp_regable in p^.properties then
@@ -937,6 +954,7 @@ constructor Tparamsym.init(const n:string;p:Pdef;vs:Tvarspez);
 
 begin
     inherited init(n,p);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     varspez:=vs;
 end;
 
@@ -1004,6 +1022,7 @@ constructor Ttypedconstsym.init(const n:string;p:Pdef;really_const:boolean);
 
 begin
    inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
    definition:=p;
    is_really_const:=really_const;
    prefix:=stringdup(procprefix);
@@ -1085,6 +1104,7 @@ constructor Tconstsym.init(const n : string;t : tconsttype;v : longint);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     consttype:=t;
     value:=v;
 end;
@@ -1301,6 +1321,7 @@ constructor Tfuncretsym.init(const n:string;approcinfo:pointer{pprocinfo});
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF}
     funcretprocinfo:=approcinfo;
 {   funcretdef:=Pprocinfo(approcinfo)^.retdef;}
     { address valid for ret in param only }
@@ -1352,6 +1373,10 @@ begin
         end;}
 end;
 
+{****************************************************************************
+                                Tpropertysym
+****************************************************************************}
+
 constructor tpropertysym.load(var s:Tstream);
 
 begin
@@ -1448,7 +1473,12 @@ end.
 
 {
   $Log$
-  Revision 1.4  2000-03-01 11:43:56  daniel
+  Revision 1.5  2000-03-11 21:11:25  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.4  2000/03/01 11:43:56  daniel
   * Some more work on the new symtable.
   + Symtable stack unit 'symstack' added.
 

compiler/new/symtable/symtable.pas

@@ -27,7 +27,8 @@ unit symtable;
 
 interface
 
-uses    objects,cobjects,aasm,globtype,cpubase;
+uses    objects{$IFDEF TP},xobjects{$ENDIF}
+        ,cobjects,aasm,globtype,cpubase;
 
 
 type    Tdefprop=(dp_regable,           {Can be stored into a register.}
@@ -49,6 +50,9 @@ type    Tdefprop=(dp_regable,           {Can be stored into a register.}
         Tsymtable=object(Tobject)
             name:Pstring;
             datasize:longint;
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
             procedure foreach(proc2call:Tnamedindexcallback);virtual;
             function insert(sym:Psym):boolean;virtual;
             function search(const s:stringid):Psym;
@@ -93,6 +97,9 @@ type    Tdefprop=(dp_regable,           {Can be stored into a register.}
 
         Tsymtableentry=object(Tnamedindexobject)
             owner:Pcontainingsymtable;
+        {$IFDEF TP}
+            constructor init(const n:string);
+        {$ENDIF TP}
         end;
 
         Tsymprop=byte;
@@ -188,6 +195,13 @@ uses    symtablt,files,verbose,globals;
                                 Tsymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tsymtable.init;
+
+begin
+    setparent(typeof(Tobject));
+end;
+{$ENDIF TP}
 
 procedure Tsymtable.foreach(proc2call:Tnamedindexcallback);
 
@@ -242,6 +256,8 @@ constructor Tcontainingsymtable.init;
 var indexgrow:word;
 
 begin
+    inherited init;
+    {$IFDEF TP}setparent(typeof(Tsymtable));{$ENDIF}
     indexgrow:=index_growsize;
     new(defindex,init(2*indexgrow,indexgrow));
     new(symsearch,init);
@@ -350,6 +366,7 @@ constructor Tref.init(const pos:Tfileposinfo);
 
 begin
     inherited init;
+    {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
     posinfo:=pos;
     moduleindex:=current_module^.unit_index;
 end;
@@ -373,6 +390,19 @@ begin
          current_module^.sourcefiles^.get_file_name(fileindex),tostr(line));
 end;
 
+{****************************************************************************
+                                Tsymtableentry
+****************************************************************************}
+
+{$IFDEF TP}
+constructor Tsymtableentry.init(const n:string);
+
+begin
+    inherited init(n);
+    setparent(typeof(Tnamedindexobject));
+end;
+{$ENDIF TP}
+
 {****************************************************************************
                                     Tsym
 ****************************************************************************}
@@ -381,6 +411,7 @@ constructor Tsym.init(const n:string);
 
 begin
     inherited init(n);
+    {$IFDEF TP}setparent(typeof(Tsymtableentry));{$ENDIF}
     fileinfo:=tokenpos;
     if cs_browser in aktmoduleswitches then
         new(references,init(32,16));
@@ -454,6 +485,7 @@ constructor Tdef.init(Aowner:Pcontainingsymtable);
 
 begin
     inherited init;
+    {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
     Aowner^.registerdef(@self);
     owner:=Aowner;
 end;

compiler/new/symtable/symtablt.pas

@@ -50,24 +50,39 @@ type    Pglobalsymtable=^Tglobalsymtable;
 
         Tinterfacesymtable=object(Tglobalsymtable)
             unitid:word;
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
             function varsymprefix:string;virtual;
         end;
 
         Timplsymtable=object(Tglobalsymtable)
             unitid:word;
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
             function varsymprefix:string;virtual;
         end;
 
         Tabstractrecordsymtable=object(Tcontainingsymtable)
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
             function varsymtodata(sym:Psym;len:longint):longint;virtual;
         end;
 
         Precordsymtable=^Trecordsymtable;
         Trecordsymtable=object(Tabstractrecordsymtable)
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
         end;
 
         Tobjectsymtable=object(Tabstractrecordsymtable)
             defowner:Pobjectsymtable;
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
 {           function speedsearch(const s:stringid;
                                  speedvalue:longint):Psym;virtual;}
         end;
@@ -80,6 +95,9 @@ type    Pglobalsymtable=^Tglobalsymtable;
              possible to make another Tmethodsymtable and move this field
              to it, but I think the advantage is not worth it. (DM)}
             method:Pdef;
+        {$IFDEF TP}
+            constructor init;
+        {$ENDIF TP}
             function insert(sym:Psym):boolean;virtual;
             function speedsearch(const s:stringid;
                                  speedvalue:longint):Psym;virtual;
@@ -113,17 +131,6 @@ implementation
 
 uses    symbols,files,globals,aasm,systems,defs,verbose;
 
-function data_align(length:longint):longint;
-
-begin
-    if length>2 then
-        data_align:=4
-    else if length>1 then
-        data_align:=2
-    else
-        data_align:=1;
-end;
-
 {****************************************************************************
                               Tglobalsymtable
 ****************************************************************************}
@@ -132,6 +139,7 @@ constructor Tglobalsymtable.init;
 
 begin
     inherited init;
+    {$IFDEF TP}setparent(typeof(Tcontainingsymtable));{$ENDIF}
     index_growsize:=128;
 end;
 
@@ -152,8 +160,7 @@ begin
         segment:=datasegment;
     if (cs_create_smart in aktmoduleswitches) then
         segment^.concat(new(Pai_cut,init));
-    ali:=data_align(len);
-    align(datasize,ali);
+    align_from_size(datasize,len);
 {$ifdef GDB}
     if cs_debuginfo in aktmoduleswitches then
         concatstabto(segment);
@@ -168,8 +175,7 @@ var ali:longint;
 begin
     if (cs_create_smart in aktmoduleswitches) then
         bsssegment^.concat(new(Pai_cut,init));
-    ali:=data_align(len);
-    align(datasize,ali);
+    align_from_size(datasize,len);
 {$ifdef GDB}
     if cs_debuginfo in aktmoduleswitches then
         concatstabto(bsssegment);
@@ -185,6 +191,14 @@ end;
                                Timplsymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Timplsymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tglobalsymtable));
+end;
+{$ENDIF TP}
 
 function Timplsymtable.varsymprefix:string;
 
@@ -196,6 +210,15 @@ end;
                             Tinterfacesymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tinterfacesymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tglobalsymtable));
+end;
+{$ENDIF TP}
+
 function Tinterfacesymtable.varsymprefix:string;
 
 begin
@@ -206,6 +229,15 @@ end;
                         Tabstractrecordsymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tabstractrecordsymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tcontainingsymtable));
+end;
+{$ENDIF TP}
+
 function Tabstractrecordsymtable.varsymtodata(sym:Psym;
                                              len:longint):longint;
 
@@ -219,10 +251,28 @@ end;
                              Trecordsymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Trecordsymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tabstractrecordsymtable));
+end;
+{$ENDIF TP}
+
 {****************************************************************************
                              Tobjectsymtable
 ****************************************************************************}
 
+{$IFDEF TP}
+constructor Tobjectsymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tabstractrecordsymtable));
+end;
+{$ENDIF TP}
+
 {This is not going to work this way, because the definition isn't known yet
  when the symbol hasn't been found. For procsyms the object properties
  are stored in the definitions, because they can be overloaded.
@@ -247,6 +297,14 @@ end;}
 {****************************************************************************
                              Tprocsymsymtable
 ****************************************************************************}
+{$IFDEF TP}
+constructor Tprocsymtable.init;
+
+begin
+    inherited init;
+    setparent(typeof(Tcontainingsymtable));
+end;
+{$ENDIF TP}
 
 function Tprocsymtable.insert(sym:Psym):boolean;
 
@@ -279,17 +337,7 @@ begin
         begin
             {Sym must be a varsym.}
             {Align datastructures >=4 on a dword.}
-            if len>=4 then
-                align(len,4)
-            else
-{$ifdef m68k}
-                {Align datastructures with size 1,2,3 on a word.}
-                align(len,2);
-{$else}
-                {Align datastructures with size 2 or 3 on a word.}
-                if len>=2 then
-                    align(len,2);
-{$endif}
+            align_from_size(len,len);
             varsymtodata:=inherited varsymtodata(sym,len);
         end;
 end;
@@ -302,6 +350,7 @@ constructor Tunitsymtable.init(const n:string);
 
 begin
     inherited init;
+    {$IFDEF TP}setparent(typeof(Tcontainingsymtable));{$ENDIF}
     name:=stringdup(n);
     index_growsize:=128;
 end;
@@ -338,8 +387,7 @@ begin
         segment:=datasegment;
     if (cs_create_smart in aktmoduleswitches) then
         segment^.concat(new(Pai_cut,init));
-    ali:=data_align(len);
-    align(datasize,ali);
+    align_from_size(datasize,len);
 {$ifdef GDB}
     if cs_debuginfo in aktmoduleswitches then
         concatstabto(segment);
@@ -373,6 +421,7 @@ constructor Twithsymtable.init(Alink:Pcontainingsymtable);
 
 begin
     inherited init;
+    {$IFDEF TP}setparent(typeof(Tsymtable));{$ENDIF}
     link:=Alink;
 end;
 

compiler/new/symtable/xobjects.pas

@@ -0,0 +1,81 @@
+unit xobjects;
+{
+    $Id$
+    Copyright (c) 2000 by Daniel Mantione
+     member of the Free Pascal development team
+
+    This unit provides an extends the Tobject type with additional methods
+    to check the type of an object. It should only be used within
+    Turbo Pascal, the Free Pascal objects unit already contains this
+    functionality.
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+interface
+
+{As TP does not store a link to the parent's VMT in the VMT, a function like
+ is_object would be impossible.
+
+ We use a very dirty trick to get it done; in an objects constructor the
+ setparent procedure should be called, which stores the link to the parent
+ into the DMT link. (!!!)}
+
+uses    objects;
+
+type    Pobject=^Tobject;
+        Tobject=object(objects.Tobject)
+            function is_object(typ:pointer):boolean;
+            procedure setparent(typ:pointer);
+        end;
+
+implementation
+
+type    vmt=record
+            size,negsize:word;
+            dmtlink:pointer;
+        end;
+
+function Tobject.is_object(typ:pointer):boolean;assembler;
+
+asm
+    les di,self
+    mov bx,[es:di]  {Get vmt link.}
+    jmp @a3
+@a2:
+    mov bx,[bx+4]   {Get dmt link, offset.}
+    or bx,bx
+    mov al,0
+    jz @a1
+@a3:
+    cmp bx,typ.word {Compare with typ.}
+    jne @a2
+    mov al,1
+@a1:
+end;
+
+procedure Tobject.setparent(typ:pointer);assembler;
+
+asm
+    les di,self
+    mov bx,[es:di]  {Get vmt link.}
+    mov ax,typ.word
+    mov cx,typ+2.word
+    mov [bx+4],ax
+    mov [bx+6],cx
+end;
+
+end.

compiler/pbase.pas

@@ -29,6 +29,9 @@ unit pbase;
 {$ifdef fixLeaksOnError}
        ,comphook
 {$endif fixLeaksOnError}
+{$IFDEF NEWST}
+       ,symbols,defs
+{$ENDIF NEWST}
        ;
 
     const
@@ -194,7 +197,12 @@ end.
 
 {
   $Log$
-  Revision 1.30  2000-02-09 13:22:56  peter
+  Revision 1.31  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.30  2000/02/09 13:22:56  peter
     * log truncated
 
   Revision 1.29  2000/01/11 17:16:04  jonas

compiler/ptype.pas

@@ -24,7 +24,10 @@ unit ptype;
 interface
 
 uses
-  globtype,symtable;
+  globtype,symtable
+  {$IFDEF NEWST}
+  ,symbols,defs
+  {$ENDIF NEWST};
 
 
     const
@@ -45,10 +48,16 @@ uses
 
 
     { reads a string, file type or a type id and returns a name and }
-    { pdef                                                        }
+    { pdef }
+{$IFDEF NEWST}
+    procedure single_type(var tt:Tdef;var s : string;isforwarddef:boolean);
+
+    procedure read_type(var tt:Tdef;const name : stringid);
+{$ELSE}
     procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean);
 
     procedure read_type(var tt:ttype;const name : stringid);
+{$ENDIF NEWST}
 
 
 implementation
@@ -1539,7 +1548,12 @@ uses
 end.
 {
   $Log$
-  Revision 1.20  2000-02-24 18:41:39  peter
+  Revision 1.21  2000-03-11 21:11:24  daniel
+    * Ported hcgdata to new symtable.
+    * Alignment code changed as suggested by Peter
+    + Usage of my is operator replacement, is_object
+
+  Revision 1.20  2000/02/24 18:41:39  peter
     * removed warnings/notes
 
   Revision 1.19  2000/02/21 22:17:49  florian