paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 07:19:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* overloading supported in child classes

Browse Source 
* fixed parsing of classes with private and virtual and overloaded
    so it is compatible with delphi
This commit is contained in:
peter 2001-11-18 18:43:13 +00:00
parent 889ca6ea25
commit faf78ea813
9 changed files with 466 additions and 374 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
compiler/cclasses.pas
View File

@ -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

83
compiler/cutils.pas
View File

@ -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

81
compiler/ncal.pas
View File

@ -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

336
compiler/nobj.pas
View File

@ -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

94
compiler/psystem.pas
View File

@ -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

73
compiler/symdef.pas
View File

@ -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

67
compiler/symsym.pas
View File

@ -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

35
compiler/symtable.pas
View File

@ -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

17
compiler/symtype.pas
View File

@ -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