1 { 2 Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller 3 4 This unit handles the symbol tables 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 **************************************************************************** 20 } 21 unit symtable; 22 23 {$i fpcdefs.inc} 24 25 interface 26 27 uses 28 { common } 29 cutils,cclasses,globtype,tokens, 30 { symtable } 31 symconst,symbase,symtype,symdef,symsym; 32 33 34 {**************************************************************************** 35 Symtable types 36 ****************************************************************************} 37 38 type 39 tstoredsymtable = class(TSymtable) 40 private 41 init_final_check_done : boolean; 42 procedure _needs_init_final(sym:TObject;arg:pointer); 43 procedure do_init_final_check; 44 procedure check_forward(sym:TObject;arg:pointer); 45 procedure check_block_valid(def: TObject;arg:pointer); 46 procedure register_defs(def:tobject;arg:pointer); 47 procedure register_syms(sym:tobject;arg:pointer); 48 procedure labeldefined(sym:TObject;arg:pointer); 49 procedure varsymbolused(sym:TObject;arg:pointer); 50 procedure TestPrivate(sym:TObject;arg:pointer); 51 procedure objectprivatesymbolused(sym:TObject;arg:pointer); 52 procedure loaddefs(ppufile:tcompilerppufile); 53 procedure loadsyms(ppufile:tcompilerppufile); 54 procedure writedefs(ppufile:tcompilerppufile); 55 procedure writesyms(ppufile:tcompilerppufile); 56 public 57 constructor create(const s:string); 58 procedure insert(sym:TSymEntry;checkdup:boolean=true);override; 59 procedure delete(sym:TSymEntry);override; 60 { load/write } 61 procedure ppuload(ppufile:tcompilerppufile);virtual; 62 procedure ppuwrite(ppufile:tcompilerppufile);virtual; 63 procedure buildderef; 64 procedure buildderefimpl; 65 { buildderef but only for (recursively) used symbols/defs } 66 procedure buildderef_registered; 67 procedure deref(only_registered: boolean);virtual; 68 procedure derefimpl(only_registered: boolean);virtual; checkduplicatenull69 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; 70 procedure allsymbolsused; 71 procedure allprivatesused; 72 procedure check_forwards; 73 procedure checklabels; needs_init_finalnull74 function needs_init_final : boolean; virtual; has_non_trivial_initnull75 function has_non_trivial_init:boolean;virtual; 76 procedure testfordefaultproperty(sym:TObject;arg:pointer); 77 procedure register_children; 78 end; 79 80 {$ifdef llvm} 81 tllvmshadowsymtableentry = class 82 constructor create(def: tdef; fieldoffset: aint); 83 private 84 ffieldoffset: aint; 85 fdef: tdef; 86 public 87 property fieldoffset: aint read ffieldoffset; 88 property def: tdef read fdef; 89 end; 90 91 tllvmshadowsymtable = class; 92 {$endif llvm} 93 94 tmanagementoperator_offset_entry = record 95 pd : tprocdef; 96 offset : asizeint; 97 end; 98 pmanagementoperator_offset_entry = ^tmanagementoperator_offset_entry; 99 100 tabstractrecordsymtable = class(tstoredsymtable) 101 {$ifdef llvm} 102 private 103 fllvmst: tllvmshadowsymtable; getllvmshadowsymtabllnull104 function getllvmshadowsymtabll: tllvmshadowsymtable; 105 {$endif llvm} 106 public 107 usefieldalignment, { alignment to use for fields (PACKRECORDS value), C_alignment is C style } 108 recordalignment, { alignment desired when inserting this record } 109 fieldalignment, { alignment current alignment used when fields are inserted } 110 padalignment : shortint; { size to a multiple of which the symtable has to be rounded up } 111 recordalignmin, { local equivalents of global settings, so that records can } 112 maxCrecordalign: shortint; { be created with custom settings internally } 113 has_fields_with_mop : tmanagementoperators; { whether any of the fields has the need for a management operator (or one of the field's fields) } 114 constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint); 115 destructor destroy;override; 116 procedure ppuload(ppufile:tcompilerppufile);override; 117 procedure ppuwrite(ppufile:tcompilerppufile);override; 118 procedure alignrecord(fieldoffset:asizeint;varalign:shortint); 119 procedure addfield(sym:tfieldvarsym;vis:tvisibility); 120 procedure addfieldlist(list: tfpobjectlist; maybereorder: boolean); 121 { returns the field closest to this offset (may not be exact because 122 of padding; internalerrors for variant records, assumes fields are 123 ordered by increasing offset) } findfieldbyoffsetnull124 function findfieldbyoffset(offset:asizeint): tfieldvarsym; 125 procedure addalignmentpadding; 126 procedure insertdef(def:TDefEntry);override; is_packednull127 function is_packed: boolean; has_single_fieldnull128 function has_single_field(out def:tdef): boolean; get_unit_symtablenull129 function get_unit_symtable: tsymtable; 130 { collects all management operators of the specified type in list (which 131 is not cleared); the entries are copies and thus must be freed by the 132 caller } 133 procedure get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist); 134 protected 135 { size in bytes including padding } 136 _datasize : asizeint; 137 { size in bits of the data in case of bitpacked record. Only important during construction, } 138 { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8. } 139 databitsize : asizeint; 140 { size in bytes of padding } 141 _paddingsize : word; 142 { array of tmanagementoperator_offset_entry lists; only assigned if 143 they had been queried once by get_management_operator_list } 144 mop_list : array[tmanagementoperator] of tfplist; 145 procedure setdatasize(val: asizeint); getfieldoffsetnull146 function getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint; 147 procedure do_get_managementoperator_offset_list(data:tobject;arg:pointer); 148 public iscurrentunitnull149 function iscurrentunit: boolean; override; 150 property datasize : asizeint read _datasize write setdatasize; 151 property paddingsize: word read _paddingsize write _paddingsize; 152 {$ifdef llvm} 153 property llvmst: tllvmshadowsymtable read getllvmshadowsymtabll; 154 {$endif llvm} 155 end; 156 157 trecordsymtable = class(tabstractrecordsymtable) 158 public 159 { maybe someday is worth to move managementoperators to } 160 { tabstractrecordsymtable to perform management class operators for } 161 { object/classes. In XE5 and newer is possible to use class operator } 162 { for classes (like for Delphi .NET before) only for Delphi NEXTGEN } 163 managementoperators : tmanagementoperators; 164 constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint); 165 procedure insertunionst(unionst : trecordsymtable;offset : asizeint); 166 procedure includemanagementoperator(mop:tmanagementoperator); 167 end; 168 169 tObjectSymtable = class(tabstractrecordsymtable) 170 public 171 constructor create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint); checkduplicatenull172 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; 173 end; 174 175 {$ifdef llvm} 176 { llvm record definitions cannot contain variant/union parts, } 177 { you have to flatten them first. the tllvmshadowsymtable } 178 { contains a flattened version of a record/object symtable } 179 tllvmshadowsymtable = class 180 private 181 equivst: tabstractrecordsymtable; 182 curroffset: aint; getnull183 function get(f: tfieldvarsym): tllvmshadowsymtableentry; get_by_llvm_indexnull184 function get_by_llvm_index(index: longint): tllvmshadowsymtableentry; 185 public 186 symdeflist: TFPObjectList; 187 188 constructor create(st: tabstractrecordsymtable); 189 destructor destroy; override; 190 191 property entries[index: tfieldvarsym]: tllvmshadowsymtableentry read get; default; 192 { warning: do not call this with field.llvmfieldnr, as 193 field.llvmfieldnr will only be initialised when the llvm shadow 194 symtable is accessed for the first time. Use the default/entries 195 property instead in this case } 196 property entries_by_llvm_index[index: longint]: tllvmshadowsymtableentry read get_by_llvm_index; 197 private 198 // generate the table 199 procedure generate; 200 // helpers 201 procedure appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean); 202 procedure findvariantstarts(variantstarts: tfplist); 203 procedure addalignmentpadding(finalsize: aint); 204 procedure buildmapping(variantstarts: tfplist); 205 procedure buildtable(variantstarts: tfplist); 206 end; 207 {$endif llvm} 208 209 { tabstractsubsymtable } 210 211 tabstractsubsymtable = class(tstoredsymtable) 212 public 213 procedure ppuwrite(ppufile:tcompilerppufile);override; 214 end; 215 216 { tabstractlocalsymtable } 217 218 tabstractlocalsymtable = class(tabstractsubsymtable) 219 public count_localsnull220 function count_locals:longint; iscurrentunitnull221 function iscurrentunit: boolean; override; 222 end; 223 224 tlocalsymtable = class(tabstractlocalsymtable) 225 public 226 constructor create(adefowner:tdef;level:byte); checkduplicatenull227 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; 228 end; 229 230 { tparasymtable } 231 232 tparasymtable = class(tabstractlocalsymtable) 233 public 234 readonly: boolean; 235 constructor create(adefowner:tdef;level:byte); checkduplicatenull236 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; 237 procedure insertdef(def:TDefEntry);override; 238 end; 239 240 tabstractuniTSymtable = class(tstoredsymtable) 241 public 242 constructor create(const n : string;id:word); checkduplicatenull243 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; findnamespacenull244 function findnamespace(const n:string):TSymEntry;virtual; iscurrentunitnull245 function iscurrentunit:boolean;override; needs_init_finalnull246 function needs_init_final: boolean; override; 247 procedure insertunit(sym:TSymEntry); has_class_condestructorsnull248 function has_class_condestructors: boolean; 249 end; 250 251 tglobalsymtable = class(tabstractuniTSymtable) 252 public 253 unittypecount : word; 254 constructor create(const n : string;id:word); 255 procedure ppuload(ppufile:tcompilerppufile);override; 256 procedure ppuwrite(ppufile:tcompilerppufile);override; 257 end; 258 259 tstaticsymtable = class(tabstractuniTSymtable) 260 public 261 constructor create(const n : string;id:word); 262 procedure ppuload(ppufile:tcompilerppufile);override; 263 procedure ppuwrite(ppufile:tcompilerppufile);override; checkduplicatenull264 function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override; findnamespacenull265 function findnamespace(const n:string):TSymEntry;override; 266 end; 267 268 tspecializesymtable = class(tglobalsymtable) 269 public 270 constructor create(const n : string;id:word); iscurrentunitnull271 function iscurrentunit:boolean;override; 272 end; 273 274 twithsymtable = class(TSymtable) 275 withrefnode : tobject; { tnode } 276 constructor create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode}); 277 destructor destroy;override; 278 procedure clear;override; 279 procedure insertdef(def:TDefEntry);override; 280 end; 281 282 tstt_excepTSymtable = class(TSymtable) 283 public 284 constructor create; 285 end; 286 287 tmacrosymtable = class(tstoredsymtable) 288 public 289 constructor create(exported: boolean); 290 end; 291 292 { tenumsymtable } 293 294 tenumsymtable = class(tabstractsubsymtable) 295 public 296 procedure insert(sym: TSymEntry; checkdup: boolean = true); override; 297 constructor create(adefowner:tdef); 298 end; 299 300 { tarraysymtable } 301 302 tarraysymtable = class(tabstractsubsymtable) 303 public 304 procedure insertdef(def:TDefEntry);override; 305 constructor create(adefowner:tdef); 306 end; 307 308 var 309 systemunit : tglobalsymtable; { pointer to the system unit } 310 311 type 312 tsymbol_search_flag = ( 313 ssf_search_option, 314 ssf_search_helper, 315 ssf_has_inherited, 316 ssf_no_addsymref 317 ); 318 tsymbol_search_flags = set of tsymbol_search_flag; 319 320 321 {**************************************************************************** 322 Functions 323 ****************************************************************************} 324 325 {*** Misc ***} FullTypeNamenull326 function FullTypeName(def,otherdef:tdef):string; generate_nested_namenull327 function generate_nested_name(symtable:tsymtable;delimiter:string):string; 328 { def is the extended type of a helper } generate_objectpascal_helper_keynull329 function generate_objectpascal_helper_key(def:tdef):string; 330 procedure incompatibletypes(def1,def2:tdef); 331 procedure hidesym(sym:TSymEntry); 332 procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym:TSymEntry; warn: boolean); handle_generic_dummysymnull333 function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean; 334 { writes all declarations for the specified system unit symbol } 335 procedure write_system_parameter_lists(const name:string); 336 337 {*** Search ***} 338 procedure addsymref(sym:tsym); is_owned_bynull339 function is_owned_by(nesteddef,ownerdef:tdef):boolean; sym_is_owned_bynull340 function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean; defs_belong_to_same_genericnull341 function defs_belong_to_same_generic(def1,def2:tdef):boolean; get_generic_in_hierarchy_by_namenull342 function get_generic_in_hierarchy_by_name(srsym:tsym;def:tdef):tdef; return_specialization_of_genericnull343 function return_specialization_of_generic(nesteddef,genericdef:tdef;out resultdef:tdef):boolean; is_visible_for_objectnull344 function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean; is_visible_for_objectnull345 function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean; is_visible_for_objectnull346 function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean; searchsymnull347 function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; searchsym_with_flagsnull348 function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; searchsym_maybe_with_symoptionnull349 function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean; 350 { searches for a symbol with the given name that has the given option in 351 symoptions set } searchsym_with_symoptionnull352 function searchsym_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;option:tsymoption):boolean; searchsym_typenull353 function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; searchsym_in_modulenull354 function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; searchsym_in_named_modulenull355 function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean; searchsym_in_classnull356 function searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; searchsym_in_recordnull357 function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; searchsym_in_class_by_msgintnull358 function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; searchsym_in_class_by_msgstrnull359 function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean; 360 { searches symbols inside of a helper's implementation } searchsym_in_helpernull361 function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; search_system_typenull362 function search_system_type(const s: TIDString): ttypesym; try_search_system_typenull363 function try_search_system_type(const s: TIDString): ttypesym; try_search_current_module_typenull364 function try_search_current_module_type(const s: TIDString): ttypesym; search_system_procnull365 function search_system_proc(const s: TIDString): tprocdef; search_named_unit_globaltypenull366 function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym; search_struct_membernull367 function search_struct_member(pd : tabstractrecorddef;const s : string):tsym; search_struct_member_no_helpernull368 function search_struct_member_no_helper(pd : tabstractrecorddef;const s : string):tsym; search_assignment_operatornull369 function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef; search_enumerator_operatornull370 function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef; search_management_operatornull371 function search_management_operator(mop:tmanagementoperator;pd:Tdef):Tprocdef; 372 { searches for the helper definition that's currently active for pd } search_last_objectpascal_helpernull373 function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean; 374 { searches whether the symbol s is available in the currently active } 375 { helper for pd } search_objectpascal_helpernull376 function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; search_objc_helpernull377 function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; search_objc_methodnull378 function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; 379 {Looks for macro s (must be given in upper case) in the macrosymbolstack, } 380 {and returns it if found. Returns nil otherwise.} search_macronull381 function search_macro(const s : string):tsym; 382 { Additionally to searching for a macro, also checks whether it's still } 383 { actually defined (could be disable using "undef") } defined_macronull384 function defined_macro(const s : string):boolean; 385 { Look for a system procedure (no overloads supported) } 386 387 {*** Object Helpers ***} search_default_propertynull388 function search_default_property(pd : tabstractrecorddef) : tpropertysym; maybe_find_real_class_definitionnull389 function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef; find_real_class_definitionnull390 function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef; 391 392 {*** Macro Helpers ***} 393 {If called initially, the following procedures manipulate macros in } 394 {initialmacrotable, otherwise they manipulate system macros local to a module.} 395 {Name can be given in any case (it will be converted to upper case).} 396 procedure def_system_macro(const name : string); 397 procedure set_system_macro(const name, value : string); 398 procedure set_system_compvar(const name, value : string); 399 procedure undef_system_macro(const name : string); 400 401 {*** symtable stack ***} 402 { $ifdef DEBUG 403 procedure test_symtablestack; 404 procedure list_symtablestack; 405 $endif DEBUG} 406 407 {$ifdef UNITALIASES} 408 type 409 punit_alias = ^tunit_alias; 410 tunit_alias = object(TNamedIndexItem) 411 newname : pshortstring; 412 constructor init(const n:string); 413 destructor done;virtual; 414 end; 415 var 416 unitaliases : pdictionary; 417 418 procedure addunitalias(const n:string); getunitaliasnull419 function getunitalias(const n:string):string; 420 {$endif UNITALIASES} 421 422 {*** Init / Done ***} 423 procedure IniTSymtable; 424 procedure DoneSymtable; 425 426 const 427 overloaded_names : array [NOTOKEN..last_overloaded] of string[16] = ( 428 { NOTOKEN } 'error', 429 { _PLUS } 'plus', 430 { _MINUS } 'minus', 431 { _STAR } 'star', 432 { _SLASH } 'slash', 433 { _EQ } 'equal', 434 { _GT } 'greater', 435 { _LT } 'lower', 436 { _GTE } 'greater_or_equal', 437 { _LTE } 'lower_or_equal', 438 { _NE } 'not_equal', 439 { _SYMDIF } 'sym_diff', 440 { _STARSTAR } 'starstar', 441 { _OP_AS } 'as', 442 { _OP_IN } 'in', 443 { _OP_IS } 'is', 444 { _OP_OR } 'or', 445 { _OP_AND } 'and', 446 { _OP_DIV } 'div', 447 { _OP_MOD } 'mod', 448 { _OP_NOT } 'not', 449 { _OP_SHL } 'shl', 450 { _OP_SHR } 'shr', 451 { _OP_XOR } 'xor', 452 { _ASSIGNMENT } 'assign', 453 { _OP_EXPLICIT } 'explicit', 454 { _OP_ENUMERATOR } 'enumerator', 455 { _OP_INITIALIZE } 'initialize', 456 { _OP_FINALIZE } 'finalize', 457 { _OP_ADDREF } 'addref', 458 { _OP_COPY } 'copy', 459 { _OP_INC } 'inc', 460 { _OP_DEC } 'dec'); 461 462 managementoperator2tok:array[tmanagementoperator] of ttoken = ( 463 { mop_none } NOTOKEN, 464 { mop_initialize } _OP_INITIALIZE, 465 { mop_finalize } _OP_FINALIZE, 466 { mop_addref } _OP_ADDREF, 467 { mop_copy } _OP_COPY 468 ); 469 470 471 472 implementation 473 474 uses 475 { global } 476 verbose,globals, 477 { symtable } 478 symutil,defutil,defcmp,objcdef, 479 { module } 480 fmodule, 481 { codegen } 482 procinfo, 483 { ppu } 484 entfile, 485 { parser } 486 scanner 487 ; 488 489 490 var 491 dupnr : longint; { unique number for duplicate symbols } 492 493 {***************************************************************************** 494 TStoredSymtable 495 *****************************************************************************} 496 497 constructor tstoredsymtable.create(const s:string); 498 begin 499 inherited create(s); 500 { Note: this happens for the initial macro symtable, so no error here } 501 if not assigned(current_module) then 502 comment(v_debug,'Current module not available for module id') 503 else 504 moduleid:=current_module.moduleid; 505 end; 506 507 508 procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true); 509 begin 510 inherited insert(sym,checkdup); 511 init_final_check_done:=false; 512 end; 513 514 515 procedure tstoredsymtable.delete(sym:TSymEntry); 516 begin 517 inherited delete(sym); 518 init_final_check_done:=false; 519 end; 520 521 522 procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile); 523 begin 524 { load the table's flags } 525 if ppufile.readentry<>ibsymtableoptions then 526 Message(unit_f_ppu_read_error); 527 ppufile.getsmallset(tableoptions); 528 529 { load definitions } 530 loaddefs(ppufile); 531 532 { load symbols } 533 loadsyms(ppufile); 534 535 init_final_check_done:=true; 536 end; 537 538 539 procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile); 540 begin 541 { ensure that we have the sto_needs_init_final flag set if needed } 542 if not init_final_check_done then 543 needs_init_final; 544 545 { write the table's flags } 546 ppufile.putsmallset(tableoptions); 547 ppufile.writeentry(ibsymtableoptions); 548 549 { write definitions } 550 writedefs(ppufile); 551 552 { write symbols } 553 writesyms(ppufile); 554 end; 555 556 557 procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile); 558 var 559 def : tdef; 560 b : byte; 561 begin 562 def:=nil; 563 { load start of definition section, which holds the amount of defs } 564 if ppufile.readentry<>ibstartdefs then 565 Message(unit_f_ppu_read_error); 566 { read definitions } 567 repeat 568 b:=ppufile.readentry; 569 case b of 570 ibpointerdef : def:=cpointerdef.ppuload(ppufile); 571 ibarraydef : def:=carraydef.ppuload(ppufile); 572 iborddef : def:=corddef.ppuload(ppufile); 573 ibfloatdef : def:=cfloatdef.ppuload(ppufile); 574 ibprocdef : def:=cprocdef.ppuload(ppufile); 575 ibshortstringdef : def:=cstringdef.loadshort(ppufile); 576 iblongstringdef : def:=cstringdef.loadlong(ppufile); 577 ibansistringdef : def:=cstringdef.loadansi(ppufile); 578 ibwidestringdef : def:=cstringdef.loadwide(ppufile); 579 ibunicodestringdef : def:=cstringdef.loadunicode(ppufile); 580 ibrecorddef : def:=crecorddef.ppuload(ppufile); 581 ibobjectdef : def:=cobjectdef.ppuload(ppufile); 582 ibenumdef : def:=cenumdef.ppuload(ppufile); 583 ibsetdef : def:=csetdef.ppuload(ppufile); 584 ibprocvardef : def:=cprocvardef.ppuload(ppufile); 585 ibfiledef : def:=cfiledef.ppuload(ppufile); 586 ibclassrefdef : def:=cclassrefdef.ppuload(ppufile); 587 ibformaldef : def:=cformaldef.ppuload(ppufile); 588 ibvariantdef : def:=cvariantdef.ppuload(ppufile); 589 ibundefineddef : def:=cundefineddef.ppuload(ppufile); 590 ibenddefs : break; 591 ibend : Message(unit_f_ppu_read_error); 592 else 593 Message1(unit_f_ppu_invalid_entry,tostr(b)); 594 end; 595 InsertDef(def); 596 until false; 597 end; 598 599 600 procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile); 601 var 602 b : byte; 603 sym : tsym; 604 begin 605 sym:=nil; 606 { load start of definition section, which holds the amount of defs } 607 if ppufile.readentry<>ibstartsyms then 608 Message(unit_f_ppu_read_error); 609 { now read the symbols } 610 repeat 611 b:=ppufile.readentry; 612 case b of 613 ibtypesym : sym:=ctypesym.ppuload(ppufile); 614 ibprocsym : sym:=cprocsym.ppuload(ppufile); 615 ibconstsym : sym:=cconstsym.ppuload(ppufile); 616 ibstaticvarsym : sym:=cstaticvarsym.ppuload(ppufile); 617 iblocalvarsym : sym:=clocalvarsym.ppuload(ppufile); 618 ibparavarsym : sym:=cparavarsym.ppuload(ppufile); 619 ibfieldvarsym : sym:=cfieldvarsym.ppuload(ppufile); 620 ibabsolutevarsym : sym:=cabsolutevarsym.ppuload(ppufile); 621 ibenumsym : sym:=cenumsym.ppuload(ppufile); 622 ibpropertysym : sym:=cpropertysym.ppuload(ppufile); 623 ibunitsym : sym:=cunitsym.ppuload(ppufile); 624 iblabelsym : sym:=clabelsym.ppuload(ppufile); 625 ibsyssym : sym:=csyssym.ppuload(ppufile); 626 ibmacrosym : sym:=tmacro.ppuload(ppufile); 627 ibnamespacesym : sym:=cnamespacesym.ppuload(ppufile); 628 ibendsyms : break; 629 ibend : Message(unit_f_ppu_read_error); 630 else 631 Message1(unit_f_ppu_invalid_entry,tostr(b)); 632 end; 633 Insert(sym,false); 634 until false; 635 end; 636 637 638 procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile); 639 var 640 defcount, 641 i : longint; 642 def : tstoreddef; 643 begin 644 defcount:=0; 645 for i:=0 to DefList.Count-1 do 646 if tstoreddef(DefList[i]).is_registered then 647 inc(defcount); 648 { each definition get a number, write then the amount of defs to the 649 ibstartdef entry } 650 ppufile.putlongint(defcount); 651 ppufile.writeentry(ibstartdefs); 652 { now write the definition } 653 for i:=0 to DefList.Count-1 do 654 begin 655 def:=tstoreddef(DefList[i]); 656 if def.is_registered then 657 def.ppuwrite(ppufile); 658 end; 659 { write end of definitions } 660 ppufile.writeentry(ibenddefs); 661 end; 662 663 664 procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile); 665 var 666 symcount, 667 i : longint; 668 sym : Tstoredsym; 669 begin 670 symcount:=0; 671 for i:=0 to SymList.Count-1 do 672 if tstoredsym(SymList[i]).is_registered then 673 inc(symcount); 674 { each definition get a number, write then the amount of syms and the 675 datasize to the ibsymdef entry } 676 ppufile.putlongint(symcount); 677 ppufile.writeentry(ibstartsyms); 678 { foreach is used to write all symbols } 679 for i:=0 to SymList.Count-1 do 680 begin 681 sym:=tstoredsym(SymList[i]); 682 if sym.is_registered then 683 sym.ppuwrite(ppufile); 684 end; 685 { end of symbols } 686 ppufile.writeentry(ibendsyms); 687 end; 688 689 690 procedure tstoredsymtable.buildderef; 691 var 692 i : longint; 693 def : tstoreddef; 694 sym : tstoredsym; 695 begin 696 { interface definitions } 697 for i:=0 to DefList.Count-1 do 698 begin 699 def:=tstoreddef(DefList[i]); 700 def.buildderef; 701 end; 702 { interface symbols } 703 for i:=0 to SymList.Count-1 do 704 begin 705 sym:=tstoredsym(SymList[i]); 706 sym.buildderef; 707 end; 708 end; 709 710 711 procedure tstoredsymtable.buildderefimpl; 712 var 713 i : longint; 714 def : tstoreddef; 715 begin 716 { implementation definitions } 717 for i:=0 to DefList.Count-1 do 718 begin 719 def:=tstoreddef(DefList[i]); 720 def.buildderefimpl; 721 end; 722 end; 723 724 725 procedure tstoredsymtable.buildderef_registered; 726 var 727 def : tstoreddef; 728 sym : tstoredsym; 729 i : longint; 730 defidmax, 731 symidmax: longint; 732 newbuiltdefderefs, 733 builtdefderefs, 734 builtsymderefs: array of boolean; 735 changed: boolean; 736 begin 737 newbuiltdefderefs:=nil; 738 builtdefderefs:=nil; 739 builtsymderefs:=nil; 740 { tdefs for which we already built the deref } 741 setlength(builtdefderefs,deflist.count); 742 { tdefs for which we built the deref in this iteration } 743 setlength(newbuiltdefderefs,deflist.count); 744 { syms for which we already built the deref } 745 setlength(builtsymderefs,symlist.count); 746 repeat 747 { we only have to store the defs (recursively) referred by wpo info 748 or inlined routines in the static symbtable } 749 750 { current number of registered defs/syms } 751 defidmax:=current_module.deflist.count; 752 symidmax:=current_module.symlist.count; 753 changed:=false; 754 755 { build the derefs for the registered defs we haven't processed yet } 756 for i:=0 to DefList.Count-1 do 757 begin 758 if not builtdefderefs[i] then 759 begin 760 def:=tstoreddef(DefList[i]); 761 if def.is_registered then 762 begin 763 def.buildderef; 764 newbuiltdefderefs[i]:=true; 765 builtdefderefs[i]:=true; 766 changed:=true; 767 end; 768 end; 769 end; 770 { same for the syms } 771 for i:=0 to SymList.Count-1 do 772 begin 773 if not builtsymderefs[i] then 774 begin 775 sym:=tstoredsym(SymList[i]); 776 if sym.is_registered then 777 begin 778 sym.buildderef; 779 builtsymderefs[i]:=true; 780 changed:=true; 781 end; 782 end; 783 end; 784 { now buildderefimpl for the defs we processed in this iteration } 785 for i:=0 to DefList.Count-1 do 786 begin 787 if newbuiltdefderefs[i] then 788 begin 789 newbuiltdefderefs[i]:=false; 790 tstoreddef(DefList[i]).buildderefimpl; 791 changed:=true; 792 end; 793 end; 794 { stop when no new defs or syms have been registered while processing 795 the currently registered ones (defs/syms get added to the module's 796 deflist/symlist when they are registered) } 797 until not changed and 798 (defidmax=current_module.deflist.count) and 799 (symidmax=current_module.symlist.count); 800 end; 801 802 803 procedure tstoredsymtable.deref(only_registered: boolean); 804 var 805 i : longint; 806 def : tstoreddef; 807 sym : tstoredsym; 808 begin 809 { first deref the interface ttype symbols. This is needs 810 to be done before the interface defs are derefed, because 811 the interface defs can contain references to the type symbols 812 which then already need to contain a resolved typedef field (PFV) } 813 for i:=0 to SymList.Count-1 do 814 begin 815 sym:=tstoredsym(SymList[i]); 816 if (sym.typ=typesym) and 817 (not only_registered or 818 sym.is_registered) then 819 sym.deref; 820 end; 821 { interface definitions } 822 for i:=0 to DefList.Count-1 do 823 begin 824 def:=tstoreddef(DefList[i]); 825 if not only_registered or 826 def.is_registered then 827 def.deref; 828 end; 829 { interface symbols } 830 for i:=0 to SymList.Count-1 do 831 begin 832 sym:=tstoredsym(SymList[i]); 833 if (not only_registered or 834 sym.is_registered) and 835 (sym.typ<>typesym) then 836 sym.deref; 837 end; 838 end; 839 840 841 procedure tstoredsymtable.derefimpl(only_registered: boolean); 842 var 843 i : longint; 844 def : tstoreddef; 845 begin 846 { implementation definitions } 847 for i:=0 to DefList.Count-1 do 848 begin 849 def:=tstoreddef(DefList[i]); 850 if not only_registered or 851 def.is_registered then 852 def.derefimpl; 853 end; 854 end; 855 856 tstoredsymtable.checkduplicatenull857 function tstoredsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 858 var 859 hsym : tsym; 860 begin 861 hsym:=tsym(FindWithHash(hashedid)); 862 if assigned(hsym) then 863 DuplicateSym(hashedid,sym,hsym,false); 864 result:=assigned(hsym); 865 end; 866 867 868 {************************************** 869 Callbacks 870 **************************************} 871 872 procedure TStoredSymtable.check_forward(sym:TObject;arg:pointer); 873 begin 874 if tsym(sym).typ=procsym then 875 tprocsym(sym).check_forward 876 { check also object method table } 877 { we needn't to test the def list } 878 { because each object has to have a type sym, 879 only test objects declarations, not type renamings } 880 else 881 if (tsym(sym).typ=typesym) and 882 assigned(ttypesym(sym).typedef) and 883 (ttypesym(sym).typedef.typesym=ttypesym(sym)) and 884 (ttypesym(sym).typedef.typ in [objectdef,recorddef]) then 885 tabstractrecorddef(ttypesym(sym).typedef).check_forwards; 886 end; 887 888 889 procedure tstoredsymtable.check_block_valid(def: TObject; arg: pointer); 890 var 891 founderrordef: tdef; 892 begin 893 { all parameters passed to a block must be handled by the Objective-C 894 runtime } 895 if is_block(tdef(def)) and 896 not objcchecktype(tdef(def),founderrordef) then 897 if assigned(tdef(def).typesym) then 898 MessagePos1(tdef(def).typesym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename) 899 else 900 Message1(type_e_objc_type_unsupported,tprocvardef(def).typename) 901 end; 902 903 904 procedure tstoredsymtable.register_syms(sym:tobject;arg:pointer); 905 begin 906 tsym(sym).register_sym; 907 end; 908 909 910 procedure tstoredsymtable.register_defs(def:tobject;arg:pointer); 911 begin 912 tdef(def).register_def; 913 end; 914 915 916 procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer); 917 begin 918 if (tsym(sym).typ=labelsym) and 919 not(tlabelsym(sym).defined) then 920 begin 921 if tlabelsym(sym).used then 922 Message1(sym_e_label_used_and_not_defined,tlabelsym(sym).realname) 923 else 924 Message1(sym_w_label_not_defined,tlabelsym(sym).realname); 925 end; 926 end; 927 928 929 procedure TStoredSymtable.varsymbolused(sym:TObject;arg:pointer); 930 begin 931 if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and 932 ((tsym(sym).owner.symtabletype in 933 [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then 934 begin 935 { unused symbol should be reported only if no } 936 { error is reported } 937 { if the symbol is in a register it is used } 938 { also don't count the value parameters which have local copies } 939 { also don't claim for high param of open parameters (PM) } 940 { also don't complain about unused symbols in generic procedures } 941 { and methods } 942 { and neither in abstract methods } 943 if (Errorcount<>0) or 944 ([vo_is_hidden_para,vo_is_funcret] * tabstractvarsym(sym).varoptions = [vo_is_hidden_para]) or 945 (sp_internal in tsym(sym).symoptions) or 946 ((assigned(tsym(sym).owner.defowner) and 947 (tsym(sym).owner.defowner.typ=procdef) and 948 ((df_generic in tprocdef(tsym(sym).owner.defowner).defoptions) or 949 (po_abstractmethod in tprocdef(tsym(sym).owner.defowner).procoptions)))) then 950 exit; 951 if (tstoredsym(sym).refs=0) then 952 begin 953 if (vo_is_funcret in tabstractvarsym(sym).varoptions) then 954 begin 955 { don't warn about the result of constructors } 956 if ((tsym(sym).owner.symtabletype<>localsymtable) or 957 (tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and 958 not (po_noreturn in tprocdef(tsym(sym).owner.defowner).procoptions) and 959 not(cs_opt_nodedfa in current_settings.optimizerswitches) then 960 MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set) 961 end 962 else if (tsym(sym).owner.symtabletype=parasymtable) then 963 MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname) 964 else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then 965 MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname) 966 else 967 MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname); 968 end 969 else if tabstractvarsym(sym).varstate in [vs_written,vs_initialised] then 970 begin 971 if (tsym(sym).owner.symtabletype=parasymtable) then 972 begin 973 if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and 974 not(vo_is_funcret in tabstractvarsym(sym).varoptions) then 975 MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname) 976 end 977 else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then 978 MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname) 979 else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then 980 MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname); 981 end 982 else if (tabstractvarsym(sym).varstate = vs_read_not_warned) and 983 ([vo_is_public,vo_is_external] * tabstractvarsym(sym).varoptions = []) then 984 MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname) 985 end 986 else if ((tsym(sym).owner.symtabletype in 987 [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then 988 begin 989 if (Errorcount<>0) or 990 (sp_internal in tsym(sym).symoptions) then 991 exit; 992 { do not claim for inherited private fields !! } 993 if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then 994 case tsym(sym).typ of 995 typesym: 996 MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname); 997 constsym: 998 MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname); 999 propertysym: 1000 MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname); 1001 else 1002 MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname); 1003 end 1004 { units references are problematic } 1005 else 1006 begin 1007 if (tsym(sym).refs=0) and 1008 not(tsym(sym).typ in [enumsym,unitsym,namespacesym]) and 1009 not(is_funcret_sym(tsym(sym))) and 1010 { don't complain about compiler generated syms for specializations, see also #13405 } 1011 not((tsym(sym).typ=typesym) and (df_specialization in ttypesym(sym).typedef.defoptions) and 1012 (pos('$',ttypesym(sym).Realname)<>0)) and 1013 ( 1014 (tsym(sym).typ<>procsym) or 1015 ((tsym(sym).owner.symtabletype=staticsymtable) and 1016 not current_module.is_unit) 1017 ) and 1018 { don't complain about alias for hidden _cmd parameter to 1019 obj-c methods } 1020 not((tsym(sym).typ in [localvarsym,paravarsym,absolutevarsym]) and 1021 (vo_is_msgsel in tabstractvarsym(sym).varoptions)) then 1022 MessagePos2(tsym(sym).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(sym).typ],tsym(sym).prettyname); 1023 end; 1024 end; 1025 end; 1026 1027 1028 procedure TStoredSymtable.TestPrivate(sym:TObject;arg:pointer); 1029 begin 1030 if tsym(sym).visibility in [vis_private,vis_strictprivate] then 1031 varsymbolused(sym,arg); 1032 end; 1033 1034 1035 procedure TStoredSymtable.objectprivatesymbolused(sym:TObject;arg:pointer); 1036 begin 1037 { 1038 Don't test simple object aliases PM 1039 } 1040 if (tsym(sym).typ=typesym) and 1041 (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and 1042 (ttypesym(sym).typedef.typesym=tsym(sym)) then 1043 tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil); 1044 end; 1045 1046 1047 procedure tstoredsymtable.testfordefaultproperty(sym:TObject;arg:pointer); 1048 begin 1049 if (tsym(sym).typ=propertysym) and 1050 (ppo_defaultproperty in tpropertysym(sym).propoptions) then 1051 ppointer(arg)^:=sym; 1052 end; 1053 1054 1055 procedure tstoredsymtable.register_children; 1056 begin 1057 SymList.ForEachCall(@register_syms,nil); 1058 DefList.ForEachCall(@register_defs,nil); 1059 end; 1060 1061 1062 {*********************************************** 1063 Process all entries 1064 ***********************************************} 1065 1066 { checks, if all procsyms and methods are defined } 1067 procedure tstoredsymtable.check_forwards; 1068 begin 1069 SymList.ForEachCall(@check_forward,nil); 1070 { check whether all block definitions contain valid Objective-C types 1071 (now that all forward definitions have been resolved) } 1072 DefList.ForEachCall(@check_block_valid,nil); 1073 end; 1074 1075 1076 procedure tstoredsymtable.checklabels; 1077 begin 1078 SymList.ForEachCall(@labeldefined,nil); 1079 end; 1080 1081 1082 procedure tstoredsymtable.allsymbolsused; 1083 begin 1084 SymList.ForEachCall(@varsymbolused,nil); 1085 end; 1086 1087 1088 procedure tstoredsymtable.allprivatesused; 1089 begin 1090 SymList.ForEachCall(@objectprivatesymbolused,nil); 1091 end; 1092 1093 1094 procedure TStoredSymtable._needs_init_final(sym:TObject;arg:pointer); 1095 begin 1096 if [sto_needs_init_final,sto_has_non_trivial_init] <= tableoptions then 1097 exit; 1098 { don't check static symbols - they can be present in structures only and 1099 always have a reference to a symbol defined on unit level } 1100 if sp_static in tsym(sym).symoptions then 1101 exit; 1102 case tsym(sym).typ of 1103 fieldvarsym, 1104 staticvarsym, 1105 localvarsym, 1106 paravarsym : 1107 begin 1108 if assigned(tabstractvarsym(sym).vardef) and 1109 is_managed_type(tabstractvarsym(sym).vardef) then 1110 include(tableoptions,sto_needs_init_final); 1111 if is_record((tabstractvarsym(sym).vardef)) and 1112 (mop_initialize in trecordsymtable(trecorddef(tabstractvarsym(sym).vardef).symtable).managementoperators) then 1113 include(tableoptions,sto_has_non_trivial_init); 1114 end; 1115 end; 1116 end; 1117 1118 1119 procedure tstoredsymtable.do_init_final_check; 1120 begin 1121 if not init_final_check_done then 1122 begin 1123 exclude(tableoptions,sto_needs_init_final); 1124 exclude(tableoptions,sto_has_non_trivial_init); 1125 SymList.ForEachCall(@_needs_init_final,nil); 1126 init_final_check_done:=true; 1127 end; 1128 end; 1129 1130 { returns true, if p contains data which needs init/final code } tstoredsymtable.needs_init_finalnull1131 function tstoredsymtable.needs_init_final : boolean; 1132 begin 1133 do_init_final_check; 1134 result:=sto_needs_init_final in tableoptions; 1135 end; 1136 1137 tstoredsymtable.has_non_trivial_initnull1138 function tstoredsymtable.has_non_trivial_init:boolean; 1139 begin 1140 do_init_final_check; 1141 result:=sto_has_non_trivial_init in tableoptions; 1142 end; 1143 1144 1145 {**************************************************************************** 1146 TAbstractRecordSymtable 1147 ****************************************************************************} 1148 1149 {$ifdef llvm} tabstractrecordsymtable.getllvmshadowsymtabllnull1150 function tabstractrecordsymtable.getllvmshadowsymtabll: tllvmshadowsymtable; 1151 begin 1152 if not assigned(fllvmst) then 1153 fllvmst:=tllvmshadowsymtable.create(self); 1154 result:=fllvmst; 1155 end; 1156 {$endif llvm} 1157 1158 constructor tabstractrecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint); 1159 begin 1160 inherited create(n); 1161 _datasize:=0; 1162 databitsize:=0; 1163 recordalignment:=1; 1164 usefieldalignment:=usealign; 1165 recordalignmin:=recordminalign; 1166 maxCrecordalign:=recordmaxCalign; 1167 padalignment:=1; 1168 { recordalign C_alignment means C record packing, that starts 1169 with an alignment of 1 } 1170 case usealign of 1171 C_alignment, 1172 bit_alignment: 1173 fieldalignment:=1; 1174 mac68k_alignment: 1175 fieldalignment:=2; 1176 else 1177 fieldalignment:=usealign; 1178 end; 1179 end; 1180 1181 1182 destructor tabstractrecordsymtable.destroy; 1183 1184 { for some reason a compiler built with 3.3.1 fails building the libxml2 1185 package if the below define is not defined and thus the code snippet is 1186 part of the destructor itself and not a nested procedure; until that bug 1187 is fixed this is used as a workaround :/ } 1188 {$define codegen_workaround} 1189 {$ifdef codegen_workaround} 1190 procedure free_mop_list(mop:tmanagementoperator); 1191 var 1192 i : longint; 1193 begin 1194 if assigned(mop_list[mop]) then 1195 for i:=0 to mop_list[mop].count-1 do 1196 dispose(pmanagementoperator_offset_entry(mop_list[mop][i])); 1197 mop_list[mop].free; 1198 end; 1199 {$endif codegen_workaround} 1200 1201 var 1202 mop : tmanagementoperator; 1203 {$ifndef codegen_workaround} 1204 i : longint; 1205 {$endif codegen_workaround} 1206 begin 1207 if refcount>1 then 1208 exit; 1209 {$ifdef llvm} 1210 fllvmst.free; 1211 {$endif llvm} 1212 for mop:=low(tmanagementoperator) to high(tmanagementoperator) do 1213 begin 1214 {$ifdef codegen_workaround} 1215 free_mop_list(mop); 1216 {$else codegen_workaround} 1217 if assigned(mop_list[mop]) then 1218 for i:=0 to mop_list[mop].count-1 do 1219 dispose(pmanagementoperator_offset_entry(mop_list[mop][i])); 1220 mop_list[mop].free; 1221 {$endif codegen_workaround} 1222 end; 1223 inherited destroy; 1224 end; 1225 1226 1227 procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile); 1228 begin 1229 if ppufile.readentry<>ibrecsymtableoptions then 1230 Message(unit_f_ppu_read_error); 1231 recordalignment:=shortint(ppufile.getbyte); 1232 usefieldalignment:=shortint(ppufile.getbyte); 1233 recordalignmin:=shortint(ppufile.getbyte); 1234 if (usefieldalignment=C_alignment) then 1235 fieldalignment:=shortint(ppufile.getbyte); 1236 ppufile.getsmallset(has_fields_with_mop); 1237 inherited ppuload(ppufile); 1238 end; 1239 1240 1241 procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile); 1242 var 1243 oldtyp : byte; 1244 begin 1245 oldtyp:=ppufile.entrytyp; 1246 ppufile.entrytyp:=subentryid; 1247 { in case of classes using C alignment, the alignment of the parent 1248 affects the alignment of fields of the childs } 1249 ppufile.putbyte(byte(recordalignment)); 1250 ppufile.putbyte(byte(usefieldalignment)); 1251 ppufile.putbyte(byte(recordalignmin)); 1252 if (usefieldalignment=C_alignment) then 1253 ppufile.putbyte(byte(fieldalignment)); 1254 { it's not really a "symtableoption", but loading this from the record 1255 def requires storing the set in the recorddef at least between 1256 ppuload and deref/derefimpl } 1257 ppufile.putsmallset(has_fields_with_mop); 1258 ppufile.writeentry(ibrecsymtableoptions); 1259 1260 inherited ppuwrite(ppufile); 1261 1262 ppufile.entrytyp:=oldtyp; 1263 end; 1264 1265 field2recordalignmentnull1266 function field2recordalignment(fieldoffs, fieldalign: asizeint): asizeint; 1267 begin 1268 { optimal alignment of the record when declaring a variable of this } 1269 { type is independent of the packrecords setting } 1270 if (fieldoffs mod fieldalign) = 0 then 1271 result:=fieldalign 1272 else if (fieldalign >= 16) and 1273 ((fieldoffs mod 16) = 0) and 1274 ((fieldalign mod 16) = 0) then 1275 result:=16 1276 else if (fieldalign >= 8) and 1277 ((fieldoffs mod 8) = 0) and 1278 ((fieldalign mod 8) = 0) then 1279 result:=8 1280 else if (fieldalign >= 4) and 1281 ((fieldoffs mod 4) = 0) and 1282 ((fieldalign mod 4) = 0) then 1283 result:=4 1284 else if (fieldalign >= 2) and 1285 ((fieldoffs mod 2) = 0) and 1286 ((fieldalign mod 2) = 0) then 1287 result:=2 1288 else 1289 result:=1; 1290 end; 1291 1292 procedure tabstractrecordsymtable.alignrecord(fieldoffset:asizeint;varalign:shortint); 1293 var 1294 varalignrecord: shortint; 1295 begin 1296 case usefieldalignment of 1297 C_alignment: 1298 varalignrecord:=used_align(varalign,recordalignmin,maxCrecordalign); 1299 mac68k_alignment: 1300 varalignrecord:=2; 1301 else 1302 varalignrecord:=field2recordalignment(fieldoffset,varalign); 1303 end; 1304 recordalignment:=max(recordalignment,varalignrecord); 1305 end; 1306 1307 procedure tabstractrecordsymtable.addfield(sym:tfieldvarsym;vis:tvisibility); 1308 var 1309 l : asizeint; 1310 varalign : shortint; 1311 vardef : tdef; 1312 begin 1313 if (sym.owner<>self) then 1314 internalerror(200602031); 1315 if sym.fieldoffset<>-1 then 1316 internalerror(200602032); 1317 { set visibility for the symbol } 1318 sym.visibility:=vis; 1319 { this symbol can't be loaded to a register } 1320 sym.varregable:=vr_none; 1321 { management operators } 1322 if sym.vardef.typ in [recorddef,objectdef] then 1323 has_fields_with_mop:=has_fields_with_mop + tabstractrecordsymtable(tabstractrecorddef(sym.vardef).symtable).has_fields_with_mop; 1324 if sym.vardef.typ=recorddef then 1325 has_fields_with_mop:=has_fields_with_mop + trecordsymtable(trecorddef(sym.vardef).symtable).managementoperators; 1326 { Calculate field offset } 1327 l:=sym.getsize; 1328 vardef:=sym.vardef; 1329 varalign:=vardef.structalignment; 1330 case usefieldalignment of 1331 bit_alignment: 1332 begin 1333 { bitpacking only happens for ordinals, the rest is aligned at } 1334 { 1 byte (compatible with GPC/GCC) } 1335 if is_ordinal(vardef) then 1336 begin 1337 sym.fieldoffset:=databitsize; 1338 l:=sym.getpackedbitsize; 1339 end 1340 else 1341 begin 1342 databitsize:=_datasize*8; 1343 sym.fieldoffset:=databitsize; 1344 if (l>high(asizeint) div 8) then 1345 Message(sym_e_segment_too_large); 1346 l:=l*8; 1347 end; 1348 if varalign=0 then 1349 varalign:=size_2_align(l); 1350 recordalignment:=max(recordalignment,field2recordalignment(databitsize mod 8,varalign)); 1351 { bit packed records are limited to high(aint) bits } 1352 { instead of bytes to avoid double precision } 1353 { arithmetic in offset calculations } 1354 if int64(l)>high(asizeint)-sym.fieldoffset then 1355 begin 1356 Message(sym_e_segment_too_large); 1357 _datasize:=high(asizeint); 1358 databitsize:=high(asizeint); 1359 end 1360 else 1361 begin 1362 databitsize:=sym.fieldoffset+l; 1363 _datasize:=(databitsize+7) div 8; 1364 end; 1365 { rest is not applicable } 1366 exit; 1367 end; 1368 else 1369 begin 1370 sym.fieldoffset:=getfieldoffset(sym,_datasize,fieldalignment); 1371 if l>high(asizeint)-sym.fieldoffset then 1372 begin 1373 Message(sym_e_segment_too_large); 1374 _datasize:=high(asizeint); 1375 end 1376 else 1377 _datasize:=sym.fieldoffset+l; 1378 { Calc alignment needed for this record } 1379 alignrecord(sym.fieldoffset,varalign); 1380 end; 1381 end; 1382 end; 1383 1384 field_alignment_comparenull1385 function field_alignment_compare(item1, item2: pointer): integer; 1386 var 1387 field1: tfieldvarsym absolute item1; 1388 field2: tfieldvarsym absolute item2; 1389 begin 1390 { we don't care about static fields, those become global variables } 1391 if (sp_static in field1.symoptions) or 1392 (sp_static in field2.symoptions) then 1393 exit(0); 1394 { sort from large to small alignment, and in case of the same alignment 1395 in declaration order (items declared close together are possibly 1396 also related and hence possibly used together -> putting them next 1397 to each other can improve cache behaviour) } 1398 result:=field2.vardef.alignment-field1.vardef.alignment; 1399 if result=0 then 1400 result:=field1.fieldoffset-field2.fieldoffset; 1401 end; 1402 1403 1404 procedure tabstractrecordsymtable.addfieldlist(list: tfpobjectlist; maybereorder: boolean); 1405 var 1406 fieldvs, insertfieldvs: tfieldvarsym; 1407 base, fieldoffset, space, insertfieldsize, insertfieldoffset, bestinsertfieldoffset, bestspaceleft: asizeint; 1408 i, j, bestfieldindex: longint; 1409 globalfieldalignment, 1410 prevglobalfieldalignment, 1411 newfieldalignment: shortint; 1412 changed: boolean; 1413 begin 1414 if maybereorder and 1415 (cs_opt_reorder_fields in current_settings.optimizerswitches) then 1416 begin 1417 { assign dummy field offsets so we can know their order in the 1418 sorting routine } 1419 for i:=0 to list.count-1 do 1420 tfieldvarsym(list[i]).fieldoffset:=i; 1421 { sort the non-class fields to minimise losses due to alignment } 1422 list.sort(@field_alignment_compare); 1423 { now fill up gaps caused by alignment skips with smaller fields 1424 where possible } 1425 repeat 1426 i:=0; 1427 base:=_datasize; 1428 globalfieldalignment:=fieldalignment; 1429 changed:=false; 1430 while i<list.count do 1431 begin 1432 fieldvs:=tfieldvarsym(list[i]); 1433 if sp_static in fieldvs.symoptions then 1434 begin 1435 inc(i); 1436 continue; 1437 end; 1438 prevglobalfieldalignment:=globalfieldalignment; 1439 fieldoffset:=getfieldoffset(fieldvs,base,globalfieldalignment); 1440 newfieldalignment:=globalfieldalignment; 1441 1442 { size of the gap between the end of the previous field and 1443 the start of the current one } 1444 space:=fieldoffset-base; 1445 bestspaceleft:=space; 1446 while space>0 do 1447 begin 1448 bestfieldindex:=-1; 1449 bestinsertfieldoffset:=-1; 1450 for j:=i+1 to list.count-1 do 1451 begin 1452 insertfieldvs:=tfieldvarsym(list[j]); 1453 if sp_static in insertfieldvs.symoptions then 1454 continue; 1455 insertfieldsize:=insertfieldvs.getsize; 1456 { can the new field fit possibly in the gap? } 1457 if insertfieldsize<=space then 1458 begin 1459 { restore globalfieldalignment to situation before 1460 the original field was inserted } 1461 globalfieldalignment:=prevglobalfieldalignment; 1462 { at what offset would it be inserted? (this new 1463 field has its own alignment requirements, which 1464 may make it impossible to fit after all) } 1465 insertfieldoffset:=getfieldoffset(insertfieldvs,base,globalfieldalignment); 1466 globalfieldalignment:=prevglobalfieldalignment; 1467 { taking into account the alignment, does it still 1468 fit and if so, does it fit better than the 1469 previously found best fit? } 1470 if (insertfieldoffset+insertfieldsize<=fieldoffset) and 1471 (fieldoffset-insertfieldoffset-insertfieldsize<bestspaceleft) then 1472 begin 1473 { new best fit } 1474 bestfieldindex:=j; 1475 bestinsertfieldoffset:=insertfieldoffset; 1476 bestspaceleft:=fieldoffset-insertfieldoffset-insertfieldsize; 1477 if bestspaceleft=0 then 1478 break; 1479 end; 1480 end; 1481 end; 1482 { if we didn't find any field to fit, stop trying for this 1483 gap } 1484 if bestfieldindex=-1 then 1485 break; 1486 changed:=true; 1487 { we found a field to insert -> adjust the new base 1488 address } 1489 base:=bestinsertfieldoffset+tfieldvarsym(list[bestfieldindex]).getsize; 1490 { update globalfieldalignment for this newly inserted 1491 field } 1492 getfieldoffset(tfieldvarsym(list[bestfieldindex]),base,globalfieldalignment); 1493 { move the new field before the current one } 1494 list.move(bestfieldindex,i); 1495 { and skip the new field (which is now at position i) } 1496 inc(i); 1497 { there may be more space left -> continue } 1498 space:=bestspaceleft; 1499 end; 1500 if base>fieldoffset then 1501 internalerror(2012071302); 1502 { check the next field } 1503 base:=fieldoffset+fieldvs.getsize; 1504 { since the original field had the same or greater alignment 1505 than anything we inserted before it, the global field 1506 alignment is still the same now as it was originally after 1507 inserting that field } 1508 globalfieldalignment:=newfieldalignment; 1509 inc(i); 1510 end; 1511 { there may be small gaps left *before* inserted fields } 1512 until not changed; 1513 end; 1514 { reset the dummy field offsets } 1515 for i:=0 to list.count-1 do 1516 tfieldvarsym(list[i]).fieldoffset:=-1; 1517 { finally, set the actual field offsets } 1518 for i:=0 to list.count-1 do 1519 begin 1520 fieldvs:=tfieldvarsym(list[i]); 1521 { static data fields are already inserted in the globalsymtable } 1522 if not(sp_static in fieldvs.symoptions) then 1523 begin 1524 { read_record_fields already set the visibility of the fields, 1525 because a single list can contain symbols with different 1526 visibility } 1527 addfield(fieldvs,fieldvs.visibility); 1528 end; 1529 end; 1530 end; 1531 1532 tabstractrecordsymtable.findfieldbyoffsetnull1533 function tabstractrecordsymtable.findfieldbyoffset(offset: asizeint): tfieldvarsym; 1534 var 1535 i: longint; 1536 sym: tsym; 1537 begin 1538 { there could be multiple fields in case of a variant record } 1539 if (defowner.typ=recorddef) and 1540 trecorddef(defowner).isunion then 1541 internalerror(2014090403); 1542 for i:=0 to SymList.count-1 do 1543 begin 1544 sym:=tsym(symlist[i]); 1545 if (sym.typ=fieldvarsym) and 1546 not(sp_static in sym.symoptions) and 1547 (tfieldvarsym(sym).fieldoffset>=offset) then 1548 begin 1549 result:=tfieldvarsym(sym); 1550 exit; 1551 end; 1552 end; 1553 result:=nil; 1554 end; 1555 1556 1557 procedure tabstractrecordsymtable.addalignmentpadding; 1558 var 1559 padded_datasize: asizeint; 1560 begin 1561 { make the record size aligned correctly so it can be 1562 used as elements in an array. For C records we 1563 use the fieldalignment, because that is updated with the 1564 used alignment. } 1565 if (padalignment = 1) then 1566 case usefieldalignment of 1567 C_alignment: 1568 padalignment:=fieldalignment; 1569 { bitpacked } 1570 bit_alignment: 1571 padalignment:=1; 1572 { mac68k: always round to multiple of 2 } 1573 mac68k_alignment: 1574 padalignment:=2; 1575 { default/no packrecords specified } 1576 0: 1577 padalignment:=recordalignment 1578 { specific packrecords setting -> use as upper limit } 1579 else 1580 padalignment:=min(recordalignment,usefieldalignment); 1581 end; 1582 padded_datasize:=align(_datasize,padalignment); 1583 _paddingsize:=padded_datasize-_datasize; 1584 _datasize:=padded_datasize; 1585 end; 1586 1587 1588 procedure tabstractrecordsymtable.insertdef(def:TDefEntry); 1589 begin 1590 { Enums must also be available outside the record scope, 1591 insert in the owner of this symtable } 1592 if def.typ=enumdef then 1593 defowner.owner.insertdef(def) 1594 else 1595 inherited insertdef(def); 1596 end; 1597 1598 tabstractrecordsymtable.is_packednull1599 function tabstractrecordsymtable.is_packed: boolean; 1600 begin 1601 result:=usefieldalignment=bit_alignment; 1602 end; 1603 1604 tabstractrecordsymtable.has_single_fieldnull1605 function tabstractrecordsymtable.has_single_field(out def:tdef): boolean; 1606 var 1607 i: longint; 1608 currentsymlist: TFPHashObjectList; 1609 currentdef: tdef; 1610 sym: tfieldvarsym; 1611 begin 1612 result:=false; 1613 { If a record contains a union, it does not contain a "single 1614 non-composite field" in the context of certain ABIs requiring 1615 special treatment for such records } 1616 if (defowner.typ=recorddef) and 1617 trecorddef(defowner).isunion then 1618 exit; 1619 { a record/object can contain other things than fields } 1620 currentsymlist:=symlist; 1621 { recurse in arrays and records } 1622 sym:=nil; 1623 repeat 1624 { record has one field? } 1625 for i:=0 to currentsymlist.Count-1 do 1626 begin 1627 if (tsym(currentsymlist[i]).typ=fieldvarsym) and 1628 not(sp_static in tsym(currentsymlist[i]).symoptions) then 1629 begin 1630 if result then 1631 begin 1632 result:=false; 1633 exit; 1634 end; 1635 result:=true; 1636 sym:=tfieldvarsym(currentsymlist[i]) 1637 end; 1638 end; 1639 if assigned(sym) then 1640 begin 1641 { if the field is an array, does it contain one element? } 1642 currentdef:=sym.vardef; 1643 while (currentdef.typ=arraydef) and 1644 not is_special_array(currentdef) do 1645 begin 1646 if tarraydef(currentdef).elecount<>1 then 1647 begin 1648 result:=false; 1649 exit; 1650 end; 1651 currentdef:=tarraydef(currentdef).elementdef; 1652 end; 1653 { if the array element is again a record, continue descending } 1654 if currentdef.typ=recorddef then 1655 currentsymlist:=trecorddef(currentdef).symtable.SymList 1656 else 1657 begin 1658 { otherwise we found the type of the single element } 1659 def:=currentdef; 1660 exit; 1661 end; 1662 end 1663 else 1664 exit 1665 until false; 1666 end; 1667 tabstractrecordsymtable.get_unit_symtablenull1668 function tabstractrecordsymtable.get_unit_symtable: tsymtable; 1669 begin 1670 result:=defowner.owner; 1671 while assigned(result) and (result.symtabletype in [ObjectSymtable,recordsymtable]) do 1672 result:=result.defowner.owner; 1673 end; 1674 1675 1676 procedure tabstractrecordsymtable.do_get_managementoperator_offset_list(data:tobject;arg:pointer); 1677 var 1678 sym : tsym absolute data; 1679 fsym : tfieldvarsym absolute data; 1680 mop : tmanagementoperator; 1681 entry : pmanagementoperator_offset_entry; 1682 sublist : tfplist; 1683 i : longint; 1684 begin 1685 if sym.typ<>fieldvarsym then 1686 exit; 1687 if not is_record(fsym.vardef) and not is_object(fsym.vardef) and not is_cppclass(fsym.vardef) then 1688 exit; 1689 mop:=tmanagementoperator(ptruint(arg)); 1690 if not assigned(mop_list[mop]) then 1691 internalerror(2018082303); 1692 1693 if is_record(fsym.vardef) then 1694 begin 1695 if mop in trecordsymtable(trecorddef(fsym.vardef).symtable).managementoperators then 1696 begin 1697 new(entry); 1698 entry^.pd:=search_management_operator(mop,fsym.vardef); 1699 if not assigned(entry^.pd) then 1700 internalerror(2018082302); 1701 entry^.offset:=fsym.fieldoffset; 1702 mop_list[mop].add(entry); 1703 end; 1704 end; 1705 1706 sublist:=tfplist.create; 1707 tabstractrecordsymtable(tabstractrecorddef(fsym.vardef).symtable).get_managementoperator_offset_list(mop,sublist); 1708 for i:=0 to sublist.count-1 do 1709 begin 1710 entry:=pmanagementoperator_offset_entry(sublist[i]); 1711 entry^.offset:=entry^.offset+fsym.fieldoffset; 1712 mop_list[mop].add(entry); 1713 end; 1714 { we don't need to remove the entries as they become part of list } 1715 sublist.free; 1716 end; 1717 1718 procedure tabstractrecordsymtable.get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist); 1719 var 1720 i : longint; 1721 entry,entrycopy : pmanagementoperator_offset_entry; 1722 begin 1723 if not assigned(list) then 1724 internalerror(2018082301); 1725 if mop=mop_none then 1726 exit; 1727 if not (mop in has_fields_with_mop) then 1728 { none of the fields or one of the field's fields has the requested operator } 1729 exit; 1730 if not assigned(mop_list[mop]) then 1731 begin 1732 mop_list[mop]:=tfplist.create; 1733 SymList.ForEachCall(@do_get_managementoperator_offset_list,pointer(ptruint(mop))); 1734 end; 1735 for i:=0 to mop_list[mop].count-1 do 1736 begin 1737 entry:=pmanagementoperator_offset_entry(mop_list[mop][i]); 1738 New(entrycopy); 1739 entrycopy^:=entry^; 1740 list.add(entrycopy); 1741 end; 1742 end; 1743 1744 procedure tabstractrecordsymtable.setdatasize(val: asizeint); 1745 begin 1746 _datasize:=val; 1747 if (usefieldalignment=bit_alignment) then 1748 { can overflow in non bitpacked records } 1749 databitsize:=val*8; 1750 end; 1751 tabstractrecordsymtable.getfieldoffsetnull1752 function tabstractrecordsymtable.getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint; 1753 var 1754 l : asizeint; 1755 varalignfield, 1756 varalign : shortint; 1757 vardef : tdef; 1758 begin 1759 { Calculate field offset } 1760 l:=sym.getsize; 1761 vardef:=sym.vardef; 1762 varalign:=vardef.structalignment; 1763 case usefieldalignment of 1764 bit_alignment: 1765 { has to be handled separately } 1766 internalerror(2012071301); 1767 C_alignment: 1768 begin 1769 { Calc the alignment size for C style records } 1770 if (varalign>4) and 1771 ((varalign mod 4)<>0) and 1772 (vardef.typ=arraydef) then 1773 Message1(sym_w_wrong_C_pack,vardef.typename); 1774 if varalign=0 then 1775 varalign:=l; 1776 if (globalfieldalignment<maxCrecordalign) then 1777 begin 1778 if (varalign>16) and (globalfieldalignment<32) then 1779 globalfieldalignment:=32 1780 else if (varalign>12) and (globalfieldalignment<16) then 1781 globalfieldalignment:=16 1782 { 12 is needed for long double } 1783 else if (varalign>8) and (globalfieldalignment<12) then 1784 globalfieldalignment:=12 1785 else if (varalign>4) and (globalfieldalignment<8) then 1786 globalfieldalignment:=8 1787 else if (varalign>2) and (globalfieldalignment<4) then 1788 globalfieldalignment:=4 1789 else if (varalign>1) and (globalfieldalignment<2) then 1790 globalfieldalignment:=2; 1791 end; 1792 globalfieldalignment:=min(globalfieldalignment,maxCrecordalign); 1793 end; 1794 mac68k_alignment: 1795 begin 1796 { mac68k alignment (C description): 1797 * char is aligned to 1 byte 1798 * everything else (except vector) is aligned to 2 bytes 1799 * vector is aligned to 16 bytes 1800 } 1801 if l>1 then 1802 globalfieldalignment:=2 1803 else 1804 globalfieldalignment:=1; 1805 varalign:=2; 1806 end; 1807 end; 1808 if varalign=0 then 1809 varalign:=size_2_align(l); 1810 varalignfield:=used_align(varalign,recordalignmin,globalfieldalignment); 1811 1812 result:=align(base,varalignfield); 1813 end; 1814 tabstractrecordsymtable.iscurrentunitnull1815 function tabstractrecordsymtable.iscurrentunit: boolean; 1816 begin 1817 Result:=assigned(current_module)and(current_module.moduleid=moduleid); 1818 end; 1819 1820 {**************************************************************************** 1821 TRecordSymtable 1822 ****************************************************************************} 1823 1824 constructor trecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint); 1825 begin 1826 inherited create(n,usealign,recordminalign,recordmaxCalign); 1827 symtabletype:=recordsymtable; 1828 end; 1829 1830 1831 { this procedure is reserved for inserting case variant into 1832 a record symtable } 1833 { the offset is the location of the start of the variant 1834 and datasize and dataalignment corresponds to 1835 the complete size (see code in pdecl unit) PM } 1836 procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : asizeint); 1837 var 1838 sym : tsym; 1839 def : tdef; 1840 i : integer; 1841 varalignrecord,varalign, 1842 storesize,storealign : asizeint; 1843 bitsize: tcgint; 1844 begin 1845 storesize:=_datasize; 1846 storealign:=fieldalignment; 1847 _datasize:=offset; 1848 if (usefieldalignment=bit_alignment) then 1849 databitsize:=offset*8; 1850 1851 { We move the ownership of the defs and symbols to the new recordsymtable. 1852 The old unionsymtable keeps the references, but doesn't own the 1853 objects anymore } 1854 unionst.DefList.OwnsObjects:=false; 1855 unionst.SymList.OwnsObjects:=false; 1856 1857 { copy symbols } 1858 for i:=0 to unionst.SymList.Count-1 do 1859 begin 1860 sym:=TSym(unionst.SymList[i]); 1861 if sym.typ<>fieldvarsym then 1862 internalerror(200601272); 1863 if tfieldvarsym(sym).fieldoffset=0 then 1864 include(tfieldvarsym(sym).varoptions,vo_is_first_field); 1865 1866 { add to this record symtable, checking for duplicate names } 1867 // unionst.SymList.List.List^[i].Data:=nil; 1868 insert(sym); 1869 varalign:=tfieldvarsym(sym).vardef.alignment; 1870 if varalign=0 then 1871 varalign:=size_2_align(tfieldvarsym(sym).getsize); 1872 { retrieve size } 1873 if (usefieldalignment=bit_alignment) then 1874 begin 1875 { bit packed records are limited to high(aint) bits } 1876 { instead of bytes to avoid double precision } 1877 { arithmetic in offset calculations } 1878 if is_ordinal(tfieldvarsym(sym).vardef) then 1879 bitsize:=tfieldvarsym(sym).getpackedbitsize 1880 else 1881 begin 1882 bitsize:=tfieldvarsym(sym).getsize; 1883 if (bitsize>high(asizeint) div 8) then 1884 Message(sym_e_segment_too_large); 1885 bitsize:=bitsize*8; 1886 end; 1887 if bitsize>high(asizeint)-databitsize then 1888 begin 1889 Message(sym_e_segment_too_large); 1890 _datasize:=high(asizeint); 1891 databitsize:=high(asizeint); 1892 end 1893 else 1894 begin 1895 databitsize:=tfieldvarsym(sym).fieldoffset+offset*8; 1896 _datasize:=(databitsize+7) div 8; 1897 end; 1898 tfieldvarsym(sym).fieldoffset:=databitsize; 1899 varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset div 8,varalign); 1900 end 1901 else 1902 begin 1903 if tfieldvarsym(sym).getsize>high(asizeint)-_datasize then 1904 begin 1905 Message(sym_e_segment_too_large); 1906 _datasize:=high(asizeint); 1907 end 1908 else 1909 _datasize:=tfieldvarsym(sym).fieldoffset+offset; 1910 { update address } 1911 tfieldvarsym(sym).fieldoffset:=_datasize; 1912 varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset,varalign); 1913 end; 1914 { update alignment of this record } 1915 if (usefieldalignment<>C_alignment) and 1916 (usefieldalignment<>mac68k_alignment) then 1917 recordalignment:=max(recordalignment,varalignrecord); 1918 end; 1919 { update alignment for C records } 1920 if (usefieldalignment=C_alignment) and 1921 (usefieldalignment<>mac68k_alignment) then 1922 recordalignment:=max(recordalignment,unionst.recordalignment); 1923 { Register defs in the new record symtable } 1924 for i:=0 to unionst.DefList.Count-1 do 1925 begin 1926 def:=TDef(unionst.DefList[i]); 1927 def.ChangeOwner(self); 1928 end; 1929 _datasize:=storesize; 1930 fieldalignment:=storealign; 1931 { If a record contains a union, it does not contain a "single 1932 non-composite field" in the context of certain ABIs requiring 1933 special treatment for such records } 1934 if defowner.typ=recorddef then 1935 trecorddef(defowner).isunion:=true; 1936 end; 1937 1938 1939 procedure trecordsymtable.includemanagementoperator(mop:tmanagementoperator); 1940 begin 1941 if mop in managementoperators then 1942 exit; 1943 include(managementoperators,mop); 1944 end; 1945 1946 1947 {**************************************************************************** 1948 TObjectSymtable 1949 ****************************************************************************} 1950 1951 constructor tObjectSymtable.create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint); 1952 begin 1953 inherited create(n,usealign,recordminalign,recordmaxCalign); 1954 symtabletype:=ObjectSymtable; 1955 defowner:=adefowner; 1956 end; 1957 1958 tObjectSymtable.checkduplicatenull1959 function tObjectSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 1960 var 1961 hsym: tsym; 1962 warn: boolean; 1963 begin 1964 result:=false; 1965 if not assigned(defowner) then 1966 internalerror(200602061); 1967 1968 { procsym and propertysym have special code 1969 to override values in inherited classes. For other 1970 symbols check for duplicates } 1971 if not(sym.typ in [procsym,propertysym]) then 1972 begin 1973 { but private ids can be reused } 1974 hsym:=search_struct_member(tobjectdef(defowner),hashedid.id); 1975 if assigned(hsym) and 1976 ( 1977 ( 1978 not(m_delphi in current_settings.modeswitches) and 1979 is_visible_for_object(hsym,tobjectdef(defowner)) 1980 ) or 1981 ( 1982 { In Delphi, you can repeat members of a parent class. You can't } 1983 { do this for objects however, and you (obviouly) can't } 1984 { declare two fields with the same name in a single class } 1985 (m_delphi in current_settings.modeswitches) and 1986 ( 1987 is_object(tdef(defowner)) or 1988 (hsym.owner = self) 1989 ) 1990 ) 1991 ) then 1992 begin 1993 { only watn when a parameter/local variable in a method 1994 conflicts with a category method, because this can easily 1995 happen due to all possible categories being imported via 1996 CocoaAll } 1997 warn:= 1998 (is_objccategory(tdef(hsym.owner.defowner)) or 1999 is_classhelper(tdef(hsym.owner.defowner))) and 2000 (sym.typ in [paravarsym,localvarsym,fieldvarsym]); 2001 DuplicateSym(hashedid,sym,hsym,warn); 2002 result:=true; 2003 end; 2004 end 2005 else 2006 result:=inherited checkduplicate(hashedid,sym); 2007 end; 2008 2009 2010 {$ifdef llvm} 2011 2012 {**************************************************************************** 2013 tLlvmShadowSymtableEntry 2014 ****************************************************************************} 2015 2016 constructor tllvmshadowsymtableentry.create(def: tdef; fieldoffset: aint); 2017 begin 2018 fdef:=def; 2019 ffieldoffset:=fieldoffset; 2020 end; 2021 2022 2023 {**************************************************************************** 2024 TLlvmShadowSymtable 2025 ****************************************************************************} 2026 tllvmshadowsymtable.getnull2027 function tllvmshadowsymtable.get(f: tfieldvarsym): tllvmshadowsymtableentry; 2028 begin 2029 result:=get_by_llvm_index(f.llvmfieldnr) 2030 end; 2031 2032 tllvmshadowsymtable.get_by_llvm_indexnull2033 function tllvmshadowsymtable.get_by_llvm_index(index: longint): tllvmshadowsymtableentry; 2034 begin 2035 result:=tllvmshadowsymtableentry(symdeflist[index]); 2036 end; 2037 2038 2039 constructor tllvmshadowsymtable.create(st: tabstractrecordsymtable); 2040 begin 2041 equivst:=st; 2042 curroffset:=0; 2043 symdeflist:=tfpobjectlist.create(true); 2044 generate; 2045 end; 2046 2047 2048 destructor tllvmshadowsymtable.destroy; 2049 begin 2050 symdeflist.free; 2051 end; 2052 2053 2054 procedure tllvmshadowsymtable.appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean); 2055 var 2056 sizectr, 2057 tmpsize: aint; 2058 begin 2059 case equivst.usefieldalignment of 2060 bit_alignment: 2061 begin 2062 { curoffset: bit address after the previous field. } 2063 { llvm has no special support for bitfields in records, } 2064 { so we replace them with plain bytes. } 2065 { as soon as a single bit of a byte is allocated, we } 2066 { allocate the byte in the llvm shadow record } 2067 if (fieldoffset>curroffset) then 2068 curroffset:=align(curroffset,8); 2069 { fields in bitpacked records always start either right } 2070 { after the previous one, or at the next byte boundary. } 2071 if (curroffset<>fieldoffset) then 2072 internalerror(2008051002); 2073 if is_ordinal(vardef) then 2074 begin 2075 tmpsize:=vardef.packedbitsize; 2076 sizectr:=((curroffset+tmpsize+7) shr 3)-((curroffset+7) shr 3); 2077 inc(curroffset,tmpsize); 2078 tmpsize:=0; 2079 while sizectr<>0 do 2080 begin 2081 symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,fieldoffset+tmpsize*8)); 2082 dec(sizectr); 2083 inc(tmpsize); 2084 end; 2085 end 2086 else 2087 begin 2088 symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset)); 2089 if not(derefclass) then 2090 inc(curroffset,vardef.size*8) 2091 else 2092 inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize*8); 2093 end; 2094 end 2095 else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then 2096 begin 2097 { curoffset: address right after the previous field } 2098 while (fieldoffset>curroffset) do 2099 begin 2100 symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset)); 2101 inc(curroffset); 2102 end; 2103 symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset)); 2104 if not(derefclass) then 2105 inc(curroffset,vardef.size) 2106 else 2107 inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize); 2108 end 2109 else 2110 { default for llvm, don't add explicit padding } 2111 symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset)); 2112 end 2113 end; 2114 2115 2116 procedure tllvmshadowsymtable.addalignmentpadding(finalsize: aint); 2117 begin 2118 case equivst.usefieldalignment of 2119 { already correct in this case } 2120 bit_alignment: 2121 ; 2122 else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then 2123 begin 2124 { add padding fields } 2125 while (finalsize>curroffset) do 2126 begin 2127 symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset)); 2128 inc(curroffset); 2129 end; 2130 end; 2131 end; 2132 end; 2133 2134 2135 procedure tllvmshadowsymtable.findvariantstarts(variantstarts: tfplist); 2136 var 2137 sym: tfieldvarsym; 2138 lastoffset: aint; 2139 newalignment: aint; 2140 i, j: longint; 2141 begin 2142 i:=0; 2143 while (i<equivst.symlist.count) do 2144 begin 2145 if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or 2146 (sp_static in tsym(equivst.symlist[i]).symoptions) then 2147 begin 2148 inc(i); 2149 continue; 2150 end; 2151 sym:=tfieldvarsym(equivst.symlist[i]); 2152 { a "better" algorithm might be to use the largest } 2153 { variant in case of (bit)packing, since then } 2154 { alignment doesn't matter } 2155 if (vo_is_first_field in sym.varoptions) then 2156 begin 2157 { we assume that all fields are processed in order. } 2158 if (variantstarts.count<>0) then 2159 lastoffset:=tfieldvarsym(variantstarts[variantstarts.count-1]).fieldoffset 2160 else 2161 lastoffset:=-1; 2162 2163 { new variant at same level as last one: use if higher alignment } 2164 if (lastoffset=sym.fieldoffset) then 2165 begin 2166 if (equivst.fieldalignment<>bit_alignment) then 2167 newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment) 2168 else 2169 newalignment:=1; 2170 if (newalignment>tfieldvarsym(variantstarts[variantstarts.count-1]).vardef.alignment) then 2171 variantstarts[variantstarts.count-1]:=sym; 2172 end 2173 { variant at deeper level than last one -> add } 2174 else if (lastoffset<sym.fieldoffset) then 2175 variantstarts.add(sym) 2176 else 2177 begin 2178 { a variant at a less deep level, so backtrack } 2179 j:=variantstarts.count-2; 2180 while (j>=0) do 2181 begin 2182 if (tfieldvarsym(variantstarts[j]).fieldoffset=sym.fieldoffset) then 2183 break; 2184 dec(j); 2185 end; 2186 if (j<0) then 2187 internalerror(2008051003); 2188 { new variant has higher alignment? } 2189 if (equivst.fieldalignment<>bit_alignment) then 2190 newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment) 2191 else 2192 newalignment:=1; 2193 { yes, replace and remove previous nested variants } 2194 if (newalignment>tfieldvarsym(variantstarts[j]).vardef.alignment) then 2195 begin 2196 variantstarts[j]:=sym; 2197 variantstarts.count:=j+1; 2198 end 2199 { no, skip this variant } 2200 else 2201 begin 2202 inc(i); 2203 while (i<equivst.symlist.count) and 2204 ((tsym(equivst.symlist[i]).typ<>fieldvarsym) or 2205 (sp_static in tsym(equivst.symlist[i]).symoptions) or 2206 (tfieldvarsym(equivst.symlist[i]).fieldoffset>sym.fieldoffset)) do 2207 inc(i); 2208 continue; 2209 end; 2210 end; 2211 end; 2212 inc(i); 2213 end; 2214 end; 2215 2216 2217 procedure tllvmshadowsymtable.buildtable(variantstarts: tfplist); 2218 var 2219 lastvaroffsetprocessed: aint; 2220 i, equivcount, varcount: longint; 2221 begin 2222 { if it's an object/class, the first entry is the parent (if there is one) } 2223 if (equivst.symtabletype=objectsymtable) and 2224 assigned(tobjectdef(equivst.defowner).childof) then 2225 appenddefoffset(tobjectdef(equivst.defowner).childof,0,is_class_or_interface_or_dispinterface(tobjectdef(equivst.defowner).childof)); 2226 equivcount:=equivst.symlist.count; 2227 varcount:=0; 2228 i:=0; 2229 lastvaroffsetprocessed:=-1; 2230 while (i<equivcount) do 2231 begin 2232 if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or 2233 (sp_static in tsym(equivst.symlist[i]).symoptions) then 2234 begin 2235 inc(i); 2236 continue; 2237 end; 2238 { start of a new variant? } 2239 if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then 2240 begin 2241 { if we want to process the same variant offset twice, it means that we } 2242 { got to the end and are trying to process the next variant part -> stop } 2243 if (tfieldvarsym(equivst.symlist[i]).fieldoffset<=lastvaroffsetprocessed) then 2244 break; 2245 2246 if (varcount>=variantstarts.count) then 2247 internalerror(2008051005); 2248 { new variant part -> use the one with the biggest alignment } 2249 i:=equivst.symlist.indexof(tobject(variantstarts[varcount])); 2250 lastvaroffsetprocessed:=tfieldvarsym(equivst.symlist[i]).fieldoffset; 2251 inc(varcount); 2252 if (i<0) then 2253 internalerror(2008051004); 2254 end; 2255 appenddefoffset(tfieldvarsym(equivst.symlist[i]).vardef,tfieldvarsym(equivst.symlist[i]).fieldoffset,false); 2256 inc(i); 2257 end; 2258 addalignmentpadding(equivst.datasize); 2259 end; 2260 2261 2262 procedure tllvmshadowsymtable.buildmapping(variantstarts: tfplist); 2263 var 2264 i, varcount: longint; 2265 shadowindex: longint; 2266 equivcount : longint; 2267 begin 2268 varcount:=0; 2269 shadowindex:=0; 2270 equivcount:=equivst.symlist.count; 2271 i:=0; 2272 while (i < equivcount) do 2273 begin 2274 if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or 2275 (sp_static in tsym(equivst.symlist[i]).symoptions) then 2276 begin 2277 inc(i); 2278 continue; 2279 end; 2280 { start of a new variant? } 2281 if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then 2282 begin 2283 { back up to a less deeply nested variant level? } 2284 while (tfieldvarsym(equivst.symlist[i]).fieldoffset<tfieldvarsym(variantstarts[varcount]).fieldoffset) do 2285 dec(varcount); 2286 { it's possible that some variants are more deeply nested than the 2287 one we recorded in the shadowsymtable (since we recorded the one 2288 with the biggest alignment, not necessarily the biggest one in size 2289 } 2290 if (tfieldvarsym(equivst.symlist[i]).fieldoffset>tfieldvarsym(variantstarts[varcount]).fieldoffset) then 2291 varcount:=variantstarts.count-1 2292 else if (tfieldvarsym(equivst.symlist[i]).fieldoffset<>tfieldvarsym(variantstarts[varcount]).fieldoffset) then 2293 internalerror(2008051006); 2294 { reset the shadowindex to the start of this variant. } 2295 { in case the llvmfieldnr is not (yet) set for this } 2296 { field, shadowindex will simply be reset to zero and } 2297 { we'll start searching from the start of the record } 2298 shadowindex:=tfieldvarsym(variantstarts[varcount]).llvmfieldnr; 2299 if (varcount<pred(variantstarts.count)) then 2300 inc(varcount); 2301 end; 2302 2303 { find the last shadowfield whose offset <= the current field's offset } 2304 while (tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset<tfieldvarsym(equivst.symlist[i]).fieldoffset) and 2305 (shadowindex<symdeflist.count-1) and 2306 (tllvmshadowsymtableentry(symdeflist[shadowindex+1]).fieldoffset<=tfieldvarsym(equivst.symlist[i]).fieldoffset) do 2307 inc(shadowindex); 2308 { set the field number and potential offset from that field (in case } 2309 { of overlapping variants) } 2310 tfieldvarsym(equivst.symlist[i]).llvmfieldnr:=shadowindex; 2311 tfieldvarsym(equivst.symlist[i]).offsetfromllvmfield:= 2312 tfieldvarsym(equivst.symlist[i]).fieldoffset-tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset; 2313 inc(i); 2314 end; 2315 end; 2316 2317 2318 procedure tllvmshadowsymtable.generate; 2319 var 2320 variantstarts: tfplist; 2321 begin 2322 variantstarts:=tfplist.create; 2323 2324 { first go through the entire record and } 2325 { store the fieldvarsyms of the variants } 2326 { with the highest alignment } 2327 findvariantstarts(variantstarts); 2328 2329 { now go through the regular fields and the selected variants, } 2330 { and add them to the llvm shadow record symtable } 2331 buildtable(variantstarts); 2332 2333 { finally map all original fields to the llvm definition } 2334 buildmapping(variantstarts); 2335 2336 variantstarts.free; 2337 end; 2338 2339 {$endif llvm} 2340 2341 {**************************************************************************** 2342 TAbstractSubSymtable 2343 ****************************************************************************} 2344 2345 procedure tabstractsubsymtable.ppuwrite(ppufile:tcompilerppufile); 2346 var 2347 oldtyp : byte; 2348 begin 2349 oldtyp:=ppufile.entrytyp; 2350 ppufile.entrytyp:=subentryid; 2351 2352 inherited ppuwrite(ppufile); 2353 2354 ppufile.entrytyp:=oldtyp; 2355 end; 2356 2357 2358 {**************************************************************************** 2359 TAbstractLocalSymtable 2360 ****************************************************************************} 2361 tabstractlocalsymtable.count_localsnull2362 function tabstractlocalsymtable.count_locals:longint; 2363 var 2364 i : longint; 2365 sym : tsym; 2366 begin 2367 result:=0; 2368 for i:=0 to SymList.Count-1 do 2369 begin 2370 sym:=tsym(SymList[i]); 2371 { Count only varsyms, but ignore the funcretsym } 2372 if (tsym(sym).typ in [localvarsym,paravarsym]) and 2373 (tsym(sym)<>current_procinfo.procdef.funcretsym) and 2374 (not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or 2375 (tstoredsym(sym).refs>0)) then 2376 inc(result); 2377 end; 2378 end; 2379 tabstractlocalsymtable.iscurrentunitnull2380 function tabstractlocalsymtable.iscurrentunit: boolean; 2381 begin 2382 Result:= 2383 assigned(defowner) and 2384 defowner.owner.iscurrentunit; 2385 end; 2386 2387 2388 {**************************************************************************** 2389 TLocalSymtable 2390 ****************************************************************************} 2391 2392 constructor tlocalsymtable.create(adefowner:tdef;level:byte); 2393 begin 2394 inherited create(''); 2395 defowner:=adefowner; 2396 symtabletype:=localsymtable; 2397 symtablelevel:=level; 2398 end; 2399 2400 tlocalsymtable.checkduplicatenull2401 function tlocalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 2402 var 2403 hsym : tsym; 2404 begin 2405 if not assigned(defowner) or 2406 (defowner.typ<>procdef) then 2407 internalerror(200602042); 2408 2409 result:=false; 2410 hsym:=tsym(FindWithHash(hashedid)); 2411 if assigned(hsym) then 2412 begin 2413 { a local and the function can have the same 2414 name in TP and Delphi, but RESULT not } 2415 if (m_duplicate_names in current_settings.modeswitches) and 2416 (hsym.typ in [absolutevarsym,localvarsym]) and 2417 (vo_is_funcret in tabstractvarsym(hsym).varoptions) and 2418 not((m_result in current_settings.modeswitches) and 2419 (vo_is_result in tabstractvarsym(hsym).varoptions)) then 2420 HideSym(hsym) 2421 else 2422 DuplicateSym(hashedid,sym,hsym,false); 2423 result:=true; 2424 exit; 2425 end; 2426 2427 { check also parasymtable, this needs to be done here because 2428 of the special situation with the funcret sym that needs to be 2429 hidden for tp and delphi modes } 2430 hsym:=tsym(tabstractprocdef(defowner).parast.FindWithHash(hashedid)); 2431 if assigned(hsym) then 2432 begin 2433 { a local and the function can have the same 2434 name in TP and Delphi, but RESULT not } 2435 if (m_duplicate_names in current_settings.modeswitches) and 2436 (sym.typ in [absolutevarsym,localvarsym]) and 2437 (vo_is_funcret in tabstractvarsym(sym).varoptions) and 2438 not((m_result in current_settings.modeswitches) and 2439 (vo_is_result in tabstractvarsym(sym).varoptions)) then 2440 Hidesym(sym) 2441 else 2442 DuplicateSym(hashedid,sym,hsym,false); 2443 result:=true; 2444 exit; 2445 end; 2446 2447 { check ObjectSymtable, skip this for funcret sym because 2448 that will always be positive because it has the same name 2449 as the procsym } 2450 if not is_funcret_sym(sym) and 2451 (defowner.typ=procdef) and 2452 assigned(tprocdef(defowner).struct) and 2453 (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and 2454 ( 2455 not(m_delphi in current_settings.modeswitches) or 2456 is_object(tprocdef(defowner).struct) 2457 ) then 2458 result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym); 2459 end; 2460 2461 2462 {**************************************************************************** 2463 TParaSymtable 2464 ****************************************************************************} 2465 2466 constructor tparasymtable.create(adefowner:tdef;level:byte); 2467 begin 2468 inherited create(''); 2469 readonly:=false; 2470 defowner:=adefowner; 2471 symtabletype:=parasymtable; 2472 symtablelevel:=level; 2473 end; 2474 2475 tparasymtable.checkduplicatenull2476 function tparasymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 2477 begin 2478 result:=inherited checkduplicate(hashedid,sym); 2479 if result then 2480 exit; 2481 if not(m_duplicate_names in current_settings.modeswitches) and 2482 assigned(defowner) and (defowner.typ=procdef) and 2483 assigned(tprocdef(defowner).struct) and 2484 assigned(tprocdef(defowner).owner) and 2485 (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and 2486 ( 2487 not(m_delphi in current_settings.modeswitches) or 2488 is_object(tprocdef(defowner).struct) 2489 ) then 2490 result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym); 2491 end; 2492 2493 procedure tparasymtable.insertdef(def: TDefEntry); 2494 begin 2495 if readonly then 2496 defowner.owner.insertdef(def) 2497 else 2498 inherited insertdef(def); 2499 end; 2500 2501 2502 {**************************************************************************** 2503 TAbstractUniTSymtable 2504 ****************************************************************************} 2505 2506 constructor tabstractuniTSymtable.create(const n : string;id:word); 2507 begin 2508 inherited create(n); 2509 moduleid:=id; 2510 end; 2511 2512 tabstractuniTSymtable.checkduplicatenull2513 function tabstractuniTSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 2514 var 2515 hsym : tsym; 2516 begin 2517 result:=false; 2518 hsym:=tsym(FindWithHash(hashedid)); 2519 if assigned(hsym) then 2520 begin 2521 if (sym is tstoredsym) and handle_generic_dummysym(hsym,tstoredsym(sym).symoptions) then 2522 exit; 2523 if hsym.typ=symconst.namespacesym then 2524 begin 2525 case sym.typ of 2526 symconst.namespacesym:; 2527 symconst.unitsym: 2528 begin 2529 HideSym(sym); { if we add a unit and there is a namespace with the same name then hide the unit name and not the namespace } 2530 tnamespacesym(hsym).unitsym:=tsym(sym); 2531 end 2532 else 2533 HideSym(hsym); 2534 end; 2535 end 2536 else 2537 { In delphi (contrary to TP) you can have a symbol with the same name as the 2538 unit, the unit can then not be accessed anymore using 2539 <unit>.<id>, so we can hide the symbol. 2540 Do the same if we add a namespace and there is a unit with the same name } 2541 if (hsym.typ=symconst.unitsym) and 2542 ((m_delphi in current_settings.modeswitches) or (sym.typ=symconst.namespacesym)) then 2543 begin 2544 HideSym(hsym); 2545 if sym.typ=symconst.namespacesym then 2546 tnamespacesym(sym).unitsym:=tsym(hsym); 2547 end 2548 { iso mode program parameters: staticvarsyms might have the same name as a program parameters, 2549 in this case, copy the isoindex and make the original symbol invisible } 2550 else if (m_isolike_program_para in current_settings.modeswitches) and (hsym.typ=programparasym) and (sym.typ=staticvarsym) 2551 and (tprogramparasym(hsym).isoindex<>0) then 2552 begin 2553 HideSym(hsym); 2554 tstaticvarsym(sym).isoindex:=tprogramparasym(hsym).isoindex; 2555 end 2556 else if (m_iso in current_settings.modeswitches) and (hsym.typ=unitsym) then 2557 HideSym(hsym) 2558 else 2559 DuplicateSym(hashedid,sym,hsym,false); 2560 result:=true; 2561 exit; 2562 end; 2563 end; 2564 tabstractuniTSymtable.findnamespacenull2565 function tabstractuniTSymtable.findnamespace(const n:string):TSymEntry; 2566 begin 2567 result:=find(n); 2568 if assigned(result)and(result.typ<>namespacesym)then 2569 result:=nil; 2570 end; 2571 tabstractuniTSymtable.iscurrentunitnull2572 function tabstractuniTSymtable.iscurrentunit:boolean; 2573 begin 2574 result:=assigned(current_module) and 2575 ( 2576 (current_module.globalsymtable=self) or 2577 (current_module.localsymtable=self) 2578 ); 2579 end; 2580 2581 tabstractuniTSymtable.needs_init_finalnull2582 function tabstractuniTSymtable.needs_init_final: boolean; 2583 begin 2584 if not init_final_check_done then 2585 begin 2586 result:=inherited needs_init_final; 2587 if not result then 2588 begin 2589 result:=has_class_condestructors; 2590 if result then 2591 include(tableoptions,sto_needs_init_final); 2592 end; 2593 end; 2594 result:=sto_needs_init_final in tableoptions; 2595 end; 2596 2597 2598 procedure tabstractuniTSymtable.insertunit(sym:TSymEntry); 2599 var 2600 p:integer; 2601 n,ns:string; 2602 oldsym:TSymEntry; 2603 begin 2604 insert(sym); 2605 n:=sym.realname; 2606 p:=pos('.',n); 2607 ns:=''; 2608 while p>0 do 2609 begin 2610 if ns='' then 2611 ns:=copy(n,1,p-1) 2612 else 2613 ns:=ns+'.'+copy(n,1,p-1); 2614 system.delete(n,1,p); 2615 oldsym:=findnamespace(upper(ns)); 2616 if not assigned(oldsym) then 2617 insert(cnamespacesym.create(ns)); 2618 p:=pos('.',n); 2619 end; 2620 end; 2621 2622 2623 procedure CheckForClassConDestructors(p:TObject;arg:pointer); 2624 var 2625 result: pboolean absolute arg; 2626 begin 2627 if result^ then 2628 exit; 2629 if (tdef(p).typ in [objectdef,recorddef]) and 2630 not (df_generic in tdef(p).defoptions) then 2631 begin 2632 { first check the class... } 2633 if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then 2634 result^:=true;; 2635 { ... and then also check all subclasses } 2636 if not result^ then 2637 tabstractrecorddef(p).symtable.deflist.foreachcall(@CheckForClassConDestructors,arg); 2638 end; 2639 end; 2640 2641 tabstractuniTSymtable.has_class_condestructorsnull2642 function tabstractuniTSymtable.has_class_condestructors: boolean; 2643 begin 2644 result:=false; 2645 deflist.foreachcall(@CheckForClassConDestructors,@result); 2646 end; 2647 2648 {**************************************************************************** 2649 TStaticSymtable 2650 ****************************************************************************} 2651 2652 constructor tstaticsymtable.create(const n : string;id:word); 2653 begin 2654 inherited create(n,id); 2655 symtabletype:=staticsymtable; 2656 symtablelevel:=main_program_level; 2657 currentvisibility:=vis_private; 2658 end; 2659 2660 2661 procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile); 2662 begin 2663 inherited ppuload(ppufile); 2664 2665 { now we can deref the syms and defs } 2666 deref(false); 2667 end; 2668 2669 2670 procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile); 2671 begin 2672 inherited ppuwrite(ppufile); 2673 end; 2674 2675 tstaticsymtable.checkduplicatenull2676 function tstaticsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean; 2677 begin 2678 result:=inherited checkduplicate(hashedid,sym); 2679 2680 if not result and 2681 (current_module.localsymtable=self) and 2682 assigned(current_module.globalsymtable) then 2683 result:=tglobalsymtable(current_module.globalsymtable).checkduplicate(hashedid,sym); 2684 end; 2685 tstaticsymtable.findnamespacenull2686 function tstaticsymtable.findnamespace(const n:string):TSymEntry; 2687 begin 2688 result:=inherited findnamespace(n); 2689 if not assigned(result) and 2690 (current_module.localsymtable=self) and 2691 assigned(current_module.globalsymtable) then 2692 result:=tglobalsymtable(current_module.globalsymtable).findnamespace(n); 2693 end; 2694 2695 2696 {**************************************************************************** 2697 TGlobalSymtable 2698 ****************************************************************************} 2699 2700 constructor tglobalsymtable.create(const n : string;id:word); 2701 begin 2702 inherited create(n,id); 2703 symtabletype:=globalsymtable; 2704 symtablelevel:=main_program_level; 2705 end; 2706 2707 2708 procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile); 2709 begin 2710 inherited ppuload(ppufile); 2711 2712 { now we can deref the syms and defs } 2713 deref(false); 2714 end; 2715 2716 2717 procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile); 2718 begin 2719 { write the symtable entries } 2720 inherited ppuwrite(ppufile); 2721 end; 2722 2723 2724 {***************************************************************************** 2725 tspecializesymtable 2726 *****************************************************************************} 2727 2728 constructor tspecializesymtable.create(const n : string;id:word); 2729 begin 2730 inherited create(n,id); 2731 { the specialize symtable does not own the syms and defs as they are all 2732 moved to a different symtable before the symtable is destroyed; this 2733 avoids calls to "extract" } 2734 symlist.ownsobjects:=false; 2735 deflist.ownsobjects:=false; 2736 end; 2737 tspecializesymtable.iscurrentunitnull2738 function tspecializesymtable.iscurrentunit: boolean; 2739 begin 2740 Result:=true; 2741 end; 2742 2743 2744 {**************************************************************************** 2745 TWITHSYMTABLE 2746 ****************************************************************************} 2747 2748 constructor twithsymtable.create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode}); 2749 begin 2750 inherited create(''); 2751 symtabletype:=withsymtable; 2752 withrefnode:=refnode; 2753 { Replace SymList with the passed symlist } 2754 SymList.free; 2755 SymList:=ASymList; 2756 defowner:=aowner; 2757 end; 2758 2759 2760 destructor twithsymtable.destroy; 2761 begin 2762 if refcount>1 then 2763 exit; 2764 withrefnode.free; 2765 { Disable SymList because we don't Own it } 2766 SymList:=nil; 2767 inherited destroy; 2768 end; 2769 2770 2771 procedure twithsymtable.clear; 2772 begin 2773 { remove no entry from a withsymtable as it is only a pointer to the 2774 recorddef or objectdef symtable } 2775 end; 2776 2777 2778 procedure twithsymtable.insertdef(def:TDefEntry); 2779 begin 2780 { Definitions can't be registered in the withsymtable 2781 because the withsymtable is removed after the with block. 2782 We can't easily solve it here because the next symtable in the 2783 stack is not known. } 2784 internalerror(200602046); 2785 end; 2786 2787 {**************************************************************************** 2788 TSTT_ExceptionSymtable 2789 ****************************************************************************} 2790 2791 constructor tstt_excepTSymtable.create; 2792 begin 2793 inherited create(''); 2794 symtabletype:=stt_excepTSymtable; 2795 end; 2796 2797 2798 {**************************************************************************** 2799 TMacroSymtable 2800 ****************************************************************************} 2801 2802 constructor tmacrosymtable.create(exported: boolean); 2803 begin 2804 inherited create(''); 2805 if exported then 2806 symtabletype:=exportedmacrosymtable 2807 else 2808 symtabletype:=localmacrosymtable; 2809 symtablelevel:=main_program_level; 2810 end; 2811 2812 {**************************************************************************** 2813 TEnumSymtable 2814 ****************************************************************************} 2815 2816 procedure tenumsymtable.insert(sym: TSymEntry; checkdup: boolean); 2817 var 2818 value: longint; 2819 def: tenumdef; 2820 begin 2821 // defowner = nil only when we are loading from ppu 2822 if defowner<>nil then 2823 begin 2824 { First entry? Then we need to set the minval } 2825 value:=tenumsym(sym).value; 2826 def:=tenumdef(defowner); 2827 if SymList.count=0 then 2828 begin 2829 if value>0 then 2830 def.has_jumps:=true; 2831 def.setmin(value); 2832 def.setmax(value); 2833 end 2834 else 2835 begin 2836 { check for jumps } 2837 if value>def.max+1 then 2838 def.has_jumps:=true; 2839 { update low and high } 2840 if def.min>value then 2841 def.setmin(value); 2842 if def.max<value then 2843 def.setmax(value); 2844 end; 2845 end; 2846 inherited insert(sym, checkdup); 2847 end; 2848 2849 constructor tenumsymtable.create(adefowner: tdef); 2850 begin 2851 inherited Create(''); 2852 symtabletype:=enumsymtable; 2853 defowner:=adefowner; 2854 end; 2855 2856 {**************************************************************************** 2857 TArraySymtable 2858 ****************************************************************************} 2859 2860 procedure tarraysymtable.insertdef(def: TDefEntry); 2861 begin 2862 { Enums must also be available outside the record scope, 2863 insert in the owner of this symtable } 2864 if def.typ=enumdef then 2865 defowner.owner.insertdef(def) 2866 else 2867 inherited insertdef(def); 2868 end; 2869 2870 constructor tarraysymtable.create(adefowner: tdef); 2871 begin 2872 inherited Create(''); 2873 symtabletype:=arraysymtable; 2874 defowner:=adefowner; 2875 end; 2876 2877 {***************************************************************************** 2878 Helper Routines 2879 *****************************************************************************} 2880 FullTypeNamenull2881 function FullTypeName(def,otherdef:tdef):string; 2882 var 2883 s1,s2 : string; 2884 begin 2885 if def.typ in [objectdef,recorddef] then 2886 s1:=tabstractrecorddef(def).RttiName 2887 else 2888 s1:=def.typename; 2889 { When the names are the same try to include the unit name } 2890 if assigned(otherdef) and 2891 (def.owner.symtabletype in [globalsymtable,staticsymtable]) then 2892 begin 2893 s2:=otherdef.typename; 2894 if upper(s1)=upper(s2) then 2895 s1:=def.owner.realname^+'.'+s1; 2896 end; 2897 FullTypeName:=s1; 2898 end; 2899 generate_nested_namenull2900 function generate_nested_name(symtable:tsymtable;delimiter:string):string; 2901 begin 2902 result:=''; 2903 while assigned(symtable) and (symtable.symtabletype in [ObjectSymtable,recordsymtable]) do 2904 begin 2905 if (result='') then 2906 if symtable.name<>nil then 2907 result:=symtable.name^ 2908 else 2909 else 2910 if symtable.name<>nil then 2911 result:=symtable.name^+delimiter+result 2912 else 2913 result:=delimiter+result; 2914 symtable:=symtable.defowner.owner; 2915 end; 2916 end; 2917 2918 generate_objectpascal_helper_keynull2919 function generate_objectpascal_helper_key(def:tdef):string; 2920 begin 2921 if not assigned(def) then 2922 internalerror(2013020501); 2923 if def.typ in [recorddef,objectdef] then 2924 result:=make_mangledname('',tabstractrecorddef(def).symtable,'') 2925 else 2926 result:=make_mangledname('',def.owner,def.typesym.name); 2927 end; 2928 2929 2930 procedure incompatibletypes(def1,def2:tdef); 2931 begin 2932 { When there is an errordef there is already an error message show } 2933 if (def2.typ=errordef) or 2934 (def1.typ=errordef) then 2935 exit; 2936 CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1)); 2937 end; 2938 2939 2940 procedure hidesym(sym:TSymEntry); 2941 begin 2942 sym.realname:='$hidden'+sym.realname; 2943 tsym(sym).visibility:=vis_hidden; 2944 end; 2945 2946 2947 procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym: TSymEntry; warn: boolean); 2948 var 2949 st : TSymtable; 2950 filename : TIDString; 2951 begin 2952 if not warn then 2953 Message1(sym_e_duplicate_id,tsym(origsym).realname) 2954 else 2955 Message1(sym_w_duplicate_id,tsym(origsym).realname); 2956 { Write hint where the original symbol was found } 2957 st:=finduniTSymtable(origsym.owner); 2958 with tsym(origsym).fileinfo do 2959 begin 2960 if assigned(st) and 2961 (st.symtabletype=globalsymtable) and 2962 st.iscurrentunit then 2963 Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line)) 2964 else if assigned(st.name) then 2965 begin 2966 filename:=find_module_from_symtable(st).sourcefiles.get_file_name(fileindex); 2967 if filename<>'' then 2968 Message2(sym_h_duplicate_id_where,'unit '+st.name^+': '+filename,tostr(line)) 2969 else 2970 Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line)) 2971 end; 2972 end; 2973 { Rename duplicate sym to an unreachable name, but it can be 2974 inserted in the symtable without errors } 2975 inc(dupnr); 2976 hashedid.id:='dup'+tostr(dupnr)+hashedid.id; 2977 if assigned(dupsym) then 2978 include(tsym(dupsym).symoptions,sp_implicitrename); 2979 end; 2980 handle_generic_dummysymnull2981 function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean; 2982 begin 2983 result:=false; 2984 if not assigned(sym) or not (sym is tstoredsym) then 2985 Internalerror(2011081101); 2986 { For generics a dummy symbol without the parameter count is created 2987 if such a symbol not yet exists so that different parts of the 2988 parser can find that symbol. If that symbol is still a 2989 undefineddef we replace the generic dummy symbol's 2990 name with a "dup" name and use the new symbol as the generic dummy 2991 symbol } 2992 if (sp_generic_dummy in tstoredsym(sym).symoptions) and 2993 (sym.typ=typesym) and (ttypesym(sym).typedef.typ=undefineddef) and 2994 (m_delphi in current_settings.modeswitches) then 2995 begin 2996 inc(dupnr); 2997 sym.Owner.SymList.Rename(upper(sym.realname),'dup_'+tostr(dupnr)+sym.realname); 2998 include(tsym(sym).symoptions,sp_implicitrename); 2999 { we need to find the new symbol now if checking for a dummy } 3000 include(symoptions,sp_generic_dummy); 3001 result:=true; 3002 end; 3003 end; 3004 3005 3006 procedure write_system_parameter_lists(const name:string); 3007 var 3008 srsym:tprocsym; 3009 begin 3010 srsym:=tprocsym(systemunit.find(name)); 3011 if not assigned(srsym) or not (srsym.typ=procsym) then 3012 internalerror(2016060302); 3013 srsym.write_parameter_lists(nil); 3014 end; 3015 3016 3017 {***************************************************************************** 3018 Search 3019 *****************************************************************************} 3020 3021 procedure addsymref(sym:tsym); 3022 var 3023 owner: tsymtable; 3024 begin 3025 { for symbols used in preprocessor expressions, we don't want to 3026 increase references count (for smaller final binaries) } 3027 if not assigned(current_scanner) then 3028 internalerror(2017050601); 3029 if current_scanner.in_preproc_comp_expr then 3030 exit; 3031 { symbol uses count } 3032 sym.IncRefCount; 3033 owner:=sym.owner; 3034 while owner.symtabletype in [objectsymtable,recordsymtable,enumsymtable] do 3035 owner:=tdef(owner.defowner).owner; 3036 if assigned(current_module) and 3037 (owner.symtabletype=globalsymtable) then 3038 begin 3039 if tglobalsymtable(owner).moduleid>=current_module.unitmapsize then 3040 internalerror(200501152); 3041 { unit uses count } 3042 inc(current_module.unitmap[tglobalsymtable(owner).moduleid].refs); 3043 { Note: don't check the symtable directly as owner might be 3044 a specialize symtable which is a globalsymtable as well } 3045 if ( 3046 assigned(current_module.globalsymtable) and 3047 (current_module.globalsymtable.moduleid<>owner.moduleid) 3048 ) or ( 3049 assigned(current_module.localsymtable) and 3050 (current_module.localsymtable.moduleid<>owner.moduleid) 3051 ) then 3052 { symbol is imported from another unit } 3053 current_module.addimportedsym(sym); 3054 end; 3055 end; 3056 3057 is_owned_bynull3058 function is_owned_by(nesteddef,ownerdef:tdef):boolean; 3059 begin 3060 result:=nesteddef=ownerdef; 3061 if not result and 3062 { types declared locally in a record method are not defined in the 3063 record itself } 3064 not(nesteddef.owner.symtabletype in [localsymtable,parasymtable]) and 3065 assigned(nesteddef.owner.defowner) then 3066 result:=is_owned_by(tdef(nesteddef.owner.defowner),ownerdef); 3067 end; 3068 sym_is_owned_bynull3069 function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean; 3070 begin 3071 result:=assigned(childsym) and (childsym.owner=symtable); 3072 if not result and assigned(childsym) and 3073 (childsym.owner.symtabletype in [objectsymtable,recordsymtable]) then 3074 result:=sym_is_owned_by(tabstractrecorddef(childsym.owner.defowner).typesym,symtable); 3075 end; 3076 defs_belong_to_same_genericnull3077 function defs_belong_to_same_generic(def1, def2: tdef): boolean; 3078 begin 3079 result:=false; 3080 if not assigned(def1) or not assigned(def2) then 3081 exit; 3082 { for both defs walk to the topmost generic } 3083 while assigned(def1.owner.defowner) and (df_generic in tstoreddef(def1.owner.defowner).defoptions) do 3084 def1:=tdef(def1.owner.defowner); 3085 while assigned(def2.owner.defowner) and (df_generic in tstoreddef(def2.owner.defowner).defoptions) do 3086 def2:=tdef(def2.owner.defowner); 3087 result:=def1=def2; 3088 end; 3089 get_generic_in_hierarchy_by_namenull3090 function get_generic_in_hierarchy_by_name(srsym: tsym; def: tdef): tdef; 3091 var 3092 uname : string; 3093 begin 3094 { TODO : check regarding arrays and records declared as their type } 3095 if not (def.typ in [recorddef,objectdef]) then 3096 internalerror(2012051501); 3097 uname:=upper(srsym.realname); 3098 repeat 3099 if uname=copy(tabstractrecorddef(def).objname^,1,pos('$',tabstractrecorddef(def).objname^)-1) then 3100 begin 3101 result:=def; 3102 exit; 3103 end; 3104 def:=tdef(def.owner.defowner); 3105 until not assigned(def) or not (def.typ in [recorddef,objectdef]); 3106 result:=nil; 3107 end; 3108 return_specialization_of_genericnull3109 function return_specialization_of_generic(nesteddef,genericdef:tdef; out resultdef:tdef):boolean; 3110 begin 3111 { TODO : check regarding arrays and records declared as their type } 3112 if not (nesteddef.typ in [recorddef,objectdef]) then 3113 internalerror(2012051601); 3114 repeat 3115 if tstoreddef(nesteddef).genericdef=genericdef then 3116 begin 3117 resultdef:=nesteddef; 3118 result:=true; 3119 exit; 3120 end; 3121 nesteddef:=tdef(nesteddef.owner.defowner); 3122 until not assigned(nesteddef) or not (nesteddef.typ in [recorddef,objectdef]); 3123 resultdef:=nil; 3124 result:=false; 3125 end; 3126 3127 { symst: symboltable that contains the symbol (-> symowner def: record/objectdef in which the symbol is defined) 3128 symvisibility: visibility of the symbol 3129 contextobjdef: via which def the symbol is accessed, e.g.: 3130 fieldname:=1 -> contextobjdef = current_structdef 3131 objfield.fieldname:=1 -> contextobjdef = def of objfield 3132 } is_visible_for_objectnull3133 function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean; 3134 var 3135 symownerdef : tabstractrecorddef; 3136 nonlocalst : tsymtable; 3137 isspezproc : boolean; 3138 begin 3139 result:=false; 3140 3141 { Get objdectdef owner of the symtable for the is_related checks } 3142 if not assigned(symst) or 3143 not (symst.symtabletype in [objectsymtable,recordsymtable]) then 3144 internalerror(200810285); 3145 symownerdef:=tabstractrecorddef(symst.defowner); 3146 { specializations might belong to a localsymtable or parasymtable } 3147 nonlocalst:=symownerdef.owner; 3148 if tstoreddef(symst.defowner).is_specialization then 3149 while nonlocalst.symtabletype in [localsymtable,parasymtable] do 3150 nonlocalst:=nonlocalst.defowner.owner; 3151 isspezproc:=false; 3152 if assigned(current_procinfo) then 3153 begin 3154 if current_procinfo.procdef.is_specialization and 3155 assigned(current_procinfo.procdef.struct) then 3156 isspezproc:=true; 3157 end; 3158 case symvisibility of 3159 vis_private : 3160 begin 3161 { private symbols are allowed when we are in the same 3162 module as they are defined } 3163 result:=( 3164 (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and 3165 (nonlocalst.iscurrentunit) 3166 ) or 3167 ( // the case of specialize inside the generic declaration and nested types 3168 (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and 3169 ( 3170 assigned(current_structdef) and 3171 ( 3172 (current_structdef=symownerdef) or 3173 (current_structdef.owner.iscurrentunit) 3174 ) 3175 ) or 3176 ( 3177 not assigned(current_structdef) and 3178 (symownerdef.owner.iscurrentunit) 3179 ) or 3180 { access from a generic method that belongs to the class 3181 but that is specialized elsewere } 3182 ( 3183 isspezproc and 3184 (current_procinfo.procdef.struct=current_structdef) 3185 ) or 3186 { specializations may access private symbols that their 3187 generics are allowed to access } 3188 ( 3189 assigned(current_structdef) and 3190 (df_specialization in current_structdef.defoptions) and 3191 (symst.moduleid=current_structdef.genericdef.owner.moduleid) 3192 ) 3193 ); 3194 end; 3195 vis_strictprivate : 3196 begin 3197 result:=assigned(current_structdef) and 3198 is_owned_by(current_structdef,symownerdef); 3199 end; 3200 vis_strictprotected : 3201 begin 3202 result:=( 3203 { access from nested class } 3204 assigned(current_structdef) and 3205 is_owned_by(current_structdef,symownerdef) 3206 ) or 3207 ( 3208 { access from child class } 3209 assigned(contextobjdef) and 3210 assigned(current_structdef) and 3211 def_is_related(contextobjdef,symownerdef) and 3212 def_is_related(current_structdef,contextobjdef) 3213 ) or 3214 ( 3215 { helpers can access strict protected symbols } 3216 is_objectpascal_helper(contextobjdef) and 3217 def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef) 3218 ) or 3219 ( 3220 { same as above, but from context of call node inside 3221 helper method } 3222 is_objectpascal_helper(current_structdef) and 3223 def_is_related(tobjectdef(current_structdef).extendeddef,symownerdef) 3224 ); 3225 end; 3226 vis_protected : 3227 begin 3228 { protected symbols are visible in the module that defines them and 3229 also visible to related objects. The related object must be defined 3230 in the current module } 3231 result:=( 3232 ( 3233 (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and 3234 (nonlocalst.iscurrentunit) 3235 ) or 3236 ( 3237 assigned(contextobjdef) and 3238 (contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable,recordsymtable]) and 3239 (contextobjdef.owner.iscurrentunit) and 3240 def_is_related(contextobjdef,symownerdef) 3241 ) or 3242 ( // the case of specialize inside the generic declaration and nested types 3243 (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and 3244 ( 3245 assigned(current_structdef) and 3246 ( 3247 (current_structdef=symownerdef) or 3248 (current_structdef.owner.iscurrentunit) 3249 ) 3250 ) or 3251 ( 3252 not assigned(current_structdef) and 3253 (symownerdef.owner.iscurrentunit) 3254 ) or 3255 ( 3256 { helpers can access protected symbols } 3257 is_objectpascal_helper(contextobjdef) and 3258 def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef) 3259 ) 3260 ) or 3261 { access from a generic method that belongs to the class 3262 but that is specialized elsewere } 3263 ( 3264 isspezproc and 3265 (current_procinfo.procdef.struct=current_structdef) 3266 ) or 3267 { specializations may access private symbols that their 3268 generics are allowed to access } 3269 ( 3270 assigned(current_structdef) and 3271 (df_specialization in current_structdef.defoptions) and 3272 (symst.moduleid=current_structdef.genericdef.owner.moduleid) 3273 ) 3274 ); 3275 end; 3276 vis_public, 3277 vis_published : 3278 result:=true; 3279 end; 3280 end; 3281 3282 is_visible_for_objectnull3283 function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean; 3284 begin 3285 result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef); 3286 end; 3287 3288 is_visible_for_objectnull3289 function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean; 3290 var 3291 i : longint; 3292 pd : tprocdef; 3293 begin 3294 if sym.typ=procsym then 3295 begin 3296 { A procsym is visible, when there is at least one of the procdefs visible } 3297 result:=false; 3298 for i:=0 to tprocsym(sym).ProcdefList.Count-1 do 3299 begin 3300 pd:=tprocdef(tprocsym(sym).ProcdefList[i]); 3301 if (pd.owner=sym.owner) and 3302 is_visible_for_object(pd,contextobjdef) then 3303 begin 3304 result:=true; 3305 exit; 3306 end; 3307 end; 3308 end 3309 else 3310 result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef); 3311 end; 3312 3313 searchsymnull3314 function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; 3315 begin 3316 result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[],sp_none); 3317 end; 3318 3319 searchsym_with_flagsnull3320 function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; 3321 begin 3322 result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,flags,sp_none); 3323 end; 3324 3325 searchsym_maybe_with_symoptionnull3326 function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean; 3327 var 3328 hashedid: THashedIDString; 3329 contextstructdef: tabstractrecorddef; 3330 stackitem: psymtablestackitem; 3331 begin 3332 result:=false; 3333 hashedid.id:=s; 3334 stackitem:=symtablestack.stack; 3335 while assigned(stackitem) do 3336 begin 3337 srsymtable:=stackitem^.symtable; 3338 if (srsymtable.symtabletype=objectsymtable) then 3339 begin 3340 { TODO : implement the search for an option in classes as well } 3341 if ssf_search_option in flags then 3342 begin 3343 result:=false; 3344 exit; 3345 end; 3346 if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,flags+[ssf_search_helper]) then 3347 begin 3348 result:=true; 3349 exit; 3350 end; 3351 end 3352 else if not((srsymtable.symtabletype=withsymtable) and assigned(srsymtable.defowner) and 3353 (srsymtable.defowner.typ=undefineddef)) then 3354 begin 3355 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3356 { First check if it is a unit/namespace symbol. 3357 They are visible only if they are from the current unit or 3358 unit of generic of currently processed specialization. } 3359 if assigned(srsym) and 3360 ( 3361 not(srsym.typ in [unitsym,namespacesym]) or 3362 srsymtable.iscurrentunit or 3363 (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid)) or 3364 ( 3365 assigned(current_procinfo) and 3366 (df_specialization in current_procinfo.procdef.defoptions) and 3367 (current_procinfo.procdef.genericdef.owner.moduleid=srsymtable.moduleid) 3368 ) 3369 ) and 3370 (not (ssf_search_option in flags) or (option in srsym.symoptions))then 3371 begin 3372 { use the class from withsymtable only when it is 3373 defined in this unit } 3374 if (srsymtable.symtabletype=withsymtable) and 3375 assigned(srsymtable.defowner) and 3376 (srsymtable.defowner.typ in [recorddef,objectdef]) and 3377 (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and 3378 (srsymtable.defowner.owner.iscurrentunit) then 3379 contextstructdef:=tabstractrecorddef(srsymtable.defowner) 3380 else 3381 contextstructdef:=current_structdef; 3382 if not(srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or 3383 is_visible_for_object(srsym,contextstructdef) then 3384 begin 3385 { we need to know if a procedure references symbols 3386 in the static symtable, because then it can't be 3387 inlined from outside this unit } 3388 if assigned(current_procinfo) and 3389 (srsym.owner.symtabletype=staticsymtable) then 3390 include(current_procinfo.flags,pi_uses_static_symtable); 3391 if not (ssf_no_addsymref in flags) then 3392 addsymref(srsym); 3393 result:=true; 3394 exit; 3395 end; 3396 end; 3397 end; 3398 stackitem:=stackitem^.next; 3399 end; 3400 srsym:=nil; 3401 srsymtable:=nil; 3402 end; 3403 searchsym_with_symoptionnull3404 function searchsym_with_symoption(const s: TIDString;out srsym:tsym;out 3405 srsymtable:TSymtable;option:tsymoption):boolean; 3406 begin 3407 result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[ssf_search_option],option); 3408 end; 3409 searchsym_typenull3410 function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; 3411 var 3412 hashedid : THashedIDString; 3413 stackitem : psymtablestackitem; 3414 classh : tobjectdef; 3415 begin 3416 result:=false; 3417 hashedid.id:=s; 3418 stackitem:=symtablestack.stack; 3419 while assigned(stackitem) do 3420 begin 3421 { 3422 It is not possible to have type symbols in: 3423 parameters 3424 Exception are classes, objects, records, generic definitions and specializations 3425 that have the parameterized types inserted in the symtable. 3426 } 3427 srsymtable:=stackitem^.symtable; 3428 if (srsymtable.symtabletype=ObjectSymtable) then 3429 begin 3430 classh:=tobjectdef(srsymtable.defowner); 3431 while assigned(classh) do 3432 begin 3433 srsymtable:=classh.symtable; 3434 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3435 if assigned(srsym) and 3436 not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and 3437 is_visible_for_object(srsym,current_structdef) then 3438 begin 3439 addsymref(srsym); 3440 result:=true; 3441 exit; 3442 end; 3443 classh:=classh.childof; 3444 end; 3445 end 3446 else 3447 begin 3448 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3449 if assigned(srsym) and 3450 ( 3451 not(srsym.typ in [unitsym,namespacesym]) or 3452 srsymtable.iscurrentunit or 3453 (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid)) 3454 ) and 3455 not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and 3456 (not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,current_structdef)) then 3457 begin 3458 { we need to know if a procedure references symbols 3459 in the static symtable, because then it can't be 3460 inlined from outside this unit } 3461 if assigned(current_procinfo) and 3462 (srsym.owner.symtabletype=staticsymtable) then 3463 include(current_procinfo.flags,pi_uses_static_symtable); 3464 addsymref(srsym); 3465 result:=true; 3466 exit; 3467 end; 3468 end; 3469 stackitem:=stackitem^.next; 3470 end; 3471 result:=false; 3472 srsym:=nil; 3473 srsymtable:=nil; 3474 end; 3475 3476 searchsym_in_modulenull3477 function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; 3478 var 3479 pmod : tmodule; 3480 begin 3481 pmod:=tmodule(pm); 3482 result:=false; 3483 if assigned(pmod.globalsymtable) then 3484 begin 3485 srsym:=tsym(pmod.globalsymtable.Find(s)); 3486 if assigned(srsym) then 3487 begin 3488 srsymtable:=pmod.globalsymtable; 3489 addsymref(srsym); 3490 result:=true; 3491 exit; 3492 end; 3493 end; 3494 { If the module is the current unit we also need 3495 to search the local symtable } 3496 if (pmod=current_module) and 3497 assigned(pmod.localsymtable) then 3498 begin 3499 srsym:=tsym(pmod.localsymtable.Find(s)); 3500 if assigned(srsym) then 3501 begin 3502 srsymtable:=pmod.localsymtable; 3503 addsymref(srsym); 3504 result:=true; 3505 exit; 3506 end; 3507 end; 3508 srsym:=nil; 3509 srsymtable:=nil; 3510 end; 3511 3512 searchsym_in_named_modulenull3513 function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean; 3514 var 3515 stackitem : psymtablestackitem; 3516 begin 3517 result:=false; 3518 stackitem:=symtablestack.stack; 3519 while assigned(stackitem) do 3520 begin 3521 srsymtable:=stackitem^.symtable; 3522 if (srsymtable.symtabletype=globalsymtable) and 3523 (srsymtable.name^=unitname) then 3524 begin 3525 srsym:=tsym(srsymtable.find(symname)); 3526 if not assigned(srsym) then 3527 break; 3528 result:=true; 3529 exit; 3530 end; 3531 stackitem:=stackitem^.next; 3532 end; 3533 3534 { If the module is the current unit we also need 3535 to search the local symtable } 3536 if assigned(current_module.localsymtable) and 3537 (current_module.localsymtable.name^=unitname) then 3538 begin 3539 srsymtable:=current_module.localsymtable; 3540 srsym:=tsym(srsymtable.find(symname)); 3541 if assigned(srsym) then 3542 begin 3543 result:=true; 3544 exit; 3545 end; 3546 end; 3547 end; 3548 3549 maybe_find_real_class_definitionnull3550 function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef; 3551 begin 3552 result:=pd; 3553 if pd.typ<>objectdef then 3554 exit; 3555 result:=find_real_class_definition(tobjectdef(pd),erroronfailure); 3556 end; 3557 3558 find_real_class_definitionnull3559 function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef; 3560 var 3561 hashedid : THashedIDString; 3562 stackitem : psymtablestackitem; 3563 srsymtable : tsymtable; 3564 srsym : tsym; 3565 formalname, 3566 foundname : shortstring; 3567 formalnameptr, 3568 foundnameptr: pshortstring; 3569 begin 3570 { not a formal definition -> return it } 3571 if not(oo_is_formal in pd.objectoptions) then 3572 begin 3573 result:=pd; 3574 exit; 3575 end; 3576 hashedid.id:=pd.typesym.name; 3577 stackitem:=symtablestack.stack; 3578 while assigned(stackitem) do 3579 begin 3580 srsymtable:=stackitem^.symtable; 3581 { ObjC classes can't appear in generics or as nested class 3582 definitions. Java classes can. } 3583 if not(srsymtable.symtabletype in [recordsymtable,parasymtable]) or 3584 (is_java_class_or_interface(pd) and 3585 (srsymtable.symtabletype=ObjectSymtable)) then 3586 begin 3587 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3588 if assigned(srsym) and 3589 (srsym.typ=typesym) and 3590 (ttypesym(srsym).typedef.typ=objectdef) and 3591 (tobjectdef(ttypesym(srsym).typedef).objecttype=pd.objecttype) and 3592 not(oo_is_formal in tobjectdef(ttypesym(srsym).typedef).objectoptions) then 3593 begin 3594 if not(oo_is_forward in tobjectdef(ttypesym(srsym).typedef).objectoptions) then 3595 begin 3596 { the external name for the formal and the real 3597 definition must match } 3598 if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) or 3599 assigned(pd.import_lib) then 3600 begin 3601 if assigned(pd.import_lib) then 3602 formalname:=pd.import_lib^+'.' 3603 else 3604 formalname:=''; 3605 formalname:=formalname+pd.objextname^; 3606 if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) then 3607 foundname:=tobjectdef(ttypesym(srsym).typedef).import_lib^+'.' 3608 else 3609 foundname:=''; 3610 foundname:=foundname+tobjectdef(ttypesym(srsym).typedef).objextname^; 3611 3612 formalnameptr:=@formalname; 3613 foundnameptr:=@foundname; 3614 end 3615 else 3616 begin 3617 formalnameptr:=pd.objextname; 3618 foundnameptr:=tobjectdef(ttypesym(srsym).typedef).objextname; 3619 end; 3620 if foundnameptr^<>formalnameptr^ then 3621 begin 3622 MessagePos2(pd.typesym.fileinfo,sym_e_external_class_name_mismatch1,formalnameptr^,pd.typename); 3623 MessagePos1(srsym.fileinfo,sym_e_external_class_name_mismatch2,foundnameptr^); 3624 end; 3625 end; 3626 result:=tobjectdef(ttypesym(srsym).typedef); 3627 if assigned(current_procinfo) and 3628 (srsym.owner.symtabletype=staticsymtable) then 3629 include(current_procinfo.flags,pi_uses_static_symtable); 3630 addsymref(srsym); 3631 exit; 3632 end; 3633 end; 3634 stackitem:=stackitem^.next; 3635 end; 3636 { nothing found: optionally give an error and return the original 3637 (empty) one } 3638 if erroronfailure then 3639 Message1(sym_e_formal_class_not_resolved,pd.objrealname^); 3640 result:=pd; 3641 end; 3642 3643 searchsym_in_classnull3644 function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; 3645 var 3646 hashedid : THashedIDString; 3647 orgclass : tobjectdef; 3648 i : longint; 3649 begin 3650 orgclass:=classh; 3651 { in case this is a formal class, first find the real definition } 3652 if assigned(classh) then 3653 begin 3654 if (oo_is_formal in classh.objectoptions) then 3655 classh:=find_real_class_definition(classh,true); 3656 { The contextclassh is used for visibility. The classh must be equal to 3657 or be a parent of contextclassh. E.g. for inherited searches the classh is the 3658 parent or a class helper. } 3659 if not (def_is_related(contextclassh,classh) or 3660 (is_classhelper(contextclassh) and 3661 assigned(tobjectdef(contextclassh).extendeddef) and 3662 (tobjectdef(contextclassh).extendeddef.typ=objectdef) and 3663 def_is_related(tobjectdef(contextclassh).extendeddef,classh))) then 3664 internalerror(200811161); 3665 end; 3666 result:=false; 3667 hashedid.id:=s; 3668 { an Objective-C protocol or Java interface can inherit from multiple 3669 other protocols/interfaces -> use ImplementedInterfaces instead } 3670 if is_objcprotocol(classh) or 3671 is_javainterface(classh) then 3672 begin 3673 srsymtable:=classh.symtable; 3674 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3675 if assigned(srsym) and 3676 is_visible_for_object(srsym,contextclassh) then 3677 begin 3678 if not (ssf_no_addsymref in flags) then 3679 addsymref(srsym); 3680 result:=true; 3681 exit; 3682 end; 3683 for i:=0 to classh.ImplementedInterfaces.count-1 do 3684 begin 3685 if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,flags-[ssf_search_helper]) then 3686 begin 3687 result:=true; 3688 exit; 3689 end; 3690 end; 3691 end 3692 else 3693 if is_objectpascal_helper(classh) then 3694 begin 3695 { helpers have their own obscure search logic... } 3696 result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,flags-[ssf_has_inherited]); 3697 if result then 3698 exit; 3699 end 3700 else 3701 begin 3702 while assigned(classh) do 3703 begin 3704 { search for a class helper method first if this is an Object 3705 Pascal class and we haven't yet found a helper symbol } 3706 if (classh.objecttype in objecttypes_with_helpers) and 3707 (ssf_search_helper in flags) then 3708 begin 3709 result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable); 3710 { an eventual overload inside the extended type's hierarchy 3711 will be found by tcallcandidates } 3712 if result then 3713 exit; 3714 end; 3715 srsymtable:=classh.symtable; 3716 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3717 if assigned(srsym) and 3718 is_visible_for_object(srsym,contextclassh) then 3719 begin 3720 if not (ssf_no_addsymref in flags) then 3721 addsymref(srsym); 3722 result:=true; 3723 exit; 3724 end; 3725 classh:=classh.childof; 3726 end; 3727 end; 3728 if is_objcclass(orgclass) then 3729 result:=search_objc_helper(orgclass,s,srsym,srsymtable) 3730 else 3731 begin 3732 srsym:=nil; 3733 srsymtable:=nil; 3734 end; 3735 end; 3736 searchsym_in_recordnull3737 function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; 3738 var 3739 hashedid : THashedIDString; 3740 begin 3741 result:=false; 3742 hashedid.id:=s; 3743 { search for a record helper method first } 3744 result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable); 3745 if result then 3746 { an eventual overload inside the extended type's hierarchy 3747 will be found by tcallcandidates } 3748 exit; 3749 srsymtable:=recordh.symtable; 3750 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3751 if assigned(srsym) and is_visible_for_object(srsym,recordh) then 3752 begin 3753 addsymref(srsym); 3754 result:=true; 3755 exit; 3756 end; 3757 srsym:=nil; 3758 srsymtable:=nil; 3759 end; 3760 searchsym_in_class_by_msgintnull3761 function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; 3762 var 3763 def : tdef; 3764 i : longint; 3765 begin 3766 { in case this is a formal class, first find the real definition } 3767 if assigned(classh) and 3768 (oo_is_formal in classh.objectoptions) then 3769 classh:=find_real_class_definition(classh,true); 3770 result:=false; 3771 def:=nil; 3772 while assigned(classh) do 3773 begin 3774 for i:=0 to classh.symtable.DefList.Count-1 do 3775 begin 3776 def:=tstoreddef(classh.symtable.DefList[i]); 3777 { Find also all hidden private methods to 3778 be compatible with delphi, see tw6203 (PFV) } 3779 if (def.typ=procdef) and 3780 (po_msgint in tprocdef(def).procoptions) and 3781 (tprocdef(def).messageinf.i=msgid) then 3782 begin 3783 srdef:=def; 3784 srsym:=tprocdef(def).procsym; 3785 srsymtable:=classh.symtable; 3786 addsymref(srsym); 3787 result:=true; 3788 exit; 3789 end; 3790 end; 3791 classh:=classh.childof; 3792 end; 3793 srdef:=nil; 3794 srsym:=nil; 3795 srsymtable:=nil; 3796 end; 3797 3798 searchsym_in_class_by_msgstrnull3799 function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean; 3800 var 3801 def : tdef; 3802 i : longint; 3803 begin 3804 { in case this is a formal class, first find the real definition } 3805 if assigned(classh) and 3806 (oo_is_formal in classh.objectoptions) then 3807 classh:=find_real_class_definition(classh,true); 3808 result:=false; 3809 def:=nil; 3810 while assigned(classh) do 3811 begin 3812 for i:=0 to classh.symtable.DefList.Count-1 do 3813 begin 3814 def:=tstoreddef(classh.symtable.DefList[i]); 3815 { Find also all hidden private methods to 3816 be compatible with delphi, see tw6203 (PFV) } 3817 if (def.typ=procdef) and 3818 (po_msgstr in tprocdef(def).procoptions) and 3819 (tprocdef(def).messageinf.str^=s) then 3820 begin 3821 srsym:=tprocdef(def).procsym; 3822 srsymtable:=classh.symtable; 3823 addsymref(srsym); 3824 result:=true; 3825 exit; 3826 end; 3827 end; 3828 classh:=classh.childof; 3829 end; 3830 srsym:=nil; 3831 srsymtable:=nil; 3832 end; 3833 searchsym_in_helpernull3834 function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean; 3835 var 3836 hashedid : THashedIDString; 3837 parentclassh : tobjectdef; 3838 begin 3839 result:=false; 3840 if not is_objectpascal_helper(classh) then 3841 Internalerror(2011030101); 3842 hashedid.id:=s; 3843 { in a helper things are a bit more complex: 3844 1. search the symbol in the helper (if not "inherited") 3845 2. search the symbol in the extended type 3846 3. search the symbol in the parent helpers 3847 4. only classes: search the symbol in the parents of the extended type 3848 } 3849 if not (ssf_has_inherited in flags) then 3850 begin 3851 { search in the helper itself } 3852 srsymtable:=classh.symtable; 3853 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3854 if assigned(srsym) and 3855 is_visible_for_object(srsym,contextclassh) then 3856 begin 3857 if not (ssf_no_addsymref in flags) then 3858 addsymref(srsym); 3859 result:=true; 3860 exit; 3861 end; 3862 end; 3863 { now search in the extended type itself } 3864 { Note: the extendeddef might be Nil if we are currently parsing the 3865 extended type itself and the identifier was not found } 3866 if assigned(classh.extendeddef) and (classh.extendeddef.typ in [recorddef,objectdef]) then 3867 begin 3868 srsymtable:=tabstractrecorddef(classh.extendeddef).symtable; 3869 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3870 if assigned(srsym) and 3871 is_visible_for_object(srsym,contextclassh) then 3872 begin 3873 if not (ssf_no_addsymref in flags) then 3874 addsymref(srsym); 3875 result:=true; 3876 exit; 3877 end; 3878 end; 3879 { now search in the parent helpers } 3880 parentclassh:=classh.childof; 3881 while assigned(parentclassh) do 3882 begin 3883 srsymtable:=parentclassh.symtable; 3884 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 3885 if assigned(srsym) and 3886 is_visible_for_object(srsym,contextclassh) then 3887 begin 3888 if not (ssf_no_addsymref in flags) then 3889 addsymref(srsym); 3890 result:=true; 3891 exit; 3892 end; 3893 parentclassh:=parentclassh.childof; 3894 end; 3895 if is_class(classh.extendeddef) then 3896 { now search in the parents of the extended class (with helpers!) } 3897 result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,flags+[ssf_search_helper]); 3898 { addsymref is already called by searchsym_in_class } 3899 end; 3900 search_specific_assignment_operatornull3901 function search_specific_assignment_operator(assignment_type:ttoken;from_def,to_def:Tdef):Tprocdef; 3902 var 3903 sym : Tprocsym; 3904 hashedid : THashedIDString; 3905 curreq, 3906 besteq : tequaltype; 3907 currpd, 3908 bestpd : tprocdef; 3909 stackitem : psymtablestackitem; 3910 shortstringcount : longint; 3911 isexplicit, 3912 checkshortstring : boolean; 3913 begin 3914 hashedid.id:=overloaded_names[assignment_type]; 3915 besteq:=te_incompatible; 3916 bestpd:=nil; 3917 stackitem:=symtablestack.stack; 3918 { special handling for assignments to shortstrings with a specific length: 3919 - if we get an operator to ShortString we use that 3920 - if we get only a single String[x] operator we use that 3921 - otherwise it's a nogo } 3922 isexplicit:=assignment_type=_OP_EXPLICIT; 3923 shortstringcount:=0; 3924 checkshortstring:=not isexplicit and is_shortstring(to_def) and (tstringdef(to_def).len<>255); 3925 while assigned(stackitem) do 3926 begin 3927 sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid)); 3928 if sym<>nil then 3929 begin 3930 if sym.typ<>procsym then 3931 internalerror(200402031); 3932 { if the source type is an alias then this is only the second choice, 3933 if you mess with this code, check tw4093 } 3934 currpd:=sym.find_procdef_assignment_operator(from_def,to_def,curreq,isexplicit); 3935 { we found a ShortString overload, use that and be done } 3936 if checkshortstring and 3937 assigned(currpd) and 3938 is_shortstring(currpd.returndef) and 3939 (tstringdef(currpd.returndef).len=255) then 3940 begin 3941 besteq:=curreq; 3942 bestpd:=currpd; 3943 break; 3944 end; 3945 { independently of the operator being better count if we encountered 3946 multpile String[x] operators } 3947 if checkshortstring and assigned(currpd) and is_shortstring(currpd.returndef) then 3948 inc(shortstringcount); 3949 if curreq>besteq then 3950 begin 3951 besteq:=curreq; 3952 bestpd:=currpd; 3953 { don't stop searching if we have a String[x] operator cause 3954 we might find a ShortString one or multiple ones (which 3955 leads to no operator use) } 3956 if (besteq=te_exact) and not checkshortstring then 3957 break; 3958 end; 3959 end; 3960 stackitem:=stackitem^.next; 3961 end; 3962 if checkshortstring and (shortstringcount>1) then 3963 bestpd:=nil; 3964 result:=bestpd; 3965 end; 3966 3967 search_assignment_operatornull3968 function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef; 3969 begin 3970 { search record/object symtable first for a suitable operator } 3971 if from_def.typ in [recorddef,objectdef] then 3972 symtablestack.push(tabstractrecorddef(from_def).symtable); 3973 if to_def.typ in [recorddef,objectdef] then 3974 symtablestack.push(tabstractrecorddef(to_def).symtable); 3975 3976 { if type conversion is explicit then search first for explicit 3977 operator overload and if not found then use implicit operator } 3978 if explicit then 3979 result:=search_specific_assignment_operator(_OP_EXPLICIT,from_def,to_def) 3980 else 3981 result:=nil; 3982 if result=nil then 3983 result:=search_specific_assignment_operator(_ASSIGNMENT,from_def,to_def); 3984 3985 { restore symtable stack } 3986 if to_def.typ in [recorddef,objectdef] then 3987 symtablestack.pop(tabstractrecorddef(to_def).symtable); 3988 if from_def.typ in [recorddef,objectdef] then 3989 symtablestack.pop(tabstractrecorddef(from_def).symtable); 3990 end; 3991 3992 search_enumerator_operatornull3993 function search_enumerator_operator(from_def,to_def:Tdef): Tprocdef; 3994 var 3995 sym : Tprocsym; 3996 hashedid : THashedIDString; 3997 curreq, 3998 besteq : tequaltype; 3999 currpd, 4000 bestpd : tprocdef; 4001 stackitem : psymtablestackitem; 4002 begin 4003 hashedid.id:='enumerator'; 4004 besteq:=te_incompatible; 4005 bestpd:=nil; 4006 stackitem:=symtablestack.stack; 4007 while assigned(stackitem) do 4008 begin 4009 sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid)); 4010 if sym<>nil then 4011 begin 4012 if sym.typ<>procsym then 4013 internalerror(200910241); 4014 { if the source type is an alias then this is only the second choice, 4015 if you mess with this code, check tw4093 } 4016 currpd:=sym.find_procdef_enumerator_operator(from_def,to_def,curreq); 4017 if curreq>besteq then 4018 begin 4019 besteq:=curreq; 4020 bestpd:=currpd; 4021 if (besteq=te_exact) then 4022 break; 4023 end; 4024 end; 4025 stackitem:=stackitem^.next; 4026 end; 4027 result:=bestpd; 4028 end; 4029 4030 search_management_operatornull4031 function search_management_operator(mop:tmanagementoperator;pd:Tdef):Tprocdef; 4032 var 4033 sym : Tprocsym; 4034 hashedid : THashedIDString; 4035 optoken: ttoken; 4036 begin 4037 optoken := managementoperator2tok[mop]; 4038 if (optoken<first_managment_operator) or 4039 (optoken>last_managment_operator) then 4040 internalerror(201602280); 4041 hashedid.id:=overloaded_names[optoken]; 4042 if not (pd.typ in [recorddef]) then 4043 internalerror(201602281); 4044 sym:=Tprocsym(tabstractrecorddef(pd).symtable.FindWithHash(hashedid)); 4045 if sym<>nil then 4046 begin 4047 if sym.typ<>procsym then 4048 internalerror(201602282); 4049 result:=sym.find_procdef_bytype(potype_operator); 4050 end 4051 else 4052 result:=nil; 4053 end; 4054 4055 search_system_typenull4056 function search_system_type(const s: TIDString): ttypesym; 4057 var 4058 sym : tsym; 4059 begin 4060 sym:=tsym(systemunit.Find(s)); 4061 if not assigned(sym) or 4062 (sym.typ<>typesym) then 4063 message1(cg_f_unknown_system_type,s); 4064 result:=ttypesym(sym); 4065 end; 4066 4067 try_search_system_typenull4068 function try_search_system_type(const s: TIDString): ttypesym; 4069 var 4070 sym : tsym; 4071 begin 4072 sym:=tsym(systemunit.Find(s)); 4073 if not assigned(sym) then 4074 result:=nil 4075 else 4076 begin 4077 if sym.typ<>typesym then 4078 message1(cg_f_unknown_system_type,s); 4079 result:=ttypesym(sym); 4080 end; 4081 end; 4082 4083 try_search_current_module_typenull4084 function try_search_current_module_type(const s: TIDString): ttypesym; 4085 var 4086 found: boolean; 4087 srsymtable: tsymtable; 4088 srsym: tsym; 4089 begin 4090 if s[1]='$' then 4091 found:=searchsym_in_module(current_module,copy(s,2,length(s)),srsym,srsymtable) 4092 else 4093 found:=searchsym_in_module(current_module,s,srsym,srsymtable); 4094 if found then 4095 begin 4096 if (srsym.typ<>typesym) then 4097 internalerror(2014091207); 4098 result:=ttypesym(srsym); 4099 end 4100 else 4101 result:=nil; 4102 end; 4103 4104 search_system_procnull4105 function search_system_proc(const s: TIDString): tprocdef; 4106 var 4107 srsym: tsym; 4108 begin 4109 srsym:=tsym(systemunit.find(s)); 4110 if not assigned(srsym) and 4111 (cs_compilesystem in current_settings.moduleswitches) then 4112 srsym:=tsym(systemunit.Find(upper(s))); 4113 if not assigned(srsym) or 4114 (srsym.typ<>procsym) then 4115 message1(cg_f_unknown_compilerproc,s); 4116 result:=tprocdef(tprocsym(srsym).procdeflist[0]); 4117 end; 4118 4119 search_named_unit_globaltypenull4120 function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym; 4121 var 4122 srsymtable: tsymtable; 4123 sym: tsym; 4124 begin 4125 sym:=nil; 4126 if searchsym_in_named_module(unitname,typename,sym,srsymtable) and 4127 (sym.typ=typesym) then 4128 begin 4129 result:=ttypesym(sym); 4130 exit; 4131 end 4132 else 4133 begin 4134 if throwerror then 4135 message2(cg_f_unknown_type_in_unit,typename,unitname); 4136 result:=nil; 4137 end; 4138 end; 4139 search_last_objectpascal_helpernull4140 function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean; 4141 var 4142 s: string; 4143 list: TFPObjectList; 4144 i: integer; 4145 st: tsymtable; 4146 begin 4147 result:=false; 4148 odef:=nil; 4149 { when there are no helpers active currently then we don't need to do 4150 anything } 4151 if current_module.extendeddefs.count=0 then 4152 exit; 4153 if (df_genconstraint in pd.defoptions) then 4154 begin 4155 { if we have a constraint for a class type or a single interface we 4156 use that to resolve helpers at declaration time of the generic, 4157 otherwise there can't be any helpers as the type isn't known yet } 4158 if pd.typ=objectdef then 4159 pd:=tobjectdef(pd).getparentdef 4160 else 4161 exit; 4162 end; 4163 { no helpers for anonymous types } 4164 if ((pd.typ in [recorddef,objectdef]) and 4165 ( 4166 not assigned(tabstractrecorddef(pd).objrealname) or 4167 (tabstractrecorddef(pd).objrealname^='') 4168 ) 4169 ) or 4170 not assigned(pd.typesym) then 4171 exit; 4172 { if pd is defined inside a procedure we must not use make_mangledname 4173 (as a helper may not be defined in a procedure this is no problem...)} 4174 st:=pd.owner; 4175 while st.symtabletype in [objectsymtable,recordsymtable] do 4176 st:=st.defowner.owner; 4177 if st.symtabletype=localsymtable then 4178 exit; 4179 { the mangled name is used as the key for tmodule.extendeddefs } 4180 s:=generate_objectpascal_helper_key(pd); 4181 list:=TFPObjectList(current_module.extendeddefs.Find(s)); 4182 if assigned(list) and (list.count>0) then 4183 begin 4184 i:=list.count-1; 4185 repeat 4186 odef:=tobjectdef(list[list.count-1]); 4187 result:=(odef.owner.symtabletype in [staticsymtable,globalsymtable]) or 4188 is_visible_for_object(tobjectdef(list[i]).typesym,contextclassh); 4189 dec(i); 4190 until result or (i<0); 4191 if not result then 4192 { just to be sure that noone uses odef } 4193 odef:=nil; 4194 end; 4195 end; 4196 search_objectpascal_helpernull4197 function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean; 4198 4199 var 4200 hashedid : THashedIDString; 4201 classh : tobjectdef; 4202 i : integer; 4203 pdef : tprocdef; 4204 begin 4205 result:=false; 4206 4207 { if there is no class helper for the class then there is no need to 4208 search further } 4209 if not search_last_objectpascal_helper(pd,contextclassh,classh) then 4210 exit; 4211 4212 hashedid.id:=s; 4213 4214 repeat 4215 srsymtable:=classh.symtable; 4216 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 4217 4218 if srsym<>nil then 4219 begin 4220 case srsym.typ of 4221 procsym: 4222 begin 4223 for i:=0 to tprocsym(srsym).procdeflist.count-1 do 4224 begin 4225 pdef:=tprocdef(tprocsym(srsym).procdeflist[i]); 4226 if not is_visible_for_object(pdef.owner,pdef.visibility,contextclassh) then 4227 continue; 4228 { we need to know if a procedure references symbols 4229 in the static symtable, because then it can't be 4230 inlined from outside this unit } 4231 if assigned(current_procinfo) and 4232 (srsym.owner.symtabletype=staticsymtable) then 4233 include(current_procinfo.flags,pi_uses_static_symtable); 4234 { the first found method wins } 4235 srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym; 4236 srsymtable:=srsym.owner; 4237 addsymref(srsym); 4238 result:=true; 4239 exit; 4240 end; 4241 end; 4242 typesym, 4243 fieldvarsym, 4244 constsym, 4245 enumsym, 4246 undefinedsym, 4247 propertysym: 4248 begin 4249 addsymref(srsym); 4250 result:=true; 4251 exit; 4252 end; 4253 else 4254 internalerror(2014041101); 4255 end; 4256 end; 4257 4258 { try the helper parent if available } 4259 classh:=classh.childof; 4260 until classh=nil; 4261 4262 srsym:=nil; 4263 srsymtable:=nil; 4264 end; 4265 search_objc_helpernull4266 function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; 4267 var 4268 searchst : tsymtable; 4269 searchsym : tsym; 4270 hashedid : THashedIDString; 4271 stackitem : psymtablestackitem; 4272 i : longint; 4273 founddefowner, 4274 defowner : tobjectdef; 4275 begin 4276 hashedid.id:=class_helper_prefix+s; 4277 stackitem:=symtablestack.stack; 4278 result:=false; 4279 srsym:=nil; 4280 srsymtable:=nil; 4281 founddefowner:=nil; 4282 while assigned(stackitem) do 4283 begin 4284 searchst:=stackitem^.symtable; 4285 searchsym:=tsym(searchst.FindWithHash(hashedid)); 4286 if assigned(searchsym) then 4287 begin 4288 if not(searchst.symtabletype in [globalsymtable,staticsymtable]) or 4289 not(searchsym.owner.symtabletype in [globalsymtable,staticsymtable]) or 4290 (searchsym.typ<>procsym) then 4291 internalerror(2009111505); 4292 { check whether this procsym includes a helper for this particular class } 4293 for i:=0 to tprocsym(searchsym).procdeflist.count-1 do 4294 begin 4295 { does pd inherit from (or is the same as) the class 4296 that this method's category extended? 4297 4298 Warning: this list contains both category and objcclass methods 4299 (for id.randommethod), so only check category methods here 4300 } 4301 defowner:=tobjectdef(tprocdef(tprocsym(searchsym).procdeflist[i]).owner.defowner); 4302 if is_objccategory(defowner) and 4303 def_is_related(pd,defowner.childof) then 4304 begin 4305 { we need to know if a procedure references symbols 4306 in the static symtable, because then it can't be 4307 inlined from outside this unit } 4308 if assigned(current_procinfo) and 4309 (searchsym.owner.symtabletype=staticsymtable) then 4310 include(current_procinfo.flags,pi_uses_static_symtable); 4311 { Stop looking if this is a category that extends the specified 4312 class itself. There might be other categories that extend this, 4313 but that doesn't matter. If it extens a parent, keep looking 4314 in case we find the symbol in a category that extends this class 4315 (or a closer parent). 4316 } 4317 if not result or 4318 def_is_related(defowner.childof,founddefowner) then 4319 begin 4320 founddefowner:=defowner.childof; 4321 srsym:=tprocdef(tprocsym(searchsym).procdeflist[i]).procsym; 4322 srsymtable:=srsym.owner; 4323 result:=true; 4324 if pd=founddefowner then 4325 begin 4326 addsymref(srsym); 4327 exit; 4328 end; 4329 end; 4330 end; 4331 end; 4332 end; 4333 stackitem:=stackitem^.next; 4334 end; 4335 if result then 4336 begin 4337 addsymref(srsym); 4338 exit; 4339 end; 4340 end; 4341 4342 search_objc_methodnull4343 function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean; 4344 var 4345 hashedid : THashedIDString; 4346 stackitem : psymtablestackitem; 4347 i : longint; 4348 begin 4349 hashedid.id:=class_helper_prefix+s; 4350 stackitem:=symtablestack.stack; 4351 while assigned(stackitem) do 4352 begin 4353 srsymtable:=stackitem^.symtable; 4354 srsym:=tsym(srsymtable.FindWithHash(hashedid)); 4355 if assigned(srsym) then 4356 begin 4357 if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or 4358 not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or 4359 (srsym.typ<>procsym) then 4360 internalerror(2009112005); 4361 { check whether this procsym includes a helper for this particular class } 4362 for i:=0 to tprocsym(srsym).procdeflist.count-1 do 4363 begin 4364 { we need to know if a procedure references symbols 4365 in the static symtable, because then it can't be 4366 inlined from outside this unit } 4367 if assigned(current_procinfo) and 4368 (srsym.owner.symtabletype=staticsymtable) then 4369 include(current_procinfo.flags,pi_uses_static_symtable); 4370 { no need to keep looking. There might be other 4371 methods with the same name, but that doesn't matter 4372 as far as the basic procsym is concerned. 4373 } 4374 srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym; 4375 { We need the symtable in which the classhelper-like sym 4376 is located, not the objectdef. The reason is that the 4377 callnode will climb the symtablestack until it encounters 4378 this symtable to start looking for overloads (and it won't 4379 find the objectsymtable in which this method sym is 4380 located 4381 4382 srsymtable:=srsym.owner; 4383 } 4384 addsymref(srsym); 4385 result:=true; 4386 exit; 4387 end; 4388 end; 4389 stackitem:=stackitem^.next; 4390 end; 4391 srsym:=nil; 4392 srsymtable:=nil; 4393 result:=false; 4394 end; 4395 4396 search_struct_membernull4397 function search_struct_member(pd : tabstractrecorddef;const s : string):tsym; 4398 { searches n in symtable of pd and all anchestors } 4399 var 4400 srsymtable : tsymtable; 4401 begin 4402 { in case this is a formal class, first find the real definition } 4403 if (oo_is_formal in pd.objectoptions) then 4404 pd:=find_real_class_definition(tobjectdef(pd),true); 4405 4406 if search_objectpascal_helper(pd, pd, s, result, srsymtable) then 4407 exit; 4408 4409 result:=search_struct_member_no_helper(pd,s); 4410 if assigned(result) then 4411 exit; 4412 4413 { not found, now look for class helpers } 4414 if is_objcclass(pd) then 4415 search_objc_helper(tobjectdef(pd),s,result,srsymtable) 4416 end; 4417 4418 search_struct_member_no_helpernull4419 function search_struct_member_no_helper(pd: tabstractrecorddef; const s: string): tsym; 4420 var 4421 hashedid : THashedIDString; 4422 srsym : tsym; 4423 begin 4424 hashedid.id:=s; 4425 while assigned(pd) do 4426 begin 4427 srsym:=tsym(pd.symtable.FindWithHash(hashedid)); 4428 if assigned(srsym) then 4429 begin 4430 result:=srsym; 4431 exit; 4432 end; 4433 if pd.typ=objectdef then 4434 pd:=tobjectdef(pd).childof 4435 else 4436 pd:=nil; 4437 end; 4438 result:=nil; 4439 end; 4440 4441 search_macronull4442 function search_macro(const s : string):tsym; 4443 var 4444 stackitem : psymtablestackitem; 4445 hashedid : THashedIDString; 4446 srsym : tsym; 4447 begin 4448 hashedid.id:=s; 4449 4450 { First search the localmacrosymtable before searching the 4451 global macrosymtables from the units } 4452 if assigned(current_module) then 4453 begin 4454 srsym:=tsym(current_module.localmacrosymtable.FindWithHash(hashedid)); 4455 if assigned(srsym) then 4456 begin 4457 result:= srsym; 4458 exit; 4459 end; 4460 end; 4461 4462 stackitem:=macrosymtablestack.stack; 4463 while assigned(stackitem) do 4464 begin 4465 srsym:=tsym(stackitem^.symtable.FindWithHash(hashedid)); 4466 if assigned(srsym) then 4467 begin 4468 result:= srsym; 4469 exit; 4470 end; 4471 stackitem:=stackitem^.next; 4472 end; 4473 result:= nil; 4474 end; 4475 4476 defined_macronull4477 function defined_macro(const s : string):boolean; 4478 var 4479 mac: tmacro; 4480 begin 4481 mac:=tmacro(search_macro(s)); 4482 if assigned(mac) then 4483 begin 4484 mac.is_used:=true; 4485 defined_macro:=mac.defined; 4486 end 4487 else 4488 defined_macro:=false; 4489 end; 4490 4491 4492 {**************************************************************************** 4493 Object Helpers 4494 ****************************************************************************} 4495 search_default_propertynull4496 function search_default_property(pd : tabstractrecorddef) : tpropertysym; 4497 { returns the default property of a class, searches also anchestors } 4498 var 4499 _defaultprop : tpropertysym; 4500 helperpd : tobjectdef; 4501 begin 4502 _defaultprop:=nil; 4503 { first search in helper's hierarchy } 4504 if search_last_objectpascal_helper(pd,nil,helperpd) then 4505 while assigned(helperpd) do 4506 begin 4507 helperpd.symtable.SymList.ForEachCall(@tstoredsymtable(helperpd.symtable).testfordefaultproperty,@_defaultprop); 4508 if assigned(_defaultprop) then 4509 break; 4510 helperpd:=helperpd.childof; 4511 end; 4512 if assigned(_defaultprop) then 4513 begin 4514 search_default_property:=_defaultprop; 4515 exit; 4516 end; 4517 { now search in the type's hierarchy itself } 4518 while assigned(pd) do 4519 begin 4520 pd.symtable.SymList.ForEachCall(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop); 4521 if assigned(_defaultprop) then 4522 break; 4523 if (pd.typ=objectdef) then 4524 pd:=tobjectdef(pd).childof 4525 else 4526 break; 4527 end; 4528 search_default_property:=_defaultprop; 4529 end; 4530 4531 4532 {**************************************************************************** 4533 Macro Helpers 4534 ****************************************************************************} 4535 4536 procedure def_system_macro(const name : string); 4537 var 4538 mac : tmacro; 4539 s: string; 4540 begin 4541 if name = '' then 4542 internalerror(2004121202); 4543 s:= upper(name); 4544 mac:=tmacro(search_macro(s)); 4545 if not assigned(mac) then 4546 begin 4547 mac:=tmacro.create(s); 4548 if assigned(current_module) then 4549 current_module.localmacrosymtable.insert(mac) 4550 else 4551 initialmacrosymtable.insert(mac); 4552 end; 4553 Message1(parser_c_macro_defined,mac.name); 4554 mac.defined:=true; 4555 end; 4556 4557 4558 procedure set_system_macro(const name, value : string); 4559 var 4560 mac : tmacro; 4561 s: string; 4562 begin 4563 if name = '' then 4564 internalerror(2004121203); 4565 s:= upper(name); 4566 mac:=tmacro(search_macro(s)); 4567 if not assigned(mac) then 4568 begin 4569 mac:=tmacro.create(s); 4570 if assigned(current_module) then 4571 current_module.localmacrosymtable.insert(mac) 4572 else 4573 initialmacrosymtable.insert(mac); 4574 end 4575 else 4576 begin 4577 mac.is_compiler_var:=false; 4578 if assigned(mac.buftext) then 4579 freemem(mac.buftext,mac.buflen); 4580 end; 4581 Message2(parser_c_macro_set_to,mac.name,value); 4582 mac.buflen:=length(value); 4583 getmem(mac.buftext,mac.buflen); 4584 move(value[1],mac.buftext^,mac.buflen); 4585 mac.defined:=true; 4586 end; 4587 4588 4589 procedure set_system_compvar(const name, value : string); 4590 var 4591 mac : tmacro; 4592 s: string; 4593 begin 4594 if name = '' then 4595 internalerror(2004121204); 4596 s:= upper(name); 4597 mac:=tmacro(search_macro(s)); 4598 if not assigned(mac) then 4599 begin 4600 mac:=tmacro.create(s); 4601 mac.is_compiler_var:=true; 4602 if assigned(current_module) then 4603 current_module.localmacrosymtable.insert(mac) 4604 else 4605 initialmacrosymtable.insert(mac); 4606 end 4607 else 4608 begin 4609 mac.is_compiler_var:=true; 4610 if assigned(mac.buftext) then 4611 freemem(mac.buftext,mac.buflen); 4612 end; 4613 Message2(parser_c_macro_set_to,mac.name,value); 4614 mac.buflen:=length(value); 4615 getmem(mac.buftext,mac.buflen); 4616 move(value[1],mac.buftext^,mac.buflen); 4617 mac.defined:=true; 4618 end; 4619 4620 4621 procedure undef_system_macro(const name : string); 4622 var 4623 mac : tmacro; 4624 s: string; 4625 begin 4626 if name = '' then 4627 internalerror(2004121205); 4628 s:= upper(name); 4629 mac:=tmacro(search_macro(s)); 4630 if not assigned(mac) then 4631 {If not found, then it's already undefined.} 4632 else 4633 begin 4634 Message1(parser_c_macro_undefined,mac.name); 4635 mac.defined:=false; 4636 mac.is_compiler_var:=false; 4637 { delete old definition } 4638 if assigned(mac.buftext) then 4639 begin 4640 freemem(mac.buftext,mac.buflen); 4641 mac.buftext:=nil; 4642 end; 4643 end; 4644 end; 4645 4646 4647 {$ifdef UNITALIASES} 4648 {**************************************************************************** 4649 TUNIT_ALIAS 4650 ****************************************************************************} 4651 4652 constructor tunit_alias.create(const n:string); 4653 var 4654 i : longint; 4655 begin 4656 i:=pos('=',n); 4657 if i=0 then 4658 fail; 4659 inherited createname(Copy(n,1,i-1)); 4660 newname:=stringdup(Copy(n,i+1,255)); 4661 end; 4662 4663 4664 destructor tunit_alias.destroy; 4665 begin 4666 stringdispose(newname); 4667 inherited destroy; 4668 end; 4669 4670 4671 procedure addunitalias(const n:string); 4672 begin 4673 unitaliases^.insert(tunit_alias,init(Upper(n)))); 4674 end; 4675 4676 getunitaliasnull4677 function getunitalias(const n:string):string; 4678 var 4679 p : punit_alias; 4680 begin 4681 p:=punit_alias(unitaliases^.Find(Upper(n))); 4682 if assigned(p) then 4683 getunitalias:=punit_alias(p).newname^ 4684 else 4685 getunitalias:=n; 4686 end; 4687 {$endif UNITALIASES} 4688 4689 4690 {**************************************************************************** 4691 Init/Done Symtable 4692 ****************************************************************************} 4693 4694 procedure InitSymtable; 4695 begin 4696 { Reset symbolstack } 4697 symtablestack:=nil; 4698 systemunit:=nil; 4699 { create error syms and def } 4700 generrorsym:=terrorsym.create; 4701 generrordef:=cerrordef.create; 4702 { macros } 4703 initialmacrosymtable:=tmacrosymtable.create(false); 4704 macrosymtablestack:=TSymtablestack.create; 4705 macrosymtablestack.push(initialmacrosymtable); 4706 {$ifdef UNITALIASES} 4707 { unit aliases } 4708 unitaliases:=TFPHashObjectList.create; 4709 {$endif} 4710 { set some global vars to nil, might be important for the ide } 4711 class_tobject:=nil; 4712 interface_iunknown:=nil; 4713 interface_idispatch:=nil; 4714 rec_tguid:=nil; 4715 rec_jmp_buf:=nil; 4716 rec_exceptaddr:=nil; 4717 objc_metaclasstype:=nil; 4718 objc_superclasstype:=nil; 4719 objc_idtype:=nil; 4720 objc_seltype:=nil; 4721 objc_objecttype:=nil; 4722 dupnr:=0; 4723 end; 4724 4725 4726 procedure DoneSymtable; 4727 begin 4728 generrorsym.owner:=nil; 4729 generrorsym.free; 4730 generrordef.owner:=nil; 4731 generrordef.free; 4732 initialmacrosymtable.free; 4733 macrosymtablestack.free; 4734 {$ifdef UNITALIASES} 4735 unitaliases.free; 4736 {$endif} 4737 end; 4738 4739 end. 4740