diff --git a/compiler/cclasses.pas b/compiler/cclasses.pas index 0cc8bb114a..2c6ba61ee9 100644 --- a/compiler/cclasses.pas +++ b/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 diff --git a/compiler/cutils.pas b/compiler/cutils.pas index 7948d696e2..3d5581eab1 100644 --- a/compiler/cutils.pas +++ b/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 - Crc32Tbl : array[0..255] of longint; +{$ifdef ver1_0} + {$R-} +{$endif} -procedure MakeCRC32Tbl; -var - crc : longint; - i,n : byte; -begin - for i:=0 to 255 do - begin - crc:=i; - for n:=1 to 8 do - if odd(crc) then - crc:=(crc shr 1) xor longint($edb88320) - else - crc:=crc shr 1; - Crc32Tbl[i]:=crc; - end; -end; + 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; -{$ifopt R+} - {$define Range_check_on} -{$endif opt R+} - -{$R- needed here } -{CRC 32} -Function GetSpeedValue(Const s:String):longint; -var - i,InitCrc : longint; -begin - if Crc32Tbl[1]=0 then - MakeCrc32Tbl; - InitCrc:=-1; - for i:=1 to Length(s) do - InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8); - GetSpeedValue:=InitCrc; -end; - -{$ifdef Range_check_on} - {$R+} - {$undef Range_check_on} -{$endif Range_check_on} + 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; {***************************************************************************** @@ -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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 544b72c683..f676a82ffc 100644 --- a/compiler/ncal.pas +++ b/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 diff --git a/compiler/nobj.pas b/compiler/nobj.pas index f001f0dd5f..f1542e9b48 100644 --- a/compiler/nobj.pas +++ b/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,191 +546,162 @@ implementation hp:=tprocsym(sym).defs; while assigned(hp) do 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); - { next overloaded method } + newdefentry(hp^.def); 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 - begin - { does the symbol already exist in the list ? } - if _name=symcoll^.name^ then + begin + { does the symbol already exist in the list ? } + if _name=symcoll^.name^ then + begin + { walk through all defs of the symbol } + hp:=tprocsym(sym).defs; + while assigned(hp) do begin - { walk through all defs of the symbol } - hp:=tprocsym(sym).defs; - while assigned(hp) do - begin - { compare with all stored definitions } - procdefcoll:=symcoll^.data; - stored:=false; - while assigned(procdefcoll) do - begin - { compare parameters } - if equal_paras(procdefcoll^.data.para,hp^.def.para,cp_all) and - ( - (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 } - if is_class(_class) 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); - end - else - if _class=hp^.def._class then - begin - if (po_virtualmethod in procdefcoll^.data.procoptions) then - Message1(parser_w_overloaded_are_not_both_virtual, - hp^.def.fullprocname) - else - Message1(parser_w_overloaded_are_not_both_non_virtual, - hp^.def.fullprocname); - end; - { was newentry; exit; (FK) } - newdefentry; - goto handlenextdef; - end - else - { the flags have to match } - { except abstract and override } - { only if both are virtual !! } - if (procdefcoll^.data.proccalloption<>hp^.def.proccalloption) or - (procdefcoll^.data.proctypeoption<>hp^.def.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 - Message1(parser_e_header_dont_match_forward,hp^.def.fullprocname); + pd:=hp^.def; + if pd.procsym=sym then + begin + pdoverload:=(po_overload in pd.procoptions) or + (m_fpc in aktmodeswitches); - { check, if the overridden directive is set } - { (povirtualmethod is set! } - - { class ? } - if is_class(_class) and - not(po_overridingmethod in hp^.def.procoptions) then + { compare with all stored definitions } + procdefcoll:=symcoll^.data; + while assigned(procdefcoll) do + begin + { compare only if the definition is not hidden } + if not procdefcoll^.hidden then + begin + { check if one of the two methods has virtual } + if (po_virtualmethod in procdefcoll^.data.procoptions) or + (po_virtualmethod in pd.procoptions) then + begin + { if the current definition has no virtual then hide the + old virtual if the new definition has the same arguments or + has no overload directive } + if not(po_virtualmethod in pd.procoptions) then + begin + if not pdoverload or + equal_paras(procdefcoll^.data.para,pd.para,cp_all) 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; + procdefcoll^.hidden:=true; + if _class=pd._class then + MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname); end; + end + { if both are virtual we check the header } + else if (po_virtualmethod in pd.procoptions) and + (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); - { error, if the return types aren't equal } - if not(is_equal(procdefcoll^.data.rettype.def,hp^.def.rettype.def)) and - not((procdefcoll^.data.rettype.def.deftype=objectdef) and - (hp^.def.rettype.def.deftype=objectdef) and - is_class(procdefcoll^.data.rettype.def) and - is_class(hp^.def.rettype.def) and - (tobjectdef(hp^.def.rettype.def).is_related( - tobjectdef(procdefcoll^.data.rettype.def)))) then - Message2(parser_e_overridden_methods_not_same_ret,hp^.def.fullprocnamewithret, - procdefcoll^.data.fullprocnamewithret); + { the flags have to match except abstract and override } + { only if both are virtual !! } + if (procdefcoll^.data.proccalloption<>pd.proccalloption) or + (procdefcoll^.data.proctypeoption<>pd.proctypeoption) or + ((procdefcoll^.data.procoptions- + [po_abstractmethod,po_overridingmethod,po_assembler,po_overload])<> + (pd.procoptions-[po_abstractmethod,po_overridingmethod,po_assembler,po_overload])) then + MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname); + { error, if the return types aren't equal } + if not(is_equal(procdefcoll^.data.rettype.def,pd.rettype.def)) and + not((procdefcoll^.data.rettype.def.deftype=objectdef) and + (pd.rettype.def.deftype=objectdef) and + is_class(procdefcoll^.data.rettype.def) and + is_class(pd.rettype.def) and + (tobjectdef(pd.rettype.def).is_related( + tobjectdef(procdefcoll^.data.rettype.def)))) then + Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocnamewithret, + procdefcoll^.data.fullprocnamewithret); - { now set the number } - hp^.def.extnumber:=procdefcoll^.data.extnumber; - { and exchange } - procdefcoll^.data:=hp^.def; - stored:=true; - goto handlenextdef; - end; { same parameters } - procdefcoll:=procdefcoll^.next; - end; - { if it isn't saved in the list } - { we create a new entry } - if not(stored) then - 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; - end; - exit; + { now set the number } + pd.extnumber:=procdefcoll^.data.extnumber; + { and exchange } + procdefcoll^.data:=pd; + goto handlenextdef; + 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 } + newdefentry(pd); + end; + handlenextdef: + hp:=hp^.next; end; - symcoll:=symcoll^.next; - end; + exit; + end; + symcoll:=symcoll^.next; + end; newentry; end; end; @@ -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 diff --git a/compiler/psystem.pas b/compiler/psystem.pas index 09f8f70308..f724cbde8c 100644 --- a/compiler/psystem.pas +++ b/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 diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 8ccd9d3f79..d6123d22b1 100644 --- a/compiler/symdef.pas +++ b/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,11 +3641,62 @@ 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 - end; + 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 diff --git a/compiler/symsym.pas b/compiler/symsym.pas index b97d4a3e32..86b9a9f6ee 100644 --- a/compiler/symsym.pas +++ b/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,7 +773,10 @@ implementation p:=defs; while assigned(p) do begin - ppufile.putderef(p^.def); + { only write the proc definitions that belong + to this procsym } + if (p^.def.procsym=self) then + ppufile.putderef(p^.def); p:=p^.next; end; ppufile.putderef(nil); @@ -836,57 +842,13 @@ implementation {$ifdef GDB} function tprocsym.stabstring : pchar; - Var RetType : Char; - Obj,Info : String; - stabsstr : string; - p : pchar; - begin - obj := name; - 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; + internalerror(200111171); 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; - 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; + internalerror(200111172); 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 diff --git a/compiler/symtable.pas b/compiler/symtable.pas index c70683c467..2a32597580 100644 --- a/compiler/symtable.pas +++ b/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.owner.defowner.owner.unitid=0)) then + hsym.check_private then begin DuplicateSym(hsym); exit; @@ -1269,20 +1268,19 @@ implementation (sym.typ <> funcretsym) then begin hsym:=search_class_member(procinfo^._class,sym.name); + { private ids can be reused } if assigned(hsym) and - { private ids can be reused } - (not(sp_private in hsym.symoptions) or - (hsym.owner.defowner.owner.unitid=0)) then - begin - { delphi allows to reuse the names in a class, but not - in object (tp7 compatible) } - if not((m_delphi in aktmodeswitches) and - is_class(procinfo^._class)) then - begin - DuplicateSym(hsym); - exit; - end; - end; + hsym.check_private then + begin + { delphi allows to reuse the names in a class, but not + in object (tp7 compatible) } + if not((m_delphi in aktmodeswitches) and + is_class(procinfo^._class)) then + begin + DuplicateSym(hsym); + exit; + end; + end; end; inherited insert(sym); @@ -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 diff --git a/compiler/symtype.pas b/compiler/symtype.pas index e7ccff4ea9..083189cf06 100644 --- a/compiler/symtype.pas +++ b/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