paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-01-04 18:26:08 +01:00
Code Issues Packages Projects Releases Wiki Activity

- removed global "resolving_forward" variable (was no longer used)

Browse Source 
* moved forward type checking from pdecl/symbase to symtable/symsym

git-svn-id: trunk@11763 -
This commit is contained in:
Jonas Maebe 2008-09-13 12:28:55 +00:00
parent bed6a0faa9
commit 0b815a6fff
5 changed files with 164 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/globals.pas
View File

@ -244,7 +244,6 @@ interface
block_type : tblock_type; { type of currently parsed block }
compile_level : word;
resolving_forward : boolean; { used to add forward reference as second ref }
exceptblockcounter : integer; { each except block gets a unique number check gotos }
current_exceptblock : integer; { the exceptblock number of the current block (0 if none) }
LinkLibraryAliases : TLinkStrMap;
@ -1255,7 +1254,6 @@ implementation
do_make:=true;
compile_level:=0;
DLLsource:=false;
resolving_forward:=false;
paratarget:=system_none;
paratargetasm:=as_none;
paratargetdbg:=dbg_none;

109
compiler/pdecl.pas
View File

@ -276,109 +276,6 @@ implementation
end;
{ search in symtablestack used, but not defined type }
procedure resolve_type_forward(p:TObject;arg:pointer);
var
hpd,pd : tdef;
stpos : tfileposinfo;
again : boolean;
srsym : tsym;
srsymtable : TSymtable;
begin
{ Check only typesyms or record/object fields }
case tsym(p).typ of
typesym :
pd:=ttypesym(p).typedef;
fieldvarsym :
pd:=tfieldvarsym(p).vardef
else
internalerror(2008090702);
end;
repeat
again:=false;
case pd.typ of
arraydef :
begin
{ elementdef could also be defined using a forwarddef }
pd:=tarraydef(pd).elementdef;
again:=true;
end;
pointerdef,
classrefdef :
begin
{ classrefdef inherits from pointerdef }
hpd:=tabstractpointerdef(pd).pointeddef;
{ still a forward def ? }
if hpd.typ=forwarddef then
begin
{ try to resolve the forward }
{ get the correct position for it }
stpos:=current_tokenpos;
current_tokenpos:=tforwarddef(hpd).forwardpos;
resolving_forward:=true;
if not assigned(tforwarddef(hpd).tosymname) then
internalerror(20021120);
searchsym(tforwarddef(hpd).tosymname^,srsym,srsymtable);
resolving_forward:=false;
current_tokenpos:=stpos;
{ we don't need the forwarddef anymore, dispose it }
hpd.free;
tabstractpointerdef(pd).pointeddef:=nil; { if error occurs }
{ was a type sym found ? }
if assigned(srsym) and
(srsym.typ=typesym) then
begin
tabstractpointerdef(pd).pointeddef:=ttypesym(srsym).typedef;
{ avoid wrong unused warnings web bug 801 PM }
inc(ttypesym(srsym).refs);
{ we need a class type for classrefdef }
if (pd.typ=classrefdef) and
not(is_class(ttypesym(srsym).typedef)) then
Message1(type_e_class_type_expected,ttypesym(srsym).typedef.typename);
end
else
begin
MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
{ try to recover }
tabstractpointerdef(pd).pointeddef:=generrordef;
end;
end;
end;
recorddef :
begin
trecorddef(pd).symtable.forwardchecksyms.ForEachCall(@resolve_type_forward,nil);
{ don't free, may still be reused }
trecorddef(pd).symtable.forwardchecksyms.clear;
end;
objectdef :
begin
if not(m_fpc in current_settings.modeswitches) and
(oo_is_forward in tobjectdef(pd).objectoptions) then
begin
{ only give an error as the implementation may follow in an
other type block which is allowed by FPC modes }
MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
end
else
begin
{ Check all fields of the object declaration, but don't
check objectdefs in objects/records, because these
can't exist (anonymous objects aren't allowed) }
if not(tsym(p).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
begin
tobjectdef(pd).symtable.forwardchecksyms.ForEachCall(@resolve_type_forward,nil);
{ don't free, may still be reused }
tobjectdef(pd).symtable.forwardchecksyms.clear;
end;
end;
end;
end;
until not again;
end;
procedure types_dec;
function parse_generic_parameters:TFPObjectList;
@ -473,7 +370,7 @@ implementation
{ the definition is modified }
object_dec(orgtypename,nil,nil,tobjectdef(ttypesym(sym).typedef));
{ since the definition is modified, there may be new forwarddefs }
symtablestack.top.forwardchecksyms.add(sym);
tstoredsymtable(symtablestack.top).checkforwardtype(sym);
newtype:=ttypesym(sym);
hdef:=newtype.typedef;
end
@ -602,9 +499,7 @@ implementation
generictypelist.free;
until token<>_ID;
typecanbeforward:=false;
symtablestack.top.forwardchecksyms.ForEachCall(@resolve_type_forward,nil);
{ don't free, may still be reused }
symtablestack.top.forwardchecksyms.clear;
tstoredsymtable(symtablestack.top).resolve_forward_types;
block_type:=old_block_type;
end;

15
compiler/symbase.pas
View File

@ -92,7 +92,6 @@ interface
realname : pshortstring;
DefList : TFPObjectList;
SymList : TFPHashObjectList;
forwardchecksyms : TFPObjectList;
defowner : TDefEntry; { for records and objects }
moduleid : longint;
refcount : smallint;
@ -105,8 +104,8 @@ interface
function getcopy:TSymtable;
procedure clear;virtual;
function checkduplicate(var s:THashedIDString;sym:TSymEntry):boolean;virtual;
procedure insert(sym:TSymEntry;checkdup:boolean=true);
procedure Delete(sym:TSymEntry);
procedure insert(sym:TSymEntry;checkdup:boolean=true);virtual;
procedure Delete(sym:TSymEntry);virtual;
function Find(const s:TIDString) : TSymEntry;
function FindWithHash(const s:THashedIDString) : TSymEntry;virtual;
procedure insertdef(def:TDefEntry);virtual;
@ -220,8 +219,6 @@ implementation
defowner:=nil;
DefList:=TFPObjectList.Create(true);
SymList:=TFPHashObjectList.Create(true);
{ the syms are owned by symlist, so don't free }
forwardchecksyms:=TFPObjectList.Create(false);
refcount:=1;
end;
@ -236,8 +233,6 @@ implementation
{ SymList can already be disposed or set to nil for withsymtable, }
{ but in that case Free does nothing }
SymList.Free;
forwardchecksyms.free;
stringdispose(name);
stringdispose(realname);
end;
@ -269,7 +264,6 @@ implementation
i : integer;
begin
SymList.Clear;
forwardchecksyms.clear;
{ Prevent recursive calls between TDef.destroy and TSymtable.Remove }
if DefList.OwnsObjects then
begin
@ -306,9 +300,6 @@ implementation
sym.ChangeOwnerAndName(SymList,Copy(sym.realname,2,255))
else
sym.ChangeOwnerAndName(SymList,Upper(sym.realname));
{ keep track of syms whose type may need forward resolving later on }
if (sym.typ in [typesym,fieldvarsym]) then
forwardchecksyms.add(sym);
sym.Owner:=self;
end;
@ -317,8 +308,6 @@ implementation
begin
if sym.Owner<>self then
internalerror(200611121);
if (sym.typ in [typesym,fieldvarsym]) then
forwardchecksyms.remove(sym);
SymList.Remove(sym);
end;

91
compiler/symsym.pas
View File

@ -46,6 +46,7 @@ interface
constructor create(st:tsymtyp;const n : string);
constructor ppuload(st:tsymtyp;ppufile:tcompilerppufile);
destructor destroy;override;
procedure resolve_type_forward;
procedure ppuwrite(ppufile:tcompilerppufile);virtual;
end;
@ -382,6 +383,96 @@ implementation
end;
{ Resolve forward defined types and give errors for non-resolved ones }
procedure tstoredsym.resolve_type_forward;
var
hpd,pd : tdef;
srsym : tsym;
srsymtable : TSymtable;
again : boolean;
begin
{ Check only typesyms or record/object fields }
case typ of
typesym :
pd:=ttypesym(self).typedef;
fieldvarsym :
pd:=tfieldvarsym(self).vardef
else
internalerror(2008090702);
end;
repeat
again:=false;
case pd.typ of
arraydef :
begin
{ elementdef could also be defined using a forwarddef }
pd:=tarraydef(pd).elementdef;
again:=true;
end;
pointerdef,
classrefdef :
begin
{ classrefdef inherits from pointerdef }
hpd:=tabstractpointerdef(pd).pointeddef;
{ still a forward def ? }
if hpd.typ=forwarddef then
begin
{ try to resolve the forward }
if not assigned(tforwarddef(hpd).tosymname) then
internalerror(20021120);
searchsym(tforwarddef(hpd).tosymname^,srsym,srsymtable);
{ we don't need the forwarddef anymore, dispose it }
hpd.free;
tabstractpointerdef(pd).pointeddef:=nil; { if error occurs }
{ was a type sym found ? }
if assigned(srsym) and
(srsym.typ=typesym) then
begin
tabstractpointerdef(pd).pointeddef:=ttypesym(srsym).typedef;
{ avoid wrong unused warnings web bug 801 PM }
inc(ttypesym(srsym).refs);
{ we need a class type for classrefdef }
if (pd.typ=classrefdef) and
not(is_class(ttypesym(srsym).typedef)) then
MessagePos1(tsym(srsym).fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename);
end
else
begin
MessagePos1(fileinfo,sym_e_forward_type_not_resolved,realname);
{ try to recover }
tabstractpointerdef(pd).pointeddef:=generrordef;
end;
end;
end;
recorddef :
begin
tstoredsymtable(trecorddef(pd).symtable).resolve_forward_types;
end;
objectdef :
begin
if not(m_fpc in current_settings.modeswitches) and
(oo_is_forward in tobjectdef(pd).objectoptions) then
begin
{ only give an error as the implementation may follow in an
other type block which is allowed by FPC modes }
MessagePos1(fileinfo,sym_e_forward_type_not_resolved,realname);
end
else
begin
{ Check all fields of the object declaration, but don't
check objectdefs in objects/records, because these
can't exist (anonymous objects aren't allowed) }
if not(owner.symtabletype in [ObjectSymtable,recordsymtable]) then
tstoredsymtable(tobjectdef(pd).symtable).resolve_forward_types;
end;
end;
end;
until not again;
end;
{****************************************************************************
TLABELSYM
****************************************************************************}

69
compiler/symtable.pas
View File

@ -46,6 +46,7 @@ interface
tstoredsymtable = class(TSymtable)
private
b_needs_init_final : boolean;
forwardchecksyms : TFPObjectList;
procedure _needs_init_final(sym:TObject;arg:pointer);
procedure check_forward(sym:TObject;arg:pointer);
procedure labeldefined(sym:TObject;arg:pointer);
@ -58,6 +59,12 @@ interface
procedure writedefs(ppufile:tcompilerppufile);
procedure writesyms(ppufile:tcompilerppufile);
public
constructor create(const s:string); reintroduce;
destructor destroy; override;
procedure clear;override;
procedure insert(sym:TSymEntry;checkdup:boolean=true);override;
procedure delete(sym:TSymEntry);override;
procedure checkforwardtype(sym:TSymEntry);
{ load/write }
procedure ppuload(ppufile:tcompilerppufile);virtual;
procedure ppuwrite(ppufile:tcompilerppufile);virtual;
@ -70,6 +77,7 @@ interface
procedure allsymbolsused;
procedure allprivatesused;
procedure check_forwards;
procedure resolve_forward_types;
procedure checklabels;
function needs_init_final : boolean;
procedure unchain_overloaded;
@ -282,6 +290,56 @@ implementation
TStoredSymtable
*****************************************************************************}
constructor tstoredsymtable.create(const s:string);
begin
inherited create(s);
{ the syms are owned by symlist, so don't free }
forwardchecksyms:=TFPObjectList.Create(false);
end;
destructor tstoredsymtable.destroy;
begin
inherited destroy;
{ must be after inherited destroy, because that one calls }
{ clear which also clears forwardchecksyms }
forwardchecksyms.free;
end;
procedure tstoredsymtable.clear;
begin
forwardchecksyms.clear;
inherited clear;
end;
procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true);
begin
inherited insert(sym,checkdup);
{ keep track of syms whose type may need forward resolving later on }
if (sym.typ in [typesym,fieldvarsym]) then
forwardchecksyms.add(sym);
end;
procedure tstoredsymtable.delete(sym:TSymEntry);
begin
{ this must happen before inherited() is called, because }
{ the sym is owned by symlist and will consequently be }
{ freed and invalid afterwards }
if (sym.typ in [typesym,fieldvarsym]) then
forwardchecksyms.remove(sym);
inherited delete(sym);
end;
procedure tstoredsymtable.checkforwardtype(sym:TSymEntry);
begin
forwardchecksyms.add(sym);
end;
procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
begin
{ load definitions }
@ -721,6 +779,17 @@ implementation
end;
procedure tstoredsymtable.resolve_forward_types;
var
i: longint;
begin
for i:=0 to forwardchecksyms.Count-1 do
tstoredsym(forwardchecksyms[i]).resolve_type_forward;
{ don't free, may still be reused }
forwardchecksyms.clear;
end;
{****************************************************************************
TAbstractRecordSymtable
****************************************************************************}