* overloading supported in child classes

* fixed parsing of classes with private and virtual and overloaded
    so it is compatible with delphi

compiler/cclasses.pas

@@ -279,56 +279,9 @@ interface
        end;
 
 
-    { Speed/Hash value }
-    Function GetSpeedValue(Const s:String):cardinal;
-
-
 implementation
 
 
-{*****************************************************************************
-                               GetSpeedValue
-*****************************************************************************}
-
-{$ifdef ver1_0}
-  {$R-}
-{$endif}
-
-    var
-      Crc32Tbl : array[0..255] of cardinal;
-
-    procedure MakeCRC32Tbl;
-      var
-        crc : cardinal;
-        i,n : integer;
-      begin
-        for i:=0 to 255 do
-         begin
-           crc:=i;
-           for n:=1 to 8 do
-            if odd(longint(crc)) then
-             crc:=cardinal(crc shr 1) xor cardinal($edb88320)
-            else
-             crc:=cardinal(crc shr 1);
-           Crc32Tbl[i]:=crc;
-         end;
-      end;
-
-
-    Function GetSpeedValue(Const s:String):cardinal;
-      var
-        i : integer;
-        InitCrc : cardinal;
-      begin
-        if Crc32Tbl[1]=0 then
-         MakeCrc32Tbl;
-        InitCrc:=cardinal($ffffffff);
-        for i:=1 to Length(s) do
-         InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
-        GetSpeedValue:=InitCrc;
-      end;
-
-
 {*****************************************************************************
                                     Memory debug
 *****************************************************************************}
@@ -1775,7 +1728,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.8  2001-11-05 14:16:25  jonas
+  Revision 1.9  2001-11-18 18:43:13  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.8  2001/11/05 14:16:25  jonas
     * reduced memory usage by about 10% and increased speed by about 15%
 
   Revision 1.7  2001/05/04 19:50:04  peter

compiler/cutils.pas

@@ -89,7 +89,7 @@ uses
     function pstring2pchar(p : pstring) : pchar;
 
 { Speed/Hash value }
-function getspeedvalue(const s : string) : longint;
+    Function GetSpeedValue(Const s:String):cardinal;
 
 { Ansistring (pchar+length) support }
 procedure ansistringdispose(var p : pchar;length : longint);
@@ -633,49 +633,43 @@ uses
                                GetSpeedValue
 *****************************************************************************}
 
-var
+{$ifdef ver1_0}
-  Crc32Tbl : array[0..255] of longint;
+  {$R-}
+{$endif}
 
-procedure MakeCRC32Tbl;
+    var
-var
+      Crc32Tbl : array[0..255] of cardinal;
-  crc : longint;
+
-  i,n : byte;
+    procedure MakeCRC32Tbl;
-begin
+      var
+        crc : cardinal;
+        i,n : integer;
+      begin
         for i:=0 to 255 do
          begin
            crc:=i;
            for n:=1 to 8 do
-      if odd(crc) then
+            if odd(longint(crc)) then
-       crc:=(crc shr 1) xor longint($edb88320)
+             crc:=cardinal(crc shr 1) xor cardinal($edb88320)
             else
-       crc:=crc shr 1;
+             crc:=cardinal(crc shr 1);
            Crc32Tbl[i]:=crc;
          end;
-end;
+      end;
 
 
-{$ifopt R+}
+    Function GetSpeedValue(Const s:String):cardinal;
-  {$define Range_check_on}
+      var
-{$endif opt R+}
+        i : integer;
-
+        InitCrc : cardinal;
-{$R- needed here }
+      begin
-{CRC 32}
-Function GetSpeedValue(Const s:String):longint;
-var
-  i,InitCrc : longint;
-begin
         if Crc32Tbl[1]=0 then
          MakeCrc32Tbl;
-  InitCrc:=-1;
+        InitCrc:=cardinal($ffffffff);
         for i:=1 to Length(s) do
          InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
         GetSpeedValue:=InitCrc;
