1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708 |
- {
- Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
- This unit handles the symbol tables
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit symtable;
- {$i fpcdefs.inc}
- interface
- uses
- { common }
- cutils,cclasses,globtype,tokens,
- { symtable }
- symconst,symbase,symtype,symdef,symsym;
- {****************************************************************************
- Symtable types
- ****************************************************************************}
- type
- tstoredsymtable = class(TSymtable)
- private
- init_final_check_done : boolean;
- procedure _needs_init_final(sym:TObject;arg:pointer);
- procedure do_init_final_check;
- procedure check_forward(sym:TObject;arg:pointer);
- procedure check_block_valid(def: TObject;arg:pointer);
- procedure register_defs(def:tobject;arg:pointer);
- procedure register_syms(sym:tobject;arg:pointer);
- procedure labeldefined(sym:TObject;arg:pointer);
- procedure varsymbolused(sym:TObject;arg:pointer);
- procedure TestPrivate(sym:TObject;arg:pointer);
- procedure objectprivatesymbolused(sym:TObject;arg:pointer);
- procedure loaddefs(ppufile:tcompilerppufile);
- procedure loadsyms(ppufile:tcompilerppufile);
- procedure writedefs(ppufile:tcompilerppufile);
- procedure writesyms(ppufile:tcompilerppufile);
- public
- constructor create(const s:string);
- procedure insert(sym:TSymEntry;checkdup:boolean=true);override;
- procedure delete(sym:TSymEntry);override;
- { load/write }
- procedure ppuload(ppufile:tcompilerppufile);virtual;
- procedure ppuwrite(ppufile:tcompilerppufile);virtual;
- procedure buildderef;
- procedure buildderefimpl;
- { buildderef but only for (recursively) used symbols/defs }
- procedure buildderef_registered;
- procedure deref(only_registered: boolean);virtual;
- procedure derefimpl(only_registered: boolean);virtual;
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- procedure allsymbolsused;
- procedure allprivatesused;
- procedure check_forwards;
- procedure checklabels;
- function needs_init_final : boolean; virtual;
- function has_non_trivial_init:boolean;virtual;
- procedure testfordefaultproperty(sym:TObject;arg:pointer);
- procedure register_children;
- end;
- {$ifdef llvm}
- tllvmshadowsymtableentry = class
- constructor create(def: tdef; fieldoffset: aint);
- private
- ffieldoffset: aint;
- fdef: tdef;
- public
- property fieldoffset: aint read ffieldoffset;
- property def: tdef read fdef;
- end;
- tllvmshadowsymtable = class;
- {$endif llvm}
- tmanagementoperator_offset_entry = record
- pd : tprocdef;
- offset : asizeint;
- end;
- pmanagementoperator_offset_entry = ^tmanagementoperator_offset_entry;
- tabstractrecordsymtable = class(tstoredsymtable)
- {$ifdef llvm}
- private
- fllvmst: tllvmshadowsymtable;
- function getllvmshadowsymtabll: tllvmshadowsymtable;
- {$endif llvm}
- public
- usefieldalignment, { alignment to use for fields (PACKRECORDS value), C_alignment is C style }
- recordalignment, { alignment desired when inserting this record }
- fieldalignment, { alignment current alignment used when fields are inserted }
- padalignment : shortint; { size to a multiple of which the symtable has to be rounded up }
- recordalignmin, { local equivalents of global settings, so that records can }
- maxCrecordalign: shortint; { be created with custom settings internally }
- has_fields_with_mop : tmanagementoperators; { whether any of the fields has the need for a management operator (or one of the field's fields) }
- constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- destructor destroy;override;
- procedure ppuload(ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- procedure alignrecord(fieldoffset:asizeint;varalign:shortint);
- procedure addfield(sym:tfieldvarsym;vis:tvisibility);
- procedure addfieldlist(list: tfpobjectlist; maybereorder: boolean);
- { returns the field closest to this offset (may not be exact because
- of padding; internalerrors for variant records, assumes fields are
- ordered by increasing offset) }
- function findfieldbyoffset(offset:asizeint): tfieldvarsym;
- procedure addalignmentpadding;
- procedure insertdef(def:TDefEntry);override;
- function is_packed: boolean;
- function has_single_field(out def:tdef): boolean;
- function get_unit_symtable: tsymtable;
- { collects all management operators of the specified type in list (which
- is not cleared); the entries are copies and thus must be freed by the
- caller }
- procedure get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist);
- protected
- { size in bytes including padding }
- _datasize : asizeint;
- { size in bits of the data in case of bitpacked record. Only important during construction, }
- { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8. }
- databitsize : asizeint;
- { size in bytes of padding }
- _paddingsize : word;
- { array of tmanagementoperator_offset_entry lists; only assigned if
- they had been queried once by get_management_operator_list }
- mop_list : array[tmanagementoperator] of tfplist;
- procedure setdatasize(val: asizeint);
- function getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint;
- procedure do_get_managementoperator_offset_list(data:tobject;arg:pointer);
- public
- function iscurrentunit: boolean; override;
- property datasize : asizeint read _datasize write setdatasize;
- property paddingsize: word read _paddingsize write _paddingsize;
- {$ifdef llvm}
- property llvmst: tllvmshadowsymtable read getllvmshadowsymtabll;
- {$endif llvm}
- end;
- trecordsymtable = class(tabstractrecordsymtable)
- public
- { maybe someday is worth to move managementoperators to }
- { tabstractrecordsymtable to perform management class operators for }
- { object/classes. In XE5 and newer is possible to use class operator }
- { for classes (like for Delphi .NET before) only for Delphi NEXTGEN }
- managementoperators : tmanagementoperators;
- constructor create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- procedure insertunionst(unionst : trecordsymtable;offset : asizeint);
- procedure includemanagementoperator(mop:tmanagementoperator);
- end;
- tObjectSymtable = class(tabstractrecordsymtable)
- public
- constructor create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- end;
- {$ifdef llvm}
- { llvm record definitions cannot contain variant/union parts, }
- { you have to flatten them first. the tllvmshadowsymtable }
- { contains a flattened version of a record/object symtable }
- tllvmshadowsymtable = class
- private
- equivst: tabstractrecordsymtable;
- curroffset: aint;
- function get(f: tfieldvarsym): tllvmshadowsymtableentry;
- function get_by_llvm_index(index: longint): tllvmshadowsymtableentry;
- public
- symdeflist: TFPObjectList;
- constructor create(st: tabstractrecordsymtable);
- destructor destroy; override;
- property entries[index: tfieldvarsym]: tllvmshadowsymtableentry read get; default;
- { warning: do not call this with field.llvmfieldnr, as
- field.llvmfieldnr will only be initialised when the llvm shadow
- symtable is accessed for the first time. Use the default/entries
- property instead in this case }
- property entries_by_llvm_index[index: longint]: tllvmshadowsymtableentry read get_by_llvm_index;
- private
- // generate the table
- procedure generate;
- // helpers
- procedure appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean);
- procedure findvariantstarts(variantstarts: tfplist);
- procedure addalignmentpadding(finalsize: aint);
- procedure buildmapping(variantstarts: tfplist);
- procedure buildtable(variantstarts: tfplist);
- end;
- {$endif llvm}
- { tabstractsubsymtable }
- tabstractsubsymtable = class(tstoredsymtable)
- public
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- end;
- { tabstractlocalsymtable }
- tabstractlocalsymtable = class(tabstractsubsymtable)
- public
- function count_locals:longint;
- function iscurrentunit: boolean; override;
- end;
- tlocalsymtable = class(tabstractlocalsymtable)
- public
- constructor create(adefowner:tdef;level:byte);
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- end;
- { tparasymtable }
- tparasymtable = class(tabstractlocalsymtable)
- public
- readonly: boolean;
- constructor create(adefowner:tdef;level:byte);
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- procedure insertdef(def:TDefEntry);override;
- end;
- tabstractuniTSymtable = class(tstoredsymtable)
- public
- constructor create(const n : string;id:word);
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- function findnamespace(const n:string):TSymEntry;virtual;
- function iscurrentunit:boolean;override;
- function needs_init_final: boolean; override;
- procedure insertunit(sym:TSymEntry);
- function has_class_condestructors: boolean;
- end;
- tglobalsymtable = class(tabstractuniTSymtable)
- public
- unittypecount : word;
- constructor create(const n : string;id:word);
- procedure ppuload(ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- end;
- tstaticsymtable = class(tabstractuniTSymtable)
- public
- constructor create(const n : string;id:word);
- procedure ppuload(ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- function checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;override;
- function findnamespace(const n:string):TSymEntry;override;
- end;
- tspecializesymtable = class(tglobalsymtable)
- public
- constructor create(const n : string;id:word);
- function iscurrentunit:boolean;override;
- end;
- twithsymtable = class(TSymtable)
- withrefnode : tobject; { tnode }
- constructor create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
- destructor destroy;override;
- procedure clear;override;
- procedure insertdef(def:TDefEntry);override;
- end;
- tstt_excepTSymtable = class(TSymtable)
- public
- constructor create;
- end;
- tmacrosymtable = class(tstoredsymtable)
- public
- constructor create(exported: boolean);
- end;
- { tenumsymtable }
- tenumsymtable = class(tabstractsubsymtable)
- public
- procedure insert(sym: TSymEntry; checkdup: boolean = true); override;
- constructor create(adefowner:tdef);
- end;
- { tarraysymtable }
- tarraysymtable = class(tabstractsubsymtable)
- public
- procedure insertdef(def:TDefEntry);override;
- constructor create(adefowner:tdef);
- end;
- var
- systemunit : tglobalsymtable; { pointer to the system unit }
- type
- tsymbol_search_flag = (
- ssf_search_option,
- ssf_search_helper,
- ssf_has_inherited,
- ssf_no_addsymref
- );
- tsymbol_search_flags = set of tsymbol_search_flag;
- {****************************************************************************
- Functions
- ****************************************************************************}
- {*** Misc ***}
- function FullTypeName(def,otherdef:tdef):string;
- function generate_nested_name(symtable:tsymtable;delimiter:string):string;
- { def is the extended type of a helper }
- function generate_objectpascal_helper_key(def:tdef):string;
- procedure incompatibletypes(def1,def2:tdef);
- procedure hidesym(sym:TSymEntry);
- procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym:TSymEntry; warn: boolean);
- function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean;
- { writes all declarations for the specified system unit symbol }
- procedure write_system_parameter_lists(const name:string);
- {*** Search ***}
- procedure addsymref(sym:tsym);
- function is_owned_by(nesteddef,ownerdef:tdef):boolean;
- function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
- function defs_belong_to_same_generic(def1,def2:tdef):boolean;
- function get_generic_in_hierarchy_by_name(srsym:tsym;def:tdef):tdef;
- function return_specialization_of_generic(nesteddef,genericdef:tdef;out resultdef:tdef):boolean;
- function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
- function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
- function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
- function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
- { searches for a symbol with the given name that has the given option in
- symoptions set }
- function searchsym_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;option:tsymoption):boolean;
- function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
- function searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
- function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
- { searches symbols inside of a helper's implementation }
- function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- function search_system_type(const s: TIDString): ttypesym;
- function try_search_system_type(const s: TIDString): ttypesym;
- function try_search_current_module_type(const s: TIDString): ttypesym;
- function search_system_proc(const s: TIDString): tprocdef;
- function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
- function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
- function search_struct_member_no_helper(pd : tabstractrecorddef;const s : string):tsym;
- function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
- function search_enumerator_operator(from_def,to_def:Tdef):Tprocdef;
- function search_management_operator(mop:tmanagementoperator;pd:Tdef):Tprocdef;
- { searches for the helper definition that's currently active for pd }
- function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
- { searches whether the symbol s is available in the currently active }
- { helper for pd }
- function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- {Looks for macro s (must be given in upper case) in the macrosymbolstack, }
- {and returns it if found. Returns nil otherwise.}
- function search_macro(const s : string):tsym;
- { Additionally to searching for a macro, also checks whether it's still }
- { actually defined (could be disable using "undef") }
- function defined_macro(const s : string):boolean;
- { Look for a system procedure (no overloads supported) }
- {*** Object Helpers ***}
- function search_default_property(pd : tabstractrecorddef) : tpropertysym;
- function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef;
- function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
- {*** Macro Helpers ***}
- {If called initially, the following procedures manipulate macros in }
- {initialmacrotable, otherwise they manipulate system macros local to a module.}
- {Name can be given in any case (it will be converted to upper case).}
- procedure def_system_macro(const name : string);
- procedure set_system_macro(const name, value : string);
- procedure set_system_compvar(const name, value : string);
- procedure undef_system_macro(const name : string);
- {*** symtable stack ***}
- { $ifdef DEBUG
- procedure test_symtablestack;
- procedure list_symtablestack;
- $endif DEBUG}
- {$ifdef UNITALIASES}
- type
- punit_alias = ^tunit_alias;
- tunit_alias = object(TNamedIndexItem)
- newname : pshortstring;
- constructor init(const n:string);
- destructor done;virtual;
- end;
- var
- unitaliases : pdictionary;
- procedure addunitalias(const n:string);
- function getunitalias(const n:string):string;
- {$endif UNITALIASES}
- {*** Init / Done ***}
- procedure IniTSymtable;
- procedure DoneSymtable;
- const
- overloaded_names : array [NOTOKEN..last_overloaded] of string[16] = (
- { NOTOKEN } 'error',
- { _PLUS } 'plus',
- { _MINUS } 'minus',
- { _STAR } 'star',
- { _SLASH } 'slash',
- { _EQ } 'equal',
- { _GT } 'greater',
- { _LT } 'lower',
- { _GTE } 'greater_or_equal',
- { _LTE } 'lower_or_equal',
- { _NE } 'not_equal',
- { _SYMDIF } 'sym_diff',
- { _STARSTAR } 'starstar',
- { _OP_AS } 'as',
- { _OP_IN } 'in',
- { _OP_IS } 'is',
- { _OP_OR } 'or',
- { _OP_AND } 'and',
- { _OP_DIV } 'div',
- { _OP_MOD } 'mod',
- { _OP_NOT } 'not',
- { _OP_SHL } 'shl',
- { _OP_SHR } 'shr',
- { _OP_XOR } 'xor',
- { _ASSIGNMENT } 'assign',
- { _OP_EXPLICIT } 'explicit',
- { _OP_ENUMERATOR } 'enumerator',
- { _OP_INITIALIZE } 'initialize',
- { _OP_FINALIZE } 'finalize',
- { _OP_ADDREF } 'addref',
- { _OP_COPY } 'copy',
- { _OP_INC } 'inc',
- { _OP_DEC } 'dec');
- managementoperator2tok:array[tmanagementoperator] of ttoken = (
- { mop_none } NOTOKEN,
- { mop_initialize } _OP_INITIALIZE,
- { mop_finalize } _OP_FINALIZE,
- { mop_addref } _OP_ADDREF,
- { mop_copy } _OP_COPY
- );
- implementation
- uses
- { global }
- verbose,globals,
- { symtable }
- symutil,defutil,defcmp,objcdef,
- { module }
- fmodule,
- { codegen }
- procinfo,
- { ppu }
- entfile,
- { parser }
- scanner
- ;
- var
- dupnr : longint; { unique number for duplicate symbols }
- {*****************************************************************************
- TStoredSymtable
- *****************************************************************************}
- constructor tstoredsymtable.create(const s:string);
- begin
- inherited create(s);
- { Note: this happens for the initial macro symtable, so no error here }
- if not assigned(current_module) then
- comment(v_debug,'Current module not available for module id')
- else
- moduleid:=current_module.moduleid;
- end;
- procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true);
- begin
- inherited insert(sym,checkdup);
- init_final_check_done:=false;
- end;
- procedure tstoredsymtable.delete(sym:TSymEntry);
- begin
- inherited delete(sym);
- init_final_check_done:=false;
- end;
- procedure tstoredsymtable.ppuload(ppufile:tcompilerppufile);
- begin
- { load the table's flags }
- if ppufile.readentry<>ibsymtableoptions then
- Message(unit_f_ppu_read_error);
- ppufile.getsmallset(tableoptions);
- { load definitions }
- loaddefs(ppufile);
- { load symbols }
- loadsyms(ppufile);
- init_final_check_done:=true;
- end;
- procedure tstoredsymtable.ppuwrite(ppufile:tcompilerppufile);
- begin
- { ensure that we have the sto_needs_init_final flag set if needed }
- if not init_final_check_done then
- needs_init_final;
- { write the table's flags }
- ppufile.putsmallset(tableoptions);
- ppufile.writeentry(ibsymtableoptions);
- { write definitions }
- writedefs(ppufile);
- { write symbols }
- writesyms(ppufile);
- end;
- procedure tstoredsymtable.loaddefs(ppufile:tcompilerppufile);
- var
- def : tdef;
- b : byte;
- begin
- def:=nil;
- { load start of definition section, which holds the amount of defs }
- if ppufile.readentry<>ibstartdefs then
- Message(unit_f_ppu_read_error);
- { read definitions }
- repeat
- b:=ppufile.readentry;
- case b of
- ibpointerdef : def:=cpointerdef.ppuload(ppufile);
- ibarraydef : def:=carraydef.ppuload(ppufile);
- iborddef : def:=corddef.ppuload(ppufile);
- ibfloatdef : def:=cfloatdef.ppuload(ppufile);
- ibprocdef : def:=cprocdef.ppuload(ppufile);
- ibshortstringdef : def:=cstringdef.loadshort(ppufile);
- iblongstringdef : def:=cstringdef.loadlong(ppufile);
- ibansistringdef : def:=cstringdef.loadansi(ppufile);
- ibwidestringdef : def:=cstringdef.loadwide(ppufile);
- ibunicodestringdef : def:=cstringdef.loadunicode(ppufile);
- ibrecorddef : def:=crecorddef.ppuload(ppufile);
- ibobjectdef : def:=cobjectdef.ppuload(ppufile);
- ibenumdef : def:=cenumdef.ppuload(ppufile);
- ibsetdef : def:=csetdef.ppuload(ppufile);
- ibprocvardef : def:=cprocvardef.ppuload(ppufile);
- ibfiledef : def:=cfiledef.ppuload(ppufile);
- ibclassrefdef : def:=cclassrefdef.ppuload(ppufile);
- ibformaldef : def:=cformaldef.ppuload(ppufile);
- ibvariantdef : def:=cvariantdef.ppuload(ppufile);
- ibundefineddef : def:=cundefineddef.ppuload(ppufile);
- ibenddefs : break;
- ibend : Message(unit_f_ppu_read_error);
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- InsertDef(def);
- until false;
- end;
- procedure tstoredsymtable.loadsyms(ppufile:tcompilerppufile);
- var
- b : byte;
- sym : tsym;
- begin
- sym:=nil;
- { load start of definition section, which holds the amount of defs }
- if ppufile.readentry<>ibstartsyms then
- Message(unit_f_ppu_read_error);
- { now read the symbols }
- repeat
- b:=ppufile.readentry;
- case b of
- ibtypesym : sym:=ctypesym.ppuload(ppufile);
- ibprocsym : sym:=cprocsym.ppuload(ppufile);
- ibconstsym : sym:=cconstsym.ppuload(ppufile);
- ibstaticvarsym : sym:=cstaticvarsym.ppuload(ppufile);
- iblocalvarsym : sym:=clocalvarsym.ppuload(ppufile);
- ibparavarsym : sym:=cparavarsym.ppuload(ppufile);
- ibfieldvarsym : sym:=cfieldvarsym.ppuload(ppufile);
- ibabsolutevarsym : sym:=cabsolutevarsym.ppuload(ppufile);
- ibenumsym : sym:=cenumsym.ppuload(ppufile);
- ibpropertysym : sym:=cpropertysym.ppuload(ppufile);
- ibunitsym : sym:=cunitsym.ppuload(ppufile);
- iblabelsym : sym:=clabelsym.ppuload(ppufile);
- ibsyssym : sym:=csyssym.ppuload(ppufile);
- ibmacrosym : sym:=tmacro.ppuload(ppufile);
- ibnamespacesym : sym:=cnamespacesym.ppuload(ppufile);
- ibendsyms : break;
- ibend : Message(unit_f_ppu_read_error);
- else
- Message1(unit_f_ppu_invalid_entry,tostr(b));
- end;
- Insert(sym,false);
- until false;
- end;
- procedure tstoredsymtable.writedefs(ppufile:tcompilerppufile);
- var
- defcount,
- i : longint;
- def : tstoreddef;
- begin
- defcount:=0;
- for i:=0 to DefList.Count-1 do
- if tstoreddef(DefList[i]).is_registered then
- inc(defcount);
- { each definition get a number, write then the amount of defs to the
- ibstartdef entry }
- ppufile.putlongint(defcount);
- ppufile.writeentry(ibstartdefs);
- { now write the definition }
- for i:=0 to DefList.Count-1 do
- begin
- def:=tstoreddef(DefList[i]);
- if def.is_registered then
- def.ppuwrite(ppufile);
- end;
- { write end of definitions }
- ppufile.writeentry(ibenddefs);
- end;
- procedure tstoredsymtable.writesyms(ppufile:tcompilerppufile);
- var
- symcount,
- i : longint;
- sym : Tstoredsym;
- begin
- symcount:=0;
- for i:=0 to SymList.Count-1 do
- if tstoredsym(SymList[i]).is_registered then
- inc(symcount);
- { each definition get a number, write then the amount of syms and the
- datasize to the ibsymdef entry }
- ppufile.putlongint(symcount);
- ppufile.writeentry(ibstartsyms);
- { foreach is used to write all symbols }
- for i:=0 to SymList.Count-1 do
- begin
- sym:=tstoredsym(SymList[i]);
- if sym.is_registered then
- sym.ppuwrite(ppufile);
- end;
- { end of symbols }
- ppufile.writeentry(ibendsyms);
- end;
- procedure tstoredsymtable.buildderef;
- var
- i : longint;
- def : tstoreddef;
- sym : tstoredsym;
- begin
- { interface definitions }
- for i:=0 to DefList.Count-1 do
- begin
- def:=tstoreddef(DefList[i]);
- def.buildderef;
- end;
- { interface symbols }
- for i:=0 to SymList.Count-1 do
- begin
- sym:=tstoredsym(SymList[i]);
- sym.buildderef;
- end;
- end;
- procedure tstoredsymtable.buildderefimpl;
- var
- i : longint;
- def : tstoreddef;
- begin
- { implementation definitions }
- for i:=0 to DefList.Count-1 do
- begin
- def:=tstoreddef(DefList[i]);
- def.buildderefimpl;
- end;
- end;
- procedure tstoredsymtable.buildderef_registered;
- var
- def : tstoreddef;
- sym : tstoredsym;
- i : longint;
- defidmax,
- symidmax: longint;
- newbuiltdefderefs,
- builtdefderefs,
- builtsymderefs: array of boolean;
- changed: boolean;
- begin
- newbuiltdefderefs:=nil;
- builtdefderefs:=nil;
- builtsymderefs:=nil;
- { tdefs for which we already built the deref }
- setlength(builtdefderefs,deflist.count);
- { tdefs for which we built the deref in this iteration }
- setlength(newbuiltdefderefs,deflist.count);
- { syms for which we already built the deref }
- setlength(builtsymderefs,symlist.count);
- repeat
- { we only have to store the defs (recursively) referred by wpo info
- or inlined routines in the static symbtable }
- { current number of registered defs/syms }
- defidmax:=current_module.deflist.count;
- symidmax:=current_module.symlist.count;
- changed:=false;
- { build the derefs for the registered defs we haven't processed yet }
- for i:=0 to DefList.Count-1 do
- begin
- if not builtdefderefs[i] then
- begin
- def:=tstoreddef(DefList[i]);
- if def.is_registered then
- begin
- def.buildderef;
- newbuiltdefderefs[i]:=true;
- builtdefderefs[i]:=true;
- changed:=true;
- end;
- end;
- end;
- { same for the syms }
- for i:=0 to SymList.Count-1 do
- begin
- if not builtsymderefs[i] then
- begin
- sym:=tstoredsym(SymList[i]);
- if sym.is_registered then
- begin
- sym.buildderef;
- builtsymderefs[i]:=true;
- changed:=true;
- end;
- end;
- end;
- { now buildderefimpl for the defs we processed in this iteration }
- for i:=0 to DefList.Count-1 do
- begin
- if newbuiltdefderefs[i] then
- begin
- newbuiltdefderefs[i]:=false;
- tstoreddef(DefList[i]).buildderefimpl;
- changed:=true;
- end;
- end;
- { stop when no new defs or syms have been registered while processing
- the currently registered ones (defs/syms get added to the module's
- deflist/symlist when they are registered) }
- until not changed and
- (defidmax=current_module.deflist.count) and
- (symidmax=current_module.symlist.count);
- end;
- procedure tstoredsymtable.deref(only_registered: boolean);
- var
- i : longint;
- def : tstoreddef;
- sym : tstoredsym;
- begin
- { first deref the interface ttype symbols. This is needs
- to be done before the interface defs are derefed, because
- the interface defs can contain references to the type symbols
- which then already need to contain a resolved typedef field (PFV) }
- for i:=0 to SymList.Count-1 do
- begin
- sym:=tstoredsym(SymList[i]);
- if (sym.typ=typesym) and
- (not only_registered or
- sym.is_registered) then
- sym.deref;
- end;
- { interface definitions }
- for i:=0 to DefList.Count-1 do
- begin
- def:=tstoreddef(DefList[i]);
- if not only_registered or
- def.is_registered then
- def.deref;
- end;
- { interface symbols }
- for i:=0 to SymList.Count-1 do
- begin
- sym:=tstoredsym(SymList[i]);
- if (not only_registered or
- sym.is_registered) and
- (sym.typ<>typesym) then
- sym.deref;
- end;
- end;
- procedure tstoredsymtable.derefimpl(only_registered: boolean);
- var
- i : longint;
- def : tstoreddef;
- begin
- { implementation definitions }
- for i:=0 to DefList.Count-1 do
- begin
- def:=tstoreddef(DefList[i]);
- if not only_registered or
- def.is_registered then
- def.derefimpl;
- end;
- end;
- function tstoredsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- var
- hsym : tsym;
- begin
- hsym:=tsym(FindWithHash(hashedid));
- if assigned(hsym) then
- DuplicateSym(hashedid,sym,hsym,false);
- result:=assigned(hsym);
- end;
- {**************************************
- Callbacks
- **************************************}
- procedure TStoredSymtable.check_forward(sym:TObject;arg:pointer);
- begin
- if tsym(sym).typ=procsym then
- tprocsym(sym).check_forward
- { check also object method table }
- { we needn't to test the def list }
- { because each object has to have a type sym,
- only test objects declarations, not type renamings }
- else
- if (tsym(sym).typ=typesym) and
- assigned(ttypesym(sym).typedef) and
- (ttypesym(sym).typedef.typesym=ttypesym(sym)) and
- (ttypesym(sym).typedef.typ in [objectdef,recorddef]) then
- tabstractrecorddef(ttypesym(sym).typedef).check_forwards;
- end;
- procedure tstoredsymtable.check_block_valid(def: TObject; arg: pointer);
- var
- founderrordef: tdef;
- begin
- { all parameters passed to a block must be handled by the Objective-C
- runtime }
- if is_block(tdef(def)) and
- not objcchecktype(tdef(def),founderrordef) then
- if assigned(tdef(def).typesym) then
- MessagePos1(tdef(def).typesym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename)
- else
- Message1(type_e_objc_type_unsupported,tprocvardef(def).typename)
- end;
- procedure tstoredsymtable.register_syms(sym:tobject;arg:pointer);
- begin
- tsym(sym).register_sym;
- end;
- procedure tstoredsymtable.register_defs(def:tobject;arg:pointer);
- begin
- tdef(def).register_def;
- end;
- procedure TStoredSymtable.labeldefined(sym:TObject;arg:pointer);
- begin
- if (tsym(sym).typ=labelsym) and
- not(tlabelsym(sym).defined) then
- begin
- if tlabelsym(sym).used then
- Message1(sym_e_label_used_and_not_defined,tlabelsym(sym).realname)
- else
- Message1(sym_w_label_not_defined,tlabelsym(sym).realname);
- end;
- end;
- procedure TStoredSymtable.varsymbolused(sym:TObject;arg:pointer);
- begin
- if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and
- ((tsym(sym).owner.symtabletype in
- [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then
- begin
- { unused symbol should be reported only if no }
- { error is reported }
- { if the symbol is in a register it is used }
- { also don't count the value parameters which have local copies }
- { also don't claim for high param of open parameters (PM) }
- { also don't complain about unused symbols in generic procedures }
- { and methods }
- { and neither in abstract methods }
- if (Errorcount<>0) or
- ([vo_is_hidden_para,vo_is_funcret] * tabstractvarsym(sym).varoptions = [vo_is_hidden_para]) or
- (sp_internal in tsym(sym).symoptions) or
- ((assigned(tsym(sym).owner.defowner) and
- (tsym(sym).owner.defowner.typ=procdef) and
- ((df_generic in tprocdef(tsym(sym).owner.defowner).defoptions) or
- (po_abstractmethod in tprocdef(tsym(sym).owner.defowner).procoptions)))) then
- exit;
- if (tstoredsym(sym).refs=0) then
- begin
- if (vo_is_funcret in tabstractvarsym(sym).varoptions) then
- begin
- { don't warn about the result of constructors }
- if ((tsym(sym).owner.symtabletype<>localsymtable) or
- (tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and
- not (po_noreturn in tprocdef(tsym(sym).owner.defowner).procoptions) and
- not(cs_opt_nodedfa in current_settings.optimizerswitches) then
- MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set)
- end
- else if (tsym(sym).owner.symtabletype=parasymtable) then
- MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname)
- else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
- else
- MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname);
- end
- else if tabstractvarsym(sym).varstate in [vs_written,vs_initialised] then
- begin
- if (tsym(sym).owner.symtabletype=parasymtable) then
- begin
- if not(tabstractvarsym(sym).varspez in [vs_var,vs_out,vs_constref]) and
- not(vo_is_funcret in tabstractvarsym(sym).varoptions) then
- MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname)
- end
- else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname)
- else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then
- MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname);
- end
- else if (tabstractvarsym(sym).varstate = vs_read_not_warned) and
- ([vo_is_public,vo_is_external] * tabstractvarsym(sym).varoptions = []) then
- MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname)
- end
- else if ((tsym(sym).owner.symtabletype in
- [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then
- begin
- if (Errorcount<>0) or
- (sp_internal in tsym(sym).symoptions) then
- exit;
- { do not claim for inherited private fields !! }
- if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
- case tsym(sym).typ of
- typesym:
- MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
- constsym:
- MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
- propertysym:
- MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
- else
- MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).GetTypeName,tsym(sym).prettyname);
- end
- { units references are problematic }
- else
- begin
- if (tsym(sym).refs=0) and
- not(tsym(sym).typ in [enumsym,unitsym,namespacesym]) and
- not(is_funcret_sym(tsym(sym))) and
- { don't complain about compiler generated syms for specializations, see also #13405 }
- not((tsym(sym).typ=typesym) and (df_specialization in ttypesym(sym).typedef.defoptions) and
- (pos('$',ttypesym(sym).Realname)<>0)) and
- (
- (tsym(sym).typ<>procsym) or
- ((tsym(sym).owner.symtabletype=staticsymtable) and
- not current_module.is_unit)
- ) and
- { don't complain about alias for hidden _cmd parameter to
- obj-c methods }
- not((tsym(sym).typ in [localvarsym,paravarsym,absolutevarsym]) and
- (vo_is_msgsel in tabstractvarsym(sym).varoptions)) then
- MessagePos2(tsym(sym).fileinfo,sym_h_local_symbol_not_used,SymTypeName[tsym(sym).typ],tsym(sym).prettyname);
- end;
- end;
- end;
- procedure TStoredSymtable.TestPrivate(sym:TObject;arg:pointer);
- begin
- if tsym(sym).visibility in [vis_private,vis_strictprivate] then
- varsymbolused(sym,arg);
- end;
- procedure TStoredSymtable.objectprivatesymbolused(sym:TObject;arg:pointer);
- begin
- {
- Don't test simple object aliases PM
- }
- if (tsym(sym).typ=typesym) and
- (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and
- (ttypesym(sym).typedef.typesym=tsym(sym)) then
- tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil);
- end;
- procedure tstoredsymtable.testfordefaultproperty(sym:TObject;arg:pointer);
- begin
- if (tsym(sym).typ=propertysym) and
- (ppo_defaultproperty in tpropertysym(sym).propoptions) then
- ppointer(arg)^:=sym;
- end;
- procedure tstoredsymtable.register_children;
- begin
- SymList.ForEachCall(@register_syms,nil);
- DefList.ForEachCall(@register_defs,nil);
- end;
- {***********************************************
- Process all entries
- ***********************************************}
- { checks, if all procsyms and methods are defined }
- procedure tstoredsymtable.check_forwards;
- begin
- SymList.ForEachCall(@check_forward,nil);
- { check whether all block definitions contain valid Objective-C types
- (now that all forward definitions have been resolved) }
- DefList.ForEachCall(@check_block_valid,nil);
- end;
- procedure tstoredsymtable.checklabels;
- begin
- SymList.ForEachCall(@labeldefined,nil);
- end;
- procedure tstoredsymtable.allsymbolsused;
- begin
- SymList.ForEachCall(@varsymbolused,nil);
- end;
- procedure tstoredsymtable.allprivatesused;
- begin
- SymList.ForEachCall(@objectprivatesymbolused,nil);
- end;
- procedure TStoredSymtable._needs_init_final(sym:TObject;arg:pointer);
- begin
- if [sto_needs_init_final,sto_has_non_trivial_init] <= tableoptions then
- exit;
- { don't check static symbols - they can be present in structures only and
- always have a reference to a symbol defined on unit level }
- if sp_static in tsym(sym).symoptions then
- exit;
- case tsym(sym).typ of
- fieldvarsym,
- staticvarsym,
- localvarsym,
- paravarsym :
- begin
- if assigned(tabstractvarsym(sym).vardef) and
- is_managed_type(tabstractvarsym(sym).vardef) then
- include(tableoptions,sto_needs_init_final);
- if is_record((tabstractvarsym(sym).vardef)) and
- (mop_initialize in trecordsymtable(trecorddef(tabstractvarsym(sym).vardef).symtable).managementoperators) then
- include(tableoptions,sto_has_non_trivial_init);
- end;
- end;
- end;
- procedure tstoredsymtable.do_init_final_check;
- begin
- if not init_final_check_done then
- begin
- exclude(tableoptions,sto_needs_init_final);
- exclude(tableoptions,sto_has_non_trivial_init);
- SymList.ForEachCall(@_needs_init_final,nil);
- init_final_check_done:=true;
- end;
- end;
- { returns true, if p contains data which needs init/final code }
- function tstoredsymtable.needs_init_final : boolean;
- begin
- do_init_final_check;
- result:=sto_needs_init_final in tableoptions;
- end;
- function tstoredsymtable.has_non_trivial_init:boolean;
- begin
- do_init_final_check;
- result:=sto_has_non_trivial_init in tableoptions;
- end;
- {****************************************************************************
- TAbstractRecordSymtable
- ****************************************************************************}
- {$ifdef llvm}
- function tabstractrecordsymtable.getllvmshadowsymtabll: tllvmshadowsymtable;
- begin
- if not assigned(fllvmst) then
- fllvmst:=tllvmshadowsymtable.create(self);
- result:=fllvmst;
- end;
- {$endif llvm}
- constructor tabstractrecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- begin
- inherited create(n);
- _datasize:=0;
- databitsize:=0;
- recordalignment:=1;
- usefieldalignment:=usealign;
- recordalignmin:=recordminalign;
- maxCrecordalign:=recordmaxCalign;
- padalignment:=1;
- { recordalign C_alignment means C record packing, that starts
- with an alignment of 1 }
- case usealign of
- C_alignment,
- bit_alignment:
- fieldalignment:=1;
- mac68k_alignment:
- fieldalignment:=2;
- else
- fieldalignment:=usealign;
- end;
- end;
- destructor tabstractrecordsymtable.destroy;
- { for some reason a compiler built with 3.3.1 fails building the libxml2
- package if the below define is not defined and thus the code snippet is
- part of the destructor itself and not a nested procedure; until that bug
- is fixed this is used as a workaround :/ }
- {$define codegen_workaround}
- {$ifdef codegen_workaround}
- procedure free_mop_list(mop:tmanagementoperator);
- var
- i : longint;
- begin
- if assigned(mop_list[mop]) then
- for i:=0 to mop_list[mop].count-1 do
- dispose(pmanagementoperator_offset_entry(mop_list[mop][i]));
- mop_list[mop].free;
- end;
- {$endif codegen_workaround}
- var
- mop : tmanagementoperator;
- {$ifndef codegen_workaround}
- i : longint;
- {$endif codegen_workaround}
- begin
- if refcount>1 then
- exit;
- {$ifdef llvm}
- fllvmst.free;
- {$endif llvm}
- for mop:=low(tmanagementoperator) to high(tmanagementoperator) do
- begin
- {$ifdef codegen_workaround}
- free_mop_list(mop);
- {$else codegen_workaround}
- if assigned(mop_list[mop]) then
- for i:=0 to mop_list[mop].count-1 do
- dispose(pmanagementoperator_offset_entry(mop_list[mop][i]));
- mop_list[mop].free;
- {$endif codegen_workaround}
- end;
- inherited destroy;
- end;
- procedure tabstractrecordsymtable.ppuload(ppufile:tcompilerppufile);
- begin
- if ppufile.readentry<>ibrecsymtableoptions then
- Message(unit_f_ppu_read_error);
- recordalignment:=shortint(ppufile.getbyte);
- usefieldalignment:=shortint(ppufile.getbyte);
- recordalignmin:=shortint(ppufile.getbyte);
- if (usefieldalignment=C_alignment) then
- fieldalignment:=shortint(ppufile.getbyte);
- ppufile.getsmallset(has_fields_with_mop);
- inherited ppuload(ppufile);
- end;
- procedure tabstractrecordsymtable.ppuwrite(ppufile:tcompilerppufile);
- var
- oldtyp : byte;
- begin
- oldtyp:=ppufile.entrytyp;
- ppufile.entrytyp:=subentryid;
- { in case of classes using C alignment, the alignment of the parent
- affects the alignment of fields of the childs }
- ppufile.putbyte(byte(recordalignment));
- ppufile.putbyte(byte(usefieldalignment));
- ppufile.putbyte(byte(recordalignmin));
- if (usefieldalignment=C_alignment) then
- ppufile.putbyte(byte(fieldalignment));
- { it's not really a "symtableoption", but loading this from the record
- def requires storing the set in the recorddef at least between
- ppuload and deref/derefimpl }
- ppufile.putsmallset(has_fields_with_mop);
- ppufile.writeentry(ibrecsymtableoptions);
- inherited ppuwrite(ppufile);
- ppufile.entrytyp:=oldtyp;
- end;
- function field2recordalignment(fieldoffs, fieldalign: asizeint): asizeint;
- begin
- { optimal alignment of the record when declaring a variable of this }
- { type is independent of the packrecords setting }
- if (fieldoffs mod fieldalign) = 0 then
- result:=fieldalign
- else if (fieldalign >= 16) and
- ((fieldoffs mod 16) = 0) and
- ((fieldalign mod 16) = 0) then
- result:=16
- else if (fieldalign >= 8) and
- ((fieldoffs mod 8) = 0) and
- ((fieldalign mod 8) = 0) then
- result:=8
- else if (fieldalign >= 4) and
- ((fieldoffs mod 4) = 0) and
- ((fieldalign mod 4) = 0) then
- result:=4
- else if (fieldalign >= 2) and
- ((fieldoffs mod 2) = 0) and
- ((fieldalign mod 2) = 0) then
- result:=2
- else
- result:=1;
- end;
- procedure tabstractrecordsymtable.alignrecord(fieldoffset:asizeint;varalign:shortint);
- var
- varalignrecord: shortint;
- begin
- case usefieldalignment of
- C_alignment:
- varalignrecord:=used_align(varalign,recordalignmin,maxCrecordalign);
- mac68k_alignment:
- varalignrecord:=2;
- else
- varalignrecord:=field2recordalignment(fieldoffset,varalign);
- end;
- recordalignment:=max(recordalignment,varalignrecord);
- end;
- procedure tabstractrecordsymtable.addfield(sym:tfieldvarsym;vis:tvisibility);
- var
- l : asizeint;
- varalign : shortint;
- vardef : tdef;
- begin
- if (sym.owner<>self) then
- internalerror(200602031);
- if sym.fieldoffset<>-1 then
- internalerror(200602032);
- { set visibility for the symbol }
- sym.visibility:=vis;
- { this symbol can't be loaded to a register }
- sym.varregable:=vr_none;
- { management operators }
- if sym.vardef.typ in [recorddef,objectdef] then
- has_fields_with_mop:=has_fields_with_mop + tabstractrecordsymtable(tabstractrecorddef(sym.vardef).symtable).has_fields_with_mop;
- if sym.vardef.typ=recorddef then
- has_fields_with_mop:=has_fields_with_mop + trecordsymtable(trecorddef(sym.vardef).symtable).managementoperators;
- { Calculate field offset }
- l:=sym.getsize;
- vardef:=sym.vardef;
- varalign:=vardef.structalignment;
- case usefieldalignment of
- bit_alignment:
- begin
- { bitpacking only happens for ordinals, the rest is aligned at }
- { 1 byte (compatible with GPC/GCC) }
- if is_ordinal(vardef) then
- begin
- sym.fieldoffset:=databitsize;
- l:=sym.getpackedbitsize;
- end
- else
- begin
- databitsize:=_datasize*8;
- sym.fieldoffset:=databitsize;
- if (l>high(asizeint) div 8) then
- Message(sym_e_segment_too_large);
- l:=l*8;
- end;
- if varalign=0 then
- varalign:=size_2_align(l);
- recordalignment:=max(recordalignment,field2recordalignment(databitsize mod 8,varalign));
- { bit packed records are limited to high(aint) bits }
- { instead of bytes to avoid double precision }
- { arithmetic in offset calculations }
- if int64(l)>high(asizeint)-sym.fieldoffset then
- begin
- Message(sym_e_segment_too_large);
- _datasize:=high(asizeint);
- databitsize:=high(asizeint);
- end
- else
- begin
- databitsize:=sym.fieldoffset+l;
- _datasize:=(databitsize+7) div 8;
- end;
- { rest is not applicable }
- exit;
- end;
- else
- begin
- sym.fieldoffset:=getfieldoffset(sym,_datasize,fieldalignment);
- if l>high(asizeint)-sym.fieldoffset then
- begin
- Message(sym_e_segment_too_large);
- _datasize:=high(asizeint);
- end
- else
- _datasize:=sym.fieldoffset+l;
- { Calc alignment needed for this record }
- alignrecord(sym.fieldoffset,varalign);
- end;
- end;
- end;
- function field_alignment_compare(item1, item2: pointer): integer;
- var
- field1: tfieldvarsym absolute item1;
- field2: tfieldvarsym absolute item2;
- begin
- { we don't care about static fields, those become global variables }
- if (sp_static in field1.symoptions) or
- (sp_static in field2.symoptions) then
- exit(0);
- { sort from large to small alignment, and in case of the same alignment
- in declaration order (items declared close together are possibly
- also related and hence possibly used together -> putting them next
- to each other can improve cache behaviour) }
- result:=field2.vardef.alignment-field1.vardef.alignment;
- if result=0 then
- result:=field1.fieldoffset-field2.fieldoffset;
- end;
- procedure tabstractrecordsymtable.addfieldlist(list: tfpobjectlist; maybereorder: boolean);
- var
- fieldvs, insertfieldvs: tfieldvarsym;
- base, fieldoffset, space, insertfieldsize, insertfieldoffset, bestinsertfieldoffset, bestspaceleft: asizeint;
- i, j, bestfieldindex: longint;
- globalfieldalignment,
- prevglobalfieldalignment,
- newfieldalignment: shortint;
- changed: boolean;
- begin
- if maybereorder and
- (cs_opt_reorder_fields in current_settings.optimizerswitches) then
- begin
- { assign dummy field offsets so we can know their order in the
- sorting routine }
- for i:=0 to list.count-1 do
- tfieldvarsym(list[i]).fieldoffset:=i;
- { sort the non-class fields to minimise losses due to alignment }
- list.sort(@field_alignment_compare);
- { now fill up gaps caused by alignment skips with smaller fields
- where possible }
- repeat
- i:=0;
- base:=_datasize;
- globalfieldalignment:=fieldalignment;
- changed:=false;
- while i<list.count do
- begin
- fieldvs:=tfieldvarsym(list[i]);
- if sp_static in fieldvs.symoptions then
- begin
- inc(i);
- continue;
- end;
- prevglobalfieldalignment:=globalfieldalignment;
- fieldoffset:=getfieldoffset(fieldvs,base,globalfieldalignment);
- newfieldalignment:=globalfieldalignment;
- { size of the gap between the end of the previous field and
- the start of the current one }
- space:=fieldoffset-base;
- bestspaceleft:=space;
- while space>0 do
- begin
- bestfieldindex:=-1;
- bestinsertfieldoffset:=-1;
- for j:=i+1 to list.count-1 do
- begin
- insertfieldvs:=tfieldvarsym(list[j]);
- if sp_static in insertfieldvs.symoptions then
- continue;
- insertfieldsize:=insertfieldvs.getsize;
- { can the new field fit possibly in the gap? }
- if insertfieldsize<=space then
- begin
- { restore globalfieldalignment to situation before
- the original field was inserted }
- globalfieldalignment:=prevglobalfieldalignment;
- { at what offset would it be inserted? (this new
- field has its own alignment requirements, which
- may make it impossible to fit after all) }
- insertfieldoffset:=getfieldoffset(insertfieldvs,base,globalfieldalignment);
- globalfieldalignment:=prevglobalfieldalignment;
- { taking into account the alignment, does it still
- fit and if so, does it fit better than the
- previously found best fit? }
- if (insertfieldoffset+insertfieldsize<=fieldoffset) and
- (fieldoffset-insertfieldoffset-insertfieldsize<bestspaceleft) then
- begin
- { new best fit }
- bestfieldindex:=j;
- bestinsertfieldoffset:=insertfieldoffset;
- bestspaceleft:=fieldoffset-insertfieldoffset-insertfieldsize;
- if bestspaceleft=0 then
- break;
- end;
- end;
- end;
- { if we didn't find any field to fit, stop trying for this
- gap }
- if bestfieldindex=-1 then
- break;
- changed:=true;
- { we found a field to insert -> adjust the new base
- address }
- base:=bestinsertfieldoffset+tfieldvarsym(list[bestfieldindex]).getsize;
- { update globalfieldalignment for this newly inserted
- field }
- getfieldoffset(tfieldvarsym(list[bestfieldindex]),base,globalfieldalignment);
- { move the new field before the current one }
- list.move(bestfieldindex,i);
- { and skip the new field (which is now at position i) }
- inc(i);
- { there may be more space left -> continue }
- space:=bestspaceleft;
- end;
- if base>fieldoffset then
- internalerror(2012071302);
- { check the next field }
- base:=fieldoffset+fieldvs.getsize;
- { since the original field had the same or greater alignment
- than anything we inserted before it, the global field
- alignment is still the same now as it was originally after
- inserting that field }
- globalfieldalignment:=newfieldalignment;
- inc(i);
- end;
- { there may be small gaps left *before* inserted fields }
- until not changed;
- end;
- { reset the dummy field offsets }
- for i:=0 to list.count-1 do
- tfieldvarsym(list[i]).fieldoffset:=-1;
- { finally, set the actual field offsets }
- for i:=0 to list.count-1 do
- begin
- fieldvs:=tfieldvarsym(list[i]);
- { static data fields are already inserted in the globalsymtable }
- if not(sp_static in fieldvs.symoptions) then
- begin
- { read_record_fields already set the visibility of the fields,
- because a single list can contain symbols with different
- visibility }
- addfield(fieldvs,fieldvs.visibility);
- end;
- end;
- end;
- function tabstractrecordsymtable.findfieldbyoffset(offset: asizeint): tfieldvarsym;
- var
- i: longint;
- sym: tsym;
- begin
- { there could be multiple fields in case of a variant record }
- if (defowner.typ=recorddef) and
- trecorddef(defowner).isunion then
- internalerror(2014090403);
- for i:=0 to SymList.count-1 do
- begin
- sym:=tsym(symlist[i]);
- if (sym.typ=fieldvarsym) and
- not(sp_static in sym.symoptions) and
- (tfieldvarsym(sym).fieldoffset>=offset) then
- begin
- result:=tfieldvarsym(sym);
- exit;
- end;
- end;
- result:=nil;
- end;
- procedure tabstractrecordsymtable.addalignmentpadding;
- var
- padded_datasize: asizeint;
- begin
- { make the record size aligned correctly so it can be
- used as elements in an array. For C records we
- use the fieldalignment, because that is updated with the
- used alignment. }
- if (padalignment = 1) then
- case usefieldalignment of
- C_alignment:
- padalignment:=fieldalignment;
- { bitpacked }
- bit_alignment:
- padalignment:=1;
- { mac68k: always round to multiple of 2 }
- mac68k_alignment:
- padalignment:=2;
- { default/no packrecords specified }
- 0:
- padalignment:=recordalignment
- { specific packrecords setting -> use as upper limit }
- else
- padalignment:=min(recordalignment,usefieldalignment);
- end;
- padded_datasize:=align(_datasize,padalignment);
- _paddingsize:=padded_datasize-_datasize;
- _datasize:=padded_datasize;
- end;
- procedure tabstractrecordsymtable.insertdef(def:TDefEntry);
- begin
- { Enums must also be available outside the record scope,
- insert in the owner of this symtable }
- if def.typ=enumdef then
- defowner.owner.insertdef(def)
- else
- inherited insertdef(def);
- end;
- function tabstractrecordsymtable.is_packed: boolean;
- begin
- result:=usefieldalignment=bit_alignment;
- end;
- function tabstractrecordsymtable.has_single_field(out def:tdef): boolean;
- var
- i: longint;
- currentsymlist: TFPHashObjectList;
- currentdef: tdef;
- sym: tfieldvarsym;
- begin
- result:=false;
- { If a record contains a union, it does not contain a "single
- non-composite field" in the context of certain ABIs requiring
- special treatment for such records }
- if (defowner.typ=recorddef) and
- trecorddef(defowner).isunion then
- exit;
- { a record/object can contain other things than fields }
- currentsymlist:=symlist;
- { recurse in arrays and records }
- sym:=nil;
- repeat
- { record has one field? }
- for i:=0 to currentsymlist.Count-1 do
- begin
- if (tsym(currentsymlist[i]).typ=fieldvarsym) and
- not(sp_static in tsym(currentsymlist[i]).symoptions) then
- begin
- if result then
- begin
- result:=false;
- exit;
- end;
- result:=true;
- sym:=tfieldvarsym(currentsymlist[i])
- end;
- end;
- if assigned(sym) then
- begin
- { if the field is an array, does it contain one element? }
- currentdef:=sym.vardef;
- while (currentdef.typ=arraydef) and
- not is_special_array(currentdef) do
- begin
- if tarraydef(currentdef).elecount<>1 then
- begin
- result:=false;
- exit;
- end;
- currentdef:=tarraydef(currentdef).elementdef;
- end;
- { if the array element is again a record, continue descending }
- if currentdef.typ=recorddef then
- currentsymlist:=trecorddef(currentdef).symtable.SymList
- else
- begin
- { otherwise we found the type of the single element }
- def:=currentdef;
- exit;
- end;
- end
- else
- exit
- until false;
- end;
- function tabstractrecordsymtable.get_unit_symtable: tsymtable;
- begin
- result:=defowner.owner;
- while assigned(result) and (result.symtabletype in [ObjectSymtable,recordsymtable]) do
- result:=result.defowner.owner;
- end;
- procedure tabstractrecordsymtable.do_get_managementoperator_offset_list(data:tobject;arg:pointer);
- var
- sym : tsym absolute data;
- fsym : tfieldvarsym absolute data;
- mop : tmanagementoperator;
- entry : pmanagementoperator_offset_entry;
- sublist : tfplist;
- i : longint;
- begin
- if sym.typ<>fieldvarsym then
- exit;
- if not is_record(fsym.vardef) and not is_object(fsym.vardef) and not is_cppclass(fsym.vardef) then
- exit;
- mop:=tmanagementoperator(ptruint(arg));
- if not assigned(mop_list[mop]) then
- internalerror(2018082303);
- if is_record(fsym.vardef) then
- begin
- if mop in trecordsymtable(trecorddef(fsym.vardef).symtable).managementoperators then
- begin
- new(entry);
- entry^.pd:=search_management_operator(mop,fsym.vardef);
- if not assigned(entry^.pd) then
- internalerror(2018082302);
- entry^.offset:=fsym.fieldoffset;
- mop_list[mop].add(entry);
- end;
- end;
- sublist:=tfplist.create;
- tabstractrecordsymtable(tabstractrecorddef(fsym.vardef).symtable).get_managementoperator_offset_list(mop,sublist);
- for i:=0 to sublist.count-1 do
- begin
- entry:=pmanagementoperator_offset_entry(sublist[i]);
- entry^.offset:=entry^.offset+fsym.fieldoffset;
- mop_list[mop].add(entry);
- end;
- { we don't need to remove the entries as they become part of list }
- sublist.free;
- end;
- procedure tabstractrecordsymtable.get_managementoperator_offset_list(mop:tmanagementoperator;list:tfplist);
- var
- i : longint;
- entry,entrycopy : pmanagementoperator_offset_entry;
- begin
- if not assigned(list) then
- internalerror(2018082301);
- if mop=mop_none then
- exit;
- if not (mop in has_fields_with_mop) then
- { none of the fields or one of the field's fields has the requested operator }
- exit;
- if not assigned(mop_list[mop]) then
- begin
- mop_list[mop]:=tfplist.create;
- SymList.ForEachCall(@do_get_managementoperator_offset_list,pointer(ptruint(mop)));
- end;
- for i:=0 to mop_list[mop].count-1 do
- begin
- entry:=pmanagementoperator_offset_entry(mop_list[mop][i]);
- New(entrycopy);
- entrycopy^:=entry^;
- list.add(entrycopy);
- end;
- end;
- procedure tabstractrecordsymtable.setdatasize(val: asizeint);
- begin
- _datasize:=val;
- if (usefieldalignment=bit_alignment) then
- { can overflow in non bitpacked records }
- databitsize:=val*8;
- end;
- function tabstractrecordsymtable.getfieldoffset(sym: tfieldvarsym; base: asizeint; var globalfieldalignment: shortint): asizeint;
- var
- l : asizeint;
- varalignfield,
- varalign : shortint;
- vardef : tdef;
- begin
- { Calculate field offset }
- l:=sym.getsize;
- vardef:=sym.vardef;
- varalign:=vardef.structalignment;
- case usefieldalignment of
- bit_alignment:
- { has to be handled separately }
- internalerror(2012071301);
- C_alignment:
- begin
- { Calc the alignment size for C style records }
- if (varalign>4) and
- ((varalign mod 4)<>0) and
- (vardef.typ=arraydef) then
- Message1(sym_w_wrong_C_pack,vardef.typename);
- if varalign=0 then
- varalign:=l;
- if (globalfieldalignment<maxCrecordalign) then
- begin
- if (varalign>16) and (globalfieldalignment<32) then
- globalfieldalignment:=32
- else if (varalign>12) and (globalfieldalignment<16) then
- globalfieldalignment:=16
- { 12 is needed for long double }
- else if (varalign>8) and (globalfieldalignment<12) then
- globalfieldalignment:=12
- else if (varalign>4) and (globalfieldalignment<8) then
- globalfieldalignment:=8
- else if (varalign>2) and (globalfieldalignment<4) then
- globalfieldalignment:=4
- else if (varalign>1) and (globalfieldalignment<2) then
- globalfieldalignment:=2;
- end;
- globalfieldalignment:=min(globalfieldalignment,maxCrecordalign);
- end;
- mac68k_alignment:
- begin
- { mac68k alignment (C description):
- * char is aligned to 1 byte
- * everything else (except vector) is aligned to 2 bytes
- * vector is aligned to 16 bytes
- }
- if l>1 then
- globalfieldalignment:=2
- else
- globalfieldalignment:=1;
- varalign:=2;
- end;
- end;
- if varalign=0 then
- varalign:=size_2_align(l);
- varalignfield:=used_align(varalign,recordalignmin,globalfieldalignment);
- result:=align(base,varalignfield);
- end;
- function tabstractrecordsymtable.iscurrentunit: boolean;
- begin
- Result:=assigned(current_module)and(current_module.moduleid=moduleid);
- end;
- {****************************************************************************
- TRecordSymtable
- ****************************************************************************}
- constructor trecordsymtable.create(const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- begin
- inherited create(n,usealign,recordminalign,recordmaxCalign);
- symtabletype:=recordsymtable;
- end;
- { this procedure is reserved for inserting case variant into
- a record symtable }
- { the offset is the location of the start of the variant
- and datasize and dataalignment corresponds to
- the complete size (see code in pdecl unit) PM }
- procedure trecordsymtable.insertunionst(unionst : trecordsymtable;offset : asizeint);
- var
- sym : tsym;
- def : tdef;
- i : integer;
- varalignrecord,varalign,
- storesize,storealign : asizeint;
- bitsize: tcgint;
- begin
- storesize:=_datasize;
- storealign:=fieldalignment;
- _datasize:=offset;
- if (usefieldalignment=bit_alignment) then
- databitsize:=offset*8;
- { We move the ownership of the defs and symbols to the new recordsymtable.
- The old unionsymtable keeps the references, but doesn't own the
- objects anymore }
- unionst.DefList.OwnsObjects:=false;
- unionst.SymList.OwnsObjects:=false;
- { copy symbols }
- for i:=0 to unionst.SymList.Count-1 do
- begin
- sym:=TSym(unionst.SymList[i]);
- if sym.typ<>fieldvarsym then
- internalerror(200601272);
- if tfieldvarsym(sym).fieldoffset=0 then
- include(tfieldvarsym(sym).varoptions,vo_is_first_field);
- { add to this record symtable, checking for duplicate names }
- // unionst.SymList.List.List^[i].Data:=nil;
- insert(sym);
- varalign:=tfieldvarsym(sym).vardef.alignment;
- if varalign=0 then
- varalign:=size_2_align(tfieldvarsym(sym).getsize);
- { retrieve size }
- if (usefieldalignment=bit_alignment) then
- begin
- { bit packed records are limited to high(aint) bits }
- { instead of bytes to avoid double precision }
- { arithmetic in offset calculations }
- if is_ordinal(tfieldvarsym(sym).vardef) then
- bitsize:=tfieldvarsym(sym).getpackedbitsize
- else
- begin
- bitsize:=tfieldvarsym(sym).getsize;
- if (bitsize>high(asizeint) div 8) then
- Message(sym_e_segment_too_large);
- bitsize:=bitsize*8;
- end;
- if bitsize>high(asizeint)-databitsize then
- begin
- Message(sym_e_segment_too_large);
- _datasize:=high(asizeint);
- databitsize:=high(asizeint);
- end
- else
- begin
- databitsize:=tfieldvarsym(sym).fieldoffset+offset*8;
- _datasize:=(databitsize+7) div 8;
- end;
- tfieldvarsym(sym).fieldoffset:=databitsize;
- varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset div 8,varalign);
- end
- else
- begin
- if tfieldvarsym(sym).getsize>high(asizeint)-_datasize then
- begin
- Message(sym_e_segment_too_large);
- _datasize:=high(asizeint);
- end
- else
- _datasize:=tfieldvarsym(sym).fieldoffset+offset;
- { update address }
- tfieldvarsym(sym).fieldoffset:=_datasize;
- varalignrecord:=field2recordalignment(tfieldvarsym(sym).fieldoffset,varalign);
- end;
- { update alignment of this record }
- if (usefieldalignment<>C_alignment) and
- (usefieldalignment<>mac68k_alignment) then
- recordalignment:=max(recordalignment,varalignrecord);
- end;
- { update alignment for C records }
- if (usefieldalignment=C_alignment) and
- (usefieldalignment<>mac68k_alignment) then
- recordalignment:=max(recordalignment,unionst.recordalignment);
- { Register defs in the new record symtable }
- for i:=0 to unionst.DefList.Count-1 do
- begin
- def:=TDef(unionst.DefList[i]);
- def.ChangeOwner(self);
- end;
- _datasize:=storesize;
- fieldalignment:=storealign;
- { If a record contains a union, it does not contain a "single
- non-composite field" in the context of certain ABIs requiring
- special treatment for such records }
- if defowner.typ=recorddef then
- trecorddef(defowner).isunion:=true;
- end;
- procedure trecordsymtable.includemanagementoperator(mop:tmanagementoperator);
- begin
- if mop in managementoperators then
- exit;
- include(managementoperators,mop);
- end;
- {****************************************************************************
- TObjectSymtable
- ****************************************************************************}
- constructor tObjectSymtable.create(adefowner:tdef;const n:string;usealign,recordminalign,recordmaxCalign:shortint);
- begin
- inherited create(n,usealign,recordminalign,recordmaxCalign);
- symtabletype:=ObjectSymtable;
- defowner:=adefowner;
- end;
- function tObjectSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- var
- hsym: tsym;
- warn: boolean;
- begin
- result:=false;
- if not assigned(defowner) then
- internalerror(200602061);
- { procsym and propertysym have special code
- to override values in inherited classes. For other
- symbols check for duplicates }
- if not(sym.typ in [procsym,propertysym]) then
- begin
- { but private ids can be reused }
- hsym:=search_struct_member(tobjectdef(defowner),hashedid.id);
- if assigned(hsym) and
- (
- (
- not(m_delphi in current_settings.modeswitches) and
- is_visible_for_object(hsym,tobjectdef(defowner))
- ) or
- (
- { In Delphi, you can repeat members of a parent class. You can't }
- { do this for objects however, and you (obviouly) can't }
- { declare two fields with the same name in a single class }
- (m_delphi in current_settings.modeswitches) and
- (
- is_object(tdef(defowner)) or
- (hsym.owner = self)
- )
- )
- ) then
- begin
- { only watn when a parameter/local variable in a method
- conflicts with a category method, because this can easily
- happen due to all possible categories being imported via
- CocoaAll }
- warn:=
- (is_objccategory(tdef(hsym.owner.defowner)) or
- is_classhelper(tdef(hsym.owner.defowner))) and
- (sym.typ in [paravarsym,localvarsym,fieldvarsym]);
- DuplicateSym(hashedid,sym,hsym,warn);
- result:=true;
- end;
- end
- else
- result:=inherited checkduplicate(hashedid,sym);
- end;
- {$ifdef llvm}
- {****************************************************************************
- tLlvmShadowSymtableEntry
- ****************************************************************************}
- constructor tllvmshadowsymtableentry.create(def: tdef; fieldoffset: aint);
- begin
- fdef:=def;
- ffieldoffset:=fieldoffset;
- end;
- {****************************************************************************
- TLlvmShadowSymtable
- ****************************************************************************}
- function tllvmshadowsymtable.get(f: tfieldvarsym): tllvmshadowsymtableentry;
- begin
- result:=get_by_llvm_index(f.llvmfieldnr)
- end;
- function tllvmshadowsymtable.get_by_llvm_index(index: longint): tllvmshadowsymtableentry;
- begin
- result:=tllvmshadowsymtableentry(symdeflist[index]);
- end;
- constructor tllvmshadowsymtable.create(st: tabstractrecordsymtable);
- begin
- equivst:=st;
- curroffset:=0;
- symdeflist:=tfpobjectlist.create(true);
- generate;
- end;
- destructor tllvmshadowsymtable.destroy;
- begin
- symdeflist.free;
- end;
- procedure tllvmshadowsymtable.appenddefoffset(vardef:tdef; fieldoffset: aint; derefclass: boolean);
- var
- sizectr,
- tmpsize: aint;
- begin
- case equivst.usefieldalignment of
- bit_alignment:
- begin
- { curoffset: bit address after the previous field. }
- { llvm has no special support for bitfields in records, }
- { so we replace them with plain bytes. }
- { as soon as a single bit of a byte is allocated, we }
- { allocate the byte in the llvm shadow record }
- if (fieldoffset>curroffset) then
- curroffset:=align(curroffset,8);
- { fields in bitpacked records always start either right }
- { after the previous one, or at the next byte boundary. }
- if (curroffset<>fieldoffset) then
- internalerror(2008051002);
- if is_ordinal(vardef) then
- begin
- tmpsize:=vardef.packedbitsize;
- sizectr:=((curroffset+tmpsize+7) shr 3)-((curroffset+7) shr 3);
- inc(curroffset,tmpsize);
- tmpsize:=0;
- while sizectr<>0 do
- begin
- symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,fieldoffset+tmpsize*8));
- dec(sizectr);
- inc(tmpsize);
- end;
- end
- else
- begin
- symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
- if not(derefclass) then
- inc(curroffset,vardef.size*8)
- else
- inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize*8);
- end;
- end
- else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then
- begin
- { curoffset: address right after the previous field }
- while (fieldoffset>curroffset) do
- begin
- symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset));
- inc(curroffset);
- end;
- symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
- if not(derefclass) then
- inc(curroffset,vardef.size)
- else
- inc(curroffset,tobjectsymtable(tobjectdef(vardef).symtable).datasize);
- end
- else
- { default for llvm, don't add explicit padding }
- symdeflist.add(tllvmshadowsymtableentry.create(vardef,fieldoffset));
- end
- end;
- procedure tllvmshadowsymtable.addalignmentpadding(finalsize: aint);
- begin
- case equivst.usefieldalignment of
- { already correct in this case }
- bit_alignment:
- ;
- else if not(df_llvm_no_struct_packing in tdef(equivst.defowner).defoptions) then
- begin
- { add padding fields }
- while (finalsize>curroffset) do
- begin
- symdeflist.add(tllvmshadowsymtableentry.create(u8inttype,curroffset));
- inc(curroffset);
- end;
- end;
- end;
- end;
- procedure tllvmshadowsymtable.findvariantstarts(variantstarts: tfplist);
- var
- sym: tfieldvarsym;
- lastoffset: aint;
- newalignment: aint;
- i, j: longint;
- begin
- i:=0;
- while (i<equivst.symlist.count) do
- begin
- if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
- (sp_static in tsym(equivst.symlist[i]).symoptions) then
- begin
- inc(i);
- continue;
- end;
- sym:=tfieldvarsym(equivst.symlist[i]);
- { a "better" algorithm might be to use the largest }
- { variant in case of (bit)packing, since then }
- { alignment doesn't matter }
- if (vo_is_first_field in sym.varoptions) then
- begin
- { we assume that all fields are processed in order. }
- if (variantstarts.count<>0) then
- lastoffset:=tfieldvarsym(variantstarts[variantstarts.count-1]).fieldoffset
- else
- lastoffset:=-1;
- { new variant at same level as last one: use if higher alignment }
- if (lastoffset=sym.fieldoffset) then
- begin
- if (equivst.fieldalignment<>bit_alignment) then
- newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment)
- else
- newalignment:=1;
- if (newalignment>tfieldvarsym(variantstarts[variantstarts.count-1]).vardef.alignment) then
- variantstarts[variantstarts.count-1]:=sym;
- end
- { variant at deeper level than last one -> add }
- else if (lastoffset<sym.fieldoffset) then
- variantstarts.add(sym)
- else
- begin
- { a variant at a less deep level, so backtrack }
- j:=variantstarts.count-2;
- while (j>=0) do
- begin
- if (tfieldvarsym(variantstarts[j]).fieldoffset=sym.fieldoffset) then
- break;
- dec(j);
- end;
- if (j<0) then
- internalerror(2008051003);
- { new variant has higher alignment? }
- if (equivst.fieldalignment<>bit_alignment) then
- newalignment:=used_align(sym.vardef.alignment,equivst.recordalignmin,equivst.fieldalignment)
- else
- newalignment:=1;
- { yes, replace and remove previous nested variants }
- if (newalignment>tfieldvarsym(variantstarts[j]).vardef.alignment) then
- begin
- variantstarts[j]:=sym;
- variantstarts.count:=j+1;
- end
- { no, skip this variant }
- else
- begin
- inc(i);
- while (i<equivst.symlist.count) and
- ((tsym(equivst.symlist[i]).typ<>fieldvarsym) or
- (sp_static in tsym(equivst.symlist[i]).symoptions) or
- (tfieldvarsym(equivst.symlist[i]).fieldoffset>sym.fieldoffset)) do
- inc(i);
- continue;
- end;
- end;
- end;
- inc(i);
- end;
- end;
- procedure tllvmshadowsymtable.buildtable(variantstarts: tfplist);
- var
- lastvaroffsetprocessed: aint;
- i, equivcount, varcount: longint;
- begin
- { if it's an object/class, the first entry is the parent (if there is one) }
- if (equivst.symtabletype=objectsymtable) and
- assigned(tobjectdef(equivst.defowner).childof) then
- appenddefoffset(tobjectdef(equivst.defowner).childof,0,is_class_or_interface_or_dispinterface(tobjectdef(equivst.defowner).childof));
- equivcount:=equivst.symlist.count;
- varcount:=0;
- i:=0;
- lastvaroffsetprocessed:=-1;
- while (i<equivcount) do
- begin
- if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
- (sp_static in tsym(equivst.symlist[i]).symoptions) then
- begin
- inc(i);
- continue;
- end;
- { start of a new variant? }
- if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then
- begin
- { if we want to process the same variant offset twice, it means that we }
- { got to the end and are trying to process the next variant part -> stop }
- if (tfieldvarsym(equivst.symlist[i]).fieldoffset<=lastvaroffsetprocessed) then
- break;
- if (varcount>=variantstarts.count) then
- internalerror(2008051005);
- { new variant part -> use the one with the biggest alignment }
- i:=equivst.symlist.indexof(tobject(variantstarts[varcount]));
- lastvaroffsetprocessed:=tfieldvarsym(equivst.symlist[i]).fieldoffset;
- inc(varcount);
- if (i<0) then
- internalerror(2008051004);
- end;
- appenddefoffset(tfieldvarsym(equivst.symlist[i]).vardef,tfieldvarsym(equivst.symlist[i]).fieldoffset,false);
- inc(i);
- end;
- addalignmentpadding(equivst.datasize);
- end;
- procedure tllvmshadowsymtable.buildmapping(variantstarts: tfplist);
- var
- i, varcount: longint;
- shadowindex: longint;
- equivcount : longint;
- begin
- varcount:=0;
- shadowindex:=0;
- equivcount:=equivst.symlist.count;
- i:=0;
- while (i < equivcount) do
- begin
- if (tsym(equivst.symlist[i]).typ<>fieldvarsym) or
- (sp_static in tsym(equivst.symlist[i]).symoptions) then
- begin
- inc(i);
- continue;
- end;
- { start of a new variant? }
- if (vo_is_first_field in tfieldvarsym(equivst.symlist[i]).varoptions) then
- begin
- { back up to a less deeply nested variant level? }
- while (tfieldvarsym(equivst.symlist[i]).fieldoffset<tfieldvarsym(variantstarts[varcount]).fieldoffset) do
- dec(varcount);
- { it's possible that some variants are more deeply nested than the
- one we recorded in the shadowsymtable (since we recorded the one
- with the biggest alignment, not necessarily the biggest one in size
- }
- if (tfieldvarsym(equivst.symlist[i]).fieldoffset>tfieldvarsym(variantstarts[varcount]).fieldoffset) then
- varcount:=variantstarts.count-1
- else if (tfieldvarsym(equivst.symlist[i]).fieldoffset<>tfieldvarsym(variantstarts[varcount]).fieldoffset) then
- internalerror(2008051006);
- { reset the shadowindex to the start of this variant. }
- { in case the llvmfieldnr is not (yet) set for this }
- { field, shadowindex will simply be reset to zero and }
- { we'll start searching from the start of the record }
- shadowindex:=tfieldvarsym(variantstarts[varcount]).llvmfieldnr;
- if (varcount<pred(variantstarts.count)) then
- inc(varcount);
- end;
- { find the last shadowfield whose offset <= the current field's offset }
- while (tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset<tfieldvarsym(equivst.symlist[i]).fieldoffset) and
- (shadowindex<symdeflist.count-1) and
- (tllvmshadowsymtableentry(symdeflist[shadowindex+1]).fieldoffset<=tfieldvarsym(equivst.symlist[i]).fieldoffset) do
- inc(shadowindex);
- { set the field number and potential offset from that field (in case }
- { of overlapping variants) }
- tfieldvarsym(equivst.symlist[i]).llvmfieldnr:=shadowindex;
- tfieldvarsym(equivst.symlist[i]).offsetfromllvmfield:=
- tfieldvarsym(equivst.symlist[i]).fieldoffset-tllvmshadowsymtableentry(symdeflist[shadowindex]).fieldoffset;
- inc(i);
- end;
- end;
- procedure tllvmshadowsymtable.generate;
- var
- variantstarts: tfplist;
- begin
- variantstarts:=tfplist.create;
- { first go through the entire record and }
- { store the fieldvarsyms of the variants }
- { with the highest alignment }
- findvariantstarts(variantstarts);
- { now go through the regular fields and the selected variants, }
- { and add them to the llvm shadow record symtable }
- buildtable(variantstarts);
- { finally map all original fields to the llvm definition }
- buildmapping(variantstarts);
- variantstarts.free;
- end;
- {$endif llvm}
- {****************************************************************************
- TAbstractSubSymtable
- ****************************************************************************}
- procedure tabstractsubsymtable.ppuwrite(ppufile:tcompilerppufile);
- var
- oldtyp : byte;
- begin
- oldtyp:=ppufile.entrytyp;
- ppufile.entrytyp:=subentryid;
- inherited ppuwrite(ppufile);
- ppufile.entrytyp:=oldtyp;
- end;
- {****************************************************************************
- TAbstractLocalSymtable
- ****************************************************************************}
- function tabstractlocalsymtable.count_locals:longint;
- var
- i : longint;
- sym : tsym;
- begin
- result:=0;
- for i:=0 to SymList.Count-1 do
- begin
- sym:=tsym(SymList[i]);
- { Count only varsyms, but ignore the funcretsym }
- if (tsym(sym).typ in [localvarsym,paravarsym]) and
- (tsym(sym)<>current_procinfo.procdef.funcretsym) and
- (not(vo_is_parentfp in tabstractvarsym(sym).varoptions) or
- (tstoredsym(sym).refs>0)) then
- inc(result);
- end;
- end;
- function tabstractlocalsymtable.iscurrentunit: boolean;
- begin
- Result:=
- assigned(defowner) and
- defowner.owner.iscurrentunit;
- end;
- {****************************************************************************
- TLocalSymtable
- ****************************************************************************}
- constructor tlocalsymtable.create(adefowner:tdef;level:byte);
- begin
- inherited create('');
- defowner:=adefowner;
- symtabletype:=localsymtable;
- symtablelevel:=level;
- end;
- function tlocalsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- var
- hsym : tsym;
- begin
- if not assigned(defowner) or
- (defowner.typ<>procdef) then
- internalerror(200602042);
- result:=false;
- hsym:=tsym(FindWithHash(hashedid));
- if assigned(hsym) then
- begin
- { a local and the function can have the same
- name in TP and Delphi, but RESULT not }
- if (m_duplicate_names in current_settings.modeswitches) and
- (hsym.typ in [absolutevarsym,localvarsym]) and
- (vo_is_funcret in tabstractvarsym(hsym).varoptions) and
- not((m_result in current_settings.modeswitches) and
- (vo_is_result in tabstractvarsym(hsym).varoptions)) then
- HideSym(hsym)
- else
- DuplicateSym(hashedid,sym,hsym,false);
- result:=true;
- exit;
- end;
- { check also parasymtable, this needs to be done here because
- of the special situation with the funcret sym that needs to be
- hidden for tp and delphi modes }
- hsym:=tsym(tabstractprocdef(defowner).parast.FindWithHash(hashedid));
- if assigned(hsym) then
- begin
- { a local and the function can have the same
- name in TP and Delphi, but RESULT not }
- if (m_duplicate_names in current_settings.modeswitches) and
- (sym.typ in [absolutevarsym,localvarsym]) and
- (vo_is_funcret in tabstractvarsym(sym).varoptions) and
- not((m_result in current_settings.modeswitches) and
- (vo_is_result in tabstractvarsym(sym).varoptions)) then
- Hidesym(sym)
- else
- DuplicateSym(hashedid,sym,hsym,false);
- result:=true;
- exit;
- end;
- { check ObjectSymtable, skip this for funcret sym because
- that will always be positive because it has the same name
- as the procsym }
- if not is_funcret_sym(sym) and
- (defowner.typ=procdef) and
- assigned(tprocdef(defowner).struct) and
- (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
- (
- not(m_delphi in current_settings.modeswitches) or
- is_object(tprocdef(defowner).struct)
- ) then
- result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
- end;
- {****************************************************************************
- TParaSymtable
- ****************************************************************************}
- constructor tparasymtable.create(adefowner:tdef;level:byte);
- begin
- inherited create('');
- readonly:=false;
- defowner:=adefowner;
- symtabletype:=parasymtable;
- symtablelevel:=level;
- end;
- function tparasymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- begin
- result:=inherited checkduplicate(hashedid,sym);
- if result then
- exit;
- if not(m_duplicate_names in current_settings.modeswitches) and
- assigned(defowner) and (defowner.typ=procdef) and
- assigned(tprocdef(defowner).struct) and
- assigned(tprocdef(defowner).owner) and
- (tprocdef(defowner).owner.defowner=tprocdef(defowner).struct) and
- (
- not(m_delphi in current_settings.modeswitches) or
- is_object(tprocdef(defowner).struct)
- ) then
- result:=tprocdef(defowner).struct.symtable.checkduplicate(hashedid,sym);
- end;
- procedure tparasymtable.insertdef(def: TDefEntry);
- begin
- if readonly then
- defowner.owner.insertdef(def)
- else
- inherited insertdef(def);
- end;
- {****************************************************************************
- TAbstractUniTSymtable
- ****************************************************************************}
- constructor tabstractuniTSymtable.create(const n : string;id:word);
- begin
- inherited create(n);
- moduleid:=id;
- end;
- function tabstractuniTSymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- var
- hsym : tsym;
- begin
- result:=false;
- hsym:=tsym(FindWithHash(hashedid));
- if assigned(hsym) then
- begin
- if (sym is tstoredsym) and handle_generic_dummysym(hsym,tstoredsym(sym).symoptions) then
- exit;
- if hsym.typ=symconst.namespacesym then
- begin
- case sym.typ of
- symconst.namespacesym:;
- symconst.unitsym:
- begin
- 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 }
- tnamespacesym(hsym).unitsym:=tsym(sym);
- end
- else
- HideSym(hsym);
- end;
- end
- else
- { In delphi (contrary to TP) you can have a symbol with the same name as the
- unit, the unit can then not be accessed anymore using
- <unit>.<id>, so we can hide the symbol.
- Do the same if we add a namespace and there is a unit with the same name }
- if (hsym.typ=symconst.unitsym) and
- ((m_delphi in current_settings.modeswitches) or (sym.typ=symconst.namespacesym)) then
- begin
- HideSym(hsym);
- if sym.typ=symconst.namespacesym then
- tnamespacesym(sym).unitsym:=tsym(hsym);
- end
- { iso mode program parameters: staticvarsyms might have the same name as a program parameters,
- in this case, copy the isoindex and make the original symbol invisible }
- else if (m_isolike_program_para in current_settings.modeswitches) and (hsym.typ=programparasym) and (sym.typ=staticvarsym)
- and (tprogramparasym(hsym).isoindex<>0) then
- begin
- HideSym(hsym);
- tstaticvarsym(sym).isoindex:=tprogramparasym(hsym).isoindex;
- end
- else
- DuplicateSym(hashedid,sym,hsym,false);
- result:=true;
- exit;
- end;
- end;
- function tabstractuniTSymtable.findnamespace(const n:string):TSymEntry;
- begin
- result:=find(n);
- if assigned(result)and(result.typ<>namespacesym)then
- result:=nil;
- end;
- function tabstractuniTSymtable.iscurrentunit:boolean;
- begin
- result:=assigned(current_module) and
- (
- (current_module.globalsymtable=self) or
- (current_module.localsymtable=self)
- );
- end;
- function tabstractuniTSymtable.needs_init_final: boolean;
- begin
- if not init_final_check_done then
- begin
- result:=inherited needs_init_final;
- if not result then
- begin
- result:=has_class_condestructors;
- if result then
- include(tableoptions,sto_needs_init_final);
- end;
- end;
- result:=sto_needs_init_final in tableoptions;
- end;
- procedure tabstractuniTSymtable.insertunit(sym:TSymEntry);
- var
- p:integer;
- n,ns:string;
- oldsym:TSymEntry;
- begin
- insert(sym);
- n:=sym.realname;
- p:=pos('.',n);
- ns:='';
- while p>0 do
- begin
- if ns='' then
- ns:=copy(n,1,p-1)
- else
- ns:=ns+'.'+copy(n,1,p-1);
- system.delete(n,1,p);
- oldsym:=findnamespace(upper(ns));
- if not assigned(oldsym) then
- insert(cnamespacesym.create(ns));
- p:=pos('.',n);
- end;
- end;
- procedure CheckForClassConDestructors(p:TObject;arg:pointer);
- var
- result: pboolean absolute arg;
- begin
- if result^ then
- exit;
- if (tdef(p).typ in [objectdef,recorddef]) and
- not (df_generic in tdef(p).defoptions) then
- begin
- { first check the class... }
- if ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
- result^:=true;;
- { ... and then also check all subclasses }
- if not result^ then
- tabstractrecorddef(p).symtable.deflist.foreachcall(@CheckForClassConDestructors,arg);
- end;
- end;
- function tabstractuniTSymtable.has_class_condestructors: boolean;
- begin
- result:=false;
- deflist.foreachcall(@CheckForClassConDestructors,@result);
- end;
- {****************************************************************************
- TStaticSymtable
- ****************************************************************************}
- constructor tstaticsymtable.create(const n : string;id:word);
- begin
- inherited create(n,id);
- symtabletype:=staticsymtable;
- symtablelevel:=main_program_level;
- currentvisibility:=vis_private;
- end;
- procedure tstaticsymtable.ppuload(ppufile:tcompilerppufile);
- begin
- inherited ppuload(ppufile);
- { now we can deref the syms and defs }
- deref(false);
- end;
- procedure tstaticsymtable.ppuwrite(ppufile:tcompilerppufile);
- begin
- inherited ppuwrite(ppufile);
- end;
- function tstaticsymtable.checkduplicate(var hashedid:THashedIDString;sym:TSymEntry):boolean;
- begin
- result:=inherited checkduplicate(hashedid,sym);
- if not result and
- (current_module.localsymtable=self) and
- assigned(current_module.globalsymtable) then
- result:=tglobalsymtable(current_module.globalsymtable).checkduplicate(hashedid,sym);
- end;
- function tstaticsymtable.findnamespace(const n:string):TSymEntry;
- begin
- result:=inherited findnamespace(n);
- if not assigned(result) and
- (current_module.localsymtable=self) and
- assigned(current_module.globalsymtable) then
- result:=tglobalsymtable(current_module.globalsymtable).findnamespace(n);
- end;
- {****************************************************************************
- TGlobalSymtable
- ****************************************************************************}
- constructor tglobalsymtable.create(const n : string;id:word);
- begin
- inherited create(n,id);
- symtabletype:=globalsymtable;
- symtablelevel:=main_program_level;
- end;
- procedure tglobalsymtable.ppuload(ppufile:tcompilerppufile);
- begin
- inherited ppuload(ppufile);
- { now we can deref the syms and defs }
- deref(false);
- end;
- procedure tglobalsymtable.ppuwrite(ppufile:tcompilerppufile);
- begin
- { write the symtable entries }
- inherited ppuwrite(ppufile);
- end;
- {*****************************************************************************
- tspecializesymtable
- *****************************************************************************}
- constructor tspecializesymtable.create(const n : string;id:word);
- begin
- inherited create(n,id);
- { the specialize symtable does not own the syms and defs as they are all
- moved to a different symtable before the symtable is destroyed; this
- avoids calls to "extract" }
- symlist.ownsobjects:=false;
- deflist.ownsobjects:=false;
- end;
- function tspecializesymtable.iscurrentunit: boolean;
- begin
- Result:=true;
- end;
- {****************************************************************************
- TWITHSYMTABLE
- ****************************************************************************}
- constructor twithsymtable.create(aowner:tdef;ASymList:TFPHashObjectList;refnode:tobject{tnode});
- begin
- inherited create('');
- symtabletype:=withsymtable;
- withrefnode:=refnode;
- { Replace SymList with the passed symlist }
- SymList.free;
- SymList:=ASymList;
- defowner:=aowner;
- end;
- destructor twithsymtable.destroy;
- begin
- if refcount>1 then
- exit;
- withrefnode.free;
- { Disable SymList because we don't Own it }
- SymList:=nil;
- inherited destroy;
- end;
- procedure twithsymtable.clear;
- begin
- { remove no entry from a withsymtable as it is only a pointer to the
- recorddef or objectdef symtable }
- end;
- procedure twithsymtable.insertdef(def:TDefEntry);
- begin
- { Definitions can't be registered in the withsymtable
- because the withsymtable is removed after the with block.
- We can't easily solve it here because the next symtable in the
- stack is not known. }
- internalerror(200602046);
- end;
- {****************************************************************************
- TSTT_ExceptionSymtable
- ****************************************************************************}
- constructor tstt_excepTSymtable.create;
- begin
- inherited create('');
- symtabletype:=stt_excepTSymtable;
- end;
- {****************************************************************************
- TMacroSymtable
- ****************************************************************************}
- constructor tmacrosymtable.create(exported: boolean);
- begin
- inherited create('');
- if exported then
- symtabletype:=exportedmacrosymtable
- else
- symtabletype:=localmacrosymtable;
- symtablelevel:=main_program_level;
- end;
- {****************************************************************************
- TEnumSymtable
- ****************************************************************************}
- procedure tenumsymtable.insert(sym: TSymEntry; checkdup: boolean);
- var
- value: longint;
- def: tenumdef;
- begin
- // defowner = nil only when we are loading from ppu
- if defowner<>nil then
- begin
- { First entry? Then we need to set the minval }
- value:=tenumsym(sym).value;
- def:=tenumdef(defowner);
- if SymList.count=0 then
- begin
- if value>0 then
- def.has_jumps:=true;
- def.setmin(value);
- def.setmax(value);
- end
- else
- begin
- { check for jumps }
- if value>def.max+1 then
- def.has_jumps:=true;
- { update low and high }
- if def.min>value then
- def.setmin(value);
- if def.max<value then
- def.setmax(value);
- end;
- end;
- inherited insert(sym, checkdup);
- end;
- constructor tenumsymtable.create(adefowner: tdef);
- begin
- inherited Create('');
- symtabletype:=enumsymtable;
- defowner:=adefowner;
- end;
- {****************************************************************************
- TArraySymtable
- ****************************************************************************}
- procedure tarraysymtable.insertdef(def: TDefEntry);
- begin
- { Enums must also be available outside the record scope,
- insert in the owner of this symtable }
- if def.typ=enumdef then
- defowner.owner.insertdef(def)
- else
- inherited insertdef(def);
- end;
- constructor tarraysymtable.create(adefowner: tdef);
- begin
- inherited Create('');
- symtabletype:=arraysymtable;
- defowner:=adefowner;
- end;
- {*****************************************************************************
- Helper Routines
- *****************************************************************************}
- function FullTypeName(def,otherdef:tdef):string;
- var
- s1,s2 : string;
- begin
- if def.typ in [objectdef,recorddef] then
- s1:=tabstractrecorddef(def).RttiName
- else
- s1:=def.typename;
- { When the names are the same try to include the unit name }
- if assigned(otherdef) and
- (def.owner.symtabletype in [globalsymtable,staticsymtable]) then
- begin
- s2:=otherdef.typename;
- if upper(s1)=upper(s2) then
- s1:=def.owner.realname^+'.'+s1;
- end;
- FullTypeName:=s1;
- end;
- function generate_nested_name(symtable:tsymtable;delimiter:string):string;
- begin
- result:='';
- while assigned(symtable) and (symtable.symtabletype in [ObjectSymtable,recordsymtable]) do
- begin
- if (result='') then
- if symtable.name<>nil then
- result:=symtable.name^
- else
- else
- if symtable.name<>nil then
- result:=symtable.name^+delimiter+result
- else
- result:=delimiter+result;
- symtable:=symtable.defowner.owner;
- end;
- end;
- function generate_objectpascal_helper_key(def:tdef):string;
- begin
- if not assigned(def) then
- internalerror(2013020501);
- if def.typ in [recorddef,objectdef] then
- result:=make_mangledname('',tabstractrecorddef(def).symtable,'')
- else
- result:=make_mangledname('',def.owner,def.typesym.name);
- end;
- procedure incompatibletypes(def1,def2:tdef);
- begin
- { When there is an errordef there is already an error message show }
- if (def2.typ=errordef) or
- (def1.typ=errordef) then
- exit;
- CGMessage2(type_e_incompatible_types,FullTypeName(def1,def2),FullTypeName(def2,def1));
- end;
- procedure hidesym(sym:TSymEntry);
- begin
- sym.realname:='$hidden'+sym.realname;
- tsym(sym).visibility:=vis_hidden;
- end;
- procedure duplicatesym(var hashedid: THashedIDString; dupsym, origsym: TSymEntry; warn: boolean);
- var
- st : TSymtable;
- filename : TIDString;
- begin
- if not warn then
- Message1(sym_e_duplicate_id,tsym(origsym).realname)
- else
- Message1(sym_w_duplicate_id,tsym(origsym).realname);
- { Write hint where the original symbol was found }
- st:=finduniTSymtable(origsym.owner);
- with tsym(origsym).fileinfo do
- begin
- if assigned(st) and
- (st.symtabletype=globalsymtable) and
- st.iscurrentunit then
- Message2(sym_h_duplicate_id_where,current_module.sourcefiles.get_file_name(fileindex),tostr(line))
- else if assigned(st.name) then
- begin
- filename:=find_module_from_symtable(st).sourcefiles.get_file_name(fileindex);
- if filename<>'' then
- Message2(sym_h_duplicate_id_where,'unit '+st.name^+': '+filename,tostr(line))
- else
- Message2(sym_h_duplicate_id_where,'unit '+st.name^,tostr(line))
- end;
- end;
- { Rename duplicate sym to an unreachable name, but it can be
- inserted in the symtable without errors }
- inc(dupnr);
- hashedid.id:='dup'+tostr(dupnr)+hashedid.id;
- if assigned(dupsym) then
- include(tsym(dupsym).symoptions,sp_implicitrename);
- end;
- function handle_generic_dummysym(sym:TSymEntry;var symoptions:tsymoptions):boolean;
- begin
- result:=false;
- if not assigned(sym) or not (sym is tstoredsym) then
- Internalerror(2011081101);
- { For generics a dummy symbol without the parameter count is created
- if such a symbol not yet exists so that different parts of the
- parser can find that symbol. If that symbol is still a
- undefineddef we replace the generic dummy symbol's
- name with a "dup" name and use the new symbol as the generic dummy
- symbol }
- if (sp_generic_dummy in tstoredsym(sym).symoptions) and
- (sym.typ=typesym) and (ttypesym(sym).typedef.typ=undefineddef) and
- (m_delphi in current_settings.modeswitches) then
- begin
- inc(dupnr);
- sym.Owner.SymList.Rename(upper(sym.realname),'dup_'+tostr(dupnr)+sym.realname);
- include(tsym(sym).symoptions,sp_implicitrename);
- { we need to find the new symbol now if checking for a dummy }
- include(symoptions,sp_generic_dummy);
- result:=true;
- end;
- end;
- procedure write_system_parameter_lists(const name:string);
- var
- srsym:tprocsym;
- begin
- srsym:=tprocsym(systemunit.find(name));
- if not assigned(srsym) or not (srsym.typ=procsym) then
- internalerror(2016060302);
- srsym.write_parameter_lists(nil);
- end;
- {*****************************************************************************
- Search
- *****************************************************************************}
- procedure addsymref(sym:tsym);
- var
- owner: tsymtable;
- begin
- { for symbols used in preprocessor expressions, we don't want to
- increase references count (for smaller final binaries) }
- if not assigned(current_scanner) then
- internalerror(2017050601);
- if current_scanner.in_preproc_comp_expr then
- exit;
- { symbol uses count }
- sym.IncRefCount;
- owner:=sym.owner;
- while owner.symtabletype in [objectsymtable,recordsymtable,enumsymtable] do
- owner:=tdef(owner.defowner).owner;
- if assigned(current_module) and
- (owner.symtabletype=globalsymtable) then
- begin
- if tglobalsymtable(owner).moduleid>=current_module.unitmapsize then
- internalerror(200501152);
- { unit uses count }
- inc(current_module.unitmap[tglobalsymtable(owner).moduleid].refs);
- { Note: don't check the symtable directly as owner might be
- a specialize symtable which is a globalsymtable as well }
- if (
- assigned(current_module.globalsymtable) and
- (current_module.globalsymtable.moduleid<>owner.moduleid)
- ) or (
- assigned(current_module.localsymtable) and
- (current_module.localsymtable.moduleid<>owner.moduleid)
- ) then
- { symbol is imported from another unit }
- current_module.addimportedsym(sym);
- end;
- end;
- function is_owned_by(nesteddef,ownerdef:tdef):boolean;
- begin
- result:=nesteddef=ownerdef;
- if not result and
- { types declared locally in a record method are not defined in the
- record itself }
- not(nesteddef.owner.symtabletype in [localsymtable,parasymtable]) and
- assigned(nesteddef.owner.defowner) then
- result:=is_owned_by(tdef(nesteddef.owner.defowner),ownerdef);
- end;
- function sym_is_owned_by(childsym:tsym;symtable:tsymtable):boolean;
- begin
- result:=assigned(childsym) and (childsym.owner=symtable);
- if not result and assigned(childsym) and
- (childsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
- result:=sym_is_owned_by(tabstractrecorddef(childsym.owner.defowner).typesym,symtable);
- end;
- function defs_belong_to_same_generic(def1, def2: tdef): boolean;
- begin
- result:=false;
- if not assigned(def1) or not assigned(def2) then
- exit;
- { for both defs walk to the topmost generic }
- while assigned(def1.owner.defowner) and (df_generic in tstoreddef(def1.owner.defowner).defoptions) do
- def1:=tdef(def1.owner.defowner);
- while assigned(def2.owner.defowner) and (df_generic in tstoreddef(def2.owner.defowner).defoptions) do
- def2:=tdef(def2.owner.defowner);
- result:=def1=def2;
- end;
- function get_generic_in_hierarchy_by_name(srsym: tsym; def: tdef): tdef;
- var
- uname : string;
- begin
- { TODO : check regarding arrays and records declared as their type }
- if not (def.typ in [recorddef,objectdef]) then
- internalerror(2012051501);
- uname:=upper(srsym.realname);
- repeat
- if uname=copy(tabstractrecorddef(def).objname^,1,pos('$',tabstractrecorddef(def).objname^)-1) then
- begin
- result:=def;
- exit;
- end;
- def:=tdef(def.owner.defowner);
- until not assigned(def) or not (def.typ in [recorddef,objectdef]);
- result:=nil;
- end;
- function return_specialization_of_generic(nesteddef,genericdef:tdef; out resultdef:tdef):boolean;
- begin
- { TODO : check regarding arrays and records declared as their type }
- if not (nesteddef.typ in [recorddef,objectdef]) then
- internalerror(2012051601);
- repeat
- if tstoreddef(nesteddef).genericdef=genericdef then
- begin
- resultdef:=nesteddef;
- result:=true;
- exit;
- end;
- nesteddef:=tdef(nesteddef.owner.defowner);
- until not assigned(nesteddef) or not (nesteddef.typ in [recorddef,objectdef]);
- resultdef:=nil;
- result:=false;
- end;
- { symst: symboltable that contains the symbol (-> symowner def: record/objectdef in which the symbol is defined)
- symvisibility: visibility of the symbol
- contextobjdef: via which def the symbol is accessed, e.g.:
- fieldname:=1 -> contextobjdef = current_structdef
- objfield.fieldname:=1 -> contextobjdef = def of objfield
- }
- function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
- var
- symownerdef : tabstractrecorddef;
- nonlocalst : tsymtable;
- isspezproc : boolean;
- begin
- result:=false;
- { Get objdectdef owner of the symtable for the is_related checks }
- if not assigned(symst) or
- not (symst.symtabletype in [objectsymtable,recordsymtable]) then
- internalerror(200810285);
- symownerdef:=tabstractrecorddef(symst.defowner);
- { specializations might belong to a localsymtable or parasymtable }
- nonlocalst:=symownerdef.owner;
- if tstoreddef(symst.defowner).is_specialization then
- while nonlocalst.symtabletype in [localsymtable,parasymtable] do
- nonlocalst:=nonlocalst.defowner.owner;
- isspezproc:=false;
- if assigned(current_procinfo) then
- begin
- if current_procinfo.procdef.is_specialization and
- assigned(current_procinfo.procdef.struct) then
- isspezproc:=true;
- end;
- case symvisibility of
- vis_private :
- begin
- { private symbols are allowed when we are in the same
- module as they are defined }
- result:=(
- (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and
- (nonlocalst.iscurrentunit)
- ) or
- ( // the case of specialize inside the generic declaration and nested types
- (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and
- (
- assigned(current_structdef) and
- (
- (current_structdef=symownerdef) or
- (current_structdef.owner.iscurrentunit)
- )
- ) or
- (
- not assigned(current_structdef) and
- (symownerdef.owner.iscurrentunit)
- ) or
- { access from a generic method that belongs to the class
- but that is specialized elsewere }
- (
- isspezproc and
- (current_procinfo.procdef.struct=current_structdef)
- ) or
- { specializations may access private symbols that their
- generics are allowed to access }
- (
- assigned(current_structdef) and
- (df_specialization in current_structdef.defoptions) and
- (symst.moduleid=current_structdef.genericdef.owner.moduleid)
- )
- );
- end;
- vis_strictprivate :
- begin
- result:=assigned(current_structdef) and
- is_owned_by(current_structdef,symownerdef);
- end;
- vis_strictprotected :
- begin
- result:=(
- { access from nested class }
- assigned(current_structdef) and
- is_owned_by(current_structdef,symownerdef)
- ) or
- (
- { access from child class }
- assigned(contextobjdef) and
- assigned(current_structdef) and
- def_is_related(contextobjdef,symownerdef) and
- def_is_related(current_structdef,contextobjdef)
- ) or
- (
- { helpers can access strict protected symbols }
- is_objectpascal_helper(contextobjdef) and
- def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef)
- ) or
- (
- { same as above, but from context of call node inside
- helper method }
- is_objectpascal_helper(current_structdef) and
- def_is_related(tobjectdef(current_structdef).extendeddef,symownerdef)
- );
- end;
- vis_protected :
- begin
- { protected symbols are visible in the module that defines them and
- also visible to related objects. The related object must be defined
- in the current module }
- result:=(
- (
- (nonlocalst.symtabletype in [globalsymtable,staticsymtable]) and
- (nonlocalst.iscurrentunit)
- ) or
- (
- assigned(contextobjdef) and
- (contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable,recordsymtable]) and
- (contextobjdef.owner.iscurrentunit) and
- def_is_related(contextobjdef,symownerdef)
- ) or
- ( // the case of specialize inside the generic declaration and nested types
- (nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and
- (
- assigned(current_structdef) and
- (
- (current_structdef=symownerdef) or
- (current_structdef.owner.iscurrentunit)
- )
- ) or
- (
- not assigned(current_structdef) and
- (symownerdef.owner.iscurrentunit)
- ) or
- (
- { helpers can access protected symbols }
- is_objectpascal_helper(contextobjdef) and
- def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef)
- )
- ) or
- { access from a generic method that belongs to the class
- but that is specialized elsewere }
- (
- isspezproc and
- (current_procinfo.procdef.struct=current_structdef)
- ) or
- { specializations may access private symbols that their
- generics are allowed to access }
- (
- assigned(current_structdef) and
- (df_specialization in current_structdef.defoptions) and
- (symst.moduleid=current_structdef.genericdef.owner.moduleid)
- )
- );
- end;
- vis_public,
- vis_published :
- result:=true;
- end;
- end;
- function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
- begin
- result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef);
- end;
- function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
- var
- i : longint;
- pd : tprocdef;
- begin
- if sym.typ=procsym then
- begin
- { A procsym is visible, when there is at least one of the procdefs visible }
- result:=false;
- for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
- begin
- pd:=tprocdef(tprocsym(sym).ProcdefList[i]);
- if (pd.owner=sym.owner) and
- is_visible_for_object(pd,contextobjdef) then
- begin
- result:=true;
- exit;
- end;
- end;
- end
- else
- result:=is_visible_for_object(sym.owner,sym.visibility,contextobjdef);
- end;
- function searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- begin
- result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[],sp_none);
- end;
- function searchsym_with_flags(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- begin
- result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,flags,sp_none);
- end;
- function searchsym_maybe_with_symoption(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags;option:tsymoption):boolean;
- var
- hashedid: THashedIDString;
- contextstructdef: tabstractrecorddef;
- stackitem: psymtablestackitem;
- begin
- result:=false;
- hashedid.id:=s;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- srsymtable:=stackitem^.symtable;
- if (srsymtable.symtabletype=objectsymtable) then
- begin
- { TODO : implement the search for an option in classes as well }
- if ssf_search_option in flags then
- begin
- result:=false;
- exit;
- end;
- if searchsym_in_class(tobjectdef(srsymtable.defowner),tobjectdef(srsymtable.defowner),s,srsym,srsymtable,flags+[ssf_search_helper]) then
- begin
- result:=true;
- exit;
- end;
- end
- else if not((srsymtable.symtabletype=withsymtable) and assigned(srsymtable.defowner) and
- (srsymtable.defowner.typ=undefineddef)) then
- begin
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- { First check if it is a unit/namespace symbol.
- They are visible only if they are from the current unit or
- unit of generic of currently processed specialization. }
- if assigned(srsym) and
- (
- not(srsym.typ in [unitsym,namespacesym]) or
- srsymtable.iscurrentunit or
- (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid)) or
- (
- assigned(current_procinfo) and
- (df_specialization in current_procinfo.procdef.defoptions) and
- (current_procinfo.procdef.genericdef.owner.moduleid=srsymtable.moduleid)
- )
- ) and
- (not (ssf_search_option in flags) or (option in srsym.symoptions))then
- begin
- { use the class from withsymtable only when it is
- defined in this unit }
- if (srsymtable.symtabletype=withsymtable) and
- assigned(srsymtable.defowner) and
- (srsymtable.defowner.typ in [recorddef,objectdef]) and
- (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) and
- (srsymtable.defowner.owner.iscurrentunit) then
- contextstructdef:=tabstractrecorddef(srsymtable.defowner)
- else
- contextstructdef:=current_structdef;
- if not(srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
- is_visible_for_object(srsym,contextstructdef) then
- begin
- { we need to know if a procedure references symbols
- in the static symtable, because then it can't be
- inlined from outside this unit }
- if assigned(current_procinfo) and
- (srsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_with_symoption(const s: TIDString;out srsym:tsym;out
- srsymtable:TSymtable;option:tsymoption):boolean;
- begin
- result:=searchsym_maybe_with_symoption(s,srsym,srsymtable,[ssf_search_option],option);
- end;
- function searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- var
- hashedid : THashedIDString;
- stackitem : psymtablestackitem;
- classh : tobjectdef;
- begin
- result:=false;
- hashedid.id:=s;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- {
- It is not possible to have type symbols in:
- parameters
- Exception are classes, objects, records, generic definitions and specializations
- that have the parameterized types inserted in the symtable.
- }
- srsymtable:=stackitem^.symtable;
- if (srsymtable.symtabletype=ObjectSymtable) then
- begin
- classh:=tobjectdef(srsymtable.defowner);
- while assigned(classh) do
- begin
- srsymtable:=classh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
- is_visible_for_object(srsym,current_structdef) then
- begin
- addsymref(srsym);
- result:=true;
- exit;
- end;
- classh:=classh.childof;
- end;
- end
- else
- begin
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- (
- not(srsym.typ in [unitsym,namespacesym]) or
- srsymtable.iscurrentunit or
- (assigned(current_specializedef)and(current_specializedef.genericdef.owner.moduleid=srsymtable.moduleid))
- ) and
- not(srsym.typ in [fieldvarsym,paravarsym,propertysym,procsym,labelsym]) and
- (not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or is_visible_for_object(srsym,current_structdef)) then
- begin
- { we need to know if a procedure references symbols
- in the static symtable, because then it can't be
- inlined from outside this unit }
- if assigned(current_procinfo) and
- (srsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- result:=false;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- var
- pmod : tmodule;
- begin
- pmod:=tmodule(pm);
- result:=false;
- if assigned(pmod.globalsymtable) then
- begin
- srsym:=tsym(pmod.globalsymtable.Find(s));
- if assigned(srsym) then
- begin
- srsymtable:=pmod.globalsymtable;
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- { If the module is the current unit we also need
- to search the local symtable }
- if (pmod=current_module) and
- assigned(pmod.localsymtable) then
- begin
- srsym:=tsym(pmod.localsymtable.Find(s));
- if assigned(srsym) then
- begin
- srsymtable:=pmod.localsymtable;
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
- var
- stackitem : psymtablestackitem;
- begin
- result:=false;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- srsymtable:=stackitem^.symtable;
- if (srsymtable.symtabletype=globalsymtable) and
- (srsymtable.name^=unitname) then
- begin
- srsym:=tsym(srsymtable.find(symname));
- if not assigned(srsym) then
- break;
- result:=true;
- exit;
- end;
- stackitem:=stackitem^.next;
- end;
- { If the module is the current unit we also need
- to search the local symtable }
- if assigned(current_module.localsymtable) and
- (current_module.localsymtable.name^=unitname) then
- begin
- srsymtable:=current_module.localsymtable;
- srsym:=tsym(srsymtable.find(symname));
- if assigned(srsym) then
- begin
- result:=true;
- exit;
- end;
- end;
- end;
- function maybe_find_real_class_definition(pd: tdef; erroronfailure: boolean): tdef;
- begin
- result:=pd;
- if pd.typ<>objectdef then
- exit;
- result:=find_real_class_definition(tobjectdef(pd),erroronfailure);
- end;
- function find_real_class_definition(pd: tobjectdef; erroronfailure: boolean): tobjectdef;
- var
- hashedid : THashedIDString;
- stackitem : psymtablestackitem;
- srsymtable : tsymtable;
- srsym : tsym;
- formalname,
- foundname : shortstring;
- formalnameptr,
- foundnameptr: pshortstring;
- begin
- { not a formal definition -> return it }
- if not(oo_is_formal in pd.objectoptions) then
- begin
- result:=pd;
- exit;
- end;
- hashedid.id:=pd.typesym.name;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- srsymtable:=stackitem^.symtable;
- { ObjC classes can't appear in generics or as nested class
- definitions. Java classes can. }
- if not(srsymtable.symtabletype in [recordsymtable,parasymtable]) or
- (is_java_class_or_interface(pd) and
- (srsymtable.symtabletype=ObjectSymtable)) then
- begin
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- (srsym.typ=typesym) and
- (ttypesym(srsym).typedef.typ=objectdef) and
- (tobjectdef(ttypesym(srsym).typedef).objecttype=pd.objecttype) and
- not(oo_is_formal in tobjectdef(ttypesym(srsym).typedef).objectoptions) then
- begin
- if not(oo_is_forward in tobjectdef(ttypesym(srsym).typedef).objectoptions) then
- begin
- { the external name for the formal and the real
- definition must match }
- if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) or
- assigned(pd.import_lib) then
- begin
- if assigned(pd.import_lib) then
- formalname:=pd.import_lib^+'.'
- else
- formalname:='';
- formalname:=formalname+pd.objextname^;
- if assigned(tobjectdef(ttypesym(srsym).typedef).import_lib) then
- foundname:=tobjectdef(ttypesym(srsym).typedef).import_lib^+'.'
- else
- foundname:='';
- foundname:=foundname+tobjectdef(ttypesym(srsym).typedef).objextname^;
- formalnameptr:=@formalname;
- foundnameptr:=@foundname;
- end
- else
- begin
- formalnameptr:=pd.objextname;
- foundnameptr:=tobjectdef(ttypesym(srsym).typedef).objextname;
- end;
- if foundnameptr^<>formalnameptr^ then
- begin
- MessagePos2(pd.typesym.fileinfo,sym_e_external_class_name_mismatch1,formalnameptr^,pd.typename);
- MessagePos1(srsym.fileinfo,sym_e_external_class_name_mismatch2,foundnameptr^);
- end;
- end;
- result:=tobjectdef(ttypesym(srsym).typedef);
- if assigned(current_procinfo) and
- (srsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- addsymref(srsym);
- exit;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- { nothing found: optionally give an error and return the original
- (empty) one }
- if erroronfailure then
- Message1(sym_e_formal_class_not_resolved,pd.objrealname^);
- result:=pd;
- end;
- function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- var
- hashedid : THashedIDString;
- orgclass : tobjectdef;
- i : longint;
- begin
- orgclass:=classh;
- { in case this is a formal class, first find the real definition }
- if assigned(classh) then
- begin
- if (oo_is_formal in classh.objectoptions) then
- classh:=find_real_class_definition(classh,true);
- { The contextclassh is used for visibility. The classh must be equal to
- or be a parent of contextclassh. E.g. for inherited searches the classh is the
- parent or a class helper. }
- if not (def_is_related(contextclassh,classh) or
- (is_classhelper(contextclassh) and
- assigned(tobjectdef(contextclassh).extendeddef) and
- (tobjectdef(contextclassh).extendeddef.typ=objectdef) and
- def_is_related(tobjectdef(contextclassh).extendeddef,classh))) then
- internalerror(200811161);
- end;
- result:=false;
- hashedid.id:=s;
- { an Objective-C protocol or Java interface can inherit from multiple
- other protocols/interfaces -> use ImplementedInterfaces instead }
- if is_objcprotocol(classh) or
- is_javainterface(classh) then
- begin
- srsymtable:=classh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- is_visible_for_object(srsym,contextclassh) then
- begin
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- for i:=0 to classh.ImplementedInterfaces.count-1 do
- begin
- if searchsym_in_class(TImplementedInterface(classh.ImplementedInterfaces[i]).intfdef,contextclassh,s,srsym,srsymtable,flags-[ssf_search_helper]) then
- begin
- result:=true;
- exit;
- end;
- end;
- end
- else
- if is_objectpascal_helper(classh) then
- begin
- { helpers have their own obscure search logic... }
- result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,flags-[ssf_has_inherited]);
- if result then
- exit;
- end
- else
- begin
- while assigned(classh) do
- begin
- { search for a class helper method first if this is an Object
- Pascal class and we haven't yet found a helper symbol }
- if (classh.objecttype in objecttypes_with_helpers) and
- (ssf_search_helper in flags) then
- begin
- result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable);
- { an eventual overload inside the extended type's hierarchy
- will be found by tcallcandidates }
- if result then
- exit;
- end;
- srsymtable:=classh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- is_visible_for_object(srsym,contextclassh) then
- begin
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- classh:=classh.childof;
- end;
- end;
- if is_objcclass(orgclass) then
- result:=search_objc_helper(orgclass,s,srsym,srsymtable)
- else
- begin
- srsym:=nil;
- srsymtable:=nil;
- end;
- end;
- function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
- var
- hashedid : THashedIDString;
- begin
- result:=false;
- hashedid.id:=s;
- { search for a record helper method first }
- result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable);
- if result then
- { an eventual overload inside the extended type's hierarchy
- will be found by tcallcandidates }
- exit;
- srsymtable:=recordh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and is_visible_for_object(srsym,recordh) then
- begin
- addsymref(srsym);
- result:=true;
- exit;
- end;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
- var
- def : tdef;
- i : longint;
- begin
- { in case this is a formal class, first find the real definition }
- if assigned(classh) and
- (oo_is_formal in classh.objectoptions) then
- classh:=find_real_class_definition(classh,true);
- result:=false;
- def:=nil;
- while assigned(classh) do
- begin
- for i:=0 to classh.symtable.DefList.Count-1 do
- begin
- def:=tstoreddef(classh.symtable.DefList[i]);
- { Find also all hidden private methods to
- be compatible with delphi, see tw6203 (PFV) }
- if (def.typ=procdef) and
- (po_msgint in tprocdef(def).procoptions) and
- (tprocdef(def).messageinf.i=msgid) then
- begin
- srdef:=def;
- srsym:=tprocdef(def).procsym;
- srsymtable:=classh.symtable;
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- classh:=classh.childof;
- end;
- srdef:=nil;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
- var
- def : tdef;
- i : longint;
- begin
- { in case this is a formal class, first find the real definition }
- if assigned(classh) and
- (oo_is_formal in classh.objectoptions) then
- classh:=find_real_class_definition(classh,true);
- result:=false;
- def:=nil;
- while assigned(classh) do
- begin
- for i:=0 to classh.symtable.DefList.Count-1 do
- begin
- def:=tstoreddef(classh.symtable.DefList[i]);
- { Find also all hidden private methods to
- be compatible with delphi, see tw6203 (PFV) }
- if (def.typ=procdef) and
- (po_msgstr in tprocdef(def).procoptions) and
- (tprocdef(def).messageinf.str^=s) then
- begin
- srsym:=tprocdef(def).procsym;
- srsymtable:=classh.symtable;
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- classh:=classh.childof;
- end;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function searchsym_in_helper(classh,contextclassh:tobjectdef;const s: TIDString;out srsym:tsym;out srsymtable:TSymtable;flags:tsymbol_search_flags):boolean;
- var
- hashedid : THashedIDString;
- parentclassh : tobjectdef;
- begin
- result:=false;
- if not is_objectpascal_helper(classh) then
- Internalerror(2011030101);
- hashedid.id:=s;
- { in a helper things are a bit more complex:
- 1. search the symbol in the helper (if not "inherited")
- 2. search the symbol in the extended type
- 3. search the symbol in the parent helpers
- 4. only classes: search the symbol in the parents of the extended type
- }
- if not (ssf_has_inherited in flags) then
- begin
- { search in the helper itself }
- srsymtable:=classh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- is_visible_for_object(srsym,contextclassh) then
- begin
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- { now search in the extended type itself }
- { Note: the extendeddef might be Nil if we are currently parsing the
- extended type itself and the identifier was not found }
- if assigned(classh.extendeddef) and (classh.extendeddef.typ in [recorddef,objectdef]) then
- begin
- srsymtable:=tabstractrecorddef(classh.extendeddef).symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- is_visible_for_object(srsym,contextclassh) then
- begin
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- { now search in the parent helpers }
- parentclassh:=classh.childof;
- while assigned(parentclassh) do
- begin
- srsymtable:=parentclassh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) and
- is_visible_for_object(srsym,contextclassh) then
- begin
- if not (ssf_no_addsymref in flags) then
- addsymref(srsym);
- result:=true;
- exit;
- end;
- parentclassh:=parentclassh.childof;
- end;
- if is_class(classh.extendeddef) then
- { now search in the parents of the extended class (with helpers!) }
- result:=searchsym_in_class(tobjectdef(classh.extendeddef).childof,contextclassh,s,srsym,srsymtable,flags+[ssf_search_helper]);
- { addsymref is already called by searchsym_in_class }
- end;
- function search_specific_assignment_operator(assignment_type:ttoken;from_def,to_def:Tdef):Tprocdef;
- var
- sym : Tprocsym;
- hashedid : THashedIDString;
- curreq,
- besteq : tequaltype;
- currpd,
- bestpd : tprocdef;
- stackitem : psymtablestackitem;
- begin
- hashedid.id:=overloaded_names[assignment_type];
- besteq:=te_incompatible;
- bestpd:=nil;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
- if sym<>nil then
- begin
- if sym.typ<>procsym then
- internalerror(200402031);
- { if the source type is an alias then this is only the second choice,
- if you mess with this code, check tw4093 }
- currpd:=sym.find_procdef_assignment_operator(from_def,to_def,curreq);
- if curreq>besteq then
- begin
- besteq:=curreq;
- bestpd:=currpd;
- if (besteq=te_exact) then
- break;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- result:=bestpd;
- end;
- function search_assignment_operator(from_def,to_def:Tdef;explicit:boolean):Tprocdef;
- begin
- { search record/object symtable first for a suitable operator }
- if from_def.typ in [recorddef,objectdef] then
- symtablestack.push(tabstractrecorddef(from_def).symtable);
- if to_def.typ in [recorddef,objectdef] then
- symtablestack.push(tabstractrecorddef(to_def).symtable);
- { if type conversion is explicit then search first for explicit
- operator overload and if not found then use implicit operator }
- if explicit then
- result:=search_specific_assignment_operator(_OP_EXPLICIT,from_def,to_def)
- else
- result:=nil;
- if result=nil then
- result:=search_specific_assignment_operator(_ASSIGNMENT,from_def,to_def);
- { restore symtable stack }
- if to_def.typ in [recorddef,objectdef] then
- symtablestack.pop(tabstractrecorddef(to_def).symtable);
- if from_def.typ in [recorddef,objectdef] then
- symtablestack.pop(tabstractrecorddef(from_def).symtable);
- end;
- function search_enumerator_operator(from_def,to_def:Tdef): Tprocdef;
- var
- sym : Tprocsym;
- hashedid : THashedIDString;
- curreq,
- besteq : tequaltype;
- currpd,
- bestpd : tprocdef;
- stackitem : psymtablestackitem;
- begin
- hashedid.id:='enumerator';
- besteq:=te_incompatible;
- bestpd:=nil;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- sym:=Tprocsym(stackitem^.symtable.FindWithHash(hashedid));
- if sym<>nil then
- begin
- if sym.typ<>procsym then
- internalerror(200910241);
- { if the source type is an alias then this is only the second choice,
- if you mess with this code, check tw4093 }
- currpd:=sym.find_procdef_enumerator_operator(from_def,to_def,curreq);
- if curreq>besteq then
- begin
- besteq:=curreq;
- bestpd:=currpd;
- if (besteq=te_exact) then
- break;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- result:=bestpd;
- end;
- function search_management_operator(mop:tmanagementoperator;pd:Tdef):Tprocdef;
- var
- sym : Tprocsym;
- hashedid : THashedIDString;
- optoken: ttoken;
- begin
- optoken := managementoperator2tok[mop];
- if (optoken<first_managment_operator) or
- (optoken>last_managment_operator) then
- internalerror(201602280);
- hashedid.id:=overloaded_names[optoken];
- if not (pd.typ in [recorddef]) then
- internalerror(201602281);
- sym:=Tprocsym(tabstractrecorddef(pd).symtable.FindWithHash(hashedid));
- if sym<>nil then
- begin
- if sym.typ<>procsym then
- internalerror(201602282);
- result:=sym.find_procdef_bytype(potype_operator);
- end
- else
- result:=nil;
- end;
- function search_system_type(const s: TIDString): ttypesym;
- var
- sym : tsym;
- begin
- sym:=tsym(systemunit.Find(s));
- if not assigned(sym) or
- (sym.typ<>typesym) then
- message1(cg_f_unknown_system_type,s);
- result:=ttypesym(sym);
- end;
- function try_search_system_type(const s: TIDString): ttypesym;
- var
- sym : tsym;
- begin
- sym:=tsym(systemunit.Find(s));
- if not assigned(sym) then
- result:=nil
- else
- begin
- if sym.typ<>typesym then
- message1(cg_f_unknown_system_type,s);
- result:=ttypesym(sym);
- end;
- end;
- function try_search_current_module_type(const s: TIDString): ttypesym;
- var
- found: boolean;
- srsymtable: tsymtable;
- srsym: tsym;
- begin
- if s[1]='$' then
- found:=searchsym_in_module(current_module,copy(s,2,length(s)),srsym,srsymtable)
- else
- found:=searchsym_in_module(current_module,s,srsym,srsymtable);
- if found then
- begin
- if (srsym.typ<>typesym) then
- internalerror(2014091207);
- result:=ttypesym(srsym);
- end
- else
- result:=nil;
- end;
- function search_system_proc(const s: TIDString): tprocdef;
- var
- srsym: tsym;
- begin
- srsym:=tsym(systemunit.find(s));
- if not assigned(srsym) and
- (cs_compilesystem in current_settings.moduleswitches) then
- srsym:=tsym(systemunit.Find(upper(s)));
- if not assigned(srsym) or
- (srsym.typ<>procsym) then
- message1(cg_f_unknown_compilerproc,s);
- result:=tprocdef(tprocsym(srsym).procdeflist[0]);
- end;
- function search_named_unit_globaltype(const unitname, typename: TIDString; throwerror: boolean): ttypesym;
- var
- srsymtable: tsymtable;
- sym: tsym;
- begin
- sym:=nil;
- if searchsym_in_named_module(unitname,typename,sym,srsymtable) and
- (sym.typ=typesym) then
- begin
- result:=ttypesym(sym);
- exit;
- end
- else
- begin
- if throwerror then
- message2(cg_f_unknown_type_in_unit,typename,unitname);
- result:=nil;
- end;
- end;
- function search_last_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;out odef : tobjectdef):boolean;
- var
- s: string;
- list: TFPObjectList;
- i: integer;
- st: tsymtable;
- begin
- result:=false;
- odef:=nil;
- { when there are no helpers active currently then we don't need to do
- anything }
- if current_module.extendeddefs.count=0 then
- exit;
- if (df_genconstraint in pd.defoptions) then
- begin
- { if we have a constraint for a class type or a single interface we
- use that to resolve helpers at declaration time of the generic,
- otherwise there can't be any helpers as the type isn't known yet }
- if pd.typ=objectdef then
- pd:=tobjectdef(pd).getparentdef
- else
- exit;
- end;
- { no helpers for anonymous types }
- if ((pd.typ in [recorddef,objectdef]) and
- (
- not assigned(tabstractrecorddef(pd).objrealname) or
- (tabstractrecorddef(pd).objrealname^='')
- )
- ) or
- not assigned(pd.typesym) then
- exit;
- { if pd is defined inside a procedure we must not use make_mangledname
- (as a helper may not be defined in a procedure this is no problem...)}
- st:=pd.owner;
- while st.symtabletype in [objectsymtable,recordsymtable] do
- st:=st.defowner.owner;
- if st.symtabletype=localsymtable then
- exit;
- { the mangled name is used as the key for tmodule.extendeddefs }
- s:=generate_objectpascal_helper_key(pd);
- list:=TFPObjectList(current_module.extendeddefs.Find(s));
- if assigned(list) and (list.count>0) then
- begin
- i:=list.count-1;
- repeat
- odef:=tobjectdef(list[list.count-1]);
- result:=(odef.owner.symtabletype in [staticsymtable,globalsymtable]) or
- is_visible_for_object(tobjectdef(list[i]).typesym,contextclassh);
- dec(i);
- until result or (i<0);
- if not result then
- { just to be sure that noone uses odef }
- odef:=nil;
- end;
- end;
- function search_objectpascal_helper(pd : tdef;contextclassh : tabstractrecorddef;const s: string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- var
- hashedid : THashedIDString;
- classh : tobjectdef;
- i : integer;
- pdef : tprocdef;
- begin
- result:=false;
- { if there is no class helper for the class then there is no need to
- search further }
- if not search_last_objectpascal_helper(pd,contextclassh,classh) then
- exit;
- hashedid.id:=s;
- repeat
- srsymtable:=classh.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if srsym<>nil then
- begin
- case srsym.typ of
- procsym:
- begin
- for i:=0 to tprocsym(srsym).procdeflist.count-1 do
- begin
- pdef:=tprocdef(tprocsym(srsym).procdeflist[i]);
- if not is_visible_for_object(pdef.owner,pdef.visibility,contextclassh) then
- continue;
- { we need to know if a procedure references symbols
- in the static symtable, because then it can't be
- inlined from outside this unit }
- if assigned(current_procinfo) and
- (srsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- { the first found method wins }
- srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
- srsymtable:=srsym.owner;
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- typesym,
- fieldvarsym,
- constsym,
- enumsym,
- undefinedsym,
- propertysym:
- begin
- addsymref(srsym);
- result:=true;
- exit;
- end;
- else
- internalerror(2014041101);
- end;
- end;
- { try the helper parent if available }
- classh:=classh.childof;
- until classh=nil;
- srsym:=nil;
- srsymtable:=nil;
- end;
- function search_objc_helper(pd : tobjectdef;const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- var
- searchst : tsymtable;
- searchsym : tsym;
- hashedid : THashedIDString;
- stackitem : psymtablestackitem;
- i : longint;
- founddefowner,
- defowner : tobjectdef;
- begin
- hashedid.id:=class_helper_prefix+s;
- stackitem:=symtablestack.stack;
- result:=false;
- srsym:=nil;
- srsymtable:=nil;
- founddefowner:=nil;
- while assigned(stackitem) do
- begin
- searchst:=stackitem^.symtable;
- searchsym:=tsym(searchst.FindWithHash(hashedid));
- if assigned(searchsym) then
- begin
- if not(searchst.symtabletype in [globalsymtable,staticsymtable]) or
- not(searchsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
- (searchsym.typ<>procsym) then
- internalerror(2009111505);
- { check whether this procsym includes a helper for this particular class }
- for i:=0 to tprocsym(searchsym).procdeflist.count-1 do
- begin
- { does pd inherit from (or is the same as) the class
- that this method's category extended?
- Warning: this list contains both category and objcclass methods
- (for id.randommethod), so only check category methods here
- }
- defowner:=tobjectdef(tprocdef(tprocsym(searchsym).procdeflist[i]).owner.defowner);
- if is_objccategory(defowner) and
- def_is_related(pd,defowner.childof) then
- begin
- { we need to know if a procedure references symbols
- in the static symtable, because then it can't be
- inlined from outside this unit }
- if assigned(current_procinfo) and
- (searchsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- { Stop looking if this is a category that extends the specified
- class itself. There might be other categories that extend this,
- but that doesn't matter. If it extens a parent, keep looking
- in case we find the symbol in a category that extends this class
- (or a closer parent).
- }
- if not result or
- def_is_related(defowner.childof,founddefowner) then
- begin
- founddefowner:=defowner.childof;
- srsym:=tprocdef(tprocsym(searchsym).procdeflist[i]).procsym;
- srsymtable:=srsym.owner;
- result:=true;
- if pd=founddefowner then
- begin
- addsymref(srsym);
- exit;
- end;
- end;
- end;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- if result then
- begin
- addsymref(srsym);
- exit;
- end;
- end;
- function search_objc_method(const s : string; out srsym: tsym; out srsymtable: tsymtable):boolean;
- var
- hashedid : THashedIDString;
- stackitem : psymtablestackitem;
- i : longint;
- begin
- hashedid.id:=class_helper_prefix+s;
- stackitem:=symtablestack.stack;
- while assigned(stackitem) do
- begin
- srsymtable:=stackitem^.symtable;
- srsym:=tsym(srsymtable.FindWithHash(hashedid));
- if assigned(srsym) then
- begin
- if not(srsymtable.symtabletype in [globalsymtable,staticsymtable]) or
- not(srsym.owner.symtabletype in [globalsymtable,staticsymtable]) or
- (srsym.typ<>procsym) then
- internalerror(2009112005);
- { check whether this procsym includes a helper for this particular class }
- for i:=0 to tprocsym(srsym).procdeflist.count-1 do
- begin
- { we need to know if a procedure references symbols
- in the static symtable, because then it can't be
- inlined from outside this unit }
- if assigned(current_procinfo) and
- (srsym.owner.symtabletype=staticsymtable) then
- include(current_procinfo.flags,pi_uses_static_symtable);
- { no need to keep looking. There might be other
- methods with the same name, but that doesn't matter
- as far as the basic procsym is concerned.
- }
- srsym:=tprocdef(tprocsym(srsym).procdeflist[i]).procsym;
- { We need the symtable in which the classhelper-like sym
- is located, not the objectdef. The reason is that the
- callnode will climb the symtablestack until it encounters
- this symtable to start looking for overloads (and it won't
- find the objectsymtable in which this method sym is
- located
- srsymtable:=srsym.owner;
- }
- addsymref(srsym);
- result:=true;
- exit;
- end;
- end;
- stackitem:=stackitem^.next;
- end;
- srsym:=nil;
- srsymtable:=nil;
- result:=false;
- end;
- function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
- { searches n in symtable of pd and all anchestors }
- var
- srsymtable : tsymtable;
- begin
- { in case this is a formal class, first find the real definition }
- if (oo_is_formal in pd.objectoptions) then
- pd:=find_real_class_definition(tobjectdef(pd),true);
- if search_objectpascal_helper(pd, pd, s, result, srsymtable) then
- exit;
- result:=search_struct_member_no_helper(pd,s);
- if assigned(result) then
- exit;
- { not found, now look for class helpers }
- if is_objcclass(pd) then
- search_objc_helper(tobjectdef(pd),s,result,srsymtable)
- end;
- function search_struct_member_no_helper(pd: tabstractrecorddef; const s: string): tsym;
- var
- hashedid : THashedIDString;
- srsym : tsym;
- begin
- hashedid.id:=s;
- while assigned(pd) do
- begin
- srsym:=tsym(pd.symtable.FindWithHash(hashedid));
- if assigned(srsym) then
- begin
- result:=srsym;
- exit;
- end;
- if pd.typ=objectdef then
- pd:=tobjectdef(pd).childof
- else
- pd:=nil;
- end;
- result:=nil;
- end;
- function search_macro(const s : string):tsym;
- var
- stackitem : psymtablestackitem;
- hashedid : THashedIDString;
- srsym : tsym;
- begin
- hashedid.id:=s;
- { First search the localmacrosymtable before searching the
- global macrosymtables from the units }
- if assigned(current_module) then
- begin
- srsym:=tsym(current_module.localmacrosymtable.FindWithHash(hashedid));
- if assigned(srsym) then
- begin
- result:= srsym;
- exit;
- end;
- end;
- stackitem:=macrosymtablestack.stack;
- while assigned(stackitem) do
- begin
- srsym:=tsym(stackitem^.symtable.FindWithHash(hashedid));
- if assigned(srsym) then
- begin
- result:= srsym;
- exit;
- end;
- stackitem:=stackitem^.next;
- end;
- result:= nil;
- end;
- function defined_macro(const s : string):boolean;
- var
- mac: tmacro;
- begin
- mac:=tmacro(search_macro(s));
- if assigned(mac) then
- begin
- mac.is_used:=true;
- defined_macro:=mac.defined;
- end
- else
- defined_macro:=false;
- end;
- {****************************************************************************
- Object Helpers
- ****************************************************************************}
- function search_default_property(pd : tabstractrecorddef) : tpropertysym;
- { returns the default property of a class, searches also anchestors }
- var
- _defaultprop : tpropertysym;
- helperpd : tobjectdef;
- begin
- _defaultprop:=nil;
- { first search in helper's hierarchy }
- if search_last_objectpascal_helper(pd,nil,helperpd) then
- while assigned(helperpd) do
- begin
- helperpd.symtable.SymList.ForEachCall(@tstoredsymtable(helperpd.symtable).testfordefaultproperty,@_defaultprop);
- if assigned(_defaultprop) then
- break;
- helperpd:=helperpd.childof;
- end;
- if assigned(_defaultprop) then
- begin
- search_default_property:=_defaultprop;
- exit;
- end;
- { now search in the type's hierarchy itself }
- while assigned(pd) do
- begin
- pd.symtable.SymList.ForEachCall(@tstoredsymtable(pd.symtable).testfordefaultproperty,@_defaultprop);
- if assigned(_defaultprop) then
- break;
- if (pd.typ=objectdef) then
- pd:=tobjectdef(pd).childof
- else
- break;
- end;
- search_default_property:=_defaultprop;
- end;
- {****************************************************************************
- Macro Helpers
- ****************************************************************************}
- procedure def_system_macro(const name : string);
- var
- mac : tmacro;
- s: string;
- begin
- if name = '' then
- internalerror(2004121202);
- s:= upper(name);
- mac:=tmacro(search_macro(s));
- if not assigned(mac) then
- begin
- mac:=tmacro.create(s);
- if assigned(current_module) then
- current_module.localmacrosymtable.insert(mac)
- else
- initialmacrosymtable.insert(mac);
- end;
- Message1(parser_c_macro_defined,mac.name);
- mac.defined:=true;
- end;
- procedure set_system_macro(const name, value : string);
- var
- mac : tmacro;
- s: string;
- begin
- if name = '' then
- internalerror(2004121203);
- s:= upper(name);
- mac:=tmacro(search_macro(s));
- if not assigned(mac) then
- begin
- mac:=tmacro.create(s);
- if assigned(current_module) then
- current_module.localmacrosymtable.insert(mac)
- else
- initialmacrosymtable.insert(mac);
- end
- else
- begin
- mac.is_compiler_var:=false;
- if assigned(mac.buftext) then
- freemem(mac.buftext,mac.buflen);
- end;
- Message2(parser_c_macro_set_to,mac.name,value);
- mac.buflen:=length(value);
- getmem(mac.buftext,mac.buflen);
- move(value[1],mac.buftext^,mac.buflen);
- mac.defined:=true;
- end;
- procedure set_system_compvar(const name, value : string);
- var
- mac : tmacro;
- s: string;
- begin
- if name = '' then
- internalerror(2004121204);
- s:= upper(name);
- mac:=tmacro(search_macro(s));
- if not assigned(mac) then
- begin
- mac:=tmacro.create(s);
- mac.is_compiler_var:=true;
- if assigned(current_module) then
- current_module.localmacrosymtable.insert(mac)
- else
- initialmacrosymtable.insert(mac);
- end
- else
- begin
- mac.is_compiler_var:=true;
- if assigned(mac.buftext) then
- freemem(mac.buftext,mac.buflen);
- end;
- Message2(parser_c_macro_set_to,mac.name,value);
- mac.buflen:=length(value);
- getmem(mac.buftext,mac.buflen);
- move(value[1],mac.buftext^,mac.buflen);
- mac.defined:=true;
- end;
- procedure undef_system_macro(const name : string);
- var
- mac : tmacro;
- s: string;
- begin
- if name = '' then
- internalerror(2004121205);
- s:= upper(name);
- mac:=tmacro(search_macro(s));
- if not assigned(mac) then
- {If not found, then it's already undefined.}
- else
- begin
- Message1(parser_c_macro_undefined,mac.name);
- mac.defined:=false;
- mac.is_compiler_var:=false;
- { delete old definition }
- if assigned(mac.buftext) then
- begin
- freemem(mac.buftext,mac.buflen);
- mac.buftext:=nil;
- end;
- end;
- end;
- {$ifdef UNITALIASES}
- {****************************************************************************
- TUNIT_ALIAS
- ****************************************************************************}
- constructor tunit_alias.create(const n:string);
- var
- i : longint;
- begin
- i:=pos('=',n);
- if i=0 then
- fail;
- inherited createname(Copy(n,1,i-1));
- newname:=stringdup(Copy(n,i+1,255));
- end;
- destructor tunit_alias.destroy;
- begin
- stringdispose(newname);
- inherited destroy;
- end;
- procedure addunitalias(const n:string);
- begin
- unitaliases^.insert(tunit_alias,init(Upper(n))));
- end;
- function getunitalias(const n:string):string;
- var
- p : punit_alias;
- begin
- p:=punit_alias(unitaliases^.Find(Upper(n)));
- if assigned(p) then
- getunitalias:=punit_alias(p).newname^
- else
- getunitalias:=n;
- end;
- {$endif UNITALIASES}
- {****************************************************************************
- Init/Done Symtable
- ****************************************************************************}
- procedure InitSymtable;
- begin
- { Reset symbolstack }
- symtablestack:=nil;
- systemunit:=nil;
- { create error syms and def }
- generrorsym:=terrorsym.create;
- generrordef:=cerrordef.create;
- { macros }
- initialmacrosymtable:=tmacrosymtable.create(false);
- macrosymtablestack:=TSymtablestack.create;
- macrosymtablestack.push(initialmacrosymtable);
- {$ifdef UNITALIASES}
- { unit aliases }
- unitaliases:=TFPHashObjectList.create;
- {$endif}
- { set some global vars to nil, might be important for the ide }
- class_tobject:=nil;
- interface_iunknown:=nil;
- interface_idispatch:=nil;
- rec_tguid:=nil;
- rec_jmp_buf:=nil;
- rec_exceptaddr:=nil;
- objc_metaclasstype:=nil;
- objc_superclasstype:=nil;
- objc_idtype:=nil;
- objc_seltype:=nil;
- objc_objecttype:=nil;
- dupnr:=0;
- end;
- procedure DoneSymtable;
- begin
- generrorsym.owner:=nil;
- generrorsym.free;
- generrordef.owner:=nil;
- generrordef.free;
- initialmacrosymtable.free;
- macrosymtablestack.free;
- {$ifdef UNITALIASES}
- unitaliases.free;
- {$endif}
- end;
- end.
|