* virtual XXXX; support for objects, only if -dWITHDMT is defined

compiler/hcgdata.pas

@@ -36,6 +36,10 @@ interface
     { 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
 
@@ -257,6 +261,86 @@ implementation
            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 do_count(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
 
       begin
@@ -575,11 +659,7 @@ implementation
                                   { generates an instance                     }
                                   if (po_abstractmethod in procdefcoll^.data^.procoptions) then
                                     begin
-{$ifdef INCLUDEOK}
                                        include(_class^.objectoptions,oo_has_abstract);
-{$else}
-                                       _class^.objectoptions:=_class^.objectoptions+[oo_has_abstract];
-{$endif}
                                        list^.concat(new(pai_const_symbol,initname('FPC_ABSTRACTERROR')));
                                     end
                                   else
@@ -616,7 +696,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.23  2000-01-07 01:14:27  peter
+  Revision 1.24  2000-01-28 23:17:53  florian
+    * virtual XXXX; support for objects, only if -dWITHDMT is defined
+
+  Revision 1.23  2000/01/07 01:14:27  peter
     * updated copyright to 2000
 
   Revision 1.22  1999/12/02 19:22:16  peter
@@ -708,4 +791,4 @@ end.
   Revision 1.1  1999/03/24 23:17:00  peter
     * fixed bugs 212,222,225,227,229,231,233
 
-}
+}

compiler/psub.pas

@@ -579,10 +579,32 @@ begin
 end;
 
 procedure pd_virtual(const procnames:Tstringcontainer);
+{$ifdef WITHDMT}
+var
+  pt : ptree;
+{$endif WITHDMT}
 begin
   if (aktprocsym^.definition^.proctypeoption=potype_constructor) and
      not(aktprocsym^.definition^._class^.is_class) then
     Message(parser_e_constructor_cannot_be_not_virtual);
+{$ifdef WITHDMT}
+  if not(aktprocsym^.definition^._class^.is_class) and
+    (token<>_SEMICOLON) then
+    begin
+       { any type of parameter is allowed here! }
+
+       pt:=comp_expr(true);
+       do_firstpass(pt);
+       if is_constintnode(pt) then
+         begin
+           include(aktprocsym^.definition^.procoptions,po_msgint);
+           aktprocsym^.definition^.messageinf.i:=pt^.value;
+         end
+       else
+         Message(parser_e_ill_msg_expr);
+       disposetree(pt);
+    end;
+{$endif WITHDMT}
 end;
 
 procedure pd_static(const procnames:Tstringcontainer);
@@ -1945,7 +1967,10 @@ end.
 
 {
   $Log$
-  Revision 1.43  2000-01-21 22:06:16  florian
+  Revision 1.44  2000-01-28 23:17:53  florian
+    * virtual XXXX; support for objects, only if -dWITHDMT is defined
+
+  Revision 1.43  2000/01/21 22:06:16  florian
     * fixed for the fix of bug 793
     * fpu variables modified by nested subroutines aren't regable anymore
     * $maxfpuregisters doesn't modify anymore the behavior of a procedure before
@@ -2079,4 +2104,4 @@ end.
     * all tokens now start with an underscore
     * PowerPC compiles!!
 
-}
+}

compiler/ptype.pas

@@ -716,6 +716,9 @@ uses
          strmessagetable,classnamelabel : pasmlabel;
          storetypecanbeforward : boolean;
          vmtlist : taasmoutput;
+{$ifdef WITHDMT}
+         dmtlabel : pasmlabel;
+{$endif WITHDMT}
 
       begin
          {Nowadays aktprocsym may already have a value, so we need to save
@@ -723,11 +726,8 @@ uses
          oldprocsym:=aktprocsym;
          { forward is resolved }
          if assigned(fd) then
-{$ifdef INCLUDEOK}
            exclude(fd^.objectoptions,oo_is_forward);
-{$else}
-           fd^.objectoptions:=fd^.objectoptions-[oo_is_forward];
-{$endif}
+
          there_is_a_destructor:=false;
          actmembertype:=[sp_public];
 
@@ -1047,6 +1047,9 @@ uses
          { Write the start of the VMT, wich is equal for classes and objects }
          if (oo_has_vmt in aktclass^.objectoptions) then
            begin
+{$ifdef WITHDMT}
+              dmtlabel:=gendmt(aktclass);
+{$endif WITHDMT}
               { this generates the entries }
               vmtlist.init;
               genvmt(@vmtlist,aktclass);
@@ -1089,7 +1092,15 @@ uses
               { size gives back 4 for classes                    }
               datasegment^.concat(new(pai_const,init_32bit(aktclass^.symtable^.datasize)));
               datasegment^.concat(new(pai_const,init_32bit(-aktclass^.symtable^.datasize)));
-
+{$ifdef WITHDMT}
+              if not(is_a_class) then
+                begin
+                   if assigned(dmtlabel) then
+                     datasegment^.concat(new(pai_const_symbol,init(dmtlabel)))
+                   else
+                     datasegment^.concat(new(pai_const,init_32bit(0)));
+                end;
+{$endif WITHDMT}
               { write pointer to parent VMT, this isn't implemented in TP }
               { but this is not used in FPC ? (PM) }
               { it's not used yet, but the delphi-operators as and is need it (FK) }
@@ -1524,7 +1535,10 @@ uses
 end.
 {
   $Log$
-  Revision 1.15  2000-01-27 16:31:40  florian
+  Revision 1.16  2000-01-28 23:17:53  florian
+    * virtual XXXX; support for objects, only if -dWITHDMT is defined
+
+  Revision 1.15  2000/01/27 16:31:40  florian
     * bug 738 fixed
 
   Revision 1.14  2000/01/11 17:16:06  jonas

compiler/symdef.inc

@@ -3362,7 +3362,11 @@ Const local_symtable_index : longint = $8001;
         if is_class then
          vmtmethodoffset:=(index+12)*target_os.size_of_pointer
         else
+{$ifdef WITHDMT}
+         vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
+{$else WITHDMT}
          vmtmethodoffset:=(index+3)*target_os.size_of_pointer;
+{$endif WITHDMT}
       end;
 
 
@@ -3859,7 +3863,10 @@ Const local_symtable_index : longint = $8001;
 
 {
   $Log$
-  Revision 1.189  2000-01-26 12:02:29  peter
+  Revision 1.190  2000-01-28 23:17:53  florian
+    * virtual XXXX; support for objects, only if -dWITHDMT is defined
+
+  Revision 1.189  2000/01/26 12:02:29  peter
     * abstractprocdef.para_size needs alignment parameter
     * secondcallparan gets para_alignment size instead of dword_align
 
@@ -3998,4 +4005,4 @@ Const local_symtable_index : longint = $8001;
   Revision 1.154  1999/08/14 00:38:58  peter
     * hack to support property with record fields
 
-}
+}