{ Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller This unit handles the symbol tables This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit symtable; {$i fpcdefs.inc} interface uses { common } cutils,cclasses, { global } cpuinfo,globtype,tokens, { symtable } symconst,symbase,symtype,symdef,symsym, { ppu } ppu, { assembler } aasmtai,aasmdata ; {**************************************************************************** Symtable types ****************************************************************************} type tstoredsymtable = class(TSymtable) private b_needs_init_final : boolean; procedure _needs_init_final(sym:TObject;arg:pointer); procedure check_forward(sym:TObject;arg:pointer); procedure labeldefined(sym:TObject;arg:pointer); procedure varsymbolused(sym:TObject;arg:pointer); procedure TestPrivate(sym:TObject;arg:pointer); procedure objectprivatesymbolused(sym:TObject;arg:pointer); procedure loaddefs(ppufile:tcompilerppufile); procedure loadsyms(ppufile:tcompilerppufile); procedure writedefs(ppufile:tcompilerppufile); procedure writesyms(ppufile:tcompilerppufile); public procedure insert(sym:TSymEntry;checkdup:boolean=true);override; procedure delete(sym:TSymEntry);override; { load/write } procedure ppuload(ppufile:tcompilerppufile);virtual; procedure ppuwrite(ppufile:tcompilerppufile);virtual; procedure buildderef;virtual; procedure buildderefimpl;virtual; procedure deref;virtual; procedure derefimpl;virtual; function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; procedure allsymbolsused; procedure allprivatesused; procedure check_forwards; procedure checklabels; function needs_init_final : boolean; procedure testfordefaultproperty(sym:TObject;arg:pointer); end; tabstractrecordsymtable = class(tstoredsymtable) public usefieldalignment, { alignment to use for fields (PACKRECORDS value), C_alignment is C style } recordalignment, { alignment desired when inserting this record } fieldalignment, { alignment current alignment used when fields are inserted } padalignment : shortint; { size to a multiple of which the symtable has to be rounded up } constructor create(const n:string;usealign:shortint); procedure ppuload(ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; procedure alignrecord(fieldoffset:aint;varalign:shortint); procedure addfield(sym:tfieldvarsym;vis:tvisibility); procedure addalignmentpadding; procedure insertdef(def:TDefEntry);override; function is_packed: boolean; function has_single_field(out sym:tfieldvarsym): boolean; function get_unit_symtable: tsymtable; protected _datasize : aint; { size in bits of the data in case of bitpacked record. Only important during construction, } { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8. } databitsize : aint; procedure setdatasize(val: aint); public function iscurrentunit: boolean; override; property datasize : aint read _datasize write setdatasize; end; trecordsymtable = class(tabstractrecordsymtable) public constructor create(const n:string;usealign:shortint); procedure insertunionst(unionst : trecordsymtable;offset : longint); end; tObjectSymtable = class(tabstractrecordsymtable) public constructor create(adefowner:tdef;const n:string;usealign:shortint); function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; end; { tabstractlocalsymtable } tabstractlocalsymtable = class(tstoredsymtable) public procedure ppuwrite(ppufile:tcompilerppufile);override; function count_locals:longint; end; tlocalsymtable = class(tabstractlocalsymtable) public constructor create(adefowner:tdef;level:byte); function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; end; tparasymtable = class(tabstractlocalsymtable) public constructor create(adefowner:tdef;level:byte); function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; end; tabstractuniTSymtable = class(tstoredsymtable) public constructor create(const n : string;id:word); function iscurrentunit:boolean;override; end; tglobalsymtable = class(tabstractuniTSymtable) public unittypecount : word; constructor create(const n : string;id:word); procedure ppuload(ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; end; tstaticsymtable = class(tabstractuniTSymtable) public constructor create(const n : string;id:word); procedure ppuload(ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; end; twithsymtable = class(TSymtable) withrefnode : tobject; { tnode } constructor create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode}); destructor destroy;override; procedure clear;override; procedure insertdef(def:TDefEntry);override; end; tstt_excepTSymtable = class(TSymtable) public constructor create; end; tmacrosymtable = class(tstoredsymtable) public constructor create(exported: boolean); end; { tenumsymtable } tenumsymtable = class(tstoredsymtable) public procedure insert(sym: TSymEntry; checkdup: boolean = true); override; constructor create(adefowner:tdef); end; var systemunit : tglobalsymtable; { pointer to the system unit } {**************************************************************************** Functions ****************************************************************************} {*** Misc ***} function FullTypeName(def,otherdef:tdef):string; function generate_nested_name(symtable:tsymtable;delimiter:string):string; procedure incompatibletypes(def1,def2:tdef); procedure hidesym(sym:TSymEntry); procedure duplicatesym(var hashedid:THashedIDString;dupsym,origsym:TSymEntry); {*** Search ***} procedure addsymref(sym:tsym); function is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean; function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean; function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean; function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean; function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean; function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean; function search_system_type(const s: TIDString): ttypesym; function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym; function search_struct_member(pd : tabstractrecorddef;const s : string):tsym; function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef; function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef; function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; {Looks for macro s (must be given in upper case) in the macrosymbolstack, } {and returns it if found. Returns nil otherwise.} function search_macro(const s : string):tsym; { Additionally to searching for a macro, also checks whether it's still } { actually defined (could be disable using "undef") } function defined_macro(const s : string):boolean; {*** Object Helpers ***} function search_default_property(pd : tobjectdef) : tpropertysym; function find_real_objcclass_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef; {*** Macro Helpers ***} {If called initially, the following procedures manipulate macros in } {initialmacrotable, otherwise they manipulate system macros local to a module.} {Name can be given in any case (it will be converted to upper case).} procedure def_system_macro(const name : string); procedure set_system_macro(const name, value : string); procedure set_system_compvar(const name, value : string); procedure undef_system_macro(const name : string); {*** symtable stack ***} { $ifdef DEBUG procedure test_symtablestack; procedure list_symtablestack; $endif DEBUG} {$ifdef UNITALIASES} type punit_alias = ^tunit_alias; tunit_alias = object(TNamedIndexItem) newname : pshortstring; constructor init(const n:string); destructor done;virtual; end; var unitaliases : pdictionary; procedure addunitalias(const n:string); function getunitalias(const n:string):string; {$endif UNITALIASES} {*** Init / Done ***} procedure IniTSymtable; procedure DoneSymtable; const overloaded_names : array [NOTOKEN..last_overloaded] of string[16] = ( { NOTOKEN } 'error', { _PLUS } 'plus', { _MINUS } 'minus', { _STAR } 'star', { _SLASH } 'slash', { _EQ } 'equal', { _GT } 'greater', { _LT } 'lower', { _GTE } 'greater_or_equal', { _LTE } 'lower_or_equal', { _NE } 'not_equal', { _SYMDIF } 'sym_diff', { _STARSTAR } 'starstar', { _OP_AS } 'as', { _OP_IN } 'in', { _OP_IS } 'is', { _OP_OR } 'or', { _OP_AND } 'and', { _OP_DIV } 'div', { _OP_MOD } 'mod', { _OP_NOT } 'not', { _OP_SHL } 'shl', { _OP_SHR } 'shr', { _OP_XOR } 'xor', { _ASSIGNMENT } 'assign', { _OP_EXPLICIT } 'explicit', { _OP_ENUMERATOR } 'enumerator', { _OP_INC } 'inc', { _OP_DEC } 'dec'); implementation uses { global } verbose,globals, { target } systems, { symtable } symutil,defcmp,defutil, { module } fmodule, { codegen } procinfo ; var dupnr : longint; { unique number for duplicate symbols } {***************************************************************************** TStoredSymtable *****************************************************************************} procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true); begin inherited insert(sym,checkdup); end; procedure tstoredsymtable.delete(sym:TSymEntry); begin inherited delete(sym); end; procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile); begin { load definitions } loaddefs(ppufile); { load symbols } loadsyms(ppufile); end; procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile); begin { write definitions } writedefs(ppufile); { write symbols } writesyms(ppufile); end; procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile); var def : tdef; b : byte; begin { load start of definition section, which holds the amount of defs } if ppufile.readentry<>ibstartdefs then Message(unit_f_ppu_read_error); { read definitions } repeat b:=ppufile.readentry; case b of ibpointerdef : def:=tpointerdef.ppuload(ppufile); ibarraydef : def:=tarraydef.ppuload(ppufile); iborddef : def:=torddef.ppuload(ppufile); ibfloatdef : def:=tfloatdef.ppuload(ppufile); ibprocdef : def:=tprocdef.ppuload(ppufile); ibshortstringdef : def:=tstringdef.loadshort(ppufile); iblongstringdef : def:=tstringdef.loadlong(ppufile); ibansistringdef : def:=tstringdef.loadansi(ppufile); ibwidestringdef : def:=tstringdef.loadwide(ppufile); ibunicodestringdef : def:=tstringdef.loadunicode(ppufile); ibrecorddef : def:=trecorddef.ppuload(ppufile); ibobjectdef : def:=tobjectdef.ppuload(ppufile); ibenumdef : def:=tenumdef.ppuload(ppufile); ibsetdef : def:=tsetdef.ppuload(ppufile); ibprocvardef : def:=tprocvardef.ppuload(ppufile); ibfiledef : def:=tfiledef.ppuload(ppufile); ibclassrefdef : def:=tclassrefdef.ppuload(ppufile); ibformaldef : def:=tformaldef.ppuload(ppufile); ibvariantdef : def:=tvariantdef.ppuload(ppufile); ibundefineddef : def:=tundefineddef.ppuload(ppufile); ibenddefs : break; ibend : Message(unit_f_ppu_read_error); else Message1(unit_f_ppu_invalid_entry,tostr(b)); end; InsertDef(def); until false; end; procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile); var b : byte; sym : tsym; begin { load start of definition section, which holds the amount of defs } if ppufile.readentry<>ibstartsyms then Message(unit_f_ppu_read_error); { now read the symbols } repeat b:=ppufile.readentry; case b of ibtypesym : sym:=ttypesym.ppuload(ppufile); ibprocsym : sym:=tprocsym.ppuload(ppufile); ibconstsym : sym:=tconstsym.ppuload(ppufile); ibstaticvarsym : sym:=tstaticvarsym.ppuload(ppufile); iblocalvarsym : sym:=tlocalvarsym.ppuload(ppufile); ibparavarsym : sym:=tparavarsym.ppuload(ppufile); ibfieldvarsym : sym:=tfieldvarsym.ppuload(ppufile); ibabsolutevarsym : sym:=tabsolutevarsym.ppuload(ppufile); ibenumsym : sym:=tenumsym.ppuload(ppufile); ibpropertysym : sym:=tpropertysym.ppuload(ppufile); ibunitsym : sym:=tunitsym.ppuload(ppufile); iblabelsym : sym:=tlabelsym.ppuload(ppufile); ibsyssym : sym:=tsyssym.ppuload(ppufile); ibmacrosym : sym:=tmacro.ppuload(ppufile); ibendsyms : break; ibend : Message(unit_f_ppu_read_error); else Message1(unit_f_ppu_invalid_entry,tostr(b)); end; Insert(sym,false); until false; end; procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile); var i : longint; def : tstoreddef; begin { each definition get a number, write then the amount of defs to the ibstartdef entry } ppufile.putlongint(DefList.count); ppufile.writeentry(ibstartdefs); { now write the definition } for i:=0 to DefList.Count-1 do begin def:=tstoreddef(DefList[i]); def.ppuwrite(ppufile); end; { write end of definitions } ppufile.writeentry(ibenddefs); end; procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile); var i : longint; sym : Tstoredsym; begin { each definition get a number, write then the amount of syms and the datasize to the ibsymdef entry } ppufile.putlongint(SymList.count); ppufile.writeentry(ibstartsyms); { foreach is used to write all symbols } for i:=0 to SymList.Count-1 do begin sym:=tstoredsym(SymList[i]); sym.ppuwrite(ppufile); end; { end of symbols } ppufile.writeentry(ibendsyms); end; procedure tstoredsymtable.buildderef; var i : longint; def : tstoreddef; sym : tstoredsym; begin { interface definitions } for i:=0 to DefList.Count-1 do begin def:=tstoreddef(DefList[i]); def.buildderef; end; { interface symbols } for i:=0 to SymList.Count-1 do begin sym:=tstoredsym(SymList[i]); sym.buildderef; end; end; procedure tstoredsymtable.buildderefimpl; var i : longint; def : tstoreddef; begin { implementation definitions } for i:=0 to DefList.Count-1 do begin def:=tstoreddef(DefList[i]); def.buildderefimpl; end; end; procedure tstoredsymtable.deref; var i : longint; def : tstoreddef; sym : tstoredsym; begin { first deref the interface ttype symbols. This is needs to be done before the interface defs are derefed, because the interface defs can contain references to the type symbols which then already need to contain a resolved typedef field (PFV) } for i:=0 to SymList.Count-1 do begin sym:=tstoredsym(SymList[i]); if sym.typ=typesym then sym.deref; end; { interface definitions } for i:=0 to DefList.Count-1 do begin def:=tstoreddef(DefList[i]); def.deref; end; { interface symbols } for i:=0 to SymList.Count-1 do begin sym:=tstoredsym(SymList[i]); if sym.typ<>typesym then sym.deref; end; end; procedure tstoredsymtable.derefimpl; var i : longint; def : tstoreddef; begin { implementation definitions } for i:=0 to DefList.Count-1 do begin def:=tstoreddef(DefList[i]); def.derefimpl; end; end; function tstoredsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; var hsym : tsym; begin hsym:=tsym(FindWithHash(hashedid)); if assigned(hsym) then DuplicateSym(hashedid,sym,hsym); result:=assigned(hsym); end; {************************************** Callbacks **************************************} procedure TStoredSymtable.check_forward(sym:TObject;arg:pointer); begin if tsym(sym).typ=procsym then tprocsym(sym).check_forward { check also object method table } { we needn't to test the def list } { because each object has to have a type sym, only test objects declarations, not type renamings } else if (tsym(sym).typ=typesym) and assigned(ttypesym(sym).typedef) and (ttypesym(sym).typedef.typesym=ttypesym(sym)) and (ttypesym(sym).typedef.typ in [objectdef,recorddef]) then tabstractrecorddef(ttypesym(sym).typedef).check_forwards; end; procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer); begin if (tsym(sym).typ=labelsym) and not(tlabelsym(sym).defined) then begin if tlabelsym(sym).used then Message1(sym_e_label_used_and_not_defined,tlabelsym(sym).realname) else Message1(sym_w_label_not_defined,tlabelsym(sym).realname); end; end; procedure TStoredSymtable.varsymbolused(sym:TObject;arg:pointer); begin if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and ((tsym(sym).owner.symtabletype in [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then begin { unused symbol should be reported only if no } { error is reported } { if the symbol is in a register it is used } { also don't count the value parameters which have local copies } { also don't claim for high param of open parameters (PM) } if (Errorcount<>0) or ([vo_is_hidden_para,vo_is_funcret] * tabstractvarsym(sym).varoptions = [vo_is_hidden_para]) or (sp_internal in tsym(sym).symoptions) then exit; if (tstoredsym(sym).refs=0) then begin if (vo_is_funcret in tabstractvarsym(sym).varoptions) then begin { don't warn about the result of constructors } if ((tsym(sym).owner.symtabletype<>localsymtable) or (tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and not(cs_opt_nodedfa in current_settings.optimizerswitches) then MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set) end else if (tsym(sym).owner.symtabletype=parasymtable) then MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname) else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname) else MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname); end else if tabstractvarsym(sym).varstate in [vs_written,vs_initialised] then begin if (tsym(sym).owner.symtabletype=parasymtable) then begin if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and not(vo_is_funcret in tabstractvarsym(sym).varoptions) then MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname) end else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname) else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname); end else if (tabstractvarsym(sym).varstate = vs_read_not_warned) and ([vo_is_public,vo_is_external] * tabstractvarsym(sym).varoptions = []) then MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname) end else if ((tsym(sym).owner.symtabletype in [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then begin if (Errorcount<>0) or (sp_internal in tsym(sym).symoptions) then exit; { do not claim for inherited private fields !! } if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then case tsym(sym).typ of typesym: MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname); constsym: MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname); propertysym: MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname); else MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname); end { units references are problematic } else begin if (tsym(sym).refs=0) and not(tsym(sym).typ in [enumsym,unitsym]) and not(is_funcret_sym(tsym(sym))) and { don't complain about compiler generated syms for specializations, see also #13405 } not((tsym(sym).typ=typesym) and (df_specialization in ttypesym(sym).typedef.defoptions) and (pos('$',ttypesym(sym).Realname)<>0)) and ( (tsym(sym).typ<>procsym) or ((tsym(sym).owner.symtabletype=staticsymtable) and not current_module.is_unit) ) and { don't complain about alias for hidden _cmd parameter to obj-c methods } not((tsym(sym).typ in [localvarsym,paravarsym,absolutevarsym]) and (vo_is_msgsel in tabstractvarsym(sym).varoptions)) then MessagePos2(tsym(sym).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(sym).typ],tsym(sym).prettyname); end; end; end; procedure TStoredSymtable.TestPrivate(sym:TObject;arg:pointer); begin if tsym(sym).visibility in [vis_private,vis_strictprivate] then varsymbolused(sym,arg); end; procedure TStoredSymtable.objectprivatesymbolused(sym:TObject;arg:pointer); begin { Don't test simple object aliases PM } if (tsym(sym).typ=typesym) and (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and (ttypesym(sym).typedef.typesym=tsym(sym)) then tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil); end; procedure tstoredsymtable.testfordefaultproperty(sym:TObject;arg:pointer); begin if (tsym(sym).typ=propertysym) and (ppo_defaultproperty in tpropertysym(sym).propoptions) then ppointer(arg)^:=sym; end; {*********************************************** Process all entries ***********************************************} { checks, if all procsyms and methods are defined } procedure tstoredsymtable.check_forwards; begin SymList.ForEachCall(@check_forward,nil); end; procedure tstoredsymtable.checklabels; begin SymList.ForEachCall(@labeldefined,nil); end; procedure tstoredsymtable.allsymbolsused; begin SymList.ForEachCall(@varsymbolused,nil); end; procedure tstoredsymtable.allprivatesused; begin SymList.ForEachCall(@objectprivatesymbolused,nil); end; procedure TStoredSymtable._needs_init_final(sym:TObject;arg:pointer); begin if b_needs_init_final then exit; { don't check static symbols - they can be present in structures only and always have a reference to a symbol defined on unit level } if sp_static in tsym(sym).symoptions then exit; case tsym(sym).typ of fieldvarsym, staticvarsym, localvarsym, paravarsym : begin if is_managed_type(tabstractvarsym(sym).vardef) then b_needs_init_final:=true; end; end; end; { returns true, if p contains data which needs init/final code } function tstoredsymtable.needs_init_final : boolean; begin b_needs_init_final:=false; SymList.ForEachCall(@_needs_init_final,nil); needs_init_final:=b_needs_init_final; end; {**************************************************************************** TAbstractRecordSymtable ****************************************************************************} constructor tabstractrecordsymtable.create(const n:string;usealign:shortint); begin inherited create(n); moduleid:=current_module.moduleid; _datasize:=0; databitsize:=0; recordalignment:=1; usefieldalignment:=usealign; padalignment:=1; { recordalign C_alignment means C record packing, that starts with an alignment of 1 } case usealign of C_alignment, bit_alignment: fieldalignment:=1; mac68k_alignment: fieldalignment:=2; else fieldalignment:=usealign; end; end; procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile); begin inherited ppuload(ppufile); end; procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile); var oldtyp : byte; begin oldtyp:=ppufile.entrytyp; ppufile.entrytyp:=subentryid; inherited ppuwrite(ppufile); ppufile.entrytyp:=oldtyp; end; function field2recordalignment(fieldoffs, fieldalign: aint): aint; begin { optimal alignment of the record when declaring a variable of this } { type is independent of the packrecords setting } if (fieldoffs mod fieldalign) = 0 then result:=fieldalign else if (fieldalign >= 16) and ((fieldoffs mod 16) = 0) and ((fieldalign mod 16) = 0) then result:=16 else if (fieldalign >= 8) and ((fieldoffs mod 8) = 0) and ((fieldalign mod 8) = 0) then result:=8 else if (fieldalign >= 4) and ((fieldoffs mod 4) = 0) and ((fieldalign mod 4) = 0) then result:=4 else if (fieldalign >= 2) and ((fieldoffs mod 2) = 0) and ((fieldalign mod 2) = 0) then result:=2 else result:=1; end; procedure tabstractrecordsymtable.alignrecord(fieldoffset:aint;varalign:shortint); var varalignrecord: shortint; begin case usefieldalignment of C_alignment: varalignrecord:=used_align(varalign,current_settings.alignment.recordalignmin,current_settings.alignment.maxCrecordalign); mac68k_alignment: varalignrecord:=2; else varalignrecord:=field2recordalignment(fieldoffset,varalign); end; recordalignment:=max(recordalignment,varalignrecord); end; procedure tabstractrecordsymtable.addfield(sym:tfieldvarsym;vis:tvisibility); var l : aint; varalignfield, varalign : shortint; vardef : tdef; begin if (sym.owner<>self) then internalerror(200602031); if sym.fieldoffset<>-1 then internalerror(200602032); { set visibility for the symbol } sym.visibility:=vis; { this symbol can't be loaded to a register } sym.varregable:=vr_none; { Calculate field offset } l:=sym.getsize; vardef:=sym.vardef; varalign:=vardef.alignment; case usefieldalignment of bit_alignment: begin { bitpacking only happens for ordinals, the rest is aligned at } { 1 byte (compatible with GPC/GCC) } if is_ordinal(vardef) then begin sym.fieldoffset:=databitsize; l:=sym.getpackedbitsize; end else begin databitsize:=_datasize*8; sym.fieldoffset:=databitsize; if (l>high(aint) div 8) then Message(sym_e_segment_too_large); l:=l*8; end; if varalign=0 then varalign:=size_2_align(l); recordalignment:=max(recordalignment,field2recordalignment(databitsize mod 8,varalign)); { bit packed records are limited to high(aint) bits } { instead of bytes to avoid double precision } { arithmetic in offset calculations } if int64(l)>high(aint)-sym.fieldoffset then begin Message(sym_e_segment_too_large); _datasize:=high(aint); databitsize:=high(aint); end else begin databitsize:=sym.fieldoffset+l; _datasize:=(databitsize+7) div 8; end; { rest is not applicable } exit; end; { Calc the alignment size for C style records } C_alignment: begin if (varalign>4) and ((varalign mod 4)<>0) and (vardef.typ=arraydef) then Message1(sym_w_wrong_C_pack,vardef.typename); if varalign=0 then varalign:=l; if (fieldalignment16) and (fieldalignment<32) then fieldalignment:=32 else if (varalign>12) and (fieldalignment<16) then fieldalignment:=16 { 12 is needed for long double } else if (varalign>8) and (fieldalignment<12) then fieldalignment:=12 else if (varalign>4) and (fieldalignment<8) then fieldalignment:=8 else if (varalign>2) and (fieldalignment<4) then fieldalignment:=4 else if (varalign>1) and (fieldalignment<2) then fieldalignment:=2; end; fieldalignment:=min(fieldalignment,current_settings.alignment.maxCrecordalign); end; mac68k_alignment: begin { mac68k alignment (C description): * char is aligned to 1 byte * everything else (except vector) is aligned to 2 bytes * vector is aligned to 16 bytes } if l>1 then fieldalignment:=2 else fieldalignment:=1; varalign:=2; end; end; if varalign=0 then varalign:=size_2_align(l); varalignfield:=used_align(varalign,current_settings.alignment.recordalignmin,fieldalignment); sym.fieldoffset:=align(_datasize,varalignfield); if l>high(aint)-sym.fieldoffset then begin Message(sym_e_segment_too_large); _datasize:=high(aint); end else _datasize:=sym.fieldoffset+l; { Calc alignment needed for this record } alignrecord(sym.fieldoffset,varalign); end; procedure tabstractrecordsymtable.addalignmentpadding; begin { make the record size aligned correctly so it can be used as elements in an array. For C records we use the fieldalignment, because that is updated with the used alignment. } if (padalignment = 1) then case usefieldalignment of C_alignment: padalignment:=fieldalignment; { bitpacked } bit_alignment: padalignment:=1; { mac68k: always round to multiple of 2 } mac68k_alignment: padalignment:=2; { default/no packrecords specified } 0: padalignment:=recordalignment { specific packrecords setting -> use as upper limit } else padalignment:=min(recordalignment,usefieldalignment); end; _datasize:=align(_datasize,padalignment); end; procedure tabstractrecordsymtable.insertdef(def:TDefEntry); begin { Enums must also be available outside the record scope, insert in the owner of this symtable } if def.typ=enumdef then defowner.owner.insertdef(def) else inherited insertdef(def); end; function tabstractrecordsymtable.is_packed: boolean; begin result:=usefieldalignment=bit_alignment; end; function tabstractrecordsymtable.has_single_field(out sym: tfieldvarsym): boolean; var i: longint; begin result:=false; { If a record contains a union, it does not contain a "single non-composite field" in the context of certain ABIs requiring special treatment for such records } if (defowner.typ=recorddef) and trecorddef(defowner).isunion then exit; { a record/object can contain other things than fields } for i:=0 to SymList.Count-1 do begin if tsym(symlist[i]).typ=fieldvarsym then begin if result then begin result:=false; exit; end; result:=true; sym:=tfieldvarsym(symlist[i]) end; end; end; function tabstractrecordsymtable.get_unit_symtable: tsymtable; begin result:=defowner.owner; while assigned(result) and (result.symtabletype in [ObjectSymtable,recordsymtable]) do result:=result.defowner.owner; end; procedure tabstractrecordsymtable.setdatasize(val: aint); begin _datasize:=val; if (usefieldalignment=bit_alignment) then { can overflow in non bitpacked records } databitsize:=val*8; end; function tabstractrecordsymtable.iscurrentunit: boolean; begin Result := Assigned(current_module) and (current_module.moduleid=moduleid); end; {**************************************************************************** TRecordSymtable ****************************************************************************} constructor trecordsymtable.create(const n:string;usealign:shortint); begin inherited create(n,usealign); symtabletype:=recordsymtable; end; { this procedure is reserved for inserting case variant into a record symtable } { the offset is the location of the start of the variant and datasize and dataalignment corresponds to the complete size (see code in pdecl unit) PM } procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : longint); var sym : tsym; def : tdef; i : integer; varalignrecord,varalign, storesize,storealign : aint; bitsize: aint; begin storesize:=_datasize; storealign:=fieldalignment; _datasize:=offset; if (usefieldalignment=bit_alignment) then databitsize:=offset*8; { We move the ownership of the defs and symbols to the new recordsymtable. The old unionsymtable keeps the references, but doesn't own the objects anymore } unionst.DefList.OwnsObjects:=false; unionst.SymList.OwnsObjects:=false; { copy symbols } for i:=0 to unionst.SymList.Count-1 do begin sym:=TSym(unionst.SymList[i]); if sym.typ<>fieldvarsym then internalerror(200601272); if tfieldvarsym(sym).fieldoffset=0 then include(tfieldvarsym(sym).varoptions,vo_is_first_field); { add to this record symtable } // unionst.SymList.List.List^[i].Data:=nil; sym.ChangeOwner(self); varalign:=tfieldvarsym(sym).vardef.alignment; if varalign=0 then varalign:=size_2_align(tfieldvarsym(sym).getsize); { retrieve size } if (usefieldalignment=bit_alignment) then begin { bit packed records are limited to high(aint) bits } { instead of bytes to avoid double precision } { arithmetic in offset calculations } if is_ordinal(tfieldvarsym(sym).vardef) then bitsize:=tfieldvarsym(sym).getpackedbitsize else begin bitsize:=tfieldvarsym(sym).getsize; if (bitsize>high(aint) div 8) then Message(sym_e_segment_too_large); bitsize:=bitsize*8; end; if bitsize>high(aint)-databitsize then begin Message(sym_e_segment_too_large); _datasize:=high(aint); databitsize:=high(aint); end else begin databitsize:=tfieldvarsym(sym).fieldoffset+offset*8; _datasize:=(databitsize+7) div 8; end; tfieldvarsym(sym).fieldoffset:=databitsize; varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset div 8,varalign); end else begin if tfieldvarsym(sym).getsize>high(aint)-_datasize then begin Message(sym_e_segment_too_large); _datasize:=high(aint); end else _datasize:=tfieldvarsym(sym).fieldoffset+offset; { update address } tfieldvarsym(sym).fieldoffset:=_datasize; varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset,varalign); end; { update alignment of this record } if (usefieldalignment<>C_alignment) and (usefieldalignment<>mac68k_alignment) then recordalignment:=max(recordalignment,varalignrecord); end; { update alignment for C records } if (usefieldalignment=C_alignment) and (usefieldalignment<>mac68k_alignment) then recordalignment:=max(recordalignment,unionst.recordalignment); { Register defs in the new record symtable } for i:=0 to unionst.DefList.Count-1 do begin def:=TDef(unionst.DefList[i]); def.ChangeOwner(self); end; _datasize:=storesize; fieldalignment:=storealign; { If a record contains a union, it does not contain a "single non-composite field" in the context of certain ABIs requiring special treatment for such records } if defowner.typ=recorddef then trecorddef(defowner).isunion:=true; end; {**************************************************************************** TObjectSymtable ****************************************************************************} constructor tObjectSymtable.create(adefowner:tdef;const n:string;usealign:shortint); begin inherited create(n,usealign); symtabletype:=ObjectSymtable; defowner:=adefowner; end; function tObjectSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; var hsym : tsym; begin result:=false; if not assigned(defowner) then internalerror(200602061); { procsym and propertysym have special code to override values in inherited classes. For other symbols check for duplicates } if not(sym.typ in [procsym,propertysym]) then begin { but private ids can be reused } hsym:=search_struct_member(tobjectdef(defowner),hashedid.id); if assigned(hsym) and ( ( not(m_delphi in current_settings.modeswitches) and is_visible_for_object(hsym,tobjectdef(defowner)) ) or ( { In Delphi, you can repeat members of a parent class. You can't } { do this for objects however, and you (obviouly) can't } { declare two fields with the same name in a single class } (m_delphi in current_settings.modeswitches) and ( is_object(tdef(defowner)) or (hsym.owner = self) ) ) ) then begin DuplicateSym(hashedid,sym,hsym); result:=true; end; end else begin if not(m_duplicate_names in current_settings.modeswitches) then result:=inherited checkduplicate(hashedid,sym); end; end; {**************************************************************************** TAbstractLocalSymtable ****************************************************************************} procedure tabstractlocalsymtable.ppuwrite(ppufile:tcompilerppufile); var oldtyp : byte; begin oldtyp:=ppufile.entrytyp; ppufile.entrytyp:=subentryid; { write definitions } writedefs(ppufile); { write symbols } writesyms(ppufile); ppufile.entrytyp:=oldtyp; end; function tabstractlocalsymtable.count_locals:longint; var i : longint; sym : tsym; begin result:=0; for i:=0 to SymList.Count-1 do begin sym:=tsym(SymList[i]); { Count only varsyms, but ignore the funcretsym } if (tsym(sym).typ in [localvarsym,paravarsym]) and (tsym(sym)<>current_procinfo.procdef.funcretsym) and (not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or (tstoredsym(sym).refs>0)) then inc(result); end; end; {**************************************************************************** TLocalSymtable ****************************************************************************} constructor tlocalsymtable.create(adefowner:tdef;level:byte); begin inherited create(''); defowner:=adefowner; symtabletype:=localsymtable; symtablelevel:=level; end; function tlocalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; var hsym : tsym; begin if not assigned(defowner) or (defowner.typ<>procdef) then internalerror(200602042); result:=false; hsym:=tsym(FindWithHash(hashedid)); if assigned(hsym) then begin { a local and the function can have the same name in TP and Delphi, but RESULT not } if (m_duplicate_names in current_settings.modeswitches) and (hsym.typ in [absolutevarsym,localvarsym]) and (vo_is_funcret in tabstractvarsym(hsym).varoptions) and not((m_result in current_settings.modeswitches) and (vo_is_result in tabstractvarsym(hsym).varoptions)) then HideSym(hsym) else DuplicateSym(hashedid,sym,hsym); result:=true; exit; end; { check also parasymtable, this needs to be done here because of the special situation with the funcret sym that needs to be hidden for tp and delphi modes } hsym:=tsym(tabstractprocdef(defowner).parast.FindWithHash(hashedid)); if assigned(hsym) then begin { a local and the function can have the same name in TP and Delphi, but RESULT not } if (m_duplicate_names in current_settings.modeswitches) and (sym.typ in [absolutevarsym,localvarsym]) and (vo_is_funcret in tabstractvarsym(sym).varoptions) and not((m_result in current_settings.modeswitches) and (vo_is_result in tabstractvarsym(sym).varoptions)) then Hidesym(sym) else DuplicateSym(hashedid,sym,hsym); result:=true; exit; end; { check ObjectSymtable, skip this for funcret sym because that will always be positive because it has the same name as the procsym } if not is_funcret_sym(sym) and (defowner.typ=procdef) and assigned(tprocdef(defowner).struct) and (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and ( not(m_delphi in current_settings.modeswitches) or is_object(tprocdef(defowner).struct) ) then result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym); end; {**************************************************************************** TParaSymtable ****************************************************************************} constructor tparasymtable.create(adefowner:tdef;level:byte); begin inherited create(''); defowner:=adefowner; symtabletype:=parasymtable; symtablelevel:=level; end; function tparasymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; begin result:=inherited checkduplicate(hashedid,sym); if result then exit; if not(m_duplicate_names in current_settings.modeswitches) and (defowner.typ=procdef) and assigned(tprocdef(defowner).struct) and (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and ( not(m_delphi in current_settings.modeswitches) or is_object(tprocdef(defowner).struct) ) then result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym); end; {**************************************************************************** TAbstractUniTSymtable ****************************************************************************} constructor tabstractuniTSymtable.create(const n : string;id:word); begin inherited create(n); moduleid:=id; end; function tabstractuniTSymtable.iscurrentunit:boolean; begin result:=assigned(current_module) and ( (current_module.globalsymtable=self) or (current_module.localsymtable=self) ); end; {**************************************************************************** TStaticSymtable ****************************************************************************} constructor tstaticsymtable.create(const n : string;id:word); begin inherited create(n,id); symtabletype:=staticsymtable; symtablelevel:=main_program_level; end; procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile); begin inherited ppuload(ppufile); { now we can deref the syms and defs } deref; end; procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile); begin inherited ppuwrite(ppufile); end; function tstaticsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; var hsym : tsym; begin result:=false; hsym:=tsym(FindWithHash(hashedid)); if assigned(hsym) then begin { Delphi (contrary to TP) you can have a symbol with the same name as the unit, the unit can then not be accessed anymore using ., so we can hide the symbol } if (m_delphi in current_settings.modeswitches) and (hsym.typ=symconst.unitsym) then HideSym(hsym) else DuplicateSym(hashedid,sym,hsym); result:=true; exit; end; if (current_module.localsymtable=self) and assigned(current_module.globalsymtable) then result:=tglobalsymtable(current_module.globalsymtable).checkduplicate(hashedid,sym); end; {**************************************************************************** TGlobalSymtable ****************************************************************************} constructor tglobalsymtable.create(const n : string;id:word); begin inherited create(n,id); symtabletype:=globalsymtable; symtablelevel:=main_program_level; end; procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile); begin inherited ppuload(ppufile); { now we can deref the syms and defs } deref; end; procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile); begin { write the symtable entries } inherited ppuwrite(ppufile); end; function tglobalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; var hsym : tsym; begin result:=false; hsym:=tsym(FindWithHash(hashedid)); if assigned(hsym) then begin { Delphi (contrary to TP) you can have a symbol with the same name as the unit, the unit can then not be accessed anymore using ., so we can hide the symbol } if (m_delphi in current_settings.modeswitches) and (hsym.typ=symconst.unitsym) then HideSym(hsym) else DuplicateSym(hashedid,sym,hsym); result:=true; exit; end; end; {**************************************************************************** TWITHSYMTABLE ****************************************************************************} constructor twithsymtable.create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode}); begin inherited create(''); symtabletype:=withsymtable; withrefnode:=refnode; { Replace SymList with the passed symlist } SymList.free; SymList:=ASymList; defowner:=aowner; end; destructor twithsymtable.destroy; begin withrefnode.free; { Disable SymList because we don't Own it } SymList:=nil; inherited destroy; end; procedure twithsymtable.clear; begin { remove no entry from a withsymtable as it is only a pointer to the recorddef or objectdef symtable } end; procedure twithsymtable.insertdef(def:TDefEntry); begin { Definitions can't be registered in the withsymtable because the withsymtable is removed after the with block. We can't easily solve it here because the next symtable in the stack is not known. } internalerror(200602046); end; {**************************************************************************** TSTT_ExceptionSymtable ****************************************************************************} constructor tstt_excepTSymtable.create; begin inherited create(''); symtabletype:=stt_excepTSymtable; end; {**************************************************************************** TMacroSymtable ****************************************************************************} constructor tmacrosymtable.create(exported: boolean); begin inherited create(''); if exported then symtabletype:=exportedmacrosymtable else symtabletype:=localmacrosymtable; symtablelevel:=main_program_level; end; {**************************************************************************** TEnumSymtable ****************************************************************************} procedure tenumsymtable.insert(sym: TSymEntry; checkdup: boolean); var value: longint; def: tenumdef; begin // defowner = nil only when we are loading from ppu if defowner<>nil then begin { First entry? Then we need to set the minval } value:=tenumsym(sym).value; def:=tenumdef(defowner); if SymList.count=0 then begin if value>0 then def.has_jumps:=true; def.setmin(value); def.setmax(value); end else begin { check for jumps } if value>def.max+1 then def.has_jumps:=true; { update low and high } if def.min>value then def.setmin(value); if def.max=current_module.unitmapsize then internalerror(200501152); inc(current_module.unitmap[tglobalsymtable(sym.owner).moduleid].refs); end; end; function is_owned_by(childdef,ownerdef:tabstractrecorddef):boolean; begin result:=childdef=ownerdef; if not result and (childdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) then result:=is_owned_by(tabstractrecorddef(childdef.owner.defowner),ownerdef); end; function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean; var symownerdef : tabstractrecorddef; begin result:=false; { Get objdectdef owner of the symtable for the is_related checks } if not assigned(symst) or not (symst.symtabletype in [objectsymtable,recordsymtable]) then internalerror(200810285); symownerdef:=tabstractrecorddef(symst.defowner); case symvisibility of vis_private : begin { private symbols are allowed when we are in the same module as they are defined } result:=( (symownerdef.owner.symtabletype in [globalsymtable,staticsymtable]) and (symownerdef.owner.iscurrentunit) ) or ( // the case of specialize inside the generic declaration (symownerdef.owner.symtabletype = objectsymtable) and ( assigned(current_structdef) and ( (current_structdef=symownerdef) or (current_structdef.owner.iscurrentunit) ) ) or ( not assigned(current_structdef) and (symownerdef.owner.iscurrentunit) ) ); end; vis_strictprivate : begin result:=assigned(current_structdef) and is_owned_by(current_structdef,symownerdef); end; vis_strictprotected : begin result:=assigned(current_structdef) and (current_structdef.is_related(symownerdef) or is_owned_by(current_structdef,symownerdef)); end; vis_protected : begin { protected symbols are visible in the module that defines them and also visible to related objects. The related object must be defined in the current module } result:=( ( (symownerdef.owner.symtabletype in [globalsymtable,staticsymtable]) and (symownerdef.owner.iscurrentunit) ) or ( assigned(contextobjdef) and (contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable]) and (contextobjdef.owner.iscurrentunit) and contextobjdef.is_related(symownerdef) ) or ( // the case of specialize inside the generic declaration (symownerdef.owner.symtabletype = objectsymtable) and ( assigned(current_structdef) and ( (current_structdef=symownerdef) or (current_structdef.owner.iscurrentunit) ) ) or ( not assigned(current_structdef) and (symownerdef.owner.iscurrentunit) ) ) ); end; vis_public, vis_published : result:=true; end; end; function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean; begin result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef); end; function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean; var i : longint; pd : tprocdef; begin if sym.typ=procsym then begin { A procsym is visible, when there is at least one of the procdefs visible } result:=false; for i:=0 to tprocsym(sym).ProcdefList.Count-1 do begin pd:=tprocdef(tprocsym(sym).ProcdefList[i]); if (pd.owner=sym.owner) and is_visible_for_object(pd,contextobjdef) then begin result:=true; exit; end; end; end else result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef); end; function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var hashedid : THashedIDString; contextstructdef : tabstractrecorddef; stackitem : psymtablestackitem; begin result:=false; hashedid.id:=s; stackitem:=symtablestack.stack; while assigned(stackitem) do begin srsymtable:=stackitem^.symtable; if (srsymtable.symtabletype=objectsymtable) then begin if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable) then begin result:=true; exit; end; end else begin srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) then begin { use the class from withsymtable only when it is defined in this unit } if (srsymtable.symtabletype=withsymtable) and assigned(srsymtable.defowner) and (srsymtable.defowner.typ in [recorddef,objectdef]) and (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and (srsymtable.defowner.owner.iscurrentunit) then contextstructdef:=tobjectdef(srsymtable.defowner) else contextstructdef:=current_structdef; if not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,contextstructdef) then begin { we need to know if a procedure references symbols in the static symtable, because then it can't be inlined from outside this unit } if assigned(current_procinfo) and (srsym.owner.symtabletype=staticsymtable) then include(current_procinfo.flags,pi_uses_static_symtable); addsymref(srsym); result:=true; exit; end; end; end; stackitem:=stackitem^.next; end; srsym:=nil; srsymtable:=nil; end; function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var hashedid : THashedIDString; stackitem : psymtablestackitem; classh : tobjectdef; begin result:=false; hashedid.id:=s; stackitem:=symtablestack.stack; while assigned(stackitem) do begin { It is not possible to have type symbols in: parameters Exception are classes, objects, records, generic definitions and specializations that have the parameterized types inserted in the symtable. } srsymtable:=stackitem^.symtable; if (srsymtable.symtabletype=ObjectSymtable) then begin classh:=tobjectdef(srsymtable.defowner); while assigned(classh) do begin srsymtable:=classh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and is_visible_for_object(srsym,current_structdef) then begin addsymref(srsym); result:=true; exit; end; classh:=classh.childof; end; end else if srsymtable.symtabletype<>parasymtable then begin srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and (not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,current_structdef)) then begin { we need to know if a procedure references symbols in the static symtable, because then it can't be inlined from outside this unit } if assigned(current_procinfo) and (srsym.owner.symtabletype=staticsymtable) then include(current_procinfo.flags,pi_uses_static_symtable); addsymref(srsym); result:=true; exit; end; end; stackitem:=stackitem^.next; end; result:=false; srsym:=nil; srsymtable:=nil; end; function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var pmod : tmodule; begin pmod:=tmodule(pm); result:=false; if assigned(pmod.globalsymtable) then begin srsym:=tsym(pmod.globalsymtable.Find(s)); if assigned(srsym) then begin srsymtable:=pmod.globalsymtable; addsymref(srsym); result:=true; exit; end; end; { If the module is the current unit we also need to search the local symtable } if (pmod=current_module) and assigned(pmod.localsymtable) then begin srsym:=tsym(pmod.localsymtable.Find(s)); if assigned(srsym) then begin srsymtable:=pmod.localsymtable; addsymref(srsym); result:=true; exit; end; end; srsym:=nil; srsymtable:=nil; end; function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean; var stackitem : psymtablestackitem; begin result:=false; stackitem:=symtablestack.stack; while assigned(stackitem) do begin srsymtable:=stackitem^.symtable; if (srsymtable.symtabletype=globalsymtable) and (srsymtable.name^=unitname) then begin srsym:=tsym(srsymtable.find(symname)); if not assigned(srsym) then break; result:=true; exit; end; stackitem:=stackitem^.next; end; { If the module is the current unit we also need to search the local symtable } if (current_module.globalsymtable=srsymtable) and assigned(current_module.localsymtable) then begin srsymtable:=current_module.localsymtable; srsym:=tsym(srsymtable.find(symname)); if assigned(srsym) then begin result:=true; exit; end; end; end; function find_real_objcclass_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef; var hashedid : THashedIDString; stackitem : psymtablestackitem; srsymtable : tsymtable; srsym : tsym; begin { not a formal definition -> return it } if not(oo_is_formal in pd.objectoptions) then begin result:=pd; exit; end; hashedid.id:=pd.typesym.name; stackitem:=symtablestack.stack; while assigned(stackitem) do begin srsymtable:=stackitem^.symtable; { ObjC classes can't appear in generics or as nested class definitions } if not(srsymtable.symtabletype in [recordsymtable,ObjectSymtable,parasymtable]) then begin srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and (srsym.typ=typesym) and is_objcclass(ttypesym(srsym).typedef) and not(oo_is_formal in tobjectdef(ttypesym(srsym).typedef).objectoptions) then begin result:=tobjectdef(ttypesym(srsym).typedef); if assigned(current_procinfo) and (srsym.owner.symtabletype=staticsymtable) then include(current_procinfo.flags,pi_uses_static_symtable); addsymref(srsym); exit; end; end; stackitem:=stackitem^.next; end; { nothing found: optionally give an error and return the original (empty) one } if erroronfailure then Message1(sym_e_objc_formal_class_not_resolved,pd.objrealname^); result:=pd; end; function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var hashedid : THashedIDString; orgclass : tobjectdef; i : longint; begin orgclass:=classh; { in case this is a formal objcclass, first find the real definition } if assigned(classh) then begin if (oo_is_formal in classh.objectoptions) then classh:=find_real_objcclass_definition(classh,true); { The contextclassh is used for visibility. The classh must be equal to or be a parent of contextclassh. E.g. for inherited searches the classh is the parent. } if not contextclassh.is_related(classh) then internalerror(200811161); end; result:=false; hashedid.id:=s; { an Objective-C protocol can inherit from multiple other protocols -> uses ImplementedInterfaces instead } if is_objcprotocol(classh) then begin srsymtable:=classh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and is_visible_for_object(srsym,contextclassh) then begin addsymref(srsym); result:=true; exit; end; for i:=0 to classh.ImplementedInterfaces.count-1 do begin if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable) then begin result:=true; exit; end; end; end else begin while assigned(classh) do begin srsymtable:=classh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and is_visible_for_object(srsym,contextclassh) then begin addsymref(srsym); result:=true; exit; end; classh:=classh.childof; end; end; if is_objcclass(orgclass) then result:=search_class_helper(orgclass,s,srsym,srsymtable) else begin srsym:=nil; srsymtable:=nil; end; end; function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var hashedid : THashedIDString; begin hashedid.id:=s; srsymtable:=recordh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and is_visible_for_object(srsym,recordh) then begin addsymref(srsym); result:=true; exit; end; srsym:=nil; srsymtable:=nil; end; function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; var def : tdef; i : longint; begin { in case this is a formal objcclass, first find the real definition } if assigned(classh) and (oo_is_formal in classh.objectoptions) then classh:=find_real_objcclass_definition(classh,true); result:=false; def:=nil; while assigned(classh) do begin for i:=0 to classh.symtable.DefList.Count-1 do begin def:=tstoreddef(classh.symtable.DefList[i]); { Find also all hidden private methods to be compatible with delphi, see tw6203 (PFV) } if (def.typ=procdef) and (po_msgint in tprocdef(def).procoptions) and (tprocdef(def).messageinf.i=msgid) then begin srdef:=def; srsym:=tprocdef(def).procsym; srsymtable:=classh.symtable; addsymref(srsym); result:=true; exit; end; end; classh:=classh.childof; end; srdef:=nil; srsym:=nil; srsymtable:=nil; end; function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean; var def : tdef; i : longint; begin { in case this is a formal objcclass, first find the real definition } if assigned(classh) and (oo_is_formal in classh.objectoptions) then classh:=find_real_objcclass_definition(classh,true); result:=false; def:=nil; while assigned(classh) do begin for i:=0 to classh.symtable.DefList.Count-1 do begin def:=tstoreddef(classh.symtable.DefList[i]); { Find also all hidden private methods to be compatible with delphi, see tw6203 (PFV) } if (def.typ=procdef) and (po_msgstr in tprocdef(def).procoptions) and (tprocdef(def).messageinf.str^=s) then begin srsym:=tprocdef(def).procsym; srsymtable:=classh.symtable; addsymref(srsym); result:=true; exit; end; end; classh:=classh.childof; end; srsym:=nil; srsymtable:=nil; end; function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef; const op_token:array[boolean] of ttoken=(_ASSIGNMENT,_OP_EXPLICIT); var sym : Tprocsym; hashedid : THashedIDString; curreq, besteq : tequaltype; currpd, bestpd : tprocdef; stackitem : psymtablestackitem; begin hashedid.id:=overloaded_names[op_token[explicit]]; besteq:=te_incompatible; bestpd:=nil; stackitem:=symtablestack.stack; while assigned(stackitem) do begin sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid)); if sym<>nil then begin if sym.typ<>procsym then internalerror(200402031); { if the source type is an alias then this is only the second choice, if you mess with this code, check tw4093 } currpd:=sym.find_procdef_assignment_operator(from_def,to_def,curreq); if curreq>besteq then begin besteq:=curreq; bestpd:=currpd; if (besteq=te_exact) then break; end; end; stackitem:=stackitem^.next; end; result:=bestpd; end; function search_enumerator_operator(from_def,to_def:Tdef): Tprocdef; var sym : Tprocsym; hashedid : THashedIDString; curreq, besteq : tequaltype; currpd, bestpd : tprocdef; stackitem : psymtablestackitem; begin hashedid.id:='enumerator'; besteq:=te_incompatible; bestpd:=nil; stackitem:=symtablestack.stack; while assigned(stackitem) do begin sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid)); if sym<>nil then begin if sym.typ<>procsym then internalerror(200910241); { if the source type is an alias then this is only the second choice, if you mess with this code, check tw4093 } currpd:=sym.find_procdef_enumerator_operator(from_def,to_def,curreq); if curreq>besteq then begin besteq:=curreq; bestpd:=currpd; if (besteq=te_exact) then break; end; end; stackitem:=stackitem^.next; end; result:=bestpd; end; function search_system_type(const s: TIDString): ttypesym; var sym : tsym; begin sym:=tsym(systemunit.Find(s)); if not assigned(sym) or (sym.typ<>typesym) then cgmessage1(cg_f_unknown_system_type,s); result:=ttypesym(sym); end; function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym; var srsymtable: tsymtable; sym: tsym; begin if searchsym_in_named_module(unitname,typename,sym,srsymtable) and (sym.typ=typesym) then begin result:=ttypesym(sym); exit; end else begin if throwerror then cgmessage2(cg_f_unknown_type_in_unit,typename,unitname); result:=nil; end; end; function search_class_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; var hashedid : THashedIDString; stackitem : psymtablestackitem; i : longint; defowner : tobjectdef; begin hashedid.id:=class_helper_prefix+s; stackitem:=symtablestack.stack; while assigned(stackitem) do begin srsymtable:=stackitem^.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) then begin if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or (srsym.typ<>procsym) then internalerror(2009111505); { check whether this procsym includes a helper for this particular class } for i:=0 to tprocsym(srsym).procdeflist.count-1 do begin { does pd inherit from (or is the same as) the class that this method's category extended? Warning: this list contains both category and objcclass methods (for id.randommethod), so only check category methods here } defowner:=tobjectdef(tprocdef(tprocsym(srsym).procdeflist[i]).owner.defowner); if (oo_is_classhelper in defowner.objectoptions) and pd.is_related(defowner.childof) then begin { we need to know if a procedure references symbols in the static symtable, because then it can't be inlined from outside this unit } if assigned(current_procinfo) and (srsym.owner.symtabletype=staticsymtable) then include(current_procinfo.flags,pi_uses_static_symtable); { no need to keep looking. There might be other categories that extend this, a parent or child class with a method with the same name (either overriding this one, or overridden by this one), but that doesn't matter as far as the basic procsym is concerned. } srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym; srsymtable:=srsym.owner; addsymref(srsym); result:=true; exit; end; end; end; stackitem:=stackitem^.next; end; srsym:=nil; srsymtable:=nil; result:=false; end; function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; var hashedid : THashedIDString; stackitem : psymtablestackitem; i : longint; begin hashedid.id:=class_helper_prefix+s; stackitem:=symtablestack.stack; while assigned(stackitem) do begin srsymtable:=stackitem^.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) then begin if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or (srsym.typ<>procsym) then internalerror(2009112005); { check whether this procsym includes a helper for this particular class } for i:=0 to tprocsym(srsym).procdeflist.count-1 do begin { we need to know if a procedure references symbols in the static symtable, because then it can't be inlined from outside this unit } if assigned(current_procinfo) and (srsym.owner.symtabletype=staticsymtable) then include(current_procinfo.flags,pi_uses_static_symtable); { no need to keep looking. There might be other methods with the same name, but that doesn't matter as far as the basic procsym is concerned. } srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym; { We need the symtable in which the classhelper-like sym is located, not the objectdef. The reason is that the callnode will climb the symtablestack until it encounters this symtable to start looking for overloads (and it won't find the objectsymtable in which this method sym is located srsymtable:=srsym.owner; } addsymref(srsym); result:=true; exit; end; end; stackitem:=stackitem^.next; end; srsym:=nil; srsymtable:=nil; result:=false; end; function search_struct_member(pd : tabstractrecorddef;const s : string):tsym; { searches n in symtable of pd and all anchestors } var hashedid : THashedIDString; srsym : tsym; orgpd : tabstractrecorddef; srsymtable : tsymtable; begin { in case this is a formal objcclass, first find the real definition } if (oo_is_formal in pd.objectoptions) then pd:=find_real_objcclass_definition(tobjectdef(pd),true); hashedid.id:=s; orgpd:=pd; while assigned(pd) do begin srsym:=tsym(pd.symtable.FindWithHash(hashedid)); if assigned(srsym) then begin search_struct_member:=srsym; exit; end; if pd.typ=objectdef then pd:=tobjectdef(pd).childof else pd:=nil; end; { not found, now look for class helpers } if is_objcclass(pd) then search_class_helper(tobjectdef(orgpd),s,result,srsymtable) else result:=nil; end; function search_macro(const s : string):tsym; var stackitem : psymtablestackitem; hashedid : THashedIDString; srsym : tsym; begin hashedid.id:=s; { First search the localmacrosymtable before searching the global macrosymtables from the units } if assigned(current_module) then begin srsym:=tsym(current_module.localmacrosymtable.FindWithHash(hashedid)); if assigned(srsym) then begin result:= srsym; exit; end; end; stackitem:=macrosymtablestack.stack; while assigned(stackitem) do begin srsym:=tsym(stackitem^.symtable.FindWithHash(hashedid)); if assigned(srsym) then begin result:= srsym; exit; end; stackitem:=stackitem^.next; end; result:= nil; end; function defined_macro(const s : string):boolean; var mac: tmacro; begin mac:=tmacro(search_macro(s)); if assigned(mac) then begin mac.is_used:=true; defined_macro:=mac.defined; end else defined_macro:=false; end; {**************************************************************************** Object Helpers ****************************************************************************} function search_default_property(pd : tobjectdef) : tpropertysym; { returns the default property of a class, searches also anchestors } var _defaultprop : tpropertysym; begin _defaultprop:=nil; while assigned(pd) do begin pd.symtable.SymList.ForEachCall(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop); if assigned(_defaultprop) then break; pd:=pd.childof; end; search_default_property:=_defaultprop; end; {**************************************************************************** Macro Helpers ****************************************************************************} procedure def_system_macro(const name : string); var mac : tmacro; s: string; begin if name = '' then internalerror(2004121202); s:= upper(name); mac:=tmacro(search_macro(s)); if not assigned(mac) then begin mac:=tmacro.create(s); if assigned(current_module) then current_module.localmacrosymtable.insert(mac) else initialmacrosymtable.insert(mac); end; if not mac.defined then Message1(parser_c_macro_defined,mac.name); mac.defined:=true; end; procedure set_system_macro(const name, value : string); var mac : tmacro; s: string; begin if name = '' then internalerror(2004121203); s:= upper(name); mac:=tmacro(search_macro(s)); if not assigned(mac) then begin mac:=tmacro.create(s); if assigned(current_module) then current_module.localmacrosymtable.insert(mac) else initialmacrosymtable.insert(mac); end else begin mac.is_compiler_var:=false; if assigned(mac.buftext) then freemem(mac.buftext,mac.buflen); end; Message2(parser_c_macro_set_to,mac.name,value); mac.buflen:=length(value); getmem(mac.buftext,mac.buflen); move(value[1],mac.buftext^,mac.buflen); mac.defined:=true; end; procedure set_system_compvar(const name, value : string); var mac : tmacro; s: string; begin if name = '' then internalerror(2004121204); s:= upper(name); mac:=tmacro(search_macro(s)); if not assigned(mac) then begin mac:=tmacro.create(s); mac.is_compiler_var:=true; if assigned(current_module) then current_module.localmacrosymtable.insert(mac) else initialmacrosymtable.insert(mac); end else begin mac.is_compiler_var:=true; if assigned(mac.buftext) then freemem(mac.buftext,mac.buflen); end; Message2(parser_c_macro_set_to,mac.name,value); mac.buflen:=length(value); getmem(mac.buftext,mac.buflen); move(value[1],mac.buftext^,mac.buflen); mac.defined:=true; end; procedure undef_system_macro(const name : string); var mac : tmacro; s: string; begin if name = '' then internalerror(2004121205); s:= upper(name); mac:=tmacro(search_macro(s)); if not assigned(mac) then {If not found, then it's already undefined.} else begin if mac.defined then Message1(parser_c_macro_undefined,mac.name); mac.defined:=false; mac.is_compiler_var:=false; { delete old definition } if assigned(mac.buftext) then begin freemem(mac.buftext,mac.buflen); mac.buftext:=nil; end; end; end; {$ifdef UNITALIASES} {**************************************************************************** TUNIT_ALIAS ****************************************************************************} constructor tunit_alias.create(const n:string); var i : longint; begin i:=pos('=',n); if i=0 then fail; inherited createname(Copy(n,1,i-1)); newname:=stringdup(Copy(n,i+1,255)); end; destructor tunit_alias.destroy; begin stringdispose(newname); inherited destroy; end; procedure addunitalias(const n:string); begin unitaliases^.insert(tunit_alias,init(Upper(n)))); end; function getunitalias(const n:string):string; var p : punit_alias; begin p:=punit_alias(unitaliases^.Find(Upper(n))); if assigned(p) then getunitalias:=punit_alias(p).newname^ else getunitalias:=n; end; {$endif UNITALIASES} {**************************************************************************** Init/Done Symtable ****************************************************************************} procedure InitSymtable; begin { Reset symbolstack } symtablestack:=nil; systemunit:=nil; { create error syms and def } generrorsym:=terrorsym.create; generrordef:=terrordef.create; { macros } initialmacrosymtable:=tmacrosymtable.create(false); macrosymtablestack:=TSymtablestack.create; macrosymtablestack.push(initialmacrosymtable); {$ifdef UNITALIASES} { unit aliases } unitaliases:=TFPHashObjectList.create; {$endif} { set some global vars to nil, might be important for the ide } class_tobject:=nil; interface_iunknown:=nil; rec_tguid:=nil; dupnr:=0; end; procedure DoneSymtable; begin generrorsym.owner:=nil; generrorsym.free; generrordef.owner:=nil; generrordef.free; initialmacrosymtable.free; macrosymtablestack.free; {$ifdef UNITALIASES} unitaliases.free; {$endif} end; end.