-end;
+      end;
-
-{$ifdef Range_check_on}
-  {$R+}
-  {$undef Range_check_on}
-{$endif Range_check_on}
 
 
 {*****************************************************************************
@@ -756,7 +750,12 @@ initialization
 end.
 {
   $Log$
-  Revision 1.11  2001-09-05 15:20:26  jonas
+  Revision 1.12  2001-11-18 18:43:13  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.11  2001/09/05 15:20:26  jonas
     * ispowerf2 now works with 64bit ints and should be faster
 
   Revision 1.10  2001/08/04 11:06:30  peter

compiler/ncal.pas

@@ -147,6 +147,66 @@ implementation
       end;
 
 
+    procedure search_class_overloads(aprocsym : tprocsym);
+    { searches n in symtable of pd and all anchestors }
+      var
+        speedvalue : cardinal;
+        srsym      : tprocsym;
+        s          : string;
+        found      : boolean;
+        srpdl,pdl  : pprocdeflist;
+        objdef     : tobjectdef;
+      begin
+        if aprocsym.overloadchecked then
+         exit;
+        aprocsym.overloadchecked:=true;
+        if (aprocsym.owner.symtabletype<>objectsymtable) then
+         internalerror(200111021);
+        objdef:=tobjectdef(aprocsym.owner.defowner);
+        { we start in the parent }
+        if not assigned(objdef.childof) then
+         exit;
+        objdef:=objdef.childof;
+        s:=aprocsym.name;
+        speedvalue:=getspeedvalue(s);
+        while assigned(objdef) do
+         begin
+           srsym:=tprocsym(objdef.symtable.speedsearch(s,speedvalue));
+           if assigned(srsym) then
+            begin
+              if (srsym.typ<>procsym) then
+               internalerror(200111022);
+              if srsym.check_private then
+               begin
+                 srpdl:=srsym.defs;
+                 while assigned(srpdl) do
+                  begin
+                    found:=false;
+                    pdl:=aprocsym.defs;
+                    while assigned(pdl) do
+                     begin
+                       if equal_paras(pdl^.def.para,srpdl^.def.para,cp_all) then
+                        begin
+                          found:=true;
+                          break;
+                        end;
+                       pdl:=pdl^.next;
+                     end;
+                    if not found then
+                     aprocsym.addprocdef(srpdl^.def);
+                    srpdl:=srpdl^.next;
+                  end;
+                 { we can stop if the overloads were already added
+                  for the found symbol }
+                 if srsym.overloadchecked then
+                  break;
+               end;
+            end;
+           { next parent }
+           objdef:=objdef.childof;
+         end;
+      end;
+
 
 {****************************************************************************
                              TCALLPARANODE
@@ -801,6 +861,20 @@ implementation
               { do we know the procedure to call ? }
               if not(assigned(procdefinition)) then
                 begin
+                   { when the definition has overload directive set, we search for
+                      overloaded definitions }
+                   if (not symtableprocentry.overloadchecked) and
+                      (
+                       (m_fpc in aktmodeswitches) or
+                       ((po_overload in symtableprocentry.defs^.def.procoptions) and
+                        (m_delphi in aktmodeswitches))
+                      ) then
+                    begin
+                      { for methods search in the class tree }
+                      if (symtableprocentry.owner.symtabletype=objectsymtable) then
+                        search_class_overloads(symtableprocentry);
+                    end;
+
                    { link all procedures which have the same # of parameters }
                    pd:=symtableprocentry.defs;
                    while assigned(pd) do
@@ -1693,7 +1767,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.55  2001-11-02 23:16:50  peter
+  Revision 1.56  2001-11-18 18:43:13  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.55  2001/11/02 23:16:50  peter
     * removed obsolete chainprocsym and test_procsym code
 
   Revision 1.54  2001/11/02 22:58:01  peter

compiler/nobj.pas

@@ -42,6 +42,7 @@ interface
       pprocdefcoll = ^tprocdefcoll;
       tprocdefcoll = record
          data : tprocdef;
+         hidden : boolean;
          next : pprocdefcoll;
       end;
 
@@ -221,7 +222,6 @@ implementation
       var
          hp : pprocdeflist;
          pt : pprocdeftree;
-
       begin
          if tsym(p).typ=procsym then
            begin
@@ -505,11 +505,35 @@ implementation
          hp : pprocdeflist;
          symcoll : psymcoll;
          _name : string;
-         stored : boolean;
+
+      procedure newdefentry(pd:tprocdef);
+        begin
+           new(procdefcoll);
+           procdefcoll^.data:=pd;
+           procdefcoll^.next:=symcoll^.data;
+           symcoll^.data:=procdefcoll;
+
+           { if it's a virtual method }
+           if (po_virtualmethod in pd.procoptions) then
+             begin
+                { then it gets a number ... }
+                pd.extnumber:=nextvirtnumber;
+                { and we inc the number }
+                inc(nextvirtnumber);
+                has_virtual_method:=true;
+             end;
+
+           if (pd.proctypeoption=potype_constructor) then
+             has_constructor:=true;
+
+           { check, if a method should be overridden }
+           if (pd._class=_class) and
+              (po_overridingmethod in pd.procoptions) then
+             MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname);
+        end;
 
       { creates a new entry in the procsym list }
       procedure newentry;
-
         begin
            { if not, generate a new symbol item }
            new(symcoll);
@@ -522,65 +546,25 @@ implementation
            hp:=tprocsym(sym).defs;
            while assigned(hp) do
              begin
-                new(procdefcoll);
+                newdefentry(hp^.def);
-                procdefcoll^.data:=hp^.def;
-                procdefcoll^.next:=symcoll^.data;
-                symcoll^.data:=procdefcoll;
-
-                { if it's a virtual method }
-                if (po_virtualmethod in hp^.def.procoptions) then
-                  begin
-                     { then it gets a number ... }
-                     hp^.def.extnumber:=nextvirtnumber;
-                     { and we inc the number }
-                     inc(nextvirtnumber);
-                     has_virtual_method:=true;
-                  end;
-
-                if (hp^.def.proctypeoption=potype_constructor) then
-                  has_constructor:=true;
-
-                { check, if a method should be overridden }
-                if (po_overridingmethod in hp^.def.procoptions) then
-                  MessagePos1(hp^.def.fileinfo,parser_e_nothing_to_be_overridden,_class.objname^+'.'+_name+hp^.def.demangled_paras);
-                { next overloaded method }
                 hp:=hp^.next;
              end;
         end;
 
-      procedure newdefentry;
-
-        begin
-           new(procdefcoll);
-           procdefcoll^.data:=hp^.def;
-           procdefcoll^.next:=symcoll^.data;
-           symcoll^.data:=procdefcoll;
-
-           { if it's a virtual method }
-           if (po_virtualmethod in hp^.def.procoptions) then
-             begin
-                { then it gets a number ... }
-                hp^.def.extnumber:=nextvirtnumber;
-                { and we inc the number }
-                inc(nextvirtnumber);
-                has_virtual_method:=true;
-             end;
-
-           if (hp^.def.proctypeoption=potype_constructor) then
-             has_constructor:=true;
-
-           { check, if a method should be overridden }
-           if (po_overridingmethod in hp^.def.procoptions) then
-             MessagePos1(hp^.def.fileinfo,parser_e_nothing_to_be_overridden,_class.objname^+'.'+_name+hp^.def.demangled_paras);
-        end;
-
       label
          handlenextdef;
-
+      var
+         pd : tprocdef;
+         pdoverload : boolean;
       begin
          { put only sub routines into the VMT }
          if tsym(sym).typ=procsym then
            begin
+              { skip private symbols that can not been seen }
+              if not tsym(sym).check_private then
+               exit;
+
+              { check the current list of symbols }
               _name:=sym.name;
               symcoll:=wurzel;
               while assigned(symcoll) do
@@ -592,113 +576,124 @@ implementation
                     hp:=tprocsym(sym).defs;
                     while assigned(hp) do
                      begin
+                       pd:=hp^.def;
+                       if pd.procsym=sym then
+                        begin
+                          pdoverload:=(po_overload in pd.procoptions) or
+                                      (m_fpc in aktmodeswitches);
+
                           { compare with all stored definitions }
                           procdefcoll:=symcoll^.data;
-                             stored:=false;
                           while assigned(procdefcoll) do
                             begin
-                                  { compare parameters }
+                               { compare only if the definition is not hidden }
-                                  if equal_paras(procdefcoll^.data.para,hp^.def.para,cp_all) and
+                               if not procdefcoll^.hidden then
-                                     (
-                                       (po_virtualmethod in procdefcoll^.data.procoptions) or
-                                       (po_virtualmethod in hp^.def.procoptions)
-                                     ) then
-                                    begin { same parameters }
-                                       { wenn sie gleich sind }
-                                       { und eine davon virtual deklariert ist }
-                                       { Fehler falls nur eine VIRTUAL }
-                                       if (po_virtualmethod in procdefcoll^.data.procoptions)<>
-                                          (po_virtualmethod in hp^.def.procoptions) then
                                 begin
-                                            { in classes, we hide the old method }
+                                  { check if one of the two methods has virtual }
-                                            if is_class(_class) then
+                                  if (po_virtualmethod in procdefcoll^.data.procoptions) or
+                                     (po_virtualmethod in pd.procoptions) then
                                    begin
-                                                 { warn only if it is the first time,
+                                     { if the current definition has no virtual then hide the
-                                                   we hide the method }
+                                       old virtual if the new definition has the same arguments or
-                                                 if _class=hp^.def._class then
+                                       has no overload directive }
-                                                   Message1(parser_w_should_use_override,hp^.def.fullprocname);
+                                     if not(po_virtualmethod in pd.procoptions) then
-                                              end
-                                            else
-                                              if _class=hp^.def._class then
                                       begin
-                                                   if (po_virtualmethod in procdefcoll^.data.procoptions) then
+                                        if not pdoverload or
-                                                     Message1(parser_w_overloaded_are_not_both_virtual,
+                                           equal_paras(procdefcoll^.data.para,pd.para,cp_all) then
-                                                              hp^.def.fullprocname)
+                                         begin
-                                                   else
+                                           procdefcoll^.hidden:=true;
-                                                     Message1(parser_w_overloaded_are_not_both_non_virtual,
+                                           if _class=pd._class then
-                                                              hp^.def.fullprocname);
+                                             MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
                                          end;
-                                            { was newentry; exit; (FK) }
-                                            newdefentry;
-                                            goto handlenextdef;
                                       end
-                                       else
+                                     { if both are virtual we check the header }
-                                       { the flags have to match      }
+                                     else if (po_virtualmethod in pd.procoptions) and
-                                       { except abstract and override }
+                                             (po_virtualmethod in procdefcoll^.data.procoptions) then
+                                      begin
+                                        { new one has not override }
+                                        if is_class(_class) and
+                                           not(po_overridingmethod in pd.procoptions) then
+                                         begin
+                                           { we start a new virtual tree, hide the old }
+                                           if not pdoverload or
+                                              equal_paras(procdefcoll^.data.para,pd.para,cp_all) then
+                                            begin
+                                              procdefcoll^.hidden:=true;
+                                              if _class=pd._class then
+                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
+                                            end;
+                                         end
+                                        { same parameters }
+                                        else if (equal_paras(procdefcoll^.data.para,pd.para,cp_all)) then
+                                         begin
+                                           { overload is inherited }
+                                           if (po_overload in procdefcoll^.data.procoptions) then
+                                            include(pd.procoptions,po_overload);
+
+                                           { the flags have to match except abstract and override }
                                            { only if both are virtual !!  }
-                                       if (procdefcoll^.data.proccalloption<>hp^.def.proccalloption) or
+                                           if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
-                                          (procdefcoll^.data.proctypeoption<>hp^.def.proctypeoption) or
+                                               (procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
                                                ((procdefcoll^.data.procoptions-
                                                    [po_abstractmethod,po_overridingmethod,po_assembler,po_overload])<>
-                                           (hp^.def.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler,po_overload])) then
+                                                (pd.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler,po_overload])) then
-                                         Message1(parser_e_header_dont_match_forward,hp^.def.fullprocname);
+                                              MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname);
-
-                                       { check, if the overridden directive is set }
-                                       { (povirtualmethod is set! }
-
-                                       { class ? }
-                                       if is_class(_class) and
-                                          not(po_overridingmethod in hp^.def.procoptions) then
-                                         begin
-                                            { warn only if it is the first time,
-                                              we hide the method }
-                                            if _class=hp^.def._class then
-                                              Message1(parser_w_should_use_override,hp^.def.fullprocname);
-                                            { was newentry; (FK) }
-                                            newdefentry;
-                                            exit;
-                                         end;
 
                                            { error, if the return types aren't equal }
-                                       if not(is_equal(procdefcoll^.data.rettype.def,hp^.def.rettype.def)) and
+                                           if not(is_equal(procdefcoll^.data.rettype.def,pd.rettype.def)) and
                                               not((procdefcoll^.data.rettype.def.deftype=objectdef) and
-                                           (hp^.def.rettype.def.deftype=objectdef) and
+                                               (pd.rettype.def.deftype=objectdef) and
                                                is_class(procdefcoll^.data.rettype.def) and
-                                           is_class(hp^.def.rettype.def) and
+                                               is_class(pd.rettype.def) and
-                                           (tobjectdef(hp^.def.rettype.def).is_related(
+                                               (tobjectdef(pd.rettype.def).is_related(
                                                    tobjectdef(procdefcoll^.data.rettype.def)))) then
-                                         Message2(parser_e_overridden_methods_not_same_ret,hp^.def.fullprocnamewithret,
+                                             Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocnamewithret,
                                                       procdefcoll^.data.fullprocnamewithret);
 
-
                                            { now set the number }
-                                       hp^.def.extnumber:=procdefcoll^.data.extnumber;
+                                           pd.extnumber:=procdefcoll^.data.extnumber;
                                            { and exchange }
-                                       procdefcoll^.data:=hp^.def;
+                                           procdefcoll^.data:=pd;
-                                       stored:=true;
                                            goto handlenextdef;
-                                    end;  { same parameters }
+                                         end
+                                        { different parameters }
+                                        else
+                                         begin
+                                           { when we got an override directive then can search futher for
+                                             the procedure to override.
+                                             If we are starting a new virtual tree then hide the old tree }
+                                           if not(po_overridingmethod in pd.procoptions) and
+                                              not pdoverload then
+                                            begin
+                                              procdefcoll^.hidden:=true;
+                                              if _class=pd._class then
+                                                MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname);
+                                            end;
+                                         end;
+                                      end
+                                     else
+                                      begin
+                                        { the new definition is virtual and the old static, we hide the old one
+                                          if the new defintion has not the overload directive }
+                                        if not pdoverload or
+                                           equal_paras(procdefcoll^.data.para,pd.para,cp_all) then
+                                         procdefcoll^.hidden:=true;
+                                      end;
+                                   end
+                                  else
+                                   begin
+                                     { both are static, we hide the old one if the new defintion
+                                       has not the overload directive }
+                                     if equal_paras(procdefcoll^.data.para,pd.para,cp_all) or
+                                        not pdoverload then
+                                      procdefcoll^.hidden:=true;
+                                   end;
+                                end; { not hidden }
                                procdefcoll:=procdefcoll^.next;
                             end;
-                             { if it isn't saved in the list }
+
-                             { we create a new entry         }
+                          { if it isn't saved in the list we create a new entry }
-                             if not(stored) then
+                          newdefentry(pd);
-                               begin
-                                  new(procdefcoll);
-                                  procdefcoll^.data:=hp^.def;
-                                  procdefcoll^.next:=symcoll^.data;
-                                  symcoll^.data:=procdefcoll;
-                                  { if the method is virtual ... }
-                                  if (po_virtualmethod in hp^.def.procoptions) then
-                                    begin
-                                       { ... it will get a number }
-                                       hp^.def.extnumber:=nextvirtnumber;
-                                       inc(nextvirtnumber);
-                                    end;
-                                  { check, if a method should be overridden }
-                                  if (po_overridingmethod in hp^.def.procoptions) then
-                                   MessagePos1(hp^.def.fileinfo,parser_e_nothing_to_be_overridden,
-                                     hp^.def.fullprocname);
                         end;
                      handlenextdef:
                        hp:=hp^.next;
@@ -1281,7 +1276,12 @@ initialization
 end.
 {
   $Log$
-  Revision 1.8  2001-11-02 22:58:02  peter
+  Revision 1.9  2001-11-18 18:43:14  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.8  2001/11/02 22:58:02  peter
     * procsym definition rewrite
 
   Revision 1.7  2001/10/25 21:22:35  peter

compiler/psystem.pas

@@ -109,50 +109,6 @@ var
   vmtarraytype : ttype;
   vmtsymtable  : tsymtable;
 begin
-{ Internal types }
-  addtype('$formal',cformaltype);
-  addtype('$void',voidtype);
-  addtype('$byte',u8bittype);
-  addtype('$word',u16bittype);
-  addtype('$ulong',u32bittype);
-  addtype('$longint',s32bittype);
-  addtype('$qword',cu64bittype);
-  addtype('$int64',cs64bittype);
-  addtype('$char',cchartype);
-  addtype('$widechar',cwidechartype);
-  addtype('$shortstring',cshortstringtype);
-  addtype('$longstring',clongstringtype);
-  addtype('$ansistring',cansistringtype);
-  addtype('$widestring',cwidestringtype);
-  addtype('$openshortstring',openshortstringtype);
-  addtype('$boolean',booltype);
-  addtype('$void_pointer',voidpointertype);
-  addtype('$char_pointer',charpointertype);
-  addtype('$void_farpointer',voidfarpointertype);
-  addtype('$openchararray',openchararraytype);
-  addtype('$file',cfiletype);
-  addtype('$variant',cvarianttype);
-  addtype('$s32real',s32floattype);
-  addtype('$s64real',s64floattype);
-  addtype('$s80real',s80floattype);
-  { Add a type for virtual method tables in lowercase }
-  { so it isn't reachable!                            }
-  vmtsymtable:=trecordsymtable.create;
-  vmttype.setdef(trecorddef.create(vmtsymtable));
-  pvmttype.setdef(tpointerdef.create(vmttype));
-  vmtsymtable.insert(tvarsym.create('$parent',pvmttype));
-  vmtsymtable.insert(tvarsym.create('$length',s32bittype));
-  vmtsymtable.insert(tvarsym.create('$mlength',s32bittype));
-  vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
-  tarraydef(vmtarraytype.def).elementtype:=voidpointertype;
-  vmtsymtable.insert(tvarsym.create('$__pfn',vmtarraytype));
-  addtype('$__vtbl_ptr_type',vmttype);
-  addtype('$pvmt',pvmttype);
-  vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
-  tarraydef(vmtarraytype.def).elementtype:=pvmttype;
-  addtype('$vtblarray',vmtarraytype);
-{ Add functions that require compiler magic }
-  insertinternsyms(p);
 { Normal types }
   addtype('Single',s32floattype);
   addtype('Double',s64floattype);
@@ -179,6 +135,49 @@ begin
   addtype('Int64',cs64bittype);
   adddef('TypedFile',tfiledef.createtyped(voidtype));
   addtype('Variant',cvarianttype);
+{ Internal types }
+  addtype('$formal',cformaltype);
+  addtype('$void',voidtype);
+  addtype('$byte',u8bittype);
+  addtype('$word',u16bittype);
+  addtype('$ulong',u32bittype);
+  addtype('$longint',s32bittype);
+  addtype('$qword',cu64bittype);
+  addtype('$int64',cs64bittype);
+  addtype('$char',cchartype);
+  addtype('$widechar',cwidechartype);
+  addtype('$shortstring',cshortstringtype);
+  addtype('$longstring',clongstringtype);
+  addtype('$ansistring',cansistringtype);
+  addtype('$widestring',cwidestringtype);
+  addtype('$openshortstring',openshortstringtype);
+  addtype('$boolean',booltype);
+  addtype('$void_pointer',voidpointertype);
+  addtype('$char_pointer',charpointertype);
+  addtype('$void_farpointer',voidfarpointertype);
+  addtype('$openchararray',openchararraytype);
+  addtype('$file',cfiletype);
+  addtype('$variant',cvarianttype);
+  addtype('$s32real',s32floattype);
+  addtype('$s64real',s64floattype);
+  addtype('$s80real',s80floattype);
+{ Add a type for virtual method tables }
+  vmtsymtable:=trecordsymtable.create;
+  vmttype.setdef(trecorddef.create(vmtsymtable));
+  pvmttype.setdef(tpointerdef.create(vmttype));
+  vmtsymtable.insert(tvarsym.create('$parent',pvmttype));
+  vmtsymtable.insert(tvarsym.create('$length',s32bittype));
+  vmtsymtable.insert(tvarsym.create('$mlength',s32bittype));
+  vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
+  tarraydef(vmtarraytype.def).elementtype:=voidpointertype;
+  vmtsymtable.insert(tvarsym.create('$__pfn',vmtarraytype));
+  addtype('$__vtbl_ptr_type',vmttype);
+  addtype('$pvmt',pvmttype);
+  vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
+  tarraydef(vmtarraytype.def).elementtype:=pvmttype;
+  addtype('$vtblarray',vmtarraytype);
+{ Add functions that require compiler magic }
+  insertinternsyms(p);
 end;
 
 
@@ -277,7 +276,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.20  2001-10-24 11:51:39  marco
+  Revision 1.21  2001-11-18 18:43:14  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.20  2001/10/24 11:51:39  marco
    * Make new/dispose system functions instead of keywords
 
   Revision 1.19  2001/08/30 20:13:53  peter

compiler/symdef.pas

@@ -458,6 +458,9 @@ interface
        tprocdef = class(tabstractprocdef)
        private
           _mangledname : pstring;
+{$ifdef GDB}
+          isstabwritten : boolean;
+{$endif GDB}
        public
           extnumber  : longint;
           messageinf : tmessageinf;
@@ -3269,6 +3272,9 @@ implementation
          regvarinfo := nil;
          count:=false;
          is_used:=false;
+{$ifdef GDB}
+         isstabwritten := false;
+{$endif GDB}
       end;
 
 
@@ -3334,6 +3340,9 @@ implementation
          refcount:=0;
          count:=true;
          is_used:=false;
+{$ifdef GDB}
+         isstabwritten := false;
+{$endif GDB}
       end;
 
 
@@ -3587,6 +3596,8 @@ implementation
 
 
 {$ifdef GDB}
+
+{$ifdef unused}
 {    procedure addparaname(p : tsym);
       var vs : char;
       begin
@@ -3630,10 +3641,61 @@ implementation
       stabstring := strnew(stabrecstring);
       freemem(stabrecstring,1024);
       end;
+{$endif unused}
 
+    function tprocdef.stabstring: pchar;
+     Var RType : Char;
+         Obj,Info : String;
+         stabsstr : string;
+         p : pchar;
+    begin
+      obj := procsym.name;
+      info := '';
+      if tprocsym(procsym).is_global then
+       RType := 'F'
+      else
+       RType := 'f';
+     if assigned(owner) then
+      begin
+        if (owner.symtabletype = objectsymtable) then
+         obj := upper(owner.name^)+'__'+procsym.name;
+        { this code was correct only as long as the local symboltable
+          of the parent had the same name as the function
+          but this is no true anymore !! PM
+        if (owner.symtabletype=localsymtable) and assigned(owner.name) then
+         info := ','+name+','+owner.name^;  }
+        if (owner.symtabletype=localsymtable) and
+           assigned(owner.defowner) and
+           assigned(tprocdef(owner.defowner).procsym) then
+          info := ','+procsym.name+','+tprocdef(owner.defowner).procsym.name;
+      end;
+     stabsstr:=mangledname;
+     getmem(p,length(stabsstr)+255);
+     strpcopy(p,'"'+obj+':'+RType
+           +tstoreddef(rettype.def).numberstring+info+'",'+tostr(n_function)
+           +',0,'+
+           tostr(fileinfo.line)
+           +',');
+     strpcopy(strend(p),stabsstr);
+     stabstring:=strnew(p);
+     freemem(p,length(stabsstr)+255);
+    end;
 
     procedure tprocdef.concatstabto(asmlist : taasmoutput);
     begin
+      if (proccalloption=pocall_internproc) then
+        exit;
+      if not isstabwritten then
+        asmList.concat(Tai_stabs.Create(stabstring));
+      isstabwritten := true;
+      if assigned(parast) then
+        tstoredsymtable(parast).concatstabto(asmlist);
+      { local type defs and vars should not be written
+        inside the main proc stab }
+      if assigned(localst) and
+         (lexlevel>main_program_level) then
+        tstoredsymtable(localst).concatstabto(asmlist);
+      is_def_stab_written := written;
     end;
 {$endif GDB}
 
@@ -5396,7 +5458,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.56  2001-11-18 18:27:57  florian
+  Revision 1.57  2001-11-18 18:43:14  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.56  2001/11/18 18:27:57  florian
     * publishing of qword, int64 and widechar properties is now possible
 
   Revision 1.55  2001/11/02 22:58:06  peter

compiler/symsym.pas

@@ -100,6 +100,7 @@ interface
        tprocsym = class(tstoredsym)
           defs      : pprocdeflist; { linked list of overloaded procdefs }
           is_global : boolean;
+          overloadchecked : boolean;
           constructor create(const n : string);
           constructor load(ppufile:tcompilerppufile);
           destructor destroy;override;
@@ -678,7 +679,8 @@ implementation
          typ:=procsym;
          defs:=nil;
          owner:=nil;
-         is_global := false;
+         is_global:=false;
+         overloadchecked:=false;
       end;
 
 
@@ -695,7 +697,8 @@ implementation
             break;
            addprocdef(pd);
          until false;
-         is_global := false;
+         is_global:=false;
+         overloadchecked:=false;
       end;
 
 
@@ -770,6 +773,9 @@ implementation
          p:=defs;
          while assigned(p) do
            begin
+             { only write the proc definitions that belong
+               to this procsym }
+             if (p^.def.procsym=self) then
               ppufile.putderef(p^.def);
              p:=p^.next;
            end;
@@ -836,57 +842,13 @@ implementation
 
 {$ifdef GDB}
     function tprocsym.stabstring : pchar;
-     Var RetType : Char;
-         Obj,Info : String;
-         stabsstr : string;
-         p : pchar;
       begin
-      obj := name;
+        internalerror(200111171);
-      info := '';
-      if is_global then
-       RetType := 'F'
-      else
-       RetType := 'f';
-     if assigned(owner) then
-      begin
-        if (owner.symtabletype = objectsymtable) then
-         obj := upper(owner.name^)+'__'+name;
-        { this code was correct only as long as the local symboltable
-          of the parent had the same name as the function
-          but this is no true anymore !! PM
-        if (owner.symtabletype=localsymtable) and assigned(owner.name) then
-         info := ','+name+','+owner.name^;  }
-        if (owner.symtabletype=localsymtable) and
-           assigned(owner.defowner) and
-           assigned(tprocdef(owner.defowner).procsym) then
-          info := ','+name+','+tprocdef(owner.defowner).procsym.name;
-      end;
-     stabsstr:=defs^.def.mangledname;
-     getmem(p,length(stabsstr)+255);
-     strpcopy(p,'"'+obj+':'+RetType
-           +tstoreddef(defs^.def.rettype.def).numberstring+info+'",'+tostr(n_function)
-           +',0,'+
-           tostr(aktfilepos.line)
-           +',');
-     strpcopy(strend(p),stabsstr);
-     stabstring:=strnew(p);
-     freemem(p,length(stabsstr)+255);
       end;
 
     procedure tprocsym.concatstabto(asmlist : taasmoutput);
     begin
-      if (defs^.def.proccalloption=pocall_internproc) then exit;
+      internalerror(200111172);
-      if not isstabwritten then
-        asmList.concat(Tai_stabs.Create(stabstring));
-      isstabwritten := true;
-      if assigned(defs^.def.parast) then
-        tstoredsymtable(defs^.def.parast).concatstabto(asmlist);
-      { local type defs and vars should not be written
-        inside the main proc stab }
-      if assigned(defs^.def.localst) and
-         (lexlevel>main_program_level) then
-        tstoredsymtable(defs^.def.localst).concatstabto(asmlist);
-      defs^.def.is_def_stab_written := written;
     end;
 {$endif GDB}
 
@@ -2477,7 +2439,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.26  2001-11-02 22:58:08  peter
+  Revision 1.27  2001-11-18 18:43:16  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.26  2001/11/02 22:58:08  peter
     * procsym definition rewrite
 
   Revision 1.25  2001/10/25 21:22:40  peter

compiler/symtable.pas

@@ -1103,8 +1103,7 @@ implementation
               { but private ids can be reused }
               hsym:=search_class_member(tobjectdef(defowner),sym.name);
               if assigned(hsym) and
-                (not(sp_private in hsym.symoptions) or
+                 hsym.check_private then
-                 (hsym.owner.defowner.owner.unitid=0)) then
                begin
                  DuplicateSym(hsym);
                  exit;
@@ -1269,10 +1268,9 @@ implementation
            (sym.typ <> funcretsym) then
            begin
               hsym:=search_class_member(procinfo^._class,sym.name);
-              if assigned(hsym) and
               { private ids can be reused }
-                (not(sp_private in hsym.symoptions) or
+              if assigned(hsym) and
-                 (hsym.owner.defowner.owner.unitid=0)) then
+                 hsym.check_private then
                begin
                  { delphi allows to reuse the names in a class, but not
                    in object (tp7 compatible) }
@@ -2047,7 +2045,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.49  2001-11-02 23:16:52  peter
+  Revision 1.50  2001-11-18 18:43:17  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.49  2001/11/02 23:16:52  peter
     * removed obsolete chainprocsym and test_procsym code
 
   Revision 1.48  2001/11/02 22:58:08  peter

compiler/symtype.pas

@@ -91,6 +91,7 @@ interface
          function  realname:string;
          procedure deref;virtual;abstract;
          function  gettypedef:tdef;virtual;
+         function  check_private:boolean;
       end;
 
 {************************************************
@@ -221,6 +222,15 @@ implementation
       end;
 
 
+    function tsym.check_private:boolean;
+      begin
+        { private symbols are allowed when we are in the same
+          module as they are defined }
+        check_private:=not(sp_private in symoptions) or
+                       (owner.defowner.owner.unitid=0);
+      end;
+
+
 {****************************************************************************
                                TRef
 ****************************************************************************}
@@ -517,7 +527,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2001-11-02 22:58:08  peter
+  Revision 1.12  2001-11-18 18:43:18  peter
+    * overloading supported in child classes
+    * fixed parsing of classes with private and virtual and overloaded
+      so it is compatible with delphi
+
+  Revision 1.11  2001/11/02 22:58:08  peter
     * procsym definition rewrite
 
   Revision 1.10  2001/10/21 12:33:07  peter